Polish exiting and add intro screen

1 files changed, 74 insertions, 33 deletions

@@ -38,14 +38,24 @@ See COPYING for details.
                                       (list)))
                    (fruit (make-thing 'fruit (world)
                                       (random-choice (fruits)) 10 20 2)))
-      (case (dynamic-wind game-setup
-                          game-loop
-                          game-cleanup)
-        ((win) (print "Congrats!"))
-        ((lose) (print "Better luck next time."))
-        (else))
-      (print "Thanks for playing!")))
-  #t)
+      (game-intro)
+      (readch)
+      (game-exit-message (dynamic-wind game-setup
+                                       game-loop
+                                       game-cleanup)))))
+
+(define (game-exit-message msg)
+  (cond
+   ((eq? msg 'win)
+    (print "Congrats!")
+    #t)
+   ((eq? msg 'lose)
+    (print "Better luck next time.")
+    #t)
+   ((and (pair? msg)
+         (eq? (car msg) 'error))
+    (apply error "An error occurred" (cdr error))
+    #f)))
 
 ;;; Parameters
 (define me (make-parameter #f))
@@ -86,14 +96,37 @@ See COPYING for details.
   (call/cc
    (lambda (return)
      (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)))))))
+       (with-exception-handler
+           (lambda (e) (return (cons 'error e)))
+         (lambda ()
+           (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 (game-intro)
+  (draw #<#END
+        #erase-screen
+        A P P L E!
+        a Spring Lisp Game Jam 2023 entry
+        by Case Duckworth <acdw@acdw.net>
+
+        Welcome to APPLE, the game of SNAKE, except you're the apple instead!
+        Specifically, you're the RED APPLE #(thing-look (me)), running from the SNAKE #(thing-look (snake-head (snake)))·····.
+        Try to dodge the snake and get him to eat himself --- you can distract him
+        by going near other FRUIT #(fruits), which he'll eat instead of you.
+
+        Move using HJKL or arrow keys!  Quit with Q, and pause with ESC.
+
+        GOOD LUCK :D
+        Press ENTER to continue .....
+
+END
+        ))
 
 (define (handle-input)
   (if (char-ready?)
@@ -218,7 +251,6 @@ See COPYING for details.
                  (thing-place! (wall w x y)))
                 (else)))
              world)
-  (draw-title world 10 10)
   (thing-pos-randomize! (me))
   (thing-place! (me))
   (thing-pos-randomize! (snake-head (snake)))
@@ -233,14 +265,6 @@ See COPYING for details.
     (thing-x-set! thing x)
     (thing-y-set! thing y)))
 
-(define (draw-title world x y)
-    (for-each thing-place!
-              (list (make-thing 'a world (with-attrs '(italic dim) "A") x y 0)
-                    (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 2) y 0)
-                    (make-thing 'p world (with-attrs '(italic dim) "P") (+ x 4) y 0)
-                    (make-thing 'p world (with-attrs '(italic dim) "L") (+ x 6) y 0)
-                    (make-thing 'p world (with-attrs '(italic dim) "E") (+ x 8) y 0))))
-
 ;;; Things
 
 (define-record-type <thing>
@@ -326,18 +350,18 @@ See COPYING for details.
 
 (define (game-win)
   (draw (cursor-move 10 10)
-        "YOU WIN!")
+        "YOU WIN!                     ")
   (sleep 1)
+  (flush-input)
   (readch)
-  (newline)
   ((game-end) 'win))
 
 (define (game-lose)
   (draw (cursor-move 10 10)
-        "YOU LOSE :(")
+        "YOU LOSE :(                  ")
   (sleep 1)
+  (flush-input)
   (readch)
-  (newline)
   ((game-end) 'lose))
 
 (define (thing-up! thing)
@@ -508,6 +532,10 @@ See COPYING for details.
      ;; Otherwise, keep going how we're going
      (else (snake-direction snake)))))
 
+(define (edible? thing-name)
+  (or (eq? thing-name 'me)
+      (eq? thing-name 'fruit)))
+
 (define (snake-decide-move snake) ; snake => direction
   (let* ((head (snake-head snake))
          (direction (snake-direction snake))
@@ -515,10 +543,10 @@ See COPYING for details.
           ;; 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)
+           ((edible? (thing-above head)) 'up)
+           ((edible? (thing-below head)) 'down)
+           ((edible? (thing-to-right head)) 'right)
+           ((edible? (thing-to-left head)) 'left)
            ;; If about to collide with something, dodge it.
            ((or (and (thing-above head)
                      (eq? direction 'up))
@@ -559,3 +587,16 @@ See COPYING for details.
 
 (define (snake-update-direction! snake)
   (snake-direction-set! snake (snake-decide-move snake)))
+
+(define (%flush-input port)
+  (let loop ((ready? (char-ready? port)))
+    (if ready?
+        (begin (read-byte port)
+               (loop (char-ready? port)))
+        #t)))
+
+(define flush-input
+  (case-lambda
+    (() (%flush-input (current-input-port)))
+    ((port) (%flush-input port))))
+