From e27621b86baa80a35586e111eb56aeb86b09f68a Mon Sep 17 00:00:00 2001
From: Peter Tillemans <pti@snamellit.com>
Date: Tue, 21 May 2024 00:56:54 +0200
Subject: [PATCH] add inputs detection and allow level tile inspection

---
 game/main.scm         | 38 +++++++++++++++++++++++++++++++++++---
 game/model/level.scm  | 28 ++++++++++++++++++++++++----
 game/render/level.scm |  2 +-
 3 files changed, 60 insertions(+), 8 deletions(-)

diff --git a/game/main.scm b/game/main.scm
index 913954c..4fc9f39 100644
--- a/game/main.scm
+++ b/game/main.scm
@@ -12,11 +12,13 @@
   #:use-module (chickadee graphics text)
   #:use-module (chickadee graphics tile-map)
   #:use-module (system repl coop-server)
+  #:use-module (srfi srfi-1)
   #:export (launch-game))
 
 (define level #f)
 (define repl #f)
 (define hero #f)
+(define inputs '())
 
 (define (load)
   (render-level-load)
@@ -37,9 +39,39 @@
   (render-hero hero)
   )
 
+(define (set-add set item)
+  (if (member item set)
+      set
+      (cons item set)))
+
+
+(define (key-press key)
+  (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))))
+
+
+(define (key-release key)
+  (set! inputs
+    (cond ((eq? key 'left) (delete 'left inputs))
+          ((eq? key 'right) (delete 'right inputs))
+          ((eq? key 'up) (delete 'up inputs))
+          ((eq? key 'down) (delete 'down inputs))
+          ((eq? key 'space) (delete 'dig inputs))
+          (else inputs))))
+
 (define (launch-game args)
-  (run-game #:load (lambda () (load))
-            #:update (lambda (dt) (update dt))
-            #:draw (lambda (alpha) (draw alpha))))
+  (run-game 
+   ;; #:title "Bloatrunner"
+   #: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))
+   ))
 
 
diff --git a/game/model/level.scm b/game/model/level.scm
index b124c82..13a59aa 100644
--- a/game/model/level.scm
+++ b/game/model/level.scm
@@ -66,10 +66,18 @@
   (level-parse (call-with-input-file filename get-string-all)))
 
 
-(define (level-tile-at level x y)
-  (let ((index (+ (* y (level-width level)) x)))
+(define (level-tile-at-row-col level row col )
+  (let ((index (+ (* row (level-width level)) col)))
     (vector-ref (level-tiles level) index)))
 
+(define cell-size 16)
+
+(define (coord->cell coord)
+  (inexact->exact (floor (/ coord cell-size))))
+
+(define (level-tile-at level x y )
+  (level-tile-at-row-col level (coord->cell y) (coord->cell x)))
+
 
 (test-begin "level")
 
@@ -99,11 +107,23 @@
 (test-equal (level-height (level-parse-file "assets/levels/level-1.map")) 30)
 
 (test-equal 
-    (level-tile-at (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 1)
+    (level-tile-at-row-col (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 1)
   'player)
 
 (test-equal 
-    (level-tile-at (level-parse "WWWWW\nWP GW\nWWWWW\n") 3 1)
+    (level-tile-at-row-col (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 3)
   'goal)
 
+(test-equal 
+    (level-find-player (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 3)
+  (vec2 16 16))
+
+(test-equal 
+    (level-find-goal (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 3)
+  (vec2 48 16))
+
+(test-equal 
+    (level-find-goal (level-parse "WWWWW\nWE EW\nWWWWW\n") 1 3)
+  (list (vec 16 16) (vec2 48 16)))
+
 (test-end "level")
diff --git a/game/render/level.scm b/game/render/level.scm
index 1bc66a7..bdd7a30 100644
--- a/game/render/level.scm
+++ b/game/render/level.scm
@@ -49,7 +49,7 @@
         (let* 
             ((x (* 16 column))
              (y (* 16 row))
-             (tile (level-tile-at level column row))
+             (tile (level-tile-at level x y))
              (texture-region (texture-atlas-ref tile-atlas (level-tile-index tile))))
           (sprite-batch-add! sprite-batch (vec2 x y) 
                              #:texture-region texture-region)))