path: root/tests/engine-test.scm

(import scheme (chicken base) (chicken keyword) test defstruct (srfi 69))

;; --- Mocks ---

(module sdl2 *
  (import scheme (chicken base))
  (define (set-main-ready!) #f)
  (define (init! . args) #f)
  (define (quit! . args) #f)
  (define (get-ticks) 0)
  (define (delay! ms) #f)
  (define (pump-events!) #f)
  (define (has-events?) #f)
  (define (make-event) #f)
  (define (poll-event! e) #f)
  (define (num-joysticks) 0)
  (define (is-game-controller? i) #f)
  (define (game-controller-open! i) #f)
  (define (create-window! . args) 'mock-window)
  (define (create-renderer! . args) 'mock-renderer)
  (define (render-logical-size-set! . args) #f)
  (define (destroy-window! . args) #f)
  (define (make-color r g b #!optional (a 255)) (list r g b a))
  (define render-draw-color (getter-with-setter (lambda (r) #f) (lambda (r c) #f)))
  (define (render-clear! . args) #f)
  (define (render-present! . args) #f)
  (define (make-rect x y w h) (list x y w h))
  (define (render-copy! . args) #f)
  (define (render-copy-ex! . args) #f)
  (define (create-texture-from-surface . args) #f))
(import (prefix sdl2 "sdl2:"))

(module sdl2-ttf *
  (import scheme (chicken base))
  (define (init!) #f))
(import (prefix sdl2-ttf "ttf:"))

(module sdl2-image *
  (import scheme (chicken base))
  (define (init! . args) #f))
(import (prefix sdl2-image "img:"))

;; --- Entity module (mock minimal structs) ---
(module (downstroke entity) *
  (import scheme (chicken base))
  (define (entity-ref entity key #!optional (default #f))
    (let loop ((plist entity))
      (cond
       ((null? plist) (if (procedure? default) (default) default))
       ((eq? (car plist) key) (cadr plist))
       (else (loop (cddr plist)))))))
(import (downstroke entity))

;; --- Input module (mock) ---
(module (downstroke input) *
  (import scheme (chicken base) defstruct)
  (defstruct input-config
    actions keyboard-map joy-button-map controller-button-map
    joy-axis-bindings controller-axis-bindings deadzone)
  (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))
  (define (create-input-state config)
    (make-input-state '() '()))
  (define (input-state-update state events config)
    state)
  (define (input-held? state action)
    #f))
(import (downstroke input))

;; --- World module (mock) ---
(module (downstroke world) *
  (import scheme (chicken base) defstruct)
  (import (downstroke entity))
  (defstruct camera x y)
  (defstruct scene entities tilemap tileset camera tileset-texture camera-target background engine-update)
  ;; 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)))))
  ;; 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))))))
  (define (scene-map-entities scene . procs)
    (let loop ((ps procs) (es (scene-entities scene)))
      (if (null? ps)
          (update-scene scene entities: es)
          (loop (cdr ps) (map (car ps) es)))))
  (define (scene-transform-entities scene proc)
    (update-scene scene entities: (proc (scene-entities scene))))
  (define (sync-groups entities) entities))
(import (downstroke world))

;; --- Real deps ---
(import simple-logger)   ;; required by input.scm
(include "assets.scm")
(import (downstroke assets))

;; --- Physics module (mock) ---
(module (downstroke physics) *
  (import scheme (chicken base))
  (define (apply-acceleration e s d) e)
  (define (apply-gravity e s d) e)
  (define (apply-velocity-x e s d) e)
  (define (apply-velocity-y e s d) e)
  (define (resolve-tile-collisions-x e s d) e)
  (define (resolve-tile-collisions-y e s d) e)
  (define (detect-on-solid e s d) e)
  (define (resolve-entity-collisions es) es))
(import (downstroke physics))

;; --- Tween module (mock) ---
(module (downstroke tween) *
  (import scheme (chicken base))
  (define (step-tweens e s d) e))
(import (downstroke tween))

;; --- Renderer module (mock) ---
(module (downstroke renderer) *
  (import scheme (chicken base))
  (define (render-scene! . args) #f)
  (define (render-debug-scene! . args) #f))
(import (downstroke renderer))

;; --- Animation module (mock) ---
(module (downstroke animation) *
  (import scheme (chicken base))
  (define (apply-animation e s d) e))
(import (downstroke animation))

;; --- Engine module (real) ---
(include "engine.scm")
(import (downstroke engine))

;; --- Tests ---

(test-begin "engine")

(test-group "make-game defaults"
  (let ((g (make-game)))
    (test "default title"
          "Downstroke Game"
          (game-title g))
    (test "default width"
          640
          (game-width g))
    (test "default height"
          480
          (game-height g))
    (test "default frame-delay"
          16
          (game-frame-delay g))
    (test "scene starts as #f"
          #f
          (game-scene g))
    (test "window starts as #f"
          #f
          (game-window g))
    (test "renderer starts as #f"
          #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))
    (test "scale defaults to 1"
          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)))
    (test "custom title" "My Game" (game-title g))
    (test "custom width" 320 (game-width g))
    (test "custom height" 240 (game-height g))
    (test "custom frame-delay" 33 (game-frame-delay g))))

(test-group "make-game debug? keyword"
  (test "debug? defaults to #f"
        #f
        (game-debug? (make-game)))
  (test "debug? can be set to #t"
        #t
        (game-debug? (make-game debug?: #t))))

(test-group "make-game scale keyword"
  (test "scale defaults to 1"
        1
        (game-scale (make-game)))
  (test "scale can be set to 2"
        2
        (game-scale (make-game scale: 2)))
  (test "scale can be set to 3"
        3
        (game-scale (make-game scale: 3)))
  (import (chicken condition))
  (let ((caught #f))
    (condition-case (make-game scale: 0)
      (e (exn) (set! caught #t)))
    (test-assert "scale: 0 signals error" caught))
  (let ((caught #f))
    (condition-case (make-game scale: -1)
      (e (exn) (set! caught #t)))
    (test-assert "scale: -1 signals error" caught))
  (let ((caught #f))
    (condition-case (make-game scale: 1.5)
      (e (exn) (set! caught #t)))
    (test-assert "scale: 1.5 signals error" caught)))

(test-group "game-asset and game-asset-set!"
  (let ((g (make-game)))
    (test "missing key returns #f"
          #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))
    (game-asset-set! g 'my-font 'updated-font)
    (test "overwrite replaces asset"
          'updated-font
          (game-asset g 'my-font))))

(test-group "make-game hooks default to #f"
  (let ((g (make-game)))
    (test "preload-hook is #f" #f (game-preload-hook g))
    (test "create-hook is #f"  #f (game-create-hook g))
    (test "update-hook is #f"  #f (game-update-hook g))
    (test "render-hook is #f"  #f (game-render-hook g))))

(test-group "make-game accepts hook lambdas"
  (let* ((called #f)
         (g (make-game update: (lambda (game dt) (set! called #t)))))
    (test-assert "update hook is stored"
      (procedure? (game-update-hook g)))))

(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))
         (g (make-game)))
    (game-scene-set! g scene)
    (test "returns scene camera"
          cam
          (game-camera g))))

(test-group "make-game-state"
  (let ((s (make-game-state create: (lambda (g) 'created)
                            update: (lambda (g dt) 'updated)
                            render: (lambda (g) 'rendered))))
    (test-assert "state has create hook" (state-hook s #:create))
    (test-assert "state has update hook" (state-hook s #:update))
    (test-assert "state has render hook" (state-hook s #:render)))
  (let ((s (make-game-state)))
    (test "default state hooks are #f" #f (state-hook s #:create))
    (test "default state update is #f" #f (state-hook s #:update))))

(test-group "game-add-state! and game-start-state!"
  (let* ((created? #f)
         (game (make-game))
         (state (make-game-state
                 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)
    (test "active-state set after start" 'play (game-active-state game))
    (test-assert "create hook called on start" created?)))

(test-group "game states defaults"
  (let ((game (make-game)))
    (test-assert "states is a hash-table" (hash-table? (game-states game)))
    (test "active-state defaults to #f" #f (game-active-state game))))

(test-group "scene engine-update"
  (test "scene engine-update defaults to #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))))

(test-end "engine")
(test-exit)