diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/engine-test.scm | 8 | ||||
| -rw-r--r-- | tests/physics-test.scm | 65 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 15 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 2 | ||||
| -rw-r--r-- | tests/world-test.scm | 10 |
5 files changed, 85 insertions, 15 deletions
diff --git a/tests/engine-test.scm b/tests/engine-test.scm index 85481ac..f886165 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -19,6 +19,8 @@ (define (create-window! . args) 'mock-window) (define (create-renderer! . args) 'mock-renderer) (define (destroy-window! . args) #f) + (define (make-color r g b #!optional (a 255)) (list r g b a)) + (define render-draw-color (getter-with-setter (lambda (r) #f) (lambda (r c) #f))) (define (render-clear! . args) #f) (define (render-present! . args) #f) (define (make-rect x y w h) (list x y w h)) @@ -82,7 +84,7 @@ (import scheme (chicken base) defstruct) (import downstroke-entity) (defstruct camera x y) - (defstruct scene entities tilemap camera tileset-texture camera-target) + (defstruct scene entities tilemap tileset camera tileset-texture camera-target background) ;; Mock camera-follow! - just clamps camera position (define (camera-follow! camera entity viewport-w viewport-h) (camera-x-set! camera (max 0 (- (entity-ref entity #:x 0) (/ viewport-w 2)))) @@ -193,9 +195,11 @@ (let* ((cam (make-camera x: 10 y: 20)) (scene (make-scene entities: '() tilemap: #f + tileset: #f camera: cam tileset-texture: #f - camera-target: #f)) + camera-target: #f + background: #f)) (g (make-game))) (game-scene-set! g scene) (test-equal "returns scene camera" diff --git a/tests/physics-test.scm b/tests/physics-test.scm index b40f8d1..04ec6bb 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -75,7 +75,7 @@ (e (resolve-tile-collisions-x e tm)) (e (apply-velocity-y e)) (e (resolve-tile-collisions-y e tm)) - (e (detect-ground e tm))) + (e (detect-on-solid e tm))) e)) ;; Test: apply-gravity @@ -383,8 +383,8 @@ (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))))) -;; New tests for detect-ground and apply-jump -(test-group "detect-ground" +;; New tests for detect-on-solid and apply-jump +(test-group "detect-on-solid" (test-group "entity standing on solid tile" ;; Tilemap: 3 rows, row 2 is solid (tile=1), rows 0-1 empty (tile=0) ;; tilewidth=tileheight=16 @@ -392,7 +392,7 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1)))) (e (list #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) - (result (detect-ground e tm))) + (result (detect-on-solid e tm))) (test-assert "on-ground? is #t" (entity-ref result #:on-ground? #f)))) (test-group "entity in mid-air" @@ -400,7 +400,7 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1)))) (e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #t)) - (result (detect-ground e tm))) + (result (detect-on-solid e tm))) (test-assert "on-ground? is #f" (not (entity-ref result #:on-ground? #f))))) (test-group "entity probe spans two tiles, left is solid" @@ -409,7 +409,7 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0)))) (e (list #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) - (result (detect-ground e tm))) + (result (detect-on-solid e tm))) (test-assert "on-ground? is #t (left foot on solid)" (entity-ref result #:on-ground? #f)))) (test-group "entity probe spans two tiles, right is solid" @@ -418,8 +418,27 @@ (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 1 0)))) (e (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) - (result (detect-ground e tm))) - (test-assert "on-ground? is #t (right foot on solid)" (entity-ref result #:on-ground? #f))))) + (result (detect-on-solid e tm))) + (test-assert "on-ground? is #t (right foot on solid)" (entity-ref result #:on-ground? #f)))) + + (test-group "standing on solid entity (no tile): moving platform / crate" + ;; All-air tilemap; wide platform top at y=32; player feet (bottom) at y=32 + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) + (platform (list #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 + #:solid? #t #:vx 0 #:vy 0 #:gravity? #f)) + (player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (ents (list platform player)) + (result (detect-on-solid player tm ents))) + (test-assert "on-ground? from entity top" (entity-ref result #:on-ground? #f)))) + + (test-group "two-arg detect-on-solid skips entity list (backward compatible)" + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) + (platform (list #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 #:solid? #t)) + (player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid player tm))) + (test-assert "no third arg → not on ground" (not (entity-ref result #:on-ground? #f)))))) (test-group "apply-jump" (test-group "on-ground and pressed → impulse applied" @@ -631,7 +650,35 @@ (result (resolve-pair a b))) (test-assert "result is a pair" (pair? result)) (test-assert "a2 is an entity" (pair? (car result))) - (test-assert "b2 is an entity" (pair? (cdr result)))))) + (test-assert "b2 is an entity" (pair? (cdr result))))) + + (test-group "immovable" + (define (make-static x y) + (list #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t)) + (define (make-box x y) + (list #:type 'box #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (test-group "both immovable and overlapping: #f" + (let* ((a (make-static 0 0)) + (b (make-static 8 0))) + (test-assert "no resolution" (not (resolve-pair a b))))) + (test-group "wall(a) left, box(b) overlaps: only box moves" + (let* ((wall (make-static 0 0)) + (box (make-box 8 0)) + (r (resolve-pair wall box)) + (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-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)) + (box (make-box 8 0)) + (r (resolve-pair box wall)) + (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-assert "a2 is box (pushed right)" (> (entity-ref a2 #:x) 8)))))) (test-group "aabb-overlap?" (test-group "two boxes clearly overlapping" diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index 8ebeedf..2829348 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -22,7 +22,7 @@ (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 (make-color r g b #!optional (a 255)) (list r g b a)) (define (render-copy! . args) #f) (define (render-copy-ex! . args) #f) (define (create-texture-from-surface . args) #f) @@ -113,7 +113,18 @@ tileset-texture: #f camera-target: #f))) (test-assert "does not crash on valid scene" - (begin (render-scene! #f scene) #t)))) + (begin (render-scene! #f scene) #t))) + + (let* ((cam (make-camera x: 0 y: 0)) + (box (list #:x 4 #:y 8 #:width 10 #:height 12 #:color '(200 40 90))) + (scene (make-scene entities: (list box) + tilemap: #f + camera: cam + tileset-texture: #f + camera-target: #f)) + (renderer #f)) + (test-assert "no tilemap: draws #:color entities without crashing" + (begin (render-scene! renderer scene) #t)))) (test-group "sprite-font" (test-group "make-sprite-font*" diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm index 137d7ed..22de396 100644 --- a/tests/scene-loader-test.scm +++ b/tests/scene-loader-test.scm @@ -43,7 +43,7 @@ (module downstroke-world * (import scheme (chicken base) defstruct) (defstruct camera x y) - (defstruct scene entities tilemap camera tileset-texture camera-target) + (defstruct scene entities tilemap tileset camera tileset-texture camera-target background) (define (scene-add-entity scene entity) (scene-entities-set! scene (cons entity (scene-entities scene))) scene)) diff --git a/tests/world-test.scm b/tests/world-test.scm index 90c26c4..b8c1a98 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -98,7 +98,15 @@ (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 "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))) + (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))) + (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: scene with entities and tilemap (test-group "scene-with-data" |