diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/engine-test.scm | 16 | ||||
| -rw-r--r-- | tests/physics-test.scm | 11 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 158 |
3 files changed, 182 insertions, 3 deletions
diff --git a/tests/engine-test.scm b/tests/engine-test.scm index 79b475e..85481ac 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -104,7 +104,8 @@ ;; --- Renderer module (mock) --- (module downstroke-renderer * (import scheme (chicken base)) - (define (render-scene! . args) #f)) + (define (render-scene! . args) #f) + (define (render-debug-scene! . args) #f)) (import downstroke-renderer) ;; --- Engine module (real) --- @@ -141,7 +142,10 @@ (test-assert "assets registry is created" (game-assets g)) (test-assert "input state is created" - (game-input g)))) + (game-input g)) + (test-equal "debug? defaults to #f" + #f + (game-debug? g)))) (test-group "make-game with keyword args" (let ((g (make-game title: "My Game" width: 320 height: 240 frame-delay: 33))) @@ -150,6 +154,14 @@ (test-equal "custom height" 240 (game-height g)) (test-equal "custom frame-delay" 33 (game-frame-delay g)))) +(test-group "make-game debug? keyword" + (test-equal "debug? defaults to #f" + #f + (game-debug? (make-game))) + (test-equal "debug? can be set to #t" + #t + (game-debug? (make-game debug?: #t)))) + (test-group "game-asset and game-asset-set!" (let ((g (make-game))) (test-equal "missing key returns #f" diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 858dec8..67c8377 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -294,6 +294,17 @@ (test-equal "pushed above floor" 28 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy)))))) + (test-group "high-velocity fall: snaps to first solid row, not last" + ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. + ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]). + ;; After apply-velocity-y the entity lands at y=34 (overlapping both rows 2 and 3). + ;; Correct: snap to top of row 2 → y=16. Bug was: fold overwrote row 2 snap with row 3 snap → y=32 (inside row 2). + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 0)))) + (e '(#:type player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "snapped to first solid row" 16 (entity-ref result #:y)) + (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) + ;; Integration test: simulate the actual game physics loop (test-group "multi-frame physics simulation" (test-group "player falls and lands on floor (10 frames)" diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index fc5c8f2..1a8f7df 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -3,6 +3,7 @@ (chicken base) (chicken keyword) (only srfi-1 fold iota for-each) + srfi-69 defstruct srfi-64) @@ -21,9 +22,13 @@ (module sdl2 * (import scheme (chicken base)) (define (make-rect x y w h) (list x y w h)) + (define (make-color r g b) (list r g b)) (define (render-copy! . args) #f) (define (render-copy-ex! . args) #f) - (define (create-texture-from-surface . args) #f)) + (define (create-texture-from-surface . args) #f) + (define (render-fill-rect! . args) #f) + ;; Mock SRFI-17 setter for render-draw-color + (define render-draw-color (getter-with-setter (lambda (r) #f) (lambda (r c) #f)))) (import (prefix sdl2 "sdl2:")) ;; Mock sdl2-ttf @@ -110,4 +115,155 @@ (test-assert "does not crash on valid scene" (begin (render-scene! #f scene) #t)))) +(test-group "sprite-font" + (test-group "make-sprite-font*" + (let ((font (make-sprite-font* tile-size: 8 spacing: 1 + ranges: (list (list #\A #\C 100))))) + (test-equal "A maps to 100" + 100 + (sprite-font-char->tile-id font #\A)) + (test-equal "B maps to 101" + 101 + (sprite-font-char->tile-id font #\B)) + (test-equal "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" + #f + (sprite-font-char->tile-id font #\1)) + (test-equal "auto-upcase: lowercase a maps to uppercase" + 100 + (sprite-font-char->tile-id font #\a)))) + + (test-group "overlapping ranges" + (import (chicken condition)) + (let ((caught-error #f)) + (condition-case + (make-sprite-font* tile-size: 8 spacing: 1 + ranges: (list (list #\A #\C 100) + (list #\B #\D 200))) + (e (exn) + (set! caught-error #t))) + (test-assert "signals error on overlapping range" + caught-error))) + + (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" + 0 + (sprite-text-width font "")) + (test-equal "single char width is tile-size" + 8 + (sprite-text-width font "A")) + (test-equal "two chars: 2*tile-size + 1*spacing" + 17 + (sprite-text-width font "AB")) + (test-equal "three chars: 3*tile-size + 2*spacing" + 26 + (sprite-text-width font "ABC")))) + + (test-group "draw-sprite-text" + (let* ((font (make-sprite-font* tile-size: 8 spacing: 1 + ranges: (list (list #\A #\Z 100)))) + (tileset (make-tileset tilewidth: 8 tileheight: 8 + spacing: 0 tilecount: 100 columns: 10 + image-source: "" image: #f)) + (renderer #f) + (texture #f)) + (test-assert "does not crash with valid text" + (begin (draw-sprite-text renderer texture tileset font "HELLO" 10 20) #t)) + (test-assert "does not crash with unmapped chars" + (begin (draw-sprite-text renderer texture tileset font "A1B" 0 0) #t))))) + +(test-group "draw-menu-items" + (test-assert "does not crash with 3 items, cursor=1" + (let ((font #f)) ; mock font + (begin + (draw-menu-items #f font '("Item 1" "Item 2" "Item 3") 1 10 20 30) + #t))) + + (test-assert "does not crash with keyword args label-fn:" + (let ((font #f)) + (begin + (draw-menu-items #f font '("A" "B" "C") 0 10 20 30 + label-fn: (lambda (x) (string-append "[" x "]"))) + #t))) + + (test-assert "does not crash with keyword args prefix:" + (let ((font #f)) + (begin + (draw-menu-items #f font '("Item 1" "Item 2") 1 10 20 30 + prefix: ">>> " no-prefix: " ") + #t)))) + +(test-group "debug-drawing" + (test-group "draw-debug-tiles" + (let* ((cam (make-camera x: 0 y: 0)) + (tileset (make-tileset tilewidth: 16 tileheight: 16 + spacing: 0 tilecount: 100 columns: 10 + image-source: "" image: #f)) + (layer (make-layer name: "ground" width: 2 height: 2 + map: '((0 1) (2 3)))) + (tilemap (make-tilemap width: 2 height: 2 + tilewidth: 16 tileheight: 16 + tileset-source: "" + tileset: tileset + layers: (list layer) + objects: '())) + (renderer #f)) + (test-assert "does not crash with 2x2 tilemap" + (begin (draw-debug-tiles renderer cam tilemap) #t)))) + + (test-group "draw-debug-entities" + (let* ((cam (make-camera x: 0 y: 0)) + (tileset (make-tileset tilewidth: 16 tileheight: 16 + spacing: 0 tilecount: 100 columns: 10 + image-source: "" image: #f)) + (layer (make-layer name: "ground" width: 1 height: 1 + map: '((0)))) + (tilemap (make-tilemap width: 1 height: 1 + tilewidth: 16 tileheight: 16 + tileset-source: "" + tileset: tileset + layers: (list layer) + objects: '())) + (player (list #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) + (enemy (list #:type 'enemy #:x 50 #:y 60 #:width 16 #:height 16 #:facing -1)) + (scene (make-scene entities: (list player enemy) + tilemap: tilemap + camera: cam + tileset-texture: #f + camera-target: #f)) + (renderer #f)) + (test-assert "does not crash with player and enemy entities" + (begin (draw-debug-entities renderer cam scene) #t)))) + + (test-group "render-debug-scene!" + (let* ((cam (make-camera x: 0 y: 0)) + (tileset (make-tileset tilewidth: 16 tileheight: 16 + spacing: 0 tilecount: 100 columns: 10 + image-source: "" image: #f)) + (layer (make-layer name: "ground" width: 1 height: 1 + map: '((0)))) + (tilemap (make-tilemap width: 1 height: 1 + tilewidth: 16 tileheight: 16 + tileset-source: "" + tileset: tileset + layers: (list layer) + objects: '())) + (player (list #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) + (scene (make-scene entities: (list player) + tilemap: tilemap + camera: cam + tileset-texture: #f + camera-target: #f)) + (renderer #f)) + (test-assert "does not crash with full scene" + (begin (render-debug-scene! renderer scene) #t))))) + (test-end "renderer") |