Convert entities to alists

1 files changed, 82 insertions, 67 deletions

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+)))