Prefabs

2 files changed, 238 insertions, 31 deletions

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