2 changed files with 112 additions and 179 deletions
--- a/game/model/hero.scm
+++ b/game/model/hero.scm
@ -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-position hero-with-position
-            hero-x 
+            hero-x hero-with-x
-            hero-y
+            hero-y hero-with-y
            hero-update
            ))
 (define-immutable-record-type <hero>
-  (%make-hero runner bloat)
+  (%make-hero position state bloat)
  hero?
-  (runner hero-runner hero-with-runner)
+  (position hero-position hero-with-position)
  (state hero-state hero-with-state)                    ;; 'go-left 'go-right 'climb 'fall 'stationary
  (bloat hero-bloat hero-with-bloat)                    ;; 0.0 to 2.0, how much the hero is inflated
  )
@ -30,30 +30,75 @@
 (define default-bloat 1.0)
 (define (hero-load level)
-  "Create a hero at the position in the level map"
+  (let ((initial-position (level-find-hero level)))
-  (let ((runner (runner-load (level-find-hero level))))
+    (%make-hero initial-position default-state default-bloat)))
    (%make-hero runner default-bloat)))
 (define (hero-x hero)
  "return the x coordinate as an integer"
-  (runner-x (hero-runner hero)))
+  (inexact->exact (floor (vec2-x (hero-position hero)))))
 (define (hero-y hero)
  "return the y coordinate as an integer"
-  (runner-y (hero-runner hero))
+  (inexact->exact (floor (vec2-y (hero-position hero)))))
  )
-(define (hero-state hero)
+(define (hero-with-x hero x)
-  "return the current state of the hero"
+  (hero-with-position hero (vec2 x (hero-y hero))))
  (runner-state (hero-runner hero)))
-(define (hero-position hero)
+(define (hero-with-y hero y)
-  "return the current position of the hero"
+  (hero-with-position hero (vec2 (hero-x hero) y)))
  (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)
-  (hero-with-runner hero (runner-update (hero-runner 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)))
@ -64,10 +109,57 @@
       (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-end "hero-model"))
+  (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")
--- a/game/model/runner.scm
+++ b/game/model/runner.scm
@ -1,159 +0,0 @@
 ;; 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")