Prefabs

1 files changed, 218 insertions, 0 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")