Fix plist handling, add test for timed animation frames

7 files changed, 300 insertions, 165 deletions

diff --git a/Makefile b/Makefile
index c0052b8..f550c31 100644
--- a/Makefile
+++ b/Makefile
@@ -4,7 +4,7 @@
 MODULE_NAMES := entity tween tilemap world input physics renderer assets engine mixer sound animation prefabs scene-loader
 OBJECT_FILES := $(patsubst %,bin/%.o,$(MODULE_NAMES))
 
-DEMO_NAMES := platformer shmup topdown audio sandbox spritefont menu tweens scaling
+DEMO_NAMES := platformer shmup topdown audio sandbox spritefont menu tweens scaling animation
 DEMO_BINS  := $(patsubst %,bin/demo-%,$(DEMO_NAMES))
 
 UNIT_NAMES := $(patsubst %,downstroke-%,$(MODULE_NAMES))
diff --git a/TODO.org b/TODO.org
index edaad3c..c09e063 100644
--- a/TODO.org
+++ b/TODO.org
@@ -1,3 +1,5 @@
+#+SEQ_TODO: TODO(t) DOING(o) | DONE(d)
 * Downstroke TODO
 
 ** TODO change exports so that imports follow the chicken convention: =(import (downstroke engine))=
+** DOING Debug flattening prefabs and mixins with things like compose-prefab that result in duplicate keys
diff --git a/animation.scm b/animation.scm
index e3e6e89..0d961a1 100644
--- a/animation.scm
+++ b/animation.scm
@@ -2,6 +2,7 @@
 (import scheme
         (chicken base)
         (chicken keyword)
+	(chicken pretty-print)
 	(only srfi-1 filter)
         downstroke-entity
         downstroke-world)
@@ -78,6 +79,7 @@
 (define-pipeline (apply-animation animation) (scene entity dt)
   guard: (entity-ref entity #:animations #f)
   (let ((animations (entity-ref entity #:animations #f)))
+    (pp entity)
     (animate-entity entity animations)))
 
 ) ;; End of animation module
diff --git a/demo/animation.scm b/demo/animation.scm
new file mode 100644
index 0000000..64c0d6a
--- /dev/null
+++ b/demo/animation.scm
@@ -0,0 +1,80 @@
+q(import scheme
+        (chicken base)
+	(chicken pretty-print)
+        (only srfi-1 iota)
+        (prefix sdl2 "sdl2:")
+        (prefix sdl2-ttf "ttf:")
+        downstroke-engine
+        downstroke-world
+        downstroke-renderer
+        downstroke-entity
+	downstroke-prefabs
+	downstroke-scene-loader
+	downstroke-tilemap
+	downstroke-animation)
+
+;; ── State ────────────────────────────────────────────────────────────────────
+
+(define *label-font*  #f)
+(define *title-font*  #f)
+
+(define (make-demo-entity x y tw th id)
+  (list #:type 'demo-bot
+        #:x x #:y y #:width tw #:height th
+        #:vx 0 #:vy 0
+        #:gravity? #t #:on-ground? #f
+        #:solid? #t #:immovable? #f
+        #:tile-id 1
+        #:demo-id id #:demo-since-jump 0))
+
+(define (make-demo-tilemap ts tw th gw gh)
+  (let* ((ncols     (inexact->exact (ceiling (/ gw tw))))
+         (nrows     (inexact->exact (ceiling (/ gh th))))
+         (empty-row (map (lambda (_) 0) (iota ncols)))
+         (floor-row (map (lambda (_) 20) (iota ncols)))
+         (map-data  (append (map (lambda (_) empty-row) (iota (- nrows 1)))
+                            (list floor-row))))
+    (make-tilemap
+     width: ncols height: nrows
+     tilewidth: tw tileheight: th
+     tileset-source: "" tileset: ts
+     layers: (list (make-layer name: "ground"
+                               width: ncols height: nrows
+                               map: map-data))
+     objects: '())))
+
+(define (make-demo-scene game)
+  (let* ((prefabs (load-prefabs "demo/assets/animation-prefabs.scm" (engine-mixins) '()))
+         (ts (game-load-tileset! game 'tileset "demo/assets/monochrome_transparent.tsx"))
+         (tw (tileset-tilewidth ts))
+         (th (tileset-tileheight ts))
+         (tex (create-texture-from-tileset (game-renderer game) ts))
+         (tm (make-demo-tilemap ts tw th (game-width game) (game-height game)))
+	 (entities (list (instantiate-prefab prefabs 'std-frames 80 80 tw th)
+			 (instantiate-prefab prefabs 'timed-frames 220 60 tw th))))
+    (pp entities)
+    (make-scene
+     entities: entities 
+     tilemap: tm
+     tileset: #f
+     camera: (make-camera x: 0 y: 0)
+     tileset-texture: tex
+     camera-target: #f
+     background: '(32 34 40))))
+
+(define *game*
+  (make-game
+   title: "Demo: Tweens" width: 640 height: 480
+
+   preload: (lambda (_game)
+	      (set! *title-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 22))
+	      (set! *label-font* (ttf:open-font "demo/assets/DejaVuSans.ttf" 13)))
+
+   create: (lambda (game)
+	     (game-scene-set! game (make-demo-scene game)))
+
+   update: (lambda (game dt)
+	     (let ((scene (game-scene game)))
+	       (game-scene-set! game (scene-map-entities scene (cut apply-animation <> <> dt)))))))
+
+(game-run! *game*)
diff --git a/demo/assets/animation-prefabs.scm b/demo/assets/animation-prefabs.scm
new file mode 100644
index 0000000..18aa7af
--- /dev/null
+++ b/demo/assets/animation-prefabs.scm
@@ -0,0 +1,6 @@
+((mixins)
+ (prefabs
+  (timed-frames animated  #:type timed-frames
+		#:animations ((#:name walk #:frames ((28 10) (29 1000)))))
+  (std-frames animated  #:type std-frames
+	      #:animations ((#:name attack #:frames (28 29) #:duration 10)))))
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)))))))
diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm
index e635d0a..3578b35 100644
--- a/tests/prefabs-test.scm
+++ b/tests/prefabs-test.scm
@@ -3,6 +3,7 @@
         (chicken base)
         (chicken keyword)
         (chicken port)
+	(chicken pretty-print)
         defstruct
         srfi-64)
 
@@ -65,6 +66,8 @@
       (lambda (reg)
         ;; Inline #:vx 99 beats mixin #:vx 5
         (let ((e (instantiate-prefab reg 'runner 0 0 16 16)))
+	  (pp e)
+	  (test-equal "entity should have squashed properties" 14 (length e))
           (test-equal "inline field beats mixin field for same key"
             99
             (entity-ref e #:vx))