From 8251c85a4a588504d38a2fad05e4b0fe1cdccb9d Mon Sep 17 00:00:00 2001 From: Gene Pasquet Date: Fri, 17 Apr 2026 16:30:34 +0100 Subject: Convert entities to alists --- prefabs.scm | 149 +++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 82 insertions(+), 67 deletions(-) (limited to 'prefabs.scm') diff --git a/prefabs.scm b/prefabs.scm index 24a9ee3..56e9ad1 100644 --- a/prefabs.scm +++ b/prefabs.scm @@ -1,10 +1,9 @@ (module downstroke-prefabs * (import scheme (chicken base) - (chicken keyword) - (chicken port) - (chicken format) + (only (chicken keyword) keyword?) srfi-1 + (only (list-utils alist) plist->alist) defstruct downstroke-entity) @@ -12,30 +11,30 @@ (defstruct prefab-registry prefabs group-prefabs file engine-mixin-table user-hooks hook-table) -(define (ensure-balanced-plist plist) - (when (> (modulo (length plist) 2) 0) - (error "Given plist has odd number of items - not a valid plist!"))) - -(define (has-keyword? key plist) - (not (eq? (get-keyword key plist (lambda () 'undefined)) 'undefined))) - -(define (plist-merge plist1 . plists) - "Merge two PLIST1 and PLIST2 into a single one, elements of PLIST1 will overwrite those of PLIST2 etc.." - (let ((meta-list (concatenate plists))) - (ensure-balanced-plist plist1) - (ensure-balanced-plist meta-list) - (if (= (length meta-list) 0) - plist1 - (let loop ((key (car meta-list)) - (value (cadr meta-list)) - (rest (if (> (length meta-list) 2) (cddr meta-list) '())) - (acc plist1)) - (let ((new-acc (if (has-keyword? key acc) - acc - (append (list key value) acc)))) - (if (null? rest) - new-acc - (loop (car rest) (cadr rest) (if (> (length rest) 2) (cddr rest) '()) new-acc))))))) +;; Private: internal prefab composition helper. +;; Merge alists left-to-right; earlier occurrences of a key win. +;; Returns a fresh alist. +(define (alist-merge . alists) + (fold (lambda (alist acc) + (fold (lambda (pair acc) + (if (assq (car pair) acc) + acc + (cons pair acc))) + acc + alist)) + '() + alists)) + +;; Keys whose values are lists-of-plists in user data files and must be +;; deep-converted to lists-of-alists after the top-level plist->alist pass. +(define +nested-plist-list-keys+ '(#:animations #:parts)) + +(define (convert-nested-plist-values alist) + (map (lambda (pair) + (if (memq (car pair) +nested-plist-list-keys+) + (cons (car pair) (map plist->alist (cdr pair))) + pair)) + alist)) ;; Return engine's built-in mixin table (define (engine-mixins) @@ -43,8 +42,10 @@ (has-facing #:facing 1) (animated #:anim-name idle #:anim-frame 0 #:anim-tick 0 #:tile-id 0 #:animations #t))) -;; Compose a prefab entry with mixin table -;; Returns (name . merged-plist) +;; Compose a prefab entry with a mixin-table of alists. +;; `entry` is the raw user plist-shaped entry: (name mixin-name ... #:k v #:k v ...) +;; `mixin-table` maps mixin-name → alist (already converted in load-prefabs). +;; Returns (name . merged-alist). (define (compose-prefab entry mixin-table) (let* ((name (car entry)) (rest (cdr entry)) @@ -54,13 +55,14 @@ (loop (cdr lst) (cons (car lst) mixins))))) (mixin-names (car split)) (inline-fields (cdr split)) - (mixin-plists + (inline-alist (plist->alist inline-fields)) + (mixin-alists (map (lambda (mname) (let ((m (assq mname mixin-table))) (if m (cdr m) (error "Unknown mixin" mname)))) mixin-names)) - ;; inline-fields prepended → first-match semantics give them highest priority - (merged (apply plist-merge inline-fields mixin-plists))) + ;; inline-alist first → highest priority (earlier-wins) + (merged (apply alist-merge (cons inline-alist mixin-alists)))) (cons name merged))) (define *engine-hooks* '()) @@ -72,29 +74,34 @@ (cdr entry) (error "Unknown prefab hook" hook-sym)))) -;; Group prefab entry: (name . plist) with #:parts = list of part plists. -;; Part offsets may use #:local-x / #:local-y or #:group-local-x / #:group-local-y. -(define (compose-group-prefab entry) - (cons (car entry) (cdr entry))) - ;; Optional profiles (enabled per group via #:pose-only-origin? / #:static-parts? in data). ;; Pose-only origin: tweened or scripted leader, invisible, does not run physics pipelines. (define +pose-only-group-origin-defaults+ - (list #:solid? #f #:gravity? #f #:skip-render #t - #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y - tile-collisions-x tile-collisions-y on-solid entity-collisions))) + '((#:solid? . #f) + (#:gravity? . #f) + (#:skip-render . #t) + (#:skip-pipelines . (jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid entity-collisions)))) ;; Physics-driving origin: invisible point mass; members follow via sync-groups. (define +physics-group-origin-defaults+ - (list #:solid? #f #:gravity? #t #:skip-render #t - #:vx 0 #:vy 0 #:on-ground? #f)) + '((#:solid? . #f) + (#:gravity? . #t) + (#:skip-render . #t) + (#:vx . 0) + (#:vy . 0) + (#:on-ground? . #f))) ;; Static rigid parts: no integration; world pose comes from the origin each frame. (define +static-group-member-defaults+ - (list #:gravity? #f #:vx 0 #:vy 0 #:on-ground? #f - #:solid? #t #:immovable? #t - #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y - tile-collisions-x tile-collisions-y on-solid))) + '((#:gravity? . #f) + (#:vx . 0) + (#:vy . 0) + (#:on-ground? . #f) + (#:solid? . #t) + (#:immovable? . #t) + (#:skip-pipelines . (jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid)))) (define (part-with-group-locals part) (let* ((p part) @@ -109,14 +116,30 @@ (mixin-section (if (assq 'mixins data) (cdr (assq 'mixins data)) '())) (prefab-section (cdr (assq 'prefabs data))) (group-section (cond ((assq 'group-prefabs data) => cdr) (else '()))) + ;; Convert engine mixin-table bodies (plists) to alists. + (engine-mixin-alist-table + (map (lambda (m) (cons (car m) (plist->alist (cdr m)))) + engine-mixin-table)) ;; user mixins first → user wins on assq lookup (overrides engine mixin by name) - (user-mixin-table (if (null? mixin-section) '() (map (lambda (m) (cons (car m) (cdr m))) mixin-section))) - (merged-mixin-table (append user-mixin-table engine-mixin-table)) + (user-mixin-table + (map (lambda (m) (cons (car m) (plist->alist (cdr m)))) + mixin-section)) + (merged-mixin-table (append user-mixin-table engine-mixin-alist-table)) ;; user-hooks first → user wins on assq lookup (overrides engine hooks by name) (hook-table (append user-hooks *engine-hooks*)) - (prefab-table (map (lambda (entry) (compose-prefab entry merged-mixin-table)) - prefab-section)) - (group-table (map compose-group-prefab group-section))) + (prefab-table + (map (lambda (entry) + (let* ((composed (compose-prefab entry merged-mixin-table)) + (converted (convert-nested-plist-values (cdr composed)))) + (cons (car composed) converted))) + prefab-section)) + (group-table + (map (lambda (entry) + (let* ((name (car entry)) + (alist-fields (plist->alist (cdr entry))) + (converted (convert-nested-plist-values alist-fields))) + (cons name converted))) + group-section))) (make-prefab-registry prefabs: prefab-table group-prefabs: group-table @@ -130,19 +153,8 @@ (prefab-registry-engine-mixin-table registry) (prefab-registry-user-hooks registry))) -(define (plist->alist plist) - (if (> (modulo (length plist) 2) 0) - (error "Invalid plist!") - (let loop ((n1 (car plist)) - (n2 (cadr plist)) - (rest (if (> (length plist) 2) (cddr plist) '()))) - (if (null? rest) - (list (cons n1 n2)) - (cons (cons n1 n2) (loop (car rest) (cadr rest) (cddr rest))))))) - (define (do-instantiate-prefab registry entry x y w h) - (let* ((base (entity-set-many (make-entity x y w h) - (plist->alist (cdr entry)))) + (let* ((base (entity-set-many (make-entity x y w h) (cdr entry))) (hook-val (entity-ref base #:on-instantiate #f)) (handler (cond @@ -163,7 +175,7 @@ (define (instantiate-group-member part ox oy gid type-members static-parts?) (let* ((p0 (part-with-group-locals part)) - (merged (plist-merge p0 (if static-parts? +static-group-member-defaults+ '()))) + (merged (alist-merge p0 (if static-parts? +static-group-member-defaults+ '()))) (lx (entity-ref merged #:group-local-x 0)) (ly (entity-ref merged #:group-local-y 0)) (typ (entity-ref merged #:type type-members)) @@ -192,9 +204,12 @@ (oh (entity-ref spec #:origin-height 0)) (ot (entity-ref spec #:origin-type 'group-origin)) (origin-fields - (append - (list #:type ot #:group-id gid #:group-origin? #t - #:x ox #:y oy #:width ow #:height oh) + (alist-merge + `((#:type . ,ot) + (#:group-id . ,gid) + (#:group-origin? . #t) + (#:x . ,ox) (#:y . ,oy) + (#:width . ,ow) (#:height . ,oh)) (if pose-only? +pose-only-group-origin-defaults+ +physics-group-origin-defaults+))) -- cgit v1.2.3