Fix plist handling, add test for timed animation frames

1 files changed, 206 insertions, 164 deletions

diff --git a/prefabs.scm b/prefabs.scm
index 819a382..24a9ee3 100644
--- a/prefabs.scm
+++ b/prefabs.scm
@@ -1,165 +1,207 @@
 (module downstroke-prefabs *
-  (import scheme
-          (chicken base)
-          (chicken keyword)
-          (chicken port)
-          defstruct
-          downstroke-entity)
-
-  ;; Registry struct to hold prefab data
-  (defstruct prefab-registry
-    prefabs group-prefabs file engine-mixin-table user-hooks hook-table)
-
-  ;; Return engine's built-in mixin table
-  (define (engine-mixins)
-    '((physics-body #:vx 0 #:vy 0 #:ay 0 #:gravity? #t #:solid? #t #:on-ground? #f)
-      (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)
-  (define (compose-prefab entry mixin-table)
-    (let* ((name (car entry))
-           (rest (cdr entry))
-           (split (let loop ((lst rest) (mixins '()))
-                    (if (or (null? lst) (keyword? (car lst)))
-                        (cons (reverse mixins) lst)
-                        (loop (cdr lst) (cons (car lst) mixins)))))
-           (mixin-names  (car split))
-           (inline-fields (cdr split))
-           (mixin-plists
-             (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 append inline-fields mixin-plists)))
-      (cons name merged)))
-
-  (define *engine-hooks* '())
-
-  ;; Lookup a hook symbol in the hook table
-  (define (lookup-hook hook-table hook-sym)
-    (let ((entry (assq hook-sym hook-table)))
-      (if entry
-          (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)))
-
-  ;; 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))
-
-  ;; 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)))
-
-  (define (part-with-group-locals part)
-    (let* ((p part)
-           (p (if (entity-ref p #:group-local-x #f) p
-                  (entity-set p #:group-local-x (entity-ref p #:local-x 0))))
-           (p (if (entity-ref p #:group-local-y #f) p
-                  (entity-set p #:group-local-y (entity-ref p #:local-y 0)))))
-      p))
-
-  (define (load-prefabs file engine-mixin-table user-hooks)
-    (let* ((data (with-input-from-file file read))
-           (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 '())))
-           ;; 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-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)))
-      (make-prefab-registry
-        prefabs:            prefab-table
-        group-prefabs:      group-table
-        file:               file
-        engine-mixin-table: engine-mixin-table
-        user-hooks:         user-hooks
-        hook-table:         hook-table)))
-
-  (define (reload-prefabs! registry)
-    (load-prefabs (prefab-registry-file               registry)
-                  (prefab-registry-engine-mixin-table registry)
-                  (prefab-registry-user-hooks         registry)))
-
-  (define (instantiate-prefab registry type x y w h)
-    (if (not registry)
-        #f
-        (let ((entry (assq type (prefab-registry-prefabs registry))))
-          (if (not entry)
-              #f
-              (let* ((base (append (cdr entry) (make-entity x y w h)))
-                     (hook-val (entity-ref base #:on-instantiate #f))
-                     (handler
-                       (cond
-                         ((procedure? hook-val) hook-val)
-                         ((symbol?    hook-val)
-                          (lookup-hook (prefab-registry-hook-table registry) hook-val))
-                         (else #f))))
-                (if handler (handler base) base))))))
-
-  (define (instantiate-group-member part ox oy gid type-members static-parts?)
-    (let* ((p0 (part-with-group-locals part))
-           (merged (append 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))
-           (with-type (entity-set merged #:type typ))
-           (g1 (entity-set with-type #:group-id gid))
-           (g2 (entity-set g1 #:group-local-x lx))
-           (g3 (entity-set g2 #:group-local-y ly))
-           (g4 (entity-set g3 #:x (+ ox lx))))
-      (entity-set g4 #:y (+ oy ly))))
-
-  ;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y.
-  ;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id.
-  (define (instantiate-group-prefab registry type ox oy)
-    (if (not registry)
-        #f
-        (let ((entry (assq type (prefab-registry-group-prefabs registry))))
-          (if (not entry)
-              #f
-              (let* ((spec (cdr entry))
-                     (gid (gensym (symbol->string type)))
-                     (parts (entity-ref spec #:parts '()))
-                     (type-members (entity-ref spec #:type-members 'group-part))
-                     (pose-only? (entity-ref spec #:pose-only-origin? #f))
-                     (static-parts? (entity-ref spec #:static-parts? #f))
-                     (ow (entity-ref spec #:origin-width 0))
-                     (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)
-                         (if pose-only?
-                             +pose-only-group-origin-defaults+
-                             +physics-group-origin-defaults+)))
-                     (origin origin-fields)
-                     (members
-                       (map (lambda (part)
-                              (instantiate-group-member
-                                part ox oy gid type-members static-parts?))
-                            parts)))
-                (cons origin members)))))))
+(import scheme
+        (chicken base)
+        (chicken keyword)
+        (chicken port)
+	(chicken format)
+	srfi-1
+        defstruct
+        downstroke-entity)
+
+;; Registry struct to hold prefab data
+(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)))))))
+
+;; Return engine's built-in mixin table
+(define (engine-mixins)
+  '((physics-body #:vx 0 #:vy 0 #:ay 0 #:gravity? #t #:solid? #t #:on-ground? #f)
+    (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)
+(define (compose-prefab entry mixin-table)
+  (let* ((name (car entry))
+         (rest (cdr entry))
+         (split (let loop ((lst rest) (mixins '()))
+                  (if (or (null? lst) (keyword? (car lst)))
+                      (cons (reverse mixins) lst)
+                      (loop (cdr lst) (cons (car lst) mixins)))))
+         (mixin-names  (car split))
+         (inline-fields (cdr split))
+         (mixin-plists
+          (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)))
+    (cons name merged)))
+
+(define *engine-hooks* '())
+
+;; Lookup a hook symbol in the hook table
+(define (lookup-hook hook-table hook-sym)
+  (let ((entry (assq hook-sym hook-table)))
+    (if entry
+        (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)))
+
+;; 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))
+
+;; 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)))
+
+(define (part-with-group-locals part)
+  (let* ((p part)
+         (p (if (entity-ref p #:group-local-x #f) p
+                (entity-set p #:group-local-x (entity-ref p #:local-x 0))))
+         (p (if (entity-ref p #:group-local-y #f) p
+                (entity-set p #:group-local-y (entity-ref p #:local-y 0)))))
+    p))
+
+(define (load-prefabs file engine-mixin-table user-hooks)
+  (let* ((data (with-input-from-file file read))
+         (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 '())))
+         ;; 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-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)))
+    (make-prefab-registry
+     prefabs:            prefab-table
+     group-prefabs:      group-table
+     file:               file
+     engine-mixin-table: engine-mixin-table
+     user-hooks:         user-hooks
+     hook-table:         hook-table)))
+
+(define (reload-prefabs! registry)
+  (load-prefabs (prefab-registry-file               registry)
+                (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))))
+         (hook-val (entity-ref base #:on-instantiate #f))
+         (handler
+          (cond
+           ((procedure? hook-val) hook-val)
+           ((symbol?    hook-val)
+            (lookup-hook (prefab-registry-hook-table registry) hook-val))
+           (else #f))))
+    (if handler (handler base) base)))
+
+
+(define (instantiate-prefab registry type x y w h)
+  (if (not registry)
+      #f
+      (let ((entry (assq type (prefab-registry-prefabs registry))))
+        (if (not entry)
+            #f
+            (do-instantiate-prefab registry entry x y w h)))))
+
+(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+ '())))
+         (lx (entity-ref merged #:group-local-x 0))
+         (ly (entity-ref merged #:group-local-y 0))
+         (typ (entity-ref merged #:type type-members))
+         (with-type (entity-set merged #:type typ))
+         (g1 (entity-set with-type #:group-id gid))
+         (g2 (entity-set g1 #:group-local-x lx))
+         (g3 (entity-set g2 #:group-local-y ly))
+         (g4 (entity-set g3 #:x (+ ox lx))))
+    (entity-set g4 #:y (+ oy ly))))
+
+;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y.
+;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id.
+(define (instantiate-group-prefab registry type ox oy)
+  (if (not registry)
+      #f
+      (let ((entry (assq type (prefab-registry-group-prefabs registry))))
+        (if (not entry)
+            #f
+            (let* ((spec (cdr entry))
+                   (gid (gensym (symbol->string type)))
+                   (parts (entity-ref spec #:parts '()))
+                   (type-members (entity-ref spec #:type-members 'group-part))
+                   (pose-only? (entity-ref spec #:pose-only-origin? #f))
+                   (static-parts? (entity-ref spec #:static-parts? #f))
+                   (ow (entity-ref spec #:origin-width 0))
+                   (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)
+                     (if pose-only?
+                         +pose-only-group-origin-defaults+
+                         +physics-group-origin-defaults+)))
+                   (origin origin-fields)
+                   (members
+                    (map (lambda (part)
+                           (instantiate-group-member
+                            part ox oy gid type-members static-parts?))
+                         parts)))
+              (cons origin members)))))))