diff options
| author | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:30:34 +0100 |
|---|---|---|
| committer | Gene Pasquet <dev@etenil.net> | 2026-04-17 16:30:34 +0100 |
| commit | 8251c85a4a588504d38a2fad05e4b0fe1cdccb9d (patch) | |
| tree | c3fcedb7331caf798f2355c7549b35aa3aaf6ac8 | |
| parent | 5de3b9cf122542f2a0c1c906c8ce8add20e5c8c6 (diff) | |
Convert entities to alists
| -rw-r--r-- | animation.scm | 37 | ||||
| -rw-r--r-- | demo/animation.scm | 15 | ||||
| -rw-r--r-- | demo/platformer.scm | 13 | ||||
| -rw-r--r-- | demo/sandbox.scm | 27 | ||||
| -rw-r--r-- | demo/scaling.scm | 15 | ||||
| -rw-r--r-- | demo/shmup.scm | 15 | ||||
| -rw-r--r-- | demo/topdown.scm | 13 | ||||
| -rw-r--r-- | demo/tweens.scm | 23 | ||||
| -rw-r--r-- | downstroke.egg | 2 | ||||
| -rw-r--r-- | engine.scm | 11 | ||||
| -rw-r--r-- | entity.scm | 23 | ||||
| -rw-r--r-- | prefabs.scm | 149 | ||||
| -rw-r--r-- | tests/animation-test.scm | 45 | ||||
| -rw-r--r-- | tests/entity-test.scm | 94 | ||||
| -rw-r--r-- | tests/input-test.scm | 11 | ||||
| -rw-r--r-- | tests/physics-test.scm | 247 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 7 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 31 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 28 | ||||
| -rw-r--r-- | tests/tween-test.scm | 71 | ||||
| -rw-r--r-- | tests/world-test.scm | 75 |
21 files changed, 498 insertions, 454 deletions
diff --git a/animation.scm b/animation.scm index 0d961a1..8843512 100644 --- a/animation.scm +++ b/animation.scm @@ -1,18 +1,25 @@ (module downstroke-animation * (import scheme (chicken base) - (chicken keyword) (chicken pretty-print) (only srfi-1 filter) downstroke-entity downstroke-world) -;; ---- Animation data accessors ---- +;; Animation definitions are alists (converted from plist form in the user's +;; prefab data file by load-prefabs). Each animation is an alist with keys +;; #:name, #:frames, optional #:duration. -(define (animation-frames anim) - (get-keyword #:frames anim)) -(define (animation-duration anim) - (get-keyword #:duration anim)) +;; Look up a key in an animation alist. Mirrors entity-ref: +;; a non-procedure default is returned as-is on miss; a procedure default +;; is invoked as a thunk. +(define (animation-ref anim key #!optional default) + (cond ((assq key anim) => cdr) + ((procedure? default) (default)) + (else default))) + +(define (animation-frames anim) (animation-ref anim #:frames)) +(define (animation-duration anim) (animation-ref anim #:duration)) (define (frame-by-idx frames frame-idx) (list-ref frames (modulo frame-idx (length frames)))) @@ -43,8 +50,10 @@ (define (animation-by-name animations name) - (let ((matching-anims (filter (lambda (anim) (eq? (get-keyword #:name anim) name)) animations))) - (if matching-anims + (let ((matching-anims + (filter (lambda (anim) (eq? (animation-ref anim #:name) name)) + animations))) + (if (pair? matching-anims) (car matching-anims) #f))) @@ -61,13 +70,13 @@ (if (>= tick duration) (let ((new-frame-id (modulo (+ frame 1) (length frames)))) (entity-set-many entity - (list (cons #:anim-tick 0) - (cons #:anim-frame new-frame-id) - (cons #:tile-id (frame->tile-id frames new-frame-id)) - (cons #:duration (frame->duration frames new-frame-id))))) + `((#:anim-tick . 0) + (#:anim-frame . ,new-frame-id) + (#:tile-id . ,(frame->tile-id frames new-frame-id)) + (#:duration . ,(frame->duration frames new-frame-id))))) (entity-set-many entity - (list (cons #:anim-tick tick) - (cons #:tile-id (frame->tile-id frames frame))))))) + `((#:anim-tick . ,tick) + (#:tile-id . ,(frame->tile-id frames frame))))))) (define (animate-entity entity animations) (let* ((anim-name (entity-ref entity #:anim-name #f)) diff --git a/demo/animation.scm b/demo/animation.scm index 2379115..f2048d6 100644 --- a/demo/animation.scm +++ b/demo/animation.scm @@ -2,6 +2,7 @@ (chicken base) (chicken pretty-print) (only srfi-1 iota) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") downstroke-engine @@ -19,13 +20,13 @@ (define *title-font* #f) (define (make-demo-entity x y tw th id) - (list #:type 'demo-bot - #:x x #:y y #:width tw #:height th - #:vx 0 #:vy 0 - #:gravity? #t #:on-ground? #f - #:solid? #t #:immovable? #f - #:tile-id 1 - #:demo-id id #:demo-since-jump 0)) + (plist->alist (list #:type 'demo-bot + #:x x #:y y #:width tw #:height th + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:solid? #t #:immovable? #f + #:tile-id 1 + #:demo-id id #:demo-since-jump 0))) (define (make-demo-tilemap ts tw th gw gh) (let* ((ncols (inexact->exact (ceiling (/ gw tw)))) diff --git a/demo/platformer.scm b/demo/platformer.scm index 1a24a8f..6e854fe 100644 --- a/demo/platformer.scm +++ b/demo/platformer.scm @@ -1,6 +1,7 @@ (import scheme (chicken base) (chicken process-context) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -16,12 +17,12 @@ (define +debug?+ (and (member "--debug" (command-line-arguments)) #t)) (define (make-player) - (list #:type 'player - #:x 100 #:y 50 - #:width 16 #:height 16 - #:vx 0 #:vy 0 - #:gravity? #t #:on-ground? #f - #:tile-id 1 #:tags '(player))) + (plist->alist (list #:type 'player + #:x 100 #:y 50 + #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:tile-id 1 #:tags '(player)))) (define (player-vx input) (cond ((input-held? input 'left) -3) diff --git a/demo/sandbox.scm b/demo/sandbox.scm index e23584f..ef71053 100644 --- a/demo/sandbox.scm +++ b/demo/sandbox.scm @@ -2,6 +2,7 @@ (chicken base) (chicken random) (only srfi-1 iota take) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -49,12 +50,12 @@ ;; ── Entity factories ───────────────────────────────────────────────────────── (define (make-box x y tw th) - (list #:type 'box - #:x x #:y y #:width tw #:height th - #:vx 0 #:vy 0 - #:gravity? #t #:on-ground? #f - #:solid? #t #:immovable? #f - #:tile-id 29)) + (plist->alist (list #:type 'box + #:x x #:y y #:width tw #:height th + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:solid? #t #:immovable? #f + #:tile-id 29))) (define (spawn-boxes tw th) (map (lambda (i) @@ -64,13 +65,13 @@ (iota 8))) (define (make-demo-bot x y tw th id) - (list #:type 'demo-bot - #:x x #:y y #:width tw #:height th - #:vx 0 #:vy 0 - #:gravity? #t #:on-ground? #f - #:solid? #t #:immovable? #f - #:tile-id 1 - #:demo-id id #:demo-since-jump 0)) + (plist->alist (list #:type 'demo-bot + #:x x #:y y #:width tw #:height th + #:vx 0 #:vy 0 + #:gravity? #t #:on-ground? #f + #:solid? #t #:immovable? #f + #:tile-id 1 + #:demo-id id #:demo-since-jump 0))) ;; ── Per-entity intent ─────────────────────────────────────────────────────── diff --git a/demo/scaling.scm b/demo/scaling.scm index 982817a..1d74e6a 100644 --- a/demo/scaling.scm +++ b/demo/scaling.scm @@ -1,5 +1,6 @@ (import scheme (chicken base) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") downstroke-engine @@ -25,13 +26,13 @@ create: (lambda (game) (game-scene-set! game (make-scene - entities: (list (list #:type 'box - #:x (/ +width+ 2) - #:y (/ +height+ 2) - #:width +box-size+ - #:height +box-size+ - #:vx 0 #:vy 0 - #:color '(255 200 0))) + entities: (list (plist->alist (list #:type 'box + #:x (/ +width+ 2) + #:y (/ +height+ 2) + #:width +box-size+ + #:height +box-size+ + #:vx 0 #:vy 0 + #:color '(255 200 0)))) tilemap: #f camera: (make-camera x: 0 y: 0) tileset-texture: #f diff --git a/demo/shmup.scm b/demo/shmup.scm index 315069c..15afb71 100644 --- a/demo/shmup.scm +++ b/demo/shmup.scm @@ -3,6 +3,7 @@ (chicken random) (only srfi-1 filter any) (only srfi-197 chain) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -27,16 +28,16 @@ ;; ── Entity factories ───────────────────────────────────────────────────────── (define (make-player) - (list #:type 'player #:x 280 #:y 360 - #:width 16 #:height 16 #:vx 0 #:vy 0)) + (plist->alist (list #:type 'player #:x 280 #:y 360 + #:width 16 #:height 16 #:vx 0 #:vy 0))) (define (make-bullet x y) - (list #:type 'bullet #:x x #:y y - #:width 4 #:height 8 #:vx 0 #:vy -6)) + (plist->alist (list #:type 'bullet #:x x #:y y + #:width 4 #:height 8 #:vx 0 #:vy -6))) (define (make-enemy x) - (list #:type 'enemy #:x x #:y 0 - #:width 16 #:height 16 #:vx 0 #:vy 2)) + (plist->alist (list #:type 'enemy #:x x #:y 0 + #:width 16 #:height 16 #:vx 0 #:vy 2))) ;; ── Collision ──────────────────────────────────────────────────────────────── @@ -79,7 +80,7 @@ (define (update-player player input) (let ((updated (chain player (entity-set _ #:vx (player-vx input)) - (apply-velocity-x _ #f 0) + (apply-velocity-x #f _ 0) (clamp-player-x _)))) (when (input-pressed? input 'a) (play-sound 'shoot)) diff --git a/demo/topdown.scm b/demo/topdown.scm index 7fa9b7e..21c7b6f 100644 --- a/demo/topdown.scm +++ b/demo/topdown.scm @@ -2,6 +2,7 @@ (chicken base) srfi-8 (only srfi-197 chain) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -13,12 +14,12 @@ downstroke-scene-loader) (define (make-player) - (list #:type 'player - #:x 100 #:y 100 - #:width 16 #:height 16 - #:vx 0 #:vy 0 - #:gravity? #f - #:tile-id 1 #:tags '(player))) + (plist->alist (list #:type 'player + #:x 100 #:y 100 + #:width 16 #:height 16 + #:vx 0 #:vy 0 + #:gravity? #f + #:tile-id 1 #:tags '(player)))) (define (input->velocity input) (values (+ (if (input-held? input 'left) -3 0) diff --git a/demo/tweens.scm b/demo/tweens.scm index 609c541..51a72b2 100644 --- a/demo/tweens.scm +++ b/demo/tweens.scm @@ -1,12 +1,14 @@ (import scheme (chicken base) (only srfi-1 iota) + (only (list-utils alist) plist->alist) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") downstroke-engine downstroke-world downstroke-renderer - downstroke-entity) + downstroke-entity + downstroke-tween) ;; ── Constants ──────────────────────────────────────────────────────────────── @@ -31,15 +33,16 @@ (define (make-ease-entity ease-sym y rgb) (let* ((left 20) (right (+ left 120)) - (base (list #:x left #:y y))) - (list #:type 'tween-demo #:x left #:y y - #:width 14 #:height 14 - #:vx 0 #:vy 0 #:gravity? #f #:solid? #f - #:color rgb - #:ease-name ease-sym - #:tween (make-tween base props: `((#:x . ,right)) - duration: +ease-duration+ ease: ease-sym - repeat: -1 yoyo?: #t)))) + (base (plist->alist (list #:x left #:y y)))) + (plist->alist + (list #:type 'tween-demo #:x left #:y y + #:width 14 #:height 14 + #:vx 0 #:vy 0 #:gravity? #f #:solid? #f + #:color rgb + #:ease-name ease-sym + #:tween (make-tween base props: `((#:x . ,right)) + duration: +ease-duration+ ease: ease-sym + repeat: -1 yoyo?: #t))))) ;; ── Rendering ──────────────────────────────────────────────────────────────── diff --git a/downstroke.egg b/downstroke.egg index ab72665..516eed3 100644 --- a/downstroke.egg +++ b/downstroke.egg @@ -3,7 +3,7 @@ (author "Gene Pasquet") (license "BSD-2-Clause") (category games) - (dependencies sdl2 sdl2-image sdl2-ttf expat defstruct srfi-1 srfi-13 srfi-69 srfi-197 matchable simple-logger) + (dependencies sdl2 sdl2-image sdl2-ttf expat defstruct srfi-1 srfi-13 srfi-69 srfi-197 matchable simple-logger list-utils) (components (extension downstroke-entity (source "entity.scm")) @@ -2,7 +2,6 @@ (import scheme (chicken base) - (chicken keyword) (prefix sdl2 "sdl2:") (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") @@ -110,15 +109,15 @@ ;; ── Named scene states ──────────────────────────────────────────────────── -;; Construct a state plist with lifecycle hooks. +;; Construct a state alist with lifecycle hooks. (define (make-game-state #!key (create #f) (update #f) (render #f)) - (list #:create create #:update update #:render render)) + `((#:create . ,create) (#:update . ,update) (#:render . ,render))) -;; Retrieve a value from a state plist. +;; Retrieve a value from a state alist. (define (state-hook state key) - (get-keyword key state (lambda () #f))) + (cond ((assq key state) => cdr) (else #f))) -;; Register a named state. name is a symbol; state is a make-game-state plist. +;; Register a named state. name is a symbol; state is a make-game-state alist. (define (game-add-state! game name state) (hash-table-set! (game-states game) name state)) @@ -2,34 +2,27 @@ * (import scheme (chicken base) - (chicken keyword) - (only srfi-1 fold)) + (only srfi-1 fold alist-delete)) - ;; Entities = plists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). + ;; Entities = alists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). (define (make-entity x y w h) - (list #:type 'none #:x x #:y y #:width w #:height h)) + `((#:type . none) (#:x . ,x) (#:y . ,y) (#:width . ,w) (#:height . ,h))) (define (entity-ref entity key #!optional default) - (get-keyword key entity (if (procedure? default) default (lambda () default)))) + (cond ((assq key entity) => cdr) + ((procedure? default) (default)) + (else 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)))) + (cons (cons key val) (alist-delete key entity eq?))) (define (entity-set-many entity pairs) (fold (lambda (pair working-ent) - (entity-set working-ent (car pair) (if (list? (cdr pair)) (cadr pair) (cdr pair)))) + (entity-set working-ent (car pair) (cdr pair))) entity pairs)) diff --git a/prefabs.scm b/prefabs.scm index 24a9ee3..56e9ad1 100644 --- a/prefabs.scm +++ b/prefabs.scm @@ -1,10 +1,9 @@ (module downstroke-prefabs * (import scheme (chicken base) - (chicken keyword) - (chicken port) - (chicken format) + (only (chicken keyword) keyword?) srfi-1 + (only (list-utils alist) plist->alist) defstruct downstroke-entity) @@ -12,30 +11,30 @@ (defstruct prefab-registry prefabs group-prefabs file engine-mixin-table user-hooks hook-table) -(define (ensure-balanced-plist plist) - (when (> (modulo (length plist) 2) 0) - (error "Given plist has odd number of items - not a valid plist!"))) - -(define (has-keyword? key plist) - (not (eq? (get-keyword key plist (lambda () 'undefined)) 'undefined))) - -(define (plist-merge plist1 . plists) - "Merge two PLIST1 and PLIST2 into a single one, elements of PLIST1 will overwrite those of PLIST2 etc.." - (let ((meta-list (concatenate plists))) - (ensure-balanced-plist plist1) - (ensure-balanced-plist meta-list) - (if (= (length meta-list) 0) - plist1 - (let loop ((key (car meta-list)) - (value (cadr meta-list)) - (rest (if (> (length meta-list) 2) (cddr meta-list) '())) - (acc plist1)) - (let ((new-acc (if (has-keyword? key acc) - acc - (append (list key value) acc)))) - (if (null? rest) - new-acc - (loop (car rest) (cadr rest) (if (> (length rest) 2) (cddr rest) '()) new-acc))))))) +;; Private: internal prefab composition helper. +;; Merge alists left-to-right; earlier occurrences of a key win. +;; Returns a fresh alist. +(define (alist-merge . alists) + (fold (lambda (alist acc) + (fold (lambda (pair acc) + (if (assq (car pair) acc) + acc + (cons pair acc))) + acc + alist)) + '() + alists)) + +;; Keys whose values are lists-of-plists in user data files and must be +;; deep-converted to lists-of-alists after the top-level plist->alist pass. +(define +nested-plist-list-keys+ '(#:animations #:parts)) + +(define (convert-nested-plist-values alist) + (map (lambda (pair) + (if (memq (car pair) +nested-plist-list-keys+) + (cons (car pair) (map plist->alist (cdr pair))) + pair)) + alist)) ;; Return engine's built-in mixin table (define (engine-mixins) @@ -43,8 +42,10 @@ (has-facing #:facing 1) (animated #:anim-name idle #:anim-frame 0 #:anim-tick 0 #:tile-id 0 #:animations #t))) -;; Compose a prefab entry with mixin table -;; Returns (name . merged-plist) +;; Compose a prefab entry with a mixin-table of alists. +;; `entry` is the raw user plist-shaped entry: (name mixin-name ... #:k v #:k v ...) +;; `mixin-table` maps mixin-name → alist (already converted in load-prefabs). +;; Returns (name . merged-alist). (define (compose-prefab entry mixin-table) (let* ((name (car entry)) (rest (cdr entry)) @@ -54,13 +55,14 @@ (loop (cdr lst) (cons (car lst) mixins))))) (mixin-names (car split)) (inline-fields (cdr split)) - (mixin-plists + (inline-alist (plist->alist inline-fields)) + (mixin-alists (map (lambda (mname) (let ((m (assq mname mixin-table))) (if m (cdr m) (error "Unknown mixin" mname)))) mixin-names)) - ;; inline-fields prepended → first-match semantics give them highest priority - (merged (apply plist-merge inline-fields mixin-plists))) + ;; inline-alist first → highest priority (earlier-wins) + (merged (apply alist-merge (cons inline-alist mixin-alists)))) (cons name merged))) (define *engine-hooks* '()) @@ -72,29 +74,34 @@ (cdr entry) (error "Unknown prefab hook" hook-sym)))) -;; Group prefab entry: (name . plist) with #:parts = list of part plists. -;; Part offsets may use #:local-x / #:local-y or #:group-local-x / #:group-local-y. -(define (compose-group-prefab entry) - (cons (car entry) (cdr entry))) - ;; Optional profiles (enabled per group via #:pose-only-origin? / #:static-parts? in data). ;; Pose-only origin: tweened or scripted leader, invisible, does not run physics pipelines. (define +pose-only-group-origin-defaults+ - (list #:solid? #f #:gravity? #f #:skip-render #t - #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y - tile-collisions-x tile-collisions-y on-solid entity-collisions))) + '((#:solid? . #f) + (#:gravity? . #f) + (#:skip-render . #t) + (#:skip-pipelines . (jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid entity-collisions)))) ;; Physics-driving origin: invisible point mass; members follow via sync-groups. (define +physics-group-origin-defaults+ - (list #:solid? #f #:gravity? #t #:skip-render #t - #:vx 0 #:vy 0 #:on-ground? #f)) + '((#:solid? . #f) + (#:gravity? . #t) + (#:skip-render . #t) + (#:vx . 0) + (#:vy . 0) + (#:on-ground? . #f))) ;; Static rigid parts: no integration; world pose comes from the origin each frame. (define +static-group-member-defaults+ - (list #:gravity? #f #:vx 0 #:vy 0 #:on-ground? #f - #:solid? #t #:immovable? #t - #:skip-pipelines '(jump acceleration gravity velocity-x velocity-y - tile-collisions-x tile-collisions-y on-solid))) + '((#:gravity? . #f) + (#:vx . 0) + (#:vy . 0) + (#:on-ground? . #f) + (#:solid? . #t) + (#:immovable? . #t) + (#:skip-pipelines . (jump acceleration gravity velocity-x velocity-y + tile-collisions-x tile-collisions-y on-solid)))) (define (part-with-group-locals part) (let* ((p part) @@ -109,14 +116,30 @@ (mixin-section (if (assq 'mixins data) (cdr (assq 'mixins data)) '())) (prefab-section (cdr (assq 'prefabs data))) (group-section (cond ((assq 'group-prefabs data) => cdr) (else '()))) + ;; Convert engine mixin-table bodies (plists) to alists. + (engine-mixin-alist-table + (map (lambda (m) (cons (car m) (plist->alist (cdr m)))) + engine-mixin-table)) ;; user mixins first → user wins on assq lookup (overrides engine mixin by name) - (user-mixin-table (if (null? mixin-section) '() (map (lambda (m) (cons (car m) (cdr m))) mixin-section))) - (merged-mixin-table (append user-mixin-table engine-mixin-table)) + (user-mixin-table + (map (lambda (m) (cons (car m) (plist->alist (cdr m)))) + mixin-section)) + (merged-mixin-table (append user-mixin-table engine-mixin-alist-table)) ;; user-hooks first → user wins on assq lookup (overrides engine hooks by name) (hook-table (append user-hooks *engine-hooks*)) - (prefab-table (map (lambda (entry) (compose-prefab entry merged-mixin-table)) - prefab-section)) - (group-table (map compose-group-prefab group-section))) + (prefab-table + (map (lambda (entry) + (let* ((composed (compose-prefab entry merged-mixin-table)) + (converted (convert-nested-plist-values (cdr composed)))) + (cons (car composed) converted))) + prefab-section)) + (group-table + (map (lambda (entry) + (let* ((name (car entry)) + (alist-fields (plist->alist (cdr entry))) + (converted (convert-nested-plist-values alist-fields))) + (cons name converted))) + group-section))) (make-prefab-registry prefabs: prefab-table group-prefabs: group-table @@ -130,19 +153,8 @@ (prefab-registry-engine-mixin-table registry) (prefab-registry-user-hooks registry))) -(define (plist->alist plist) - (if (> (modulo (length plist) 2) 0) - (error "Invalid plist!") - (let loop ((n1 (car plist)) - (n2 (cadr plist)) - (rest (if (> (length plist) 2) (cddr plist) '()))) - (if (null? rest) - (list (cons n1 n2)) - (cons (cons n1 n2) (loop (car rest) (cadr rest) (cddr rest))))))) - (define (do-instantiate-prefab registry entry x y w h) - (let* ((base (entity-set-many (make-entity x y w h) - (plist->alist (cdr entry)))) + (let* ((base (entity-set-many (make-entity x y w h) (cdr entry))) (hook-val (entity-ref base #:on-instantiate #f)) (handler (cond @@ -163,7 +175,7 @@ (define (instantiate-group-member part ox oy gid type-members static-parts?) (let* ((p0 (part-with-group-locals part)) - (merged (plist-merge p0 (if static-parts? +static-group-member-defaults+ '()))) + (merged (alist-merge p0 (if static-parts? +static-group-member-defaults+ '()))) (lx (entity-ref merged #:group-local-x 0)) (ly (entity-ref merged #:group-local-y 0)) (typ (entity-ref merged #:type type-members)) @@ -192,9 +204,12 @@ (oh (entity-ref spec #:origin-height 0)) (ot (entity-ref spec #:origin-type 'group-origin)) (origin-fields - (append - (list #:type ot #:group-id gid #:group-origin? #t - #:x ox #:y oy #:width ow #:height oh) + (alist-merge + `((#:type . ,ot) + (#:group-id . ,gid) + (#:group-origin? . #t) + (#:x . ,ox) (#:y . ,oy) + (#:width . ,ow) (#:height . ,oh)) (if pose-only? +pose-only-group-origin-defaults+ +physics-group-origin-defaults+))) diff --git a/tests/animation-test.scm b/tests/animation-test.scm index 87b18e7..aae829a 100644 --- a/tests/animation-test.scm +++ b/tests/animation-test.scm @@ -1,10 +1,15 @@ -(import srfi-64) +(import srfi-64 + (only (list-utils alist) plist->alist)) (include "entity.scm") (include "tilemap.scm") (include "world.scm") (include "animation.scm") (import downstroke-entity downstroke-world downstroke-animation) +;; Test helpers: construct alist entities / animation defs from readable plist kwargs. +(define (entity . kws) (plist->alist kws)) +(define (anim . kws) (plist->alist kws)) + (test-begin "animation") (test-group "frame->tile-id" @@ -24,44 +29,44 @@ ) (test-group "set-animation" - (let ((entity (list #:type 'player #:anim-name 'idle #:anim-frame 5 #:anim-tick 8))) - (test-equal "no-op if already active" entity (set-animation entity 'idle)) - (let ((switched (set-animation entity 'walk))) + (let ((e (entity #:type 'player #:anim-name 'idle #:anim-frame 5 #:anim-tick 8))) + (test-equal "no-op if already active" e (set-animation e 'idle)) + (let ((switched (set-animation e 'walk))) (test-equal "switches anim-name" 'walk (entity-ref switched #:anim-name)) (test-equal "resets frame" 0 (entity-ref switched #:anim-frame)) (test-equal "resets tick" 0 (entity-ref switched #:anim-tick))))) (test-group "animate-entity" (test-group "Single frames" - (let* ((anims '((#:name walk #:frames (2 3) #:duration 4))) - (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0)) - (stepped (animate-entity entity anims))) + (let* ((anims (list (anim #:name 'walk #:frames '(2 3) #:duration 4))) + (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0)) + (stepped (animate-entity e anims))) (test-equal "increments tick" 1 (entity-ref stepped #:anim-tick)) (test-equal "sets tile-id on first tick" 2 (entity-ref stepped #:tile-id))) - (let* ((anims '((#:name walk #:frames (0 1) #:duration 2))) - (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 1)) - (advanced (animate-entity entity anims))) + (let* ((anims (list (anim #:name 'walk #:frames '(0 1) #:duration 2))) + (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 1)) + (advanced (animate-entity e anims))) (test-equal "advances frame when tick reaches duration" 1 (entity-ref advanced #:anim-frame)) (test-equal "resets tick on frame advance" 0 (entity-ref advanced #:anim-tick)))) (test-group "Frames with duration" - (let* ((anims '((#:name walk #:frames ((0 10) (1 20)) #:duration 4))) - (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 9)) - (stepped (animate-entity entity anims))) + (let* ((anims (list (anim #:name 'walk #:frames '((0 10) (1 20)) #:duration 4))) + (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 9)) + (stepped (animate-entity e anims))) (test-equal "ticks resets on frame switch" 0 (entity-ref stepped #:anim-tick)) (test-equal "sets tile-id on 10th tick" 1 (entity-ref stepped #:tile-id)) (test-equal "sets duration to frame duration" 20 (entity-ref stepped #:duration)))) (test-group "Empty" - (let* ((entity (list #:type 'player))) - (test-equal "unchanged entity without anim-name" entity (animate-entity entity '()))))) + (let* ((e (entity #:type 'player))) + (test-equal "unchanged entity without anim-name" e (animate-entity e '()))))) (test-group "animation pipeline" (test-group "animated entity" - (let* ((anims '((#:name walk #:frames (2 3) #:duration 4))) - (entity (list #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0 #:animations anims)) - (stepped-entity (apply-animation #f entity 10))) + (let* ((anims (list (anim #:name 'walk #:frames '(2 3) #:duration 4))) + (e (entity #:type 'player #:anim-name 'walk #:anim-frame 0 #:anim-tick 0 #:animations anims)) + (stepped-entity (apply-animation #f e 10))) (test-equal "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick))) - (let* ((entity (list #:type 'static)) - (stepped-entity (apply-animation #f entity 10))) + (let* ((e (entity #:type 'static)) + (stepped-entity (apply-animation #f e 10))) (test-equal "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick))))) (test-end "animation") diff --git a/tests/entity-test.scm b/tests/entity-test.scm index 3b83dff..d686acf 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -4,9 +4,13 @@ (test-begin "entity") -;; Test: entity-ref retrieves values from entity plists +;; Test: entity-ref retrieves values from entity alists (test-group "entity-ref" - (let ((entity '(#:type player #:x 100 #:y 200 #:width 16 #:height 16))) + (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)) @@ -14,7 +18,7 @@ (test-equal "retrieves height" 16 (entity-ref entity #:height))) ;; Test with default value - (let ((entity '(#:type player))) + (let ((entity '((#:type . player)))) (test-equal "returns default for missing key" 99 (entity-ref entity #:x 99)) @@ -24,7 +28,7 @@ ;; Test: entity-ref with procedure as default (test-group "entity-ref-with-procedure-default" - (let ((entity '(#:type player))) + (let ((entity '((#:type . player)))) (test-equal "calls procedure default when key missing" 42 (entity-ref entity #:x (lambda () 42))))) @@ -40,26 +44,26 @@ ;; Test: entity-type extracts type from entity (test-group "entity-type" - (let ((player '(#:type player #:x 100)) - (enemy '(#:type enemy #:x 200))) + (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))) + (let ((no-type '((#:x . 100) (#:y . 200)))) (test-equal "returns #f for entity without type" #f (entity-type no-type)))) ;; 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))) + (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)))) @@ -67,79 +71,75 @@ ;; 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))) + (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)))) + ;; alist length stays at 2 (one pair removed, one added) — not 3. + (test-equal "no duplicate key: list length unchanged" 2 (length e)))) (test-group "new key is added" - (let ((e (entity-set '(#:x 10) #:vx 3))) + (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-equal "list grows by one pair" 2 (length e))))) (test-group "entity-set-many" - (test-group "Set multiple entities with lists" - (let ((e (entity-set-many '(#:x 10 #:y 20) '((#:x 15) (#:y 25))))) - (test-equal "value x updated" 15 (entity-ref e #:x)) - (test-equal "value y updated" 25 (entity-ref e #:y)))) (test-group "Set multiple entities with cons" - (let ((e (entity-set-many '(#:x 10 #:y 20) (list (cons #:x 15) (cons #:y 25))))) + (let ((e (entity-set-many '((#:x . 10) (#:y . 20)) + '((#:x . 15) (#:y . 25))))) (test-equal "value x updated" 15 (entity-ref e #:x)) (test-equal "value y updated" 25 (entity-ref e #:y))))) ;; 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))))) + (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))) + (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)))) + (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))))) + (let ((e (entity-update '((#:x . 10) (#:y . 20)) #:x (lambda (v) (* v 2))))) + (test-equal "length is 2" 2 (length e))))) (test-group "entity-skips-pipeline?" (test-assert "absent skip list" - (not (entity-skips-pipeline? '(#:type a) 'gravity))) + (not (entity-skips-pipeline? '((#:type . a)) 'gravity))) (test-assert "empty skip list" - (not (entity-skips-pipeline? '(#:skip-pipelines ()) 'gravity))) + (not (entity-skips-pipeline? '((#:skip-pipelines . ())) 'gravity))) (test-assert "member" - (entity-skips-pipeline? '(#:skip-pipelines (gravity velocity-x)) 'gravity)) + (entity-skips-pipeline? '((#:skip-pipelines . (gravity velocity-x))) 'gravity)) (test-assert "not member" - (not (entity-skips-pipeline? '(#:skip-pipelines (gravity)) 'velocity-x)))) + (not (entity-skips-pipeline? '((#:skip-pipelines . (gravity))) 'velocity-x)))) -(define-pipeline (fixture-pipeline fixture-skip) (scene_ ent) +(define-pipeline (fixture-pipeline fixture-skip) (scene_ ent _dt) (entity-set ent #:x 42)) (test-group "define-pipeline" - (let ((e '(#:type t #:x 0))) - (test-equal "runs body" 42 (entity-ref (fixture-pipeline e) #:x))) - (let ((e '(#:type t #:x 0 #:skip-pipelines (fixture-skip)))) - (test-equal "skipped" 0 (entity-ref (fixture-pipeline e) #:x)))) + (let ((e '((#:type . t) (#:x . 0)))) + (test-equal "runs body" 42 (entity-ref (fixture-pipeline #f e 0) #:x))) + (let ((e '((#:type . t) (#:x . 0) (#:skip-pipelines . (fixture-skip))))) + (test-equal "skipped" 0 (entity-ref (fixture-pipeline #f e 0) #:x)))) -(define-pipeline (guarded-pipeline guarded-skip) (scene_ ent) +(define-pipeline (guarded-pipeline guarded-skip) (scene_ ent _dt) guard: (entity-ref ent #:active? #f) (entity-set ent #:x 99)) (test-group "define-pipeline with guard:" - (let ((e '(#:type t #:x 0 #:active? #t))) + (let ((e '((#:type . t) (#:x . 0) (#:active? . #t)))) (test-equal "runs body when guard passes" 99 - (entity-ref (guarded-pipeline e) #:x))) - (let ((e '(#:type t #:x 0))) + (entity-ref (guarded-pipeline #f e 0) #:x))) + (let ((e '((#:type . t) (#:x . 0)))) (test-equal "returns entity unchanged when guard fails" 0 - (entity-ref (guarded-pipeline e) #:x))) - (let ((e '(#:type t #:x 0 #:active? #t #:skip-pipelines (guarded-skip)))) + (entity-ref (guarded-pipeline #f e 0) #:x))) + (let ((e '((#:type . t) (#:x . 0) (#:active? . #t) (#:skip-pipelines . (guarded-skip))))) (test-equal "skip-pipelines takes precedence over guard" 0 - (entity-ref (guarded-pipeline e) #:x)))) + (entity-ref (guarded-pipeline #f e 0) #:x)))) (test-end "entity") diff --git a/tests/input-test.scm b/tests/input-test.scm index 0d1e4b5..bbc5599 100644 --- a/tests/input-test.scm +++ b/tests/input-test.scm @@ -14,6 +14,11 @@ (include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Load the module source directly (include "input.scm") ;; Now import it to access the exported functions @@ -119,13 +124,13 @@ (define (make-physics-entity) (entity-set-many (make-entity 0 0 16 16) - '((#:vx 0) (#:vy 0) - (#:input-map ((left . (-2 . 0)) (right . (2 . 0))))))) + `((#:vx . 0) (#:vy . 0) + (#:input-map . ((left . (-2 . 0)) (right . (2 . 0))))))) ;; 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)) + (let* ((e (entity #:type 'player #:x 5 #:y 10)) (out (apply-input-to-entity e (lambda (a) #f)))) (test-equal "entity returned as-is" e out))) diff --git a/tests/physics-test.scm b/tests/physics-test.scm index 88ddcce..4ab4b17 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -41,6 +41,11 @@ (include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Load world module first (include "world.scm") (import downstroke-world) @@ -74,82 +79,82 @@ ;; Integration helper: simulate one frame of physics (define (tick e tm held?) (let* ((e (apply-input-to-entity e held?)) - (e (apply-gravity e #f 0)) - (e (apply-velocity-x e #f 0)) - (e (resolve-tile-collisions-x e (test-scene tilemap: tm) 0)) - (e (apply-velocity-y e #f 0)) - (e (resolve-tile-collisions-y e (test-scene tilemap: tm) 0)) - (e (detect-on-solid e (test-scene tilemap: tm) 0))) + (e (apply-gravity #f e 0)) + (e (apply-velocity-x #f e 0)) + (e (resolve-tile-collisions-x (test-scene tilemap: tm) e 0)) + (e (apply-velocity-y #f e 0)) + (e (resolve-tile-collisions-y (test-scene tilemap: tm) e 0)) + (e (detect-on-solid (test-scene tilemap: tm) e 0))) 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 #f 0))) + (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #t)) + (result (apply-gravity #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 0 #:y 0 #:vx 0 #:vy 3 #:gravity? #t)) + (result (apply-gravity #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'static #:x 0 #:y 0 #:vx 0 #:vy 0 #:gravity? #f)) + (result (apply-gravity #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'static #:x 5 #:y 5)) + (result (apply-gravity #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 5 #:vy -2)) + (result (apply-velocity-x #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 0 #:vy 3)) + (result (apply-velocity-x #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy -5)) + (result (apply-velocity-y #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'rock #:x 10 #:y 20 #:vx 3 #:vy 0)) + (result (apply-velocity-y #f e 0))) (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)) + (let* ((e (entity #: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)) + (let* ((e (entity #: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)) + (let* ((e (entity #: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))))) @@ -201,100 +206,100 @@ (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0)))) + (e (entity #: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 (test-scene tilemap: tm) e 0)))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 20 #:y 16 #:width 16 #:height 16 #:vx 5 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx -5 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 20.5 #:y 16 #:width 16 #:height 16 #:vx 2 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 28 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 34 #:y 0 #:width 20 #:height 16 #:vx 3 #:vy 0))) + (let ((result (resolve-tile-collisions-x (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:vx 0 #:vy 2))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0)))) + (e (entity #: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 (test-scene tilemap: tm) e 0)))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 20 #:width 16 #:height 16 #:vx 0 #:vy 5))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 16 #:y 16 #:width 16 #:height 16 #:vx 0 #:vy -5))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 20.5 #:width 16 #:height 16 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 28 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (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 (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 20 #:vx 0 #:vy 3))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "pushed above floor" 28 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy)))))) @@ -304,8 +309,8 @@ ;; After apply-velocity-y the entity lands at y=34 (overlapping both rows 2 and 3). ;; Correct: snap to top of row 2 → y=16. Bug was: fold overwrote row 2 snap with row 3 snap → y=32 (inside row 2). (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (1 0 0) (1 0 0) (0 0 0)))) - (e '(#:type player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) - (let ((result (resolve-tile-collisions-y e (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 34 #:width 16 #:height 16 #:vx 0 #:vy 20))) + (let ((result (resolve-tile-collisions-y (test-scene tilemap: tm) e 0))) (test-equal "snapped to first solid row" 16 (entity-ref result #:y)) (test-equal "vy zeroed" 0 (entity-ref result #:vy))))) @@ -315,8 +320,8 @@ ;; 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 ()))) + (e0 (entity #: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 @@ -328,8 +333,8 @@ ;; 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 ()))) + (e0 (entity #: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)) @@ -350,7 +355,7 @@ (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)) + (entity #: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)) @@ -383,9 +388,9 @@ (test-group "immovable: landing uses vertical separation when horizontal overlap is shallower" ;; Without the landing rule, ovx < ovy would pick horizontal separation and shove the ;; mover sideways off a narrow platform. Box center remains above shelf center → snap on top. - (let* ((shelf (list #:type 'static #:x 100 #:y 200 #:width 16 #:height 16 - #:solid? #t #:immovable? #t)) - (box (list #:type 'box #:x 92 #:y 196 #:width 16 #:height 16 + (let* ((shelf (entity #:type 'static #:x 100 #:y 200 #:width 16 #:height 16 + #:solid? #t #:immovable? #t)) + (box (entity #:type 'box #:x 92 #:y 196 #:width 16 #:height 16 #:solid? #t #:immovable? #f #:vx 0 #:vy 0)) (result (resolve-entity-collisions (list shelf box))) (box2 (list-ref result 1))) @@ -394,7 +399,7 @@ (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)) + (b (entity #: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))))) @@ -406,72 +411,72 @@ ;; 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-on-solid e (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (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-on-solid e (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #t)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (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-on-solid e (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 0 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (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-on-solid e (test-scene tilemap: tm) 0))) + (e (entity #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) e 0))) (test-assert "on-ground? is #t (right foot on solid)" (entity-ref result #:on-ground? #f)))) (test-group "standing on solid entity (no tile): moving platform / crate" ;; All-air tilemap; wide platform top at y=32; player feet (bottom) at y=32 (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) - (platform (list #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 - #:solid? #t #:vx 0 #:vy 0 #:gravity? #f)) - (player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 - #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) + (platform (entity #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 + #:solid? #t #:vx 0 #:vy 0 #:gravity? #f)) + (player (entity #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:vx 0 #:vy 0 #:gravity? #t #:on-ground? #f)) (ents (list platform player)) - (result (detect-on-solid player (test-scene tilemap: tm entities: ents) 0))) + (result (detect-on-solid (test-scene tilemap: tm entities: ents) player 0))) (test-assert "on-ground? from entity top" (entity-ref result #:on-ground? #f)))) (test-group "scene with empty entity list: no entity below" (let* ((tm (make-test-tilemap '((0 0 0) (0 0 0) (0 0 0)))) - (platform (list #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 #:solid? #t)) - (player (list #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 - #:gravity? #t #:on-ground? #f)) - (result (detect-on-solid player (test-scene tilemap: tm) 0))) + (platform (entity #:type 'platform #:x 0 #:y 32 #:width 64 #:height 16 #:solid? #t)) + (player (entity #:type 'player #:x 8 #:y 16 #:width 16 #:height 16 + #:gravity? #t #:on-ground? #f)) + (result (detect-on-solid (test-scene tilemap: tm) player 0))) (test-assert "empty entity list → not on ground" (not (entity-ref result #:on-ground? #f)))))) (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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #t)) + (result (apply-acceleration #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 0 #:gravity? #t)) + (result (apply-acceleration #f e 0))) (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 #f 0))) + (let* ((e (entity #:type 'player #:x 0 #:y 0 #:vy 3 #:ay 5 #:gravity? #f)) + (result (apply-acceleration #f e 0))) (test-equal "entity unchanged" e result)))) (test-group "pixel->tile" @@ -485,14 +490,14 @@ (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)) + (e (entity #: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)) + (e (entity #:type 'player #:x 8 #:y 8 #:width 16 #:height 16)) (cells (entity-tile-cells e tm))) (test-equal "four cells" 4 (length cells))))) @@ -531,43 +536,43 @@ (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)) + (let* ((e (entity #: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)) + (let* ((e (entity #: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))) + (let ((e (entity #: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))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #: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))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #: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))) + (let ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #: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)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 10 #:y 0 #:width 16 #:height 16)) (result (push-along-axis #:x a b 6)) (ra (car result)) (rb (cdr result))) @@ -577,8 +582,8 @@ (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)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #:type 'player #:x 0 #:y 10 #:width 16 #:height 16)) (result (push-along-axis #:y a b 6)) (ra (car result)) (rb (cdr result))) @@ -588,42 +593,42 @@ (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)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #: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)) + (let* ((a (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (b (entity #: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 "skip-pipelines" (test-group "apply-gravity" - (let* ((e '(#:type t #:vy 0 #:gravity? #t #:skip-pipelines (gravity))) - (r (apply-gravity e #f 0))) + (let* ((e (entity #:type 't #:vy 0 #:gravity? #t #:skip-pipelines '(gravity))) + (r (apply-gravity #f e 0))) (test-equal "skipped: vy unchanged" 0 (entity-ref r #:vy)))) (test-group "apply-velocity-x" - (let* ((e '(#:type t #:x 10 #:vx 5 #:skip-pipelines (velocity-x))) - (r (apply-velocity-x e #f 0))) + (let* ((e (entity #:type 't #:x 10 #:vx 5 #:skip-pipelines '(velocity-x))) + (r (apply-velocity-x #f e 0))) (test-equal "skipped: x unchanged" 10 (entity-ref r #:x)))) (test-group "resolve-pair with entity-collisions skip" - (define (make-solid x y) (list #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) - (let* ((a (list #:type 'ghost #:x 0 #:y 0 #:width 16 #:height 16 #:solid? #t - #:skip-pipelines '(entity-collisions))) + (define (make-solid x y) (entity #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (let* ((a (entity #:type 'ghost #:x 0 #:y 0 #:width 16 #:height 16 #:solid? #t + #:skip-pipelines '(entity-collisions))) (b (make-solid 10 0))) (test-assert "no resolution" (not (resolve-pair a b)))))) (test-group "resolve-pair" - (define (make-solid x y) (list #:type 'block #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (define (make-solid x y) (entity #: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))) + (b (entity #: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" @@ -641,9 +646,9 @@ (test-group "immovable" (define (make-static x y) - (list #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t)) + (entity #:type 'wall #:x x #:y y #:width 16 #:height 16 #:solid? #t #:immovable? #t)) (define (make-box x y) - (list #:type 'box #:x x #:y y #:width 16 #:height 16 #:solid? #t)) + (entity #:type 'box #:x x #:y y #:width 16 #:height 16 #:solid? #t)) (test-group "both immovable and overlapping: #f" (let* ((a (make-static 0 0)) (b (make-static 8 0))) diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index 3578b35..ab7b5f1 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -67,7 +67,7 @@ ;; Inline #:vx 99 beats mixin #:vx 5 (let ((e (instantiate-prefab reg 'runner 0 0 16 16))) (pp e) - (test-equal "entity should have squashed properties" 14 (length e)) + (test-equal "entity should have squashed properties" 7 (length e)) (test-equal "inline field beats mixin field for same key" 99 (entity-ref e #:vx)) @@ -143,9 +143,8 @@ ;; (Data files only contain symbols; this tests the procedure? branch directly.) (let* ((hook-proc (lambda (e) (entity-set e #:proc-fired #t))) (reg (make-prefab-registry - prefabs: (list (cons 'proc-hooked - (list #:type 'proc-hooked - #:on-instantiate hook-proc))) + prefabs: `((proc-hooked . ((#:type . proc-hooked) + (#:on-instantiate . ,hook-proc)))) group-prefabs: '() file: "/dev/null" engine-mixin-table: '() diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index 2829348..9f6ce55 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -42,6 +42,11 @@ (include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Load world module (include "world.scm") (import downstroke-world) @@ -54,7 +59,7 @@ (test-group "entity-screen-coords" (let* ((cam (make-camera x: 10 y: 20)) - (e (list #:x 50 #:y 80 #:width 16 #:height 16))) + (e (entity #:x 50 #:y 80 #:width 16 #:height 16))) (test-equal "subtracts camera offset from x" 40 (car (entity-screen-coords e cam))) @@ -69,7 +74,7 @@ (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))) + (e (entity #:x 100.7 #:y 200.3 #:width 16 #:height 16))) (test-equal "floors fractional x" 100 (car (entity-screen-coords e cam))) @@ -78,7 +83,7 @@ (cadr (entity-screen-coords e cam)))) (let* ((cam (make-camera x: 0 y: 0)) - (e (list #:x 0 #:y 0 #:width 32 #:height 32))) + (e (entity #:x 0 #:y 0 #:width 32 #:height 32))) (test-equal "zero camera, zero position" '(0 0 32 32) (entity-screen-coords e cam)))) @@ -86,13 +91,13 @@ (test-group "entity-flip" (test-equal "facing 1: no flip" '() - (entity-flip (list #:facing 1))) + (entity-flip (entity #:facing 1))) (test-equal "facing -1: horizontal flip" '(horizontal) - (entity-flip (list #:facing -1))) + (entity-flip (entity #:facing -1))) (test-equal "no facing key: defaults to no flip" '() - (entity-flip (list #:x 0)))) + (entity-flip (entity #:x 0)))) (test-group "render-scene!" (let* ((cam (make-camera x: 0 y: 0)) @@ -116,7 +121,7 @@ (begin (render-scene! #f scene) #t))) (let* ((cam (make-camera x: 0 y: 0)) - (box (list #:x 4 #:y 8 #:width 10 #:height 12 #:color '(200 40 90))) + (box (entity #:x 4 #:y 8 #:width 10 #:height 12 #:color '(200 40 90))) (scene (make-scene entities: (list box) tilemap: #f camera: cam @@ -243,8 +248,8 @@ tileset: tileset layers: (list layer) objects: '())) - (player (list #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) - (enemy (list #:type 'enemy #:x 50 #:y 60 #:width 16 #:height 16 #:facing -1)) + (player (entity #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) + (enemy (entity #:type 'enemy #:x 50 #:y 60 #:width 16 #:height 16 #:facing -1)) (scene (make-scene entities: (list player enemy) tilemap: tilemap camera: cam @@ -267,7 +272,7 @@ tileset: tileset layers: (list layer) objects: '())) - (player (list #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) + (player (entity #:type 'player #:x 10 #:y 20 #:width 16 #:height 16 #:facing 1)) (scene (make-scene entities: (list player) tilemap: tilemap camera: cam @@ -287,9 +292,9 @@ tileset-source: "" tileset: tileset layers: (list layer) objects: '())) (tex 'mock-texture) - (entity (list #:type 'box #:x 10 #:y 20 #:width 16 #:height 16 #:tile-id 1)) - (cell (vector entity 'extra-data 0 100 'linear #t)) - (scene-ok (make-scene entities: (list entity) + (ent (entity #:type 'box #:x 10 #:y 20 #:width 16 #:height 16 #:tile-id 1)) + (cell (vector ent 'extra-data 0 100 'linear #t)) + (scene-ok (make-scene entities: (list ent) tilemap: tilemap camera: cam tileset-texture: tex camera-target: #f)) (scene-bad (make-scene entities: (list cell) diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm index 5c85ede..88fb544 100644 --- a/tests/scene-loader-test.scm +++ b/tests/scene-loader-test.scm @@ -20,25 +20,15 @@ (define (load-tileset filename) (make-tileset tilewidth: 16 tileheight: 16 spacing: 0 tilecount: 256 columns: 16 image-source: "" image: #f))) (import downstroke-tilemap) -;; Mock entity module (minimal) -(module downstroke-entity * - (import scheme (chicken base)) - (define (entity-ref entity key #!optional (default #f)) - (let loop ((plist entity)) - (cond - ((null? plist) (if (procedure? default) (default) default)) - ((eq? (car plist) key) (cadr plist)) - (else (loop (cddr plist)))))) - (define (entity-set entity key val) - (let loop ((plist entity) (acc '())) - (cond - ((null? plist) (reverse (cons val (cons key acc)))) - ((eq? (car plist) key) (append (reverse acc) (cons key (cons val (cddr plist))))) - (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc))))))) - (define (entity-type entity) - (entity-ref entity #:type #f))) +;; Load the real entity module (alist-based) +(include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Mock world module (module downstroke-world * (import scheme (chicken base) defstruct) @@ -100,8 +90,8 @@ objects: (list obj1 obj2 obj3))) ;; mock registry: alist of (type . constructor) (registry - (list (cons 'player (lambda (x y w h) (list #:type 'player #:x x #:y y #:width w #:height h))) - (cons 'enemy (lambda (x y w h) (list #:type 'enemy #:x x #:y y #:width w #:height h))))) + (list (cons 'player (lambda (x y w h) (entity #:type 'player #:x x #:y y #:width w #:height h))) + (cons 'enemy (lambda (x y w h) (entity #:type 'enemy #:x x #:y y #:width w #:height h))))) (result (tilemap-objects->entities tm registry))) (test-equal "filters #f results: 2 entities from 3 objects" 2 (length result)) diff --git a/tests/tween-test.scm b/tests/tween-test.scm index f0622fb..962d325 100644 --- a/tests/tween-test.scm +++ b/tests/tween-test.scm @@ -4,6 +4,11 @@ (include "tween.scm") (import downstroke-entity downstroke-tween) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + (test-begin "tween") (test-group "ease functions" @@ -35,7 +40,7 @@ (test-group "make-tween / tween-step" (test-group "linear completes to target" - (let* ((ent (list #:type 'a #:x 0 #:y 10)) + (let* ((ent (entity #:type 'a #:x 0 #:y 10)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "finished" (tween-finished? tw2)) @@ -43,7 +48,7 @@ (test-equal "y preserved" 10 (entity-ref e2 #:y))))) (test-group "delay holds props" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 50)) duration: 100 delay: 40 ease: 'linear))) (receive (tw2 e2) (tween-step tw ent 30) (test-assert "not finished" (not (tween-finished? tw2))) @@ -55,14 +60,14 @@ (test-assert "past delay, moved" (> (entity-ref e4 #:x) 0))))))) (test-group "midpoint linear" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 delay: 0 ease: 'linear))) (receive (_ e2) (tween-step tw ent 50) (test-equal "halfway x" 50.0 (entity-ref e2 #:x))))) (test-group "on-complete runs once" (let ((calls 0)) - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 delay: 0 ease: 'linear on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) @@ -72,7 +77,7 @@ (test-equal "entity stable" e3 e2)))))) (test-group "idempotent after finish" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 20)) duration: 10 delay: 0 ease: 'linear))) (receive (tw2 e2) (tween-step tw ent 10) (receive (tw3 e3) (tween-step tw2 e2 999) @@ -81,7 +86,7 @@ (test-group "repeat" (test-group "repeat: 1 plays twice" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 1))) (receive (tw2 e2) (tween-step tw ent 100) @@ -92,7 +97,7 @@ (test-equal "x at target again" 100.0 (entity-ref e3 #:x)))))) (test-group "repeat: -1 never finishes" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 ease: 'linear repeat: -1))) (let loop ((tw tw) (ent ent) (i 0)) @@ -102,14 +107,14 @@ (loop tw2 e2 (+ i 1))))))) (test-group "repeat: 0 is default (no repeat)" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 50)) duration: 50 ease: 'linear))) (receive (tw2 _e2) (tween-step tw ent 50) (test-assert "finished immediately" (tween-finished? tw2))))) (test-group "on-complete fires after last repeat" (let ((calls 0)) - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 ease: 'linear repeat: 1 on-complete: (lambda (_) (set! calls (+ calls 1)))))) @@ -120,7 +125,7 @@ (test-group "on-complete does not fire with repeat: -1" (let ((calls 0)) - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 ease: 'linear repeat: -1 on-complete: (lambda (_) (set! calls (+ calls 1)))))) @@ -131,7 +136,7 @@ (test-group "yoyo" (test-group "yoyo: #t with repeat: 1 reverses" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 1 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) @@ -143,7 +148,7 @@ (test-equal "x back to start" 0.0 (entity-ref e4 #:x))))))) (test-group "yoyo: #t with repeat: -1 ping-pongs forever" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) ;; Forward @@ -158,7 +163,7 @@ (test-assert "still active" (tween-active? tw4))))))) (test-group "yoyo: #f with repeat: 1 replays same direction" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 1 yoyo?: #f))) (receive (tw2 e2) (tween-step tw ent 100) @@ -169,7 +174,7 @@ (test-assert "not finished mid-repeat" (not (tween-finished? tw3))))))) (test-group "yoyo: #t without repeat has no effect" - (let* ((ent (list #:type 'a #:x 0)) + (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 ease: 'linear repeat: 0 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) @@ -178,40 +183,40 @@ (test-group "step-tweens pipeline" (test-group "advances #:tween on entity" - (let* ((ent (list #:type 'a #:x 0 - #:tween (make-tween (list #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) - (e2 (step-tweens ent #f 50))) + (let* ((ent (entity #:type 'a #:x 0 + #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens #f ent 50))) (test-equal "x moved to midpoint" 50.0 (entity-ref e2 #:x)) (test-assert "tween still attached" (entity-ref e2 #:tween #f)))) (test-group "removes #:tween when finished" - (let* ((ent (list #:type 'a #:x 0 - #:tween (make-tween (list #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) - (e2 (step-tweens ent #f 100))) + (let* ((ent (entity #:type 'a #:x 0 + #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens #f ent 100))) (test-equal "x at target" 100.0 (entity-ref e2 #:x)) (test-equal "tween removed" #f (entity-ref e2 #:tween #f)))) (test-group "no-op without #:tween" - (let* ((ent (list #:type 'a #:x 42)) - (e2 (step-tweens ent #f 100))) + (let* ((ent (entity #:type 'a #:x 42)) + (e2 (step-tweens #f ent 100))) (test-equal "x unchanged" 42 (entity-ref e2 #:x)))) (test-group "keeps repeating tween attached" - (let* ((ent (list #:type 'a #:x 0 - #:tween (make-tween (list #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) - (e2 (step-tweens ent #f 100))) + (let* ((ent (entity #:type 'a #:x 0 + #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) + (e2 (step-tweens #f ent 100))) (test-equal "x at target" 100.0 (entity-ref e2 #:x)) (test-assert "tween still attached (repeating)" (entity-ref e2 #:tween #f)))) (test-group "respects #:skip-pipelines" - (let* ((ent (list #:type 'a #:x 0 - #:skip-pipelines '(tweens) - #:tween (make-tween (list #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) - (e2 (step-tweens ent #f 100))) + (let* ((ent (entity #:type 'a #:x 0 + #:skip-pipelines '(tweens) + #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) + duration: 100 ease: 'linear))) + (e2 (step-tweens #f ent 100))) (test-equal "x unchanged (skipped)" 0 (entity-ref e2 #:x)) (test-assert "tween still there" (entity-ref e2 #:tween #f))))) diff --git a/tests/world-test.scm b/tests/world-test.scm index bfbb336..a66103e 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -41,6 +41,11 @@ (include "entity.scm") (import downstroke-entity) +(import (only (list-utils alist) plist->alist)) + +;; Test helper: build an alist entity from plist-style keyword args. +(define (entity . kws) (plist->alist kws)) + ;; Load the module source directly (include "world.scm") ;; Now import it to access the exported functions @@ -111,7 +116,7 @@ ;; Test: scene with entities and tilemap (test-group "scene-with-data" (let* ((player (entity-set (make-entity 100 100 16 16) #:type 'player)) - (enemy '(#:type enemy #:x 200 #:y 200)) + (enemy (entity #:type 'enemy #:x 200 #:y 200)) (tilemap "mock-tilemap") (scene (make-scene entities: (list player enemy) tilemap: tilemap @@ -130,7 +135,7 @@ (test-group "scene-add-entity" (let* ((player (make-entity 100 100 16 16)) (scene (make-scene entities: (list player) tilemap: #f camera-target: #f)) - (enemy '(#:type enemy #:x 200 #:y 200))) + (enemy (entity #:type 'enemy #:x 200 #:y 200))) (test-equal "initial entity count" 1 (length (scene-entities scene))) @@ -143,9 +148,9 @@ ;; 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)) + (let* ((e1 (entity #:type 'a #:x 1)) + (e2 (entity #:type 'b #:x 2)) + (e3 (entity #:type 'c #:x 3)) (scene (make-scene entities: (list e1) tilemap: #f camera-target: #f)) (scene (scene-add-entity scene e2)) (scene (scene-add-entity scene e3))) @@ -156,14 +161,14 @@ ;; Test: scene-map-entities applies function to all entities (test-group "scene-map-entities" - (let* ((e1 '(#:type player #:x 100 #:y 100)) - (e2 '(#:type enemy #:x 200 #:y 200)) + (let* ((e1 (entity #:type 'player #:x 100 #:y 100)) + (e2 (entity #:type 'enemy #:x 200 #:y 200)) (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) - (move-right (lambda (scene 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)))) + (move-right (lambda (scene ent) + (let ((x (entity-ref ent #:x)) + (y (entity-ref ent #:y)) + (type (entity-ref ent #:type))) + (entity #:type type #:x (+ x 10) #:y y)))) (scene2 (scene-map-entities scene move-right))) (test-equal "original scene unchanged" @@ -181,8 +186,8 @@ ;; Test: scene-map-entities with identity function (test-group "scene-map-entities-identity" - (let* ((e1 '(#:type player #:x 100)) - (e2 '(#:type enemy #:x 200)) + (let* ((e1 (entity #:type 'player #:x 100)) + (e2 (entity #:type 'enemy #:x 200)) (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) (scene2 (scene-map-entities scene (lambda (scene e) e)))) @@ -204,8 +209,8 @@ (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)))))) + (entity #: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))))) @@ -227,8 +232,8 @@ ;; 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)) + (let* ((e1 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16)) + (e2 (entity #: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) @@ -244,20 +249,20 @@ (test-group "camera-follow" (let* ((cam (make-camera x: 0 y: 0)) - (entity (list #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) - (cam2 (camera-follow cam entity 600 400))) + (ent (entity #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) (test-equal "original camera unchanged" 0 (camera-x cam)) (test-equal "centers camera x on entity" 100 (camera-x cam2)) (test-equal "centers camera y on entity" 100 (camera-y cam2))) (let* ((cam (make-camera x: 0 y: 0)) - (entity (list #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) - (cam2 (camera-follow cam entity 600 400))) + (ent (entity #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) (test-equal "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) (test-equal "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) (test-group "scene-find-tagged" - (let* ((p (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player))) - (e (list #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy npc))) + (let* ((p (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player))) + (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy npc))) (s (make-scene entities: (list p e) tilemap: #f camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) (test-equal "finds entity with matching tag" p (scene-find-tagged s 'player)) @@ -266,9 +271,9 @@ (test-equal "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) (test-group "scene-find-all-tagged" - (let* ((p1 (list #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player friendly))) - (p2 (list #:type 'ally #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(ally friendly))) - (e (list #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy))) + (let* ((p1 (entity #:type 'player #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(player friendly))) + (p2 (entity #:type 'ally #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(ally friendly))) + (e (entity #:type 'enemy #:x 0 #:y 0 #:width 16 #:height 16 #:tags '(enemy))) (s (make-scene entities: (list p1 p2 e) tilemap: #f camera: (make-camera x: 0 y: 0) tileset-texture: #f camera-target: #f))) (test-equal "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) @@ -276,12 +281,12 @@ (test-group "sync-groups" (let* ((gid 'g1) - (origin (list #:type 'group-origin #:group-origin? #t #:group-id gid - #:x 100 #:y 200 #:width 0 #:height 0)) - (m1 (list #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0 - #:x 0 #:y 0 #:width 8 #:height 8)) - (m2 (list #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7 - #:x 0 #:y 0 #:width 8 #:height 8)) + (origin (entity #:type 'group-origin #:group-origin? #t #:group-id gid + #:x 100 #:y 200 #:width 0 #:height 0)) + (m1 (entity #:type 'part #:group-id gid #:group-local-x 5 #:group-local-y 0 + #:x 0 #:y 0 #:width 8 #:height 8)) + (m2 (entity #:type 'part #:group-id gid #:group-local-x 0 #:group-local-y 7 + #:x 0 #:y 0 #:width 8 #:height 8)) (entities (list origin m1 m2)) (result (sync-groups entities))) (test-equal "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) @@ -291,8 +296,8 @@ (test-equal "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) (test-group "scene-transform-entities" - (let* ((e1 '(#:type a #:x 1)) - (e2 '(#:type b #:x 2)) + (let* ((e1 (entity #:type 'a #:x 1)) + (e2 (entity #:type 'b #:x 2)) (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) (scene2 (scene-transform-entities scene reverse))) (test-equal "transforms entity list" 'b |