2 files changed, 156 insertions, 333 deletions

@@ -1,14 +1,13 @@
 #!/bin/sh
 #| -*- scheme -*-
 exec csi -R r7rs -ss "$0" "$@"
+game
 |#
-#+chicken (import r7rs)
 
 (import (scheme base)
         (scheme write)
         (chicken io)
         (chicken port)
-        (srfi 133)
         (yolk common)
         (yolk xterm)
         (yolk erase)
@@ -16,162 +15,191 @@ exec csi -R r7rs -ss "$0" "$@"
         (matchable)
         (stty))
 
-(define (draw . instructions)
-  (for-each (lambda (i)
-              (cond
-               ((string? i)
-                (display i))
-               ((list? i)
-                (apply draw i))))
-            instructions))
-
-(define me
-  (string-append "@" (cursor-left 1)))
-
-(define rock
-  (string-append "o" (cursor-left 1)))
-
-(define blank
-  (string-append " " (cursor-left 1)))
-
-(define WIDTH
-  (make-parameter 80))
-
-(define HEIGHT
-  (make-parameter 24))
+(define (log . xs)
+  (with-output-to-port (current-error-port)
+    (lambda ()
+      (for-each (lambda (x) (display x) (display " ") x)
+                xs)
+      (newline))))
 
-(define WORLD
-  (make-vector (* (WIDTH) (HEIGHT)) 0))
-
-(define (get-position x y)
-  (if (or (> x (WIDTH))
-          (< x 0)
-          (> y (HEIGHT))
-          (< y 0))
-      #f
-      (vector-ref WORLD (+ y (* (WIDTH) x)))))
-
-(define (set-position! x y thing)
-  (if (or (> x (WIDTH))
-          (< x 0)
-          (> y (HEIGHT))
-          (< y 0))
-      (error "Out of bounds" (list (WIDTH) (HEIGHT)) (list x y))
-  (vector-set! WORLD (+ y (* (WIDTH) x)) thing)))
-
-(define X
-  (make-parameter (/ (WIDTH) 2)))
-
-(define Y
-  (make-parameter (/ (HEIGHT) 2)))
-
-(define (move-up)
-  (unless (<= (Y) 2)
-    (draw blank (cursor-up 1) me)
-    (Y (- (Y) 1))))
-
-(define (move-left)
-  (unless (<= (X) 2)
-    (draw blank (cursor-left 1) me)
-    (X (- (X) 1))))
-
-(define (move-right)
-  (unless (>= (X) (- (WIDTH) 1))
-    (draw blank (cursor-right 1) me)
-    (X (+ (X) 1))))
-
-(define (move-down)
-  (unless (>= (Y) (- (HEIGHT) 1))
-    (draw blank (cursor-down 1) me)
-    (Y (+ (Y) 1))))
+(define (main args)
+  (parameterize ((world (make-world 80 25)))
+    (dynamic-wind game-setup
+                  game-loop
+                  game-cleanup))
+  #t)
 
 (define (game-setup)
+  ;; Prepare terminal
   (stty '(raw (not echo)))
   (set-buffering-mode! (current-input-port) #:none 1)
   (set-buffering-mode! (current-output-port) #:none 1)
-  ;; Set up screen
   (draw alt-buffer-enable
         erase-screen
         (cursor-save)
         invisible-cursor)
-
-  ;; Draw borders
-  (draw cursor-home
-        "/"
-        (list->string
-         (let loop ((c 1)
-                    (acc '()))
-           (if (>= c (- (WIDTH) 1))
-               acc
-               (loop (+ 1 c)
-                     (cons #\- acc)))))
-        "\\"
-        (let loop ((r 2)
-                   (acc '()))
-          (if (>= r (HEIGHT))
-              acc
-              (loop (+ 1 r)
-                    (append `(,(cursor-move 0 r)
-                              "|"
-                              ,(cursor-move (WIDTH) r)
-                              "|")
-                            acc))))
-        (cursor-move 1 (HEIGHT))
-        "\\"
-        (list->string
-         (let loop ((c 1)
-                    (acc '()))
-           (if (>= c (- (WIDTH) 1))
-               acc
-               (loop (+ 1 c)
-                     (cons #\- acc)))))
-        "/")
-
-  ;; Draw character
-  (draw (cursor-move (X) (Y))
-        me))
+  ;; Set up world
+  (world-init (world))
+  (world-draw (world)))
 
 (define (game-cleanup)
+  ;; Restore terminal
   (stty '(cooked echo))
   (draw cursor-home
         (cursor-restore)
         alt-buffer-disable
         visible-cursor))
 
-(define (readch)
-  (integer->char (read-byte)))
-
-(define (car* x)
-  (and (pair? x)
-       (car x)))
-
 (define (game-loop)
   (let loop ((c (readch)))
     (if (eq? c 'done)
         #t
         (let ((done? #f))
           (match c
-            ((or #\q #\) (set! done? #t))
-            (#\h (move-left))
-            (#\j (move-down))
-            (#\k (move-up))
-            (#\l (move-right))
+            ((or #\q #\)
+             (set! done? #t))
             ;; Escape characters
             (#\escape
              (match (readch)
                (#\[ (match (readch)
-                      (#\A (move-up))
-                      (#\B (move-down))
-                      (#\C (move-right))
-                      (#\D (move-left))
+                      (#\A (up!))
+                      (#\B (down!))
+                      (#\C (right!))
+                      (#\D (left!))
                       (else)))
                (else)))
             (else))
+          (world-draw (world))
           (loop (if done? 'done (readch)))))))
 
-(define (main args)
-  (dynamic-wind
-    game-setup
-    game-loop
-    game-cleanup)
-  #t)
+(define (readch)
+  (let ((c (integer->char (read-byte))))
+    c))
+
+(define (draw . instructions)
+  (for-each (lambda (i)
+              (cond
+               ((string? i) (display i))
+               ((list? i) (apply draw i))
+               (else (error "Don't know how to draw" i))))
+            instructions))
+
+(define-record-type world
+  (%make-world width height map)
+  world?
+  (width world-width world-width-set!)
+  (height world-height world-height-set!)
+  (map world-map world-map-set!))
+
+(define (in-bounds? world x y)
+  (or (< x (world-width world))
+      (> x 0)
+      (< y (world-height world))
+      (> y 0)))
+
+(define (coords->index world x y)
+  (if (in-bounds? world x y)
+      (+ x (* (world-width world) y))
+      (error "Out of bounds"
+             (list (world-width world) (world-height world))
+             (list x y))))
+
+(define (world-get world x y)
+  (vector-ref (world-map world) (coords->index world x y)))
+
+(define (world-set! world x y obj)
+  (vector-set! (world-map world)
+               (coords->index world x y)
+               obj))
+
+(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)
+    (do ((x 1 (+ x 1)))
+        ((= x (world-width world)) #t)
+      (proc world x y))))
+
+(define (world-draw world)
+  (draw cursor-home)
+  (for-world (lambda (w x y)
+               (cond
+                ((thing? (world-get w x y))
+                 (draw (cursor-move x y)
+                       (thing-look (world-get w x y))))
+                (else
+                 (draw (cursor-move x y)
+                       " "))))
+             world))
+
+(define (world-init world)
+  (for-world (lambda (w x y)
+               (cond
+                ((or (= x 1)
+                     (= y 1)
+                     (= x (- (world-width world) 1))
+                     (= y (- (world-height world) 1)))
+                 (thing-place! w (wall x y)))
+                (else)))
+             world)
+  (thing-place! world (me)))
+
+(define-record-type thing
+  (make-thing name look x y z attrs)
+  thing?
+  (name thing-name)
+  (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!))
+
+(define (thing-place! world thing)
+  (world-set! world (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-relative! world thing dx dy)
+  (let* ((new-x (+ (thing-x thing) dx))
+         (new-y (+ (thing-y thing) dy))
+         (other (world-get world new-x new-y)))
+    (cond
+     ((and (thing? other)
+           (> (thing-z other) (thing-z thing))))
+     (else
+      (cond ((< new-x 1)
+             (set! new-x 1))
+            ((> new-x (- (world-width world) 1))
+             (set! new-x (- (world-width world) 1))))
+      (cond ((< new-y 1)
+             (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)))))
+
+(define (wall x y)
+  (make-thing 'wall "#" x y 100 '()))
+
+(define me
+  (make-parameter
+   (make-thing 'me "@" 40 10 2 '())))
+
+(define (up!)
+  (thing-move-relative! (world) (me) 0 -1))
+
+(define (down!)
+  (thing-move-relative! (world) (me) 0 1))
+
+(define (right!)
+  (thing-move-relative! (world) (me) 1 0))
+
+(define (left!)
+  (thing-move-relative! (world) (me) -1 0))
@@ -1,205 +0,0 @@
-#!/bin/sh
-#| -*- scheme -*-
-exec csi -R r7rs -ss "$0" "$@"
-game
-|#
-
-(import (scheme base)
-        (scheme write)
-        (chicken io)
-        (chicken port)
-        (yolk common)
-        (yolk xterm)
-        (yolk erase)
-        (yolk cursor)
-        (matchable)
-        (stty))
-
-(define (log . xs)
-  (with-output-to-port (current-error-port)
-    (lambda ()
-      (for-each (lambda (x) (display x) (display " ") x)
-                xs)
-      (newline))))
-
-(define (main args)
-  (parameterize ((world (make-world 80 25)))
-    (dynamic-wind game-setup
-                  game-loop
-                  game-cleanup))
-  #t)
-
-(define (game-setup)
-  ;; Prepare terminal
-  (stty '(raw (not echo)))
-  (set-buffering-mode! (current-input-port) #:none 1)
-  (set-buffering-mode! (current-output-port) #:none 1)
-  (draw alt-buffer-enable
-        erase-screen
-        (cursor-save)
-        invisible-cursor)
-  ;; Set up world
-  (world-init (world))
-  (world-draw (world)))
-
-(define (game-cleanup)
-  ;; Restore terminal
-  (stty '(cooked echo))
-  (draw cursor-home
-        (cursor-restore)
-        alt-buffer-disable
-        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))
-          (world-draw (world))
-          (loop (if done? 'done (readch)))))))
-
-(define (readch)
-  (let ((c (integer->char (read-byte))))
-    c))
-
-(define (draw . instructions)
-  (for-each (lambda (i)
-              (cond
-               ((string? i) (display i))
-               ((list? i) (apply draw i))
-               (else (error "Don't know how to draw" i))))
-            instructions))
-
-(define-record-type world
-  (%make-world width height map)
-  world?
-  (width world-width world-width-set!)
-  (height world-height world-height-set!)
-  (map world-map world-map-set!))
-
-(define (in-bounds? world x y)
-  (or (< x (world-width world))
-      (> x 0)
-      (< y (world-height world))
-      (> y 0)))
-
-(define (coords->index world x y)
-  (if (in-bounds? world x y)
-      (+ x (* (world-width world) y))
-      (error "Out of bounds"
-             (list (world-width world) (world-height world))
-             (list x y))))
-
-(define (world-get world x y)
-  (vector-ref (world-map world) (coords->index world x y)))
-
-(define (world-set! world x y obj)
-  (vector-set! (world-map world)
-               (coords->index world x y)
-               obj))
-
-(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)
-    (do ((x 1 (+ x 1)))
-        ((= x (world-width world)) #t)
-      (proc world x y))))
-
-(define (world-draw world)
-  (draw cursor-home)
-  (for-world (lambda (w x y)
-               (cond
-                ((thing? (world-get w x y))
-                 (draw (cursor-move x y)
-                       (thing-look (world-get w x y))))
-                (else
-                 (draw (cursor-move x y)
-                       " "))))
-             world))
-
-(define (world-init world)
-  (for-world (lambda (w x y)
-               (cond
-                ((or (= x 1)
-                     (= y 1)
-                     (= x (- (world-width world) 1))
-                     (= y (- (world-height world) 1)))
-                 (thing-place! w (wall x y)))
-                (else)))
-             world)
-  (thing-place! world (me)))
-
-(define-record-type thing
-  (make-thing name look x y z attrs)
-  thing?
-  (name thing-name)
-  (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!))
-
-(define (thing-place! world thing)
-  (world-set! world (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-relative! world thing dx dy)
-  (let* ((new-x (+ (thing-x thing) dx))
-         (new-y (+ (thing-y thing) dy))
-         (other (world-get world new-x new-y)))
-    (cond
-     ((and (thing? other)
-           (> (thing-z other) (thing-z thing))))
-     (else
-      (cond ((< new-x 1)
-             (set! new-x 1))
-            ((> new-x (- (world-width world) 1))
-             (set! new-x (- (world-width world) 1))))
-      (cond ((< new-y 1)
-             (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)))))
-
-(define (wall x y)
-  (make-thing 'wall "#" x y 100 '()))
-
-(define me
-  (make-parameter
-   (make-thing 'me "@" 40 10 2 '())))
-
-(define (up!)
-  (thing-move-relative! (world) (me) 0 -1))
-
-(define (down!)
-  (thing-move-relative! (world) (me) 0 1))
-
-(define (right!)
-  (thing-move-relative! (world) (me) 1 0))
-
-(define (left!)
-  (thing-move-relative! (world) (me) -1 0))