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