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 --- .gitignore | 9 + CLAUDE.md | 193 +++++++++++++++ Makefile | 43 ++++ README.org | 125 ++++++++++ TODO.org | 1 + entity.scm | 45 ++++ input.scm | 184 ++++++++++++++ physics.scm | 238 ++++++++++++++++++ renderer.scm | 88 +++++++ 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 ++++++++++++++++++ tilemap.scm | 235 ++++++++++++++++++ world.scm | 59 +++++ 17 files changed, 2671 insertions(+) create mode 100644 .gitignore create mode 100644 CLAUDE.md create mode 100644 Makefile create mode 100644 README.org create mode 120000 TODO.org create mode 100644 entity.scm create mode 100644 input.scm create mode 100644 physics.scm create mode 100644 renderer.scm 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 create mode 100644 tilemap.scm create mode 100644 world.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..47a40fa --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +\#*\# +.\#* +*~ +/bin/ +*.import.scm +*.o +*.log +logs +/.agent-shell/ diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..fb196e5 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,193 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## What this is + +**Downstroke** is a 2D tile-driven game engine for Chicken Scheme, built on SDL2. API inspired by Phaser 2: a minimal game is ~20 lines of Scheme. + +The engine is being extracted from the testbed game **macroknight** (`/home/gene/src/macroknight`). Milestones 1–6 are pure refactoring (no behavior changes); Milestone 7 is the design pivot where the public API stabilizes. + +**Detailed extraction plan**: `/home/gene/src/macroknight/TODO-engine.org` +**Project milestones**: `/home/gene/Documents/Perso/Projects/downstroke.org` (also in README.org) + +## Target API + +```scheme +(define my-game + (make-game + title: "My Game" width: 600 height: 400 + preload: (lambda (game) ...) ; load assets + create: (lambda (game) ...) ; init scene + update: (lambda (game dt) ...))) ; game-specific logic (physics runs first) + +(game-run! my-game) +``` + +Built-in physics pipeline (runs before user `update:` hook): +``` +input → acceleration → gravity → velocity-x → tile-collision-x → +velocity-y → tile-collision-y → ground-detection → entity-collisions +``` + +## Build & Test (macroknight — source of truth) + +All engine code currently lives in `/home/gene/src/macroknight`. Until Milestone 1 is complete, build and test from there. + +```bash +cd /home/gene/src/macroknight + +make # compile all modules + link bin/game +make test # run all 8 SRFI-64 test suites via csi +make clean # remove bin/ and .import.scm files + +# Run a single test module: +csi -s tests/physics-test.scm +csi -s tests/entity-test.scm +# etc. +``` + +Once extraction begins, the downstroke Makefile must also build all demos: + +```bash +make # compile engine + all demos in demo/ +make test # run all SRFI-64 test suites +make demos # build demo games only (verify they compile) +``` + +**Module compile order** (dependency order, must be respected in Makefile): +`tilemap → entity → world → animation → physics → ai → input → prefabs → mixer → sound` + +Modules are compiled as **units** (`csc -c -J -unit $*`) to avoid C toplevel name collisions when linking multiple `.o` files. Each module generates both a `.o` and a `.import.scm` in `bin/`. + +## Test-Driven Development + +**Tests are mandatory for all engine code.** Write tests before or alongside implementation — never after. The test suite is the primary correctness guarantee for the engine, since behavior regressions are easy to introduce during extraction. + +- Test files live in `tests/`, named `-test.scm` +- Framework: SRFI-64 (`test-begin`, `test-equal`, `test-assert`, `test-end`) +- Tests run via `csi -s` (interpreter, not compiled) and must not require SDL2 — mock or stub any SDL2-dependent code +- Each engine module must have a corresponding test module before the module is considered done + +## Documentation + +End-user documentation lives in `docs/` as **org-mode files** and must be kept up to date as the API evolves. This is not optional — docs ship with the egg. + +- `docs/api.org` — public API reference (`make-game`, `game-run!`, all accessors and hooks) +- `docs/guide.org` — getting started guide with the minimal ~20-line game example +- `docs/entities.org` — entity model, plist keys, prefab/mixin system +- `docs/physics.org` — physics pipeline, collision model, gravity/velocity API + +When adding or changing any public-facing function or keyword argument, update the relevant doc file in the same commit. + +## Demo Games + +`demo/` contains small self-contained example games that exercise the engine API. They serve as living documentation and integration tests. + +- Each demo is a single `.scm` file (plus any assets in `demo//`) +- The Makefile must build all demos as part of `make` or `make demos` — a demo that fails to compile is a build failure +- Demos should be minimal: one mechanic per demo (gravity+jump, tilemap rendering, animation, etc.) +- Do not add game-specific logic to the engine to make a demo work; if a demo needs something, it belongs in the engine's public API + +## Engine Module Architecture + +| Module | File | Responsibility | +|---|---|---| +| `engine` | engine.scm | `make-game`, `game-run!`, lifecycle orchestration | +| `world` | world.scm | Scene struct, entity list ops, camera | +| `entity` | entity.scm | Entity plist accessors (`entity-ref`, `entity-set`, `entity-type`) | +| `physics` | physics.scm | Gravity, velocity, AABB tile + entity collisions, ground detection | +| `tilemap` | tilemap.scm | TMX/TSX XML parsing (expat), tileset loading, tile rect calculations | +| `input` | input.scm | SDL2 event → action mapping, keyboard/joystick/controller | +| `animation` | animation.scm | Frame/tick tracking, sprite ID mapping, animation state machine | +| `prefabs` | prefabs.scm | Mixin composition, prefab data loading, entity instantiation + hooks | +| `ai` | ai.scm | FSM-based enemy AI (idle/patrol/chase) via `states` egg | +| `renderer` | renderer.scm | SDL2 drawing abstraction: `draw-sprite`, `draw-tilemap-layer`, `draw-text` | +| `assets` | assets.scm | Asset registry for `preload:` lifecycle hook | +| `scene-loader` | scene-loader.scm | `game-load-scene!`, `instantiate-prefab` | +| `sound` | sound.scm | Sound registry, music playback | +| `mixer` | mixer.scm | SDL_mixer FFI bindings (no Scheme dependencies) | + +## Entity Model + +Entities are **plists** (property lists) — no classes, pure data + functions: + +```scheme +(list #:type 'player + #:x 100 #:y 200 + #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #t + #:on-ground? #f + #:tile-id 29 ; sprite index in tileset + #:tags '(player) + #:anim-name 'walk + #:animations ((idle #:frames (28) #:duration 10) + (walk #:frames (27 28) #:duration 10))) +``` + +Key shared entity keys: `#:type`, `#:x`, `#:y`, `#:width`, `#:height`, `#:vx`, `#:vy`, `#:tile-id`, `#:tags`. + +Access via `entity-ref`, `entity-set` (returns new plist — functional/immutable), `entity-type`. + +## Scene & Camera + +```scheme +(make-scene + entities: (list ...) + tilemap: tm + camera: (make-camera x: 0 y: 0) + tileset-texture: tex) +``` + +## Prefab / Mixin System + +```scheme +(mixins + (physics-body #:vx 0 #:vy 0 ...) + (has-facing #:facing 1)) + +(prefabs + (player physics-body has-facing #:type player #:tile-id 29 ...)) +``` + +Prefabs are loaded from a data file (`assets/prefabs.scm`). `instantiate-prefab` merges mixins + overrides into a fresh entity plist. + +## Tile Collision Model + +Tiles come from TMX maps (Tiled editor). The tilemap module parses TMX XML via expat into a struct with layers, tile GIDs, and a tileset. Collision tiles are identified by metadata in the TSX tileset. The physics module checks all tile cells overlapping an entity's AABB and snaps the entity to the nearest edge (velocity-direction-aware). + +## AI State Machine + +Uses the `states` egg. States: `idle → patrol → chase → patrol` (cycles back). Guards: `player-in-range?`, `player-in-attack-range?`, `chase-give-up?`. After Milestone 10, hardcoded `'player` type checks are replaced with `(scene-find-tagged scene 'player)`. + +## Dependencies + +System: `SDL2`, `SDL2_mixer`, `SDL2_ttf`, `SDL2_image` + +Chicken eggs: `sdl2`, `sdl2-image`, `expat`, `matchable`, `defstruct`, `states`, `srfi-64` (tests), `srfi-197` + +## Egg Packaging + +Downstroke is distributed as a **Chicken egg** named `downstroke`. The egg spec (`downstroke.egg`) declares all modules as installable units. Once published, games depend on it via `chicken-install downstroke`. + +Module namespacing follows the egg convention: `downstroke/physics`, `downstroke/world`, etc. All module source files live at the project root; the egg spec maps them to the namespaced identifiers. + +## Macroknight Port + +As soon as the first installable egg exists (Milestone 11), macroknight must be ported to depend on it. This is an ongoing obligation — macroknight is the primary validation that the engine API is usable. Any engine change that requires macroknight to be updated should update macroknight in the same work session. + +The ported macroknight `game.scm` is the definition of "Milestone 12 done": it should be ~20–30 lines, containing only `make-game` + lifecycle hooks + `game-run!`. + +## Tracking Progress + +As milestones and tasks are completed, update the TODO items in `/home/gene/Documents/Perso/Projects/downstroke.org`. Mark tasks with `DONE` as they are finished — this file is the authoritative project tracker. + +## Milestone Status + +Milestones 1–6: pure refactoring — extract modules into the project root, no behavior changes. +Milestone 7: design pivot — `make-game` + `game-run!` public API becomes stable. +Milestones 8–10: camera follow, scene state machine, AI tag lookup. +Milestones 11–12: package as Chicken egg, macroknight uses it as dependency. + +Current status: all milestones at 0/N — extraction has not yet begun. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..960f42e --- /dev/null +++ b/Makefile @@ -0,0 +1,43 @@ +.DEFAULT_GOAL := engine + +# Modules listed in dependency order +MODULE_NAMES := entity tilemap world input physics renderer +OBJECT_FILES := $(patsubst %,bin/%.o,$(MODULE_NAMES)) + +# Build all engine modules +engine: $(OBJECT_FILES) + +bin: + @mkdir -p $@ + +# Explicit inter-module dependencies +bin/entity.o: +bin/tilemap.o: +bin/world.o: bin/entity.o bin/tilemap.o +bin/input.o: bin/entity.o +bin/physics.o: bin/entity.o bin/world.o bin/tilemap.o +bin/renderer.o: bin/entity.o bin/tilemap.o bin/world.o + +# Pattern rule: compile each module as a library unit +bin/%.o bin/%.import.scm: %.scm | bin + csc -c -J -unit $* $*.scm -o bin/$*.o -I bin + @if [ -f $*.import.scm ]; then mv $*.import.scm bin/; fi + +.PHONY: clean test engine demos + +clean: + rm -rf bin + rm -f *.import.scm + rm -f *.log + +test: + @echo "Running unit tests..." + @csi -s tests/entity-test.scm + @csi -s tests/world-test.scm + @csi -s tests/tilemap-test.scm + @csi -s tests/physics-test.scm + @csi -s tests/input-test.scm + @csi -s tests/renderer-test.scm + +demos: + @echo "No demos yet." diff --git a/README.org b/README.org new file mode 100644 index 0000000..45db408 --- /dev/null +++ b/README.org @@ -0,0 +1,125 @@ +* Downstroke + +A 2D tile-driven game engine for Chicken Scheme, built on SDL2. Targets old-school platformer and arcade games — NES-style and beyond. The API is inspired by Phaser 2: one call to start, lifecycle hooks to fill in. A minimal game is ~20 lines of Scheme. + +#+begin_src scheme +(define my-game + (make-game + title: "My Game" width: 320 height: 240 + preload: (lambda (game) ...) ; load assets + create: (lambda (game) ...) ; set up scene + update: (lambda (game dt) ...))) ; per-frame logic (physics runs first) + +(game-run! my-game) +#+end_src + +** Features + +- Tile-based physics: gravity, velocity, AABB collision against TMX tilemaps +- Built-in update pipeline: input → acceleration → gravity → x-collision → y-collision → ground detection → entity collisions +- Entities as plists — purely functional, no classes +- Data-driven prefab/mixin system for composing entity types +- FSM-based enemy AI via the =states= egg +- Configurable input: keyboard, joystick, and controller +- Asset registry with =preload:= lifecycle hook +- Scene and camera management +- Sprite animation with frame/tick tracking +- SDL2_mixer audio via a thin FFI binding + +** Status + +Early extraction phase. The engine logic is fully working — it powers [[https://genepasquet.itch.io/macroknight][macroknight]], built for Spring Lisp Game Jam 2025. Work is underway to extract it into a standalone, installable Chicken egg. + +| Milestone | Description | Status | +|-----------+------------------------------------+----------| +| 1 | Zero-risk module extraction | DONE | +| 2 | Configurable input system | pending | +| 3 | Data-driven entity rendering | pending | +| 4 | Renderer abstraction | pending | +| 5 | Asset preloading | pending | +| 6 | Scene loading via =create:= hook | pending | +| 7 | =make-game= / =game-run!= API | pending | +| 8 | Camera follow | pending | +| 9 | Named scene states | pending | +| 10 | AI tag-based lookup | pending | +| 11 | Package as Chicken egg (v0.1.0) | pending | +| 12 | Macroknight ported to use the egg | pending | + +Milestones 1–6 are pure refactoring. Milestone 7 is the design pivot where the public API stabilises. Milestones 11–12 produce the first installable egg and validate it against macroknight. + +** Dependencies + +System libraries: =SDL2=, =SDL2_image=, =SDL2_mixer=, =SDL2_ttf= + +Chicken eggs: +#+begin_example +chicken-install sdl2 sdl2-image expat matchable defstruct states \ + srfi-197 simple-logger srfi-64 +#+end_example + +** Building + +#+begin_src sh +make # compile all modules to bin/ +make test # run SRFI-64 test suites +make demos # build demo games (verifies they compile) +make clean # remove bin/ +#+end_src + +Single test module: +#+begin_src sh +csi -s tests/physics-test.scm +#+end_src + +** Architecture + +Modules live at the project root. Each compiles as a Chicken unit (=csc -c -J -unit=). Compile order follows the dependency graph: + +: entity, tilemap → world → animation, physics, ai → input → prefabs → mixer → sound → engine + +| Module | Responsibility | +|----------------+---------------------------------------------------| +| =entity= | Plist accessors: =entity-ref=, =entity-set= | +| =tilemap= | TMX/TSX parsing (expat), tileset loading | +| =world= | Scene struct, entity list ops, camera | +| =physics= | Gravity, velocity, AABB tile + entity collisions | +| =input= | SDL2 events → action mapping, configurable binds | +| =animation= | Frame/tick tracking, sprite ID mapping | +| =ai= | FSM enemy AI: idle → patrol → chase → attack | +| =prefabs= | Mixin composition, entity instantiation | +| =renderer= | =draw-sprite=, =draw-tilemap-layer=, =draw-text= | +| =assets= | Asset registry for the =preload:= hook | +| =scene-loader= | =game-load-scene!=, =instantiate-prefab= | +| =mixer= | SDL_mixer FFI (no Scheme deps) | +| =sound= | Sound registry, music playback | +| =engine= | =make-game=, =game-run!=, lifecycle orchestration | + +Entities are plists — no classes, purely functional: + +#+begin_src scheme +(list #:type 'player + #:x 100 #:y 200 #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:tile-id 29 + #:tags '(player) + #:anim-name 'walk + #:animations '((idle #:frames (28) #:duration 10) + (walk #:frames (27 28) #:duration 10))) +#+end_src + +Entity types are composed from mixins declared in a data file: + +#+begin_src scheme +(mixins + (physics-body #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f) + (has-facing #:facing 1)) + +(prefabs + (player physics-body has-facing #:type player #:tile-id 29)) +#+end_src + +** Credits + +Engine extracted from [[https://genepasquet.itch.io/macroknight][macroknight]] (Spring Lisp Game Jam 2025). +Code: Gene Pasquet — Levels: Owen Pasquet — Art: [[https://kenney.nl][Kenney]] (1-bit pack) diff --git a/TODO.org b/TODO.org new file mode 120000 index 0000000..d2964da --- /dev/null +++ b/TODO.org @@ -0,0 +1 @@ +/home/gene/Documents/Perso/Projects/downstroke.org \ No newline at end of file diff --git a/entity.scm b/entity.scm new file mode 100644 index 0000000..cd467eb --- /dev/null +++ b/entity.scm @@ -0,0 +1,45 @@ +(module entity + * + (import scheme + (chicken base) + (chicken keyword) + (only srfi-1 fold)) + + ;; Entities = plists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). + + (define (entity-ref entity key #!optional default) + (get-keyword key entity (if (procedure? default) default (lambda () default)))) + + (define (entity-type entity) + (entity-ref entity #:type #f)) + + (define (entity-set entity key val) + (let ((cleaned (let loop ((lst entity) (acc '())) + (if (null? lst) + (reverse acc) + (let ((k (car lst)) + (v (cadr lst))) + (if (eq? k key) + (loop (cddr lst) acc) + (loop (cddr lst) (cons v (cons k acc))))))))) + (cons key (cons val cleaned)))) + + (define (entity-update entity key proc #!optional default) + (entity-set entity key (proc (entity-ref entity key default)))) + + (define (make-player-entity x y width height) + (list #:type 'player + #:x x + #:y y + #:width width + #:height height + #:vx 0 + #:vy 0 + #:gravity? #t + #:on-ground? #f + #:tile-id 29 + #:input-map '((left . (-2 . 0)) + (right . ( 2 . 0)) + (down . ( 0 . 2))))) +) + diff --git a/input.scm b/input.scm new file mode 100644 index 0000000..db581f0 --- /dev/null +++ b/input.scm @@ -0,0 +1,184 @@ +(module input + * + +(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 + entity + defstruct) + +;; Input configuration record +(defstruct input-config + actions ; list of action symbols + keyboard-map ; alist: (sdl2-key-sym . action) + joy-button-map ; alist: (button-id . action) + controller-button-map ; alist: (button-sym . action) + joy-axis-bindings ; list of (axis-id positive-action negative-action) + controller-axis-bindings ; list of (axis-sym positive-action negative-action) + deadzone) ; integer threshold for analog sticks + +;; Default input configuration (capture current hardcoded values) +(define *default-input-config* + (make-input-config + actions: '(up down left right a b start select quit) + keyboard-map: '((w . up) (up . up) + (s . down) (down . down) + (a . left) (left . left) + (d . right) (right . right) + (j . a) (z . a) + (k . b) (x . b) + (return . start) + (escape . quit)) + joy-button-map: '((0 . a) (1 . b) (7 . start) (6 . select)) + controller-button-map: '((a . a) (b . b) (start . start) (back . select) + (dpad-up . up) (dpad-down . down) + (dpad-left . left) (dpad-right . right)) + joy-axis-bindings: '((0 right left) (1 down up)) + controller-axis-bindings: '((left-x right left) (left-y down up)) + deadzone: 8000)) + +(define-record input-state + current ; Alist: (action . bool) + previous) ; Alist: (action . bool) + +;; Create empty input state from config +(define (create-input-state config) + (let ((initial (map (lambda (a) (cons a #f)) (input-config-actions config)))) + (make-input-state initial initial))) + +;; Helper to update the Alist +(define (set-action state action value) + (let* ((curr (input-state-current state)) + (new-curr (cons (cons action value) (alist-delete action curr eq?)))) + (make-input-state new-curr (input-state-previous state)))) + +(define (input-state-diff state) + "Retrieve the difference between current and previous input state maps" + (fold (lambda (item agg) + (unless (eq? (alist-ref item (input-state-previous state)) item) + (cons item agg))) + '() + (input-state-current state))) + +(define (handle-noop state event type config) + state) + +(define (handle-keyboard state event type config) + (let* ((pressed? (eq? type 'key-down)) + (sym (sdl2:keyboard-event-sym event)) + (action (alist-ref sym (input-config-keyboard-map config) eq? #f))) + (if action (set-action state action pressed?) state))) + +(define (apply-axis-to-state state val positive-action negative-action deadzone) + (chain state + (set-action _ positive-action (> val deadzone)) + (set-action _ negative-action (< val (- deadzone))))) + +(define (handle-joy-button state event type config) + (let* ((pressed? (eq? type 'joy-button-down)) + (btn (sdl2:joy-button-event-button event)) + (action (alist-ref btn (input-config-joy-button-map config) eqv? #f))) + (if action (set-action state action pressed?) state))) + +(define (handle-joy-axis state event type config) + (let ((axis (sdl2:joy-axis-event-axis event)) + (val (sdl2:joy-axis-event-value event)) + (dz (input-config-deadzone config))) + (let ((binding (assv axis (input-config-joy-axis-bindings config)))) + (if binding + (apply-axis-to-state state val (cadr binding) (caddr binding) dz) + state)))) + +(define (handle-controller-button state event type config) + (let* ((pressed? (eq? type 'controller-button-down)) + (btn (sdl2:controller-button-event-button event)) + (action (alist-ref btn (input-config-controller-button-map config) eq? #f))) + (if action (set-action state action pressed?) state))) + +(define (handle-controller-axis state event type config) + (let ((axis (sdl2:controller-axis-event-axis event)) + (val (sdl2:controller-axis-event-value event)) + (dz (input-config-deadzone config))) + (let ((binding (assv axis (input-config-controller-axis-bindings config)))) + (if binding + (apply-axis-to-state state val (cadr binding) (caddr binding) dz) + state)))) + +(define (handle-controller-device state event type config) + (when (eq? type 'controller-device-added) + (sdl2:game-controller-open! (sdl2:controller-device-event-which event))) + state) + +(define (handle-event state event config) + (let* ((type (sdl2:event-type event)) + (handler (case type + ((key-down key-up) handle-keyboard) + ((joy-button-down joy-button-up) handle-joy-button) + ((joy-axis-motion) handle-joy-axis) + ((controller-button-down + controller-button-up) handle-controller-button) + ((controller-axis-motion) handle-controller-axis) + ((controller-device-added + controller-device-removed) handle-controller-device) + (else handle-noop)))) + (handler state event type config))) + +(define (input-state-update state events config) + (let ((rolled (make-input-state (input-state-current state) + (input-state-current state)))) + (let* ((new-state (fold (lambda (ev st) (handle-event st ev config)) rolled events)) + (state-diff (input-state-diff new-state))) + (unless (eq? state-diff '()) + (log-debug "input-state change: ~a" state-diff)) + new-state))) + +;; 5. Simple Getters +(define (input-held? state action) + (alist-ref action (input-state-current state) eq? #f)) + +(define (input-pressed? state action) + (and (input-held? state action) + (not (alist-ref action (input-state-previous state) eq? #f)))) + +(define (input-released? state action) + (and (not (input-held? state action)) + (alist-ref action (input-state-previous state) eq? #f))) + +(define (input-any-pressed? state config) + (any (lambda (a) (input-pressed? state a)) (input-config-actions config))) + +(define (input-state->string state config) + (let ((active (filter (lambda (a) (input-held? state a)) (input-config-actions config)))) + (format #f "[Input: ~a]" (string-join (map symbol->string active) " ")))) + +(define (set-facing-from-vx entity vx) + (cond + ((> vx 0) (entity-set entity #:facing 1)) + ((< vx 0) (entity-set entity #:facing -1)) + (else entity))) + +(define (apply-input-to-entity entity held?) + (let ((input-map (entity-ref entity #:input-map #f))) + (if (not input-map) + entity + (let* ((delta (fold (lambda (entry acc) + (let* ((action (car entry)) + (d (cdr entry)) + (dvx (car d)) + (dvy (cdr d))) + (if (held? action) + (cons (+ (car acc) dvx) + (+ (cdr acc) dvy)) + acc))) + '(0 . 0) + input-map)) + (speed (entity-ref entity #:move-speed 1)) + (vx (* speed (car delta)))) + (set-facing-from-vx (entity-set entity #:vx vx) vx))))) + +) ;; end module diff --git a/physics.scm b/physics.scm new file mode 100644 index 0000000..83cc85b --- /dev/null +++ b/physics.scm @@ -0,0 +1,238 @@ +(module physics * + (import scheme + (chicken base) + (chicken keyword) + (only srfi-1 fold iota) + defstruct + tilemap + entity + world + simple-logger) + + ;; Gravity constant: pixels per frame per frame + (define *gravity* 1) + + ;; Jump force: vertical acceleration applied on jump (one frame) + (define *jump-force* 15) + + ;; Consume #:ay into #:vy and clear it (one-shot acceleration) + (define (apply-acceleration entity) + (if (not (entity-ref entity #:gravity? #f)) + entity + (let ((ay (entity-ref entity #:ay 0)) + (vy (entity-ref entity #:vy 0))) + (entity-set (entity-set entity #:vy (+ vy ay)) #:ay 0)))) + + ;; Apply gravity to an entity if it has gravity enabled + (define (apply-gravity entity) + (if (entity-ref entity #:gravity? #f) + (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*)) + entity)) + + ;; Update entity's x by its vx velocity + (define (apply-velocity-x entity) + "Update entity's x by its vx velocity." + (let ((x (entity-ref entity #:x 0)) + (vx (entity-ref entity #:vx 0))) + (entity-set entity #:x (+ x vx)))) + + ;; Update entity's y by its vy velocity + (define (apply-velocity-y entity) + "Update entity's y by its vy velocity." + (let ((y (entity-ref entity #:y 0)) + (vy (entity-ref entity #:vy 0))) + (entity-set entity #:y (+ y vy)))) + + ;; Legacy function: update both x and y by velocities + (define (apply-velocity entity) + "Legacy function: update both x and y by velocities." + (let ((x (entity-ref entity #:x 0)) + (y (entity-ref entity #:y 0)) + (vx (entity-ref entity #:vx 0)) + (vy (entity-ref entity #:vy 0))) + (entity-set (entity-set entity #:x (+ x vx)) #:y (+ y vy)))) + + ;; Build list of (col . row) pairs to check for collisions + (define (build-cell-list col-start col-end row-start row-end) + (let loop ((col col-start) (row row-start) (acc '())) + (log-debug "Build-cell-list loop with: ~a" (list col row acc)) + (if (> col col-end) + (if (>= row row-end) + (reverse acc) + (loop col-start (+ row 1) acc)) + (loop (+ col 1) row (cons (cons col row) acc))))) + + ;; Convert a pixel coordinate to a tile grid index + (define (pixel->tile pixel tile-size) + (inexact->exact (floor (/ pixel tile-size)))) + + ;; Return all tile cells (col . row) overlapping the entity's bounding box + (define (entity-tile-cells entity tilemap) + (let ((x (entity-ref entity #:x 0)) + (y (entity-ref entity #:y 0)) + (w (entity-ref entity #:width 0)) + (h (entity-ref entity #:height 0)) + (tw (tilemap-tilewidth tilemap)) + (th (tilemap-tileheight tilemap))) + (build-cell-list + (pixel->tile x tw) + (pixel->tile (- (+ x w) 1) tw) + (pixel->tile y th) + (pixel->tile (- (+ y h) 1) th)))) + + ;; Snap position to the near or far edge of a tile after collision. + ;; Moving forward (v>0): snap entity's leading edge to tile's near edge. + ;; Moving backward (v<0): snap entity's trailing edge to tile's far edge. + (define (tile-push-pos v coord tile-size entity-size) + (if (> v 0) + (- (* coord tile-size) entity-size) + (* (+ coord 1) tile-size))) + + ;; Resolve collisions with tiles along a single axis. + ;; push-fn: (v col row) -> new-pos + (define (resolve-tile-collisions-axis entity tilemap vel-key pos-key push-fn) + (let ((v (entity-ref entity vel-key 0))) + (if (zero? v) + entity + (fold (lambda (cell acc) + (log-debug "resolve-~a: cell=~a acc=~a" vel-key cell acc) + (let* ((col (car cell)) + (row (cdr cell)) + (tile-id (tilemap-tile-at tilemap col row))) + (if (zero? tile-id) + acc + (entity-set (entity-set acc pos-key (push-fn v col row)) vel-key 0)))) + entity + (entity-tile-cells entity tilemap))))) + + ;; Resolve horizontal collisions with solid tiles + (define (resolve-tile-collisions-x entity tilemap) + (let ((w (entity-ref entity #:width 0)) + (tw (tilemap-tilewidth tilemap))) + (resolve-tile-collisions-axis entity tilemap #:vx #:x + (lambda (v col row) (tile-push-pos v col tw w))))) + + ;; Resolve vertical collisions with solid tiles + (define (resolve-tile-collisions-y entity tilemap) + (let ((h (entity-ref entity #:height 0)) + (th (tilemap-tileheight tilemap))) + (resolve-tile-collisions-axis entity tilemap #:vy #:y + (lambda (v col row) (tile-push-pos v row th h))))) + + ;; Detect if entity is standing on ground by probing 1px below feet + (define (detect-ground entity tilemap) + (if (not (entity-ref entity #:gravity? #f)) + entity + (let* ((x (entity-ref entity #:x 0)) + (w (entity-ref entity #:width 0)) + (tw (tilemap-tilewidth tilemap)) + (th (tilemap-tileheight tilemap)) + (probe-y (+ (entity-ref entity #:y 0) (entity-ref entity #:height 0) 1)) + (row (pixel->tile probe-y th)) + (col-left (pixel->tile x tw)) + (col-right (pixel->tile (- (+ x w) 1) tw)) + (on-ground? (or (not (zero? (tilemap-tile-at tilemap col-left row))) + (not (zero? (tilemap-tile-at tilemap col-right row)))))) + (entity-set entity #:on-ground? on-ground?)))) + + ;; Set vertical acceleration for jump (consumed next frame by apply-acceleration) + (define (apply-jump entity jump-pressed?) + "Set #:ay to jump force if jump pressed and entity is on ground." + (if (and jump-pressed? (entity-ref entity #:on-ground? #f)) + (entity-set entity #:ay (- (entity-ref entity #:jump-force *jump-force*))) + entity)) + + ;; Replace element at idx in lst with val + (define (list-set lst idx val) + (let loop ((lst lst) (i 0) (acc '())) + (if (null? lst) + (reverse acc) + (loop (cdr lst) (+ i 1) + (cons (if (= i idx) val (car lst)) acc))))) + + ;; Generate all unique (i . j) index pairs where i < j + (define (index-pairs n) + (if (< n 2) '() + (apply append + (map (lambda (i) + (map (lambda (j) (cons i j)) + (iota (- n i 1) (+ i 1)))) + (iota (- n 1)))))) + + (define (axis->dimension axis) + (case axis + ((#:x) #:width) + ((#:y) #:height))) + + (define (axis->velocity axis) + (case axis + ((#:x) #:vx) + ((#:y) #:vy))) + + ;; Push entity along one axis by half-overlap, setting velocity in push direction + (define (push-entity entity pos-key vel-key pos overlap sign) + (entity-set (entity-set entity pos-key (+ pos (* sign (/ overlap 2)))) vel-key sign)) + + + (define (entity-center-on-axis entity axis) + (let ((dimension (axis->dimension axis))) + (+ (entity-ref entity axis 0) (/ (entity-ref entity dimension 0) 2)))) + + (define (aabb-overlap-on-axis axis a b) + (let ((dimension (axis->dimension axis))) + (- (/ (+ (entity-ref a dimension 0) (entity-ref b dimension 0)) 2) + (abs (- (entity-center-on-axis b axis) (entity-center-on-axis a axis)))))) + + (define (push-along-axis axis a b overlap) + (let* ((a-center (entity-center-on-axis a axis)) + (b-center (entity-center-on-axis b axis)) + (delta (if (< a-center b-center) -1 1)) + (axis-velocity-key (axis->velocity axis))) + (cons (push-entity a axis axis-velocity-key (entity-ref a axis 0) overlap delta) + (push-entity b axis axis-velocity-key (entity-ref b axis 0) overlap (- delta))))) + + ;; Push two overlapping entities apart along the minimum penetration axis. + ;; Returns (a2 . b2) with updated positions and velocities. + (define (push-apart a b) + (let* ((ovx (aabb-overlap-on-axis #:x a b)) + (ovy (aabb-overlap-on-axis #:y a b))) + (if (<= ovx ovy) + (push-along-axis #:x a b ovx) + (push-along-axis #:y a b ovy)))) + + ;; Check if two axis-aligned bounding boxes overlap. + ;; Returns #t if they overlap, #f if they don't (including edge-touching). + (define (aabb-overlap? x1 y1 w1 h1 x2 y2 w2 h2) + (not (or (>= x1 (+ x2 w2)) + (>= x2 (+ x1 w1)) + (>= y1 (+ y2 h2)) + (>= y2 (+ y1 h1))))) + + ;; Resolve AABB collision between two solid entities. + ;; Returns (a2 . b2) with positions/velocities adjusted, or #f if no collision. + (define (resolve-pair a b) + (and (entity-ref a #:solid? #f) + (entity-ref b #:solid? #f) + (aabb-overlap? (entity-ref a #:x 0) (entity-ref a #:y 0) + (entity-ref a #:width 0) (entity-ref a #:height 0) + (entity-ref b #:x 0) (entity-ref b #:y 0) + (entity-ref b #:width 0) (entity-ref b #:height 0)) + (push-apart a b))) + + ;; Detect and resolve AABB overlaps between all pairs of solid entities. + ;; Returns a new entity list with collisions resolved. + (define (resolve-entity-collisions entities) + (fold (lambda (pair ents) + (let* ((i (car pair)) (j (cdr pair)) + (result (resolve-pair (list-ref ents i) (list-ref ents j)))) + (if result + (list-set (list-set ents i (car result)) j (cdr result)) + ents))) + entities + (index-pairs (length entities)))) + + ;; Wrapper for scene-resolve-collisions + (define (scene-resolve-collisions scene) + (scene-entities-set! scene + (resolve-entity-collisions (scene-entities scene))) + scene)) diff --git a/renderer.scm b/renderer.scm new file mode 100644 index 0000000..ad894d0 --- /dev/null +++ b/renderer.scm @@ -0,0 +1,88 @@ +(module renderer + * + (import scheme + (chicken base) + (only srfi-1 iota for-each) + (prefix sdl2 "sdl2:") + (prefix sdl2-ttf "ttf:") + entity + tilemap + world) + + ;; --- Pure functions (no SDL2, testable) --- + + ;; Returns (x y w h) as a plain list — testable without SDL2 + (define (entity-screen-coords entity camera) + (list (- (inexact->exact (floor (entity-ref entity #:x 0))) (camera-x camera)) + (- (inexact->exact (floor (entity-ref entity #:y 0))) (camera-y camera)) + (inexact->exact (floor (entity-ref entity #:width 0))) + (inexact->exact (floor (entity-ref entity #:height 0))))) + + ;; Returns sdl2:rect for actual drawing + (define (entity->screen-rect entity camera) + (apply sdl2:make-rect (entity-screen-coords entity camera))) + + ;; Returns flip list based on #:facing field + (define (entity-flip entity) + (if (= (entity-ref entity #:facing 1) -1) '(horizontal) '())) + + ;; --- Tilemap drawing --- + + (define (draw-tile renderer camera tileset tileset-texture tile-id row-num col-num) + (let ((tile (tileset-tile tileset tile-id))) + (sdl2:render-copy! renderer tileset-texture + (tile-rect tile) + (sdl2:make-rect + (- (* col-num (tileset-tilewidth tileset)) (camera-x camera)) + (- (* row-num (tileset-tileheight tileset)) (camera-y camera)) + (tileset-tilewidth tileset) + (tileset-tileheight tileset))))) + + (define (draw-tilemap-rows draw-fn rows row-num) + (unless (null? rows) + (for-each + (cut draw-fn <> row-num <>) + (car rows) + (iota (length (car rows)))) + (draw-tilemap-rows draw-fn (cdr rows) (+ row-num 1)))) + + (define (draw-tilemap renderer camera tileset-texture tilemap) + (let ((map-layers (tilemap-layers tilemap)) + (tileset (tilemap-tileset tilemap))) + (for-each + (lambda (layer) + (draw-tilemap-rows + (cut draw-tile renderer camera tileset tileset-texture <> <> <>) + (layer-map layer) + 0)) + map-layers))) + + ;; --- Entity drawing --- + + (define (draw-entity renderer camera tileset tileset-texture entity) + (let ((tile-id (entity-ref entity #:tile-id #f))) + (when tile-id + (sdl2:render-copy-ex! renderer tileset-texture + (tile-rect (tileset-tile tileset tile-id)) + (entity->screen-rect entity camera) + 0.0 + #f + (entity-flip entity))))) + + (define (draw-entities renderer camera tileset tileset-texture entities) + (for-each + (lambda (e) (draw-entity renderer camera tileset tileset-texture e)) + entities)) + + ;; --- Text drawing --- + + (define (draw-ui-text renderer font text color x y) + (let* ((surface (ttf:render-text-solid font text color)) + (texture (sdl2:create-texture-from-surface renderer surface)) + (dims (call-with-values (lambda () (ttf:size-utf8 font text)) cons)) + (w (car dims)) + (h (cdr dims))) + (sdl2:render-copy! renderer texture #f + (sdl2:make-rect x y w h)))) + +) ;; end module renderer 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") diff --git a/tilemap.scm b/tilemap.scm new file mode 100644 index 0000000..6e4dc95 --- /dev/null +++ b/tilemap.scm @@ -0,0 +1,235 @@ +(module tilemap + * + (import scheme + (chicken io) + (chicken base) + (chicken string) + (chicken format) + (chicken process-context) + (chicken pathname) + (chicken pretty-print) + (srfi 1) + matchable + expat + defstruct + (prefix sdl2-image "img:") + (prefix sdl2 "sdl2:")) + +(+ 1 1) + + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) + + (+ 1 1) + + (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 (maybe-do action) + (lambda (value) + (if (eq? value #f) + #f + (action value)))) + + (define (attempt action) + (lambda (value) + (or (action value) value))) + + (define maybe-string->number (maybe-do (attempt string->number))) + + (define (string-alist->alist string-alist) + (map (lambda (pair) (cons (string->symbol (car pair)) + (maybe-string->number (cdr pair)))) + string-alist)) + + (define (parse-tileset string-tileset) + (let ((parser (expat:make-parser)) + (tags '()) + (tileset (make-tileset 0 0 0 0 0 ""))) + (expat:set-start-handler! parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("tileset" (set! tileset (alist->tileset symbol-attrs))) + ("image" (tileset-image-source-set! tileset (alist-ref 'source symbol-attrs))) + (_ #f))) + (set! tags (cons tag tags)))) + (expat:set-end-handler! parser (lambda (tag) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! parser (lambda (line) #f)) + (expat:parse parser string-tileset) + tileset)) + + (define (load-tileset file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tileset (parse-tileset (read-string #f port))) + (image-source (tileset-image-source tileset)) + (base-path (pathname-directory file-name)) + (img-to-load (if (absolute-pathname? image-source) + image-source + (pathname-replace-directory + image-source + (if (pathname-directory image-source) + (format "~a/~a" base-path (pathname-directory image-source)) + base-path))))) + (tileset-image-set! tileset (img:load img-to-load)) + tileset)))) + + (define (parse-tilemap string-tilemap) + (let ((parser (expat:make-parser)) + (tags '()) + (tilemap (make-tilemap width: 0 height: 0 tilewidth: 0 tileheight: 0 + tileset-source: "" tileset: #f + layers: '() objects: '())) + (layer '()) + (object '())) + (expat:set-start-handler! + parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("map" + (tilemap-width-set! tilemap (alist-ref 'width symbol-attrs)) + (tilemap-height-set! tilemap (alist-ref 'height symbol-attrs)) + (tilemap-tilewidth-set! tilemap (alist-ref 'tilewidth symbol-attrs)) + (tilemap-tileheight-set! tilemap (alist-ref 'tileheight symbol-attrs))) + ("tileset" + (tilemap-tileset-source-set! tilemap (alist-ref 'source symbol-attrs))) + ("layer" + (set! layer (alist->layer attrs))) + ("object" + (set! object (alist->object symbol-attrs))) + ("property" + (object-properties-set! + object + (cons (cons (alist-ref 'name symbol-attrs) (alist-ref 'value symbol-attrs)) + (or (object-properties object) '())))) + (_ #f)) + (set! tags (cons tag tags))))) + (expat:set-end-handler! + parser + (lambda (tag) + (match tag + ("layer" (begin + (tilemap-layers-set! tilemap + (cons layer (tilemap-layers tilemap))) + (set! layer '()))) + ("object" (tilemap-objects-set! tilemap (cons object (tilemap-objects tilemap)))) + (_ #f)) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! + parser + (lambda (line) + (when (string=? (car tags) "data") + (let ((txt (string-chomp line))) + (when (not (string=? txt "")) + (layer-map-set! layer (append + (or (layer-map layer) '()) + (list (map string->number + (string-split txt ",")))))))))) + (expat:parse parser string-tilemap) + tilemap)) + + (define (tileset-rows tileset) + "Return the number of rows in the tileset" + (inexact->exact (ceiling (/ (tileset-tilecount tileset) (tileset-columns tileset))))) + + (define (tileset-tile tileset tile-id) + ;; Use the tileset's columns setting and the tileheight/tilewidth to + ;; find the tile's x,y location and create a rect + (let* ((tile-num (- tile-id 1)) ; tile-id starts at 1! + (tile-width (tileset-tilewidth tileset)) + (tile-height (tileset-tileheight tileset)) + (tile-x (modulo tile-num (tileset-columns tileset))) + (tile-y (inexact->exact (floor (/ tile-num (tileset-columns tileset))))) + (x (+ (* tile-x tile-width) tile-x)) + (y (+ (* tile-y tile-height) tile-y))) + (make-tile + id: tile-id + rect: (sdl2:make-rect x y tile-width tile-height)))) + + (define (load-tilemap file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tilemap (parse-tilemap (read-string #f port))) + (base-path (pathname-directory file-name)) + (tileset-source (tilemap-tileset-source tilemap))) + (tilemap-tileset-set! tilemap (load-tileset + (if (absolute-pathname? tileset-source) + tileset-source + (pathname-replace-directory + tileset-source + (if (pathname-directory tileset-source) + (format "~a/~a" base-path (pathname-directory tileset-source)) + base-path)) + ))) + tilemap)))) + + (when #f + + (let ((txt " + + + +")) + (tileset-image (parse-tileset txt))) + + (let ((txt " + + + + +0,0,0,0,168,169,0,0,0,0, +844,0,0,0,0,0,845,546,546,546, + + + + + + + + + + + + +")) + (tilemap-tileset (parse-tilemap txt))) + + (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) + ) + + ) ;; End tilemap module diff --git a/world.scm b/world.scm new file mode 100644 index 0000000..ee1d60c --- /dev/null +++ b/world.scm @@ -0,0 +1,59 @@ +(module world + * + (import scheme + (chicken base) + (only srfi-1 fold filter) + defstruct + tilemap + entity) + ;; Scene = current level: tilemap (layers, objects) + list of entities. + + ;; Returns tile-id if the cell at (col, row) in this layer is non-zero, #f otherwise. + (define (layer-tile-at layer col row) + (let ((rows (layer-map layer))) + (and (< row (length rows)) + (let ((row-data (list-ref rows row))) + (and (< col (length row-data)) + (let ((tile-id (list-ref row-data col))) + (and (not (zero? tile-id)) tile-id))))))) + + (define (tilemap-tile-at tilemap col row) + "Get the tile ID at grid position (col, row). + Returns 0 if out of bounds or if all layers have 0 at that cell." + (let ((width (tilemap-width tilemap)) + (height (tilemap-height tilemap))) + (if (or (< col 0) (>= col width) (< row 0) (>= row height)) + 0 + (let loop ((layers (tilemap-layers tilemap))) + (if (null? layers) + 0 + (or (layer-tile-at (car layers) col row) + (loop (cdr layers)))))))) + + (defstruct camera x y) + + (defstruct scene + entities + tilemap + camera + tileset-texture) + + (define (scene-add-entity scene entity) + (scene-entities-set! scene (append (scene-entities scene) (list entity))) + scene) + + (define (scene-update-entities scene . procs) + "Apply each proc in sequence to the scene's entities; each proc maps over all entities. + The scene's entity list is replaced once with the final result." + (scene-entities-set! scene + (fold (lambda (proc es) (map proc es)) + (scene-entities scene) + procs)) + scene) + + (define (scene-filter-entities scene pred) + "Remove all entities from scene that do not satisfy pred." + (scene-entities-set! scene + (filter pred (scene-entities scene))) + scene) +) -- cgit v1.2.3