Prefabs

6 files changed, 345 insertions, 55 deletions

diff --git a/Makefile b/Makefile
index 6327ef9..9bf8a82 100644
--- a/Makefile
+++ b/Makefile
@@ -1,7 +1,7 @@
 .DEFAULT_GOAL := engine
 
 # Modules listed in dependency order
-MODULE_NAMES := entity tilemap world input physics renderer assets engine mixer sound animation ai scene-loader
+MODULE_NAMES := entity tilemap world input physics renderer assets engine mixer sound animation ai prefabs scene-loader
 OBJECT_FILES := $(patsubst %,bin/%.o,$(MODULE_NAMES))
 
 DEMO_NAMES := platformer shmup topdown audio sandbox
@@ -29,7 +29,8 @@ bin/mixer.o:
 bin/sound.o: bin/mixer.o
 bin/animation.o: bin/entity.o bin/world.o
 bin/ai.o: bin/entity.o bin/world.o
-bin/scene-loader.o: bin/world.o bin/tilemap.o bin/assets.o bin/engine.o
+bin/prefabs.o: bin/entity.o bin/ai.o
+bin/scene-loader.o: bin/world.o bin/tilemap.o bin/assets.o bin/engine.o bin/prefabs.o
 
 # Pattern rule: compile each module as a library unit
 bin/%.o: %.scm | bin
@@ -55,6 +56,7 @@ test:
 	@csi -s tests/engine-test.scm
 	@csi -s tests/animation-test.scm
 	@csi -s tests/ai-test.scm
+	@csi -s tests/prefabs-test.scm
 	@csi -s tests/scene-loader-test.scm
 
 demos: engine $(DEMO_BINS)
diff --git a/downstroke.egg b/downstroke.egg
index 216f864..32f839e 100644
--- a/downstroke.egg
+++ b/downstroke.egg
@@ -37,6 +37,9 @@
    (extension downstroke-ai
      (source "ai.scm")
      (component-dependencies downstroke-entity downstroke-world))
+   (extension downstroke-prefabs
+     (source "prefabs.scm")
+     (component-dependencies downstroke-entity downstroke-ai))
    (extension downstroke-scene-loader
      (source "scene-loader.scm")
-     (component-dependencies downstroke-world downstroke-tilemap downstroke-assets downstroke-engine))))
+     (component-dependencies downstroke-world downstroke-tilemap downstroke-assets downstroke-engine downstroke-prefabs))))
diff --git a/prefabs.scm b/prefabs.scm
new file mode 100644
index 0000000..56bc60a
--- /dev/null
+++ b/prefabs.scm
@@ -0,0 +1,91 @@
+(module downstroke-prefabs *
+  (import scheme
+          (chicken base)
+          (chicken keyword)
+          (chicken port)
+          defstruct
+          downstroke-entity
+          downstroke-ai)
+
+  ;; Registry struct to hold prefab data
+  (defstruct prefab-registry
+    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)
+      (ai-body      #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)))
+
+  ;; 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)))
+
+  ;; Engine-level hooks
+  (define *engine-hooks*
+    `((init-enemy-ai . ,(lambda (e) (entity-set e #:ai-machine (make-enemy-ai-machine))))))
+
+  ;; 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))))
+
+  (define (load-prefabs file engine-mixin-table user-hooks)
+    (let* ((data (with-input-from-file file read))
+           (mixin-section  (cdr (assq 'mixins data)))
+           (prefab-section (cdr (assq 'prefabs data)))
+           ;; user mixins first → user wins on assq lookup (overrides engine mixin by name)
+           (user-mixin-table (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)))
+      (make-prefab-registry
+        prefabs:            prefab-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
+              ;; instance fields prepended → highest priority
+              (let* ((base (append (list #:x x #:y y #:width w #:height h)
+                                   (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)))))))
diff --git a/scene-loader.scm b/scene-loader.scm
index f00cbce..9b5545e 100644
--- a/scene-loader.scm
+++ b/scene-loader.scm
@@ -2,39 +2,26 @@
   (import scheme
           (chicken base)
           (only srfi-1 filter-map)
-          (srfi 69)
           (prefix sdl2 "sdl2:")
           (prefix sdl2-ttf "ttf:")
           defstruct
           downstroke-tilemap
           downstroke-world
-          downstroke-engine)
+          downstroke-assets
+          downstroke-engine
+          downstroke-prefabs)
 
-  ;; Create a prefab registry from alternating symbol/constructor pairs.
-  ;; Returns a srfi-69 hash-table mapping symbols to constructor functions.
-  (define (make-prefab-registry . pairs)
-    (let ((ht (make-hash-table)))
-      (let loop ((p pairs))
-        (if (null? p) ht
-            (begin
-              (hash-table-set! ht (car p) (cadr p))
-              (loop (cddr p)))))))
-
-  ;; Instantiate a prefab by type from the registry.
-  ;; Returns the entity plist if type exists, #f otherwise.
-  (define (instantiate-prefab registry type x y w h)
-    (let ((ctor (hash-table-ref/default registry type #f)))
-      (and ctor (ctor x y w h))))
 
   ;; Convert TMX object list to entities.
   ;; Object types are strings from XML; convert to symbols before instantiating.
   ;; Filters out #f results (objects without registered prefabs).
-  (define (tilemap-objects->entities tilemap instantiate-fn)
+  (define (tilemap-objects->entities tilemap registry)
     (filter-map
       (lambda (obj)
-        (instantiate-fn (string->symbol (object-type obj))
-                        (object-x obj) (object-y obj)
-                        (object-width obj) (object-height obj)))
+        (instantiate-prefab registry
+                            (string->symbol (object-type obj))
+                            (object-x obj) (object-y obj)
+                            (object-width obj) (object-height obj)))
       (tilemap-objects tilemap)))
 
   ;; Create an SDL2 texture from the tileset image embedded in a tilemap.
diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm
new file mode 100644
index 0000000..6ccc473
--- /dev/null
+++ b/tests/prefabs-test.scm
@@ -0,0 +1,218 @@
+;; Base imports
+(import scheme
+        (chicken base)
+        (chicken keyword)
+        (chicken port)
+        defstruct
+        srfi-64)
+
+;; Mock downstroke-entity
+(module downstroke-entity *
+  (import scheme (chicken base))
+  (define (entity-ref entity key #!optional (default #f))
+    (let loop ((plist entity))
+      (cond
+        ((null? plist) (if (procedure? default) (default) default))
+        ((eq? (car plist) key) (cadr plist))
+        (else (loop (cddr plist))))))
+  (define (entity-set entity key val)
+    (let loop ((plist entity) (acc '()))
+      (cond
+        ((null? plist) (reverse (cons val (cons key acc))))
+        ((eq? (car plist) key) (append (reverse acc) (list key val) (cddr plist)))
+        (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc)))))))
+  (define (entity-type entity) (entity-ref entity #:type #f)))
+(import downstroke-entity)
+
+;; Mock downstroke-ai
+(module downstroke-ai *
+  (import scheme (chicken base))
+  (define (make-enemy-ai-machine) 'mock-ai-machine))
+(import downstroke-ai)
+
+;; Load module under test
+(include "prefabs.scm")
+(import downstroke-prefabs)
+
+(test-begin "prefabs")
+
+(test-group "engine-mixins"
+  (let ((m (engine-mixins)))
+    (test-assert "returns a list" (list? m))
+    (test-assert "physics-body entry exists" (assq 'physics-body m))
+    (test-assert "has-facing entry exists"   (assq 'has-facing m))
+    (test-assert "animated entry exists"     (assq 'animated m))
+    (test-assert "ai-body entry exists"      (assq 'ai-body m))
+
+    (let ((pb (cdr (assq 'physics-body m))))
+      (test-equal "physics-body has #:vx 0"       0   (cadr (memq #:vx pb)))
+      (test-equal "physics-body has #:gravity? #t" #t  (cadr (memq #:gravity? pb)))
+      (test-equal "physics-body has #:on-ground? #f" #f (cadr (memq #:on-ground? pb))))
+
+    (let ((an (cdr (assq 'animated m))))
+      (test-equal "animated has #:anim-tick 0" 0 (cadr (memq #:anim-tick an)))
+      (test-equal "animated has #:tile-id 0"   0 (cadr (memq #:tile-id an)))
+      (test-equal "animated has #:anim-name idle" 'idle (cadr (memq #:anim-name an))))
+
+    (let ((ai (cdr (assq 'ai-body m))))
+      (test-equal "ai-body has #:ai-machine #f"     #f (cadr (memq #:ai-machine ai)))
+      (test-equal "ai-body has #:disabled #f"       #f (cadr (memq #:disabled ai)))
+      (test-equal "ai-body has #:chase-origin-x 0"   0 (cadr (memq #:chase-origin-x ai))))))
+
+(test-group "compose-prefab (via load-prefabs with temp file)"
+
+  ;; Helper: write a temp data file and load it
+  (define (with-prefab-data str thunk)
+    (let ((tmp "/tmp/test-prefabs.scm"))
+      (with-output-to-file tmp (lambda () (display str)))
+      (thunk (load-prefabs tmp (engine-mixins) '()))))
+
+  (test-group "mixin merge priority"
+    (with-prefab-data
+      "((mixins (speed-mixin #:vx 5 #:vy 0))
+        (prefabs (runner speed-mixin #:type runner #:vx 99)))"
+      (lambda (reg)
+        ;; Inline #:vx 99 beats mixin #:vx 5
+        (let ((e (instantiate-prefab reg 'runner 0 0 16 16)))
+          (test-equal "inline field beats mixin field for same key"
+            99
+            (entity-ref e #:vx))
+          (test-equal "mixin field present when not overridden"
+            0
+            (entity-ref e #:vy))))))
+
+  (test-group "left-to-right mixin priority"
+    (with-prefab-data
+      "((mixins (m1 #:key first) (m2 #:key second))
+        (prefabs (thing m1 m2 #:type thing)))"
+      (lambda (reg)
+        ;; m1 listed before m2 → m1's #:key wins
+        (let ((e (instantiate-prefab reg 'thing 0 0 8 8)))
+          (test-equal "earlier mixin wins over later mixin for same key"
+            'first
+            (entity-ref e #:key))))))
+
+  (test-group "user mixin overrides engine mixin by name"
+    (with-prefab-data
+      "((mixins (physics-body #:vx 77 #:vy 88))
+        (prefabs (custom-obj physics-body #:type custom-obj)))"
+      (lambda (reg)
+        ;; User redefined physics-body → user's version wins
+        (let ((e (instantiate-prefab reg 'custom-obj 0 0 16 16)))
+          (test-equal "user-redefined mixin key overrides engine default"
+            77
+            (entity-ref e #:vx))))))
+
+  (test-group "unknown mixin raises error"
+    (test-error
+      (let ((tmp "/tmp/test-prefabs.scm"))
+        (with-output-to-file tmp (lambda () (display "((mixins) (prefabs (bad-prefab nonexistent-mixin #:type bad)))")))
+        (load-prefabs tmp (engine-mixins) '())))))
+
+(test-group "instantiate-prefab"
+  (define (with-simple-registry thunk)
+    (let ((tmp "/tmp/test-prefabs-inst.scm"))
+      (with-output-to-file tmp
+        (lambda ()
+          (display "((mixins) (prefabs (box physics-body #:type box #:tile-id 5)))")))
+      (thunk (load-prefabs tmp (engine-mixins) '()))))
+
+  (test-assert "returns #f when registry is #f"
+    (not (instantiate-prefab #f 'player 0 0 8 8)))
+
+  (with-simple-registry
+    (lambda (reg)
+      (test-assert "returns #f for unknown type"
+        (not (instantiate-prefab reg 'unknown 0 0 8 8)))
+
+      (let ((e (instantiate-prefab reg 'box 10 20 32 48)))
+        (test-equal "instance #:x is set"    10  (entity-ref e #:x))
+        (test-equal "instance #:y is set"    20  (entity-ref e #:y))
+        (test-equal "instance #:width is set"  32  (entity-ref e #:width))
+        (test-equal "instance #:height is set" 48  (entity-ref e #:height))
+        (test-equal "prefab field #:type present" 'box (entity-ref e #:type))
+        (test-equal "mixin field #:vx present"  0  (entity-ref e #:vx))
+        (test-equal "mixin field #:gravity? present" #t (entity-ref e #:gravity?))))))
+
+(test-group "hooks"
+  (define (with-hook-registry extra-prefabs user-hooks thunk)
+    (let ((tmp "/tmp/test-prefabs-hooks.scm"))
+      (with-output-to-file tmp
+        (lambda ()
+          (display (string-append
+            "((mixins)"
+            " (prefabs " extra-prefabs "))"))))
+      (thunk (load-prefabs tmp (engine-mixins) user-hooks))))
+
+  (test-group "procedure value in #:on-instantiate fires directly"
+    ;; Build a registry manually with a procedure in #:on-instantiate.
+    ;; (Data files only contain symbols; this tests the procedure? branch directly.)
+    (let* ((hook-proc (lambda (e) (entity-set e #:proc-fired #t)))
+           (reg (make-prefab-registry
+                  prefabs:            (list (cons 'proc-hooked
+                                                 (list #:type 'proc-hooked
+                                                       #:on-instantiate hook-proc)))
+                  file:               "/dev/null"
+                  engine-mixin-table: '()
+                  user-hooks:         '()
+                  hook-table:         '())))
+      (let ((e (instantiate-prefab reg 'proc-hooked 0 0 8 8)))
+        (test-equal "procedure hook fires and sets #:proc-fired"
+          #t
+          (entity-ref e #:proc-fired)))))
+
+  ;; Symbol hook: value in data file is a symbol, resolved via hook-table
+  (test-group "symbol hook via user-hooks"
+    (with-hook-registry
+      "(hooked physics-body #:type hooked #:on-instantiate my-hook)"
+      `((my-hook . ,(lambda (e) (entity-set e #:initialized #t))))
+      (lambda (reg)
+        (let ((e (instantiate-prefab reg 'hooked 0 0 8 8)))
+          (test-equal "user hook sets #:initialized"
+            #t
+            (entity-ref e #:initialized))))))
+
+  (test-group "init-enemy-ai engine hook"
+    (with-hook-registry
+      "(npc ai-body has-facing #:type npc #:on-instantiate init-enemy-ai)"
+      '()
+      (lambda (reg)
+        (let ((e (instantiate-prefab reg 'npc 0 0 16 16)))
+          (test-equal "engine hook sets #:ai-machine via make-enemy-ai-machine"
+            'mock-ai-machine
+            (entity-ref e #:ai-machine))))))
+
+  (test-group "no hook: entity returned unchanged"
+    (with-hook-registry
+      "(plain physics-body #:type plain)"
+      '()
+      (lambda (reg)
+        (let ((e (instantiate-prefab reg 'plain 0 0 8 8)))
+          (test-equal "no hook: type is plain" 'plain (entity-ref e #:type))))))
+
+  (test-group "unknown hook symbol raises error"
+    (test-error
+      (with-hook-registry
+        "(bad-hook #:type bad #:on-instantiate no-such-hook)"
+        '()
+        (lambda (reg)
+          (instantiate-prefab reg 'bad-hook 0 0 8 8))))))
+
+(test-group "reload-prefabs!"
+  (let* ((tmp "/tmp/test-prefabs-reload.scm")
+         (_ (with-output-to-file tmp
+              (lambda ()
+                (display "((mixins) (prefabs (box #:type box #:value 1)))"))))
+         (reg1 (load-prefabs tmp (engine-mixins) '()))
+         (e1   (instantiate-prefab reg1 'box 0 0 8 8))
+         ;; Overwrite the file with new value
+         (_ (with-output-to-file tmp
+              (lambda ()
+                (display "((mixins) (prefabs (box #:type box #:value 42)))"))))
+         (reg2 (reload-prefabs! reg1))
+         (e2   (instantiate-prefab reg2 'box 0 0 8 8)))
+    (test-equal "original registry has #:value 1"  1  (entity-ref e1 #:value))
+    (test-equal "reloaded registry has #:value 42" 42 (entity-ref e2 #:value))
+    (test-equal "original registry unchanged after reload" 1 (entity-ref e1 #:value))))
+
+(test-end "prefabs")
diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm
index 6a0b27c..137d7ed 100644
--- a/tests/scene-loader-test.scm
+++ b/tests/scene-loader-test.scm
@@ -75,28 +75,22 @@
   (define (open-font filename size) (list 'font filename size)))
 (import (prefix sdl2-ttf "ttf:"))
 
+;; Mock downstroke-prefabs
+;; The mock registry is just an alist ((type . constructor) ...) for test simplicity.
+;; instantiate-prefab maps to the constructor call.
+(module downstroke-prefabs *
+  (import scheme (chicken base))
+  (define (instantiate-prefab registry type x y w h)
+    (let ((entry (assq type registry)))
+      (and entry ((cdr entry) x y w h)))))
+(import downstroke-prefabs)
+
 ;; Load scene-loader module
 (include "scene-loader.scm")
 (import downstroke-scene-loader)
 
 (test-begin "scene-loader")
 
-(test-group "make-prefab-registry + instantiate-prefab"
-  (let* ((registry (make-prefab-registry
-                     'player (lambda (x y w h) (list #:type 'player #:x x #:y y #:width w #:height h))
-                     'enemy  (lambda (x y w h) (list #:type 'enemy  #:x x #:y y #:width w #:height h))))
-         (result (instantiate-prefab registry 'player 10 20 16 16)))
-    (test-assert "instantiate-prefab returns a plist for known type"
-      (list? result))
-    (test-equal "player has correct x"
-      10
-      (entity-ref result #:x))
-    (test-equal "player has correct type"
-      'player
-      (entity-ref result #:type))
-    (test-assert "unknown type returns #f"
-      (not (instantiate-prefab registry 'unknown 10 20 16 16)))))
-
 (test-group "tilemap-objects->entities"
   (let* ((obj1 (make-object name: "player1" type: "player"     x: 10  y: 20  width: 16 height: 16 properties: '()))
          (obj2 (make-object name: "deco"    type: "decoration" x: 50  y: 60  width: 32 height: 32 properties: '()))
@@ -104,29 +98,24 @@
          (tm   (make-tilemap width: 100 height: 100 tilewidth: 16 tileheight: 16
                              tileset-source: "" tileset: #f layers: '()
                              objects: (list obj1 obj2 obj3)))
-         (fn   (lambda (type x y w h)
-                 (cond
-                   ((eq? type 'player) (list #:type 'player #:x x #:y y #:width w #:height h))
-                   ((eq? type 'enemy)  (list #:type 'enemy  #:x x #:y y #:width w #:height h))
-                   (else #f))))
-         (result (tilemap-objects->entities tm fn)))
+         ;; mock registry: alist of (type . constructor)
+         (registry
+           (list (cons 'player (lambda (x y w h) (list #:type 'player #:x x #:y y #:width w #:height h)))
+                 (cons 'enemy  (lambda (x y w h) (list #:type 'enemy  #:x x #:y y #:width w #:height h)))))
+         (result (tilemap-objects->entities tm registry)))
     (test-equal "filters #f results: 2 entities from 3 objects"
-      2
-      (length result))
+      2 (length result))
     (test-equal "first entity is player"
-      'player
-      (entity-ref (car result) #:type))
+      'player (entity-ref (car result) #:type))
     (test-equal "second entity is enemy"
-      'enemy
-      (entity-ref (cadr result) #:type)))
+      'enemy  (entity-ref (cadr result) #:type)))
 
   (let* ((tm-empty (make-tilemap width: 100 height: 100 tilewidth: 16 tileheight: 16
                                  tileset-source: "" tileset: #f layers: '()
                                  objects: '()))
-         (result (tilemap-objects->entities tm-empty (lambda (t x y w h) #f))))
+         (result (tilemap-objects->entities tm-empty '())))
     (test-equal "empty object list returns empty list"
-      0
-      (length result))))
+      0 (length result))))
 
 (test-group "game-load-tilemap! / game-load-tileset! / game-load-font!"
   ;; game-load-tilemap! calls load-tilemap and stores result