path: root/game.scm

#!/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))