diff --git a/game/main.scm b/game/main.scm index 8501495..9b1d7b7 100644 --- a/game/main.scm +++ b/game/main.scm @@ -1,4 +1,5 @@ (define-module (game main) + #:use-module (ice-9 pretty-print) #:use-module (game model level) #:use-module (game model hero) #:use-module (game render level) @@ -30,12 +31,9 @@ (define (update dt) (poll-coop-repl-server repl) - (set! hero - (hero-with-x - hero - (floor-remainder - (+ (hero-x hero) (* 50.0 dt)) - 608.0)))) + (set! hero (hero-update hero level inputs dt)) + (pretty-print hero) + ) (define (draw _alpha) (render-level-draw level) @@ -48,17 +46,20 @@ (cons item set))) -(define (key-press key) +(define (key-press key _modifiers _repeat?) + (pretty-print (list 'press key inputs)) (set! inputs (cond ((eq? key 'left) (set-add inputs 'left)) ((eq? key 'right) (set-add inputs 'right)) ((eq? key 'up) (set-add inputs 'up)) ((eq? key 'down) (set-add inputs 'down )) ((eq? key 'space) (set-add inputs 'dig )) - (else inputs)))) + (else inputs))) + ) -(define (key-release key) +(define (key-release key _modifiers) + (pretty-print (list 'release key inputs)) (set! inputs (cond ((eq? key 'left) (delete 'left inputs)) ((eq? key 'right) (delete 'right inputs)) @@ -73,8 +74,8 @@ #:load (lambda () (load)) #:update (lambda (dt) (update dt)) #:draw (lambda (alpha) (draw alpha)) - ;; #:key-press (lambda (key) (key-press key)) - ;; #:key-release (lambda (key) (key-release key)) + #:key-press (lambda (key modifiers repeat?) (key-press key modifiers repeat?)) + #:key-release (lambda (key modifiers) (key-release key modifiers)) )) diff --git a/game/model/hero.scm b/game/model/hero.scm index 583786b..276784d 100644 --- a/game/model/hero.scm +++ b/game/model/hero.scm @@ -1,9 +1,12 @@ ;; Game state and logic for the hero entity (define-module (game model hero) + #: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 (hero-load hero-state @@ -11,6 +14,7 @@ hero-position hero-with-position hero-x hero-with-x hero-y hero-with-y + hero-update )) @@ -22,7 +26,7 @@ (bloat hero-bloat hero-with-bloat) ;; 0.0 to 2.0, how much the hero is inflated ) -(define default-state 'stationary) +(define default-state 'falling) (define default-bloat 1.0) (define (hero-load level) @@ -43,12 +47,66 @@ (define (hero-with-y hero y) (hero-with-position hero (vec2 (hero-x hero) y))) + +;; 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) 'falling) + ((equal? tile-below 'empty) 'falling) + (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 + ((falling) (vec2- position (vec2 0 distance))) + ((climb) (vec2+ position (input->movement (car inputs) distance))) + ((go-left) (vec2- position (vec2 distance 0))) + ((go-right) (vec2+ position (vec2 distance 0))) + ((stationary) position) + ((ladder) (fold (lambda (input movement) + (vec2+ movement (input->movement input distance))) + position + inputs)) + (else position) + )) + (define speed 50.0) -;; Tests -[test-begin "hero model"] +(define (hero-update hero level inputs dt) + (let* ((state (next-state hero level inputs)) + (distance (* dt speed)) + (position (next-position (hero-position hero) state 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))) -(let* ((level (level-parse "WWWWW\nW...W\nW.P.W\nW...W\nWWWWW\n")) + + +;; Tests +[test-begin "hero-model"] + +(let* ((level (level-parse "WWWWW\nW...W\nW.P.W\nW..HW\nWWWWW\n")) (hero (hero-load level)) (default-position (level-find-hero level))) (test-assert (hero? hero)) @@ -66,6 +124,43 @@ (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 'falling (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 'falling (next-state hero level '()))) + + (test-equal (vec2 32.0 31.0) (next-position (vec2 32.0 32.0) 'falling '() 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)) + 'falling) + level + '() + 0.017 + ) + )) ) -(test-end "hero model") +(test-end "hero-model") diff --git a/game/model/level.scm b/game/model/level.scm index 56b2823..19d14f8 100644 --- a/game/model/level.scm +++ b/game/model/level.scm @@ -16,6 +16,7 @@ level-parse level-tile-at level-find-hero + level-cell-size )) (define-record-type @@ -73,13 +74,15 @@ (let ((index (+ (* row (level-width level)) col))) (vector-ref (level-tiles level) index))) -(define cell-size 16) +(define level-cell-size 16) (define (coord->cell coord) - (inexact->exact (floor (/ coord cell-size)))) + (inexact->exact (floor (/ coord level-cell-size)))) -(define (level-tile-at level x y ) - (level-tile-at-row-col level (coord->cell y) (coord->cell x))) +(define (level-tile-at level position ) + (let ((x (vec2-x position)) + (y (vec2-y position))) + (level-tile-at-row-col level (coord->cell y) (coord->cell x)))) (define (gen-coords a b) (append-map @@ -93,7 +96,7 @@ (define (level-find-tile level tile) (map - (lambda (rc) (vec2 (* cell-size (cadr rc)) (* cell-size (car rc)))) + (lambda (rc) (vec2 (* level-cell-size (cadr rc)) (* level-cell-size (car rc)))) (filter (lambda (rc) (equal? diff --git a/game/render/hero.scm b/game/render/hero.scm index 51288e7..38b6c36 100644 --- a/game/render/hero.scm +++ b/game/render/hero.scm @@ -17,17 +17,47 @@ (set! hero-atlas (split-texture hero-texture 32 32))) ;; start index of the walk animation -(define hero-walk-offset 56) +(define hero-walking-offset 56) +(define hero-falling-offset 32) +(define hero-climbing-offset 40) -(define (hero-sprite hero) - (let* ((x (inexact->exact (floor (vec2-x (hero-position hero))))) +(define (hero-sprite-walking hero) + (let* ((x (hero-x hero)) (animation-frame (remainder x 8)) - (hero-index (+ hero-walk-offset animation-frame))) + (hero-index (+ hero-walking-offset animation-frame))) + (texture-atlas-ref hero-atlas hero-index))) + +(define (hero-sprite-stationary _hero) + (texture-atlas-ref hero-atlas 56)) + + +(define (hero-sprite-falling hero) + (let* ((y (hero-y hero)) + (animation-frame (remainder y 8)) + (hero-index (+ hero-falling-offset animation-frame))) + (texture-atlas-ref hero-atlas hero-index))) + +(define (hero-sprite-climbing hero) + (let* ((y (hero-y hero)) + (animation-frame (remainder y 8)) + (hero-index (+ hero-climbing-offset animation-frame))) (texture-atlas-ref hero-atlas hero-index))) (define (render-hero hero) - (draw-sprite - (hero-sprite hero) - (vec2+ - (hero-position hero) - (vec2 -9.0 0.0)))) + (case (hero-state hero) + ((stationary) (draw-sprite + (hero-sprite-stationary hero) + (vec2+ (hero-position hero) (vec2 -9.0 1.0)))) + ((falling) (draw-sprite + (hero-sprite-falling hero) + (vec2+ (hero-position hero) (vec2 -9.0 1.0)))) + ((go-left) (draw-sprite + (hero-sprite-walking hero) + (vec2+ (hero-position hero) (vec2 23.0 1.0)) + #:scale (vec2 -1.0 1.0) + )) + ((go-right) (draw-sprite + (hero-sprite-walking hero) + (vec2+ (hero-position hero) (vec2 -9.0 1.0)))) + ) + ) diff --git a/game/render/level.scm b/game/render/level.scm index 5c76628..ebb2b7f 100644 --- a/game/render/level.scm +++ b/game/render/level.scm @@ -47,15 +47,12 @@ (for-each (lambda (column) (let* - ((x (* 16 column)) - (y (* 16 row)) - (tile (level-tile-at level x y)) + ((position (vec2 (* 16 column) (* 16 row))) + (tile (level-tile-at level position)) (texture-region (texture-atlas-ref tile-atlas (level-tile-index tile)))) - (display (format #f "tile ~a at ~a ~a~%" (level-tile-index tile) row column)) - (sprite-batch-add! sprite-batch (vec2 x y) + (sprite-batch-add! sprite-batch position #:texture-region texture-region))) (iota (level-width level) 0))) - (iota (level-height level) 0))) ;; render the level tiles diff --git a/game/util/pipe.scm b/game/util/pipe.scm new file mode 100644 index 0000000..a1b8c72 --- /dev/null +++ b/game/util/pipe.scm @@ -0,0 +1,28 @@ +(define-module (game util pipe) + #:export (-> ->>) + #:version (0 1 0)) + +;; Thread first macro. +;; The first s-expression will be inserted as the first argument of the next s-expesssion. +;; Example: (-> 100 (/ 10) (/ 5)) becomes (/ (/ 100 10) 5) +(define-syntax -> + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x (f . (f-rest ...))) (f x f-rest ...)) + ((_ x f) (f x)) + ((_ x (f . (f-rest ...)) rest ...) (-> (f x f-rest ...) rest ...)) + ((_ x f rest ...) (-> (f x) rest ...)) + )) + +;; Thread last macro. +;; The first s-expression will be inserted as the last argument of the next s-expesssion. +;; Example: (-> 100 (/ 10) (/ 5)) becomes (/ 5 (/ 10 100)) +(define-syntax ->> + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x (f ...)) (f ... x)) + ((_ x f) `(f x)) + ((_ x (f ...) rest ...) (->> (f ... x) rest ...)) + ((_ x f rest ...) (->> (f x) rest ...))))