From bba87d2d253200d177daae44a5df969a0149dca2 Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Thu, 1 Jun 2023 23:24:36 -0500
Subject: Made the snake smart and added collision detection

- I made the snake smart!
  - now it follows the appple around the screen trying to eat it
  - figuring out collision logic and making sure the snake didn't eat itself and all was .. whoo boy, it was wild
  - but in the end it works well enough!
- Added game win/lose conditions
- Added fruit
  - will make that work tomorrow
  - hacky AS HECK! here be dragons yall
  - collision detection is full of special cases, and I don't like how it works
---
 README.md |  15 +++++
 apple.scm | 226 +++++++++++++++++++++++++++++++++++++++++++++++---------------
 2 files changed, 186 insertions(+), 55 deletions(-)

diff --git a/README.md b/README.md
index 9951e43..95b97b6 100644
--- a/README.md
+++ b/README.md
@@ -29,6 +29,21 @@ Here is a picture of the cool rock I found:
 
 ## Development log
 
+### 2023-06-01
+
+- Changed name to *apple*
+- Added a makefile for compilation
+
+- I made the snake smart!
+  - now it follows the appple around the screen trying to eat it
+  - figuring out collision logic and making sure the snake didn't eat itself and all was .. whoo boy, it was wild
+  - but in the end it works well enough!
+- Added game win/lose conditions
+- Added fruit
+  - will make that work tomorrow
+  - hacky AS HECK! here be dragons yall
+  - collision detection is full of special cases, and I don't like how it works
+
 ### 2023-05-31
 
 - Added color using the (yolk attrs) library
diff --git a/apple.scm b/apple.scm
index 5dae4eb..41e12f6 100755
--- a/apple.scm
+++ b/apple.scm
@@ -30,24 +30,37 @@ See COPYING for details.
 
 (define (main args)
   (parameterize ((world (make-world 80 25)))
-    (parameterize ((me (let-values (((x y) (random-point (world))))
-                         (make-thing 'me (world)
-                                     (with-attrs '(red) "ó") x y 2)))
-                   (snake (let-values (((x y) (random-point (world))))
-                            (make-snake (world) 5 (current-jiffy) 100 'left
-                                        (make-thing 'snake-head (world)
-                                                    "<" x y 2)
-                                        (list (make-thing 'snake-tail (world)
-                                                          "-" (+ 1 x) y 2))))))
-      (dynamic-wind game-setup
-                    game-loop
-                    game-cleanup)))
+    (parameterize ((me (make-thing 'me (world)
+                                   (with-attrs '(red) "ó") 10 10 2))
+                   (snake (make-snake (world) 5 (current-jiffy) 200 'left
+                                      (make-thing 'snake-head (world)
+                                                  "<" 20 20 2)
+                                      (list)))
+                   (fruit (make-thing 'fruit (world)
+                                      (random-choice (fruits)) 10 20 1)))
+      (case (dynamic-wind game-setup
+                          game-loop
+                          game-cleanup)
+        ((win) (print "Congrats!"))
+        ((lose) (print "Better luck next time."))
+        (else))
+      (print "Thanks for playing!")))
   #t)
 
+;;; Parameters
 (define me (make-parameter #f))
-(define world (make-parameter #f))
 (define snake (make-parameter #f))
+(define fruit (make-parameter #f))
+(define world (make-parameter #f))
+(define game-end (make-parameter #f))
+
+(define fruits
+  (make-parameter (list (with-attrs '(yellow) ")")
+                        (with-attrs '(green) "ò")
+                        (with-attrs '(magenta) "%")
+                        (with-attrs '(blue) "*"))))
 
+;;; Main game elements
 (define (game-setup)
   ;; Prepare terminal
   (stty '(raw (not echo)))
@@ -72,16 +85,20 @@ See COPYING for details.
 (define (game-loop)
   (call/cc
    (lambda (return)
-     (let loop ((now (current-jiffy)))
-       (handle-input return)
-       (snake-step (snake) now)
-       (world-draw (world))
-       (loop (current-jiffy))))))
-
-(define (handle-input done)
+     (parameterize ((game-end return))
+       (let loop ((now (current-jiffy)))
+         (unless (and (eq? (thing-x (fruit)) (thing-x (me)))
+                      (eq? (thing-y (fruit)) (thing-y (me))))
+           (thing-place! (fruit)))
+         (handle-input)
+         (snake-step (snake) now)
+         (world-draw (world))
+         (loop (current-jiffy)))))))
+
+(define (handle-input)
   (if (char-ready?)
       (match (readch)
-        (#\q (done))
+        ((or #\q #\) ((game-end) 'quit))
         (#\k (up!))
         (#\j (down!))
         (#\l (right!))
@@ -95,7 +112,7 @@ See COPYING for details.
                            (#\D (left!))
                            (_ #f)))
                     (_ #f)))
-        (x (log* x)))
+        (_ #f))
       #f))
 
 (define (readch)
@@ -126,6 +143,9 @@ See COPYING for details.
         (loop (random-x world) (random-y world))
         (values x y))))
 
+(define (random-choice . choices)
+  (list-ref choices (random-int (length choices))))
+
 ;;; Drawing stuff
 
 (define (draw . instructions)
@@ -198,10 +218,19 @@ See COPYING for details.
                  (thing-place! (wall w x y)))
                 (else)))
              world)
+  (thing-pos-randomize! (me))
   (thing-place! (me))
+  (thing-pos-randomize! (snake-head (snake)))
   (thing-place! (snake-head (snake)))
   (for-each (lambda (t) (thing-place! t))
-            (snake-tail (snake))))
+            (snake-tail (snake)))
+  (thing-pos-randomize! (fruit))
+  (thing-place! (fruit)))
+
+(define (thing-pos-randomize! thing)
+  (let-values (((x y) (random-point (thing-world thing))))
+    (thing-x-set! thing x)
+    (thing-y-set! thing y)))
 
 ;;; Things
 
@@ -249,7 +278,8 @@ See COPYING for details.
          (other (world-get world new-x new-y)))
     (cond
      ((and (thing? other)
-           (> (thing-z other) (thing-z thing))))
+           (<= (thing-z thing) (thing-z other)))
+      (handle-collision thing other))
      (else
       (cond ((< new-x 1)
              (set! new-x 1))
@@ -261,6 +291,40 @@ See COPYING for details.
              (set! new-y (- (world-height world) 1))))
       (thing-move! thing new-x new-y)))))
 
+;;; XXX: these are hacky
+(define (me? x)
+  (and (thing? x)
+       (eq? 'me (thing-name x))))
+
+(define (snake-head? x)
+  (and (thing? x)
+       (eq? 'snake-head (thing-name x))))
+;;; hacky-end
+
+(define (handle-collision a b)
+  (cond
+   ((or (and (me? a) (snake-head? b))
+        (and (snake-head? a) (me? b)))
+    (game-lose))
+   ((or (and (snake-head? a) (thing? b))
+        (and (thing? a) (snake-head? b)))
+    (game-win))
+   (else)))
+
+(define (game-win)
+  (draw (cursor-move 10 10)
+        "YOU WIN!")
+  (readch)
+  (newline)
+  ((game-end) 'win))
+
+(define (game-lose)
+  (draw (cursor-move 10 10)
+        "YOU LOSE :(")
+  (readch)
+  (newline)
+  ((game-end) 'lose))
+
 (define (thing-up! thing)
   (thing-move-relative! thing 0 -1))
 
@@ -281,31 +345,38 @@ See COPYING for details.
 (define (thing-above thing)
   (if (< (thing-y thing) 1)
       #f
-      (world-get (thing-world thing)
-                 (thing-x thing)
-                 (- (thing-y thing) 1))))
+      (let ((t (world-get (thing-world thing)
+                          (thing-x thing)
+                          (- (thing-y thing) 1))))
+        (and (thing? t)
+             (thing-name t)))))
 
 (define (thing-below thing)
   (if (> (thing-y thing) (world-height (thing-world thing)))
       #f
-      (world-get (thing-world thing)
-                 (thing-x thing)
-                 (+ (thing-y thing) 1))))
+      (let ((t (world-get (thing-world thing)
+                          (thing-x thing)
+                          (+ (thing-y thing) 1))))
+        (and (thing? t)
+             (thing-name t)))))
 
 (define (thing-to-left thing)
   (if (< (thing-x thing) 1)
       #f
-      (world-get (thing-world thing)
-                 (- (thing-x thing) 1)
-                 (thing-y thing))))
+      (let ((t (world-get (thing-world thing)
+                          (- (thing-x thing) 1)
+                          (thing-y thing))))
+        (and (thing? t)
+             (thing-name t)))))
 
 (define (thing-to-right thing)
   (if (> (thing-x thing) (world-width (thing-world thing)))
       #f
-      (world-get (thing-world thing)
-                 (+ (thing-x thing) 1)
-                 (thing-y thing)
-                 )))
+      (let ((t (world-get (thing-world thing)
+                          (+ (thing-x thing) 1)
+                          (thing-y thing))))
+        (and (thing? t)
+             (thing-name t)))))
 
 ;;; snake
 
@@ -347,17 +418,18 @@ See COPYING for details.
 (define (snake-step snake now)
   (when (> now (+ (snake-mtime snake) (snake-wait snake)))
     (let ((new-tail (make-thing 'snake-tail (snake-world snake)
-                                (if (snake-vertical? snake)
-                                    "|"
-                                    "-")
+                                "∙"
+                                #;(if (snake-vertical? snake)
+                                "|"
+                                "-")
                                 (snake-x snake)
                                 (snake-y snake)
                                 (snake-z snake))))
       (snake-update-head! snake)
+      (snake-update-direction! snake)
       (apply thing-move-relative!
              (snake-head snake)
              (direction->velocity (snake-direction snake)))
-      (snake-update-direction! snake)
       (for-each (lambda (t) (world-set! (snake-world snake)
                                    (thing-x t)
                                    (thing-y t)
@@ -391,18 +463,62 @@ See COPYING for details.
                      ((left) "<")
                      ((up) "^"))))
 
+(define (snake-decide-move snake) ; snake => direction
+  (let* ((head (snake-head snake))
+         (direction (snake-direction snake))
+         (snake-x (snake-x snake))
+         (snake-y (snake-y snake))
+         (me-x (thing-x (me)))
+         (me-y (thing-y (me)))
+         (new-dir
+          ;; Initial decision
+          (cond
+           ;; If `me' is right there, move toward it
+           ((eq? (thing-above head) 'me) 'up)
+           ((eq? (thing-below head) 'me) 'down)
+           ((eq? (thing-to-right head) 'me) 'right)
+           ((eq? (thing-to-left head) 'me) 'left)
+           ;; Otherwise, if about to collide with something, dodge it.
+           ((or (and (thing-above head)
+                     (eq? direction 'up))
+                (and (thing-below head)
+                     (eq? direction 'down)))
+            (if (thing-to-left head) 'right 'left))
+           ((or (and (thing-to-right head)
+                     (eq? direction 'right))
+                (and (thing-to-left head)
+                     (eq? direction 'left)))
+            (if (thing-above head) 'down 'up))
+           ;; Otherwise, move toward `me'
+           ((< snake-x me-x)
+            (if (> (abs (- snake-x me-x))
+                   (abs (- snake-y me-y)))
+                'right
+                (if (< snake-y me-y) 'down 'up)))
+           ((> snake-x me-x)
+            (if (> (abs (- snake-x me-x))
+                   (abs (- snake-y me-y)))
+                'left
+                (if (< snake-y me-y) 'down 'up)))
+           ((= snake-x me-x) (cond
+                              ((< snake-y me-y) 'down)
+                              ((> snake-y me-y) 'up)
+                              (else ((game-end) 'lose))))
+           ;; Otherwise, keep going how we're going
+           (else (snake-direction snake)))))
+    ;; Don't let the snake double back into itself
+    (cond
+     ((or (and (eq? direction 'right)
+               (eq? new-dir 'left))
+          (and (eq? direction 'left)
+               (eq? new-dir 'right)))
+      (if (< snake-y me-y) 'down 'up))
+     ((or (and (eq? direction 'up)
+               (eq? new-dir 'down))
+          (and (eq? direction 'down)
+               (eq? new-dir 'up)))
+      (if (< snake-x me-x) 'right 'left))
+     (else new-dir))))
+
 (define (snake-update-direction! snake)
-  (let ((head (snake-head snake)))
-    (case (snake-direction snake)
-      ((up)
-       (when (thing-above head)
-         (snake-direction-set! snake 'left)))
-      ((down)
-       (when (thing-below head)
-         (snake-direction-set! snake 'right)))
-      ((left)
-       (when (thing-to-left head)
-         (snake-direction-set! snake 'down)))
-      ((right)
-       (when (thing-to-right head)
-         (snake-direction-set! snake 'up))))))
+  (snake-direction-set! snake (snake-decide-move snake)))
-- 
cgit 1.4.1-21-gabe81