diff --git a/game/model/runner.scm b/game/model/runner.scm new file mode 100644 index 0000000..49f06b3 --- /dev/null +++ b/game/model/runner.scm @@ -0,0 +1,158 @@ +;; 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 + (%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) + (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")