1 files changed, 191 insertions, 113 deletions

@@ -17,11 +17,12 @@ See COPYING for details.
         (yolk xterm)
         (yolk erase)
         (yolk cursor)
+        (yolk attrs)
         (srfi 18)
         (matchable)
         (stty))
 
-(define (log . xs)
+(define (log* . xs)
   (with-output-to-port (current-error-port)
     (lambda ()
       (for-each (lambda (x) (display x) (display " ") x)
@@ -30,11 +31,24 @@ See COPYING for details.
 
 (define (main args)
   (parameterize ((world (make-world 80 25)))
-    (dynamic-wind game-setup
-                  game-loop
-                  game-cleanup))
+    (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)))
   #t)
 
+(define me (make-parameter #f))
+(define world (make-parameter #f))
+(define snake (make-parameter #f))
+
 (define (game-setup)
   ;; Prepare terminal
   (stty '(raw (not echo)))
@@ -46,9 +60,7 @@ See COPYING for details.
         invisible-cursor)
   ;; Set up world
   (world-init (world))
-  (world-draw (world))
-  ;; Start snake
-  (snake-init (snake)))
+  (world-draw (world)))
 
 (define (game-cleanup)
   ;; Restore terminal
@@ -59,32 +71,62 @@ See COPYING for details.
         visible-cursor))
 
 (define (game-loop)
-  (let loop ((c (readch)))
-    (if (eq? c 'done)
-        #t
-        (let ((done? #f))
-          (match c
-            ((or #\q #\)
-             (set! done? #t))
-            ;; Escape characters
-            (#\escape
-             (match (readch)
-               (#\[ (match (readch)
-                      (#\A (up!))
-                      (#\B (down!))
-                      (#\C (right!))
-                      (#\D (left!))
-                      (else)))
-               (else)))
-            (else))
-          (snake-step (snake) (world))
-          (world-draw (world))
-          (loop (if done? 'done (readch)))))))
+  (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)
+  (if (char-ready?)
+      (match (readch)
+        (#\q (done))
+        (#\k (up!))
+        (#\j (down!))
+        (#\l (right!))
+        (#\h (left!))
+        ;; Escape characters
+        (#\escape (match (readch)
+                    (#\[ (match (readch)
+                           (#\A (up!))
+                           (#\B (down!))
+                           (#\C (right!))
+                           (#\D (left!))
+                           (_ #f)))
+                    (_ #f)))
+        (x (log* x)))
+      #f))
 
 (define (readch)
   (let ((c (integer->char (read-byte))))
     c))
 
+;;; random
+
+(define random-int
+  (case-lambda
+    (() (pseudo-random-integer 100))
+    ((max) (pseudo-random-integer max))
+    ((min max)
+     (let ((max (if (> max min) max min))
+           (min (if (< min max) min max)))
+       (+ min (pseudo-random-integer (- max min)))))))
+
+(define (random-x world)
+  (random-int 1 (- (world-width world) 1)))
+
+(define (random-y world)
+  (random-int 1 (- (world-height world) 1)))
+
+(define (random-point world)
+  (let loop ((x (random-x world))
+             (y (random-y world)))
+    (if (world-get world x y)
+        (loop (random-x world) (random-y world))
+        (values x y))))
+
 ;;; Drawing stuff
 
 (define (draw . instructions)
@@ -128,8 +170,6 @@ See COPYING for details.
 (define (make-world width height)
   (%make-world width height (make-vector (* width height) #f)))
 
-(define world (make-parameter #f))
-
 (define (for-world proc world)
   (do ((y 1 (+ y 1)))
       ((= y (world-height world)) #t)
@@ -156,25 +196,28 @@ See COPYING for details.
                      (= y 1)
                      (= x (- (world-width world) 1))
                      (= y (- (world-height world) 1)))
-                 (thing-place! w (wall x y)))
+                 (thing-place! (wall w x y)))
                 (else)))
              world)
-  (thing-place! world (me))
-  (thing-place! world (snake-head (snake)))
-  (for-each (lambda (t) (thing-place! world t))
+  (thing-place! (me))
+  (thing-place! (snake-head (snake)))
+  (for-each (lambda (t) (thing-place! t))
             (snake-tail (snake))))
 
 ;;; Things
 
 (define-record-type <thing>
-  (make-thing name look x y z attrs)
+  (make-thing name world look x y z)
   thing?
   (name thing-name)
+  (world thing-world thing-world-set!)
   (look thing-look thing-look-set!)
   (x thing-x thing-x-set!)
   (y thing-y thing-y-set!)
-  (z thing-z thing-z-set!)
-  (attrs thing-attrs thing-attrs-set!))
+  (z thing-z thing-z-set!))
+
+(define (wall w x y)
+  (make-thing 'wall w "#" x y 100))
 
 (define (thing-attr-get thing attr)
   (let ((x (assoc attr (thing-attrs thing))))
@@ -190,17 +233,19 @@ See COPYING for details.
                           (cons (cons attr val)
                                 (thing-attrs thing))))))
 
-(define (thing-place! world thing)
-  (world-set! world (thing-x thing) (thing-y thing) thing))
+(define (thing-place! thing)
+  (world-set! (thing-world thing) (thing-x thing) (thing-y thing) thing))
 
-(define (thing-move! world thing x y)
-  (world-set! world (thing-x thing) (thing-y thing) #f)
-  (thing-x-set! thing x)
-  (thing-y-set! thing y)
-  (world-set! world x y thing))
+(define (thing-move! thing x y)
+  (let ((world (thing-world thing)))
+    (world-set! world (thing-x thing) (thing-y thing) #f)
+    (thing-x-set! thing x)
+    (thing-y-set! thing y)
+    (world-set! world x y thing)))
 
-(define (thing-move-relative! world thing dx dy)
-  (let* ((new-x (+ (thing-x thing) dx))
+(define (thing-move-relative! thing dx dy)
+  (let* ((world (thing-world thing))
+         (new-x (+ (thing-x thing) dx))
          (new-y (+ (thing-y thing) dy))
          (other (world-get world new-x new-y)))
     (cond
@@ -215,72 +260,67 @@ See COPYING for details.
              (set! new-y 1))
             ((> new-y (- (world-height world) 1))
              (set! new-y (- (world-height world) 1))))
-      (thing-move! world thing new-x new-y)))))
+      (thing-move! thing new-x new-y)))))
 
 (define (thing-up! thing)
-  (thing-move-relative! (world) thing 0 -1))
+  (thing-move-relative! thing 0 -1))
 
 (define (thing-down! thing)
-  (thing-move-relative! (world) thing 0 1))
+  (thing-move-relative! thing 0 1))
 
 (define (thing-right! thing)
-  (thing-move-relative! (world) thing 1 0))
+  (thing-move-relative! thing 1 0))
 
 (define (thing-left! thing)
-  (thing-move-relative! (world) thing -1 0))
-
-(define (wall x y)
-  (make-thing 'wall "#" x y 100 '()))
-
-(define me
-  (make-parameter
-   (make-thing 'me "@" 40 10 2 '())))
+  (thing-move-relative! thing -1 0))
 
 (define (up!) (thing-up! (me)))
 (define (down!) (thing-down! (me)))
 (define (left!) (thing-left! (me)))
 (define (right!) (thing-right! (me)))
 
-;;; random
-
-(define random-int
-  (case-lambda
-    (() (pseudo-random-integer 100))
-    ((max) (pseudo-random-integer max))
-    ((min max)
-     (let ((max (if (> max min) max min))
-           (min (if (< min max) min max)))
-       (+ min (pseudo-random-integer (- max min)))))))
-
-(define (random-x world)
-  (random-int 1 (- (world-width world) 1)))
-
-(define (random-y world)
-  (random-int 1 (- (world-height world) 1)))
+(define (thing-above thing)
+  (if (< (thing-y thing) 1)
+      #f
+      (world-get (thing-world thing)
+                 (thing-x thing)
+                 (- (thing-y thing) 1))))
+
+(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))))
+
+(define (thing-to-left thing)
+  (if (< (thing-x thing) 1)
+      #f
+      (world-get (thing-world thing)
+                 (- (thing-x thing) 1)
+                 (thing-y thing))))
+
+(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)
+                 )))
 
 ;;; snake
 
 (define-record-type <snake>
-  (make-snake length head tail)
+  (make-snake world length mtime wait direction head tail)
   snake?
   (length snake-length snake-length-set!)
+  (world snake-world snake-world-set!)
+  (mtime snake-mtime snake-mtime-set!)
+  (direction snake-direction snake-direction-set!)
+  (wait snake-wait snake-wait-set!)
   (head snake-head snake-head-set!)
   (tail snake-tail snake-tail-set!))
 
-(define snake
-  (make-parameter
-   (make-snake 5
-               (make-thing 'snake-head "<" 60 20 2
-                           '((dir . (-1 0))))
-               (list (make-thing 'snake-tail "-" 61 20 2 '())
-                     #;(make-thing 'snake-tail "-" 62 20 2 '())
-                     #;(make-thing 'snake-tail "-" 63 20 2 '())
-                     #;(make-thing 'snake-tail "-" 64 20 2 '())
-                     #;(make-thing 'snake-tail "-" 65 20 2 '())))))
-
-(define (snake-init snake)
-  #f)
-
 (define (snake-x snake)
   (thing-x (snake-head snake)))
 
@@ -290,9 +330,6 @@ See COPYING for details.
 (define (snake-z snake)
   (thing-z (snake-head snake)))
 
-(define (snake-direction snake)
-  (thing-attr-get (snake-head snake) 'dir))
-
 (define (take* xs n)
   ;;; Like `take' from SRFI 1, but doesn't choke on too-short lists.
   (unless (and (integer? n)
@@ -308,24 +345,65 @@ See COPYING for details.
               (- n 1)
               (cons (car xs) acc)))))
 
-(define (snake-step snake world)
-  (let ((new-tail (make-thing 'snake-tail
-                              (if (zero? (car (snake-direction snake)))
-                                  "|"
-                                  "-")
-                              (snake-x snake)
-                              (snake-y snake)
-                              (snake-z snake)
-                              '())))
-    (apply thing-move-relative!
-           world
-           (snake-head snake)
-           (snake-direction snake))
-    (for-each (lambda (t) (world-set! world (thing-x t) (thing-y t) #f))
-              (snake-tail snake))
-    (snake-tail-set! snake
-                     (take* (cons new-tail
-                                 (snake-tail snake))
-                           (snake-length snake)))
-    (for-each (lambda (t) (thing-place! world t))
-              (snake-tail snake))))
+(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)
+                                    "|"
+                                    "-")
+                                (snake-x snake)
+                                (snake-y snake)
+                                (snake-z snake))))
+      (snake-update-head! 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)
+                                   #f))
+                (snake-tail snake))
+      (snake-tail-set! snake
+                       (take* (cons new-tail
+                                    (snake-tail snake))
+                              (snake-length snake)))
+      (for-each (lambda (t) (thing-place! t))
+                (snake-tail snake))
+      (snake-mtime-set! snake now))))
+
+(define (direction->velocity direction)
+  (case direction
+    ((up) '(0 -1))
+    ((down) '(0 1))
+    ((left) '(-1 0))
+    ((right) '(1 0))
+    (else direction)))
+
+(define (snake-vertical? snake)
+  (or (eq? (snake-direction snake) 'up)
+      (eq? (snake-direction snake) 'down)))
+
+(define (snake-update-head! snake)
+  (thing-look-set! (snake-head snake)
+                   (case (snake-direction snake)
+                     ((right) ">")
+                     ((down) "v")
+                     ((left) "<")
+                     ((up) "^"))))
+
+(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))))))