159 lines
6 KiB
Scheme
159 lines
6 KiB
Scheme
;; Game state and logic for the runner entities
|
|
(define-module (game model runner)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (srfi srfi-64)
|
|
#:use-module (chickadee math vector)
|
|
#:use-module (game util pipe)
|
|
#:use-module (game model level)
|
|
#:export (runner-load
|
|
runner-state
|
|
runner-position runner-with-position
|
|
runner-x runner-with-x
|
|
runner-y runner-with-y
|
|
runner-update))
|
|
|
|
(define-immutable-record-type <runner>
|
|
(%make-runner position state)
|
|
runner?
|
|
(position runner-position runner-with-position)
|
|
(state runner-state runner-with-state) ;; 'go-left 'go-right 'climb 'fall 'stationary
|
|
)
|
|
|
|
(define default-state 'fall)
|
|
|
|
(define (runner-load initial-position)
|
|
(%make-runner initial-position default-state))
|
|
|
|
(define (runner-x runner)
|
|
"return the x coordinate as an integer"
|
|
(inexact->exact (floor (vec2-x (runner-position runner)))))
|
|
|
|
(define (runner-y runner)
|
|
"return the y coordinate as an integer"
|
|
(inexact->exact (floor (vec2-y (runner-position runner)))))
|
|
|
|
(define (runner-with-x runner x)
|
|
(runner-with-position runner (vec2 x (runner-y runner))))
|
|
|
|
(define (runner-with-y runner y)
|
|
(runner-with-position runner (vec2 (runner-x runner) y)))
|
|
|
|
;; return next state of runner
|
|
;; @returns 'go-left 'go-right 'climb 'fall 'stationary
|
|
(define (next-state runner level inputs)
|
|
"return the next state of the runner based on the current state, level and inputs"
|
|
(let* ((position (runner-position runner))
|
|
(state (runner-state runner))
|
|
(tile-below-blocked? (level-tile-blocked? level (vec2 (runner-x runner) (1- (runner-y runner))))))
|
|
(cond
|
|
((equal? (level-tile-at level position) 'ladder) 'climb)
|
|
((> (floor-remainder (runner-y runner) level-cell-size) 0) 'fall)
|
|
((not tile-below-blocked?) 'fall)
|
|
(else (cond
|
|
((member 'left inputs) 'go-left)
|
|
((member 'right inputs) 'go-right)
|
|
(else 'stationary))))))
|
|
|
|
(define (input->movement input distance)
|
|
(case input
|
|
((left) (vec2 (- distance) 0))
|
|
((right) (vec2 distance 0))
|
|
((up) (vec2 0 distance))
|
|
((down) (vec2 0 (- distance)))
|
|
(else (vec2 0 0))))
|
|
|
|
(define (round-position pos)
|
|
(vec2 (inexact->exact (floor (vec2-x pos)))
|
|
(inexact->exact (floor (vec2-y pos)))))
|
|
|
|
(define (safe-move level pos move)
|
|
(let ((new-pos (vec2+ pos move)))
|
|
(if (level-tile-blocked? level new-pos)
|
|
(pk "snap position " pos "to" (round-position pos)) ;; snap to grid on collision with hard scenery
|
|
new-pos
|
|
)))
|
|
|
|
(define (next-position level position state inputs distance)
|
|
(case state
|
|
((fall) (safe-move level position (vec2 0 (- distance))))
|
|
((go-left) (safe-move level position (vec2 (- distance) 0)))
|
|
((go-right) (safe-move level position (vec2 distance 0)))
|
|
((stationary) position)
|
|
((climb) (fold (lambda (input pos)
|
|
(safe-move level pos (input->movement input distance)))
|
|
position
|
|
inputs))
|
|
(else position)
|
|
))
|
|
|
|
(define speed 50.0)
|
|
|
|
(define (runner-update runner level inputs dt)
|
|
(let* ((state (next-state runner level inputs))
|
|
(distance (* dt speed))
|
|
(position (next-position level (runner-position runner) (runner-state runner) inputs distance))
|
|
)
|
|
(-> runner
|
|
(runner-with-state state)
|
|
(runner-with-position position))))
|
|
|
|
;; Tests
|
|
(test-begin "runner-model")
|
|
|
|
(let* ((level (level-parse "WWWWW\nW...W\nW.P.W\nW..HW\nWWWWW\n"))
|
|
(default-position (vec2 32 32))
|
|
(runner (runner-load default-position)))
|
|
(test-assert (runner? runner))
|
|
(test-equal default-position (runner-position runner))
|
|
(test-equal default-state (runner-state runner))
|
|
|
|
(test-equal (vec2 10 20) (runner-position (runner-with-position runner (vec2 10 20))))
|
|
(test-equal default-position (runner-position runner))
|
|
(test-equal 'go-left (runner-state (runner-with-state runner 'go-left)))
|
|
(test-equal default-state (runner-state runner))
|
|
|
|
(test-equal 16 (runner-x (runner-with-position runner (vec2 16.34 20.78))))
|
|
(test-equal 20 (runner-y (runner-with-position runner (vec2 16.34 20.78))))
|
|
|
|
(test-equal 'fall (next-state runner level '()))
|
|
(let ((runner (runner-with-position runner (vec2 16 16))))
|
|
(test-equal 'stationary (next-state runner level '()))
|
|
(test-equal 'go-left (next-state runner level '(left)))
|
|
(test-equal 'go-right (next-state runner level '(right))))
|
|
(let ((runner (runner-with-position runner (vec2 48 32))))
|
|
(test-equal 'stationary (next-state runner level '())))
|
|
(let ((runner (runner-with-position runner (vec2 48 31))))
|
|
(test-equal 'climb (next-state runner level '())))
|
|
(let ((runner (runner-with-position runner (vec2 32 31))))
|
|
(test-equal 'fall (next-state runner level '())))
|
|
|
|
(test-equal "fall in air" (vec2 32.0 31.0) (next-position level (vec2 32.0 32.0) 'fall '() 1.0))
|
|
(test-equal "fall on brick" (vec2 32.0 16.0) (next-position level (vec2 32.0 16.0) 'fall '() 1.0))
|
|
|
|
(test-equal (vec2 31.0 32.0) (next-position level (vec2 32.0 32.0) 'go-left '() 1.0))
|
|
(test-equal (vec2 33.0 32.0) (next-position level (vec2 32.0 32.0) 'go-right '() 1.0))
|
|
(test-equal (vec2 32.0 32.0) (next-position level (vec2 32.0 32.0) 'stationary '() 1.0))
|
|
|
|
(test-equal "climb left" (vec2 31.0 32.0) (next-position level (vec2 32.0 32.0) 'climb '(left) 1.0))
|
|
(test-equal "climb right" (vec2 33.0 32.0) (next-position level (vec2 32.0 32.0) 'climb '(right) 1.0))
|
|
(test-equal "climb down" (vec2 32.0 31.0) (next-position level (vec2 32.0 32.0) 'climb '(down) 1.0))
|
|
(test-equal "climb up" (vec2 32.0 33.0) (next-position level (vec2 32.0 32.0) 'climb '(up) 1.0))
|
|
|
|
(test-equal "snap to grid on collision with hard scenery"
|
|
(vec2 32.0 16.0)
|
|
(runner-position
|
|
(runner-update
|
|
(runner-with-state
|
|
(runner-with-position runner (vec2 32 16.3))
|
|
'fall)
|
|
level
|
|
'()
|
|
0.017
|
|
)
|
|
))
|
|
)
|
|
|
|
(test-end "runner-model")
|