diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/animation-test.scm | 6 | ||||
| -rw-r--r-- | tests/assets-test.scm | 20 | ||||
| -rw-r--r-- | tests/engine-test.scm | 134 | ||||
| -rw-r--r-- | tests/entity-test.scm | 24 | ||||
| -rw-r--r-- | tests/input-test.scm | 34 | ||||
| -rw-r--r-- | tests/physics-test.scm | 20 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 202 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 90 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 18 | ||||
| -rw-r--r-- | tests/tilemap-test.scm | 8 | ||||
| -rw-r--r-- | tests/tween-test.scm | 30 | ||||
| -rw-r--r-- | tests/world-test.scm | 192 |
12 files changed, 389 insertions, 389 deletions
diff --git a/tests/animation-test.scm b/tests/animation-test.scm index 117e933..356f44c 100644 --- a/tests/animation-test.scm +++ b/tests/animation-test.scm @@ -26,7 +26,7 @@ (test "first frame, frames (0)" 100 (frame->duration '((0 100)) 0)) (test "wraps around" 100 (frame->duration '((0 100) (1 200)) 2)) (test "frame 1 of (27 28)" 200 (frame->duration '((27 100) (28 200)) 1)) -) + ) (test-group "set-animation" (let ((e (entity #:type 'player #:anim-name 'idle #:anim-frame 5 #:anim-tick 8))) @@ -63,10 +63,10 @@ (test-group "animated entity" (let* ((anims (list (anim #:name 'walk #:frames '(2 3) #:duration 4))) (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0 #:animations anims)) - (stepped-entity (apply-animation #f e 10))) + (stepped-entity (apply-animation #f e 10))) (test "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick))) (let* ((e (entity #:type 'static)) - (stepped-entity (apply-animation #f e 10))) + (stepped-entity (apply-animation #f e 10))) (test "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick))))) (test-end "animation") diff --git a/tests/assets-test.scm b/tests/assets-test.scm index 5fea845..c167e7a 100644 --- a/tests/assets-test.scm +++ b/tests/assets-test.scm @@ -12,26 +12,26 @@ (test-group "asset-set! and asset-ref" (let ((reg (make-asset-registry))) (test "missing key returns #f" - #f - (asset-ref reg 'missing)) + #f + (asset-ref reg 'missing)) (asset-set! reg 'my-tilemap "data") (test "stored value is retrievable" - "data" - (asset-ref reg 'my-tilemap)) + "data" + (asset-ref reg 'my-tilemap)) (asset-set! reg 'my-tilemap "updated") (test "overwrite replaces value" - "updated" - (asset-ref reg 'my-tilemap)) + "updated" + (asset-ref reg 'my-tilemap)) (asset-set! reg 'other 42) (test "multiple keys coexist" - "updated" - (asset-ref reg 'my-tilemap)) + "updated" + (asset-ref reg 'my-tilemap)) (test "second key retrievable" - 42 - (asset-ref reg 'other)))) + 42 + (asset-ref reg 'other)))) (test-end "assets") (test-exit) diff --git a/tests/engine-test.scm b/tests/engine-test.scm index bfa6d75..0ae56a9 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -46,9 +46,9 @@ (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))))))) (import (downstroke entity)) ;; --- Input module (mock) --- @@ -60,18 +60,18 @@ (define-record input-state current previous) (define *default-input-config* (make-input-config - actions: '(up down left right a b start select quit) - keyboard-map: '((w . up) (up . up) (s . down) (down . down) - (a . left) (left . left) (d . right) (right . right) - (j . a) (z . a) (k . b) (x . b) - (return . start) (escape . quit)) - joy-button-map: '((0 . a) (1 . b) (7 . start) (6 . select)) - controller-button-map: '((a . a) (b . b) (start . start) (back . select) - (dpad-up . up) (dpad-down . down) - (dpad-left . left) (dpad-right . right)) - joy-axis-bindings: '((0 right left) (1 down up)) - controller-axis-bindings: '((left-x right left) (left-y down up)) - deadzone: 8000)) + actions: '(up down left right a b start select quit) + keyboard-map: '((w . up) (up . up) (s . down) (down . down) + (a . left) (left . left) (d . right) (right . right) + (j . a) (z . a) (k . b) (x . b) + (return . start) (escape . quit)) + joy-button-map: '((0 . a) (1 . b) (7 . start) (6 . select)) + controller-button-map: '((a . a) (b . b) (start . start) (back . select) + (dpad-up . up) (dpad-down . down) + (dpad-left . left) (dpad-right . right)) + joy-axis-bindings: '((0 right left) (1 down up)) + controller-axis-bindings: '((left-x right left) (left-y down up)) + deadzone: 8000)) (define (create-input-state config) (make-input-state '() '())) (define (input-state-update state events config) @@ -89,15 +89,15 @@ ;; Mock camera-follow - returns a new camera (define (camera-follow camera entity viewport-w viewport-h) (update-camera camera - x: (max 0 (- (entity-ref entity #:x 0) (/ viewport-w 2))) - y: (max 0 (- (entity-ref entity #:y 0) (/ viewport-h 2))))) + x: (max 0 (- (entity-ref entity #:x 0) (/ viewport-w 2))) + y: (max 0 (- (entity-ref entity #:y 0) (/ viewport-h 2))))) ;; Mock scene-find-tagged - finds first entity with matching tag (define (scene-find-tagged scene tag) (let loop ((entities (scene-entities scene))) (cond - ((null? entities) #f) - ((member tag (entity-ref (car entities) #:tags '())) (car entities)) - (else (loop (cdr entities)))))) + ((null? entities) #f) + ((member tag (entity-ref (car entities) #:tags '())) (car entities)) + (else (loop (cdr entities)))))) (define (scene-map-entities scene . procs) (let loop ((ps procs) (es (scene-entities scene))) (if (null? ps) @@ -156,36 +156,36 @@ (test-group "make-game defaults" (let ((g (make-game))) (test "default title" - "Downstroke Game" - (game-title g)) + "Downstroke Game" + (game-title g)) (test "default width" - 640 - (game-width g)) + 640 + (game-width g)) (test "default height" - 480 - (game-height g)) + 480 + (game-height g)) (test "default frame-delay" - 16 - (game-frame-delay g)) + 16 + (game-frame-delay g)) (test "scene starts as #f" - #f - (game-scene g)) + #f + (game-scene g)) (test "window starts as #f" - #f - (game-window g)) + #f + (game-window g)) (test "renderer starts as #f" - #f - (game-renderer g)) + #f + (game-renderer g)) (test-assert "assets registry is created" (game-assets g)) (test-assert "input state is created" (game-input g)) (test "debug? defaults to #f" - #f - (game-debug? g)) + #f + (game-debug? g)) (test "scale defaults to 1" - 1 - (game-scale g)))) + 1 + (game-scale g)))) (test-group "make-game with keyword args" (let ((g (make-game title: "My Game" width: 320 height: 240 frame-delay: 33))) @@ -196,22 +196,22 @@ (test-group "make-game debug? keyword" (test "debug? defaults to #f" - #f - (game-debug? (make-game))) + #f + (game-debug? (make-game))) (test "debug? can be set to #t" - #t - (game-debug? (make-game debug?: #t)))) + #t + (game-debug? (make-game debug?: #t)))) (test-group "make-game scale keyword" (test "scale defaults to 1" - 1 - (game-scale (make-game))) + 1 + (game-scale (make-game))) (test "scale can be set to 2" - 2 - (game-scale (make-game scale: 2))) + 2 + (game-scale (make-game scale: 2))) (test "scale can be set to 3" - 3 - (game-scale (make-game scale: 3))) + 3 + (game-scale (make-game scale: 3))) (import (chicken condition)) (let ((caught #f)) (condition-case (make-game scale: 0) @@ -229,16 +229,16 @@ (test-group "game-asset and game-asset-set!" (let ((g (make-game))) (test "missing key returns #f" - #f - (game-asset g 'no-such-asset)) + #f + (game-asset g 'no-such-asset)) (game-asset-set! g 'my-font 'font-object) (test "stored asset is retrievable" - 'font-object - (game-asset g 'my-font)) + 'font-object + (game-asset g 'my-font)) (game-asset-set! g 'my-font 'updated-font) (test "overwrite replaces asset" - 'updated-font - (game-asset g 'my-font)))) + 'updated-font + (game-asset g 'my-font)))) (test-group "make-game hooks default to #f" (let ((g (make-game))) @@ -256,17 +256,17 @@ (test-group "game-camera" (let* ((cam (make-camera x: 10 y: 20)) (scene (make-scene entities: '() - tilemap: #f - tileset: #f - camera: cam - tileset-texture: #f - camera-target: #f - background: #f)) + tilemap: #f + tileset: #f + camera: cam + tileset-texture: #f + camera-target: #f + background: #f)) (g (make-game))) (game-scene-set! g scene) (test "returns scene camera" - cam - (game-camera g)))) + cam + (game-camera g)))) (test-group "make-game-state" (let ((s (make-game-state create: (lambda (g) 'created) @@ -283,7 +283,7 @@ (let* ((created? #f) (game (make-game)) (state (make-game-state - create: (lambda (g) (set! created? #t))))) + create: (lambda (g) (set! created? #t))))) (game-add-state! game 'play state) (test "active-state defaults to #f" #f (game-active-state game)) (game-start-state! game 'play) @@ -297,16 +297,16 @@ (test-group "scene engine-update" (test "scene engine-update defaults to #f" - #f - (scene-engine-update (make-scene entities: '() tilemap: #f camera-target: #f))) + #f + (scene-engine-update (make-scene entities: '() tilemap: #f camera-target: #f))) (let* ((my-eu (lambda (game dt) #t)) (s (make-scene entities: '() tilemap: #f camera-target: #f engine-update: my-eu))) (test-assert "custom engine-update stored on scene" (procedure? (scene-engine-update s)))) (let ((s (make-scene entities: '() tilemap: #f camera-target: #f engine-update: 'none))) (test "engine-update: 'none disables pipeline" - 'none - (scene-engine-update s)))) + 'none + (scene-engine-update s)))) (test-end "engine") (test-exit) diff --git a/tests/entity-test.scm b/tests/entity-test.scm index 1e3ab19..c7bcd2d 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -20,18 +20,18 @@ ;; Test with default value (let ((entity '((#:type . player)))) (test "returns default for missing key" - 99 - (entity-ref entity #:x 99)) + 99 + (entity-ref entity #:x 99)) (test "returns #f as default if not specified" - #f - (entity-ref entity #:missing-key)))) + #f + (entity-ref entity #:missing-key)))) ;; Test: entity-ref with procedure as default (test-group "entity-ref-with-procedure-default" (let ((entity '((#:type . player)))) (test "calls procedure default when key missing" - 42 - (entity-ref entity #:x (lambda () 42))))) + 42 + (entity-ref entity #:x (lambda () 42))))) ;; Test: make-player-entity creates valid player entity (test-group "make-entity" @@ -51,8 +51,8 @@ (let ((no-type '((#:x . 100) (#:y . 200)))) (test "returns #f for entity without type" - #f - (entity-type no-type)))) + #f + (entity-type no-type)))) ;; Test: complex entity with multiple properties (test-group "complex-entity" @@ -128,19 +128,19 @@ (test "skipped" 0 (entity-ref (fixture-pipeline #f e 0) #:x)))) (define-pipeline (guarded-pipeline guarded-skip) (scene_ ent _dt) - guard: (entity-ref ent #:active? #f) + guard: (entity-ref ent #:active? #f) (entity-set ent #:x 99)) (test-group "define-pipeline with guard:" (let ((e '((#:type . t) (#:x . 0) (#:active? . #t)))) (test "runs body when guard passes" 99 - (entity-ref (guarded-pipeline #f e 0) #:x))) + (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0)))) (test "returns entity unchanged when guard fails" 0 - (entity-ref (guarded-pipeline #f e 0) #:x))) + (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0) (#:active? . #t) (#:skip-pipelines . (guarded-skip))))) (test "skip-pipelines takes precedence over guard" 0 - (entity-ref (guarded-pipeline #f e 0) #:x)))) + (entity-ref (guarded-pipeline #f e 0) #:x)))) (test-end "entity") (test-exit) diff --git a/tests/input-test.scm b/tests/input-test.scm index 2903cbb..39316c4 100644 --- a/tests/input-test.scm +++ b/tests/input-test.scm @@ -63,7 +63,7 @@ ;; In state2, up is held but was not held before -> pressed (test-assert "pressed when current=#t and previous=#f" - (input-pressed? state2 'up)))) + (input-pressed? state2 'up)))) ;; Test: input-released? detection (test-group "input-released?" @@ -79,14 +79,14 @@ (test "not released when held" #f (input-released? state-held 'up)) (test-assert "released when current=#f and previous=#t" - (input-released? state-released 'up)))) + (input-released? state-released 'up)))) ;; Test: input-any-pressed? (test-group "input-any-pressed?" (let ((state1 (create-input-state *default-input-config*))) (test "no actions pressed in initial state" - #f - (input-any-pressed? state1 *default-input-config*)))) + #f + (input-any-pressed? state1 *default-input-config*)))) ;; Test: input-state->string formatting (test-group "input-state->string" @@ -95,8 +95,8 @@ (test-assert "returns a string" (string? str)) (test-assert "contains [Input:" (string-contains str "[Input:")) (test-assert "empty state shows no actions" - (or (string-contains str "[]") - (string-contains str "[Input: ]"))))) + (or (string-contains str "[]") + (string-contains str "[Input: ]"))))) ;; Test: state transitions (test-group "state-transitions" @@ -119,13 +119,13 @@ (input-state-current state2)))) (test-assert "up still held in state3" (input-held? state3 'up)) (test "up not pressed in state3 (already was pressed)" - #f - (input-pressed? state3 'up))))) + #f + (input-pressed? state3 'up))))) (define (make-physics-entity) (entity-set-many (make-entity 0 0 16 16) - `((#:vx . 0) (#:vy . 0) - (#:input-map . ((left . (-2 . 0)) (right . (2 . 0))))))) + `((#:vx . 0) (#:vy . 0) + (#:input-map . ((left . (-2 . 0)) (right . (2 . 0))))))) ;; Test: apply-input-to-entity applies input to entity (test-group "apply-input-to-entity" @@ -169,13 +169,13 @@ (test-group "custom-input-config" (let* ((cfg (make-input-config - actions: '(jump shoot) - keyboard-map: '((space . jump) (f . shoot)) - joy-button-map: '() - controller-button-map: '() - joy-axis-bindings: '() - controller-axis-bindings: '() - deadzone: 8000)) + actions: '(jump shoot) + keyboard-map: '((space . jump) (f . shoot)) + joy-button-map: '() + controller-button-map: '() + joy-axis-bindings: '() + controller-axis-bindings: '() + deadzone: 8000)) (state (create-input-state cfg))) (test-assert "custom config creates valid state" (input-state? state)) (test "jump is false" #f (input-held? state 'jump)) diff --git a/tests/physics-test.scm b/tests/physics-test.scm index e22c2fd..54c71ea 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -303,16 +303,16 @@ (test "pushed above floor" 28 (entity-ref result #:y)) (test "vy zeroed" 0 (entity-ref result #:vy)))))) - (test-group "high-velocity fall: snaps to first solid row, not last" - ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. - ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]). - ;; After apply-velocity-y the entity lands at y=34 (overlapping both rows 2 and 3). - ;; Correct: snap to top of row 2 → y=16. Bug was: fold overwrote row 2 snap with row 3 snap → y=32 (inside row 2). - (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 0)))) - (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) - (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test "snapped to first solid row" 16 (entity-ref result #:y)) - (test "vy zeroed" 0 (entity-ref result #:vy))))) +(test-group "high-velocity fall: snaps to first solid row, not last" + ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. + ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]). + ;; After apply-velocity-y the entity lands at y=34 (overlapping both rows 2 and 3). + ;; Correct: snap to top of row 2 → y=16. Bug was: fold overwrote row 2 snap with row 3 snap → y=32 (inside row 2). + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 0)))) + (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) + (test "snapped to first solid row" 16 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) ;; Integration test: simulate the actual game physics loop (test-group "multi-frame physics simulation" 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) diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index 3a85c73..cd4c5d9 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -61,43 +61,43 @@ (let* ((cam (make-camera x: 10 y: 20)) (e (entity #:x 50 #:y 80 #:width 16 #:height 16))) (test "subtracts camera offset from x" - 40 - (car (entity-screen-coords e cam))) + 40 + (car (entity-screen-coords e cam))) (test "subtracts camera offset from y" - 60 - (cadr (entity-screen-coords e cam))) + 60 + (cadr (entity-screen-coords e cam))) (test "preserves width" - 16 - (caddr (entity-screen-coords e cam))) + 16 + (caddr (entity-screen-coords e cam))) (test "preserves height" - 16 - (cadddr (entity-screen-coords e cam)))) + 16 + (cadddr (entity-screen-coords e cam)))) (let* ((cam (make-camera x: 0 y: 0)) (e (entity #:x 100.7 #:y 200.3 #:width 16 #:height 16))) (test "floors fractional x" - 100 - (car (entity-screen-coords e cam))) + 100 + (car (entity-screen-coords e cam))) (test "floors fractional y" - 200 - (cadr (entity-screen-coords e cam)))) + 200 + (cadr (entity-screen-coords e cam)))) (let* ((cam (make-camera x: 0 y: 0)) (e (entity #:x 0 #:y 0 #:width 32 #:height 32))) (test "zero camera, zero position" - '(0 0 32 32) - (entity-screen-coords e cam)))) + '(0 0 32 32) + (entity-screen-coords e cam)))) (test-group "entity-flip" (test "facing 1: no flip" - '() - (entity-flip (entity #:facing 1))) + '() + (entity-flip (entity #:facing 1))) (test "facing -1: horizontal flip" - '(horizontal) - (entity-flip (entity #:facing -1))) + '(horizontal) + (entity-flip (entity #:facing -1))) (test "no facing key: defaults to no flip" - '() - (entity-flip (entity #:x 0)))) + '() + (entity-flip (entity #:x 0)))) (test-group "render-scene!" (let* ((cam (make-camera x: 0 y: 0)) @@ -134,34 +134,34 @@ (test-group "sprite-font" (test-group "make-sprite-font*" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\C 100))))) + ranges: (list (list #\A #\C 100))))) (test "A maps to 100" - 100 - (sprite-font-char->tile-id font #\A)) + 100 + (sprite-font-char->tile-id font #\A)) (test "B maps to 101" - 101 - (sprite-font-char->tile-id font #\B)) + 101 + (sprite-font-char->tile-id font #\B)) (test "C maps to 102" - 102 - (sprite-font-char->tile-id font #\C)))) + 102 + (sprite-font-char->tile-id font #\C)))) (test-group "sprite-font-char->tile-id" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\Z 100))))) + ranges: (list (list #\A #\Z 100))))) (test "returns #f for unmapped char" - #f - (sprite-font-char->tile-id font #\1)) + #f + (sprite-font-char->tile-id font #\1)) (test "auto-upcase: lowercase a maps to uppercase" - 100 - (sprite-font-char->tile-id font #\a)))) + 100 + (sprite-font-char->tile-id font #\a)))) (test-group "overlapping ranges" (import (chicken condition)) (let ((caught-error #f)) (condition-case - (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\C 100) - (list #\B #\D 200))) + (make-sprite-font* tile-size: 8 spacing: 1 + ranges: (list (list #\A #\C 100) + (list #\B #\D 200))) (e (exn) (set! caught-error #t))) (test-assert "signals error on overlapping range" @@ -169,19 +169,19 @@ (test-group "sprite-text-width" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\Z 100))))) + ranges: (list (list #\A #\Z 100))))) (test "empty string width is 0" - 0 - (sprite-text-width font "")) + 0 + (sprite-text-width font "")) (test "single char width is tile-size" - 8 - (sprite-text-width font "A")) + 8 + (sprite-text-width font "A")) (test "two chars: 2*tile-size + 1*spacing" - 17 - (sprite-text-width font "AB")) + 17 + (sprite-text-width font "AB")) (test "three chars: 3*tile-size + 2*spacing" - 26 - (sprite-text-width font "ABC")))) + 26 + (sprite-text-width font "ABC")))) (test-group "draw-sprite-text" (let* ((font (make-sprite-font* tile-size: 8 spacing: 1 @@ -303,7 +303,7 @@ (test-assert "render-scene! works with plist entities" (begin (render-scene! #f scene-ok) #t)) (test-error "render-scene! errors when entity list contains a vector" - (render-scene! #f scene-bad)) + (render-scene! #f scene-bad)) (test-assert "extracting entity from cell vector fixes the issue" (let ((scene-fixed (make-scene entities: (list (vector-ref cell 0)) tilemap: tilemap camera: cam diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm index e86ea42..3286c70 100644 --- a/tests/scene-loader-test.scm +++ b/tests/scene-loader-test.scm @@ -36,7 +36,7 @@ (defstruct scene entities tilemap tileset camera tileset-texture camera-target background engine-update) (define (scene-add-entity scene entity) (update-scene scene - entities: (append (scene-entities scene) (list entity))))) + entities: (append (scene-entities scene) (list entity))))) (import (downstroke world)) ;; Mock assets module @@ -90,22 +90,22 @@ objects: (list obj1 obj2 obj3))) ;; mock registry: alist of (type . constructor) (registry - (list (cons 'player (lambda (x y w h) (entity #:type 'player #:x x #:y y #:width w #:height h))) - (cons 'enemy (lambda (x y w h) (entity #:type 'enemy #:x x #:y y #:width w #:height h))))) + (list (cons 'player (lambda (x y w h) (entity #:type 'player #:x x #:y y #:width w #:height h))) + (cons 'enemy (lambda (x y w h) (entity #:type 'enemy #:x x #:y y #:width w #:height h))))) (result (tilemap-objects->entities tm registry))) (test "filters #f results: 2 entities from 3 objects" - 2 (length result)) + 2 (length result)) (test "first entity is player" - 'player (entity-ref (car result) #:type)) + 'player (entity-ref (car result) #:type)) (test "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 '()))) (test "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 @@ -121,8 +121,8 @@ (let* ((game #f) ; mock game (game-asset-set! ignores it in mock) (font (ttf:open-font "test.ttf" 16))) (test "mock font is a list" - 'font - (car font)))) + 'font + (car font)))) (test-group "make-sprite-scene" (let ((s (make-sprite-scene))) diff --git a/tests/tilemap-test.scm b/tests/tilemap-test.scm index 3fe5cfe..33f9175 100644 --- a/tests/tilemap-test.scm +++ b/tests/tilemap-test.scm @@ -52,8 +52,8 @@ image-source: "test.png" image: #f))) (test "100 tiles / 10 columns = 10 rows" - 10 - (tileset-rows ts))) + 10 + (tileset-rows ts))) (let ((ts (make-tileset tilewidth: 16 tileheight: 16 @@ -63,8 +63,8 @@ image-source: "test.png" image: #f))) (test "105 tiles / 10 columns = 11 rows (ceiling)" - 11 - (tileset-rows ts)))) + 11 + (tileset-rows ts)))) ;; Test: tileset-tile calculates correct tile position (test-group "tileset-tile" diff --git a/tests/tween-test.scm b/tests/tween-test.scm index 31b4de3..1e19a4b 100644 --- a/tests/tween-test.scm +++ b/tests/tween-test.scm @@ -69,7 +69,7 @@ (let ((calls 0)) (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 delay: 0 ease: 'linear - on-complete: (lambda (_) (set! calls (+ calls 1)))))) + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) (test "one call" 1 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 5) @@ -88,7 +88,7 @@ (test-group "repeat: 1 plays twice" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1))) + ease: 'linear repeat: 1))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "not finished after first play" (not (tween-finished? tw2))) (test "x at target" 100.0 (entity-ref e2 #:x)) @@ -99,7 +99,7 @@ (test-group "repeat: -1 never finishes" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 - ease: 'linear repeat: -1))) + ease: 'linear repeat: -1))) (let loop ((tw tw) (ent ent) (i 0)) (if (>= i 5) (test-assert "still active after 5 cycles" (tween-active? tw)) (receive (tw2 e2) (tween-step tw ent 10) @@ -116,8 +116,8 @@ (let ((calls 0)) (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 - ease: 'linear repeat: 1 - on-complete: (lambda (_) (set! calls (+ calls 1)))))) + ease: 'linear repeat: 1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) (test "no call after first play" 0 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 10) @@ -127,8 +127,8 @@ (let ((calls 0)) (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 - ease: 'linear repeat: -1 - on-complete: (lambda (_) (set! calls (+ calls 1)))))) + ease: 'linear repeat: -1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (let loop ((tw tw) (ent ent) (i 0)) (if (>= i 5) (test "never called" 0 (begin calls)) (receive (tw2 e2) (tween-step tw ent 10) @@ -138,7 +138,7 @@ (test-group "yoyo: #t with repeat: 1 reverses" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1 yoyo?: #t))) + ease: 'linear repeat: 1 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) (test "x at target after forward" 100.0 (entity-ref e2 #:x)) (receive (tw3 e3) (tween-step tw2 e2 50) @@ -150,7 +150,7 @@ (test-group "yoyo: #t with repeat: -1 ping-pongs forever" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: -1 yoyo?: #t))) + ease: 'linear repeat: -1 yoyo?: #t))) ;; Forward (receive (tw2 e2) (tween-step tw ent 100) (test "at target" 100.0 (entity-ref e2 #:x)) @@ -165,7 +165,7 @@ (test-group "yoyo: #f with repeat: 1 replays same direction" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1 yoyo?: #f))) + ease: 'linear repeat: 1 yoyo?: #f))) (receive (tw2 e2) (tween-step tw ent 100) (test "x at target" 100.0 (entity-ref e2 #:x)) ;; Second play starts from same starts (0→100), but entity is at 100 @@ -176,7 +176,7 @@ (test-group "yoyo: #t without repeat has no effect" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 0 yoyo?: #t))) + ease: 'linear repeat: 0 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "finishes normally" (tween-finished? tw2)) (test "x at target" 100.0 (entity-ref e2 #:x)))))) @@ -185,7 +185,7 @@ (test-group "advances #:tween on entity" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 50))) (test "x moved to midpoint" 50.0 (entity-ref e2 #:x)) (test-assert "tween still attached" (entity-ref e2 #:tween #f)))) @@ -193,7 +193,7 @@ (test-group "removes #:tween when finished" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) (test "x at target" 100.0 (entity-ref e2 #:x)) (test "tween removed" #f (entity-ref e2 #:tween #f)))) @@ -206,7 +206,7 @@ (test-group "keeps repeating tween attached" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) + duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) (e2 (step-tweens #f ent 100))) (test "x at target" 100.0 (entity-ref e2 #:x)) (test-assert "tween still attached (repeating)" (entity-ref e2 #:tween #f)))) @@ -215,7 +215,7 @@ (let* ((ent (entity #:type 'a #:x 0 #:skip-pipelines '(tweens) #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) (test "x unchanged (skipped)" 0 (entity-ref e2 #:x)) (test-assert "tween still there" (entity-ref e2 #:tween #f))))) diff --git a/tests/world-test.scm b/tests/world-test.scm index 0915cd2..9fd4947 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -96,7 +96,7 @@ layers: (list layer1 layer2) objects: '()))) (test "skips zero in layer1, finds in layer2" - 5 (tilemap-tile-at tm 1 1))))) + 5 (tilemap-tile-at tm 1 1))))) ;; Test: scene record creation (test-group "scene-structure" @@ -122,14 +122,14 @@ tilemap: tilemap camera-target: #f))) (test "scene has 2 entities" - 2 - (length (scene-entities scene))) + 2 + (length (scene-entities scene))) (test "first entity is player" - 'player - (entity-type (car (scene-entities scene)))) + 'player + (entity-type (car (scene-entities scene)))) (test "tilemap is set correctly" - "mock-tilemap" - (scene-tilemap scene)))) + "mock-tilemap" + (scene-tilemap scene)))) ;; Test: scene-add-entity adds entity to scene (test-group "scene-add-entity" @@ -143,8 +143,8 @@ (test "original scene unchanged" 1 (length (scene-entities scene))) (test "entity count after add" 2 (length (scene-entities scene2))) (test "second entity is enemy" - 'enemy - (entity-type (cadr (scene-entities scene2))))))) + 'enemy + (entity-type (cadr (scene-entities scene2))))))) ;; Test: scene-add-entity appends to end (test-group "scene-add-entity-order" @@ -156,8 +156,8 @@ (scene (scene-add-entity scene e3))) (test "entities are in order" - '(a b c) - (map entity-type (scene-entities scene))))) + '(a b c) + (map entity-type (scene-entities scene))))) ;; Test: scene-map-entities applies function to all entities (test-group "scene-map-entities" @@ -165,24 +165,24 @@ (e2 (entity #:type 'enemy #:x 200 #:y 200)) (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) (move-right (lambda (scene ent) - (let ((x (entity-ref ent #:x)) - (y (entity-ref ent #:y)) - (type (entity-ref ent #:type))) - (entity #:type type #:x (+ x 10) #:y y)))) + (let ((x (entity-ref ent #:x)) + (y (entity-ref ent #:y)) + (type (entity-ref ent #:type))) + (entity #:type type #:x (+ x 10) #:y y)))) (scene2 (scene-map-entities scene move-right))) (test "original scene unchanged" - 100 - (entity-ref (car (scene-entities scene)) #:x)) + 100 + (entity-ref (car (scene-entities scene)) #:x)) (test "first entity moved right" - 110 - (entity-ref (car (scene-entities scene2)) #:x)) + 110 + (entity-ref (car (scene-entities scene2)) #:x)) (test "second entity moved right" - 210 - (entity-ref (cadr (scene-entities scene2)) #:x)) + 210 + (entity-ref (cadr (scene-entities scene2)) #:x)) (test "y values unchanged" - 100 - (entity-ref (car (scene-entities scene2)) #:y)))) + 100 + (entity-ref (car (scene-entities scene2)) #:y)))) ;; Test: scene-map-entities with identity function (test-group "scene-map-entities-identity" @@ -193,8 +193,8 @@ (test "entity count unchanged" 2 (length (scene-entities scene2))) (test "first entity unchanged" - 100 - (entity-ref (car (scene-entities scene2)) #:x)))) + 100 + (entity-ref (car (scene-entities scene2)) #:x)))) ;; Test: scene chaining (was mutation test) (test-group "scene-chaining" @@ -205,12 +205,12 @@ (test "entity added" 1 (length (scene-entities scene))) (let ((scene (scene-map-entities scene - (lambda (scene e) - (let ((x (entity-ref e #:x)) - (y (entity-ref e #:y)) - (type (entity-type e))) - (entity #:type type #:x (* x 2) #:y (* y 2) - #:width 16 #:height 16)))))) + (lambda (scene e) + (let ((x (entity-ref e #:x)) + (y (entity-ref e #:y)) + (type (entity-type e))) + (entity #:type type #:x (* x 2) #:y (* y 2) + #:width 16 #:height 16)))))) (test "entity x doubled" 20 (entity-ref (car (scene-entities scene)) #:x)) (test "entity y doubled" 40 (entity-ref (car (scene-entities scene)) #:y))))) @@ -235,75 +235,75 @@ (let* ((e1 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (e2 (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16)) (scene (make-scene entities: (list e1 e2) - tilemap: test-tilemap - camera: (make-camera x: 0 y: 0) - tileset-texture: #f - camera-target: #f)) + tilemap: test-tilemap + camera: (make-camera x: 0 y: 0) + tileset-texture: #f + camera-target: #f)) (scene2 (scene-filter-entities scene - (lambda (e) (eq? (entity-ref e #:type #f) 'player))))) + (lambda (e) (eq? (entity-ref e #:type #f) 'player))))) (test "original scene unchanged" 2 (length (scene-entities scene))) (test "keeps matching entities" 1 (length (scene-entities scene2))) (test "kept entity is player" - 'player - (entity-ref (car (scene-entities scene2)) #:type #f)))) - - (test-group "camera-follow" - (let* ((cam (make-camera x: 0 y: 0)) - (ent (entity #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) - (cam2 (camera-follow cam ent 600 400))) - (test "original camera unchanged" 0 (camera-x cam)) - (test "centers camera x on entity" 100 (camera-x cam2)) - (test "centers camera y on entity" 100 (camera-y cam2))) - (let* ((cam (make-camera x: 0 y: 0)) - (ent (entity #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) - (cam2 (camera-follow cam ent 600 400))) - (test "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) - (test "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) - - (test-group "scene-find-tagged" - (let* ((p (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player))) - (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy npc))) - (s (make-scene entities: (list p e) tilemap: #f - camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) - (test "finds entity with matching tag" p (scene-find-tagged s 'player)) - (test "finds enemy by 'enemy tag" e (scene-find-tagged s 'enemy)) - (test "finds entity with second tag in list" e (scene-find-tagged s 'npc)) - (test "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) - - (test-group "scene-find-all-tagged" - (let* ((p1 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player friendly))) - (p2 (entity #:type 'ally #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(ally friendly))) - (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy))) - (s (make-scene entities: (list p1 p2 e) tilemap: #f - camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) - (test "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) - (test "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) - - (test-group "sync-groups" - (let* ((gid 'g1) - (origin (entity #:type 'group-origin #:group-origin? #t #:group-id gid - #:x 100 #:y 200 #:width 0 #:height 0)) - (m1 (entity #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0 - #:x 0 #:y 0 #:width 8 #:height 8)) - (m2 (entity #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7 - #:x 0 #:y 0 #:width 8 #:height 8)) - (entities (list origin m1 m2)) - (result (sync-groups entities))) - (test "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) - (test "member 1 follows origin" 105 (entity-ref (list-ref result 1) #:x)) - (test "member 1 y" 200 (entity-ref (list-ref result 1) #:y)) - (test "member 2 x" 100 (entity-ref (list-ref result 2) #:x)) - (test "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) - - (test-group "scene-transform-entities" - (let* ((e1 (entity #:type 'a #:x 1)) - (e2 (entity #:type 'b #:x 2)) - (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) - (scene2 (scene-transform-entities scene reverse))) - (test "transforms entity list" 'b - (entity-type (car (scene-entities scene2)))) - (test "original scene unchanged" 'a - (entity-type (car (scene-entities scene)))))) + 'player + (entity-ref (car (scene-entities scene2)) #:type #f)))) + +(test-group "camera-follow" + (let* ((cam (make-camera x: 0 y: 0)) + (ent (entity #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) + (test "original camera unchanged" 0 (camera-x cam)) + (test "centers camera x on entity" 100 (camera-x cam2)) + (test "centers camera y on entity" 100 (camera-y cam2))) + (let* ((cam (make-camera x: 0 y: 0)) + (ent (entity #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) + (test "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) + (test "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) + +(test-group "scene-find-tagged" + (let* ((p (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player))) + (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy npc))) + (s (make-scene entities: (list p e) tilemap: #f + camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) + (test "finds entity with matching tag" p (scene-find-tagged s 'player)) + (test "finds enemy by 'enemy tag" e (scene-find-tagged s 'enemy)) + (test "finds entity with second tag in list" e (scene-find-tagged s 'npc)) + (test "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) + +(test-group "scene-find-all-tagged" + (let* ((p1 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player friendly))) + (p2 (entity #:type 'ally #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(ally friendly))) + (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy))) + (s (make-scene entities: (list p1 p2 e) tilemap: #f + camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) + (test "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) + (test "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) + +(test-group "sync-groups" + (let* ((gid 'g1) + (origin (entity #:type 'group-origin #:group-origin? #t #:group-id gid + #:x 100 #:y 200 #:width 0 #:height 0)) + (m1 (entity #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0 + #:x 0 #:y 0 #:width 8 #:height 8)) + (m2 (entity #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7 + #:x 0 #:y 0 #:width 8 #:height 8)) + (entities (list origin m1 m2)) + (result (sync-groups entities))) + (test "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) + (test "member 1 follows origin" 105 (entity-ref (list-ref result 1) #:x)) + (test "member 1 y" 200 (entity-ref (list-ref result 1) #:y)) + (test "member 2 x" 100 (entity-ref (list-ref result 2) #:x)) + (test "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) + +(test-group "scene-transform-entities" + (let* ((e1 (entity #:type 'a #:x 1)) + (e2 (entity #:type 'b #:x 2)) + (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) + (scene2 (scene-transform-entities scene reverse))) + (test "transforms entity list" 'b + (entity-type (car (scene-entities scene2)))) + (test "original scene unchanged" 'a + (entity-type (car (scene-entities scene)))))) (test-end "world-module") (test-exit) |