From 526e6cdcdf1025d5e29680bc99ab910c79789764 Mon Sep 17 00:00:00 2001 From: Gene Pasquet Date: Sun, 5 Apr 2026 14:17:51 +0100 Subject: Initial port of macroknight to an engine --- tests/entity-test.scm | 116 +++++++++ tests/input-test.scm | 174 ++++++++++++++ tests/physics-test.scm | 626 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/renderer-test.scm | 92 +++++++ tests/tilemap-test.scm | 204 ++++++++++++++++ tests/world-test.scm | 239 ++++++++++++++++++ 6 files changed, 1451 insertions(+) create mode 100644 tests/entity-test.scm create mode 100644 tests/input-test.scm create mode 100644 tests/physics-test.scm create mode 100644 tests/renderer-test.scm create mode 100644 tests/tilemap-test.scm create mode 100644 tests/world-test.scm (limited to 'tests') diff --git a/tests/entity-test.scm b/tests/entity-test.scm new file mode 100644 index 0000000..3e1f85e --- /dev/null +++ b/tests/entity-test.scm @@ -0,0 +1,116 @@ +(import srfi-64) +(include "entity.scm") +(import entity) + +(test-begin "entity") + +;; Test: entity-ref retrieves values from entity plists +(test-group "entity-ref" + (let ((entity '(#:type player #:x 100 #: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 with default value + (let ((entity '(#:type player))) + (test-equal "returns default for missing key" + 99 + (entity-ref entity #:x 99)) + (test-equal "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" + 42 + (entity-ref entity #:x (lambda () 42))))) + +;; 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))) + + (let ((no-type '(#:x 100 #:y 200))) + (test-equal "returns #f for entity without type" + #f + (entity-type no-type)))) + +;; Test: make-player-entity creates valid player entity +(test-group "make-player-entity" + (let ((player (make-player-entity 50 75 16 16))) + (test-assert "returns a list" (list? player)) + (test-equal "has correct type" 'player (entity-ref player #:type)) + (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-equal "has initial tile-id" 29 (entity-ref player #:tile-id)))) + +;; Test: complex entity with multiple properties +(test-group "complex-entity" + (let ((entity '(#:type enemy + #:x 100 + #:y 200 + #:width 16 + #:height 16 + #: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: 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)) + ;; plist length should shrink from 4 to 4 (same — one pair removed, one added) + ;; stronger: verify the list length stays at 4, not 6 + (test-equal "no duplicate key: list length unchanged" 4 (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" 4 (length e))))) + +;; 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-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-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-group "no duplicate keys" + (let ((e (entity-update '(#:x 10 #:y 20) #:x (lambda (v) (* v 2))))) + (test-equal "length is 4" 4 (length e))))) + +;; Test: make-player-entity velocity fields +(test-group "make-player-entity-velocity-fields" + (let* ((p (make-player-entity 5 10 16 16)) + (imap (entity-ref p #:input-map #f))) + (test-equal "vx defaults to 0" 0 (entity-ref p #:vx)) + (test-equal "vy defaults to 0" 0 (entity-ref p #:vy)) + (test-assert "input-map is present" imap) + ;; Each entry is (action . (dvx . dvy)); assq returns (action . (dvx . dvy)) + (test-equal "left dvx" -2 (car (cdr (assq 'left imap)))) + (test-equal "left dvy" 0 (cdr (cdr (assq 'left imap)))) + (test-equal "right dvx" 2 (car (cdr (assq 'right imap)))) + (test-equal "right dvy" 0 (cdr (cdr (assq 'right imap)))))) + +(test-end "entity") diff --git a/tests/input-test.scm b/tests/input-test.scm new file mode 100644 index 0000000..822875e --- /dev/null +++ b/tests/input-test.scm @@ -0,0 +1,174 @@ +;; Load dependencies first +(import scheme + (chicken base) + (chicken format) + (only srfi-1 any filter fold alist-delete) + (only srfi-13 string-join) + (only srfi-197 chain) + (prefix sdl2 sdl2:) + simple-logger + srfi-64 + defstruct) + +;; Load entity first (input imports it) +(include "entity.scm") +(import entity) + +;; Load the module source directly +(include "input.scm") +;; Now import it to access the exported functions +(import input) + +;; Test suite for input module +(test-begin "input-module") + +;; Test: create-input-state initializes correctly +(test-group "create-input-state" + (let ((state (create-input-state *default-input-config*))) + (test-assert "returns an input-state record" (input-state? state)) + (test-assert "has current field" (list? (input-state-current state))) + (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: 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: input-pressed? detection +(test-group "input-pressed?" + (let* ((state1 (create-input-state *default-input-config*)) + ;; Simulate state transition: nothing -> up pressed + (state2 (make-input-state + (cons (cons 'up #t) (input-state-current state1)) + (input-state-current state1)))) + + ;; In state1, up is not pressed + (test-equal "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" + (input-pressed? state2 'up)))) + +;; Test: input-released? detection +(test-group "input-released?" + (let* ((state1 (create-input-state *default-input-config*)) + ;; State with up held + (state-held (make-input-state + (cons (cons 'up #t) (input-state-current state1)) + (input-state-current state1))) + ;; State with up released (current=#f, previous=#t) + (state-released (make-input-state + (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-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" + #f + (input-any-pressed? state1 *default-input-config*)))) + +;; Test: input-state->string formatting +(test-group "input-state->string" + (let* ((state (create-input-state *default-input-config*)) + (str (input-state->string state *default-input-config*))) + (test-assert "returns a string" (string? str)) + (test-assert "contains [Input:" (string-contains str "[Input:")) + (test-assert "empty state shows no actions" + (or (string-contains str "[]") + (string-contains str "[Input: ]"))))) + +;; Test: state transitions +(test-group "state-transitions" + (let* ((state1 (create-input-state *default-input-config*)) + ;; Manually create state2 where 'up' is pressed + (state2 (make-input-state + (cons (cons 'up #t) + (filter (lambda (p) (not (eq? (car p) 'up))) + (input-state-current state1))) + (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-assert "up held in state2" (input-held? state2 'up)) + (test-assert "up pressed in state2" (input-pressed? state2 'up)) + + ;; Now create state3 where up is still held (not pressed anymore) + (let ((state3 (make-input-state + (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)" + #f + (input-pressed? state3 'up))))) + +;; Test: apply-input-to-entity applies input to entity +(test-group "apply-input-to-entity" + (test-group "no input-map: entity unchanged" + (let* ((e '(#:type player #:x 5 #:y 10)) + (out (apply-input-to-entity e (lambda (a) #f)))) + (test-equal "entity returned as-is" e out))) + + (test-group "no actions held: velocity is zero" + (let* ((e (make-player-entity 0 0 16 16)) + (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-group "right held: vx=2 vy=0" + (let* ((e (make-player-entity 0 0 16 16)) + (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-group "right+down held: vx=2 vy unchanged" + (let* ((e (make-player-entity 0 0 16 16)) + (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-group "right held: facing set to 1" + (let* ((e (make-player-entity 0 0 16 16)) + (out (apply-input-to-entity e (lambda (a) (eq? a 'right))))) + (test-equal "facing is 1" 1 (entity-ref out #:facing 0)))) + + (test-group "left held: facing set to -1" + (let* ((e (make-player-entity 0 0 16 16)) + (out (apply-input-to-entity e (lambda (a) (eq? a 'left))))) + (test-equal "facing is -1" -1 (entity-ref out #:facing 0)))) + + (test-group "no key held: facing retains previous value" + (let* ((e (entity-set (make-player-entity 0 0 16 16) #: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-group "custom-input-config" + (let* ((cfg (make-input-config + actions: '(jump shoot) + keyboard-map: '((space . jump) (f . shoot)) + joy-button-map: '() + controller-button-map: '() + joy-axis-bindings: '() + controller-axis-bindings: '() + deadzone: 8000)) + (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-end "input-module") diff --git a/tests/physics-test.scm b/tests/physics-test.scm new file mode 100644 index 0000000..4c6d4a6 --- /dev/null +++ b/tests/physics-test.scm @@ -0,0 +1,626 @@ +;; Load dependencies first +(import scheme + (chicken base) + (chicken keyword) + defstruct + srfi-64 + (only srfi-1 every member make-list fold iota)) + +;; Create a mock tilemap module to avoid SDL dependency +(module tilemap * + (import scheme (chicken base) defstruct) + + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) + + (defstruct layer + name + width + height + map) + + (defstruct tilemap + width + height + tilewidth + tileheight + tileset-source + tileset + layers + objects)) + +(import tilemap) + +;; Load entity module first (since world now imports entity) +(include "entity.scm") +(import entity) + +;; Load world module first +(include "world.scm") +(import world) + +;; Load physics module +(include "physics.scm") +(import physics) + +;; Load physics module +(include "input.scm") +(import input) + +;; Test suite for physics module +(test-begin "physics-module") + +;; Helper to reduce tilemap boilerplate in tests +;; rows: list of lists of tile IDs, tiles are 16x16 +(define (make-test-tilemap rows) + (let* ((height (length rows)) + (width (length (car rows))) + (layer (make-layer name: "test" width: width height: height map: rows))) + (make-tilemap width: width height: height + tilewidth: 16 tileheight: 16 + tileset-source: "" tileset: #f + layers: (list layer) objects: '()))) + +;; Integration helper: simulate one frame of physics +(define (tick e tm held?) + (let* ((e (apply-input-to-entity e held?)) + (e (apply-gravity e)) + (e (apply-velocity-x e)) + (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)) + +;; Test: apply-gravity +(test-group "apply-gravity" + (test-group "gravity? true, vy starts at 0" + (let* ((e '(#:type rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t)) + (result (apply-gravity e))) + (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-group "gravity? true, vy already has value" + (let* ((e '(#:type rock #:x 0 #:y 0 #:vx 0 #:vy 3 #:gravity? #t)) + (result (apply-gravity e))) + (test-equal "vy increased by gravity" 4 (entity-ref result #:vy)))) + + (test-group "gravity? false" + (let* ((e '(#:type static #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #f)) + (result (apply-gravity e))) + (test-equal "vy unchanged" 0 (entity-ref result #:vy)))) + + (test-group "no gravity? field at all" + (let* ((e '(#:type static #:x 5 #:y 5)) + (result (apply-gravity e))) + (test-equal "entity unchanged" e result)))) + +(test-group "apply-velocity-x" + (test-group "basic horizontal movement" + (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 5 #:vy -2)) + (result (apply-velocity-x e))) + (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-group "zero vx" + (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 0 #:vy 3)) + (result (apply-velocity-x e))) + (test-equal "x unchanged" 10 (entity-ref result #:x)) + (test-equal "y unchanged" 20 (entity-ref result #:y))))) + +(test-group "apply-velocity-y" + (test-group "basic vertical movement" + (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 3 #:vy -5)) + (result (apply-velocity-y e))) + (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-group "zero vy" + (let* ((e '(#:type rock #:x 10 #:y 20 #:vx 3 #:vy 0)) + (result (apply-velocity-y e))) + (test-equal "x unchanged" 10 (entity-ref result #:x)) + (test-equal "y unchanged" 20 (entity-ref result #:y))))) + +(test-group "apply-velocity" + (test-group "basic movement" + (let* ((e '(#: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-group "zero velocity" + (let* ((e '(#: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-group "no velocity fields (defaults to 0)" + (let* ((e '(#: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-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-group "two columns one row" + (let ((cells (build-cell-list 11 12 22 22))) + (test-equal "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-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-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-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) + (col-start (inexact->exact (floor (/ x tw)))) + (col-end (inexact->exact (floor (/ (- (+ x w) 1) tw)))) + (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-assert "all cells are pairs" (every pair? cells))))) + +(test-group "resolve-tile-collisions-x" + (test-group "no collision: entity unchanged" + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) + (e '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "x unchanged" 0 (entity-ref result #:x)) + (test-equal "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 '(#: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 e tm)))) + + (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 '(#:type player #:x 20 #:y 16 #:width 16 #:height 16 #:vx 5 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) + (test-equal "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 '(#:type player #:x 16 #:y 16 #:width 16 #:height 16 #:vx -5 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "pushed right of solid tile" 32 (entity-ref result #:x)) + (test-equal "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 '(#:type player #:x 20.5 #:y 16 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "pushed left of solid tile" 0 (entity-ref result #:x)) + (test-equal "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 '(#:type player #:x 28 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "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 '(#:type player #:x 34 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x e tm))) + (test-equal "pushed left of wall" 28 (entity-ref result #:x)) + (test-equal "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 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "y unchanged" 0 (entity-ref result #:y)) + (test-equal "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 '(#: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 e tm)))) + + (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 '(#:type player #:x 0 #:y 20 #:width 16 #:height 16 #:vx 0 #:vy 5))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) + (test-equal "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 '(#:type player #:x 16 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy -5))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "pushed below solid tile" 32 (entity-ref result #:y)) + (test-equal "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 '(#:type player #:x 0 #:y 20.5 #:width 16 #:height 16 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "pushed above solid tile" 0 (entity-ref result #:y)) + (test-equal "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 '(#:type player #:x 0 #:y 28 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "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 '(#:type player #:x 0 #:y 34 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y e tm))) + (test-equal "pushed above floor" 28 (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)" + ;; 3x4 tilemap: air on rows 0-2, solid floor on row 3 + ;; Player starts at y=0, 16px tall; floor is at y=48 + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0) (1 1 1)))) + (e0 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:input-map ()))) + (let loop ((e e0) (n 10)) + (if (= n 0) + (begin + (test-assert "player rests at or above floor" (<= (entity-ref e #:y) 32)) + (test-assert "y is non-negative" (>= (entity-ref e #:y) 0))) + (loop (tick e tm (lambda (a) #f)) (- n 1)))))) + + (test-group "player stable on floor (10 frames of gravity jitter)" + ;; Player already on floor, should stay there + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 1 1)))) + ;; Floor at row 2 (y=32); player at y=16, height=16: bottom at y=32 + (e0 '(#:type player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:input-map ()))) + (let loop ((e e0) (n 10)) + (if (= n 0) + (test-assert "player stays on floor" (<= (entity-ref e #:y) 16)) + (loop (tick e tm (lambda (a) #f)) (- n 1)))))) + + (test-group "player with real starting coordinates (x=182 y=350.5) falls 5 frames" + ;; Use a large enough tilemap: 15 cols x 25 rows, solid floor at row 24 + (let* ((empty-row (make-list 15 0)) + (solid-row (make-list 15 1)) + (rows (append (make-list 24 empty-row) (list solid-row))) + (tm (make-test-tilemap rows)) + (e0 (make-player-entity 182 350.5 16 16))) + ;; Should not crash + (let loop ((e e0) (n 5)) + (if (= n 0) + (test-assert "player survived 5 frames" #t) + (loop (tick e tm (lambda (a) #f)) (- n 1))))))) + +(test-group "resolve-entity-collisions" + (define (make-solid x y w h) + (list #:type 'block #:x x #:y y #:width w #:height h #:solid? #t)) + + (test-group "no overlap: entities unchanged" + (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-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 + ;; push on x (smaller), each by 3px + (let* ((a (make-solid 0 0 16 16)) + (b (make-solid 10 0 16 16)) + (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-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 + (let* ((a (make-solid 0 0 16 16)) + (b (make-solid 0 10 16 16)) + (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-group "non-solid entity ignored" + (let* ((a (make-solid 0 0 16 16)) + (b (list #: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))))) + +;; New tests for detect-ground and apply-jump +(test-group "detect-ground" + (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 + ;; Entity standing: y=16, h=16 → bottom at y=32, probe at y=33 → row=2 → solid + (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))) + (test-assert "on-ground? is #t" (entity-ref result #:on-ground? #f)))) + + (test-group "entity in mid-air" + ;; Entity in mid-air: y=0, h=16 → bottom at 16, probe at 17 → row=1 → empty + (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))) + (test-assert "on-ground? is #f" (not (entity-ref result #:on-ground? #f))))) + + (test-group "entity probe spans two tiles, left is solid" + ;; Entity at x=0, w=16: left foot at col 0; probe below + ;; Row with solid at col 0, empty at col 1: should be on-ground + (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))) + (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" + ;; Entity at x=8, w=16: left foot at col 0, right foot at col 1; probe below + ;; Row with empty at col 0, solid at col 1: should be on-ground (right foot on solid) + (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))))) + +(test-group "apply-jump" + (test-group "on-ground and pressed → impulse applied" + (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:on-ground? #t)) + (result (apply-jump e #t))) + (test-equal "ay is -jump-force" (- *jump-force*) (entity-ref result #:ay 0)))) + + (test-group "on-ground but not pressed → unchanged" + (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:on-ground? #t)) + (result (apply-jump e #f))) + (test-equal "vy unchanged" 0 (entity-ref result #:vy 0)))) + + (test-group "in-air and pressed → no double jump" + (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy -5 #:on-ground? #f)) + (result (apply-jump e #t))) + (test-equal "vy unchanged (no double jump)" -5 (entity-ref result #:vy 0)))) + + (test-group "in-air and not pressed → unchanged" + (let* ((e (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy -5 #:on-ground? #f)) + (result (apply-jump e #f))) + (test-equal "vy unchanged" -5 (entity-ref result #:vy 0))))) + +(test-group "apply-acceleration" + (test-group "gravity? #t, ay set: consumed into vy and cleared" + (let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t)) + (result (apply-acceleration e))) + (test-equal "vy += ay" 8 (entity-ref result #:vy 0)) + (test-equal "ay cleared" 0 (entity-ref result #:ay 0)))) + + (test-group "gravity? #t, ay is 0: vy unchanged" + (let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 0 #:gravity? #t)) + (result (apply-acceleration e))) + (test-equal "vy unchanged" 3 (entity-ref result #:vy 0)) + (test-equal "ay still 0" 0 (entity-ref result #:ay 0)))) + + (test-group "gravity? #f: entity unchanged" + (let* ((e '(#:type player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #f)) + (result (apply-acceleration e))) + (test-equal "entity unchanged" e 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-group "entity-tile-cells" + (test-group "entity aligned to one tile" + (let* ((tm (make-test-tilemap '((0 0) (0 0)))) + (e '(#: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-group "entity spanning 2 cols and 2 rows" + (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) + (e '(#:type player #:x 8 #:y 8 #:width 16 #:height 16)) + (cells (entity-tile-cells e tm))) + (test-equal "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-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-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-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-group "n=3: three pairs" + (let ((pairs (index-pairs 3))) + (test-equal "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-group "axis->velocity" + (test-equal "#:x → #:vx" #:vx (axis->velocity #:x)) + (test-equal "#:y → #:vy" #:vy (axis->velocity #:y))) + +(test-group "push-entity" + (test-group "push right (sign=1): x += overlap/2, vx=1" + (let* ((e '(#: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-group "push left (sign=-1): x -= overlap/2, vx=-1" + (let* ((e '(#: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-group "entity-center-on-axis" + (let ((e '(#: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-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 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#:type player #:x 10 #:y 0 #:width 16 #:height 16))) + (test-equal "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 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#:type player #:x 0 #:y 10 #:width 16 #:height 16))) + (test-equal "y overlap = 6" 6 (aabb-overlap-on-axis #:y a b)))) + + (test-group "no overlap: negative value" + (let ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#:type player #:x 100 #:y 0 #:width 16 #:height 16))) + (test-assert "x overlap is negative" (< (aabb-overlap-on-axis #:x a b) 0))))) + +(test-group "push-along-axis" + (test-group "x axis: a left of b, pushed apart" + (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#:type player #:x 10 #:y 0 #:width 16 #:height 16)) + (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-group "y axis: a above b, pushed apart" + (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#:type player #:x 0 #:y 10 #:width 16 #:height 16)) + (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-group "push-apart" + (test-group "x overlap smaller: pushes on x axis" + ;; a at (0,0), b at (10,0), both 16x16: ovx=6, ovy=16 → push on x + (let* ((a '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#: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-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 '(#:type player #:x 0 #:y 0 #:width 16 #:height 16)) + (b '(#: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-group "resolve-pair" + (define (make-solid x y) (list #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + + (test-group "one entity not solid: returns #f" + (let ((a (make-solid 0 0)) + (b '(#:type ghost #:x 5 #:y 5 #:width 16 #:height 16))) + (test-assert "returns #f" (not (resolve-pair a b))))) + + (test-group "no overlap: returns #f" + (let ((a (make-solid 0 0)) + (b (make-solid 100 0))) + (test-assert "returns #f" (not (resolve-pair a b))))) + + (test-group "overlap: returns (a2 . b2) pair" + (let* ((a (make-solid 0 0)) + (b (make-solid 10 0)) + (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-group "aabb-overlap?" + (test-group "two boxes clearly overlapping" + (test-assert "boxes overlap in center" + (aabb-overlap? 0 0 10 10 5 5 10 10))) + + (test-group "two boxes not overlapping (separated horizontally)" + (test-assert "boxes don't overlap when separated on x-axis" + (not (aabb-overlap? 0 0 10 10 20 0 10 10)))) + + (test-group "two boxes not overlapping (separated vertically)" + (test-assert "boxes don't overlap when separated on y-axis" + (not (aabb-overlap? 0 0 10 10 0 20 10 10)))) + + (test-group "edge-touching exactly" + (test-assert "touching edges are not overlapping" + (not (aabb-overlap? 0 0 10 10 10 0 10 10)))) + + (test-group "one box fully inside another" + (test-assert "inner box overlaps with outer" + (aabb-overlap? 0 0 20 20 5 5 10 10)))) + +(test-end "physics-module") diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm new file mode 100644 index 0000000..a8fdeed --- /dev/null +++ b/tests/renderer-test.scm @@ -0,0 +1,92 @@ +;; Load base deps +(import scheme + (chicken base) + (chicken keyword) + (only srfi-1 fold iota for-each) + defstruct + srfi-64) + +;; Mock tilemap module +(module tilemap * + (import scheme (chicken base) defstruct) + (defstruct tileset tilewidth tileheight spacing tilecount columns image-source image) + (defstruct layer name width height map) + (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)) +(import tilemap) + +;; Mock sdl2 +(module sdl2 * + (import scheme (chicken base)) + (define (make-rect x y w h) (list x y w h)) + (define (render-copy! . args) #f) + (define (render-copy-ex! . args) #f) + (define (create-texture-from-surface . args) #f)) +(import (prefix sdl2 "sdl2:")) + +;; Mock sdl2-ttf +(module sdl2-ttf * + (import scheme (chicken base)) + (define (render-text-solid . args) #f) + (define (size-utf8 . args) (values 0 0))) +(import (prefix sdl2-ttf "ttf:")) + +;; Load entity module +(include "entity.scm") +(import entity) + +;; Load world module +(include "world.scm") +(import world) + +;; Load renderer module +(include "renderer.scm") +(import renderer) + +(test-begin "renderer") + +(test-group "entity-screen-coords" + (let* ((cam (make-camera x: 10 y: 20)) + (e (list #:x 50 #:y 80 #:width 16 #:height 16))) + (test-equal "subtracts camera offset from x" + 40 + (car (entity-screen-coords e cam))) + (test-equal "subtracts camera offset from y" + 60 + (cadr (entity-screen-coords e cam))) + (test-equal "preserves width" + 16 + (caddr (entity-screen-coords e cam))) + (test-equal "preserves height" + 16 + (cadddr (entity-screen-coords e cam)))) + + (let* ((cam (make-camera x: 0 y: 0)) + (e (list #:x 100.7 #:y 200.3 #:width 16 #:height 16))) + (test-equal "floors fractional x" + 100 + (car (entity-screen-coords e cam))) + (test-equal "floors fractional y" + 200 + (cadr (entity-screen-coords e cam)))) + + (let* ((cam (make-camera x: 0 y: 0)) + (e (list #:x 0 #:y 0 #:width 32 #:height 32))) + (test-equal "zero camera, zero position" + '(0 0 32 32) + (entity-screen-coords e cam)))) + +(test-group "entity-flip" + (test-equal "facing 1: no flip" + '() + (entity-flip (list #:facing 1))) + (test-equal "facing -1: horizontal flip" + '(horizontal) + (entity-flip (list #:facing -1))) + (test-equal "no facing key: defaults to no flip" + '() + (entity-flip (list #:x 0)))) + +(test-end "renderer") diff --git a/tests/tilemap-test.scm b/tests/tilemap-test.scm new file mode 100644 index 0000000..a76cff9 --- /dev/null +++ b/tests/tilemap-test.scm @@ -0,0 +1,204 @@ +;; Load dependencies first +(import scheme + (chicken base) + (chicken io) + (chicken file) + (chicken format) + (chicken string) + (chicken pathname) + (chicken process-context) + (chicken pretty-print) + (only srfi-1 filter-map) + expat + matchable + defstruct + (prefix sdl2 sdl2:) + (prefix sdl2-image img:) + srfi-69 + srfi-64) + +;; Load the module source directly +(include "tilemap.scm") +;; Now import it to access the exported functions +(import tilemap) + +;; Test suite for tilemap module +(test-begin "tilemap-module") + +;; Test: tileset record creation +(test-group "tileset-structure" + (let ((ts (make-tileset tilewidth: 16 + tileheight: 16 + spacing: 1 + tilecount: 100 + columns: 10 + 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: tileset-rows calculation +(test-group "tileset-rows" + (let ((ts (make-tileset tilewidth: 16 + tileheight: 16 + spacing: 1 + tilecount: 100 + columns: 10 + image-source: "test.png" + image: #f))) + (test-equal "100 tiles / 10 columns = 10 rows" + 10 + (tileset-rows ts))) + + (let ((ts (make-tileset tilewidth: 16 + tileheight: 16 + spacing: 1 + tilecount: 105 + columns: 10 + image-source: "test.png" + image: #f))) + (test-equal "105 tiles / 10 columns = 11 rows (ceiling)" + 11 + (tileset-rows ts)))) + +;; Test: tileset-tile calculates correct tile position +(test-group "tileset-tile" + (let* ((ts (make-tileset tilewidth: 16 + tileheight: 16 + spacing: 1 + tilecount: 100 + columns: 10 + image-source: "test.png" + image: #f)) + (tile1 (tileset-tile ts 1)) + (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-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))) + + ;; 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: layer record creation +(test-group "layer-structure" + (let ((layer (make-layer name: "ground" + width: 40 + 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: object record creation +(test-group "object-structure" + (let ((obj (make-object name: "player" + type: "Player" + x: 100 + y: 200 + width: 16 + 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: tilemap record creation +(test-group "tilemap-structure" + (let ((tm (make-tilemap width: 40 + height: 30 + tilewidth: 16 + tileheight: 16 + tileset-source: "test.tsx" + tileset: '() + 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: 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-assert "rect is an SDL rect" (sdl2:rect? (tile-rect tile))))) + +;; Test: parse-tileset XML parsing +(test-group "parse-tileset" + (let* ((xml " + + +") + (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: parse-tilemap XML parsing +(test-group "parse-tilemap" + (let* ((xml " + + + + +1,2,3,4,5,6,7,8,9,10, +11,12,13,14,15,16,17,18,19,20 + + +") + (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-assert "has layers" (not (null? (tilemap-layers tm)))) + (test-equal "first layer name" "ground" (layer-name (car (tilemap-layers tm)))))) + +;; Test: parse-tilemap with objects +(test-group "parse-tilemap-with-objects" + (let* ((xml " + + + + + + + + + +") + (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-end "tilemap-module") diff --git a/tests/world-test.scm b/tests/world-test.scm new file mode 100644 index 0000000..c758d2a --- /dev/null +++ b/tests/world-test.scm @@ -0,0 +1,239 @@ +;; Load dependencies first +(import scheme + (chicken base) + (chicken keyword) + defstruct + srfi-64 + (only srfi-1 every member make-list)) + +;; Create a mock tilemap module to avoid SDL dependency +(module tilemap * + (import scheme (chicken base) defstruct) + + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) + + (defstruct layer + name + width + height + map) + + (defstruct tilemap + width + height + tilewidth + tileheight + tileset-source + tileset + layers + objects)) + +(import tilemap) + +;; Load entity module first (since world now imports entity) +(include "entity.scm") +(import entity) + +;; Load the module source directly +(include "world.scm") +;; Now import it to access the exported functions +(import world) + +;; Test suite for world module +(test-begin "world-module") + +;; Test: tilemap-tile-at retrieves tile IDs +(test-group "tilemap-tile-at" + (test-group "valid positions in a small 3x3 tilemap" + (let* ((layer1 (make-layer name: "test" width: 3 height: 3 + map: '((1 2 3) (4 5 6) (7 8 9)))) + (tm (make-tilemap width: 3 height: 3 + tilewidth: 16 tileheight: 16 + tileset-source: "" + 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-group "out-of-bounds returns 0" + (let* ((layer1 (make-layer name: "test" width: 3 height: 3 + map: '((1 2 3) (4 5 6) (7 8 9)))) + (tm (make-tilemap width: 3 height: 3 + tilewidth: 16 tileheight: 16 + tileset-source: "" + 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-group "zero tiles are skipped to next layer" + (let* ((layer1 (make-layer name: "test1" width: 3 height: 3 + map: '((0 0 0) (0 0 0) (0 0 0)))) + (layer2 (make-layer name: "test2" width: 3 height: 3 + map: '((1 2 3) (4 5 6) (7 8 9)))) + (tm (make-tilemap width: 3 height: 3 + tilewidth: 16 tileheight: 16 + tileset-source: "" + tileset: #f + layers: (list layer1 layer2) + objects: '()))) + (test-equal "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))) + (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: scene with entities and tilemap +(test-group "scene-with-data" + (let* ((player (make-player-entity 100 100 16 16)) + (enemy '(#:type enemy #:x 200 #:y 200)) + (tilemap "mock-tilemap") + (scene (make-scene entities: (list player enemy) + tilemap: tilemap))) + (test-equal "scene has 2 entities" + 2 + (length (scene-entities scene))) + (test-equal "first entity is player" + 'player + (entity-type (car (scene-entities scene)))) + (test-equal "tilemap is set correctly" + "mock-tilemap" + (scene-tilemap scene)))) + +;; 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)) + (enemy '(#:type enemy #:x 200 #:y 200))) + + (test-equal "initial entity count" 1 (length (scene-entities scene))) + + (scene-add-entity scene enemy) + + (test-equal "entity count after add" 2 (length (scene-entities scene))) + (test-equal "second entity is enemy" + 'enemy + (entity-type (cadr (scene-entities scene)))))) + +;; Test: scene-add-entity appends to end +(test-group "scene-add-entity-order" + (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-add-entity scene e2) + (scene-add-entity scene e3) + + (test-equal "entities are in order" + '(a b c) + (map entity-type (scene-entities scene))))) + +;; Test: scene-update-entities applies function to all entities +(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)) + ;; Function that moves all entities right by 10 + (move-right (lambda (entity) + (let ((x (entity-ref entity #:x)) + (y (entity-ref entity #:y)) + (type (entity-ref entity #:type))) + (list #:type type #:x (+ x 10) #:y y))))) + + (scene-update-entities scene move-right) + + (test-equal "first entity moved right" + 110 + (entity-ref (car (scene-entities scene)) #:x)) + (test-equal "second entity moved right" + 210 + (entity-ref (cadr (scene-entities scene)) #:x)) + (test-equal "y values unchanged" + 100 + (entity-ref (car (scene-entities scene)) #:y)))) + +;; Test: scene-update-entities with identity function +(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-update-entities scene (lambda (e) e)) + + (test-equal "entity count unchanged" 2 (length (scene-entities scene))) + (test-equal "first entity unchanged" + 100 + (entity-ref (car (scene-entities scene)) #:x)))) + +;; Test: scene mutation +(test-group "scene-mutation" + (let* ((scene (make-scene entities: '() tilemap: #f)) + (player (make-player-entity 10 20 16 16))) + + ;; Add entity + (scene-add-entity scene player) + (test-equal "entity added" 1 (length (scene-entities scene))) + + ;; Update entities + (scene-update-entities scene + (lambda (e) + (let ((x (entity-ref e #:x)) + (y (entity-ref e #:y)) + (type (entity-type e))) + (list #: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: scene-tilemap-set! +(test-group "scene-tilemap-mutation" + (let ((scene (make-scene entities: '() tilemap: #f))) + (test-equal "tilemap initially #f" #f (scene-tilemap scene)) + + (scene-tilemap-set! scene "new-tilemap") + (test-equal "tilemap updated" "new-tilemap" (scene-tilemap scene)))) + +;; Create a test tilemap for the filter test +(define test-tilemap + (make-tilemap width: 3 height: 3 + tilewidth: 16 tileheight: 16 + tileset-source: "" + tileset: #f + layers: '() + objects: '())) + +;; Test: scene-filter-entities +(test-group "scene-filter-entities" + (let* ((e1 (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (e2 (list #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16)) + (scene (make-scene entities: (list e1 e2) + tilemap: test-tilemap + camera: (make-camera x: 0 y: 0) + tileset-texture: #f))) + (scene-filter-entities scene + (lambda (e) (eq? (entity-ref e #:type #f) 'player))) + (test-equal "keeps matching entities" 1 (length (scene-entities scene))) + (test-equal "kept entity is player" + 'player + (entity-ref (car (scene-entities scene)) #:type #f)))) + +(test-end "world-module") -- cgit v1.2.3