diff options
Diffstat (limited to 'tests/prefabs-test.scm')
| -rw-r--r-- | tests/prefabs-test.scm | 218 |
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") |