diff options
Diffstat (limited to 'tests/prefabs-test.scm')
| -rw-r--r-- | tests/prefabs-test.scm | 202 |
1 files changed, 101 insertions, 101 deletions
diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index 06f9ba9..d77bcc5 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -3,7 +3,7 @@ (chicken base) (chicken keyword) (chicken port) - (chicken pretty-print) + (chicken pretty-print) defstruct test) @@ -13,15 +13,15 @@ (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)))))) + ((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))))))) + ((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)) @@ -61,47 +61,47 @@ (test-group "mixin merge priority" (with-prefab-data - "((mixins (speed-mixin #:vx 5 #:vy 0)) + "((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))) - (pp e) - (test "entity should have squashed properties" 7 (length e)) - (test "inline field beats mixin field for same key" - 99 - (entity-ref e #:vx)) - (test "mixin field present when not overridden" - 0 - (entity-ref e #:vy)))))) + (lambda (reg) + ;; Inline #:vx 99 beats mixin #:vx 5 + (let ((e (instantiate-prefab reg 'runner 0 0 16 16))) + (pp e) + (test "entity should have squashed properties" 7 (length e)) + (test "inline field beats mixin field for same key" + 99 + (entity-ref e #:vx)) + (test "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)) + "((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 "earlier mixin wins over later mixin for same key" - 'first - (entity-ref e #:key)))))) + (lambda (reg) + ;; m1 listed before m2 → m1's #:key wins + (let ((e (instantiate-prefab reg 'thing 0 0 8 8))) + (test "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)) + "((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 "user-redefined mixin key overrides engine default" - 77 - (entity-ref e #:vx)))))) + (lambda (reg) + ;; User redefined physics-body → user's version wins + (let ((e (instantiate-prefab reg 'custom-obj 0 0 16 16))) + (test "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) '()))))) + (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) @@ -115,18 +115,18 @@ (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))) + (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 "instance #:x is set" 10 (entity-ref e #:x)) - (test "instance #:y is set" 20 (entity-ref e #:y)) - (test "instance #:width is set" 32 (entity-ref e #:width)) - (test "instance #:height is set" 48 (entity-ref e #:height)) - (test "prefab field #:type present" 'box (entity-ref e #:type)) - (test "mixin field #:vx present" 0 (entity-ref e #:vx)) - (test "mixin field #:gravity? present" #t (entity-ref e #:gravity?)))))) + (let ((e (instantiate-prefab reg 'box 10 20 32 48))) + (test "instance #:x is set" 10 (entity-ref e #:x)) + (test "instance #:y is set" 20 (entity-ref e #:y)) + (test "instance #:width is set" 32 (entity-ref e #:width)) + (test "instance #:height is set" 48 (entity-ref e #:height)) + (test "prefab field #:type present" 'box (entity-ref e #:type)) + (test "mixin field #:vx present" 0 (entity-ref e #:vx)) + (test "mixin field #:gravity? present" #t (entity-ref e #:gravity?)))))) (test-group "hooks" (define (with-hook-registry extra-prefabs user-hooks thunk) @@ -134,8 +134,8 @@ (with-output-to-file tmp (lambda () (display (string-append - "((mixins)" - " (prefabs " extra-prefabs "))")))) + "((mixins)" + " (prefabs " extra-prefabs "))")))) (thunk (load-prefabs tmp (engine-mixins) user-hooks)))) (test-group "procedure value in #:on-instantiate fires directly" @@ -143,58 +143,58 @@ ;; (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: `((proc-hooked . ((#:type . proc-hooked) - (#:on-instantiate . ,hook-proc)))) - group-prefabs: '() - file: "/dev/null" - engine-mixin-table: '() - user-hooks: '() - hook-table: '()))) + prefabs: `((proc-hooked . ((#:type . proc-hooked) + (#:on-instantiate . ,hook-proc)))) + group-prefabs: '() + file: "/dev/null" + engine-mixin-table: '() + user-hooks: '() + hook-table: '()))) (let ((e (instantiate-prefab reg 'proc-hooked 0 0 8 8))) (test "procedure hook fires and sets #:proc-fired" - #t - (entity-ref e #: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 "user hook sets #:initialized" - #t - (entity-ref e #:initialized)))))) + "(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 "user hook sets #:initialized" + #t + (entity-ref e #:initialized)))))) (test-group "game hook via user-hooks (e.g. init-enemy-ai pattern)" (let ((tmp "/tmp/test-prefabs-user-init.scm")) (with-output-to-file tmp (lambda () (display - "((mixins (ai-body #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)) + "((mixins (ai-body #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)) (prefabs (npc ai-body has-facing #:type npc #:on-instantiate init-npc)))"))) (let ((reg (load-prefabs tmp (engine-mixins) - `((init-npc . ,(lambda (e) (entity-set e #:ai-machine 'from-user-hook))))))) + `((init-npc . ,(lambda (e) (entity-set e #:ai-machine 'from-user-hook))))))) (let ((e (instantiate-prefab reg 'npc 0 0 16 16))) (test "user hook sets #:ai-machine" - 'from-user-hook - (entity-ref e #:ai-machine)))))) + 'from-user-hook + (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 "no hook: type is plain" 'plain (entity-ref e #:type)))))) + "(plain physics-body #:type plain)" + '() + (lambda (reg) + (let ((e (instantiate-prefab reg 'plain 0 0 8 8))) + (test "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)))))) + (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") @@ -220,37 +220,37 @@ (thunk (load-prefabs tmp (engine-mixins) '())))) (with-group-prefab-data - "((mixins) (prefabs) + "((mixins) (prefabs) (group-prefabs (two-block #:pose-only-origin? #t #:static-parts? #t #:type-members segment #:parts ((#:local-x 0 #:local-y 0 #:width 10 #:height 8 #:tile-id 1) (#:local-x 10 #:local-y 0 #:width 10 #:height 8 #:tile-id 2)))))" - (lambda (reg) - (test-assert "instantiate-group-prefab unknown → #f" - (not (instantiate-group-prefab reg 'nope 0 0))) - (let ((lst (instantiate-group-prefab reg 'two-block 100 50))) - (test "returns list of origin + 2 members" 3 (length lst)) - (let ((origin (car lst)) - (a (cadr lst)) - (b (caddr lst))) - (test "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) - (test "origin group-origin?" #t (entity-ref origin #:group-origin?)) - (test "member a world x" 100 (entity-ref a #:x)) - (test "member b world x" 110 (entity-ref b #:x)) - (test "member a local x" 0 (entity-ref a #:group-local-x)) - (test "member b local x" 10 (entity-ref b #:group-local-x)) - (test "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) + (lambda (reg) + (test-assert "instantiate-group-prefab unknown → #f" + (not (instantiate-group-prefab reg 'nope 0 0))) + (let ((lst (instantiate-group-prefab reg 'two-block 100 50))) + (test "returns list of origin + 2 members" 3 (length lst)) + (let ((origin (car lst)) + (a (cadr lst)) + (b (caddr lst))) + (test "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) + (test "origin group-origin?" #t (entity-ref origin #:group-origin?)) + (test "member a world x" 100 (entity-ref a #:x)) + (test "member b world x" 110 (entity-ref b #:x)) + (test "member a local x" 0 (entity-ref a #:group-local-x)) + (test "member b local x" 10 (entity-ref b #:group-local-x)) + (test "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) (with-group-prefab-data - "((mixins) (prefabs) + "((mixins) (prefabs) (group-prefabs (falling-asm #:pose-only-origin? #f #:static-parts? #t #:type-members part #:parts ((#:local-x 0 #:local-y 0 #:width 4 #:height 4 #:tile-id 1)))))" - (lambda (reg) - (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0)))) - (test "physics origin has gravity" #t (entity-ref origin #:gravity?)) - (test-assert "physics origin has no #:skip-pipelines (pipelines run)" - (eq? 'absent (entity-ref origin #:skip-pipelines 'absent))))))) + (lambda (reg) + (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0)))) + (test "physics origin has gravity" #t (entity-ref origin #:gravity?)) + (test-assert "physics origin has no #:skip-pipelines (pipelines run)" + (eq? 'absent (entity-ref origin #:skip-pipelines 'absent))))))) (test-end "prefabs") (test-exit) |