add runner model

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 <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)
+  (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")