diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/engine-test.scm | 25 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 3 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 148 | ||||
| -rw-r--r-- | tests/world-test.scm | 24 |
4 files changed, 185 insertions, 15 deletions
diff --git a/tests/engine-test.scm b/tests/engine-test.scm index 67b9942..99bb12f 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -39,7 +39,13 @@ ;; --- Entity module (mock minimal structs) --- (module downstroke/entity * - (import scheme (chicken base))) + (import scheme (chicken base)) + (define (entity-ref entity key #!optional (default #f)) + (let loop ((plist entity)) + (cond + ((null? plist) (if (procedure? default) (default) default)) + ((eq? (car plist) key) (cadr plist)) + (else (loop (cddr plist))))))) (import downstroke/entity) ;; --- Input module (mock) --- @@ -74,8 +80,20 @@ ;; --- World module (mock) --- (module downstroke/world * (import scheme (chicken base) defstruct) + (import downstroke/entity) (defstruct camera x y) - (defstruct scene entities tilemap camera tileset-texture)) + (defstruct scene entities tilemap camera tileset-texture camera-target) + ;; 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)))) + (camera-y-set! camera (max 0 (- (entity-ref entity #:y 0) (/ viewport-h 2))))) + ;; Mock scene-find-tagged - finds first entity with matching tag + (define (scene-find-tagged scene tag) + (let loop ((entities (scene-entities scene))) + (cond + ((null? entities) #f) + ((member tag (entity-ref (car entities) #:tags '())) (car entities)) + (else (loop (cdr entities))))))) (import downstroke/world) ;; --- Real deps --- @@ -164,7 +182,8 @@ (scene (make-scene entities: '() tilemap: #f camera: cam - tileset-texture: #f)) + tileset-texture: #f + camera-target: #f)) (g (make-game))) (game-scene-set! g scene) (test-equal "returns scene camera" diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index fb91f54..d14f12c 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -105,7 +105,8 @@ (scene (make-scene entities: '() tilemap: tilemap camera: cam - tileset-texture: #f))) + tileset-texture: #f + camera-target: #f))) (test-assert "does not crash on valid scene" (begin (render-scene! #f scene) #t)))) diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm new file mode 100644 index 0000000..61f142f --- /dev/null +++ b/tests/scene-loader-test.scm @@ -0,0 +1,148 @@ +;; Load base deps +(import scheme + (chicken base) + (chicken keyword) + (only srfi-1 fold filter) + defstruct + srfi-64) + +;; Mock tilemap module +(module downstroke/tilemap * + (import scheme (chicken base) defstruct) + (defstruct tileset tilewidth tileheight spacing tilecount columns image-source image) + (defstruct layer name width height map) + (defstruct object name type x y width height properties) + (defstruct tilemap width height tilewidth tileheight tileset-source tileset layers objects) + (defstruct tile id rect) + (define (tileset-tile ts id) (make-tile id: id rect: #f)) + (define (tile-rect t) #f) + (define (load-tilemap filename) (make-tilemap width: 100 height: 100 tilewidth: 16 tileheight: 16 tileset-source: "" tileset: (make-tileset tilewidth: 16 tileheight: 16 spacing: 0 tilecount: 256 columns: 16 image-source: "" image: #f) layers: '() objects: '())) + (define (load-tileset filename) (make-tileset tilewidth: 16 tileheight: 16 spacing: 0 tilecount: 256 columns: 16 image-source: "" image: #f))) +(import downstroke/tilemap) + +;; Mock entity module (minimal) +(module downstroke/entity * + (import scheme (chicken base)) + (define (entity-ref entity key #!optional (default #f)) + (let loop ((plist entity)) + (cond + ((null? plist) (if (procedure? default) (default) default)) + ((eq? (car plist) key) (cadr plist)) + (else (loop (cddr plist)))))) + (define (entity-set entity key val) + (let loop ((plist entity) (acc '())) + (cond + ((null? plist) (reverse (cons val (cons key acc)))) + ((eq? (car plist) key) (append (reverse acc) (cons key (cons val (cddr plist))))) + (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc))))))) + (define (entity-type entity) + (entity-ref entity #:type #f))) +(import downstroke/entity) + +;; Mock world module +(module downstroke/world * + (import scheme (chicken base) defstruct) + (defstruct camera x y) + (defstruct scene entities tilemap camera tileset-texture camera-target) + (define (scene-add-entity scene entity) + (scene-entities-set! scene (cons entity (scene-entities scene))) + scene)) +(import downstroke/world) + +;; Mock assets module +(module downstroke/assets * + (import scheme (chicken base)) + (define (asset-set! assets key value) #f)) +(import downstroke/assets) + +;; Mock engine module +(module downstroke/engine * + (import scheme (chicken base)) + (define (game-renderer game) #f) + (define (game-asset-set! game key value) #f) + (define (game-scene-set! game scene) #f)) +(import downstroke/engine) + +;; Mock sdl2 +(module sdl2 * + (import scheme (chicken base)) + (define (create-texture-from-surface renderer surface) #f)) +(import (prefix sdl2 "sdl2:")) + +;; Mock sdl2-ttf +(module sdl2-ttf * + (import scheme (chicken base)) + (define (open-font filename size) (list 'font filename size))) +(import (prefix sdl2-ttf "ttf:")) + +;; Load scene-loader module +(include "scene-loader.scm") +(import downstroke/scene-loader) + +(test-begin "scene-loader") + +(test-group "make-prefab-registry + instantiate-prefab" + (let* ((registry (make-prefab-registry + 'player (lambda (x y w h) (list #:type 'player #:x x #:y y #:width w #:height h)) + 'enemy (lambda (x y w h) (list #:type 'enemy #:x x #:y y #:width w #:height h)))) + (result (instantiate-prefab registry 'player 10 20 16 16))) + (test-assert "instantiate-prefab returns a plist for known type" + (list? result)) + (test-equal "player has correct x" + 10 + (entity-ref result #:x)) + (test-equal "player has correct type" + 'player + (entity-ref result #:type)) + (test-assert "unknown type returns #f" + (not (instantiate-prefab registry 'unknown 10 20 16 16))))) + +(test-group "tilemap-objects->entities" + (let* ((obj1 (make-object name: "player1" type: "player" x: 10 y: 20 width: 16 height: 16 properties: '())) + (obj2 (make-object name: "deco" type: "decoration" x: 50 y: 60 width: 32 height: 32 properties: '())) + (obj3 (make-object name: "enemy1" type: "enemy" x: 100 y: 120 width: 16 height: 16 properties: '())) + (tm (make-tilemap width: 100 height: 100 tilewidth: 16 tileheight: 16 + tileset-source: "" tileset: #f layers: '() + objects: (list obj1 obj2 obj3))) + (fn (lambda (type x y w h) + (cond + ((eq? type 'player) (list #:type 'player #:x x #:y y #:width w #:height h)) + ((eq? type 'enemy) (list #:type 'enemy #:x x #:y y #:width w #:height h)) + (else #f)))) + (result (tilemap-objects->entities tm fn))) + (test-equal "filters #f results: 2 entities from 3 objects" + 2 + (length result)) + (test-equal "first entity is player" + 'player + (entity-ref (car result) #:type)) + (test-equal "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 (lambda (t x y w h) #f)))) + (test-equal "empty object list returns empty list" + 0 + (length result)))) + +(test-group "game-load-tilemap! / game-load-tileset! / game-load-font!" + ;; game-load-tilemap! calls load-tilemap and stores result + ;; We can't test file I/O directly, but we can verify the function exists + ;; and that our mock game-asset-set! doesn't crash + (test-assert "game-load-tilemap! is a procedure" + (procedure? game-load-tilemap!)) + (test-assert "game-load-tileset! is a procedure" + (procedure? game-load-tileset!)) + (test-assert "game-load-font! is a procedure" + (procedure? game-load-font!)) + ;; 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" + 'font + (car font)))) + +(test-end "scene-loader") diff --git a/tests/world-test.scm b/tests/world-test.scm index c4fd887..451ab2a 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -95,7 +95,7 @@ ;; Test: scene record creation (test-group "scene-structure" - (let ((scene (make-scene entities: '() tilemap: #f))) + (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)))) @@ -106,7 +106,8 @@ (enemy '(#:type enemy #:x 200 #:y 200)) (tilemap "mock-tilemap") (scene (make-scene entities: (list player enemy) - tilemap: tilemap))) + tilemap: tilemap + camera-target: #f))) (test-equal "scene has 2 entities" 2 (length (scene-entities scene))) @@ -120,7 +121,7 @@ ;; Test: scene-add-entity adds entity to scene (test-group "scene-add-entity" (let* ((player (make-player-entity 100 100 16 16)) - (scene (make-scene entities: (list player) tilemap: #f)) + (scene (make-scene entities: (list player) tilemap: #f camera-target: #f)) (enemy '(#:type enemy #:x 200 #:y 200))) (test-equal "initial entity count" 1 (length (scene-entities scene))) @@ -137,7 +138,7 @@ (let* ((e1 '(#:type a #:x 1)) (e2 '(#:type b #:x 2)) (e3 '(#:type c #:x 3)) - (scene (make-scene entities: (list e1) tilemap: #f))) + (scene (make-scene entities: (list e1) tilemap: #f camera-target: #f))) (scene-add-entity scene e2) (scene-add-entity scene e3) @@ -150,7 +151,7 @@ (test-group "scene-update-entities" (let* ((e1 '(#:type player #:x 100 #:y 100)) (e2 '(#:type enemy #:x 200 #:y 200)) - (scene (make-scene entities: (list e1 e2) tilemap: #f)) + (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) ;; Function that moves all entities right by 10 (move-right (lambda (entity) (let ((x (entity-ref entity #:x)) @@ -174,7 +175,7 @@ (test-group "scene-update-entities-identity" (let* ((e1 '(#:type player #:x 100)) (e2 '(#:type enemy #:x 200)) - (scene (make-scene entities: (list e1 e2) tilemap: #f))) + (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f))) (scene-update-entities scene (lambda (e) e)) @@ -185,7 +186,7 @@ ;; Test: scene mutation (test-group "scene-mutation" - (let* ((scene (make-scene entities: '() tilemap: #f)) + (let* ((scene (make-scene entities: '() tilemap: #f camera-target: #f)) (player (make-player-entity 10 20 16 16))) ;; Add entity @@ -206,7 +207,7 @@ ;; Test: scene-tilemap-set! (test-group "scene-tilemap-mutation" - (let ((scene (make-scene entities: '() tilemap: #f))) + (let ((scene (make-scene entities: '() tilemap: #f camera-target: #f))) (test-equal "tilemap initially #f" #f (scene-tilemap scene)) (scene-tilemap-set! scene "new-tilemap") @@ -228,7 +229,8 @@ (scene (make-scene entities: (list e1 e2) tilemap: test-tilemap camera: (make-camera x: 0 y: 0) - tileset-texture: #f))) + tileset-texture: #f + camera-target: #f))) (scene-filter-entities scene (lambda (e) (eq? (entity-ref e #:type #f) 'player))) (test-equal "keeps matching entities" 1 (length (scene-entities scene))) @@ -252,7 +254,7 @@ (let* ((p (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player))) (e (list #: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: (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)) @@ -263,7 +265,7 @@ (p2 (list #:type 'ally #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(ally friendly))) (e (list #: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: (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)))) |