diff options
| -rw-r--r-- | Makefile | 15 | ||||
| -rw-r--r-- | animation.scm | 150 | ||||
| -rw-r--r-- | assets.scm | 20 | ||||
| -rw-r--r-- | demo/assets/animation-prefabs.scm | 4 | ||||
| -rw-r--r-- | engine.scm | 486 | ||||
| -rw-r--r-- | entity.scm | 106 | ||||
| -rw-r--r-- | format.el | 50 | ||||
| -rw-r--r-- | input.scm | 362 | ||||
| -rw-r--r-- | mixer.scm | 62 | ||||
| -rw-r--r-- | physics.scm | 630 | ||||
| -rw-r--r-- | prefabs.scm | 442 | ||||
| -rw-r--r-- | renderer.scm | 508 | ||||
| -rw-r--r-- | scene-loader.scm | 170 | ||||
| -rw-r--r-- | sound.scm | 88 | ||||
| -rw-r--r-- | tests/animation-test.scm | 6 | ||||
| -rw-r--r-- | tests/assets-test.scm | 20 | ||||
| -rw-r--r-- | tests/engine-test.scm | 134 | ||||
| -rw-r--r-- | tests/entity-test.scm | 24 | ||||
| -rw-r--r-- | tests/input-test.scm | 34 | ||||
| -rw-r--r-- | tests/physics-test.scm | 20 | ||||
| -rw-r--r-- | tests/prefabs-test.scm | 202 | ||||
| -rw-r--r-- | tests/renderer-test.scm | 90 | ||||
| -rw-r--r-- | tests/scene-loader-test.scm | 18 | ||||
| -rw-r--r-- | tests/tilemap-test.scm | 8 | ||||
| -rw-r--r-- | tests/tween-test.scm | 30 | ||||
| -rw-r--r-- | tests/world-test.scm | 192 | ||||
| -rw-r--r-- | tilemap.scm | 428 | ||||
| -rw-r--r-- | tween.scm | 410 | ||||
| -rw-r--r-- | world.scm | 210 |
29 files changed, 2491 insertions, 2428 deletions
@@ -37,7 +37,20 @@ bin/%.o: %.scm | bin csc -c -J -unit downstroke.$* $*.scm -o bin/$*.o -I bin @if [ -f downstroke.$*.import.scm ]; then mv downstroke.$*.import.scm bin/; fi -.PHONY: clean test engine demos filter +.PHONY: clean test engine demos filter format + +# Reformat every tracked .scm file with Emacs `indent-region` under the user's +# real init (so geiser-chicken / scheme-mode rules apply consistently). +# Override EMACS_INIT_DIR / EMACS_SUBSTRATE_DIR if your config lives elsewhere. +EMACS_INIT_DIR ?= $(HOME)/.emacs-perso +EMACS_SUBSTRATE_DIR ?= $(EMACS_INIT_DIR)/emacs-substrate +format: + @emacs --batch \ + --init-directory=$(EMACS_INIT_DIR) \ + --eval "(add-to-list 'load-path \"$(EMACS_SUBSTRATE_DIR)/\")" \ + -l $(EMACS_INIT_DIR)/init.el \ + -l format.el \ + --eval "(downstroke-format-tracked-scm-files)" clean: rm -rf bin downstroke/ diff --git a/animation.scm b/animation.scm index 96718ec..1005868 100644 --- a/animation.scm +++ b/animation.scm @@ -1,92 +1,92 @@ (module (downstroke animation) * -(import scheme - (chicken base) - (only srfi-1 filter) - (downstroke entity) - (downstroke world)) + (import scheme + (chicken base) + (only srfi-1 filter) + (downstroke entity) + (downstroke world)) -;; 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. + ;; 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. -;; 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))) + ;; 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 (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)))) + (define (frame-by-idx frames frame-idx) + (list-ref frames (modulo frame-idx (length frames)))) -;; The tile ID is 1-indexed. -(define (frame->tile-id frames frame-idx) - (let ((frame-def (frame-by-idx frames frame-idx))) - (if (list? frame-def) - (car frame-def) - frame-def))) + ;; The tile ID is 1-indexed. + (define (frame->tile-id frames frame-idx) + (let ((frame-def (frame-by-idx frames frame-idx))) + (if (list? frame-def) + (car frame-def) + frame-def))) -(define (frame->duration frames frame-idx) - (let ((frame-def (frame-by-idx frames frame-idx))) - (if (list? frame-def) - (cadr frame-def) - 10))) + (define (frame->duration frames frame-idx) + (let ((frame-def (frame-by-idx frames frame-idx))) + (if (list? frame-def) + (cadr frame-def) + 10))) -;; ---- set-animation ---- -;; Switch to a new animation, resetting frame and tick counters. -;; No-op if the animation is already active (avoids restart mid-loop). + ;; ---- set-animation ---- + ;; Switch to a new animation, resetting frame and tick counters. + ;; No-op if the animation is already active (avoids restart mid-loop). -(define (set-animation entity name) - (if (eq? (entity-ref entity #:anim-name #f) name) - entity - (entity-set (entity-set (entity-set entity #:anim-name name) - #:anim-frame 0) - #:anim-tick 0))) + (define (set-animation entity name) + (if (eq? (entity-ref entity #:anim-name #f) name) + entity + (entity-set (entity-set (entity-set entity #:anim-name name) + #:anim-frame 0) + #:anim-tick 0))) -(define (animation-by-name animations name) - (let ((matching-anims - (filter (lambda (anim) (eq? (animation-ref anim #:name) name)) - animations))) - (if (pair? matching-anims) - (car matching-anims) - #f))) + (define (animation-by-name animations name) + (let ((matching-anims + (filter (lambda (anim) (eq? (animation-ref anim #:name) name)) + animations))) + (if (pair? matching-anims) + (car matching-anims) + #f))) -;; ---- animate-entity ---- -;; Advance the animation tick/frame counter for one game tick. -;; Pass the animation table for this entity's type. -;; Entities without #:anim-name are returned unchanged. + ;; ---- animate-entity ---- + ;; Advance the animation tick/frame counter for one game tick. + ;; Pass the animation table for this entity's type. + ;; Entities without #:anim-name are returned unchanged. -(define (advance-animation entity anim) - (let ((tick (+ 1 (entity-ref entity #:anim-tick 0))) - (duration (animation-duration anim)) - (frames (animation-frames anim)) - (frame (entity-ref entity #:anim-frame 0))) - (if (>= tick duration) - (let ((new-frame-id (modulo (+ frame 1) (length frames)))) + (define (advance-animation entity anim) + (let ((tick (+ 1 (entity-ref entity #:anim-tick 0))) + (duration (animation-duration anim)) + (frames (animation-frames anim)) + (frame (entity-ref entity #:anim-frame 0))) + (if (>= tick duration) + (let ((new-frame-id (modulo (+ frame 1) (length frames)))) + (entity-set-many entity + `((#: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 - `((#: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 - `((#:anim-tick . ,tick) - (#: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)) - (anim (and anim-name (animation-by-name animations anim-name)))) - (if anim - (advance-animation entity anim) - entity))) + (define (animate-entity entity animations) + (let* ((anim-name (entity-ref entity #:anim-name #f)) + (anim (and anim-name (animation-by-name animations anim-name)))) + (if anim + (advance-animation entity anim) + entity))) -(define-pipeline (apply-animation animation) (scene entity dt) - guard: (entity-ref entity #:animations #f) - (let ((animations (entity-ref entity #:animations #f))) - (animate-entity entity animations))) + (define-pipeline (apply-animation animation) (scene entity dt) + guard: (entity-ref entity #:animations #f) + (let ((animations (entity-ref entity #:animations #f))) + (animate-entity entity animations))) -) ;; End of animation module + ) ;; End of animation module @@ -1,16 +1,16 @@ (module (downstroke assets) * -(import scheme - (chicken base) - (srfi 69)) + (import scheme + (chicken base) + (srfi 69)) -(define (make-asset-registry) - (make-hash-table)) + (define (make-asset-registry) + (make-hash-table)) -(define (asset-set! registry key value) - (hash-table-set! registry key value)) + (define (asset-set! registry key value) + (hash-table-set! registry key value)) -(define (asset-ref registry key) - (hash-table-ref/default registry key #f)) + (define (asset-ref registry key) + (hash-table-ref/default registry key #f)) -) ;; end module + ) ;; end module diff --git a/demo/assets/animation-prefabs.scm b/demo/assets/animation-prefabs.scm index 20a4106..f965c81 100644 --- a/demo/assets/animation-prefabs.scm +++ b/demo/assets/animation-prefabs.scm @@ -1,6 +1,6 @@ ((mixins) (prefabs (timed-frames animated #:type timed-frames #:anim-name walk - #:animations ((#:name walk #:frames ((28 10) (29 1000))))) + #:animations ((#:name walk #:frames ((28 10) (29 1000))))) (std-frames animated #:type std-frames #:anim-name attack - #:animations ((#:name attack #:frames (28 29) #:duration 10))))) + #:animations ((#:name attack #:frames (28 29) #:duration 10))))) @@ -1,245 +1,245 @@ (module (downstroke engine) * -(import scheme - (chicken base) - (prefix sdl2 "sdl2:") - (prefix sdl2-ttf "ttf:") - (prefix sdl2-image "img:") - (srfi 69) - (only srfi-197 chain) - defstruct - (downstroke world) - (downstroke input) - (downstroke physics) - (downstroke tween) - (downstroke assets) - (downstroke animation) - (downstroke renderer)) - -;; ── Game struct ──────────────────────────────────────────────────────────── -;; defstruct auto-generates make-game, which we'll wrap with default values - -(defstruct game - title width height - scale ;; positive integer: whole-game pixel scaling factor - window renderer - input ;; input-state record - input-config ;; input-config record - assets ;; asset registry (hash-table from assets.scm) - frame-delay - preload-hook ;; (lambda (game) ...) - create-hook ;; (lambda (game) ...) - update-hook ;; (lambda (game dt) ...) - render-hook ;; (lambda (game) ...) — post-render overlay - scene ;; current scene struct; #f until create: runs - states ;; hash-table of name → state-plist - active-state ;; symbol or #f — currently active state name - debug?) ;; boolean: enable debug overlay drawing - -;; Store the auto-generated constructor as make-game* -(define make-game* make-game) - -;; ── Public constructor wrapper ───────────────────────────────────────────── -;; Wraps the auto-generated make-game (renamed to make-game*) with default values - -;; ── Default engine update ──────────────────────────────────────────────── -;; Standard physics pipeline: tweens → acceleration → gravity → velocity → -;; tile collisions → ground detection → entity collisions → group sync. -;; Runs automatically each frame unless overridden or disabled. - -(define (default-engine-update game dt) - (let ((scene (game-scene game))) - (when scene - (game-scene-set! - game - (chain scene - (scene-map-entities _ (cut step-tweens <> <> dt)) - (scene-map-entities _ (cut apply-acceleration <> <> dt)) - (scene-map-entities _ (cut apply-gravity <> <> dt)) - (scene-map-entities _ (cut apply-velocity-x <> <> dt)) - (scene-map-entities _ (cut resolve-tile-collisions-x <> <> dt)) - (scene-map-entities _ (cut apply-velocity-y <> <> dt)) - (scene-map-entities _ (cut resolve-tile-collisions-y <> <> dt)) - (scene-map-entities _ (cut detect-on-solid <> <> dt)) - (scene-transform-entities _ resolve-entity-collisions) - (scene-transform-entities _ sync-groups) - (scene-map-entities _ (cut apply-animation <> <> dt))))))) - -(define (make-game #!key - (title "Downstroke Game") - (width 640) (height 480) - (scale 1) - (frame-delay 16) - (input-config *default-input-config*) - (preload #f) (create #f) (update #f) (render #f) - (debug? #f)) - (unless (and (integer? scale) (positive? scale)) - (error "make-game: scale must be a positive integer" scale)) - (make-game* - title: title - width: width - height: height - scale: scale - window: #f - renderer: #f - scene: #f - input: (create-input-state input-config) - input-config: input-config - assets: (make-asset-registry) - frame-delay: frame-delay - preload-hook: preload - create-hook: create - update-hook: update - render-hook: render - states: (make-hash-table) - active-state: #f - debug?: debug?)) - -;; ── Convenience accessors ────────────────────────────────────────────────── - -;; game-camera: derived from the current scene (only valid after create: runs) -(define (game-camera game) - (scene-camera (game-scene game))) - -;; game-asset: retrieve an asset by key -(define (game-asset game key) - (asset-ref (game-assets game) key)) - -;; game-asset-set!: store an asset by key -(define (game-asset-set! game key value) - (asset-set! (game-assets game) key value)) - -;; ── Named scene states ──────────────────────────────────────────────────── - -;; Construct a state alist with lifecycle hooks. -(define (make-game-state #!key (create #f) (update #f) (render #f)) - `((#:create . ,create) (#:update . ,update) (#:render . ,render))) - -;; Retrieve a value from a state alist. -(define (state-hook state key) - (cond ((assq key state) => cdr) (else #f))) - -;; 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)) - -;; Transition to a named state. Calls the state's create: hook if present. -(define (game-start-state! game name) - (game-active-state-set! game name) - (let* ((state (hash-table-ref (game-states game) name)) - (create (state-hook state #:create))) - (when create (create game)))) - -;; Set renderer draw color for SDL_RenderClear (called every frame before clear). -(define (renderer-set-clear-color! renderer scene) - (let ((bg (and scene (scene-background scene)))) - (if (and (list? bg) (>= (length bg) 3)) - (let ((r (list-ref bg 0)) - (g (list-ref bg 1)) - (b (list-ref bg 2)) - (a (if (>= (length bg) 4) (list-ref bg 3) 255))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color 0 0 0 255))))) - -;; ── game-run! helpers ───────────────────────────────────────────────────── - -(define (collect-sdl-events) - (sdl2:pump-events!) - (let collect ((lst '())) - (if (not (sdl2:has-events?)) - (reverse lst) - (let ((e (sdl2:make-event))) - (sdl2:poll-event! e) - (collect (cons e lst)))))) - -(define (resolve-hooks game) - (let* ((active (game-active-state game)) - (state (and active - (hash-table-ref/default (game-states game) active #f)))) - (values (or (and state (state-hook state #:update)) (game-update-hook game)) - (or (and state (state-hook state #:render)) (game-render-hook game))))) - -(define (update-camera-follow scene game) - (let ((target-tag (and scene (scene-camera-target scene)))) - (if (not target-tag) - scene - (let ((target (scene-find-tagged scene target-tag))) - (if (not target) - scene - (update-scene scene - camera: (camera-follow (scene-camera scene) - target - (game-width game) - (game-height game)))))))) - -(define (game-render! game render-fn) - (renderer-set-clear-color! (game-renderer game) (game-scene game)) - (sdl2:render-clear! (game-renderer game)) - (when (game-scene game) - (render-scene! (game-renderer game) (game-scene game))) - (when (and (game-debug? game) (game-scene game)) - (render-debug-scene! (game-renderer game) (game-scene game))) - (when render-fn (render-fn game)) - (sdl2:render-present! (game-renderer game))) - -;; ── game-run! ────────────────────────────────────────────────────────────── - -(define (game-run! game) - (sdl2:set-main-ready!) - (sdl2:init! '(video joystick game-controller)) - (ttf:init!) - (img:init! '(png)) - - (let init-controllers ((i 0)) - (when (< i (sdl2:num-joysticks)) - (when (sdl2:is-game-controller? i) - (sdl2:game-controller-open! i)) - (init-controllers (+ i 1)))) - - (let ((scale (game-scale game))) - (game-window-set! game - (sdl2:create-window! (game-title game) 'centered 'centered - (* (game-width game) scale) - (* (game-height game) scale) '())) - (game-renderer-set! game - (sdl2:create-renderer! (game-window game) -1 '(accelerated))) - (when (> scale 1) - (sdl2:render-logical-size-set! - (game-renderer game) - (list (game-width game) (game-height game))))) - - (when (game-preload-hook game) ((game-preload-hook game) game)) - (when (game-create-hook game) ((game-create-hook game) game)) - - (let loop ((last-ticks (sdl2:get-ticks))) - (let* ((now (sdl2:get-ticks)) - (dt (- now last-ticks)) - (input (input-state-update (game-input game) (collect-sdl-events) - (game-input-config game)))) - (game-input-set! game input) - (unless (input-held? input 'quit) - (let ((scene (game-scene game))) - (when scene - (let ((eu (scene-engine-update scene))) - ;; engine-update dispatch: - ;; #f → run default-engine-update (implicit opt-in) - ;; 'none → run no engine update at all (explicit opt-out) - ;; <proc> → run the user procedure - (cond - ((eq? eu 'none)) - ((procedure? eu) (eu game dt)) - ((not eu) (default-engine-update game dt)) - (else - (error "engine-update must be #f, 'none, or a procedure" eu)))))) - (receive (update-fn render-fn) (resolve-hooks game) - (when update-fn (update-fn game dt)) - (when (game-scene game) - (game-scene-set! game (update-camera-follow (game-scene game) game))) - (game-render! game render-fn)) - (sdl2:delay! (game-frame-delay game)) - (loop now)))) - - (sdl2:destroy-window! (game-window game)) - (sdl2:quit!)) - -) ;; end module + (import scheme + (chicken base) + (prefix sdl2 "sdl2:") + (prefix sdl2-ttf "ttf:") + (prefix sdl2-image "img:") + (srfi 69) + (only srfi-197 chain) + defstruct + (downstroke world) + (downstroke input) + (downstroke physics) + (downstroke tween) + (downstroke assets) + (downstroke animation) + (downstroke renderer)) + + ;; ── Game struct ──────────────────────────────────────────────────────────── + ;; defstruct auto-generates make-game, which we'll wrap with default values + + (defstruct game + title width height + scale ;; positive integer: whole-game pixel scaling factor + window renderer + input ;; input-state record + input-config ;; input-config record + assets ;; asset registry (hash-table from assets.scm) + frame-delay + preload-hook ;; (lambda (game) ...) + create-hook ;; (lambda (game) ...) + update-hook ;; (lambda (game dt) ...) + render-hook ;; (lambda (game) ...) — post-render overlay + scene ;; current scene struct; #f until create: runs + states ;; hash-table of name → state-plist + active-state ;; symbol or #f — currently active state name + debug?) ;; boolean: enable debug overlay drawing + + ;; Store the auto-generated constructor as make-game* + (define make-game* make-game) + + ;; ── Public constructor wrapper ───────────────────────────────────────────── + ;; Wraps the auto-generated make-game (renamed to make-game*) with default values + + ;; ── Default engine update ──────────────────────────────────────────────── + ;; Standard physics pipeline: tweens → acceleration → gravity → velocity → + ;; tile collisions → ground detection → entity collisions → group sync. + ;; Runs automatically each frame unless overridden or disabled. + + (define (default-engine-update game dt) + (let ((scene (game-scene game))) + (when scene + (game-scene-set! + game + (chain scene + (scene-map-entities _ (cut step-tweens <> <> dt)) + (scene-map-entities _ (cut apply-acceleration <> <> dt)) + (scene-map-entities _ (cut apply-gravity <> <> dt)) + (scene-map-entities _ (cut apply-velocity-x <> <> dt)) + (scene-map-entities _ (cut resolve-tile-collisions-x <> <> dt)) + (scene-map-entities _ (cut apply-velocity-y <> <> dt)) + (scene-map-entities _ (cut resolve-tile-collisions-y <> <> dt)) + (scene-map-entities _ (cut detect-on-solid <> <> dt)) + (scene-transform-entities _ resolve-entity-collisions) + (scene-transform-entities _ sync-groups) + (scene-map-entities _ (cut apply-animation <> <> dt))))))) + + (define (make-game #!key + (title "Downstroke Game") + (width 640) (height 480) + (scale 1) + (frame-delay 16) + (input-config *default-input-config*) + (preload #f) (create #f) (update #f) (render #f) + (debug? #f)) + (unless (and (integer? scale) (positive? scale)) + (error "make-game: scale must be a positive integer" scale)) + (make-game* + title: title + width: width + height: height + scale: scale + window: #f + renderer: #f + scene: #f + input: (create-input-state input-config) + input-config: input-config + assets: (make-asset-registry) + frame-delay: frame-delay + preload-hook: preload + create-hook: create + update-hook: update + render-hook: render + states: (make-hash-table) + active-state: #f + debug?: debug?)) + + ;; ── Convenience accessors ────────────────────────────────────────────────── + + ;; game-camera: derived from the current scene (only valid after create: runs) + (define (game-camera game) + (scene-camera (game-scene game))) + + ;; game-asset: retrieve an asset by key + (define (game-asset game key) + (asset-ref (game-assets game) key)) + + ;; game-asset-set!: store an asset by key + (define (game-asset-set! game key value) + (asset-set! (game-assets game) key value)) + + ;; ── Named scene states ──────────────────────────────────────────────────── + + ;; Construct a state alist with lifecycle hooks. + (define (make-game-state #!key (create #f) (update #f) (render #f)) + `((#:create . ,create) (#:update . ,update) (#:render . ,render))) + + ;; Retrieve a value from a state alist. + (define (state-hook state key) + (cond ((assq key state) => cdr) (else #f))) + + ;; 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)) + + ;; Transition to a named state. Calls the state's create: hook if present. + (define (game-start-state! game name) + (game-active-state-set! game name) + (let* ((state (hash-table-ref (game-states game) name)) + (create (state-hook state #:create))) + (when create (create game)))) + + ;; Set renderer draw color for SDL_RenderClear (called every frame before clear). + (define (renderer-set-clear-color! renderer scene) + (let ((bg (and scene (scene-background scene)))) + (if (and (list? bg) (>= (length bg) 3)) + (let ((r (list-ref bg 0)) + (g (list-ref bg 1)) + (b (list-ref bg 2)) + (a (if (>= (length bg) 4) (list-ref bg 3) 255))) + (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a))) + (set! (sdl2:render-draw-color renderer) (sdl2:make-color 0 0 0 255))))) + + ;; ── game-run! helpers ───────────────────────────────────────────────────── + + (define (collect-sdl-events) + (sdl2:pump-events!) + (let collect ((lst '())) + (if (not (sdl2:has-events?)) + (reverse lst) + (let ((e (sdl2:make-event))) + (sdl2:poll-event! e) + (collect (cons e lst)))))) + + (define (resolve-hooks game) + (let* ((active (game-active-state game)) + (state (and active + (hash-table-ref/default (game-states game) active #f)))) + (values (or (and state (state-hook state #:update)) (game-update-hook game)) + (or (and state (state-hook state #:render)) (game-render-hook game))))) + + (define (update-camera-follow scene game) + (let ((target-tag (and scene (scene-camera-target scene)))) + (if (not target-tag) + scene + (let ((target (scene-find-tagged scene target-tag))) + (if (not target) + scene + (update-scene scene + camera: (camera-follow (scene-camera scene) + target + (game-width game) + (game-height game)))))))) + + (define (game-render! game render-fn) + (renderer-set-clear-color! (game-renderer game) (game-scene game)) + (sdl2:render-clear! (game-renderer game)) + (when (game-scene game) + (render-scene! (game-renderer game) (game-scene game))) + (when (and (game-debug? game) (game-scene game)) + (render-debug-scene! (game-renderer game) (game-scene game))) + (when render-fn (render-fn game)) + (sdl2:render-present! (game-renderer game))) + + ;; ── game-run! ────────────────────────────────────────────────────────────── + + (define (game-run! game) + (sdl2:set-main-ready!) + (sdl2:init! '(video joystick game-controller)) + (ttf:init!) + (img:init! '(png)) + + (let init-controllers ((i 0)) + (when (< i (sdl2:num-joysticks)) + (when (sdl2:is-game-controller? i) + (sdl2:game-controller-open! i)) + (init-controllers (+ i 1)))) + + (let ((scale (game-scale game))) + (game-window-set! game + (sdl2:create-window! (game-title game) 'centered 'centered + (* (game-width game) scale) + (* (game-height game) scale) '())) + (game-renderer-set! game + (sdl2:create-renderer! (game-window game) -1 '(accelerated))) + (when (> scale 1) + (sdl2:render-logical-size-set! + (game-renderer game) + (list (game-width game) (game-height game))))) + + (when (game-preload-hook game) ((game-preload-hook game) game)) + (when (game-create-hook game) ((game-create-hook game) game)) + + (let loop ((last-ticks (sdl2:get-ticks))) + (let* ((now (sdl2:get-ticks)) + (dt (- now last-ticks)) + (input (input-state-update (game-input game) (collect-sdl-events) + (game-input-config game)))) + (game-input-set! game input) + (unless (input-held? input 'quit) + (let ((scene (game-scene game))) + (when scene + (let ((eu (scene-engine-update scene))) + ;; engine-update dispatch: + ;; #f → run default-engine-update (implicit opt-in) + ;; 'none → run no engine update at all (explicit opt-out) + ;; <proc> → run the user procedure + (cond + ((eq? eu 'none)) + ((procedure? eu) (eu game dt)) + ((not eu) (default-engine-update game dt)) + (else + (error "engine-update must be #f, 'none, or a procedure" eu)))))) + (receive (update-fn render-fn) (resolve-hooks game) + (when update-fn (update-fn game dt)) + (when (game-scene game) + (game-scene-set! game (update-camera-follow (game-scene game) game))) + (game-render! game render-fn)) + (sdl2:delay! (game-frame-delay game)) + (loop now)))) + + (sdl2:destroy-window! (game-window game)) + (sdl2:quit!)) + + ) ;; end module @@ -1,54 +1,54 @@ (module (downstroke entity) -* -(import scheme - (chicken base) - (only srfi-1 fold alist-delete)) - -;; Entities = alists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). - -(define (make-entity x y w h) - `((#:type . none) (#:x . ,x) (#:y . ,y) (#:width . ,w) (#:height . ,h))) - -(define (entity-ref entity key #!optional 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) - (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) (cdr pair))) - entity - pairs)) - -(define (entity-update entity key proc #!optional default) - (entity-set entity key (proc (entity-ref entity key default)))) - -;; #:skip-pipelines — list of symbols naming frame pipeline steps to skip for this -;; entity. Physics documents the built-in step names (see docs/physics.org). Other -;; subsystems (e.g. animation, rendering) may reserve additional symbols later and -;; use the same predicate and define-pipeline macro. - -(define (entity-skips-pipeline? entity step) - (let ((skips (entity-ref entity #:skip-pipelines '()))) - (and (pair? skips) (memq step skips)))) - -(define-syntax define-pipeline - (syntax-rules () - ((define-pipeline (identifier name) (scene entity dt) :guard guard (body ...)) - (define (identifier scene entity dt) - (if (or (not guard) (entity-skips-pipeline? entity (quote name))) - entity - (body ...)))) - ((define-pipeline (identifier name) (scene entity dt) (body ...)) - (define (identifier scene entity dt) - (if (entity-skips-pipeline? entity (quote name)) - entity - (body ...)))))) - -) ;; End of entity + * + (import scheme + (chicken base) + (only srfi-1 fold alist-delete)) + + ;; Entities = alists with shared keys (#:type, #:x, #:y, #:width, #:height, ...). + + (define (make-entity x y w h) + `((#:type . none) (#:x . ,x) (#:y . ,y) (#:width . ,w) (#:height . ,h))) + + (define (entity-ref entity key #!optional 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) + (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) (cdr pair))) + entity + pairs)) + + (define (entity-update entity key proc #!optional default) + (entity-set entity key (proc (entity-ref entity key default)))) + + ;; #:skip-pipelines — list of symbols naming frame pipeline steps to skip for this + ;; entity. Physics documents the built-in step names (see docs/physics.org). Other + ;; subsystems (e.g. animation, rendering) may reserve additional symbols later and + ;; use the same predicate and define-pipeline macro. + + (define (entity-skips-pipeline? entity step) + (let ((skips (entity-ref entity #:skip-pipelines '()))) + (and (pair? skips) (memq step skips)))) + + (define-syntax define-pipeline + (syntax-rules () + ((define-pipeline (identifier name) (scene entity dt) :guard guard (body ...)) + (define (identifier scene entity dt) + (if (or (not guard) (entity-skips-pipeline? entity (quote name))) + entity + (body ...)))) + ((define-pipeline (identifier name) (scene entity dt) (body ...)) + (define (identifier scene entity dt) + (if (entity-skips-pipeline? entity (quote name)) + entity + (body ...)))))) + + ) ;; End of entity diff --git a/format.el b/format.el new file mode 100644 index 0000000..48c2df6 --- /dev/null +++ b/format.el @@ -0,0 +1,50 @@ +;;; format.el — batch scheme formatter for downstroke. +;;; +;;; Reformats every tracked .scm file using `indent-region` under +;;; `scheme-mode`, with the user's full Emacs init loaded so the indent +;;; rules match exactly what interactive Emacs does (notably the +;;; geiser-chicken / scheme-mode `module` indent). +;;; +;;; Usage (from the Makefile): +;;; make format +;;; +;;; Or directly: +;;; emacs --batch \ +;;; --init-directory=$HOME/.emacs-perso \ +;;; --eval "(add-to-list 'load-path (expand-file-name \"emacs-substrate/\" \"~/.emacs-perso\"))" \ +;;; -l ~/.emacs-perso/init.el \ +;;; -l format.el \ +;;; --eval "(downstroke-format-tracked-scm-files)" + +(require 'subr-x) + +(defun downstroke--project-root () + "Directory containing this script — the downstroke project root." + (file-name-directory (or load-file-name buffer-file-name default-directory))) + +(defun downstroke--tracked-scm-files () + "Return a list of all .scm files tracked by git in the project." + (let ((default-directory (downstroke--project-root))) + (split-string + (string-trim + (shell-command-to-string "git ls-files -- '*.scm'")) + "\n" t))) + +(defun downstroke-format-file (path) + "Reformat a single .scm file with `indent-region'." + (let ((inhibit-message t)) + (find-file path) + (scheme-mode) + (indent-region (point-min) (point-max)) + (save-buffer) + (kill-buffer))) + +(defun downstroke-format-tracked-scm-files () + "Reformat every tracked .scm file in the project." + (let ((default-directory (downstroke--project-root)) + (files (downstroke--tracked-scm-files))) + (message "downstroke-format: reindenting %d files" (length files)) + (dolist (p files) + (message "indent: %s" p) + (downstroke-format-file p)) + (message "downstroke-format: done"))) @@ -1,182 +1,182 @@ (module (downstroke 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 - (downstroke 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 (compute-input-delta input-map held?) - (fold (lambda (entry acc) - (if (held? (car entry)) - (cons (+ (car acc) (cadr entry)) - (+ (cdr acc) (cddr entry))) - acc)) - '(0 . 0) - input-map)) - -(define (apply-input-to-entity entity held?) - (let ((input-map (entity-ref entity #:input-map #f))) - (if (not input-map) - entity - (let* ((delta (compute-input-delta input-map held?)) - (vx (* (entity-ref entity #:move-speed 1) (car delta)))) - (set-facing-from-vx (entity-set entity #:vx vx) vx))))) - -) ;; end module + * + + (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 + (downstroke 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 (compute-input-delta input-map held?) + (fold (lambda (entry acc) + (if (held? (car entry)) + (cons (+ (car acc) (cadr entry)) + (+ (cdr acc) (cddr entry))) + acc)) + '(0 . 0) + input-map)) + + (define (apply-input-to-entity entity held?) + (let ((input-map (entity-ref entity #:input-map #f))) + (if (not input-map) + entity + (let* ((delta (compute-input-delta input-map held?)) + (vx (* (entity-ref entity #:move-speed 1) (car delta)))) + (set-facing-from-vx (entity-set entity #:vx vx) vx))))) + + ) ;; end module @@ -1,46 +1,46 @@ (module (downstroke mixer) * -(import scheme - (chicken base) - (chicken foreign)) + (import scheme + (chicken base) + (chicken foreign)) -#> #include "SDL2/SDL_mixer.h" <# + #> #include "SDL2/SDL_mixer.h" <# -(define-foreign-type mix-chunk* (c-pointer "Mix_Chunk")) + (define-foreign-type mix-chunk* (c-pointer "Mix_Chunk")) -(define mix-open-audio! - (foreign-lambda int "Mix_OpenAudio" int unsigned-short int int)) + (define mix-open-audio! + (foreign-lambda int "Mix_OpenAudio" int unsigned-short int int)) -(define mix-close-audio! - (foreign-lambda void "Mix_CloseAudio")) + (define mix-close-audio! + (foreign-lambda void "Mix_CloseAudio")) -(define mix-load-chunk - (foreign-lambda* mix-chunk* ((c-string path)) - "C_return(Mix_LoadWAV(path));")) + (define mix-load-chunk + (foreign-lambda* mix-chunk* ((c-string path)) + "C_return(Mix_LoadWAV(path));")) -(define mix-free-chunk! - (foreign-lambda void "Mix_FreeChunk" mix-chunk*)) + (define mix-free-chunk! + (foreign-lambda void "Mix_FreeChunk" mix-chunk*)) -(define mix-play-channel - (foreign-lambda int "Mix_PlayChannel" int mix-chunk* int)) + (define mix-play-channel + (foreign-lambda int "Mix_PlayChannel" int mix-chunk* int)) -(define mix-default-format - ((foreign-lambda* unsigned-short () - "C_return(MIX_DEFAULT_FORMAT);"))) + (define mix-default-format + ((foreign-lambda* unsigned-short () + "C_return(MIX_DEFAULT_FORMAT);"))) -(define-foreign-type mix-music* (c-pointer "Mix_Music")) + (define-foreign-type mix-music* (c-pointer "Mix_Music")) -(define mix-load-mus - (foreign-lambda mix-music* "Mix_LoadMUS" c-string)) + (define mix-load-mus + (foreign-lambda mix-music* "Mix_LoadMUS" c-string)) -(define mix-play-music - (foreign-lambda int "Mix_PlayMusic" mix-music* int)) + (define mix-play-music + (foreign-lambda int "Mix_PlayMusic" mix-music* int)) -(define mix-free-music! - (foreign-lambda void "Mix_FreeMusic" mix-music*)) + (define mix-free-music! + (foreign-lambda void "Mix_FreeMusic" mix-music*)) -(define mix-halt-music - (foreign-lambda int "Mix_HaltMusic")) + (define mix-halt-music + (foreign-lambda int "Mix_HaltMusic")) -(define mix-volume-music - (foreign-lambda int "Mix_VolumeMusic" int)) -) + (define mix-volume-music + (foreign-lambda int "Mix_VolumeMusic" int)) + ) diff --git a/physics.scm b/physics.scm index 92e50dc..dafb112 100644 --- a/physics.scm +++ b/physics.scm @@ -1,317 +1,317 @@ (module (downstroke physics) -(resolve-entity-collisions - resolve-pair - aabb-overlap? push-apart push-along-axis aabb-overlap-on-axis - entity-center-on-axis push-entity axis->velocity axis->dimension - index-pairs list-set detect-on-solid - resolve-tile-collisions-y resolve-tile-collisions-x resolve-tile-collisions-axis - tile-push-pos entity-tile-cells pixel->tile build-cell-list - apply-velocity apply-velocity-y apply-velocity-x apply-gravity apply-acceleration - *jump-force* *gravity*) - -(import scheme - (chicken base) - (chicken keyword) - (only srfi-1 any fold iota) - defstruct - (downstroke tilemap) - (downstroke entity) - (downstroke 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) - -;; Feet may be this far (pixels) from another solid's top and count as standing on it. -(define *entity-ground-contact-tolerance* 5) -;; If |vy| is above this, another entity does not count as ground (mid-air / fast fall). -(define *entity-ground-vy-max* 12) - -;; Per-entity steps use define-pipeline from (downstroke entity) (see docs/physics.org -;; for #:skip-pipelines symbol names). - -;; Consume #:ay into #:vy and clear it (one-shot acceleration) -(define-pipeline (apply-acceleration acceleration) (scene entity dt) - guard: (entity-ref entity #:gravity? #f) - (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-pipeline (apply-gravity gravity) (scene entity dt) - guard: (entity-ref entity #:gravity? #f) - (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*))) - -;; Update entity's x by its vx velocity -(define-pipeline (apply-velocity-x velocity-x) (scene entity dt) - (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-pipeline (apply-velocity-y velocity-y) (scene entity dt) - (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)) - (e (if (downstroke.entity#entity-skips-pipeline? entity 'velocity-x) + (resolve-entity-collisions + resolve-pair + aabb-overlap? push-apart push-along-axis aabb-overlap-on-axis + entity-center-on-axis push-entity axis->velocity axis->dimension + index-pairs list-set detect-on-solid + resolve-tile-collisions-y resolve-tile-collisions-x resolve-tile-collisions-axis + tile-push-pos entity-tile-cells pixel->tile build-cell-list + apply-velocity apply-velocity-y apply-velocity-x apply-gravity apply-acceleration + *jump-force* *gravity*) + + (import scheme + (chicken base) + (chicken keyword) + (only srfi-1 any fold iota) + defstruct + (downstroke tilemap) + (downstroke entity) + (downstroke 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) + + ;; Feet may be this far (pixels) from another solid's top and count as standing on it. + (define *entity-ground-contact-tolerance* 5) + ;; If |vy| is above this, another entity does not count as ground (mid-air / fast fall). + (define *entity-ground-vy-max* 12) + + ;; Per-entity steps use define-pipeline from (downstroke entity) (see docs/physics.org + ;; for #:skip-pipelines symbol names). + + ;; Consume #:ay into #:vy and clear it (one-shot acceleration) + (define-pipeline (apply-acceleration acceleration) (scene entity dt) + guard: (entity-ref entity #:gravity? #f) + (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-pipeline (apply-gravity gravity) (scene entity dt) + guard: (entity-ref entity #:gravity? #f) + (entity-set entity #:vy (+ (entity-ref entity #:vy) *gravity*))) + + ;; Update entity's x by its vx velocity + (define-pipeline (apply-velocity-x velocity-x) (scene entity dt) + (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-pipeline (apply-velocity-y velocity-y) (scene entity dt) + (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)) + (e (if (downstroke.entity#entity-skips-pipeline? entity 'velocity-x) + entity + (entity-set entity #:x (+ x vx)))) + (e (if (downstroke.entity#entity-skips-pipeline? entity 'velocity-y) + e + (entity-set e #:y (+ (entity-ref e #:y 0) vy))))) + e)) + + ;; 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 + ;; For v>0 (moving right/down): snap to the FIRST solid cell (shallowest penetration). + ;; For v<0 (moving left/up): snap to the LAST solid cell (deepest penetration from above/left). + (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 + (if (and (> v 0) (zero? (entity-ref acc vel-key v))) + acc ; v>0: first collision already resolved, don't overwrite + (entity-set (entity-set acc pos-key (push-fn v col row)) vel-key 0))))) entity - (entity-set entity #:x (+ x vx)))) - (e (if (downstroke.entity#entity-skips-pipeline? entity 'velocity-y) - e - (entity-set e #:y (+ (entity-ref e #:y 0) vy))))) - e)) - -;; 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 -;; For v>0 (moving right/down): snap to the FIRST solid cell (shallowest penetration). -;; For v<0 (moving left/up): snap to the LAST solid cell (deepest penetration from above/left). -(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 - (if (and (> v 0) (zero? (entity-ref acc vel-key v))) - acc ; v>0: first collision already resolved, don't overwrite - (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-pipeline (resolve-tile-collisions-x tile-collisions-x) (scene entity dt) - guard: (scene-tilemap scene) - (let* ((tilemap (scene-tilemap scene)) - (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-pipeline (resolve-tile-collisions-y tile-collisions-y) (scene entity dt) - guard: (scene-tilemap scene) - (let* ((tilemap (scene-tilemap scene)) - (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))))) - -;; True if ~self~ is supported by another solid's top surface (moving platforms, crates, …). -(define (entity-solid-support-below? self others) - (let* ((bx (entity-ref self #:x 0)) - (bw (entity-ref self #:width 0)) - (by (entity-ref self #:y 0)) - (bh (entity-ref self #:height 0)) - (bottom (+ by bh)) - (vy (abs (entity-ref self #:vy 0)))) - (and (<= vy *entity-ground-vy-max*) - (any (lambda (o) - (and (not (eq? self o)) - (entity-ref o #:solid? #f) - (let* ((ox (entity-ref o #:x 0)) - (oy (entity-ref o #:y 0)) - (ow (entity-ref o #:width 0))) - (and (< bx (+ ox ow)) - (< ox (+ bx bw)) - (<= (abs (- bottom oy)) *entity-ground-contact-tolerance*))))) - others)))) - -(define (tile-ground-below? entity tilemap) - (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))) - (or (not (zero? (tilemap-tile-at tilemap col-left row))) - (not (zero? (tilemap-tile-at tilemap col-right row)))))) - -(define-pipeline (detect-on-solid on-solid) (scene entity dt) - guard: (entity-ref entity #:gravity? #f) - (let* ((tilemap (scene-tilemap scene)) - (on-tile? (and tilemap (tile-ground-below? entity tilemap))) - (on-entity? (entity-solid-support-below? entity (scene-entities scene)))) - (entity-set entity #:on-ground? (or on-tile? on-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)))) - -;; Move ~m~ out of ~s~ along the shallow penetration axis; ~s~ is unchanged. -;; Used when ~s~ has #:immovable? #t. -;; -;; When ~m~ is falling onto ~s~ from above, the minimum-penetration axis can be -;; horizontal (narrow overlap in X but deeper in Y), which shoves the mover -;; sideways instead of resting it on the platform. Prefer vertical separation -;; whenever ~m~'s center is still above ~s~'s center (landing contact). -(define (push-movable-along-axis m s axis overlap) - (let* ((mc (entity-center-on-axis m axis)) - (sc (entity-center-on-axis s axis)) - (dir (if (< mc sc) -1 1)) - (pos (entity-ref m axis 0)) - (vel (axis->velocity axis))) - (entity-set (entity-set m axis (+ pos (* dir overlap))) vel 0))) - -(define (separate-movable-from-static m s) - (let* ((ovx (aabb-overlap-on-axis #:x m s)) - (ovy (aabb-overlap-on-axis #:y m s)) - (land-on-top? (and (< (entity-center-on-axis m #:y) - (entity-center-on-axis s #:y)) - (> ovy 0)))) - (cond - (land-on-top? (push-movable-along-axis m s #:y ovy)) - ((<= ovx ovy) (push-movable-along-axis m s #:x ovx)) - (else (push-movable-along-axis m s #:y 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. -;; #:immovable? #t marks static geometry; only the other entity is displaced. -(define (resolve-pair a b) - (and (not (downstroke.entity#entity-skips-pipeline? a 'entity-collisions)) - (not (downstroke.entity#entity-skips-pipeline? b 'entity-collisions)) - (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)) - (let ((ia (entity-ref a #:immovable? #f)) - (ib (entity-ref b #:immovable? #f))) - (cond - ((and ia ib) #f) - (ia (let ((b2 (separate-movable-from-static b a))) - (and b2 (cons a b2)))) - (ib (let ((a2 (separate-movable-from-static a b))) - (and a2 (cons a2 b)))) - (else (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)))) - -) + (entity-tile-cells entity tilemap))))) + + ;; Resolve horizontal collisions with solid tiles + (define-pipeline (resolve-tile-collisions-x tile-collisions-x) (scene entity dt) + guard: (scene-tilemap scene) + (let* ((tilemap (scene-tilemap scene)) + (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-pipeline (resolve-tile-collisions-y tile-collisions-y) (scene entity dt) + guard: (scene-tilemap scene) + (let* ((tilemap (scene-tilemap scene)) + (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))))) + + ;; True if ~self~ is supported by another solid's top surface (moving platforms, crates, …). + (define (entity-solid-support-below? self others) + (let* ((bx (entity-ref self #:x 0)) + (bw (entity-ref self #:width 0)) + (by (entity-ref self #:y 0)) + (bh (entity-ref self #:height 0)) + (bottom (+ by bh)) + (vy (abs (entity-ref self #:vy 0)))) + (and (<= vy *entity-ground-vy-max*) + (any (lambda (o) + (and (not (eq? self o)) + (entity-ref o #:solid? #f) + (let* ((ox (entity-ref o #:x 0)) + (oy (entity-ref o #:y 0)) + (ow (entity-ref o #:width 0))) + (and (< bx (+ ox ow)) + (< ox (+ bx bw)) + (<= (abs (- bottom oy)) *entity-ground-contact-tolerance*))))) + others)))) + + (define (tile-ground-below? entity tilemap) + (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))) + (or (not (zero? (tilemap-tile-at tilemap col-left row))) + (not (zero? (tilemap-tile-at tilemap col-right row)))))) + + (define-pipeline (detect-on-solid on-solid) (scene entity dt) + guard: (entity-ref entity #:gravity? #f) + (let* ((tilemap (scene-tilemap scene)) + (on-tile? (and tilemap (tile-ground-below? entity tilemap))) + (on-entity? (entity-solid-support-below? entity (scene-entities scene)))) + (entity-set entity #:on-ground? (or on-tile? on-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)))) + + ;; Move ~m~ out of ~s~ along the shallow penetration axis; ~s~ is unchanged. + ;; Used when ~s~ has #:immovable? #t. + ;; + ;; When ~m~ is falling onto ~s~ from above, the minimum-penetration axis can be + ;; horizontal (narrow overlap in X but deeper in Y), which shoves the mover + ;; sideways instead of resting it on the platform. Prefer vertical separation + ;; whenever ~m~'s center is still above ~s~'s center (landing contact). + (define (push-movable-along-axis m s axis overlap) + (let* ((mc (entity-center-on-axis m axis)) + (sc (entity-center-on-axis s axis)) + (dir (if (< mc sc) -1 1)) + (pos (entity-ref m axis 0)) + (vel (axis->velocity axis))) + (entity-set (entity-set m axis (+ pos (* dir overlap))) vel 0))) + + (define (separate-movable-from-static m s) + (let* ((ovx (aabb-overlap-on-axis #:x m s)) + (ovy (aabb-overlap-on-axis #:y m s)) + (land-on-top? (and (< (entity-center-on-axis m #:y) + (entity-center-on-axis s #:y)) + (> ovy 0)))) + (cond + (land-on-top? (push-movable-along-axis m s #:y ovy)) + ((<= ovx ovy) (push-movable-along-axis m s #:x ovx)) + (else (push-movable-along-axis m s #:y 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. + ;; #:immovable? #t marks static geometry; only the other entity is displaced. + (define (resolve-pair a b) + (and (not (downstroke.entity#entity-skips-pipeline? a 'entity-collisions)) + (not (downstroke.entity#entity-skips-pipeline? b 'entity-collisions)) + (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)) + (let ((ia (entity-ref a #:immovable? #f)) + (ib (entity-ref b #:immovable? #f))) + (cond + ((and ia ib) #f) + (ia (let ((b2 (separate-movable-from-static b a))) + (and b2 (cons a b2)))) + (ib (let ((a2 (separate-movable-from-static a b))) + (and a2 (cons a2 b)))) + (else (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)))) + + ) diff --git a/prefabs.scm b/prefabs.scm index ac9d5d0..35c8180 100644 --- a/prefabs.scm +++ b/prefabs.scm @@ -1,222 +1,222 @@ (module (downstroke prefabs) * -(import scheme - (chicken base) - (only (chicken keyword) keyword?) - srfi-1 - (only (list-utils alist) plist->alist) - defstruct - (downstroke entity)) - -;; Registry struct to hold prefab data -(defstruct prefab-registry - prefabs group-prefabs file engine-mixin-table user-hooks hook-table) - -;; 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) - '((physics-body #:vx 0 #:vy 0 #:ay 0 #:gravity? #t #:solid? #t #:on-ground? #f) - (has-facing #:facing 1) - (animated #:anim-name idle #:anim-frame 0 #:anim-tick 0 #:tile-id 0 #:animations #t))) - -;; 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)) - (split (let loop ((lst rest) (mixins '())) - (if (or (null? lst) (keyword? (car lst))) - (cons (reverse mixins) lst) - (loop (cdr lst) (cons (car lst) mixins))))) - (mixin-names (car split)) - (inline-fields (cdr split)) - (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-alist first → highest priority (earlier-wins) - (merged (apply alist-merge (cons inline-alist mixin-alists)))) - (cons name merged))) - -(define *engine-hooks* '()) - -;; Lookup a hook symbol in the hook table -(define (lookup-hook hook-table hook-sym) - (let ((entry (assq hook-sym hook-table))) - (if entry - (cdr entry) - (error "Unknown prefab hook" hook-sym)))) - -;; 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+ - '((#: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+ - '((#: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+ - '((#: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) - (p (if (entity-ref p #:group-local-x #f) p - (entity-set p #:group-local-x (entity-ref p #:local-x 0)))) - (p (if (entity-ref p #:group-local-y #f) p - (entity-set p #:group-local-y (entity-ref p #:local-y 0))))) - p)) - -(define (load-prefabs file engine-mixin-table user-hooks) - (let* ((data (with-input-from-file file read)) - (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 - (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) - (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 - file: file - engine-mixin-table: engine-mixin-table - user-hooks: user-hooks - hook-table: hook-table))) - -(define (reload-prefabs! registry) - (load-prefabs (prefab-registry-file registry) - (prefab-registry-engine-mixin-table registry) - (prefab-registry-user-hooks registry))) - -(define (do-instantiate-prefab registry entry x y w h) - (let* ((base (entity-set-many (make-entity x y w h) (cdr entry))) - (hook-val (entity-ref base #:on-instantiate #f)) - (handler - (cond - ((procedure? hook-val) hook-val) - ((symbol? hook-val) - (lookup-hook (prefab-registry-hook-table registry) hook-val)) - (else #f)))) - (if handler (handler base) base))) - - -(define (instantiate-prefab registry type x y w h) - (if (not registry) - #f - (let ((entry (assq type (prefab-registry-prefabs registry)))) - (if (not entry) - #f - (do-instantiate-prefab registry entry x y w h))))) - -(define (instantiate-group-member part ox oy gid type-members static-parts?) - (let* ((p0 (part-with-group-locals part)) - (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)) - (with-type (entity-set merged #:type typ)) - (g1 (entity-set with-type #:group-id gid)) - (g2 (entity-set g1 #:group-local-x lx)) - (g3 (entity-set g2 #:group-local-y ly)) - (g4 (entity-set g3 #:x (+ ox lx)))) - (entity-set g4 #:y (+ oy ly)))) - -;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y. -;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id. -(define (instantiate-group-prefab registry type ox oy) - (if (not registry) - #f - (let ((entry (assq type (prefab-registry-group-prefabs registry)))) - (if (not entry) - #f - (let* ((spec (cdr entry)) - (gid (gensym (symbol->string type))) - (parts (entity-ref spec #:parts '())) - (type-members (entity-ref spec #:type-members 'group-part)) - (pose-only? (entity-ref spec #:pose-only-origin? #f)) - (static-parts? (entity-ref spec #:static-parts? #f)) - (ow (entity-ref spec #:origin-width 0)) - (oh (entity-ref spec #:origin-height 0)) - (ot (entity-ref spec #:origin-type 'group-origin)) - (origin-fields - (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+))) - (origin origin-fields) - (members - (map (lambda (part) - (instantiate-group-member - part ox oy gid type-members static-parts?)) - parts))) - (cons origin members))))))) + (import scheme + (chicken base) + (only (chicken keyword) keyword?) + srfi-1 + (only (list-utils alist) plist->alist) + defstruct + (downstroke entity)) + + ;; Registry struct to hold prefab data + (defstruct prefab-registry + prefabs group-prefabs file engine-mixin-table user-hooks hook-table) + + ;; 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) + '((physics-body #:vx 0 #:vy 0 #:ay 0 #:gravity? #t #:solid? #t #:on-ground? #f) + (has-facing #:facing 1) + (animated #:anim-name idle #:anim-frame 0 #:anim-tick 0 #:tile-id 0 #:animations #t))) + + ;; 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)) + (split (let loop ((lst rest) (mixins '())) + (if (or (null? lst) (keyword? (car lst))) + (cons (reverse mixins) lst) + (loop (cdr lst) (cons (car lst) mixins))))) + (mixin-names (car split)) + (inline-fields (cdr split)) + (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-alist first → highest priority (earlier-wins) + (merged (apply alist-merge (cons inline-alist mixin-alists)))) + (cons name merged))) + + (define *engine-hooks* '()) + + ;; Lookup a hook symbol in the hook table + (define (lookup-hook hook-table hook-sym) + (let ((entry (assq hook-sym hook-table))) + (if entry + (cdr entry) + (error "Unknown prefab hook" hook-sym)))) + + ;; 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+ + '((#: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+ + '((#: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+ + '((#: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) + (p (if (entity-ref p #:group-local-x #f) p + (entity-set p #:group-local-x (entity-ref p #:local-x 0)))) + (p (if (entity-ref p #:group-local-y #f) p + (entity-set p #:group-local-y (entity-ref p #:local-y 0))))) + p)) + + (define (load-prefabs file engine-mixin-table user-hooks) + (let* ((data (with-input-from-file file read)) + (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 + (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) + (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 + file: file + engine-mixin-table: engine-mixin-table + user-hooks: user-hooks + hook-table: hook-table))) + + (define (reload-prefabs! registry) + (load-prefabs (prefab-registry-file registry) + (prefab-registry-engine-mixin-table registry) + (prefab-registry-user-hooks registry))) + + (define (do-instantiate-prefab registry entry x y w h) + (let* ((base (entity-set-many (make-entity x y w h) (cdr entry))) + (hook-val (entity-ref base #:on-instantiate #f)) + (handler + (cond + ((procedure? hook-val) hook-val) + ((symbol? hook-val) + (lookup-hook (prefab-registry-hook-table registry) hook-val)) + (else #f)))) + (if handler (handler base) base))) + + + (define (instantiate-prefab registry type x y w h) + (if (not registry) + #f + (let ((entry (assq type (prefab-registry-prefabs registry)))) + (if (not entry) + #f + (do-instantiate-prefab registry entry x y w h))))) + + (define (instantiate-group-member part ox oy gid type-members static-parts?) + (let* ((p0 (part-with-group-locals part)) + (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)) + (with-type (entity-set merged #:type typ)) + (g1 (entity-set with-type #:group-id gid)) + (g2 (entity-set g1 #:group-local-x lx)) + (g3 (entity-set g2 #:group-local-y ly)) + (g4 (entity-set g3 #:x (+ ox lx)))) + (entity-set g4 #:y (+ oy ly)))) + + ;; Instantiate a group prefab: one origin entity (pose) + members with #:group-local-x/y. + ;; Returns (origin member ...) or #f. Each instance gets a fresh gensym #:group-id. + (define (instantiate-group-prefab registry type ox oy) + (if (not registry) + #f + (let ((entry (assq type (prefab-registry-group-prefabs registry)))) + (if (not entry) + #f + (let* ((spec (cdr entry)) + (gid (gensym (symbol->string type))) + (parts (entity-ref spec #:parts '())) + (type-members (entity-ref spec #:type-members 'group-part)) + (pose-only? (entity-ref spec #:pose-only-origin? #f)) + (static-parts? (entity-ref spec #:static-parts? #f)) + (ow (entity-ref spec #:origin-width 0)) + (oh (entity-ref spec #:origin-height 0)) + (ot (entity-ref spec #:origin-type 'group-origin)) + (origin-fields + (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+))) + (origin origin-fields) + (members + (map (lambda (part) + (instantiate-group-member + part ox oy gid type-members static-parts?)) + parts))) + (cons origin members))))))) diff --git a/renderer.scm b/renderer.scm index 2683442..6efc1ec 100644 --- a/renderer.scm +++ b/renderer.scm @@ -1,256 +1,256 @@ (module (downstroke renderer) -* -(import scheme - (chicken base) - (only srfi-1 iota for-each) - srfi-69 - (prefix sdl2 "sdl2:") - (prefix sdl2-ttf "ttf:") - (downstroke entity) - (downstroke tilemap) - (downstroke world)) - -(import defstruct) - -;; --- Debug colors --- - -(define +debug-player-color+ (sdl2:make-color 64 128 255)) -(define +debug-enemy-color+ (sdl2:make-color 220 40 40)) -(define +debug-attack-color+ (sdl2:make-color 0 200 80)) -(define +debug-tile-color+ (sdl2:make-color 140 0 220)) - -;; --- Sprite font data structure --- - -(defstruct sprite-font - tile-size ;; integer: pixel width/height of each glyph tile - spacing ;; integer: pixels between characters - char-map) ;; hash-table: char -> tile-id - -;; Public constructor for sprite-font -;; ranges: list of (start-char end-char first-tile-id) triples -(define (make-sprite-font* #!key tile-size (spacing 1) ranges) - (let ((ht (make-hash-table))) + * + (import scheme + (chicken base) + (only srfi-1 iota for-each) + srfi-69 + (prefix sdl2 "sdl2:") + (prefix sdl2-ttf "ttf:") + (downstroke entity) + (downstroke tilemap) + (downstroke world)) + + (import defstruct) + + ;; --- Debug colors --- + + (define +debug-player-color+ (sdl2:make-color 64 128 255)) + (define +debug-enemy-color+ (sdl2:make-color 220 40 40)) + (define +debug-attack-color+ (sdl2:make-color 0 200 80)) + (define +debug-tile-color+ (sdl2:make-color 140 0 220)) + + ;; --- Sprite font data structure --- + + (defstruct sprite-font + tile-size ;; integer: pixel width/height of each glyph tile + spacing ;; integer: pixels between characters + char-map) ;; hash-table: char -> tile-id + + ;; Public constructor for sprite-font + ;; ranges: list of (start-char end-char first-tile-id) triples + (define (make-sprite-font* #!key tile-size (spacing 1) ranges) + (let ((ht (make-hash-table))) + (for-each + (lambda (range) + (let ((start-char (car range)) + (end-char (cadr range)) + (first-tile-id (caddr range))) + (let loop ((ch start-char) (tile-id first-tile-id)) + (when (char<=? ch end-char) + (let ((upcase-ch (char-upcase ch))) + (when (hash-table-exists? ht upcase-ch) + (error "sprite-font: overlapping range at char" upcase-ch)) + (hash-table-set! ht upcase-ch tile-id)) + (loop (integer->char (+ (char->integer ch) 1)) (+ tile-id 1)))))) + ranges) + (make-sprite-font tile-size: tile-size spacing: spacing char-map: ht))) + + ;; Look up char tile-id (always upcase) + (define (sprite-font-char->tile-id font ch) + (hash-table-ref/default (sprite-font-char-map font) (char-upcase ch) #f)) + + ;; Compute pixel width of text + (define (sprite-text-width font text) + (let ((n (string-length text))) + (if (zero? n) 0 + (+ (* n (sprite-font-tile-size font)) + (* (- n 1) (sprite-font-spacing font)))))) + + ;; Draw sprite text using a bitmap font + (define (draw-sprite-text renderer tileset-texture tileset font text x y) + (let ((ts (sprite-font-tile-size font)) + (sp (sprite-font-spacing font))) + (let loop ((i 0) (cx x)) + (when (< i (string-length text)) + (let ((tile-id (sprite-font-char->tile-id font (string-ref text i)))) + (when tile-id + (sdl2:render-copy! renderer tileset-texture + (tile-rect (tileset-tile tileset tile-id)) + (sdl2:make-rect cx y ts ts))) + (loop (+ i 1) (+ cx ts sp))))))) + + ;; --- 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 --- + + ;; #:color is (r g b) or (r g b a); used when no tile sprite is drawn. + (define (draw-entity renderer camera tileset tileset-texture entity) + (if (entity-ref entity #:skip-render #f) + (void) + (let ((tile-id (entity-ref entity #:tile-id #f)) + (color (entity-ref entity #:color #f))) + (cond + ((and tile-id tileset tileset-texture) + (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))) + ((and (list? color) (>= (length color) 3)) + (let ((r (list-ref color 0)) + (g (list-ref color 1)) + (b (list-ref color 2)) + (a (if (>= (length color) 4) (list-ref color 3) 255))) + (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) + (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) + (else #f))))) + + (define (draw-entities renderer camera tileset tileset-texture entities) (for-each - (lambda (range) - (let ((start-char (car range)) - (end-char (cadr range)) - (first-tile-id (caddr range))) - (let loop ((ch start-char) (tile-id first-tile-id)) - (when (char<=? ch end-char) - (let ((upcase-ch (char-upcase ch))) - (when (hash-table-exists? ht upcase-ch) - (error "sprite-font: overlapping range at char" upcase-ch)) - (hash-table-set! ht upcase-ch tile-id)) - (loop (integer->char (+ (char->integer ch) 1)) (+ tile-id 1)))))) - ranges) - (make-sprite-font tile-size: tile-size spacing: spacing char-map: ht))) - -;; Look up char tile-id (always upcase) -(define (sprite-font-char->tile-id font ch) - (hash-table-ref/default (sprite-font-char-map font) (char-upcase ch) #f)) - -;; Compute pixel width of text -(define (sprite-text-width font text) - (let ((n (string-length text))) - (if (zero? n) 0 - (+ (* n (sprite-font-tile-size font)) - (* (- n 1) (sprite-font-spacing font)))))) - -;; Draw sprite text using a bitmap font -(define (draw-sprite-text renderer tileset-texture tileset font text x y) - (let ((ts (sprite-font-tile-size font)) - (sp (sprite-font-spacing font))) - (let loop ((i 0) (cx x)) - (when (< i (string-length text)) - (let ((tile-id (sprite-font-char->tile-id font (string-ref text i)))) - (when tile-id - (sdl2:render-copy! renderer tileset-texture - (tile-rect (tileset-tile tileset tile-id)) - (sdl2:make-rect cx y ts ts))) - (loop (+ i 1) (+ cx ts sp))))))) - -;; --- 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 --- - -;; #:color is (r g b) or (r g b a); used when no tile sprite is drawn. -(define (draw-entity renderer camera tileset tileset-texture entity) - (if (entity-ref entity #:skip-render #f) - (void) - (let ((tile-id (entity-ref entity #:tile-id #f)) - (color (entity-ref entity #:color #f))) - (cond - ((and tile-id tileset tileset-texture) - (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))) - ((and (list? color) (>= (length color) 3)) - (let ((r (list-ref color 0)) - (g (list-ref color 1)) - (b (list-ref color 2)) - (a (if (>= (length color) 4) (list-ref color 3) 255))) - (set! (sdl2:render-draw-color renderer) (sdl2:make-color r g b a)) - (sdl2:render-fill-rect! renderer (entity->screen-rect entity camera)))) - (else #f))))) - -(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)))) - -;; --- Menu drawing --- - -(define (draw-menu-items renderer font items cursor x y-start y-step - #!key (label-fn identity) (color #f) (prefix "> ") (no-prefix " ")) - (let loop ((i 0) (rest items)) - (unless (null? rest) - (draw-ui-text renderer font - (string-append (if (= i cursor) prefix no-prefix) - (label-fn (car rest))) - (or color (sdl2:make-color 255 255 255)) - x (+ y-start (* i y-step))) - (loop (+ i 1) (cdr rest))))) - -;; --- Scene drawing --- - -(define (render-scene! renderer scene) - (let* ((camera (scene-camera scene)) - (tilemap (scene-tilemap scene)) - (scene-ts (scene-tileset scene)) - (tileset-texture (scene-tileset-texture scene)) - (entities (scene-entities scene)) - ;; Resolve the tileset for rect math independently of the - ;; texture. draw-entity itself guards on the texture, so sprite - ;; entities still fall back to #:color rendering when no texture - ;; is available (instead of being silently dropped). - (tileset (or scene-ts (and tilemap (tilemap-tileset tilemap))))) - (when (and tilemap tileset-texture) - (draw-tilemap renderer camera tileset-texture tilemap)) - (draw-entities renderer camera tileset tileset-texture entities))) - -;; --- Debug drawing --- - -(define (draw-debug-tiles renderer camera tilemap) - (let ((tw (tilemap-tilewidth tilemap)) - (th (tilemap-tileheight tilemap)) - (cx (camera-x camera)) - (cy (camera-y camera))) - (set! (sdl2:render-draw-color renderer) +debug-tile-color+) - (for-each - (lambda (layer) - (let row-loop ((rows (layer-map layer)) (row 0)) - (unless (null? rows) - (let col-loop ((tiles (car rows)) (col 0)) - (unless (null? tiles) - (unless (zero? (car tiles)) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- (* col tw) cx) - (- (* row th) cy) - tw th))) - (col-loop (cdr tiles) (+ col 1)))) - (row-loop (cdr rows) (+ row 1))))) - (tilemap-layers tilemap)))) - -(define (draw-attack-hitbox renderer e tw cx cy) - (when (> (entity-ref e #:attack-timer 0) 0) - (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) - (ey (inexact->exact (floor (entity-ref e #:y 0)))) - (ew (inexact->exact (floor (entity-ref e #:width 0)))) - (eh (inexact->exact (floor (entity-ref e #:height 0)))) - (facing (entity-ref e #:facing 1)) - (ax (if (> facing 0) (+ ex ew) (- ex tw)))) - (set! (sdl2:render-draw-color renderer) +debug-attack-color+) - (sdl2:render-fill-rect! renderer - (sdl2:make-rect (- ax cx) (- ey cy) tw eh))))) - -(define (draw-debug-entities renderer camera scene) - (let* ((tilemap (scene-tilemap scene)) - ;; Hitbox thickness falls back to the entity's own width when - ;; no tilemap is present (sprite-only scenes). - (tw (and tilemap (tilemap-tilewidth tilemap))) - (cx (camera-x camera)) - (cy (camera-y camera))) - (for-each - (lambda (e) - (let ((type (entity-type e)) - (rect (entity->screen-rect e camera)) - (hit-w (or tw (entity-ref e #:width 0)))) - (cond - ((eq? type 'player) - (set! (sdl2:render-draw-color renderer) +debug-player-color+) - (sdl2:render-fill-rect! renderer rect) - (draw-attack-hitbox renderer e hit-w cx cy)) - ((eq? type 'enemy) - (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) - (sdl2:render-fill-rect! renderer rect) - (draw-attack-hitbox renderer e hit-w cx cy))))) - (scene-entities scene)))) - -(define (render-debug-scene! renderer scene) - (let ((camera (scene-camera scene)) - (tilemap (scene-tilemap scene))) - (when tilemap - (draw-debug-tiles renderer camera tilemap)) - (draw-debug-entities renderer camera scene))) - -) ;; end module renderer + (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)))) + + ;; --- Menu drawing --- + + (define (draw-menu-items renderer font items cursor x y-start y-step + #!key (label-fn identity) (color #f) (prefix "> ") (no-prefix " ")) + (let loop ((i 0) (rest items)) + (unless (null? rest) + (draw-ui-text renderer font + (string-append (if (= i cursor) prefix no-prefix) + (label-fn (car rest))) + (or color (sdl2:make-color 255 255 255)) + x (+ y-start (* i y-step))) + (loop (+ i 1) (cdr rest))))) + + ;; --- Scene drawing --- + + (define (render-scene! renderer scene) + (let* ((camera (scene-camera scene)) + (tilemap (scene-tilemap scene)) + (scene-ts (scene-tileset scene)) + (tileset-texture (scene-tileset-texture scene)) + (entities (scene-entities scene)) + ;; Resolve the tileset for rect math independently of the + ;; texture. draw-entity itself guards on the texture, so sprite + ;; entities still fall back to #:color rendering when no texture + ;; is available (instead of being silently dropped). + (tileset (or scene-ts (and tilemap (tilemap-tileset tilemap))))) + (when (and tilemap tileset-texture) + (draw-tilemap renderer camera tileset-texture tilemap)) + (draw-entities renderer camera tileset tileset-texture entities))) + + ;; --- Debug drawing --- + + (define (draw-debug-tiles renderer camera tilemap) + (let ((tw (tilemap-tilewidth tilemap)) + (th (tilemap-tileheight tilemap)) + (cx (camera-x camera)) + (cy (camera-y camera))) + (set! (sdl2:render-draw-color renderer) +debug-tile-color+) + (for-each + (lambda (layer) + (let row-loop ((rows (layer-map layer)) (row 0)) + (unless (null? rows) + (let col-loop ((tiles (car rows)) (col 0)) + (unless (null? tiles) + (unless (zero? (car tiles)) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- (* col tw) cx) + (- (* row th) cy) + tw th))) + (col-loop (cdr tiles) (+ col 1)))) + (row-loop (cdr rows) (+ row 1))))) + (tilemap-layers tilemap)))) + + (define (draw-attack-hitbox renderer e tw cx cy) + (when (> (entity-ref e #:attack-timer 0) 0) + (let* ((ex (inexact->exact (floor (entity-ref e #:x 0)))) + (ey (inexact->exact (floor (entity-ref e #:y 0)))) + (ew (inexact->exact (floor (entity-ref e #:width 0)))) + (eh (inexact->exact (floor (entity-ref e #:height 0)))) + (facing (entity-ref e #:facing 1)) + (ax (if (> facing 0) (+ ex ew) (- ex tw)))) + (set! (sdl2:render-draw-color renderer) +debug-attack-color+) + (sdl2:render-fill-rect! renderer + (sdl2:make-rect (- ax cx) (- ey cy) tw eh))))) + + (define (draw-debug-entities renderer camera scene) + (let* ((tilemap (scene-tilemap scene)) + ;; Hitbox thickness falls back to the entity's own width when + ;; no tilemap is present (sprite-only scenes). + (tw (and tilemap (tilemap-tilewidth tilemap))) + (cx (camera-x camera)) + (cy (camera-y camera))) + (for-each + (lambda (e) + (let ((type (entity-type e)) + (rect (entity->screen-rect e camera)) + (hit-w (or tw (entity-ref e #:width 0)))) + (cond + ((eq? type 'player) + (set! (sdl2:render-draw-color renderer) +debug-player-color+) + (sdl2:render-fill-rect! renderer rect) + (draw-attack-hitbox renderer e hit-w cx cy)) + ((eq? type 'enemy) + (set! (sdl2:render-draw-color renderer) +debug-enemy-color+) + (sdl2:render-fill-rect! renderer rect) + (draw-attack-hitbox renderer e hit-w cx cy))))) + (scene-entities scene)))) + + (define (render-debug-scene! renderer scene) + (let ((camera (scene-camera scene)) + (tilemap (scene-tilemap scene))) + (when tilemap + (draw-debug-tiles renderer camera tilemap)) + (draw-debug-entities renderer camera scene))) + + ) ;; end module renderer diff --git a/scene-loader.scm b/scene-loader.scm index 50ad210..c2e600b 100644 --- a/scene-loader.scm +++ b/scene-loader.scm @@ -1,96 +1,96 @@ (module (downstroke scene-loader) * -(import scheme - (chicken base) - (only srfi-1 filter-map) - (prefix sdl2 "sdl2:") - (prefix sdl2-ttf "ttf:") - defstruct - (downstroke tilemap) - (downstroke world) - (downstroke assets) - (downstroke engine) - (downstroke prefabs)) + (import scheme + (chicken base) + (only srfi-1 filter-map) + (prefix sdl2 "sdl2:") + (prefix sdl2-ttf "ttf:") + defstruct + (downstroke tilemap) + (downstroke world) + (downstroke assets) + (downstroke engine) + (downstroke prefabs)) -;; Convert TMX object list to entities. -;; Object types are strings from XML; convert to symbols before instantiating. -;; Filters out #f results (objects without registered prefabs). -(define (tilemap-objects->entities tilemap registry) - (filter-map - (lambda (obj) - (instantiate-prefab registry - (string->symbol (object-type obj)) - (object-x obj) (object-y obj) - (object-width obj) (object-height obj))) - (tilemap-objects tilemap))) + ;; Convert TMX object list to entities. + ;; Object types are strings from XML; convert to symbols before instantiating. + ;; Filters out #f results (objects without registered prefabs). + (define (tilemap-objects->entities tilemap registry) + (filter-map + (lambda (obj) + (instantiate-prefab registry + (string->symbol (object-type obj)) + (object-x obj) (object-y obj) + (object-width obj) (object-height obj))) + (tilemap-objects tilemap))) -;; Create an SDL2 texture from a tileset's embedded image surface. -(define (create-texture-from-tileset renderer tileset) - (sdl2:create-texture-from-surface renderer (tileset-image tileset))) + ;; Create an SDL2 texture from a tileset's embedded image surface. + (define (create-texture-from-tileset renderer tileset) + (sdl2:create-texture-from-surface renderer (tileset-image tileset))) -;; Create an SDL2 texture from the tileset image embedded in a tilemap. -(define (create-tileset-texture renderer tilemap) - (create-texture-from-tileset renderer (tilemap-tileset tilemap))) + ;; Create an SDL2 texture from the tileset image embedded in a tilemap. + (define (create-tileset-texture renderer tilemap) + (create-texture-from-tileset renderer (tilemap-tileset tilemap))) -;; Load a TMX tilemap file and store it in the game asset registry. -;; Returns the loaded tilemap struct. -(define (game-load-tilemap! game key filename) - (let ((tm (load-tilemap filename))) - (game-asset-set! game key tm) - tm)) + ;; Load a TMX tilemap file and store it in the game asset registry. + ;; Returns the loaded tilemap struct. + (define (game-load-tilemap! game key filename) + (let ((tm (load-tilemap filename))) + (game-asset-set! game key tm) + tm)) -;; Load a TSX tileset file and store it in the game asset registry. -;; Returns the loaded tileset struct. -(define (game-load-tileset! game key filename) - (let ((ts (load-tileset filename))) - (game-asset-set! game key ts) - ts)) + ;; Load a TSX tileset file and store it in the game asset registry. + ;; Returns the loaded tileset struct. + (define (game-load-tileset! game key filename) + (let ((ts (load-tileset filename))) + (game-asset-set! game key ts) + ts)) -;; Load a TTF font file and store it in the game asset registry. -;; size is the point size. Returns the loaded font. -(define (game-load-font! game key filename size) - (let ((font (ttf:open-font filename size))) - (game-asset-set! game key font) - font)) + ;; Load a TTF font file and store it in the game asset registry. + ;; size is the point size. Returns the loaded font. + (define (game-load-font! game key filename size) + (let ((font (ttf:open-font filename size))) + (game-asset-set! game key font) + font)) -;; Load a scene from a TMX tilemap file. -;; 1. Loads the tilemap from the file (and stores in assets) -;; 2. Creates a texture from the tilemap's tileset image -;; 3. Creates a scene with empty entities list -;; 4. Sets the scene on the game -;; Returns the scene. -(define (game-load-scene! game filename) - (let* ((tm (game-load-tilemap! game 'tilemap filename)) - (tex (create-tileset-texture (game-renderer game) tm)) - (scene (make-scene - entities: '() - tilemap: tm - tileset: #f - camera: (make-camera x: 0 y: 0) - tileset-texture: tex - camera-target: #f))) - (game-scene-set! game scene) - scene)) + ;; Load a scene from a TMX tilemap file. + ;; 1. Loads the tilemap from the file (and stores in assets) + ;; 2. Creates a texture from the tilemap's tileset image + ;; 3. Creates a scene with empty entities list + ;; 4. Sets the scene on the game + ;; Returns the scene. + (define (game-load-scene! game filename) + (let* ((tm (game-load-tilemap! game 'tilemap filename)) + (tex (create-tileset-texture (game-renderer game) tm)) + (scene (make-scene + entities: '() + tilemap: tm + tileset: #f + camera: (make-camera x: 0 y: 0) + tileset-texture: tex + camera-target: #f))) + (game-scene-set! game scene) + scene)) -;; Build a tilemap-less scene driven only by a tileset (for sprite-only -;; demos/games that don't need a TMX map). Any keyword accepted by -;; make-scene can be passed via #!rest to override defaults. -(define (make-sprite-scene #!key - (entities '()) - (tileset #f) - (tileset-texture #f) - (camera (make-camera x: 0 y: 0)) - (camera-target #f) - (background #f) - (engine-update #f)) - (make-scene - entities: entities - tilemap: #f - tileset: tileset - camera: camera - tileset-texture: tileset-texture - camera-target: camera-target - background: background - engine-update: engine-update)) + ;; Build a tilemap-less scene driven only by a tileset (for sprite-only + ;; demos/games that don't need a TMX map). Any keyword accepted by + ;; make-scene can be passed via #!rest to override defaults. + (define (make-sprite-scene #!key + (entities '()) + (tileset #f) + (tileset-texture #f) + (camera (make-camera x: 0 y: 0)) + (camera-target #f) + (background #f) + (engine-update #f)) + (make-scene + entities: entities + tilemap: #f + tileset: tileset + camera: camera + tileset-texture: tileset-texture + camera-target: camera-target + background: background + engine-update: engine-update)) -) ;; end module + ) ;; end module @@ -1,45 +1,45 @@ (module (downstroke sound) * -(import scheme - (chicken base) - (only srfi-1 for-each) - (downstroke mixer)) - -(define *sound-registry* '()) -(define *music* #f) - -(define (init-audio!) - (mix-open-audio! 44100 mix-default-format 2 512)) - -(define (load-sounds! sound-alist) - (set! *sound-registry* - (map (lambda (pair) - (cons (car pair) (mix-load-chunk (cdr pair)))) - sound-alist))) - -(define (play-sound sym) - (let ((entry (assq sym *sound-registry*))) - (when (and entry (cdr entry)) - (mix-play-channel -1 (cdr entry) 0)))) - -(define (load-music! path) - (set! *music* (mix-load-mus path))) - -(define (play-music! volume) - (when *music* - (mix-play-music *music* -1) - (mix-volume-music (inexact->exact (round (* volume 128)))))) - -(define (stop-music!) (mix-halt-music)) - -(define (set-music-volume! volume) - (mix-volume-music (inexact->exact (round (* volume 128))))) - -(define (cleanup-audio!) - (when *music* - (mix-halt-music) - (mix-free-music! *music*) - (set! *music* #f)) - (for-each (lambda (pair) (mix-free-chunk! (cdr pair))) - *sound-registry*) - (set! *sound-registry* '()) - (mix-close-audio!))) + (import scheme + (chicken base) + (only srfi-1 for-each) + (downstroke mixer)) + + (define *sound-registry* '()) + (define *music* #f) + + (define (init-audio!) + (mix-open-audio! 44100 mix-default-format 2 512)) + + (define (load-sounds! sound-alist) + (set! *sound-registry* + (map (lambda (pair) + (cons (car pair) (mix-load-chunk (cdr pair)))) + sound-alist))) + + (define (play-sound sym) + (let ((entry (assq sym *sound-registry*))) + (when (and entry (cdr entry)) + (mix-play-channel -1 (cdr entry) 0)))) + + (define (load-music! path) + (set! *music* (mix-load-mus path))) + + (define (play-music! volume) + (when *music* + (mix-play-music *music* -1) + (mix-volume-music (inexact->exact (round (* volume 128)))))) + + (define (stop-music!) (mix-halt-music)) + + (define (set-music-volume! volume) + (mix-volume-music (inexact->exact (round (* volume 128))))) + + (define (cleanup-audio!) + (when *music* + (mix-halt-music) + (mix-free-music! *music*) + (set! *music* #f)) + (for-each (lambda (pair) (mix-free-chunk! (cdr pair))) + *sound-registry*) + (set! *sound-registry* '()) + (mix-close-audio!))) diff --git a/tests/animation-test.scm b/tests/animation-test.scm index 117e933..356f44c 100644 --- a/tests/animation-test.scm +++ b/tests/animation-test.scm @@ -26,7 +26,7 @@ (test "first frame, frames (0)" 100 (frame->duration '((0 100)) 0)) (test "wraps around" 100 (frame->duration '((0 100) (1 200)) 2)) (test "frame 1 of (27 28)" 200 (frame->duration '((27 100) (28 200)) 1)) -) + ) (test-group "set-animation" (let ((e (entity #:type 'player #:anim-name 'idle #:anim-frame 5 #:anim-tick 8))) @@ -63,10 +63,10 @@ (test-group "animated entity" (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))) + (stepped-entity (apply-animation #f e 10))) (test "Updated animated entity" 1 (entity-ref stepped-entity #:anim-tick))) (let* ((e (entity #:type 'static)) - (stepped-entity (apply-animation #f e 10))) + (stepped-entity (apply-animation #f e 10))) (test "unchanged static entity" #f (entity-ref stepped-entity #:anim-tick))))) (test-end "animation") diff --git a/tests/assets-test.scm b/tests/assets-test.scm index 5fea845..c167e7a 100644 --- a/tests/assets-test.scm +++ b/tests/assets-test.scm @@ -12,26 +12,26 @@ (test-group "asset-set! and asset-ref" (let ((reg (make-asset-registry))) (test "missing key returns #f" - #f - (asset-ref reg 'missing)) + #f + (asset-ref reg 'missing)) (asset-set! reg 'my-tilemap "data") (test "stored value is retrievable" - "data" - (asset-ref reg 'my-tilemap)) + "data" + (asset-ref reg 'my-tilemap)) (asset-set! reg 'my-tilemap "updated") (test "overwrite replaces value" - "updated" - (asset-ref reg 'my-tilemap)) + "updated" + (asset-ref reg 'my-tilemap)) (asset-set! reg 'other 42) (test "multiple keys coexist" - "updated" - (asset-ref reg 'my-tilemap)) + "updated" + (asset-ref reg 'my-tilemap)) (test "second key retrievable" - 42 - (asset-ref reg 'other)))) + 42 + (asset-ref reg 'other)))) (test-end "assets") (test-exit) diff --git a/tests/engine-test.scm b/tests/engine-test.scm index bfa6d75..0ae56a9 100644 --- a/tests/engine-test.scm +++ b/tests/engine-test.scm @@ -46,9 +46,9 @@ (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))))))) + ((null? plist) (if (procedure? default) (default) default)) + ((eq? (car plist) key) (cadr plist)) + (else (loop (cddr plist))))))) (import (downstroke entity)) ;; --- Input module (mock) --- @@ -60,18 +60,18 @@ (define-record input-state current previous) (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)) + 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 (create-input-state config) (make-input-state '() '())) (define (input-state-update state events config) @@ -89,15 +89,15 @@ ;; Mock camera-follow - returns a new camera (define (camera-follow camera entity viewport-w viewport-h) (update-camera camera - x: (max 0 (- (entity-ref entity #:x 0) (/ viewport-w 2))) - y: (max 0 (- (entity-ref entity #:y 0) (/ viewport-h 2))))) + x: (max 0 (- (entity-ref entity #:x 0) (/ viewport-w 2))) + y: (max 0 (- (entity-ref entity #:y 0) (/ viewport-h 2))))) ;; Mock scene-find-tagged - finds first entity with matching tag (define (scene-find-tagged scene tag) (let loop ((entities (scene-entities scene))) (cond - ((null? entities) #f) - ((member tag (entity-ref (car entities) #:tags '())) (car entities)) - (else (loop (cdr entities)))))) + ((null? entities) #f) + ((member tag (entity-ref (car entities) #:tags '())) (car entities)) + (else (loop (cdr entities)))))) (define (scene-map-entities scene . procs) (let loop ((ps procs) (es (scene-entities scene))) (if (null? ps) @@ -156,36 +156,36 @@ (test-group "make-game defaults" (let ((g (make-game))) (test "default title" - "Downstroke Game" - (game-title g)) + "Downstroke Game" + (game-title g)) (test "default width" - 640 - (game-width g)) + 640 + (game-width g)) (test "default height" - 480 - (game-height g)) + 480 + (game-height g)) (test "default frame-delay" - 16 - (game-frame-delay g)) + 16 + (game-frame-delay g)) (test "scene starts as #f" - #f - (game-scene g)) + #f + (game-scene g)) (test "window starts as #f" - #f - (game-window g)) + #f + (game-window g)) (test "renderer starts as #f" - #f - (game-renderer g)) + #f + (game-renderer g)) (test-assert "assets registry is created" (game-assets g)) (test-assert "input state is created" (game-input g)) (test "debug? defaults to #f" - #f - (game-debug? g)) + #f + (game-debug? g)) (test "scale defaults to 1" - 1 - (game-scale g)))) + 1 + (game-scale g)))) (test-group "make-game with keyword args" (let ((g (make-game title: "My Game" width: 320 height: 240 frame-delay: 33))) @@ -196,22 +196,22 @@ (test-group "make-game debug? keyword" (test "debug? defaults to #f" - #f - (game-debug? (make-game))) + #f + (game-debug? (make-game))) (test "debug? can be set to #t" - #t - (game-debug? (make-game debug?: #t)))) + #t + (game-debug? (make-game debug?: #t)))) (test-group "make-game scale keyword" (test "scale defaults to 1" - 1 - (game-scale (make-game))) + 1 + (game-scale (make-game))) (test "scale can be set to 2" - 2 - (game-scale (make-game scale: 2))) + 2 + (game-scale (make-game scale: 2))) (test "scale can be set to 3" - 3 - (game-scale (make-game scale: 3))) + 3 + (game-scale (make-game scale: 3))) (import (chicken condition)) (let ((caught #f)) (condition-case (make-game scale: 0) @@ -229,16 +229,16 @@ (test-group "game-asset and game-asset-set!" (let ((g (make-game))) (test "missing key returns #f" - #f - (game-asset g 'no-such-asset)) + #f + (game-asset g 'no-such-asset)) (game-asset-set! g 'my-font 'font-object) (test "stored asset is retrievable" - 'font-object - (game-asset g 'my-font)) + 'font-object + (game-asset g 'my-font)) (game-asset-set! g 'my-font 'updated-font) (test "overwrite replaces asset" - 'updated-font - (game-asset g 'my-font)))) + 'updated-font + (game-asset g 'my-font)))) (test-group "make-game hooks default to #f" (let ((g (make-game))) @@ -256,17 +256,17 @@ (test-group "game-camera" (let* ((cam (make-camera x: 10 y: 20)) (scene (make-scene entities: '() - tilemap: #f - tileset: #f - camera: cam - tileset-texture: #f - camera-target: #f - background: #f)) + tilemap: #f + tileset: #f + camera: cam + tileset-texture: #f + camera-target: #f + background: #f)) (g (make-game))) (game-scene-set! g scene) (test "returns scene camera" - cam - (game-camera g)))) + cam + (game-camera g)))) (test-group "make-game-state" (let ((s (make-game-state create: (lambda (g) 'created) @@ -283,7 +283,7 @@ (let* ((created? #f) (game (make-game)) (state (make-game-state - create: (lambda (g) (set! created? #t))))) + create: (lambda (g) (set! created? #t))))) (game-add-state! game 'play state) (test "active-state defaults to #f" #f (game-active-state game)) (game-start-state! game 'play) @@ -297,16 +297,16 @@ (test-group "scene engine-update" (test "scene engine-update defaults to #f" - #f - (scene-engine-update (make-scene entities: '() tilemap: #f camera-target: #f))) + #f + (scene-engine-update (make-scene entities: '() tilemap: #f camera-target: #f))) (let* ((my-eu (lambda (game dt) #t)) (s (make-scene entities: '() tilemap: #f camera-target: #f engine-update: my-eu))) (test-assert "custom engine-update stored on scene" (procedure? (scene-engine-update s)))) (let ((s (make-scene entities: '() tilemap: #f camera-target: #f engine-update: 'none))) (test "engine-update: 'none disables pipeline" - 'none - (scene-engine-update s)))) + 'none + (scene-engine-update s)))) (test-end "engine") (test-exit) diff --git a/tests/entity-test.scm b/tests/entity-test.scm index 1e3ab19..c7bcd2d 100644 --- a/tests/entity-test.scm +++ b/tests/entity-test.scm @@ -20,18 +20,18 @@ ;; Test with default value (let ((entity '((#:type . player)))) (test "returns default for missing key" - 99 - (entity-ref entity #:x 99)) + 99 + (entity-ref entity #:x 99)) (test "returns #f as default if not specified" - #f - (entity-ref entity #:missing-key)))) + #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 "calls procedure default when key missing" - 42 - (entity-ref entity #:x (lambda () 42))))) + 42 + (entity-ref entity #:x (lambda () 42))))) ;; Test: make-player-entity creates valid player entity (test-group "make-entity" @@ -51,8 +51,8 @@ (let ((no-type '((#:x . 100) (#:y . 200)))) (test "returns #f for entity without type" - #f - (entity-type no-type)))) + #f + (entity-type no-type)))) ;; Test: complex entity with multiple properties (test-group "complex-entity" @@ -128,19 +128,19 @@ (test "skipped" 0 (entity-ref (fixture-pipeline #f e 0) #:x)))) (define-pipeline (guarded-pipeline guarded-skip) (scene_ ent _dt) - guard: (entity-ref ent #:active? #f) + 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)))) (test "runs body when guard passes" 99 - (entity-ref (guarded-pipeline #f e 0) #:x))) + (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0)))) (test "returns entity unchanged when guard fails" 0 - (entity-ref (guarded-pipeline #f e 0) #:x))) + (entity-ref (guarded-pipeline #f e 0) #:x))) (let ((e '((#:type . t) (#:x . 0) (#:active? . #t) (#:skip-pipelines . (guarded-skip))))) (test "skip-pipelines takes precedence over guard" 0 - (entity-ref (guarded-pipeline #f e 0) #:x)))) + (entity-ref (guarded-pipeline #f e 0) #:x)))) (test-end "entity") (test-exit) diff --git a/tests/input-test.scm b/tests/input-test.scm index 2903cbb..39316c4 100644 --- a/tests/input-test.scm +++ b/tests/input-test.scm @@ -63,7 +63,7 @@ ;; In state2, up is held but was not held before -> pressed (test-assert "pressed when current=#t and previous=#f" - (input-pressed? state2 'up)))) + (input-pressed? state2 'up)))) ;; Test: input-released? detection (test-group "input-released?" @@ -79,14 +79,14 @@ (test "not released when held" #f (input-released? state-held 'up)) (test-assert "released when current=#f and previous=#t" - (input-released? state-released 'up)))) + (input-released? state-released 'up)))) ;; Test: input-any-pressed? (test-group "input-any-pressed?" (let ((state1 (create-input-state *default-input-config*))) (test "no actions pressed in initial state" - #f - (input-any-pressed? state1 *default-input-config*)))) + #f + (input-any-pressed? state1 *default-input-config*)))) ;; Test: input-state->string formatting (test-group "input-state->string" @@ -95,8 +95,8 @@ (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: ]"))))) + (or (string-contains str "[]") + (string-contains str "[Input: ]"))))) ;; Test: state transitions (test-group "state-transitions" @@ -119,13 +119,13 @@ (input-state-current state2)))) (test-assert "up still held in state3" (input-held? state3 'up)) (test "up not pressed in state3 (already was pressed)" - #f - (input-pressed? state3 'up))))) + #f + (input-pressed? state3 'up))))) (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" @@ -169,13 +169,13 @@ (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)) + 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 "jump is false" #f (input-held? state 'jump)) diff --git a/tests/physics-test.scm b/tests/physics-test.scm index e22c2fd..54c71ea 100644 --- a/tests/physics-test.scm +++ b/tests/physics-test.scm @@ -303,16 +303,16 @@ (test "pushed above floor" 28 (entity-ref result #:y)) (test "vy zeroed" 0 (entity-ref result #:vy)))))) - (test-group "high-velocity fall: snaps to first solid row, not last" - ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. - ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]). - ;; 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 (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 "snapped to first solid row" 16 (entity-ref result #:y)) - (test "vy zeroed" 0 (entity-ref result #:vy))))) +(test-group "high-velocity fall: snaps to first solid row, not last" + ;; Regression: entity falls fast enough that apply-velocity-y moves it into TWO solid rows. + ;; Rows 2 and 3 are both solid (tileheight=16, so row 2 = y=[32,47], row 3 = y=[48,63]). + ;; 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 (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 "snapped to first solid row" 16 (entity-ref result #:y)) + (test "vy zeroed" 0 (entity-ref result #:vy))))) ;; Integration test: simulate the actual game physics loop (test-group "multi-frame physics simulation" diff --git a/tests/prefabs-test.scm b/tests/prefabs-test.scm index 06f9ba9..d77bcc5 100644 --- a/tests/prefabs-test.scm +++ b/tests/prefabs-test.scm @@ -3,7 +3,7 @@ (chicken base) (chicken keyword) (chicken port) - (chicken pretty-print) + (chicken pretty-print) defstruct test) @@ -13,15 +13,15 @@ (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)))))) + ((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) (list key val) (cddr plist))) - (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc))))))) + ((null? plist) (reverse (cons val (cons key acc)))) + ((eq? (car plist) key) (append (reverse acc) (list key val) (cddr plist))) + (else (loop (cddr plist) (cons (cadr plist) (cons (car plist) acc))))))) (define (entity-type entity) (entity-ref entity #:type #f))) (import (downstroke entity)) @@ -61,47 +61,47 @@ (test-group "mixin merge priority" (with-prefab-data - "((mixins (speed-mixin #:vx 5 #:vy 0)) + "((mixins (speed-mixin #:vx 5 #:vy 0)) (prefabs (runner speed-mixin #:type runner #:vx 99)))" - (lambda (reg) - ;; Inline #:vx 99 beats mixin #:vx 5 - (let ((e (instantiate-prefab reg 'runner 0 0 16 16))) - (pp e) - (test "entity should have squashed properties" 7 (length e)) - (test "inline field beats mixin field for same key" - 99 - (entity-ref e #:vx)) - (test "mixin field present when not overridden" - 0 - (entity-ref e #:vy)))))) + (lambda (reg) + ;; Inline #:vx 99 beats mixin #:vx 5 + (let ((e (instantiate-prefab reg 'runner 0 0 16 16))) + (pp e) + (test "entity should have squashed properties" 7 (length e)) + (test "inline field beats mixin field for same key" + 99 + (entity-ref e #:vx)) + (test "mixin field present when not overridden" + 0 + (entity-ref e #:vy)))))) (test-group "left-to-right mixin priority" (with-prefab-data - "((mixins (m1 #:key first) (m2 #:key second)) + "((mixins (m1 #:key first) (m2 #:key second)) (prefabs (thing m1 m2 #:type thing)))" - (lambda (reg) - ;; m1 listed before m2 → m1's #:key wins - (let ((e (instantiate-prefab reg 'thing 0 0 8 8))) - (test "earlier mixin wins over later mixin for same key" - 'first - (entity-ref e #:key)))))) + (lambda (reg) + ;; m1 listed before m2 → m1's #:key wins + (let ((e (instantiate-prefab reg 'thing 0 0 8 8))) + (test "earlier mixin wins over later mixin for same key" + 'first + (entity-ref e #:key)))))) (test-group "user mixin overrides engine mixin by name" (with-prefab-data - "((mixins (physics-body #:vx 77 #:vy 88)) + "((mixins (physics-body #:vx 77 #:vy 88)) (prefabs (custom-obj physics-body #:type custom-obj)))" - (lambda (reg) - ;; User redefined physics-body → user's version wins - (let ((e (instantiate-prefab reg 'custom-obj 0 0 16 16))) - (test "user-redefined mixin key overrides engine default" - 77 - (entity-ref e #:vx)))))) + (lambda (reg) + ;; User redefined physics-body → user's version wins + (let ((e (instantiate-prefab reg 'custom-obj 0 0 16 16))) + (test "user-redefined mixin key overrides engine default" + 77 + (entity-ref e #:vx)))))) (test-group "unknown mixin raises error" (test-error - (let ((tmp "/tmp/test-prefabs.scm")) - (with-output-to-file tmp (lambda () (display "((mixins) (prefabs (bad-prefab nonexistent-mixin #:type bad)))"))) - (load-prefabs tmp (engine-mixins) '()))))) + (let ((tmp "/tmp/test-prefabs.scm")) + (with-output-to-file tmp (lambda () (display "((mixins) (prefabs (bad-prefab nonexistent-mixin #:type bad)))"))) + (load-prefabs tmp (engine-mixins) '()))))) (test-group "instantiate-prefab" (define (with-simple-registry thunk) @@ -115,18 +115,18 @@ (not (instantiate-prefab #f 'player 0 0 8 8))) (with-simple-registry - (lambda (reg) - (test-assert "returns #f for unknown type" - (not (instantiate-prefab reg 'unknown 0 0 8 8))) + (lambda (reg) + (test-assert "returns #f for unknown type" + (not (instantiate-prefab reg 'unknown 0 0 8 8))) - (let ((e (instantiate-prefab reg 'box 10 20 32 48))) - (test "instance #:x is set" 10 (entity-ref e #:x)) - (test "instance #:y is set" 20 (entity-ref e #:y)) - (test "instance #:width is set" 32 (entity-ref e #:width)) - (test "instance #:height is set" 48 (entity-ref e #:height)) - (test "prefab field #:type present" 'box (entity-ref e #:type)) - (test "mixin field #:vx present" 0 (entity-ref e #:vx)) - (test "mixin field #:gravity? present" #t (entity-ref e #:gravity?)))))) + (let ((e (instantiate-prefab reg 'box 10 20 32 48))) + (test "instance #:x is set" 10 (entity-ref e #:x)) + (test "instance #:y is set" 20 (entity-ref e #:y)) + (test "instance #:width is set" 32 (entity-ref e #:width)) + (test "instance #:height is set" 48 (entity-ref e #:height)) + (test "prefab field #:type present" 'box (entity-ref e #:type)) + (test "mixin field #:vx present" 0 (entity-ref e #:vx)) + (test "mixin field #:gravity? present" #t (entity-ref e #:gravity?)))))) (test-group "hooks" (define (with-hook-registry extra-prefabs user-hooks thunk) @@ -134,8 +134,8 @@ (with-output-to-file tmp (lambda () (display (string-append - "((mixins)" - " (prefabs " extra-prefabs "))")))) + "((mixins)" + " (prefabs " extra-prefabs "))")))) (thunk (load-prefabs tmp (engine-mixins) user-hooks)))) (test-group "procedure value in #:on-instantiate fires directly" @@ -143,58 +143,58 @@ ;; (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: `((proc-hooked . ((#:type . proc-hooked) - (#:on-instantiate . ,hook-proc)))) - group-prefabs: '() - file: "/dev/null" - engine-mixin-table: '() - user-hooks: '() - hook-table: '()))) + prefabs: `((proc-hooked . ((#:type . proc-hooked) + (#:on-instantiate . ,hook-proc)))) + group-prefabs: '() + file: "/dev/null" + engine-mixin-table: '() + user-hooks: '() + hook-table: '()))) (let ((e (instantiate-prefab reg 'proc-hooked 0 0 8 8))) (test "procedure hook fires and sets #:proc-fired" - #t - (entity-ref e #:proc-fired))))) + #t + (entity-ref e #:proc-fired))))) ;; Symbol hook: value in data file is a symbol, resolved via hook-table (test-group "symbol hook via user-hooks" (with-hook-registry - "(hooked physics-body #:type hooked #:on-instantiate my-hook)" - `((my-hook . ,(lambda (e) (entity-set e #:initialized #t)))) - (lambda (reg) - (let ((e (instantiate-prefab reg 'hooked 0 0 8 8))) - (test "user hook sets #:initialized" - #t - (entity-ref e #:initialized)))))) + "(hooked physics-body #:type hooked #:on-instantiate my-hook)" + `((my-hook . ,(lambda (e) (entity-set e #:initialized #t)))) + (lambda (reg) + (let ((e (instantiate-prefab reg 'hooked 0 0 8 8))) + (test "user hook sets #:initialized" + #t + (entity-ref e #:initialized)))))) (test-group "game hook via user-hooks (e.g. init-enemy-ai pattern)" (let ((tmp "/tmp/test-prefabs-user-init.scm")) (with-output-to-file tmp (lambda () (display - "((mixins (ai-body #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)) + "((mixins (ai-body #:ai-facing 1 #:ai-machine #f #:chase-origin-x 0 #:disabled #f)) (prefabs (npc ai-body has-facing #:type npc #:on-instantiate init-npc)))"))) (let ((reg (load-prefabs tmp (engine-mixins) - `((init-npc . ,(lambda (e) (entity-set e #:ai-machine 'from-user-hook))))))) + `((init-npc . ,(lambda (e) (entity-set e #:ai-machine 'from-user-hook))))))) (let ((e (instantiate-prefab reg 'npc 0 0 16 16))) (test "user hook sets #:ai-machine" - 'from-user-hook - (entity-ref e #:ai-machine)))))) + 'from-user-hook + (entity-ref e #:ai-machine)))))) (test-group "no hook: entity returned unchanged" (with-hook-registry - "(plain physics-body #:type plain)" - '() - (lambda (reg) - (let ((e (instantiate-prefab reg 'plain 0 0 8 8))) - (test "no hook: type is plain" 'plain (entity-ref e #:type)))))) + "(plain physics-body #:type plain)" + '() + (lambda (reg) + (let ((e (instantiate-prefab reg 'plain 0 0 8 8))) + (test "no hook: type is plain" 'plain (entity-ref e #:type)))))) (test-group "unknown hook symbol raises error" (test-error - (with-hook-registry - "(bad-hook #:type bad #:on-instantiate no-such-hook)" - '() - (lambda (reg) - (instantiate-prefab reg 'bad-hook 0 0 8 8)))))) + (with-hook-registry + "(bad-hook #:type bad #:on-instantiate no-such-hook)" + '() + (lambda (reg) + (instantiate-prefab reg 'bad-hook 0 0 8 8)))))) (test-group "reload-prefabs!" (let* ((tmp "/tmp/test-prefabs-reload.scm") @@ -220,37 +220,37 @@ (thunk (load-prefabs tmp (engine-mixins) '())))) (with-group-prefab-data - "((mixins) (prefabs) + "((mixins) (prefabs) (group-prefabs (two-block #:pose-only-origin? #t #:static-parts? #t #:type-members segment #:parts ((#:local-x 0 #:local-y 0 #:width 10 #:height 8 #:tile-id 1) (#:local-x 10 #:local-y 0 #:width 10 #:height 8 #:tile-id 2)))))" - (lambda (reg) - (test-assert "instantiate-group-prefab unknown → #f" - (not (instantiate-group-prefab reg 'nope 0 0))) - (let ((lst (instantiate-group-prefab reg 'two-block 100 50))) - (test "returns list of origin + 2 members" 3 (length lst)) - (let ((origin (car lst)) - (a (cadr lst)) - (b (caddr lst))) - (test "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) - (test "origin group-origin?" #t (entity-ref origin #:group-origin?)) - (test "member a world x" 100 (entity-ref a #:x)) - (test "member b world x" 110 (entity-ref b #:x)) - (test "member a local x" 0 (entity-ref a #:group-local-x)) - (test "member b local x" 10 (entity-ref b #:group-local-x)) - (test "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) + (lambda (reg) + (test-assert "instantiate-group-prefab unknown → #f" + (not (instantiate-group-prefab reg 'nope 0 0))) + (let ((lst (instantiate-group-prefab reg 'two-block 100 50))) + (test "returns list of origin + 2 members" 3 (length lst)) + (let ((origin (car lst)) + (a (cadr lst)) + (b (caddr lst))) + (test "pose-only origin skip-render" #t (entity-ref origin #:skip-render)) + (test "origin group-origin?" #t (entity-ref origin #:group-origin?)) + (test "member a world x" 100 (entity-ref a #:x)) + (test "member b world x" 110 (entity-ref b #:x)) + (test "member a local x" 0 (entity-ref a #:group-local-x)) + (test "member b local x" 10 (entity-ref b #:group-local-x)) + (test "shared group-id" (entity-ref origin #:group-id) (entity-ref a #:group-id)))))) (with-group-prefab-data - "((mixins) (prefabs) + "((mixins) (prefabs) (group-prefabs (falling-asm #:pose-only-origin? #f #:static-parts? #t #:type-members part #:parts ((#:local-x 0 #:local-y 0 #:width 4 #:height 4 #:tile-id 1)))))" - (lambda (reg) - (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0)))) - (test "physics origin has gravity" #t (entity-ref origin #:gravity?)) - (test-assert "physics origin has no #:skip-pipelines (pipelines run)" - (eq? 'absent (entity-ref origin #:skip-pipelines 'absent))))))) + (lambda (reg) + (let ((origin (car (instantiate-group-prefab reg 'falling-asm 0 0)))) + (test "physics origin has gravity" #t (entity-ref origin #:gravity?)) + (test-assert "physics origin has no #:skip-pipelines (pipelines run)" + (eq? 'absent (entity-ref origin #:skip-pipelines 'absent))))))) (test-end "prefabs") (test-exit) diff --git a/tests/renderer-test.scm b/tests/renderer-test.scm index 3a85c73..cd4c5d9 100644 --- a/tests/renderer-test.scm +++ b/tests/renderer-test.scm @@ -61,43 +61,43 @@ (let* ((cam (make-camera x: 10 y: 20)) (e (entity #:x 50 #:y 80 #:width 16 #:height 16))) (test "subtracts camera offset from x" - 40 - (car (entity-screen-coords e cam))) + 40 + (car (entity-screen-coords e cam))) (test "subtracts camera offset from y" - 60 - (cadr (entity-screen-coords e cam))) + 60 + (cadr (entity-screen-coords e cam))) (test "preserves width" - 16 - (caddr (entity-screen-coords e cam))) + 16 + (caddr (entity-screen-coords e cam))) (test "preserves height" - 16 - (cadddr (entity-screen-coords e cam)))) + 16 + (cadddr (entity-screen-coords e cam)))) (let* ((cam (make-camera x: 0 y: 0)) (e (entity #:x 100.7 #:y 200.3 #:width 16 #:height 16))) (test "floors fractional x" - 100 - (car (entity-screen-coords e cam))) + 100 + (car (entity-screen-coords e cam))) (test "floors fractional y" - 200 - (cadr (entity-screen-coords e cam)))) + 200 + (cadr (entity-screen-coords e cam)))) (let* ((cam (make-camera x: 0 y: 0)) (e (entity #:x 0 #:y 0 #:width 32 #:height 32))) (test "zero camera, zero position" - '(0 0 32 32) - (entity-screen-coords e cam)))) + '(0 0 32 32) + (entity-screen-coords e cam)))) (test-group "entity-flip" (test "facing 1: no flip" - '() - (entity-flip (entity #:facing 1))) + '() + (entity-flip (entity #:facing 1))) (test "facing -1: horizontal flip" - '(horizontal) - (entity-flip (entity #:facing -1))) + '(horizontal) + (entity-flip (entity #:facing -1))) (test "no facing key: defaults to no flip" - '() - (entity-flip (entity #:x 0)))) + '() + (entity-flip (entity #:x 0)))) (test-group "render-scene!" (let* ((cam (make-camera x: 0 y: 0)) @@ -134,34 +134,34 @@ (test-group "sprite-font" (test-group "make-sprite-font*" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\C 100))))) + ranges: (list (list #\A #\C 100))))) (test "A maps to 100" - 100 - (sprite-font-char->tile-id font #\A)) + 100 + (sprite-font-char->tile-id font #\A)) (test "B maps to 101" - 101 - (sprite-font-char->tile-id font #\B)) + 101 + (sprite-font-char->tile-id font #\B)) (test "C maps to 102" - 102 - (sprite-font-char->tile-id font #\C)))) + 102 + (sprite-font-char->tile-id font #\C)))) (test-group "sprite-font-char->tile-id" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\Z 100))))) + ranges: (list (list #\A #\Z 100))))) (test "returns #f for unmapped char" - #f - (sprite-font-char->tile-id font #\1)) + #f + (sprite-font-char->tile-id font #\1)) (test "auto-upcase: lowercase a maps to uppercase" - 100 - (sprite-font-char->tile-id font #\a)))) + 100 + (sprite-font-char->tile-id font #\a)))) (test-group "overlapping ranges" (import (chicken condition)) (let ((caught-error #f)) (condition-case - (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\C 100) - (list #\B #\D 200))) + (make-sprite-font* tile-size: 8 spacing: 1 + ranges: (list (list #\A #\C 100) + (list #\B #\D 200))) (e (exn) (set! caught-error #t))) (test-assert "signals error on overlapping range" @@ -169,19 +169,19 @@ (test-group "sprite-text-width" (let ((font (make-sprite-font* tile-size: 8 spacing: 1 - ranges: (list (list #\A #\Z 100))))) + ranges: (list (list #\A #\Z 100))))) (test "empty string width is 0" - 0 - (sprite-text-width font "")) + 0 + (sprite-text-width font "")) (test "single char width is tile-size" - 8 - (sprite-text-width font "A")) + 8 + (sprite-text-width font "A")) (test "two chars: 2*tile-size + 1*spacing" - 17 - (sprite-text-width font "AB")) + 17 + (sprite-text-width font "AB")) (test "three chars: 3*tile-size + 2*spacing" - 26 - (sprite-text-width font "ABC")))) + 26 + (sprite-text-width font "ABC")))) (test-group "draw-sprite-text" (let* ((font (make-sprite-font* tile-size: 8 spacing: 1 @@ -303,7 +303,7 @@ (test-assert "render-scene! works with plist entities" (begin (render-scene! #f scene-ok) #t)) (test-error "render-scene! errors when entity list contains a vector" - (render-scene! #f scene-bad)) + (render-scene! #f scene-bad)) (test-assert "extracting entity from cell vector fixes the issue" (let ((scene-fixed (make-scene entities: (list (vector-ref cell 0)) tilemap: tilemap camera: cam diff --git a/tests/scene-loader-test.scm b/tests/scene-loader-test.scm index e86ea42..3286c70 100644 --- a/tests/scene-loader-test.scm +++ b/tests/scene-loader-test.scm @@ -36,7 +36,7 @@ (defstruct scene entities tilemap tileset camera tileset-texture camera-target background engine-update) (define (scene-add-entity scene entity) (update-scene scene - entities: (append (scene-entities scene) (list entity))))) + entities: (append (scene-entities scene) (list entity))))) (import (downstroke world)) ;; Mock assets module @@ -90,22 +90,22 @@ objects: (list obj1 obj2 obj3))) ;; mock registry: alist of (type . constructor) (registry - (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))))) + (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 "filters #f results: 2 entities from 3 objects" - 2 (length result)) + 2 (length result)) (test "first entity is player" - 'player (entity-ref (car result) #:type)) + 'player (entity-ref (car result) #:type)) (test "second entity is enemy" - 'enemy (entity-ref (cadr result) #:type))) + 'enemy (entity-ref (cadr result) #:type))) (let* ((tm-empty (make-tilemap width: 100 height: 100 tilewidth: 16 tileheight: 16 tileset-source: "" tileset: #f layers: '() objects: '())) (result (tilemap-objects->entities tm-empty '()))) (test "empty object list returns empty list" - 0 (length result)))) + 0 (length result)))) (test-group "game-load-tilemap! / game-load-tileset! / game-load-font!" ;; game-load-tilemap! calls load-tilemap and stores result @@ -121,8 +121,8 @@ (let* ((game #f) ; mock game (game-asset-set! ignores it in mock) (font (ttf:open-font "test.ttf" 16))) (test "mock font is a list" - 'font - (car font)))) + 'font + (car font)))) (test-group "make-sprite-scene" (let ((s (make-sprite-scene))) diff --git a/tests/tilemap-test.scm b/tests/tilemap-test.scm index 3fe5cfe..33f9175 100644 --- a/tests/tilemap-test.scm +++ b/tests/tilemap-test.scm @@ -52,8 +52,8 @@ image-source: "test.png" image: #f))) (test "100 tiles / 10 columns = 10 rows" - 10 - (tileset-rows ts))) + 10 + (tileset-rows ts))) (let ((ts (make-tileset tilewidth: 16 tileheight: 16 @@ -63,8 +63,8 @@ image-source: "test.png" image: #f))) (test "105 tiles / 10 columns = 11 rows (ceiling)" - 11 - (tileset-rows ts)))) + 11 + (tileset-rows ts)))) ;; Test: tileset-tile calculates correct tile position (test-group "tileset-tile" diff --git a/tests/tween-test.scm b/tests/tween-test.scm index 31b4de3..1e19a4b 100644 --- a/tests/tween-test.scm +++ b/tests/tween-test.scm @@ -69,7 +69,7 @@ (let ((calls 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)))))) + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) (test "one call" 1 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 5) @@ -88,7 +88,7 @@ (test-group "repeat: 1 plays twice" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1))) + ease: 'linear repeat: 1))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "not finished after first play" (not (tween-finished? tw2))) (test "x at target" 100.0 (entity-ref e2 #:x)) @@ -99,7 +99,7 @@ (test-group "repeat: -1 never finishes" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 10)) duration: 10 - ease: 'linear repeat: -1))) + ease: 'linear repeat: -1))) (let loop ((tw tw) (ent ent) (i 0)) (if (>= i 5) (test-assert "still active after 5 cycles" (tween-active? tw)) (receive (tw2 e2) (tween-step tw ent 10) @@ -116,8 +116,8 @@ (let ((calls 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)))))) + ease: 'linear repeat: 1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (receive (tw2 e2) (tween-step tw ent 10) (test "no call after first play" 0 (begin calls)) (receive (tw3 e3) (tween-step tw2 e2 10) @@ -127,8 +127,8 @@ (let ((calls 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)))))) + ease: 'linear repeat: -1 + on-complete: (lambda (_) (set! calls (+ calls 1)))))) (let loop ((tw tw) (ent ent) (i 0)) (if (>= i 5) (test "never called" 0 (begin calls)) (receive (tw2 e2) (tween-step tw ent 10) @@ -138,7 +138,7 @@ (test-group "yoyo: #t with repeat: 1 reverses" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1 yoyo?: #t))) + ease: 'linear repeat: 1 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) (test "x at target after forward" 100.0 (entity-ref e2 #:x)) (receive (tw3 e3) (tween-step tw2 e2 50) @@ -150,7 +150,7 @@ (test-group "yoyo: #t with repeat: -1 ping-pongs forever" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: -1 yoyo?: #t))) + ease: 'linear repeat: -1 yoyo?: #t))) ;; Forward (receive (tw2 e2) (tween-step tw ent 100) (test "at target" 100.0 (entity-ref e2 #:x)) @@ -165,7 +165,7 @@ (test-group "yoyo: #f with repeat: 1 replays same direction" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 1 yoyo?: #f))) + ease: 'linear repeat: 1 yoyo?: #f))) (receive (tw2 e2) (tween-step tw ent 100) (test "x at target" 100.0 (entity-ref e2 #:x)) ;; Second play starts from same starts (0→100), but entity is at 100 @@ -176,7 +176,7 @@ (test-group "yoyo: #t without repeat has no effect" (let* ((ent (entity #:type 'a #:x 0)) (tw (make-tween ent props: '((#:x . 100)) duration: 100 - ease: 'linear repeat: 0 yoyo?: #t))) + ease: 'linear repeat: 0 yoyo?: #t))) (receive (tw2 e2) (tween-step tw ent 100) (test-assert "finishes normally" (tween-finished? tw2)) (test "x at target" 100.0 (entity-ref e2 #:x)))))) @@ -185,7 +185,7 @@ (test-group "advances #:tween on entity" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 50))) (test "x moved to midpoint" 50.0 (entity-ref e2 #:x)) (test-assert "tween still attached" (entity-ref e2 #:tween #f)))) @@ -193,7 +193,7 @@ (test-group "removes #:tween when finished" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) (test "x at target" 100.0 (entity-ref e2 #:x)) (test "tween removed" #f (entity-ref e2 #:tween #f)))) @@ -206,7 +206,7 @@ (test-group "keeps repeating tween attached" (let* ((ent (entity #:type 'a #:x 0 #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) + duration: 100 ease: 'linear repeat: -1 yoyo?: #t))) (e2 (step-tweens #f ent 100))) (test "x at target" 100.0 (entity-ref e2 #:x)) (test-assert "tween still attached (repeating)" (entity-ref e2 #:tween #f)))) @@ -215,7 +215,7 @@ (let* ((ent (entity #:type 'a #:x 0 #:skip-pipelines '(tweens) #:tween (make-tween (entity #:x 0) props: '((#:x . 100)) - duration: 100 ease: 'linear))) + duration: 100 ease: 'linear))) (e2 (step-tweens #f ent 100))) (test "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 0915cd2..9fd4947 100644 --- a/tests/world-test.scm +++ b/tests/world-test.scm @@ -96,7 +96,7 @@ layers: (list layer1 layer2) objects: '()))) (test "skips zero in layer1, finds in layer2" - 5 (tilemap-tile-at tm 1 1))))) + 5 (tilemap-tile-at tm 1 1))))) ;; Test: scene record creation (test-group "scene-structure" @@ -122,14 +122,14 @@ tilemap: tilemap camera-target: #f))) (test "scene has 2 entities" - 2 - (length (scene-entities scene))) + 2 + (length (scene-entities scene))) (test "first entity is player" - 'player - (entity-type (car (scene-entities scene)))) + 'player + (entity-type (car (scene-entities scene)))) (test "tilemap is set correctly" - "mock-tilemap" - (scene-tilemap scene)))) + "mock-tilemap" + (scene-tilemap scene)))) ;; Test: scene-add-entity adds entity to scene (test-group "scene-add-entity" @@ -143,8 +143,8 @@ (test "original scene unchanged" 1 (length (scene-entities scene))) (test "entity count after add" 2 (length (scene-entities scene2))) (test "second entity is enemy" - 'enemy - (entity-type (cadr (scene-entities scene2))))))) + 'enemy + (entity-type (cadr (scene-entities scene2))))))) ;; Test: scene-add-entity appends to end (test-group "scene-add-entity-order" @@ -156,8 +156,8 @@ (scene (scene-add-entity scene e3))) (test "entities are in order" - '(a b c) - (map entity-type (scene-entities scene))))) + '(a b c) + (map entity-type (scene-entities scene))))) ;; Test: scene-map-entities applies function to all entities (test-group "scene-map-entities" @@ -165,24 +165,24 @@ (e2 (entity #:type 'enemy #:x 200 #:y 200)) (scene (make-scene entities: (list e1 e2) tilemap: #f camera-target: #f)) (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)))) + (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 "original scene unchanged" - 100 - (entity-ref (car (scene-entities scene)) #:x)) + 100 + (entity-ref (car (scene-entities scene)) #:x)) (test "first entity moved right" - 110 - (entity-ref (car (scene-entities scene2)) #:x)) + 110 + (entity-ref (car (scene-entities scene2)) #:x)) (test "second entity moved right" - 210 - (entity-ref (cadr (scene-entities scene2)) #:x)) + 210 + (entity-ref (cadr (scene-entities scene2)) #:x)) (test "y values unchanged" - 100 - (entity-ref (car (scene-entities scene2)) #:y)))) + 100 + (entity-ref (car (scene-entities scene2)) #:y)))) ;; Test: scene-map-entities with identity function (test-group "scene-map-entities-identity" @@ -193,8 +193,8 @@ (test "entity count unchanged" 2 (length (scene-entities scene2))) (test "first entity unchanged" - 100 - (entity-ref (car (scene-entities scene2)) #:x)))) + 100 + (entity-ref (car (scene-entities scene2)) #:x)))) ;; Test: scene chaining (was mutation test) (test-group "scene-chaining" @@ -205,12 +205,12 @@ (test "entity added" 1 (length (scene-entities scene))) (let ((scene (scene-map-entities scene - (lambda (scene e) - (let ((x (entity-ref e #:x)) - (y (entity-ref e #:y)) - (type (entity-type e))) - (entity #:type type #:x (* x 2) #:y (* y 2) - #:width 16 #:height 16)))))) + (lambda (scene e) + (let ((x (entity-ref e #:x)) + (y (entity-ref e #:y)) + (type (entity-type e))) + (entity #:type type #:x (* x 2) #:y (* y 2) + #:width 16 #:height 16)))))) (test "entity x doubled" 20 (entity-ref (car (scene-entities scene)) #:x)) (test "entity y doubled" 40 (entity-ref (car (scene-entities scene)) #:y))))) @@ -235,75 +235,75 @@ (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) - tileset-texture: #f - camera-target: #f)) + tilemap: test-tilemap + camera: (make-camera x: 0 y: 0) + tileset-texture: #f + camera-target: #f)) (scene2 (scene-filter-entities scene - (lambda (e) (eq? (entity-ref e #:type #f) 'player))))) + (lambda (e) (eq? (entity-ref e #:type #f) 'player))))) (test "original scene unchanged" 2 (length (scene-entities scene))) (test "keeps matching entities" 1 (length (scene-entities scene2))) (test "kept entity is player" - 'player - (entity-ref (car (scene-entities scene2)) #:type #f)))) - - (test-group "camera-follow" - (let* ((cam (make-camera x: 0 y: 0)) - (ent (entity #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) - (cam2 (camera-follow cam ent 600 400))) - (test "original camera unchanged" 0 (camera-x cam)) - (test "centers camera x on entity" 100 (camera-x cam2)) - (test "centers camera y on entity" 100 (camera-y cam2))) - (let* ((cam (make-camera x: 0 y: 0)) - (ent (entity #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) - (cam2 (camera-follow cam ent 600 400))) - (test "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) - (test "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) - - (test-group "scene-find-tagged" - (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 "finds entity with matching tag" p (scene-find-tagged s 'player)) - (test "finds enemy by 'enemy tag" e (scene-find-tagged s 'enemy)) - (test "finds entity with second tag in list" e (scene-find-tagged s 'npc)) - (test "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) - - (test-group "scene-find-all-tagged" - (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 "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) - (test "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) - - (test-group "sync-groups" - (let* ((gid 'g1) - (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 "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) - (test "member 1 follows origin" 105 (entity-ref (list-ref result 1) #:x)) - (test "member 1 y" 200 (entity-ref (list-ref result 1) #:y)) - (test "member 2 x" 100 (entity-ref (list-ref result 2) #:x)) - (test "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) - - (test-group "scene-transform-entities" - (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 "transforms entity list" 'b - (entity-type (car (scene-entities scene2)))) - (test "original scene unchanged" 'a - (entity-type (car (scene-entities scene)))))) + 'player + (entity-ref (car (scene-entities scene2)) #:type #f)))) + +(test-group "camera-follow" + (let* ((cam (make-camera x: 0 y: 0)) + (ent (entity #:type 'player #:x 400 #:y 300 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) + (test "original camera unchanged" 0 (camera-x cam)) + (test "centers camera x on entity" 100 (camera-x cam2)) + (test "centers camera y on entity" 100 (camera-y cam2))) + (let* ((cam (make-camera x: 0 y: 0)) + (ent (entity #:type 'player #:x 50 #:y 30 #:width 16 #:height 16)) + (cam2 (camera-follow cam ent 600 400))) + (test "clamps camera x to 0 when entity near origin" 0 (camera-x cam2)) + (test "clamps camera y to 0 when entity near origin" 0 (camera-y cam2)))) + +(test-group "scene-find-tagged" + (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 "finds entity with matching tag" p (scene-find-tagged s 'player)) + (test "finds enemy by 'enemy tag" e (scene-find-tagged s 'enemy)) + (test "finds entity with second tag in list" e (scene-find-tagged s 'npc)) + (test "returns #f when tag not found" #f (scene-find-tagged s 'boss)))) + +(test-group "scene-find-all-tagged" + (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 "returns all friendly entities" 2 (length (scene-find-all-tagged s 'friendly))) + (test "returns empty list when none match" '() (scene-find-all-tagged s 'boss)))) + +(test-group "sync-groups" + (let* ((gid 'g1) + (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 "original list unchanged" 0 (entity-ref (list-ref entities 1) #:x)) + (test "member 1 follows origin" 105 (entity-ref (list-ref result 1) #:x)) + (test "member 1 y" 200 (entity-ref (list-ref result 1) #:y)) + (test "member 2 x" 100 (entity-ref (list-ref result 2) #:x)) + (test "member 2 y" 207 (entity-ref (list-ref result 2) #:y)))) + +(test-group "scene-transform-entities" + (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 "transforms entity list" 'b + (entity-type (car (scene-entities scene2)))) + (test "original scene unchanged" 'a + (entity-type (car (scene-entities scene)))))) (test-end "world-module") (test-exit) diff --git a/tilemap.scm b/tilemap.scm index 7729a7a..3880ad6 100644 --- a/tilemap.scm +++ b/tilemap.scm @@ -1,243 +1,243 @@ (module (downstroke 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:")) + * + (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) + (+ 1 1) -(defstruct tileset - tilewidth - tileheight - spacing - tilecount - columns - image-source - image) + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) -(+ 1 1) + (+ 1 1) -(defstruct layer - name - width - height - map) + (defstruct layer + name + width + height + map) -(defstruct object - name - type - x - y - width - height - properties) + (defstruct object + name + type + x + y + width + height + properties) -(defstruct tilemap - width - height - tilewidth - tileheight - tileset-source - tileset - layers - objects) + (defstruct tilemap + width + height + tilewidth + tileheight + tileset-source + tileset + layers + objects) -(defstruct tile - id - rect) + (defstruct tile + id + rect) -(define (maybe-do action) - (lambda (value) - (if (eq? value #f) - #f - (action value)))) + (define (maybe-do action) + (lambda (value) + (if (eq? value #f) + #f + (action value)))) -(define (attempt action) - (lambda (value) - (or (action value) value))) + (define (attempt action) + (lambda (value) + (or (action value) value))) -(define maybe-string->number (maybe-do (attempt string->number))) + (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 (string-alist->alist string-alist) + (map (lambda (pair) (cons (string->symbol (car pair)) + (maybe-string->number (cdr pair)))) + string-alist)) -(define (alist->tileset attrs) - (make-tileset - tilewidth: (alist-ref 'tilewidth attrs eq?) - tileheight: (alist-ref 'tileheight attrs eq?) - spacing: (alist-ref 'spacing attrs eq? 0) - tilecount: (alist-ref 'tilecount attrs eq?) - columns: (alist-ref 'columns attrs eq?) - image-source: "" - image: #f)) + (define (alist->tileset attrs) + (make-tileset + tilewidth: (alist-ref 'tilewidth attrs eq?) + tileheight: (alist-ref 'tileheight attrs eq?) + spacing: (alist-ref 'spacing attrs eq? 0) + tilecount: (alist-ref 'tilecount attrs eq?) + columns: (alist-ref 'columns attrs eq?) + image-source: "" + image: #f)) -(define (alist->layer attrs) - (let ((symbol-attrs (string-alist->alist attrs))) - (make-layer - name: (alist-ref 'name symbol-attrs eq?) - width: (alist-ref 'width symbol-attrs eq?) - height: (alist-ref 'height symbol-attrs eq?) - map: '()))) + (define (alist->layer attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (make-layer + name: (alist-ref 'name symbol-attrs eq?) + width: (alist-ref 'width symbol-attrs eq?) + height: (alist-ref 'height symbol-attrs eq?) + map: '()))) -(define (alist->object attrs) - (make-object - name: (alist-ref 'name attrs eq?) - type: (alist-ref 'type attrs eq?) - x: (alist-ref 'x attrs eq?) - y: (alist-ref 'y attrs eq?) - width: (alist-ref 'width attrs eq? 0) - height: (alist-ref 'height attrs eq? 0) - properties: '())) + (define (alist->object attrs) + (make-object + name: (alist-ref 'name attrs eq?) + type: (alist-ref 'type attrs eq?) + x: (alist-ref 'x attrs eq?) + y: (alist-ref 'y attrs eq?) + width: (alist-ref 'width attrs eq? 0) + height: (alist-ref 'height attrs eq? 0) + properties: '())) -(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 (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 (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))) + (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 (string->symbol (alist-ref "name" attrs string=?)) + (alist-ref "value" attrs string=?)) + (or (object-properties object) '())))) + (_ #f)) + (set! tags (cons tag tags))))) + (expat:set-end-handler! + parser + (lambda (tag) (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 (string->symbol (alist-ref "name" attrs string=?)) - (alist-ref "value" attrs string=?)) - (or (object-properties object) '())))) + ("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 (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)) + (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-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)) - (spacing (or (tileset-spacing tileset) 0)) - (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 spacing))) - (y (+ (* tile-y tile-height) (* tile-y spacing)))) - (make-tile - id: tile-id - rect: (sdl2:make-rect x y tile-width tile-height)))) + (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)) + (spacing (or (tileset-spacing tileset) 0)) + (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 spacing))) + (y (+ (* tile-y tile-height) (* tile-y spacing)))) + (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)))) + (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 + (when #f - (let ((txt "<?xml version='1.0' encoding='UTF-8'?> + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> <tileset version='1.10' tiledversion='1.11.2' name='monochrome_transparent' tilewidth='16' tileheight='16' spacing='1' tilecount='1078' columns='49'> <image source='monochrome-transparent.png' width='832' height='373'/> </tileset> ")) - (tileset-image (parse-tileset txt))) + (tileset-image (parse-tileset txt))) - (let ((txt "<?xml version='1.0' encoding='UTF-8'?> + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> <map version='1.10' tiledversion='1.11.0' orientation='orthogonal' renderorder='right-down' width='40' height='30' tilewidth='16' tileheight='16' infinite='0' nextlayerid='8' nextobjectid='5'> <tileset firstgid='1' source='monochrome_transparent.tsx'/> <layer id='3' name='ground' width='40' height='30'> @@ -257,9 +257,9 @@ </objectgroup> </map> ")) - (tilemap-tileset (parse-tilemap txt))) + (tilemap-tileset (parse-tilemap txt))) - (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) - ) + (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) + ) -) ;; End tilemap module + ) ;; End tilemap module @@ -1,207 +1,207 @@ (module (downstroke tween) * -(import scheme - (chicken base) - (chicken keyword) - (only srfi-1 fold) - defstruct - (downstroke entity)) - -;; ── Easing: t in [0,1] → eased factor in [0,1] for linear interpolation ── - -(define (ease-linear t) t) - -(define (ease-quad-in t) (* t t)) - -(define (ease-quad-out t) - (- 1 (* (- 1 t) (- 1 t)))) - -(define (ease-quad-in-out t) - (if (< t 0.5) - (* 2 t t) - (- 1 (* 2 (- 1 t) (- 1 t))))) - -(define (ease-cubic-in t) (* t t t)) - -(define (ease-cubic-out t) - (- 1 (expt (- 1 t) 3))) - -(define (ease-cubic-in-out t) - (if (< t 0.5) - (* 4 t t t) - (- 1.0 (/ (expt (- 2 (* 2 t)) 3) 2)))) - -(define (ease-sine-in-out t) - (- 0.5 (* 0.5 (cos (* 3.14159265358979323846 t))))) - -(define (ease-expo-in t) - (if (zero? t) 0.0 (expt 2 (* 10 (- t 1))))) - -(define (ease-expo-out t) - (if (>= t 1) 1.0 (- 1.0 (expt 2 (* -10 t))))) - -(define (ease-expo-in-out t) - (cond ((<= t 0) 0.0) - ((>= t 1) 1.0) - ((< t 0.5) (/ (expt 2 (- (* 20 t) 10)) 2)) - (else (- 1 (/ (expt 2 (+ (* -20 t) 10)) 2))))) - -;; Overshoots past 1 then settles (Robert Penner back-out, s ≈ 1.70158) -(define (ease-back-out t) - (let ((s 1.70158) - (u (- t 1))) - (+ 1 (* (+ 1 s) (expt u 3)) (* s (expt u 2))))) - -;; ── Symbol → ease procedure ─────────────────────────────────────────────── - -(define *ease-table* - `((linear . ,ease-linear) - (quad-in . ,ease-quad-in) - (quad-out . ,ease-quad-out) - (quad-in-out . ,ease-quad-in-out) - (cubic-in . ,ease-cubic-in) - (cubic-out . ,ease-cubic-out) - (cubic-in-out . ,ease-cubic-in-out) - (sine-in-out . ,ease-sine-in-out) - (expo-in . ,ease-expo-in) - (expo-out . ,ease-expo-out) - (expo-in-out . ,ease-expo-in-out) - (back-out . ,ease-back-out))) - -(define (ease-named sym) - (cond ((assq sym *ease-table*) => cdr) - (else (error "ease-named: unknown ease symbol" sym)))) - -(define (ease-resolve ease) - (cond ((procedure? ease) ease) - ((symbol? ease) (ease-named ease)) - (else (error "ease-resolve: expected symbol or procedure" ease)))) - -;; ── Tween struct (internal) ─────────────────────────────────────────────── - -(defstruct tw - starts ;; alist: (key . start-num) - ends ;; alist: (key . end-num) - duration ;; ms, > 0 - delay ;; ms, >= 0 - ease-fn ;; number → number - elapsed ;; ms since tween started (includes delay period) - done? ;; boolean - callback ;; (entity → unspecified) or #f; invoked once at completion - repeat ;; -1 = infinite, 0 = no more repeats, N = N repeats remaining - yoyo?) ;; swap starts/ends on each repeat cycle - -;; ── Public API ──────────────────────────────────────────────────────────── - -(define (tween-finished? t) (tw-done? t)) - -(define (tween-active? t) (not (tw-done? t))) - -;; props: alist of (keyword . target-number), e.g. ((#:x . 200) (#:y . 40)) -(define (make-tween entity #!key props (duration 500) (delay 0) (ease 'linear) - (on-complete #f) (repeat 0) (yoyo? #f)) - (unless (and (integer? duration) (> duration 0)) - (error "make-tween: duration must be a positive integer (ms)" duration)) - (unless (and (integer? delay) (>= delay 0)) - (error "make-tween: delay must be a non-negative integer (ms)" delay)) - (unless (pair? props) - (error "make-tween: props must be a non-empty alist" props)) - (unless (and (integer? repeat) (>= repeat -1)) - (error "make-tween: repeat must be -1 (infinite) or a non-negative integer" repeat)) - (let ((ease-fn (ease-resolve ease)) - (starts (map (lambda (p) - (let ((k (car p))) - (unless (keyword? k) - (error "make-tween: property keys must be keywords" k)) - (cons k (entity-ref entity k 0)))) - props))) - (make-tw starts: starts - ends: props - duration: duration - delay: delay - ease-fn: ease-fn - elapsed: 0 - done?: #f - callback: on-complete - repeat: repeat - yoyo?: yoyo?))) - -;; Linear interpolation with eased factor u in [0,1] -(define (lerp a b u) - (+ a (* (- b a) u))) - -(define (apply-props entity starts ends u) - (fold (lambda (end-pair ent) - (let* ((k (car end-pair)) - (end (cdr end-pair)) - (start (cdr (assq k starts)))) - (entity-set ent k (lerp start end u)))) - entity - ends)) - -(define (tw-with-elapsed tw elapsed) - (make-tw starts: (tw-starts tw) ends: (tw-ends tw) - duration: (tw-duration tw) delay: (tw-delay tw) - ease-fn: (tw-ease-fn tw) elapsed: elapsed - done?: #f callback: (tw-callback tw) - repeat: (tw-repeat tw) yoyo?: (tw-yoyo? tw))) - -(define (tw-finish tw elapsed) - (make-tw starts: (tw-starts tw) ends: (tw-ends tw) - duration: (tw-duration tw) delay: (tw-delay tw) - ease-fn: (tw-ease-fn tw) elapsed: elapsed - done?: #t callback: #f - repeat: 0 yoyo?: (tw-yoyo? tw))) - -(define (tw-next-cycle tw overflow) - (let* ((yoyo? (tw-yoyo? tw)) - (starts (tw-starts tw)) - (ends (tw-ends tw))) - (make-tw starts: (if yoyo? ends starts) - ends: (if yoyo? starts ends) - duration: (tw-duration tw) delay: 0 - ease-fn: (tw-ease-fn tw) elapsed: overflow + (import scheme + (chicken base) + (chicken keyword) + (only srfi-1 fold) + defstruct + (downstroke entity)) + + ;; ── Easing: t in [0,1] → eased factor in [0,1] for linear interpolation ── + + (define (ease-linear t) t) + + (define (ease-quad-in t) (* t t)) + + (define (ease-quad-out t) + (- 1 (* (- 1 t) (- 1 t)))) + + (define (ease-quad-in-out t) + (if (< t 0.5) + (* 2 t t) + (- 1 (* 2 (- 1 t) (- 1 t))))) + + (define (ease-cubic-in t) (* t t t)) + + (define (ease-cubic-out t) + (- 1 (expt (- 1 t) 3))) + + (define (ease-cubic-in-out t) + (if (< t 0.5) + (* 4 t t t) + (- 1.0 (/ (expt (- 2 (* 2 t)) 3) 2)))) + + (define (ease-sine-in-out t) + (- 0.5 (* 0.5 (cos (* 3.14159265358979323846 t))))) + + (define (ease-expo-in t) + (if (zero? t) 0.0 (expt 2 (* 10 (- t 1))))) + + (define (ease-expo-out t) + (if (>= t 1) 1.0 (- 1.0 (expt 2 (* -10 t))))) + + (define (ease-expo-in-out t) + (cond ((<= t 0) 0.0) + ((>= t 1) 1.0) + ((< t 0.5) (/ (expt 2 (- (* 20 t) 10)) 2)) + (else (- 1 (/ (expt 2 (+ (* -20 t) 10)) 2))))) + + ;; Overshoots past 1 then settles (Robert Penner back-out, s ≈ 1.70158) + (define (ease-back-out t) + (let ((s 1.70158) + (u (- t 1))) + (+ 1 (* (+ 1 s) (expt u 3)) (* s (expt u 2))))) + + ;; ── Symbol → ease procedure ─────────────────────────────────────────────── + + (define *ease-table* + `((linear . ,ease-linear) + (quad-in . ,ease-quad-in) + (quad-out . ,ease-quad-out) + (quad-in-out . ,ease-quad-in-out) + (cubic-in . ,ease-cubic-in) + (cubic-out . ,ease-cubic-out) + (cubic-in-out . ,ease-cubic-in-out) + (sine-in-out . ,ease-sine-in-out) + (expo-in . ,ease-expo-in) + (expo-out . ,ease-expo-out) + (expo-in-out . ,ease-expo-in-out) + (back-out . ,ease-back-out))) + + (define (ease-named sym) + (cond ((assq sym *ease-table*) => cdr) + (else (error "ease-named: unknown ease symbol" sym)))) + + (define (ease-resolve ease) + (cond ((procedure? ease) ease) + ((symbol? ease) (ease-named ease)) + (else (error "ease-resolve: expected symbol or procedure" ease)))) + + ;; ── Tween struct (internal) ─────────────────────────────────────────────── + + (defstruct tw + starts ;; alist: (key . start-num) + ends ;; alist: (key . end-num) + duration ;; ms, > 0 + delay ;; ms, >= 0 + ease-fn ;; number → number + elapsed ;; ms since tween started (includes delay period) + done? ;; boolean + callback ;; (entity → unspecified) or #f; invoked once at completion + repeat ;; -1 = infinite, 0 = no more repeats, N = N repeats remaining + yoyo?) ;; swap starts/ends on each repeat cycle + + ;; ── Public API ──────────────────────────────────────────────────────────── + + (define (tween-finished? t) (tw-done? t)) + + (define (tween-active? t) (not (tw-done? t))) + + ;; props: alist of (keyword . target-number), e.g. ((#:x . 200) (#:y . 40)) + (define (make-tween entity #!key props (duration 500) (delay 0) (ease 'linear) + (on-complete #f) (repeat 0) (yoyo? #f)) + (unless (and (integer? duration) (> duration 0)) + (error "make-tween: duration must be a positive integer (ms)" duration)) + (unless (and (integer? delay) (>= delay 0)) + (error "make-tween: delay must be a non-negative integer (ms)" delay)) + (unless (pair? props) + (error "make-tween: props must be a non-empty alist" props)) + (unless (and (integer? repeat) (>= repeat -1)) + (error "make-tween: repeat must be -1 (infinite) or a non-negative integer" repeat)) + (let ((ease-fn (ease-resolve ease)) + (starts (map (lambda (p) + (let ((k (car p))) + (unless (keyword? k) + (error "make-tween: property keys must be keywords" k)) + (cons k (entity-ref entity k 0)))) + props))) + (make-tw starts: starts + ends: props + duration: duration + delay: delay + ease-fn: ease-fn + elapsed: 0 + done?: #f + callback: on-complete + repeat: repeat + yoyo?: yoyo?))) + + ;; Linear interpolation with eased factor u in [0,1] + (define (lerp a b u) + (+ a (* (- b a) u))) + + (define (apply-props entity starts ends u) + (fold (lambda (end-pair ent) + (let* ((k (car end-pair)) + (end (cdr end-pair)) + (start (cdr (assq k starts)))) + (entity-set ent k (lerp start end u)))) + entity + ends)) + + (define (tw-with-elapsed tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed done?: #f callback: (tw-callback tw) - repeat: (let ((r (tw-repeat tw))) (if (= r -1) -1 (- r 1))) - yoyo?: yoyo?))) - -(define (tween-complete tw entity elapsed) - (let ((final (apply-props entity (tw-starts tw) (tw-ends tw) 1.0))) - (if (zero? (tw-repeat tw)) - (begin - (when (tw-callback tw) ((tw-callback tw) final)) - (values (tw-finish tw elapsed) final)) - (let ((overflow (- (- elapsed (tw-delay tw)) (tw-duration tw)))) - (values (tw-next-cycle tw overflow) final))))) - -(define (tween-interpolate tw entity elapsed) - (let* ((t0 (- elapsed (tw-delay tw))) - (u (min 1.0 (max 0.0 (/ t0 (tw-duration tw))))) - (eased ((tw-ease-fn tw) u)) - (ent2 (apply-props entity (tw-starts tw) (tw-ends tw) eased))) - (if (>= u 1.0) - (tween-complete tw entity elapsed) - (values (tw-with-elapsed tw elapsed) ent2)))) - -(define (tween-step tw entity dt) - (unless (tw? tw) (error "tween-step: expected tween struct" tw)) - (if (tw-done? tw) - (values tw entity) - (let ((elapsed (+ (tw-elapsed tw) dt))) - (if (< elapsed (tw-delay tw)) - (values (tw-with-elapsed tw elapsed) entity) - (tween-interpolate tw entity elapsed))))) - -;; ── Pipeline step ────────────────────────────────────────────────────────── -;; Auto-advance #:tween on an entity. Call from update: as part of the -;; per-entity pipeline, e.g. (step-tweens entity dt). Removes #:tween -;; when the tween finishes. - -(define-pipeline (step-tweens tweens) (scene entity dt) - guard: (entity-ref entity #:tween #f) - (let ((tw (entity-ref entity #:tween))) - (receive (tw2 ent2) (tween-step tw entity dt) - (if (tween-finished? tw2) - (entity-set ent2 #:tween #f) - (entity-set ent2 #:tween tw2))))) - -) ;; end module + repeat: (tw-repeat tw) yoyo?: (tw-yoyo? tw))) + + (define (tw-finish tw elapsed) + (make-tw starts: (tw-starts tw) ends: (tw-ends tw) + duration: (tw-duration tw) delay: (tw-delay tw) + ease-fn: (tw-ease-fn tw) elapsed: elapsed + done?: #t callback: #f + repeat: 0 yoyo?: (tw-yoyo? tw))) + + (define (tw-next-cycle tw overflow) + (let* ((yoyo? (tw-yoyo? tw)) + (starts (tw-starts tw)) + (ends (tw-ends tw))) + (make-tw starts: (if yoyo? ends starts) + ends: (if yoyo? starts ends) + duration: (tw-duration tw) delay: 0 + ease-fn: (tw-ease-fn tw) elapsed: overflow + done?: #f callback: (tw-callback tw) + repeat: (let ((r (tw-repeat tw))) (if (= r -1) -1 (- r 1))) + yoyo?: yoyo?))) + + (define (tween-complete tw entity elapsed) + (let ((final (apply-props entity (tw-starts tw) (tw-ends tw) 1.0))) + (if (zero? (tw-repeat tw)) + (begin + (when (tw-callback tw) ((tw-callback tw) final)) + (values (tw-finish tw elapsed) final)) + (let ((overflow (- (- elapsed (tw-delay tw)) (tw-duration tw)))) + (values (tw-next-cycle tw overflow) final))))) + + (define (tween-interpolate tw entity elapsed) + (let* ((t0 (- elapsed (tw-delay tw))) + (u (min 1.0 (max 0.0 (/ t0 (tw-duration tw))))) + (eased ((tw-ease-fn tw) u)) + (ent2 (apply-props entity (tw-starts tw) (tw-ends tw) eased))) + (if (>= u 1.0) + (tween-complete tw entity elapsed) + (values (tw-with-elapsed tw elapsed) ent2)))) + + (define (tween-step tw entity dt) + (unless (tw? tw) (error "tween-step: expected tween struct" tw)) + (if (tw-done? tw) + (values tw entity) + (let ((elapsed (+ (tw-elapsed tw) dt))) + (if (< elapsed (tw-delay tw)) + (values (tw-with-elapsed tw elapsed) entity) + (tween-interpolate tw entity elapsed))))) + + ;; ── Pipeline step ────────────────────────────────────────────────────────── + ;; Auto-advance #:tween on an entity. Call from update: as part of the + ;; per-entity pipeline, e.g. (step-tweens entity dt). Removes #:tween + ;; when the tween finishes. + + (define-pipeline (step-tweens tweens) (scene entity dt) + guard: (entity-ref entity #:tween #f) + (let ((tw (entity-ref entity #:tween))) + (receive (tw2 ent2) (tween-step tw entity dt) + (if (tween-finished? tw2) + (entity-set ent2 #:tween #f) + (entity-set ent2 #:tween tw2))))) + + ) ;; end module @@ -1,121 +1,121 @@ (module (downstroke world) -* -(import scheme - (chicken base) - (only srfi-1 fold filter) - defstruct - (downstroke tilemap) - (downstroke entity)) -;; Scene = current level: tilemap (layers, objects) + list of entities. + * + (import scheme + (chicken base) + (only srfi-1 fold filter) + defstruct + (downstroke tilemap) + (downstroke 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))))))) + ;; 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). + (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)))))))) + (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 camera x y) -(defstruct scene - entities - tilemap - tileset ; optional tileset struct when ~tilemap~ is ~#f~ (see renderer) - camera - tileset-texture - camera-target ; symbol tag or #f - background ; #f or (r g b) / (r g b a) for framebuffer clear - engine-update) ; #f = inherit from game, procedure = per-scene override + (defstruct scene + entities + tilemap + tileset ; optional tileset struct when ~tilemap~ is ~#f~ (see renderer) + camera + tileset-texture + camera-target ; symbol tag or #f + background ; #f or (r g b) / (r g b a) for framebuffer clear + engine-update) ; #f = inherit from game, procedure = per-scene override -(define (scene-add-entity scene entity) - (update-scene scene - entities: (append (scene-entities scene) (list entity)))) + (define (scene-add-entity scene entity) + (update-scene scene + entities: (append (scene-entities scene) (list entity)))) -(define (scene-map-entities scene . procs) - "Apply each proc in sequence to the scene's entities; returns a new scene." - (update-scene scene - entities: (fold - (lambda (proc es) - (map (cut proc scene <>) es)) - (scene-entities scene) - procs))) + (define (scene-map-entities scene . procs) + "Apply each proc in sequence to the scene's entities; returns a new scene." + (update-scene scene + entities: (fold + (lambda (proc es) + (map (cut proc scene <>) es)) + (scene-entities scene) + procs))) -(define (scene-filter-entities scene pred) - "Keep only entities satisfying pred; returns a new scene." - (update-scene scene - entities: (filter pred (scene-entities scene)))) + (define (scene-filter-entities scene pred) + "Keep only entities satisfying pred; returns a new scene." + (update-scene scene + entities: (filter pred (scene-entities scene)))) -(define (scene-transform-entities scene proc) - "Apply proc to the full entity list (entities → entities); returns a new scene." - (update-scene scene - entities: (proc (scene-entities scene)))) + (define (scene-transform-entities scene proc) + "Apply proc to the full entity list (entities → entities); returns a new scene." + (update-scene scene + entities: (proc (scene-entities scene)))) -;; Center camera on entity. Clamps to >= 0 on both axes. -;; Returns a new camera struct. -(define (camera-follow camera entity viewport-w viewport-h) - (let* ((entity-x (entity-ref entity #:x 0)) - (entity-y (entity-ref entity #:y 0))) - (update-camera camera - x: (inexact->exact (floor (max 0 (- entity-x (/ viewport-w 2))))) - y: (inexact->exact (floor (max 0 (- entity-y (/ viewport-h 2)))))))) + ;; Center camera on entity. Clamps to >= 0 on both axes. + ;; Returns a new camera struct. + (define (camera-follow camera entity viewport-w viewport-h) + (let* ((entity-x (entity-ref entity #:x 0)) + (entity-y (entity-ref entity #:y 0))) + (update-camera camera + x: (inexact->exact (floor (max 0 (- entity-x (/ viewport-w 2))))) + y: (inexact->exact (floor (max 0 (- entity-y (/ viewport-h 2)))))))) -;; Returns the first entity in scene whose #:tags list contains tag, or #f. -(define (scene-find-tagged scene tag) - (let loop ((entities (scene-entities scene))) - (cond - ((null? entities) #f) - ((member tag (entity-ref (car entities) #:tags '())) (car entities)) - (else (loop (cdr entities)))))) + ;; Returns the first entity in scene whose #:tags list contains tag, or #f. + (define (scene-find-tagged scene tag) + (let loop ((entities (scene-entities scene))) + (cond + ((null? entities) #f) + ((member tag (entity-ref (car entities) #:tags '())) (car entities)) + (else (loop (cdr entities)))))) -;; Returns all entities in scene whose #:tags list contains tag. -(define (scene-find-all-tagged scene tag) - (filter (lambda (e) (member tag (entity-ref e #:tags '()))) - (scene-entities scene))) + ;; Returns all entities in scene whose #:tags list contains tag. + (define (scene-find-all-tagged scene tag) + (filter (lambda (e) (member tag (entity-ref e #:tags '()))) + (scene-entities scene))) -;; First wins: one origin entity per #:group-id (for lookup). -(define (group-origin-alist entities) - (let loop ((es entities) (acc '())) - (if (null? es) - acc - (let ((e (car es))) - (if (and (entity-ref e #:group-origin? #f) - (entity-ref e #:group-id #f)) - (let ((gid (entity-ref e #:group-id))) - (if (assq gid acc) - (loop (cdr es) acc) - (loop (cdr es) (cons (cons gid e) acc)))) - (loop (cdr es) acc)))))) + ;; First wins: one origin entity per #:group-id (for lookup). + (define (group-origin-alist entities) + (let loop ((es entities) (acc '())) + (if (null? es) + acc + (let ((e (car es))) + (if (and (entity-ref e #:group-origin? #f) + (entity-ref e #:group-id #f)) + (let ((gid (entity-ref e #:group-id))) + (if (assq gid acc) + (loop (cdr es) acc) + (loop (cdr es) (cons (cons gid e) acc)))) + (loop (cdr es) acc)))))) -(define (sync-member-to-origin e origins) - (let* ((gid (entity-ref e #:group-id #f)) - (o (and gid (not (entity-ref e #:group-origin? #f)) - (assq gid origins)))) - (if o - (let ((origin (cdr o))) - (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) - (entity-ref e #:group-local-x 0))) - #:y (+ (entity-ref origin #:y 0) - (entity-ref e #:group-local-y 0)))) - e))) + (define (sync-member-to-origin e origins) + (let* ((gid (entity-ref e #:group-id #f)) + (o (and gid (not (entity-ref e #:group-origin? #f)) + (assq gid origins)))) + (if o + (let ((origin (cdr o))) + (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) + (entity-ref e #:group-local-x 0))) + #:y (+ (entity-ref origin #:y 0) + (entity-ref e #:group-local-y 0)))) + e))) -;; Snap member #:x/#:y to origin + #:group-local-x/y. -;; Pure entities → entities function; use with scene-transform-entities. -(define (sync-groups entities) - (let ((origins (group-origin-alist entities))) - (map (cut sync-member-to-origin <> origins) entities))) -) + ;; Snap member #:x/#:y to origin + #:group-local-x/y. + ;; Pure entities → entities function; use with scene-transform-entities. + (define (sync-groups entities) + (let ((origins (group-origin-alist entities))) + (map (cut sync-member-to-origin <> origins) entities))) + ) |