Initial commit

1 files changed, 177 insertions, 0 deletions

@@ -0,0 +1,177 @@
+#!/bin/sh
+#| -*- scheme -*-
+exec csi -R r7rs -ss "$0" "$@"
+|#
+#+chicken (import r7rs)
+
+(import (scheme base)
+        (scheme write)
+        (chicken io)
+        (chicken port)
+        (srfi 133)
+        (yolk common)
+        (yolk xterm)
+        (yolk erase)
+        (yolk cursor)
+        (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 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 (game-setup)
+  (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))
+
+(define (game-cleanup)
+  (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))
+            ;; Escape characters
+            (#\escape
+             (match (readch)
+               (#\[ (match (readch)
+                      (#\A (move-up))
+                      (#\B (move-down))
+                      (#\C (move-right))
+                      (#\D (move-left))
+                      (else)))
+               (else)))
+            (else))
+          (loop (if done? 'done (readch)))))))
+
+(define (main args)
+  (dynamic-wind
+    game-setup
+    game-loop
+    game-cleanup)
+  #t)