Compare commits

..

2 commits

Author SHA1 Message Date
391dbc011a refactored runner logic out of hero model 2024-05-22 09:41:39 +02:00
4356aba841 add runner model 2024-05-22 08:57:59 +02:00
2 changed files with 179 additions and 112 deletions

View file

@ -8,21 +8,21 @@
#:use-module (chickadee math vector)
#:use-module (game util pipe)
#:use-module (game model level)
#:use-module (game model runner)
#:export (hero-load
hero-state
hero-bloat
hero-position hero-with-position
hero-x hero-with-x
hero-y hero-with-y
hero-position
hero-x
hero-y
hero-update
))
(define-immutable-record-type <hero>
(%make-hero position state bloat)
(%make-hero runner bloat)
hero?
(position hero-position hero-with-position)
(state hero-state hero-with-state) ;; 'go-left 'go-right 'climb 'fall 'stationary
(runner hero-runner hero-with-runner)
(bloat hero-bloat hero-with-bloat) ;; 0.0 to 2.0, how much the hero is inflated
)
@ -30,75 +30,30 @@
(define default-bloat 1.0)
(define (hero-load level)
(let ((initial-position (level-find-hero level)))
(%make-hero initial-position default-state default-bloat)))
"Create a hero at the position in the level map"
(let ((runner (runner-load (level-find-hero level))))
(%make-hero runner default-bloat)))
(define (hero-x hero)
"return the x coordinate as an integer"
(inexact->exact (floor (vec2-x (hero-position hero)))))
(runner-x (hero-runner hero)))
(define (hero-y hero)
"return the y coordinate as an integer"
(inexact->exact (floor (vec2-y (hero-position hero)))))
(runner-y (hero-runner hero))
)
(define (hero-with-x hero x)
(hero-with-position hero (vec2 x (hero-y hero))))
(define (hero-state hero)
"return the current state of the hero"
(runner-state (hero-runner hero)))
(define (hero-with-y hero y)
(hero-with-position hero (vec2 (hero-x hero) y)))
(define (hero-position hero)
"return the current position of the hero"
(runner-position (hero-runner hero)))
;; return next state of hero
;; @returns 'go-left 'go-right 'climb 'fall 'stationary
(define (next-state hero level inputs)
(let* ((position (hero-position hero))
(state (hero-state hero))
(tile-below (level-tile-at level (vec2 (hero-x hero) (1- (hero-y hero))))))
(cond
((equal? (level-tile-at level position) 'ladder) 'climb)
((> (floor-remainder (hero-y hero) level-cell-size) 0) 'fall)
((equal? tile-below 'empty) '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 (next-position position state inputs distance)
(case state
((fall) (vec2- position (vec2 0 distance)))
((go-left) (vec2- position (vec2 distance 0)))
((go-right) (vec2+ position (vec2 distance 0)))
((stationary) position)
((climb) (fold (lambda (input movement)
(vec2+ movement (input->movement input distance)))
position
inputs))
(else position)
))
(define speed 50.0)
(define (hero-update hero level inputs dt)
(let* ((state (next-state hero level inputs))
(distance (* dt speed))
(position (next-position (hero-position hero) (hero-state hero) inputs distance))
(tile (level-tile-at level position))
)
(hero-with-state
(if (member tile '(empty ladder other))
(hero-with-position hero position)
(hero-with-position hero (vec2 (hero-x hero) (hero-y hero))) ;; round position
)
state)))
(hero-with-runner hero (runner-update (hero-runner hero) level inputs dt)))
@ -109,57 +64,10 @@
(hero (hero-load level))
(default-position (level-find-hero level)))
(test-assert (hero? hero))
(test-equal default-position (hero-position hero))
(test-equal default-state (hero-state hero))
(test-equal default-bloat (hero-bloat hero))
(test-equal (vec2 10 20) (hero-position (hero-with-position hero (vec2 10 20))))
(test-equal default-position (hero-position hero))
(test-equal 'go-left (hero-state (hero-with-state hero 'go-left)))
(test-equal default-state (hero-state hero))
(test-equal 1.5 (hero-bloat (hero-with-bloat hero 1.5)))
(test-equal default-bloat (hero-bloat hero))
(test-equal 16 (hero-x (hero-with-position hero (vec2 16.34 20.78))))
(test-equal 20 (hero-y (hero-with-position hero (vec2 16.34 20.78))))
(test-equal 'fall (next-state hero level '()))
(let ((hero (hero-with-position hero (vec2 16 16))))
(test-equal 'stationary (next-state hero level '()))
(test-equal 'go-left (next-state hero level '(left)))
(test-equal 'go-right (next-state hero level '(right))))
(let ((hero (hero-with-position hero (vec2 48 32))))
(test-equal 'stationary (next-state hero level '())))
(let ((hero (hero-with-position hero (vec2 48 31))))
(test-equal 'climb (next-state hero level '())))
(let ((hero (hero-with-position hero (vec2 32 31))))
(test-equal 'fall (next-state hero level '())))
(test-equal (vec2 32.0 31.0) (next-position (vec2 32.0 32.0) 'fall '() 1.0))
(test-equal (vec2 31.0 32.0) (next-position (vec2 32.0 32.0) 'go-left '() 1.0))
(test-equal (vec2 33.0 32.0) (next-position (vec2 32.0 32.0) 'go-right '() 1.0))
(test-equal (vec2 32.0 32.0) (next-position (vec2 32.0 32.0) 'stationary '() 1.0))
(test-equal (vec2 31.0 32.0) (next-position (vec2 32.0 32.0) 'climb '(left) 1.0))
(test-equal (vec2 33.0 32.0) (next-position (vec2 32.0 32.0) 'climb '(right) 1.0))
(test-equal (vec2 32.0 31.0) (next-position (vec2 32.0 32.0) 'climb '(down) 1.0))
(test-equal (vec2 32.0 33.0) (next-position (vec2 32.0 32.0) 'climb '(up) 1.0))
(test-equal
(vec2 32.0 16.0)
(hero-position
(hero-update
(hero-with-state
(hero-with-position hero (vec2 32 16.3))
'fall)
level
'()
0.017
)
))
)
(test-end "hero-model"))
(test-end "hero-model")

159
game/model/runner.scm Normal file
View file

@ -0,0 +1,159 @@
;; 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 (level-tile-at 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)
((equal? tile-below 'empty) '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 (next-position position state inputs distance)
(case state
((fall) (vec2- position (vec2 0 distance)))
((go-left) (vec2- position (vec2 distance 0)))
((go-right) (vec2+ position (vec2 distance 0)))
((stationary) position)
((climb) (fold (lambda (input movement)
(vec2+ movement (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 (runner-position runner) (runner-state runner) inputs distance))
(tile (level-tile-at level position))
)
(runner-with-state
(if (member tile '(empty ladder other))
(runner-with-position runner position)
(runner-with-position runner (vec2 (runner-x runner) (runner-y runner))) ;; round position
)
state)))
;; 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 (vec2 32.0 31.0) (next-position (vec2 32.0 32.0) 'fall '() 1.0))
(test-equal (vec2 31.0 32.0) (next-position (vec2 32.0 32.0) 'go-left '() 1.0))
(test-equal (vec2 33.0 32.0) (next-position (vec2 32.0 32.0) 'go-right '() 1.0))
(test-equal (vec2 32.0 32.0) (next-position (vec2 32.0 32.0) 'stationary '() 1.0))
(test-equal (vec2 31.0 32.0) (next-position (vec2 32.0 32.0) 'climb '(left) 1.0))
(test-equal (vec2 33.0 32.0) (next-position (vec2 32.0 32.0) 'climb '(right) 1.0))
(test-equal (vec2 32.0 31.0) (next-position (vec2 32.0 32.0) 'climb '(down) 1.0))
(test-equal (vec2 32.0 33.0) (next-position (vec2 32.0 32.0) 'climb '(up) 1.0))
(test-equal
(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")