1 files changed, 123 insertions, 13 deletions

@@ -1,17 +1,23 @@
 #!/bin/sh
 #| -*- scheme -*-
 exec csi -R r7rs -ss "$0" "$@"
-game
+game --- 2023 lisp game jam
+(C) Case Duckworth <acdw@acdw.net>
+Distributed under the terms of the LATCRIFPL, v1.0.
+See COPYING for details.
 |#
 
 (import (scheme base)
+        (scheme time)
         (scheme write)
         (chicken io)
         (chicken port)
+        (chicken random)
         (yolk common)
         (yolk xterm)
         (yolk erase)
         (yolk cursor)
+        (srfi 1)
         (matchable)
         (stty))
 
@@ -40,7 +46,9 @@ game
         invisible-cursor)
   ;; Set up world
   (world-init (world))
-  (world-draw (world)))
+  (world-draw (world))
+  ;; Start snake
+  (snake-init (snake)))
 
 (define (game-cleanup)
   ;; Restore terminal
@@ -76,6 +84,8 @@ game
   (let ((c (integer->char (read-byte))))
     c))
 
+;;; Drawing stuff
+
 (define (draw . instructions)
   (for-each (lambda (i)
               (cond
@@ -84,7 +94,9 @@ game
                (else (error "Don't know how to draw" i))))
             instructions))
 
-(define-record-type world
+;;; World
+
+(define-record-type <world>
   (%make-world width height map)
   world?
   (width world-width world-width-set!)
@@ -146,9 +158,14 @@ game
                  (thing-place! w (wall x y)))
                 (else)))
              world)
-  (thing-place! world (me)))
+  (thing-place! world (me))
+  (thing-place! world (snake-head (snake)))
+  (for-each (lambda (t) (thing-place! world t))
+            (snake-tail (snake))))
+
+;;; Things
 
-(define-record-type thing
+(define-record-type <thing>
   (make-thing name look x y z attrs)
   thing?
   (name thing-name)
@@ -158,6 +175,20 @@ game
   (z thing-z thing-z-set!)
   (attrs thing-attrs thing-attrs-set!))
 
+(define (thing-attr-get thing attr)
+  (let ((x (assoc attr (thing-attrs thing))))
+    (if x
+        (cdr x)
+        #f)))
+
+(define (thing-attr-set! thing attr val)
+  (let ((x (assoc attr (thing-attrs thing))))
+    (if x
+        (set-cdr! x val)
+        (thing-attrs-set! thing
+                          (cons (cons attr val)
+                                (thing-attrs thing))))))
+
 (define (thing-place! world thing)
   (world-set! world (thing-x thing) (thing-y thing) thing))
 
@@ -185,6 +216,18 @@ game
              (set! new-y (- (world-height world) 1))))
       (thing-move! world thing new-x new-y)))))
 
+(define (thing-up! thing)
+  (thing-move-relative! (world) thing 0 -1))
+
+(define (thing-down! thing)
+  (thing-move-relative! (world) thing 0 1))
+
+(define (thing-right! thing)
+  (thing-move-relative! (world) thing 1 0))
+
+(define (thing-left! thing)
+  (thing-move-relative! (world) thing -1 0))
+
 (define (wall x y)
   (make-thing 'wall "#" x y 100 '()))
 
@@ -192,14 +235,81 @@ game
   (make-parameter
    (make-thing 'me "@" 40 10 2 '())))
 
-(define (up!)
-  (thing-move-relative! (world) (me) 0 -1))
+(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)))
+
+;;; snake
+
+(define-record-type <snake>
+  (make-snake length head tail)
+  snake?
+  (length snake-length snake-length-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-x snake)
+  (thing-x (snake-head snake)))
+
+(define (snake-y snake)
+  (thing-y (snake-head snake)))
+
+(define (snake-z snake)
+  (thing-z (snake-head snake)))
 
-(define (down!)
-  (thing-move-relative! (world) (me) 0 1))
+(define (snake-direction snake)
+  (thing-attr-get (snake-head snake) 'dir))
 
-(define (right!)
-  (thing-move-relative! (world) (me) 1 0))
+(define (snake-init snake)
+  (let loop (())))
 
-(define (left!)
-  (thing-move-relative! (world) (me) -1 0))
+(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))))