diff options
| author | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:52:41 +0100 |
|---|---|---|
| committer | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:52:41 +0100 |
| commit | a02b892e2ad1e1605ff942c63afdd618daa48be4 (patch) | |
| tree | 7ccd9278a0cdc7fd2f156b0b4710f6ac00acab27 | |
| parent | 8251c85a4a588504d38a2fad05e4b0fe1cdccb9d (diff) | |
Migrate tests to the test egg
| -rw-r--r-- | Makefile | 13 | ||||
| -rw-r--r-- | downstroke.egg | 1 | ||||
| -rw-r--r-- | tests/animation-test.scm | 49 | ||||
| -rw-r--r-- | tests/assets-test.scm | 13 | ||||
| -rw-r--r-- | tests/engine-test.scm | 69 | ||||
| -rw-r--r-- | tests/entity-test.scm | 75 | ||||
| -rw-r--r-- | tests/input-test.scm | 57 | ||||
| -rw-r--r-- | tests/physics-test.scm | 241 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 71 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 43 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 13 | ||||
| -rw-r--r-- | tests/tilemap-test.scm | 91 | ||||
| -rw-r--r-- | tests/tween-test.scm | 85 | ||||
| -rw-r--r-- | tests/world-test.scm | 113 |
14 files changed, 479 insertions, 455 deletions
@@ -37,7 +37,7 @@ bin/%.o: %.scm | bin csc -c -J -unit downstroke-$* $*.scm -o bin/$*.o -I bin @if [ -f downstroke-$*.import.scm ]; then mv downstroke-$*.import.scm bin/; fi -.PHONY: clean test engine demos +.PHONY: clean test engine demos filter clean: rm -rf bin downstroke/ @@ -59,6 +59,17 @@ test: @csi -s tests/scene-loader-test.scm @csi -s tests/tween-test.scm +# Run a single test file with optional name/group filtering (pytest -k style). +# make filter FILE=tests/physics-test.scm # whole file +# make filter FILE=tests/physics-test.scm K=gravity # tests matching regex +# make filter FILE=tests/physics-test.scm G=apply # groups matching regex +# Note: combining K/G with TEST_QUIET=1 hits a known bug in the `test` egg +# (modulo error in summary timing), so this target intentionally doesn't +# expose Q. Use `TEST_QUIET=1 csi -s <file>` directly when you want quiet. +filter: + @if [ -z "$(FILE)" ]; then echo "usage: make filter FILE=<test.scm> [K=name-regex] [G=group-regex]"; exit 2; fi + @$(if $(K),TEST_FILTER='$(K)') $(if $(G),TEST_GROUP_FILTER='$(G)') csi -s $(FILE) + demos: engine $(DEMO_BINS) bin/demo-%: demo/%.scm $(OBJECT_FILES) | bin diff --git a/downstroke.egg b/downstroke.egg index 516eed3..c069e85 100644 --- a/downstroke.egg +++ b/downstroke.egg @@ -4,6 +4,7 @@ (license "BSD-2-Clause") (category games) (dependencies sdl2 sdl2-image sdl2-ttf expat defstruct srfi-1 srfi-13 srfi-69 srfi-197 matchable simple-logger list-utils) + (test-dependencies test) (components (extension downstroke-entity (source "entity.scm")) diff --git a/tests/animation-test.scm b/tests/animation-test.scm index aae829a..adf534f 100644 --- a/tests/animation-test.scm +++ b/tests/animation-test.scm @@ -1,4 +1,4 @@ -(import srfi-64 +(import test (only (list-utils alist) plist->alist)) (include "entity.scm") (include "tilemap.scm") @@ -14,59 +14,60 @@ (test-group "frame->tile-id" (test-group "tile IDs only" - (test-equal "first frame, frames (0)" 0 (frame->tile-id '(0) 0)) - (test-equal "wraps around" 0 (frame->tile-id '(0 1) 2)) - (test-equal "frame 1 of (27 28)" 28 (frame->tile-id '(27 28) 1))) + (test "first frame, frames (0)" 0 (frame->tile-id '(0) 0)) + (test "wraps around" 0 (frame->tile-id '(0 1) 2)) + (test "frame 1 of (27 28)" 28 (frame->tile-id '(27 28) 1))) (test-group "tile IDs and durations" - (test-equal "first frame, frames (0)" 0 (frame->tile-id '((0 10)) 0)) - (test-equal "wraps around" 0 (frame->tile-id '((0 10) (1 10)) 2)) - (test-equal "frame 1 of (27 28)" 28 (frame->tile-id '((27 10) (28 10)) 1)))) + (test "first frame, frames (0)" 0 (frame->tile-id '((0 10)) 0)) + (test "wraps around" 0 (frame->tile-id '((0 10) (1 10)) 2)) + (test "frame 1 of (27 28)" 28 (frame->tile-id '((27 10) (28 10)) 1)))) (test-group "frame->duration" - (test-equal "first frame, frames (0)" 100 (frame->duration '((0 100)) 0)) - (test-equal "wraps around" 100 (frame->duration '((0 100) (1 200)) 2)) - (test-equal "frame 1 of (27 28)" 200 (frame->duration '((27 100) (28 200)) 1)) + (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))) - (test-equal "no-op if already active" e (set-animation e 'idle)) + (test "no-op if already active" e (set-animation e 'idle)) (let ((switched (set-animation e 'walk))) - (test-equal "switches anim-name" 'walk (entity-ref switched #:anim-name)) - (test-equal "resets frame" 0 (entity-ref switched #:anim-frame)) - (test-equal "resets tick" 0 (entity-ref switched #:anim-tick))))) + (test "switches anim-name" 'walk (entity-ref switched #:anim-name)) + (test "resets frame" 0 (entity-ref switched #:anim-frame)) + (test "resets tick" 0 (entity-ref switched #:anim-tick))))) (test-group "animate-entity" (test-group "Single frames" (let* ((anims (list (anim #:name 'walk #:frames '(2 3) #:duration 4))) (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0)) (stepped (animate-entity e anims))) - (test-equal "increments tick" 1 (entity-ref stepped #:anim-tick)) - (test-equal "sets tile-id on first tick" 2 (entity-ref stepped #:tile-id))) + (test "increments tick" 1 (entity-ref stepped #:anim-tick)) + (test "sets tile-id on first tick" 2 (entity-ref stepped #:tile-id))) (let* ((anims (list (anim #:name 'walk #:frames '(0 1) #:duration 2))) (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 1)) (advanced (animate-entity e anims))) - (test-equal "advances frame when tick reaches duration" 1 (entity-ref advanced #:anim-frame)) - (test-equal "resets tick on frame advance" 0 (entity-ref advanced #:anim-tick)))) + (test "advances frame when tick reaches duration" 1 (entity-ref advanced #:anim-frame)) + (test "resets tick on frame advance" 0 (entity-ref advanced #:anim-tick)))) (test-group "Frames with duration" (let* ((anims (list (anim #:name 'walk #:frames '((0 10) (1 20)) #:duration 4))) (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 9)) (stepped (animate-entity e anims))) - (test-equal "ticks resets on frame switch" 0 (entity-ref stepped #:anim-tick)) - (test-equal "sets tile-id on 10th tick" 1 (entity-ref stepped #:tile-id)) - (test-equal "sets duration to frame duration" 20 (entity-ref stepped #:duration)))) + (test "ticks resets on frame switch" 0 (entity-ref stepped #:anim-tick)) + (test "sets tile-id on 10th tick" 1 (entity-ref stepped #:tile-id)) + (test "sets duration to frame duration" 20 (entity-ref stepped #:duration)))) (test-group "Empty" (let* ((e (entity #:type 'player))) - (test-equal "unchanged entity without anim-name" e (animate-entity e '()))))) + (test "unchanged entity without anim-name" e (animate-entity e '()))))) (test-group "animation pipeline" (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))) - (test-equal "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick))) + (test "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick))) (let* ((e (entity #:type 'static)) (stepped-entity (apply-animation #f e 10))) - (test-equal "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick))))) + (test "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick))))) (test-end "animation") +(test-exit) diff --git a/tests/assets-test.scm b/tests/assets-test.scm index c7b26f0..348cea0 100644 --- a/tests/assets-test.scm +++ b/tests/assets-test.scm @@ -1,4 +1,4 @@ -(import srfi-64) +(import test) (include "assets.scm") (import downstroke-assets) @@ -11,26 +11,27 @@ (test-group "asset-set! and asset-ref" (let ((reg (make-asset-registry))) - (test-equal "missing key returns #f" + (test "missing key returns #f" #f (asset-ref reg 'missing)) (asset-set! reg 'my-tilemap "data") - (test-equal "stored value is retrievable" + (test "stored value is retrievable" "data" (asset-ref reg 'my-tilemap)) (asset-set! reg 'my-tilemap "updated") - (test-equal "overwrite replaces value" + (test "overwrite replaces value" "updated" (asset-ref reg 'my-tilemap)) (asset-set! reg 'other 42) - (test-equal "multiple keys coexist" + (test "multiple keys coexist" "updated" (asset-ref reg 'my-tilemap)) - (test-equal "second key retrievable" + (test "second key retrievable" 42 (asset-ref reg 'other)))) (test-end "assets") +(test-exit) diff --git a/tests/engine-test.scm b/tests/engine-test.scm index aa44964..40a02ad 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -1,4 +1,4 @@ -(import scheme (chicken base) (chicken keyword) srfi-64 defstruct (srfi 69)) +(import scheme (chicken base) (chicken keyword) test defstruct (srfi 69)) ;; --- Mocks --- @@ -149,61 +149,61 @@ (test-group "make-game defaults" (let ((g (make-game))) - (test-equal "default title" + (test "default title" "Downstroke Game" (game-title g)) - (test-equal "default width" + (test "default width" 640 (game-width g)) - (test-equal "default height" + (test "default height" 480 (game-height g)) - (test-equal "default frame-delay" + (test "default frame-delay" 16 (game-frame-delay g)) - (test-equal "scene starts as #f" + (test "scene starts as #f" #f (game-scene g)) - (test-equal "window starts as #f" + (test "window starts as #f" #f (game-window g)) - (test-equal "renderer starts as #f" + (test "renderer starts as #f" #f (game-renderer g)) (test-assert "assets registry is created" (game-assets g)) (test-assert "input state is created" (game-input g)) - (test-equal "debug? defaults to #f" + (test "debug? defaults to #f" #f (game-debug? g)) - (test-equal "scale defaults to 1" + (test "scale defaults to 1" 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))) - (test-equal "custom title" "My Game" (game-title g)) - (test-equal "custom width" 320 (game-width g)) - (test-equal "custom height" 240 (game-height g)) - (test-equal "custom frame-delay" 33 (game-frame-delay g)))) + (test "custom title" "My Game" (game-title g)) + (test "custom width" 320 (game-width g)) + (test "custom height" 240 (game-height g)) + (test "custom frame-delay" 33 (game-frame-delay g)))) (test-group "make-game debug? keyword" - (test-equal "debug? defaults to #f" + (test "debug? defaults to #f" #f (game-debug? (make-game))) - (test-equal "debug? can be set to #t" + (test "debug? can be set to #t" #t (game-debug? (make-game debug?: #t)))) (test-group "make-game scale keyword" - (test-equal "scale defaults to 1" + (test "scale defaults to 1" 1 (game-scale (make-game))) - (test-equal "scale can be set to 2" + (test "scale can be set to 2" 2 (game-scale (make-game scale: 2))) - (test-equal "scale can be set to 3" + (test "scale can be set to 3" 3 (game-scale (make-game scale: 3))) (import (chicken condition)) @@ -222,24 +222,24 @@ (test-group "game-asset and game-asset-set!" (let ((g (make-game))) - (test-equal "missing key returns #f" + (test "missing key returns #f" #f (game-asset g 'no-such-asset)) (game-asset-set! g 'my-font 'font-object) - (test-equal "stored asset is retrievable" + (test "stored asset is retrievable" 'font-object (game-asset g 'my-font)) (game-asset-set! g 'my-font 'updated-font) - (test-equal "overwrite replaces asset" + (test "overwrite replaces asset" 'updated-font (game-asset g 'my-font)))) (test-group "make-game hooks default to #f" (let ((g (make-game))) - (test-equal "preload-hook is #f" #f (game-preload-hook g)) - (test-equal "create-hook is #f" #f (game-create-hook g)) - (test-equal "update-hook is #f" #f (game-update-hook g)) - (test-equal "render-hook is #f" #f (game-render-hook g)))) + (test "preload-hook is #f" #f (game-preload-hook g)) + (test "create-hook is #f" #f (game-create-hook g)) + (test "update-hook is #f" #f (game-update-hook g)) + (test "render-hook is #f" #f (game-render-hook g)))) (test-group "make-game accepts hook lambdas" (let* ((called #f) @@ -258,7 +258,7 @@ background: #f)) (g (make-game))) (game-scene-set! g scene) - (test-equal "returns scene camera" + (test "returns scene camera" cam (game-camera g)))) @@ -270,8 +270,8 @@ (test-assert "state has update hook" (state-hook s #:update)) (test-assert "state has render hook" (state-hook s #:render))) (let ((s (make-game-state))) - (test-equal "default state hooks are #f" #f (state-hook s #:create)) - (test-equal "default state update is #f" #f (state-hook s #:update)))) + (test "default state hooks are #f" #f (state-hook s #:create)) + (test "default state update is #f" #f (state-hook s #:update)))) (test-group "game-add-state! and game-start-state!" (let* ((created? #f) @@ -279,18 +279,18 @@ (state (make-game-state create: (lambda (g) (set! created? #t))))) (game-add-state! game 'play state) - (test-equal "active-state defaults to #f" #f (game-active-state game)) + (test "active-state defaults to #f" #f (game-active-state game)) (game-start-state! game 'play) - (test-equal "active-state set after start" 'play (game-active-state game)) + (test "active-state set after start" 'play (game-active-state game)) (test-assert "create hook called on start" created?))) (test-group "game states defaults" (let ((game (make-game))) (test-assert "states is a hash-table" (hash-table? (game-states game))) - (test-equal "active-state defaults to #f" #f (game-active-state game)))) + (test "active-state defaults to #f" #f (game-active-state game)))) (test-group "scene engine-update" - (test-equal "scene engine-update defaults to #f" + (test "scene engine-update defaults to #f" #f (scene-engine-update (make-scene entities: '() tilemap: #f camera-target: #f))) (let* ((my-eu (lambda (game dt) #t)) @@ -298,8 +298,9 @@ (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-equal "engine-update: 'none disables pipeline" + (test "engine-update: 'none disables pipeline" 'none (scene-engine-update s)))) (test-end "engine") +(test-exit) diff --git a/tests/entity-test.scm b/tests/entity-test.scm index d686acf..d56e115 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -1,4 +1,4 @@ -(import srfi-64) +(import test) (include "entity.scm") (import downstroke-entity) @@ -11,25 +11,25 @@ (#:y . 200) (#:width . 16) (#:height . 16)))) - (test-equal "retrieves type" 'player (entity-ref entity #:type)) - (test-equal "retrieves x" 100 (entity-ref entity #:x)) - (test-equal "retrieves y" 200 (entity-ref entity #:y)) - (test-equal "retrieves width" 16 (entity-ref entity #:width)) - (test-equal "retrieves height" 16 (entity-ref entity #:height))) + (test "retrieves type" 'player (entity-ref entity #:type)) + (test "retrieves x" 100 (entity-ref entity #:x)) + (test "retrieves y" 200 (entity-ref entity #:y)) + (test "retrieves width" 16 (entity-ref entity #:width)) + (test "retrieves height" 16 (entity-ref entity #:height))) ;; Test with default value (let ((entity '((#:type . player)))) - (test-equal "returns default for missing key" + (test "returns default for missing key" 99 (entity-ref entity #:x 99)) - (test-equal "returns #f as default if not specified" + (test "returns #f as default if not specified" #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-equal "calls procedure default when key missing" + (test "calls procedure default when key missing" 42 (entity-ref entity #:x (lambda () 42))))) @@ -37,20 +37,20 @@ (test-group "make-entity" (let ((player (make-entity 50 75 16 16))) (test-assert "returns a list" (list? player)) - (test-equal "has correct x" 50 (entity-ref player #:x)) - (test-equal "has correct y" 75 (entity-ref player #:y)) - (test-equal "has correct width" 16 (entity-ref player #:width)) - (test-equal "has correct height" 16 (entity-ref player #:height)))) + (test "has correct x" 50 (entity-ref player #:x)) + (test "has correct y" 75 (entity-ref player #:y)) + (test "has correct width" 16 (entity-ref player #:width)) + (test "has correct height" 16 (entity-ref player #:height)))) ;; Test: entity-type extracts type from entity (test-group "entity-type" (let ((player '((#:type . player) (#:x . 100))) (enemy '((#:type . enemy) (#:x . 200)))) - (test-equal "extracts player type" 'player (entity-type player)) - (test-equal "extracts enemy type" 'enemy (entity-type enemy))) + (test "extracts player type" 'player (entity-type player)) + (test "extracts enemy type" 'enemy (entity-type enemy))) (let ((no-type '((#:x . 100) (#:y . 200)))) - (test-equal "returns #f for entity without type" + (test "returns #f for entity without type" #f (entity-type no-type)))) @@ -64,49 +64,49 @@ (#:health . 50) (#:speed . 2.5) (#:ai-state . patrol)))) - (test-equal "retrieves numeric property" 50 (entity-ref entity #:health)) - (test-equal "retrieves float property" 2.5 (entity-ref entity #:speed)) - (test-equal "retrieves symbol property" 'patrol (entity-ref entity #:ai-state)))) + (test "retrieves numeric property" 50 (entity-ref entity #:health)) + (test "retrieves float property" 2.5 (entity-ref entity #:speed)) + (test "retrieves symbol property" 'patrol (entity-ref entity #:ai-state)))) ;; Test: entity-set updates entity properties (test-group "entity-set" (test-group "existing key is replaced" (let ((e (entity-set '((#:x . 10) (#:y . 20)) #:x 15))) - (test-equal "value updated" 15 (entity-ref e #:x)) - (test-equal "other key untouched" 20 (entity-ref e #:y)) + (test "value updated" 15 (entity-ref e #:x)) + (test "other key untouched" 20 (entity-ref e #:y)) ;; alist length stays at 2 (one pair removed, one added) — not 3. - (test-equal "no duplicate key: list length unchanged" 2 (length e)))) + (test "no duplicate key: list length unchanged" 2 (length e)))) (test-group "new key is added" (let ((e (entity-set '((#:x . 10)) #:vx 3))) - (test-equal "new key present" 3 (entity-ref e #:vx)) - (test-equal "existing key untouched" 10 (entity-ref e #:x)) - (test-equal "list grows by one pair" 2 (length e))))) + (test "new key present" 3 (entity-ref e #:vx)) + (test "existing key untouched" 10 (entity-ref e #:x)) + (test "list grows by one pair" 2 (length e))))) (test-group "entity-set-many" (test-group "Set multiple entities with cons" (let ((e (entity-set-many '((#:x . 10) (#:y . 20)) '((#:x . 15) (#:y . 25))))) - (test-equal "value x updated" 15 (entity-ref e #:x)) - (test-equal "value y updated" 25 (entity-ref e #:y))))) + (test "value x updated" 15 (entity-ref e #:x)) + (test "value y updated" 25 (entity-ref e #:y))))) ;; Test: entity-update applies transformations (test-group "entity-update" (test-group "transform existing value" (let ((e (entity-update '((#:x . 10) (#:y . 20)) #:x (lambda (v) (+ v 5))))) - (test-equal "#:x is 15" 15 (entity-ref e #:x)) - (test-equal "#:y is 20" 20 (entity-ref e #:y)))) + (test "#:x is 15" 15 (entity-ref e #:x)) + (test "#:y is 20" 20 (entity-ref e #:y)))) (test-group "missing key uses default" (let ((e (entity-update '((#:x . 10)) #:health (lambda (v) (+ v 1)) 0))) - (test-equal "#:health is 1" 1 (entity-ref e #:health)))) + (test "#:health is 1" 1 (entity-ref e #:health)))) (test-group "missing key without default" (let ((e (entity-update '((#:x . 10)) #:z (lambda (v) v)))) - (test-equal "#:z is #f" #f (entity-ref e #:z)))) + (test "#:z is #f" #f (entity-ref e #:z)))) (test-group "no duplicate keys" (let ((e (entity-update '((#:x . 10) (#:y . 20)) #:x (lambda (v) (* v 2))))) - (test-equal "length is 2" 2 (length e))))) + (test "length is 2" 2 (length e))))) (test-group "entity-skips-pipeline?" (test-assert "absent skip list" @@ -123,9 +123,9 @@ (test-group "define-pipeline" (let ((e '((#:type . t) (#:x . 0)))) - (test-equal "runs body" 42 (entity-ref (fixture-pipeline #f e 0) #:x))) + (test "runs body" 42 (entity-ref (fixture-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0) (#:skip-pipelines . (fixture-skip))))) - (test-equal "skipped" 0 (entity-ref (fixture-pipeline #f e 0) #:x)))) + (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) @@ -133,13 +133,14 @@ (test-group "define-pipeline with guard:" (let ((e '((#:type . t) (#:x . 0) (#:active? . #t)))) - (test-equal "runs body when guard passes" 99 + (test "runs body when guard passes" 99 (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0)))) - (test-equal "returns entity unchanged when guard fails" 0 + (test "returns entity unchanged when guard fails" 0 (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0) (#:active? . #t) (#:skip-pipelines . (guarded-skip))))) - (test-equal "skip-pipelines takes precedence over guard" 0 + (test "skip-pipelines takes precedence over guard" 0 (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 bbc5599..50395d8 100644 --- a/tests/input-test.scm +++ b/tests/input-test.scm @@ -7,7 +7,7 @@ (only srfi-197 chain) (prefix sdl2 sdl2:) simple-logger - srfi-64 + test defstruct) ;; Load entity first (input imports it) @@ -35,20 +35,20 @@ (test-assert "has previous field" (list? (input-state-previous state))) ;; All actions should be initialized to #f - (test-equal "up action is false" #f (input-held? state 'up)) - (test-equal "down action is false" #f (input-held? state 'down)) - (test-equal "left action is false" #f (input-held? state 'left)) - (test-equal "right action is false" #f (input-held? state 'right)) - (test-equal "a action is false" #f (input-held? state 'a)) - (test-equal "b action is false" #f (input-held? state 'b)) - (test-equal "start action is false" #f (input-held? state 'start)) - (test-equal "quit action is false" #f (input-held? state 'quit)))) + (test "up action is false" #f (input-held? state 'up)) + (test "down action is false" #f (input-held? state 'down)) + (test "left action is false" #f (input-held? state 'left)) + (test "right action is false" #f (input-held? state 'right)) + (test "a action is false" #f (input-held? state 'a)) + (test "b action is false" #f (input-held? state 'b)) + (test "start action is false" #f (input-held? state 'start)) + (test "quit action is false" #f (input-held? state 'quit)))) ;; Test: input-held? query (test-group "input-held?" (let ((state (create-input-state *default-input-config*))) - (test-equal "returns false for unheld action" #f (input-held? state 'up)) - (test-equal "returns false for unknown action" #f (input-held? state 'unknown)))) + (test "returns false for unheld action" #f (input-held? state 'up)) + (test "returns false for unknown action" #f (input-held? state 'unknown)))) ;; Test: input-pressed? detection (test-group "input-pressed?" @@ -59,7 +59,7 @@ (input-state-current state1)))) ;; In state1, up is not pressed - (test-equal "not pressed in initial state" #f (input-pressed? state1 'up)) + (test "not pressed in initial state" #f (input-pressed? state1 'up)) ;; In state2, up is held but was not held before -> pressed (test-assert "pressed when current=#t and previous=#f" @@ -77,14 +77,14 @@ (cons (cons 'up #f) (input-state-current state1)) (cons (cons 'up #t) (input-state-current state1))))) - (test-equal "not released when held" #f (input-released? state-held 'up)) + (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)))) ;; Test: input-any-pressed? (test-group "input-any-pressed?" (let ((state1 (create-input-state *default-input-config*))) - (test-equal "no actions pressed in initial state" + (test "no actions pressed in initial state" #f (input-any-pressed? state1 *default-input-config*)))) @@ -109,7 +109,7 @@ (input-state-current state1)))) ;; Verify transition from not-held to held = pressed - (test-equal "up not held in state1" #f (input-held? state1 'up)) + (test "up not held in state1" #f (input-held? state1 'up)) (test-assert "up held in state2" (input-held? state2 'up)) (test-assert "up pressed in state2" (input-pressed? state2 'up)) @@ -118,7 +118,7 @@ (input-state-current state2) (input-state-current state2)))) (test-assert "up still held in state3" (input-held? state3 'up)) - (test-equal "up not pressed in state3 (already was pressed)" + (test "up not pressed in state3 (already was pressed)" #f (input-pressed? state3 'up))))) @@ -132,40 +132,40 @@ (test-group "no input-map: entity unchanged" (let* ((e (entity #:type 'player #:x 5 #:y 10)) (out (apply-input-to-entity e (lambda (a) #f)))) - (test-equal "entity returned as-is" e out))) + (test "entity returned as-is" e (begin out)))) (test-group "no actions held: velocity is zero" (let* ((e (make-physics-entity)) (out (apply-input-to-entity e (lambda (a) #f)))) - (test-equal "vx is 0" 0 (entity-ref out #:vx)) - (test-equal "vy is 0" 0 (entity-ref out #:vy)))) + (test "vx is 0" 0 (entity-ref out #:vx)) + (test "vy is 0" 0 (entity-ref out #:vy)))) (test-group "right held: vx=2 vy=0" (let* ((e (make-physics-entity)) (out (apply-input-to-entity e (lambda (a) (eq? a 'right))))) - (test-equal "vx is 2" 2 (entity-ref out #:vx)) - (test-equal "vy is 0" 0 (entity-ref out #:vy)))) + (test "vx is 2" 2 (entity-ref out #:vx)) + (test "vy is 0" 0 (entity-ref out #:vy)))) (test-group "right+down held: vx=2 vy unchanged" (let* ((e (make-physics-entity)) (out (apply-input-to-entity e (lambda (a) (memv a '(right down)))))) - (test-equal "vx is 2" 2 (entity-ref out #:vx)) - (test-equal "vy is unchanged (input handler does not set vy)" 0 (entity-ref out #:vy)))) + (test "vx is 2" 2 (entity-ref out #:vx)) + (test "vy is unchanged (input handler does not set vy)" 0 (entity-ref out #:vy)))) (test-group "right held: facing set to 1" (let* ((e (make-physics-entity)) (out (apply-input-to-entity e (lambda (a) (eq? a 'right))))) - (test-equal "facing is 1" 1 (entity-ref out #:facing 0)))) + (test "facing is 1" 1 (entity-ref out #:facing 0)))) (test-group "left held: facing set to -1" (let* ((e (make-physics-entity)) (out (apply-input-to-entity e (lambda (a) (eq? a 'left))))) - (test-equal "facing is -1" -1 (entity-ref out #:facing 0)))) + (test "facing is -1" -1 (entity-ref out #:facing 0)))) (test-group "no key held: facing retains previous value" (let* ((e (entity-set (make-physics-entity) #:facing 1)) (out (apply-input-to-entity e (lambda (a) #f)))) - (test-equal "facing stays 1 when vx=0" 1 (entity-ref out #:facing 0))))) + (test "facing stays 1 when vx=0" 1 (entity-ref out #:facing 0))))) (test-group "custom-input-config" (let* ((cfg (make-input-config @@ -178,7 +178,8 @@ deadzone: 8000)) (state (create-input-state cfg))) (test-assert "custom config creates valid state" (input-state? state)) - (test-equal "jump is false" #f (input-held? state 'jump)) - (test-equal "shoot is false" #f (input-held? state 'shoot)))) + (test "jump is false" #f (input-held? state 'jump)) + (test "shoot is false" #f (input-held? state 'shoot)))) (test-end "input-module") +(test-exit) diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 4ab4b17..76b480c 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -3,7 +3,7 @@ (chicken base) (chicken keyword) defstruct - srfi-64 + test (only srfi-1 every member make-list fold iota)) ;; Create a mock tilemap module to avoid SDL dependency @@ -92,102 +92,102 @@ (test-group "gravity? true, vy starts at 0" (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t)) (result (apply-gravity #f e 0))) - (test-equal "vy increased by gravity" *gravity* (entity-ref result #:vy)) - (test-equal "x unchanged" 0 (entity-ref result #:x)) - (test-equal "y unchanged" 0 (entity-ref result #:y)) - (test-equal "vx unchanged" 0 (entity-ref result #:vx)))) + (test "vy increased by gravity" *gravity* (entity-ref result #:vy)) + (test "x unchanged" 0 (entity-ref result #:x)) + (test "y unchanged" 0 (entity-ref result #:y)) + (test "vx unchanged" 0 (entity-ref result #:vx)))) (test-group "gravity? true, vy already has value" (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 3 #:gravity? #t)) (result (apply-gravity #f e 0))) - (test-equal "vy increased by gravity" 4 (entity-ref result #:vy)))) + (test "vy increased by gravity" 4 (entity-ref result #:vy)))) (test-group "gravity? false" (let* ((e (entity #:type 'static #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #f)) (result (apply-gravity #f e 0))) - (test-equal "vy unchanged" 0 (entity-ref result #:vy)))) + (test "vy unchanged" 0 (entity-ref result #:vy)))) (test-group "no gravity? field at all" (let* ((e (entity #:type 'static #:x 5 #:y 5)) (result (apply-gravity #f e 0))) - (test-equal "entity unchanged" e result)))) + (test "entity unchanged" e (begin result))))) (test-group "apply-velocity-x" (test-group "basic horizontal movement" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 5 #:vy -2)) (result (apply-velocity-x #f e 0))) - (test-equal "x moved by vx" 15 (entity-ref result #:x)) - (test-equal "y unchanged" 20 (entity-ref result #:y)) - (test-equal "vy unchanged" -2 (entity-ref result #:vy)))) + (test "x moved by vx" 15 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y)) + (test "vy unchanged" -2 (entity-ref result #:vy)))) (test-group "zero vx" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 0 #:vy 3)) (result (apply-velocity-x #f e 0))) - (test-equal "x unchanged" 10 (entity-ref result #:x)) - (test-equal "y unchanged" 20 (entity-ref result #:y))))) + (test "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y))))) (test-group "apply-velocity-y" (test-group "basic vertical movement" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy -5)) (result (apply-velocity-y #f e 0))) - (test-equal "x unchanged" 10 (entity-ref result #:x)) - (test-equal "y moved by vy" 15 (entity-ref result #:y)) - (test-equal "vx unchanged" 3 (entity-ref result #:vx)))) + (test "x unchanged" 10 (entity-ref result #:x)) + (test "y moved by vy" 15 (entity-ref result #:y)) + (test "vx unchanged" 3 (entity-ref result #:vx)))) (test-group "zero vy" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy 0)) (result (apply-velocity-y #f e 0))) - (test-equal "x unchanged" 10 (entity-ref result #:x)) - (test-equal "y unchanged" 20 (entity-ref result #:y))))) + (test "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y))))) (test-group "apply-velocity" (test-group "basic movement" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy -2)) (result (apply-velocity e))) - (test-equal "x moved by vx" 13 (entity-ref result #:x)) - (test-equal "y moved by vy" 18 (entity-ref result #:y)))) + (test "x moved by vx" 13 (entity-ref result #:x)) + (test "y moved by vy" 18 (entity-ref result #:y)))) (test-group "zero velocity" (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 0 #:vy 0)) (result (apply-velocity e))) - (test-equal "x unchanged" 10 (entity-ref result #:x)) - (test-equal "y unchanged" 20 (entity-ref result #:y)))) + (test "x unchanged" 10 (entity-ref result #:x)) + (test "y unchanged" 20 (entity-ref result #:y)))) (test-group "no velocity fields (defaults to 0)" (let* ((e (entity #:type 'static #:x 5 #:y 5)) (result (apply-velocity e))) - (test-equal "x unchanged" 5 (entity-ref result #:x)) - (test-equal "y unchanged" 5 (entity-ref result #:y))))) + (test "x unchanged" 5 (entity-ref result #:x)) + (test "y unchanged" 5 (entity-ref result #:y))))) (test-group "build-cell-list" (test-group "single cell" (let ((cells (build-cell-list 5 5 3 3))) - (test-equal "one cell" 1 (length cells)) - (test-equal "cell is pair" '(5 . 3) (car cells)))) + (test "one cell" 1 (length cells)) + (test "cell is pair" '(5 . 3) (car cells)))) (test-group "two columns one row" (let ((cells (build-cell-list 11 12 22 22))) - (test-equal "two cells" 2 (length cells)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "contains (11 . 22)" (member '(11 . 22) cells)) (test-assert "contains (12 . 22)" (member '(12 . 22) cells)))) (test-group "one column two rows" (let ((cells (build-cell-list 5 5 2 3))) - (test-equal "two cells" 2 (length cells)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "contains (5 . 2)" (member '(5 . 2) cells)) (test-assert "contains (5 . 3)" (member '(5 . 3) cells)))) (test-group "2x2 grid" (let ((cells (build-cell-list 0 1 0 1))) - (test-equal "four cells" 4 (length cells)) + (test "four cells" 4 (length cells)) (test-assert "all cells are pairs" (every pair? cells)) (test-assert "no #f in list" (not (member #f cells))))) (test-group "empty when col-start > col-end" (let ((cells (build-cell-list 5 4 0 0))) - (test-equal "empty list" '() cells))) + (test "empty list" '() (begin cells)))) (test-group "player-like values (x=182 y=352 w=16 h=16 tw=16 th=16)" (let* ((x 182) (y 352) (w 16) (h 16) (tw 16) (th 16) @@ -196,11 +196,11 @@ (row-start (inexact->exact (floor (/ y th)))) (row-end (inexact->exact (floor (/ (- (+ y h) 1) th)))) (cells (build-cell-list col-start col-end row-start row-end))) - (test-equal "col-start" 11 col-start) - (test-equal "col-end" 12 col-end) - (test-equal "row-start" 22 row-start) - (test-equal "row-end" 22 row-end) - (test-equal "two cells" 2 (length cells)) + (test "col-start" 11 (begin col-start)) + (test "col-end" 12 (begin col-end)) + (test "row-start" 22 (begin row-start)) + (test "row-end" 22 (begin row-end)) + (test "two cells" 2 (length cells)) (test-assert "all cells are pairs" (every pair? cells))))) (test-group "resolve-tile-collisions-x" @@ -208,100 +208,100 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 2 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "x unchanged" 0 (entity-ref result #:x)) - (test-equal "vx unchanged" 2 (entity-ref result #:vx))))) + (test "x unchanged" 0 (entity-ref result #:x)) + (test "vx unchanged" 2 (entity-ref result #:vx))))) (test-group "zero vx: skipped entirely" (let* ((tm (make-test-tilemap '((0 1 0) (0 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 0))) - (test-equal "entity eq? when vx=0" e (resolve-tile-collisions-x (test-scene tilemap: tm) e 0)))) + (test "entity eq? when vx=0" e (resolve-tile-collisions-x (test-scene tilemap: tm) e 0)))) (test-group "collision moving right: push left" ;; solid at col=1 (x=16..31); entity at x=20 overlaps it, vx>0 (let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0)))) (e (entity #:type 'player #:x 20 #:y 16 #:width 16 #:height 16 #:vx 5 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) - (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) + (test "pushed left of solid tile" 0 (entity-ref result #:x)) + (test "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "collision moving left: push right" ;; solid at col=1 (x=16..31); entity at x=16 overlaps it, vx<0 (let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0)))) (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx -5 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "pushed right of solid tile" 32 (entity-ref result #:x)) - (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) + (test "pushed right of solid tile" 32 (entity-ref result #:x)) + (test "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "floating-point x position" ;; solid at col=1; entity at x=20.5 (float), vx>0 (let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0)))) (e (entity #:type 'player #:x 20.5 #:y 16 #:width 16 #:height 16 #:vx 2 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) - (test-equal "vx zeroed" 0 (entity-ref result #:vx))))) + (test "pushed left of solid tile" 0 (entity-ref result #:x)) + (test "vx zeroed" 0 (entity-ref result #:vx))))) (test-group "entity spanning two columns: both checked" ;; wall at col=3; 20px-wide entity at x=28 spans cols 1 and 2, no collision (let* ((tm (make-test-tilemap '((0 0 0 1) (0 0 0 1) (0 0 0 1)))) (e (entity #:type 'player #:x 28 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "no collision yet" 28 (entity-ref result #:x)))) + (test "no collision yet" 28 (entity-ref result #:x)))) ;; entity moved to x=34 now spans cols 2 and 3 (solid), pushed left (let* ((tm (make-test-tilemap '((0 0 0 1) (0 0 0 1) (0 0 0 1)))) (e (entity #:type 'player #:x 34 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) - (test-equal "pushed left of wall" 28 (entity-ref result #:x)) - (test-equal "vx zeroed" 0 (entity-ref result #:vx)))))) + (test "pushed left of wall" 28 (entity-ref result #:x)) + (test "vx zeroed" 0 (entity-ref result #:vx)))))) (test-group "resolve-tile-collisions-y" (test-group "no collision: entity unchanged" (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "y unchanged" 0 (entity-ref result #:y)) - (test-equal "vy unchanged" 2 (entity-ref result #:vy))))) + (test "y unchanged" 0 (entity-ref result #:y)) + (test "vy unchanged" 2 (entity-ref result #:vy))))) (test-group "zero vy: skipped entirely" (let* ((tm (make-test-tilemap '((1 0 0) (0 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 0))) - (test-equal "entity eq? when vy=0" e (resolve-tile-collisions-y (test-scene tilemap: tm) e 0)))) + (test "entity eq? when vy=0" e (resolve-tile-collisions-y (test-scene tilemap: tm) e 0)))) (test-group "collision moving down: push up" ;; solid at row=1 (y=16..31); entity at y=20 overlaps it, vy>0 (let* ((tm (make-test-tilemap '((0 0 0) (1 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 20 #:width 16 #:height 16 #:vx 0 #:vy 5))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) - (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) + (test "pushed above solid tile" 0 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "collision moving up: push down" ;; solid at row=1 (y=16..31); entity at y=16 overlaps it from below, vy<0 (let* ((tm (make-test-tilemap '((0 0 0) (0 1 0) (0 0 0)))) (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy -5))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "pushed below solid tile" 32 (entity-ref result #:y)) - (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) + (test "pushed below solid tile" 32 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "floating-point y position" ;; solid at row=1; entity at y=20.5 (float), vy>0 (let* ((tm (make-test-tilemap '((0 0 0) (1 0 0) (0 0 0)))) (e (entity #:type 'player #:x 0 #:y 20.5 #:width 16 #:height 16 #:vx 0 #:vy 3))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) - (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) + (test "pushed above solid tile" 0 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) (test-group "entity spanning two rows: both checked" ;; floor at row=3; 20px-tall entity at y=28 spans rows 1 and 2, no collision (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1)))) (e (entity #:type 'player #:x 0 #:y 28 #:width 16 #:height 20 #:vx 0 #:vy 3))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "no collision yet" 28 (entity-ref result #:y)))) + (test "no collision yet" 28 (entity-ref result #:y)))) ;; entity at y=34 now spans rows 2 and 3 (solid), pushed up (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1)))) (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 20 #:vx 0 #:vy 3))) (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) - (test-equal "pushed above floor" 28 (entity-ref result #:y)) - (test-equal "vy zeroed" 0 (entity-ref result #:vy)))))) + (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. @@ -311,8 +311,8 @@ (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-equal "snapped to first solid row" 16 (entity-ref result #:y)) - (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) + (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" @@ -361,8 +361,8 @@ (let* ((a (make-solid 0 0 16 16)) (b (make-solid 100 0 16 16)) (result (resolve-entity-collisions (list a b)))) - (test-equal "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) - (test-equal "b x unchanged" 100 (entity-ref (list-ref result 1) #:x 0)))) + (test "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) + (test "b x unchanged" 100 (entity-ref (list-ref result 1) #:x 0)))) (test-group "horizontal overlap: pushed apart on x" ;; a at x=0, b at x=10, both 16x16 → overlap-x = (16+16)/2 - 10 = 6, overlap-y = (16+16)/2 - 0 = 16 @@ -372,8 +372,8 @@ (result (resolve-entity-collisions (list a b))) (ra (list-ref result 0)) (rb (list-ref result 1))) - (test-equal "a pushed left by 3" -3 (entity-ref ra #:x 0)) - (test-equal "b pushed right by 3" 13 (entity-ref rb #:x 0)))) + (test "a pushed left by 3" -3 (entity-ref ra #:x 0)) + (test "b pushed right by 3" 13 (entity-ref rb #:x 0)))) (test-group "vertical overlap: pushed apart on y" ;; a at y=0, b at y=10, both 16x16 → overlap-x=16, overlap-y=6 → push on y @@ -382,8 +382,8 @@ (result (resolve-entity-collisions (list a b))) (ra (list-ref result 0)) (rb (list-ref result 1))) - (test-equal "a pushed up by 3" -3 (entity-ref ra #:y 0)) - (test-equal "b pushed down by 3" 13 (entity-ref rb #:y 0)))) + (test "a pushed up by 3" -3 (entity-ref ra #:y 0)) + (test "b pushed down by 3" 13 (entity-ref rb #:y 0)))) (test-group "immovable: landing uses vertical separation when horizontal overlap is shallower" ;; Without the landing rule, ovx < ovy would pick horizontal separation and shove the @@ -394,15 +394,15 @@ #:solid? #t #:immovable? #f #:vx 0 #:vy 0)) (result (resolve-entity-collisions (list shelf box))) (box2 (list-ref result 1))) - (test-equal "box rests on shelf top (y = shelf_y - height)" 184 (entity-ref box2 #:y 0)) - (test-equal "vy zeroed" 0 (entity-ref box2 #:vy 0)))) + (test "box rests on shelf top (y = shelf_y - height)" 184 (entity-ref box2 #:y 0)) + (test "vy zeroed" 0 (entity-ref box2 #:vy 0)))) (test-group "non-solid entity ignored" (let* ((a (make-solid 0 0 16 16)) (b (entity #:type 'goal #:x 5 #:y 5 #:width 16 #:height 16)) (result (resolve-entity-collisions (list a b)))) - (test-equal "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) - (test-equal "b x unchanged" 5 (entity-ref (list-ref result 1) #:x 0))))) + (test "a x unchanged" 0 (entity-ref (list-ref result 0) #:x 0)) + (test "b x unchanged" 5 (entity-ref (list-ref result 1) #:x 0))))) ;; Tests for detect-on-solid (test-group "detect-on-solid" @@ -465,104 +465,104 @@ (test-group "gravity? #t, ay set: consumed into vy and cleared" (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t)) (result (apply-acceleration #f e 0))) - (test-equal "vy += ay" 8 (entity-ref result #:vy 0)) - (test-equal "ay cleared" 0 (entity-ref result #:ay 0)))) + (test "vy += ay" 8 (entity-ref result #:vy 0)) + (test "ay cleared" 0 (entity-ref result #:ay 0)))) (test-group "gravity? #t, ay is 0: vy unchanged" (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 0 #:gravity? #t)) (result (apply-acceleration #f e 0))) - (test-equal "vy unchanged" 3 (entity-ref result #:vy 0)) - (test-equal "ay still 0" 0 (entity-ref result #:ay 0)))) + (test "vy unchanged" 3 (entity-ref result #:vy 0)) + (test "ay still 0" 0 (entity-ref result #:ay 0)))) (test-group "gravity? #f: entity unchanged" (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #f)) (result (apply-acceleration #f e 0))) - (test-equal "entity unchanged" e result)))) + (test "entity unchanged" e (begin result))))) (test-group "pixel->tile" - (test-equal "pixel 0 in 16px tile → 0" 0 (pixel->tile 0 16)) - (test-equal "pixel 15 in 16px tile → 0" 0 (pixel->tile 15 16)) - (test-equal "pixel 16 in 16px tile → 1" 1 (pixel->tile 16 16)) - (test-equal "pixel 24 in 16px tile → 1" 1 (pixel->tile 24 16)) - (test-equal "pixel 24.7 in 16px tile → 1" 1 (pixel->tile 24.7 16)) - (test-equal "pixel 32 in 16px tile → 2" 2 (pixel->tile 32 16))) + (test "pixel 0 in 16px tile → 0" 0 (pixel->tile 0 16)) + (test "pixel 15 in 16px tile → 0" 0 (pixel->tile 15 16)) + (test "pixel 16 in 16px tile → 1" 1 (pixel->tile 16 16)) + (test "pixel 24 in 16px tile → 1" 1 (pixel->tile 24 16)) + (test "pixel 24.7 in 16px tile → 1" 1 (pixel->tile 24.7 16)) + (test "pixel 32 in 16px tile → 2" 2 (pixel->tile 32 16))) (test-group "entity-tile-cells" (test-group "entity aligned to one tile" (let* ((tm (make-test-tilemap '((0 0) (0 0)))) (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) - (test-equal "one cell" 1 (length cells)) - (test-equal "cell is (0 . 0)" '(0 . 0) (car cells)))) + (test "one cell" 1 (length cells)) + (test "cell is (0 . 0)" '(0 . 0) (car cells)))) (test-group "entity spanning 2 cols and 2 rows" (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) (e (entity #:type 'player #:x 8 #:y 8 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) - (test-equal "four cells" 4 (length cells))))) + (test "four cells" 4 (length cells))))) (test-group "tile-push-pos" (test-group "moving forward (v>0): snap leading edge to near side of tile" ;; coord=3, tile-size=16, entity-size=16 → 3*16 - 16 = 32 - (test-equal "push pos" 32 (tile-push-pos 1 3 16 16))) + (test "push pos" 32 (tile-push-pos 1 3 16 16))) (test-group "moving backward (v<0): snap trailing edge to far side of tile" ;; coord=3, tile-size=16 → (3+1)*16 = 64 - (test-equal "push pos" 64 (tile-push-pos -1 3 16 16)))) + (test "push pos" 64 (tile-push-pos -1 3 16 16)))) (test-group "list-set" - (test-equal "replace first" '(x b c) (list-set '(a b c) 0 'x)) - (test-equal "replace middle" '(a x c) (list-set '(a b c) 1 'x)) - (test-equal "replace last" '(a b x) (list-set '(a b c) 2 'x))) + (test "replace first" '(x b c) (list-set '(a b c) 0 'x)) + (test "replace middle" '(a x c) (list-set '(a b c) 1 'x)) + (test "replace last" '(a b x) (list-set '(a b c) 2 'x))) (test-group "index-pairs" - (test-equal "n=0: empty" '() (index-pairs 0)) - (test-equal "n=1: empty" '() (index-pairs 1)) - (test-equal "n=2: one pair" '((0 . 1)) (index-pairs 2)) + (test "n=0: empty" '() (index-pairs 0)) + (test "n=1: empty" '() (index-pairs 1)) + (test "n=2: one pair" '((0 . 1)) (index-pairs 2)) (test-group "n=3: three pairs" (let ((pairs (index-pairs 3))) - (test-equal "count" 3 (length pairs)) + (test "count" 3 (length pairs)) (test-assert "(0 . 1)" (member '(0 . 1) pairs)) (test-assert "(0 . 2)" (member '(0 . 2) pairs)) (test-assert "(1 . 2)" (member '(1 . 2) pairs))))) (test-group "axis->dimension" - (test-equal "#:x → #:width" #:width (axis->dimension #:x)) - (test-equal "#:y → #:height" #:height (axis->dimension #:y))) + (test "#:x → #:width" #:width (axis->dimension #:x)) + (test "#:y → #:height" #:height (axis->dimension #:y))) (test-group "axis->velocity" - (test-equal "#:x → #:vx" #:vx (axis->velocity #:x)) - (test-equal "#:y → #:vy" #:vy (axis->velocity #:y))) + (test "#:x → #:vx" #:vx (axis->velocity #:x)) + (test "#:y → #:vy" #:vy (axis->velocity #:y))) (test-group "push-entity" (test-group "push right (sign=1): x += overlap/2, vx=1" (let* ((e (entity #:type 'player #:x 10 #:y 0 #:vx 0 #:vy 0)) (result (push-entity e #:x #:vx 10 6 1))) - (test-equal "x = 10 + 3" 13 (entity-ref result #:x 0)) - (test-equal "vx = 1" 1 (entity-ref result #:vx 0)))) + (test "x = 10 + 3" 13 (entity-ref result #:x 0)) + (test "vx = 1" 1 (entity-ref result #:vx 0)))) (test-group "push left (sign=-1): x -= overlap/2, vx=-1" (let* ((e (entity #:type 'player #:x 10 #:y 0 #:vx 0 #:vy 0)) (result (push-entity e #:x #:vx 10 6 -1))) - (test-equal "x = 10 - 3" 7 (entity-ref result #:x 0)) - (test-equal "vx = -1" -1 (entity-ref result #:vx 0))))) + (test "x = 10 - 3" 7 (entity-ref result #:x 0)) + (test "vx = -1" -1 (entity-ref result #:vx 0))))) (test-group "entity-center-on-axis" (let ((e (entity #:type 'player #:x 10 #:y 20 #:width 16 #:height 24))) - (test-equal "center-x = 10 + 8 = 18" 18 (entity-center-on-axis e #:x)) - (test-equal "center-y = 20 + 12 = 32" 32 (entity-center-on-axis e #:y)))) + (test "center-x = 10 + 8 = 18" 18 (entity-center-on-axis e #:x)) + (test "center-y = 20 + 12 = 32" 32 (entity-center-on-axis e #:y)))) (test-group "aabb-overlap-on-axis" (test-group "x overlap: a at x=0 w=16, b at x=10 w=16 → overlap=6" ;; half-sum of widths = 16, center dist = |18 - 8| = 10, overlap = 16 - 10 = 6 (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16))) - (test-equal "x overlap = 6" 6 (aabb-overlap-on-axis #:x a b)))) + (test "x overlap = 6" 6 (aabb-overlap-on-axis #:x a b)))) (test-group "y overlap: a at y=0 h=16, b at y=10 h=16 → overlap=6" (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16))) - (test-equal "y overlap = 6" 6 (aabb-overlap-on-axis #:y a b)))) + (test "y overlap = 6" 6 (aabb-overlap-on-axis #:y a b)))) (test-group "no overlap: negative value" (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) @@ -576,10 +576,10 @@ (result (push-along-axis #:x a b 6)) (ra (car result)) (rb (cdr result))) - (test-equal "a pushed left to -3" -3 (entity-ref ra #:x 0)) - (test-equal "b pushed right to 13" 13 (entity-ref rb #:x 0)) - (test-equal "a vx = -1" -1 (entity-ref ra #:vx 0)) - (test-equal "b vx = 1" 1 (entity-ref rb #:vx 0)))) + (test "a pushed left to -3" -3 (entity-ref ra #:x 0)) + (test "b pushed right to 13" 13 (entity-ref rb #:x 0)) + (test "a vx = -1" -1 (entity-ref ra #:vx 0)) + (test "b vx = 1" 1 (entity-ref rb #:vx 0)))) (test-group "y axis: a above b, pushed apart" (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) @@ -587,8 +587,8 @@ (result (push-along-axis #:y a b 6)) (ra (car result)) (rb (cdr result))) - (test-equal "a pushed up to -3" -3 (entity-ref ra #:y 0)) - (test-equal "b pushed down to 13" 13 (entity-ref rb #:y 0))))) + (test "a pushed up to -3" -3 (entity-ref ra #:y 0)) + (test "b pushed down to 13" 13 (entity-ref rb #:y 0))))) (test-group "push-apart" (test-group "x overlap smaller: pushes on x axis" @@ -596,26 +596,26 @@ (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16)) (result (push-apart a b))) - (test-equal "a pushed left" -3 (entity-ref (car result) #:x 0)) - (test-equal "b pushed right" 13 (entity-ref (cdr result) #:x 0)))) + (test "a pushed left" -3 (entity-ref (car result) #:x 0)) + (test "b pushed right" 13 (entity-ref (cdr result) #:x 0)))) (test-group "y overlap smaller: pushes on y axis" ;; a at (0,0), b at (0,10), both 16x16: ovx=16, ovy=6 → push on y (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16)) (result (push-apart a b))) - (test-equal "a pushed up" -3 (entity-ref (car result) #:y 0)) - (test-equal "b pushed down" 13 (entity-ref (cdr result) #:y 0))))) + (test "a pushed up" -3 (entity-ref (car result) #:y 0)) + (test "b pushed down" 13 (entity-ref (cdr result) #:y 0))))) (test-group "skip-pipelines" (test-group "apply-gravity" (let* ((e (entity #:type 't #:vy 0 #:gravity? #t #:skip-pipelines '(gravity))) (r (apply-gravity #f e 0))) - (test-equal "skipped: vy unchanged" 0 (entity-ref r #:vy)))) + (test "skipped: vy unchanged" 0 (entity-ref r #:vy)))) (test-group "apply-velocity-x" (let* ((e (entity #:type 't #:x 10 #:vx 5 #:skip-pipelines '(velocity-x))) (r (apply-velocity-x #f e 0))) - (test-equal "skipped: x unchanged" 10 (entity-ref r #:x)))) + (test "skipped: x unchanged" 10 (entity-ref r #:x)))) (test-group "resolve-pair with entity-collisions skip" (define (make-solid x y) (entity #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) (let* ((a (entity #:type 'ghost #:x 0 #:y 0 #:width 16 #:height 16 #:solid? #t @@ -660,7 +660,7 @@ (a2 (car r)) (b2 (cdr r))) (test-assert "result is pair" (pair? r)) - (test-equal "a2 is wall (unchanged x)" 0 (entity-ref a2 #:x)) + (test "a2 is wall (unchanged x)" 0 (entity-ref a2 #:x)) (test-assert "b2 is box (pushed right)" (> (entity-ref b2 #:x) 8)))) (test-group "box(a) first, wall(b) second" (let* ((wall (make-static 0 0)) @@ -669,7 +669,7 @@ (a2 (car r)) (b2 (cdr r))) (test-assert "result is pair" (pair? r)) - (test-equal "b2 is wall (unchanged x)" 0 (entity-ref b2 #:x)) + (test "b2 is wall (unchanged x)" 0 (entity-ref b2 #:x)) (test-assert "a2 is box (pushed right)" (> (entity-ref a2 #:x) 8)))))) (test-group "aabb-overlap?" @@ -694,3 +694,4 @@ (aabb-overlap? 0 0 20 20 5 5 10 10)))) (test-end "physics-module") +(test-exit) diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index ab7b5f1..8eaf348 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -5,7 +5,7 @@ (chicken port) (chicken pretty-print) defstruct - srfi-64) + test) ;; Mock downstroke-entity (module downstroke-entity * @@ -42,14 +42,14 @@ (test-assert "animated entry exists" (assq 'animated 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)))) + (test "physics-body has #:vx 0" 0 (cadr (memq #:vx pb))) + (test "physics-body has #:gravity? #t" #t (cadr (memq #:gravity? pb))) + (test "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)))))) + (test "animated has #:anim-tick 0" 0 (cadr (memq #:anim-tick an))) + (test "animated has #:tile-id 0" 0 (cadr (memq #:tile-id an))) + (test "animated has #:anim-name idle" 'idle (cadr (memq #:anim-name an)))))) (test-group "compose-prefab (via load-prefabs with temp file)" @@ -67,11 +67,11 @@ ;; Inline #:vx 99 beats mixin #:vx 5 (let ((e (instantiate-prefab reg 'runner 0 0 16 16))) (pp e) - (test-equal "entity should have squashed properties" 7 (length e)) - (test-equal "inline field beats mixin field for same key" + (test "entity should have squashed properties" 7 (length e)) + (test "inline field beats mixin field for same key" 99 (entity-ref e #:vx)) - (test-equal "mixin field present when not overridden" + (test "mixin field present when not overridden" 0 (entity-ref e #:vy)))))) @@ -82,7 +82,7 @@ (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" + (test "earlier mixin wins over later mixin for same key" 'first (entity-ref e #:key)))))) @@ -93,7 +93,7 @@ (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" + (test "user-redefined mixin key overrides engine default" 77 (entity-ref e #:vx)))))) @@ -120,13 +120,13 @@ (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 "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) @@ -151,7 +151,7 @@ user-hooks: '() hook-table: '()))) (let ((e (instantiate-prefab reg 'proc-hooked 0 0 8 8))) - (test-equal "procedure hook fires and sets #:proc-fired" + (test "procedure hook fires and sets #:proc-fired" #t (entity-ref e #:proc-fired))))) @@ -162,7 +162,7 @@ `((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" + (test "user hook sets #:initialized" #t (entity-ref e #:initialized)))))) @@ -176,7 +176,7 @@ (let ((reg (load-prefabs tmp (engine-mixins) `((init-npc . ,(lambda (e) (entity-set e #:ai-machine 'from-user-hook))))))) (let ((e (instantiate-prefab reg 'npc 0 0 16 16))) - (test-equal "user hook sets #:ai-machine" + (test "user hook sets #:ai-machine" 'from-user-hook (entity-ref e #:ai-machine)))))) @@ -186,7 +186,7 @@ '() (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 "no hook: type is plain" 'plain (entity-ref e #:type)))))) (test-group "unknown hook symbol raises error" (test-error @@ -209,9 +209,9 @@ (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 "original registry has #:value 1" 1 (entity-ref e1 #:value)) + (test "reloaded registry has #:value 42" 42 (entity-ref e2 #:value)) + (test "original registry unchanged after reload" 1 (entity-ref e1 #:value)))) (test-group "group-prefabs" (define (with-group-prefab-data str thunk) @@ -229,17 +229,17 @@ (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-equal "returns list of origin + 2 members" 3 (length lst)) + (test "returns list of origin + 2 members" 3 (length lst)) (let ((origin (car lst)) (a (cadr lst)) (b (caddr lst))) - (test-equal "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) - (test-equal "origin group-origin?" #t (entity-ref origin #:group-origin?)) - (test-equal "member a world x" 100 (entity-ref a #:x)) - (test-equal "member b world x" 110 (entity-ref b #:x)) - (test-equal "member a local x" 0 (entity-ref a #:group-local-x)) - (test-equal "member b local x" 10 (entity-ref b #:group-local-x)) - (test-equal "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) + (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) @@ -248,8 +248,9 @@ #: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-equal "physics origin has gravity" #t (entity-ref origin #:gravity?)) + (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 9f6ce55..702a712 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -5,7 +5,7 @@ (only srfi-1 fold iota for-each) srfi-69 defstruct - srfi-64) + test) ;; Mock tilemap module (module downstroke-tilemap * @@ -60,42 +60,42 @@ (test-group "entity-screen-coords" (let* ((cam (make-camera x: 10 y: 20)) (e (entity #:x 50 #:y 80 #:width 16 #:height 16))) - (test-equal "subtracts camera offset from x" + (test "subtracts camera offset from x" 40 (car (entity-screen-coords e cam))) - (test-equal "subtracts camera offset from y" + (test "subtracts camera offset from y" 60 (cadr (entity-screen-coords e cam))) - (test-equal "preserves width" + (test "preserves width" 16 (caddr (entity-screen-coords e cam))) - (test-equal "preserves height" + (test "preserves height" 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-equal "floors fractional x" + (test "floors fractional x" 100 (car (entity-screen-coords e cam))) - (test-equal "floors fractional y" + (test "floors fractional y" 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-equal "zero camera, zero position" + (test "zero camera, zero position" '(0 0 32 32) (entity-screen-coords e cam)))) (test-group "entity-flip" - (test-equal "facing 1: no flip" + (test "facing 1: no flip" '() (entity-flip (entity #:facing 1))) - (test-equal "facing -1: horizontal flip" + (test "facing -1: horizontal flip" '(horizontal) (entity-flip (entity #:facing -1))) - (test-equal "no facing key: defaults to no flip" + (test "no facing key: defaults to no flip" '() (entity-flip (entity #:x 0)))) @@ -135,23 +135,23 @@ (test-group "make-sprite-font*" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 ranges: (list (list #\A #\C 100))))) - (test-equal "A maps to 100" + (test "A maps to 100" 100 (sprite-font-char->tile-id font #\A)) - (test-equal "B maps to 101" + (test "B maps to 101" 101 (sprite-font-char->tile-id font #\B)) - (test-equal "C maps to 102" + (test "C maps to 102" 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))))) - (test-equal "returns #f for unmapped char" + (test "returns #f for unmapped char" #f (sprite-font-char->tile-id font #\1)) - (test-equal "auto-upcase: lowercase a maps to uppercase" + (test "auto-upcase: lowercase a maps to uppercase" 100 (sprite-font-char->tile-id font #\a)))) @@ -170,16 +170,16 @@ (test-group "sprite-text-width" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 ranges: (list (list #\A #\Z 100))))) - (test-equal "empty string width is 0" + (test "empty string width is 0" 0 (sprite-text-width font "")) - (test-equal "single char width is tile-size" + (test "single char width is tile-size" 8 (sprite-text-width font "A")) - (test-equal "two chars: 2*tile-size + 1*spacing" + (test "two chars: 2*tile-size + 1*spacing" 17 (sprite-text-width font "AB")) - (test-equal "three chars: 3*tile-size + 2*spacing" + (test "three chars: 3*tile-size + 2*spacing" 26 (sprite-text-width font "ABC")))) @@ -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" - #t (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 @@ -311,3 +311,4 @@ (begin (render-scene! #f scene-fixed) #t))))) (test-end "renderer") +(test-exit) diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm index 88fb544..6e0be9c 100644 --- a/tests/scene-loader-test.scm +++ b/tests/scene-loader-test.scm @@ -4,7 +4,7 @@ (chicken keyword) (only srfi-1 fold filter) defstruct - srfi-64) + test) ;; Mock tilemap module (module downstroke-tilemap * @@ -93,18 +93,18 @@ (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-equal "filters #f results: 2 entities from 3 objects" + (test "filters #f results: 2 entities from 3 objects" 2 (length result)) - (test-equal "first entity is player" + (test "first entity is player" 'player (entity-ref (car result) #:type)) - (test-equal "second entity is enemy" + (test "second entity is enemy" '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-equal "empty object list returns empty list" + (test "empty object list returns empty list" 0 (length result)))) (test-group "game-load-tilemap! / game-load-tileset! / game-load-font!" @@ -120,8 +120,9 @@ ;; game-load-font! with mock ttf returns a font value (let* ((game #f) ; mock game (game-asset-set! ignores it in mock) (font (ttf:open-font "test.ttf" 16))) - (test-equal "mock font is a list" + (test "mock font is a list" 'font (car font)))) (test-end "scene-loader") +(test-exit) diff --git a/tests/tilemap-test.scm b/tests/tilemap-test.scm index 16629bd..282400f 100644 --- a/tests/tilemap-test.scm +++ b/tests/tilemap-test.scm @@ -15,7 +15,7 @@ (prefix sdl2 sdl2:) (prefix sdl2-image img:) srfi-69 - srfi-64) + test) ;; Load the module source directly (include "tilemap.scm") @@ -35,12 +35,12 @@ image-source: "test.png" image: #f))) (test-assert "tileset is a record" (tileset? ts)) - (test-equal "tilewidth is set correctly" 16 (tileset-tilewidth ts)) - (test-equal "tileheight is set correctly" 16 (tileset-tileheight ts)) - (test-equal "spacing is set correctly" 1 (tileset-spacing ts)) - (test-equal "tilecount is set correctly" 100 (tileset-tilecount ts)) - (test-equal "columns is set correctly" 10 (tileset-columns ts)) - (test-equal "image-source is set correctly" "test.png" (tileset-image-source ts)))) + (test "tilewidth is set correctly" 16 (tileset-tilewidth ts)) + (test "tileheight is set correctly" 16 (tileset-tileheight ts)) + (test "spacing is set correctly" 1 (tileset-spacing ts)) + (test "tilecount is set correctly" 100 (tileset-tilecount ts)) + (test "columns is set correctly" 10 (tileset-columns ts)) + (test "image-source is set correctly" "test.png" (tileset-image-source ts)))) ;; Test: tileset-rows calculation (test-group "tileset-rows" @@ -51,7 +51,7 @@ columns: 10 image-source: "test.png" image: #f))) - (test-equal "100 tiles / 10 columns = 10 rows" + (test "100 tiles / 10 columns = 10 rows" 10 (tileset-rows ts))) @@ -62,7 +62,7 @@ columns: 10 image-source: "test.png" image: #f))) - (test-equal "105 tiles / 10 columns = 11 rows (ceiling)" + (test "105 tiles / 10 columns = 11 rows (ceiling)" 11 (tileset-rows ts)))) @@ -79,16 +79,16 @@ (tile11 (tileset-tile ts 11))) (test-assert "tile1 is a tile record" (tile? tile1)) - (test-equal "tile1 has correct id" 1 (tile-id tile1)) + (test "tile1 has correct id" 1 (tile-id tile1)) (test-assert "tile1 has a rect" (sdl2:rect? (tile-rect tile1))) ;; First tile should be at (0, 0) - (test-equal "tile1 x position" 0 (sdl2:rect-x (tile-rect tile1))) - (test-equal "tile1 y position" 0 (sdl2:rect-y (tile-rect tile1))) + (test "tile1 x position" 0 (sdl2:rect-x (tile-rect tile1))) + (test "tile1 y position" 0 (sdl2:rect-y (tile-rect tile1))) ;; Tile 11 should be at start of second row (x=0, y=17 with spacing) - (test-equal "tile11 x position" 0 (sdl2:rect-x (tile-rect tile11))) - (test-equal "tile11 y position" 17 (sdl2:rect-y (tile-rect tile11))))) + (test "tile11 x position" 0 (sdl2:rect-x (tile-rect tile11))) + (test "tile11 y position" 17 (sdl2:rect-y (tile-rect tile11))))) ;; Test: layer record creation (test-group "layer-structure" @@ -97,10 +97,10 @@ height: 30 map: '()))) (test-assert "layer is a record" (layer? layer)) - (test-equal "name is set correctly" "ground" (layer-name layer)) - (test-equal "width is set correctly" 40 (layer-width layer)) - (test-equal "height is set correctly" 30 (layer-height layer)) - (test-equal "map is empty list" '() (layer-map layer)))) + (test "name is set correctly" "ground" (layer-name layer)) + (test "width is set correctly" 40 (layer-width layer)) + (test "height is set correctly" 30 (layer-height layer)) + (test "map is empty list" '() (layer-map layer)))) ;; Test: object record creation (test-group "object-structure" @@ -112,11 +112,11 @@ height: 16 properties: '((text . "hello"))))) (test-assert "object is a record" (object? obj)) - (test-equal "name is set correctly" "player" (object-name obj)) - (test-equal "type is set correctly" "Player" (object-type obj)) - (test-equal "x is set correctly" 100 (object-x obj)) - (test-equal "y is set correctly" 200 (object-y obj)) - (test-equal "properties contain text" "hello" (alist-ref 'text (object-properties obj))))) + (test "name is set correctly" "player" (object-name obj)) + (test "type is set correctly" "Player" (object-type obj)) + (test "x is set correctly" 100 (object-x obj)) + (test "y is set correctly" 200 (object-y obj)) + (test "properties contain text" "hello" (alist-ref 'text (object-properties obj))))) ;; Test: tilemap record creation (test-group "tilemap-structure" @@ -129,17 +129,17 @@ layers: '() objects: '()))) (test-assert "tilemap is a record" (tilemap? tm)) - (test-equal "width is set correctly" 40 (tilemap-width tm)) - (test-equal "height is set correctly" 30 (tilemap-height tm)) - (test-equal "tilewidth is set correctly" 16 (tilemap-tilewidth tm)) - (test-equal "tileheight is set correctly" 16 (tilemap-tileheight tm)))) + (test "width is set correctly" 40 (tilemap-width tm)) + (test "height is set correctly" 30 (tilemap-height tm)) + (test "tilewidth is set correctly" 16 (tilemap-tilewidth tm)) + (test "tileheight is set correctly" 16 (tilemap-tileheight tm)))) ;; Test: tile record creation (test-group "tile-structure" (let* ((rect (sdl2:make-rect 0 0 16 16)) (tile (make-tile id: 1 rect: rect))) (test-assert "tile is a record" (tile? tile)) - (test-equal "id is set correctly" 1 (tile-id tile)) + (test "id is set correctly" 1 (tile-id tile)) (test-assert "rect is an SDL rect" (sdl2:rect? (tile-rect tile))))) ;; Test: parse-tileset XML parsing @@ -150,12 +150,12 @@ </tileset>") (ts (parse-tileset xml))) (test-assert "returns a tileset" (tileset? ts)) - (test-equal "parses tilewidth" 16 (tileset-tilewidth ts)) - (test-equal "parses tileheight" 16 (tileset-tileheight ts)) - (test-equal "parses spacing" 1 (tileset-spacing ts)) - (test-equal "parses tilecount" 100 (tileset-tilecount ts)) - (test-equal "parses columns" 10 (tileset-columns ts)) - (test-equal "parses image source" "test.png" (tileset-image-source ts)))) + (test "parses tilewidth" 16 (tileset-tilewidth ts)) + (test "parses tileheight" 16 (tileset-tileheight ts)) + (test "parses spacing" 1 (tileset-spacing ts)) + (test "parses tilecount" 100 (tileset-tilecount ts)) + (test "parses columns" 10 (tileset-columns ts)) + (test "parses image source" "test.png" (tileset-image-source ts)))) ;; Test: parse-tilemap XML parsing (test-group "parse-tilemap" @@ -171,13 +171,13 @@ </map>") (tm (parse-tilemap xml))) (test-assert "returns a tilemap" (tilemap? tm)) - (test-equal "parses width" 10 (tilemap-width tm)) - (test-equal "parses height" 10 (tilemap-height tm)) - (test-equal "parses tilewidth" 16 (tilemap-tilewidth tm)) - (test-equal "parses tileheight" 16 (tilemap-tileheight tm)) - (test-equal "parses tileset source" "test.tsx" (tilemap-tileset-source tm)) + (test "parses width" 10 (tilemap-width tm)) + (test "parses height" 10 (tilemap-height tm)) + (test "parses tilewidth" 16 (tilemap-tilewidth tm)) + (test "parses tileheight" 16 (tilemap-tileheight tm)) + (test "parses tileset source" "test.tsx" (tilemap-tileset-source tm)) (test-assert "has layers" (not (null? (tilemap-layers tm)))) - (test-equal "first layer name" "ground" (layer-name (car (tilemap-layers tm)))))) + (test "first layer name" "ground" (layer-name (car (tilemap-layers tm)))))) ;; Test: parse-tilemap with objects (test-group "parse-tilemap-with-objects" @@ -195,10 +195,11 @@ (tm (parse-tilemap xml))) (test-assert "has objects" (not (null? (tilemap-objects tm)))) (let ((obj (car (tilemap-objects tm)))) - (test-equal "object name" "player" (object-name obj)) - (test-equal "object type" "Player" (object-type obj)) - (test-equal "object x" 50 (object-x obj)) - (test-equal "object y" 50 (object-y obj)) - (test-equal "object has properties" "5" (alist-ref 'speed (object-properties obj)))))) + (test "object name" "player" (object-name obj)) + (test "object type" "Player" (object-type obj)) + (test "object x" 50 (object-x obj)) + (test "object y" 50 (object-y obj)) + (test "object has properties" "5" (alist-ref 'speed (object-properties obj)))))) (test-end "tilemap-module") +(test-exit) diff --git a/tests/tween-test.scm b/tests/tween-test.scm index 962d325..51675b8 100644 --- a/tests/tween-test.scm +++ b/tests/tween-test.scm @@ -1,4 +1,4 @@ -(import srfi-64 +(import test (chicken base)) (include "entity.scm") (include "tween.scm") @@ -12,18 +12,18 @@ (test-begin "tween") (test-group "ease functions" - (test-equal "linear mid" 0.5 (ease-linear 0.5)) - (test-equal "quad-in mid" 0.25 (ease-quad-in 0.5)) - (test-equal "quad-out mid" 0.75 (ease-quad-out 0.5)) - (test-equal "quad-in-out mid" 0.5 (ease-quad-in-out 0.5)) - (test-equal "cubic-in mid" 0.125 (ease-cubic-in 0.5)) + (test "linear mid" 0.5 (ease-linear 0.5)) + (test "quad-in mid" 0.25 (ease-quad-in 0.5)) + (test "quad-out mid" 0.75 (ease-quad-out 0.5)) + (test "quad-in-out mid" 0.5 (ease-quad-in-out 0.5)) + (test "cubic-in mid" 0.125 (ease-cubic-in 0.5)) (test-assert "sine-in-out endpoints" (and (= 0.0 (ease-sine-in-out 0)) (= 1.0 (ease-sine-in-out 1)))) - (test-equal "expo-in at 0" 0.0 (ease-expo-in 0)) - (test-equal "expo-out at 1" 1.0 (ease-expo-out 1)) - (test-equal "expo-in-out mid" 0.5 (ease-expo-in-out 0.5)) - (test-equal "cubic-in-out mid" 0.5 (ease-cubic-in-out 0.5)) - (test-equal "cubic-out mid" 0.875 (ease-cubic-out 0.5)) + (test "expo-in at 0" 0.0 (ease-expo-in 0)) + (test "expo-out at 1" 1.0 (ease-expo-out 1)) + (test "expo-in-out mid" 0.5 (ease-expo-in-out 0.5)) + (test "cubic-in-out mid" 0.5 (ease-cubic-in-out 0.5)) + (test "cubic-out mid" 0.875 (ease-cubic-out 0.5)) (test-assert "cubic-in-out stays in [0,1]" (let loop ((i 0) (ok #t)) (if (> i 100) ok @@ -32,11 +32,11 @@ (loop (+ i 1) (and ok (>= v 0) (<= v 1)))))))) (test-group "ease-named" - (test-equal "quad-in-out proc" ease-quad-in-out (ease-named 'quad-in-out))) + (test "quad-in-out proc" ease-quad-in-out (ease-named 'quad-in-out))) (test-group "ease-resolve" - (test-equal "symbol" ease-cubic-out (ease-resolve 'cubic-out)) - (test-equal "procedure passthrough" ease-linear (ease-resolve ease-linear))) + (test "symbol" ease-cubic-out (ease-resolve 'cubic-out)) + (test "procedure passthrough" ease-linear (ease-resolve ease-linear))) (test-group "make-tween / tween-step" (test-group "linear completes to target" @@ -44,18 +44,18 @@ (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "finished" (tween-finished? tw2)) - (test-equal "x at end" 100.0 (entity-ref e2 #:x)) - (test-equal "y preserved" 10 (entity-ref e2 #:y))))) + (test "x at end" 100.0 (entity-ref e2 #:x)) + (test "y preserved" 10 (entity-ref e2 #:y))))) (test-group "delay holds props" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 50)) duration: 100 delay: 40 ease: 'linear))) (receive (tw2 e2) (tween-step tw ent 30) (test-assert "not finished" (not (tween-finished? tw2))) - (test-equal "x unchanged during delay" 0 (entity-ref e2 #:x)) + (test "x unchanged during delay" 0 (entity-ref e2 #:x)) (receive (tw3 e3) (tween-step tw2 e2 9) (test-assert "still in delay at 39ms" (not (tween-finished? tw3))) - (test-equal "x still 0" 0 (entity-ref e3 #:x)) + (test "x still 0" 0 (entity-ref e3 #:x)) (receive (_tw4 e4) (tween-step tw3 e3 50) (test-assert "past delay, moved" (> (entity-ref e4 #:x) 0))))))) @@ -63,7 +63,7 @@ (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) (receive (_ e2) (tween-step tw ent 50) - (test-equal "halfway x" 50.0 (entity-ref e2 #:x))))) + (test "halfway x" 50.0 (entity-ref e2 #:x))))) (test-group "on-complete runs once" (let ((calls 0)) @@ -71,10 +71,10 @@ (tw (make-tween ent props: '((#:x . 10)) duration: 10 delay: 0 ease: 'linear on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) - (test-equal "one call" 1 calls) + (test "one call" 1 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 5) - (test-equal "still one call" 1 calls) - (test-equal "entity stable" e3 e2)))))) + (test "still one call" 1 (begin calls)) + (test "entity stable" e3 (begin e2))))))) (test-group "idempotent after finish" (let* ((ent (entity #:type 'a #:x 0)) @@ -82,7 +82,7 @@ (receive (tw2 e2) (tween-step tw ent 10) (receive (tw3 e3) (tween-step tw2 e2 999) (test-assert (tween-finished? tw3)) - (test-equal "x stays" 20.0 (entity-ref e3 #:x))))))) + (test "x stays" 20.0 (entity-ref e3 #:x))))))) (test-group "repeat" (test-group "repeat: 1 plays twice" @@ -91,10 +91,10 @@ ease: 'linear repeat: 1))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "not finished after first play" (not (tween-finished? tw2))) - (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (test "x at target" 100.0 (entity-ref e2 #:x)) (receive (tw3 e3) (tween-step tw2 e2 100) (test-assert "finished after second play" (tween-finished? tw3)) - (test-equal "x at target again" 100.0 (entity-ref e3 #:x)))))) + (test "x at target again" 100.0 (entity-ref e3 #:x)))))) (test-group "repeat: -1 never finishes" (let* ((ent (entity #:type 'a #:x 0)) @@ -119,9 +119,9 @@ ease: 'linear repeat: 1 on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) - (test-equal "no call after first play" 0 calls) + (test "no call after first play" 0 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 10) - (test-equal "one call after last repeat" 1 calls)))))) + (test "one call after last repeat" 1 (begin calls))))))) (test-group "on-complete does not fire with repeat: -1" (let ((calls 0)) @@ -130,7 +130,7 @@ ease: 'linear repeat: -1 on-complete: (lambda (_) (set! calls (+ calls 1)))))) (let loop ((tw tw) (ent ent) (i 0)) - (if (>= i 5) (test-equal "never called" 0 calls) + (if (>= i 5) (test "never called" 0 (begin calls)) (receive (tw2 e2) (tween-step tw ent 10) (loop tw2 e2 (+ i 1))))))))) @@ -140,12 +140,12 @@ (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 1 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) - (test-equal "x at target after forward" 100.0 (entity-ref e2 #:x)) + (test "x at target after forward" 100.0 (entity-ref e2 #:x)) (receive (tw3 e3) (tween-step tw2 e2 50) - (test-equal "x halfway back" 50.0 (entity-ref e3 #:x)) + (test "x halfway back" 50.0 (entity-ref e3 #:x)) (receive (tw4 e4) (tween-step tw3 e3 50) (test-assert "finished after reverse" (tween-finished? tw4)) - (test-equal "x back to start" 0.0 (entity-ref e4 #:x))))))) + (test "x back to start" 0.0 (entity-ref e4 #:x))))))) (test-group "yoyo: #t with repeat: -1 ping-pongs forever" (let* ((ent (entity #:type 'a #:x 0)) @@ -153,13 +153,13 @@ ease: 'linear repeat: -1 yoyo?: #t))) ;; Forward (receive (tw2 e2) (tween-step tw ent 100) - (test-equal "at target" 100.0 (entity-ref e2 #:x)) + (test "at target" 100.0 (entity-ref e2 #:x)) ;; Reverse (receive (tw3 e3) (tween-step tw2 e2 100) - (test-equal "back to start" 0.0 (entity-ref e3 #:x)) + (test "back to start" 0.0 (entity-ref e3 #:x)) ;; Forward again (receive (tw4 e4) (tween-step tw3 e3 100) - (test-equal "at target again" 100.0 (entity-ref e4 #:x)) + (test "at target again" 100.0 (entity-ref e4 #:x)) (test-assert "still active" (tween-active? tw4))))))) (test-group "yoyo: #f with repeat: 1 replays same direction" @@ -167,7 +167,7 @@ (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 1 yoyo?: #f))) (receive (tw2 e2) (tween-step tw ent 100) - (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (test "x at target" 100.0 (entity-ref e2 #:x)) ;; Second play starts from same starts (0→100), but entity is at 100 ;; The tween replays 0→100 using original start values (receive (tw3 e3) (tween-step tw2 e2 50) @@ -179,7 +179,7 @@ ease: 'linear repeat: 0 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "finishes normally" (tween-finished? tw2)) - (test-equal "x at target" 100.0 (entity-ref e2 #:x)))))) + (test "x at target" 100.0 (entity-ref e2 #:x)))))) (test-group "step-tweens pipeline" (test-group "advances #:tween on entity" @@ -187,7 +187,7 @@ #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 50))) - (test-equal "x moved to midpoint" 50.0 (entity-ref e2 #:x)) + (test "x moved to midpoint" 50.0 (entity-ref e2 #:x)) (test-assert "tween still attached" (entity-ref e2 #:tween #f)))) (test-group "removes #:tween when finished" @@ -195,20 +195,20 @@ #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) - (test-equal "x at target" 100.0 (entity-ref e2 #:x)) - (test-equal "tween removed" #f (entity-ref e2 #:tween #f)))) + (test "x at target" 100.0 (entity-ref e2 #:x)) + (test "tween removed" #f (entity-ref e2 #:tween #f)))) (test-group "no-op without #:tween" (let* ((ent (entity #:type 'a #:x 42)) (e2 (step-tweens #f ent 100))) - (test-equal "x unchanged" 42 (entity-ref e2 #:x)))) + (test "x unchanged" 42 (entity-ref e2 #:x)))) (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))) (e2 (step-tweens #f ent 100))) - (test-equal "x at target" 100.0 (entity-ref e2 #:x)) + (test "x at target" 100.0 (entity-ref e2 #:x)) (test-assert "tween still attached (repeating)" (entity-ref e2 #:tween #f)))) (test-group "respects #:skip-pipelines" @@ -217,7 +217,8 @@ #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) - (test-equal "x unchanged (skipped)" 0 (entity-ref e2 #:x)) + (test "x unchanged (skipped)" 0 (entity-ref e2 #:x)) (test-assert "tween still there" (entity-ref e2 #:tween #f))))) (test-end "tween") +(test-exit) diff --git a/tests/world-test.scm b/tests/world-test.scm index a66103e..8cbe4f2 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -3,7 +3,7 @@ (chicken base) (chicken keyword) defstruct - srfi-64 + test (only srfi-1 every member make-list)) ;; Create a mock tilemap module to avoid SDL dependency @@ -65,10 +65,10 @@ tileset: #f layers: (list layer1) objects: '()))) - (test-equal "top-left corner" 1 (tilemap-tile-at tm 0 0)) - (test-equal "top-right corner" 3 (tilemap-tile-at tm 2 0)) - (test-equal "bottom-left corner" 7 (tilemap-tile-at tm 0 2)) - (test-equal "center" 5 (tilemap-tile-at tm 1 1)))) + (test "top-left corner" 1 (tilemap-tile-at tm 0 0)) + (test "top-right corner" 3 (tilemap-tile-at tm 2 0)) + (test "bottom-left corner" 7 (tilemap-tile-at tm 0 2)) + (test "center" 5 (tilemap-tile-at tm 1 1)))) (test-group "out-of-bounds returns 0" (let* ((layer1 (make-layer name: "test" width: 3 height: 3 @@ -79,10 +79,10 @@ tileset: #f layers: (list layer1) objects: '()))) - (test-equal "negative col" 0 (tilemap-tile-at tm -1 0)) - (test-equal "col beyond width" 0 (tilemap-tile-at tm 3 0)) - (test-equal "negative row" 0 (tilemap-tile-at tm 0 -1)) - (test-equal "row beyond height" 0 (tilemap-tile-at tm 0 3)))) + (test "negative col" 0 (tilemap-tile-at tm -1 0)) + (test "col beyond width" 0 (tilemap-tile-at tm 3 0)) + (test "negative row" 0 (tilemap-tile-at tm 0 -1)) + (test "row beyond height" 0 (tilemap-tile-at tm 0 3)))) (test-group "zero tiles are skipped to next layer" (let* ((layer1 (make-layer name: "test1" width: 3 height: 3 @@ -95,23 +95,23 @@ tileset: #f layers: (list layer1 layer2) objects: '()))) - (test-equal "skips zero in layer1, finds in layer2" + (test "skips zero in layer1, finds in layer2" 5 (tilemap-tile-at tm 1 1))))) ;; Test: scene record creation (test-group "scene-structure" (let ((scene (make-scene entities: '() tilemap: #f camera-target: #f))) (test-assert "scene is a record" (scene? scene)) - (test-equal "entities list is empty" '() (scene-entities scene)) - (test-equal "tilemap is #f" #f (scene-tilemap scene)) - (test-equal "background defaults to #f" #f (scene-background scene)) - (test-equal "tileset defaults to #f" #f (scene-tileset scene))) + (test "entities list is empty" '() (scene-entities scene)) + (test "tilemap is #f" #f (scene-tilemap scene)) + (test "background defaults to #f" #f (scene-background scene)) + (test "tileset defaults to #f" #f (scene-tileset scene))) (let ((s (make-scene entities: '() tilemap: #f camera-target: #f background: '(40 44 52)))) - (test-equal "background RGB stored" '(40 44 52) (scene-background s))) + (test "background RGB stored" '(40 44 52) (scene-background s))) (let ((s (make-scene entities: '() tilemap: #f camera-target: #f background: '(1 2 3 200)))) - (test-equal "background RGBA stored" '(1 2 3 200) (scene-background s)))) + (test "background RGBA stored" '(1 2 3 200) (scene-background s)))) ;; Test: scene with entities and tilemap (test-group "scene-with-data" @@ -121,13 +121,13 @@ (scene (make-scene entities: (list player enemy) tilemap: tilemap camera-target: #f))) - (test-equal "scene has 2 entities" + (test "scene has 2 entities" 2 (length (scene-entities scene))) - (test-equal "first entity is player" + (test "first entity is player" 'player (entity-type (car (scene-entities scene)))) - (test-equal "tilemap is set correctly" + (test "tilemap is set correctly" "mock-tilemap" (scene-tilemap scene)))) @@ -137,12 +137,12 @@ (scene (make-scene entities: (list player) tilemap: #f camera-target: #f)) (enemy (entity #:type 'enemy #:x 200 #:y 200))) - (test-equal "initial entity count" 1 (length (scene-entities scene))) + (test "initial entity count" 1 (length (scene-entities scene))) (let ((scene2 (scene-add-entity scene enemy))) - (test-equal "original scene unchanged" 1 (length (scene-entities scene))) - (test-equal "entity count after add" 2 (length (scene-entities scene2))) - (test-equal "second entity is enemy" + (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))))))) @@ -155,7 +155,7 @@ (scene (scene-add-entity scene e2)) (scene (scene-add-entity scene e3))) - (test-equal "entities are in order" + (test "entities are in order" '(a b c) (map entity-type (scene-entities scene))))) @@ -171,16 +171,16 @@ (entity #:type type #:x (+ x 10) #:y y)))) (scene2 (scene-map-entities scene move-right))) - (test-equal "original scene unchanged" + (test "original scene unchanged" 100 (entity-ref (car (scene-entities scene)) #:x)) - (test-equal "first entity moved right" + (test "first entity moved right" 110 (entity-ref (car (scene-entities scene2)) #:x)) - (test-equal "second entity moved right" + (test "second entity moved right" 210 (entity-ref (cadr (scene-entities scene2)) #:x)) - (test-equal "y values unchanged" + (test "y values unchanged" 100 (entity-ref (car (scene-entities scene2)) #:y)))) @@ -191,8 +191,8 @@ (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) (scene2 (scene-map-entities scene (lambda (scene e) e)))) - (test-equal "entity count unchanged" 2 (length (scene-entities scene2))) - (test-equal "first entity unchanged" + (test "entity count unchanged" 2 (length (scene-entities scene2))) + (test "first entity unchanged" 100 (entity-ref (car (scene-entities scene2)) #:x)))) @@ -202,7 +202,7 @@ (player (make-entity 10 20 16 16)) (scene (scene-add-entity scene player))) - (test-equal "entity added" 1 (length (scene-entities scene))) + (test "entity added" 1 (length (scene-entities scene))) (let ((scene (scene-map-entities scene (lambda (scene e) @@ -211,15 +211,15 @@ (type (entity-type e))) (entity #:type type #:x (* x 2) #:y (* y 2) #:width 16 #:height 16)))))) - (test-equal "entity x doubled" 20 (entity-ref (car (scene-entities scene)) #:x)) - (test-equal "entity y doubled" 40 (entity-ref (car (scene-entities scene)) #:y))))) + (test "entity x doubled" 20 (entity-ref (car (scene-entities scene)) #:x)) + (test "entity y doubled" 40 (entity-ref (car (scene-entities scene)) #:y))))) ;; Test: update-scene for tilemap (test-group "scene-tilemap-update" (let* ((scene (make-scene entities: '() tilemap: #f camera-target: #f)) (scene2 (update-scene scene tilemap: "new-tilemap"))) - (test-equal "tilemap initially #f" #f (scene-tilemap scene)) - (test-equal "tilemap updated in new scene" "new-tilemap" (scene-tilemap scene2)))) + (test "tilemap initially #f" #f (scene-tilemap scene)) + (test "tilemap updated in new scene" "new-tilemap" (scene-tilemap scene2)))) ;; Create a test tilemap for the filter test (define test-tilemap @@ -241,9 +241,9 @@ camera-target: #f)) (scene2 (scene-filter-entities scene (lambda (e) (eq? (entity-ref e #:type #f) 'player))))) - (test-equal "original scene unchanged" 2 (length (scene-entities scene))) - (test-equal "keeps matching entities" 1 (length (scene-entities scene2))) - (test-equal "kept entity is 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)))) @@ -251,24 +251,24 @@ (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-equal "original camera unchanged" 0 (camera-x cam)) - (test-equal "centers camera x on entity" 100 (camera-x cam2)) - (test-equal "centers camera y on entity" 100 (camera-y cam2))) + (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-equal "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) - (test-equal "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) + (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-equal "finds entity with matching tag" p (scene-find-tagged s 'player)) - (test-equal "finds enemy by 'enemy tag" e (scene-find-tagged s 'enemy)) - (test-equal "finds entity with second tag in list" e (scene-find-tagged s 'npc)) - (test-equal "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) + (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))) @@ -276,8 +276,8 @@ (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-equal "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) - (test-equal "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) + (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) @@ -289,20 +289,21 @@ #:x 0 #:y 0 #:width 8 #:height 8)) (entities (list origin m1 m2)) (result (sync-groups entities))) - (test-equal "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) - (test-equal "member 1 follows origin" 105 (entity-ref (list-ref result 1) #:x)) - (test-equal "member 1 y" 200 (entity-ref (list-ref result 1) #:y)) - (test-equal "member 2 x" 100 (entity-ref (list-ref result 2) #:x)) - (test-equal "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) + (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-equal "transforms entity list" 'b + (test "transforms entity list" 'b (entity-type (car (scene-entities scene2)))) - (test-equal "original scene unchanged" 'a + (test "original scene unchanged" 'a (entity-type (car (scene-entities scene)))))) (test-end "world-module") +(test-exit) |