#!/bin/sh
#| -*- scheme -*-
exec csi -R r7rs -ss "$0" "$@"
apple --- 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)
        (yolk attrs)
        (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)))
    (parameterize ((me (make-thing 'me (world)
                                   (with-attrs '(red) "ó") 10 10 2))
                   (snake (make-snake (world) 5 (current-jiffy) 200 'left
                                      (make-thing 'snake-head (world)
                                                  "<" 20 20 2)
                                      (list)))
                   (fruit (make-thing 'fruit (world)
                                      (random-choice (fruits)) 10 20 1)))
      (case (dynamic-wind game-setup
                          game-loop
                          game-cleanup)
        ((win) (print "Congrats!"))
        ((lose) (print "Better luck next time."))
        (else))
      (print "Thanks for playing!")))
  #t)

;;; Parameters
(define me (make-parameter #f))
(define snake (make-parameter #f))
(define fruit (make-parameter #f))
(define world (make-parameter #f))
(define game-end (make-parameter #f))

(define fruits
  (make-parameter (list (with-attrs '(yellow) ")")
                        (with-attrs '(green) "ò")
                        (with-attrs '(magenta) "%")
                        (with-attrs '(blue) "*"))))

;;; Main game elements
(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)
  (call/cc
   (lambda (return)
     (parameterize ((game-end return))
       (let loop ((now (current-jiffy)))
         (unless (and (eq? (thing-x (fruit)) (thing-x (me)))
                      (eq? (thing-y (fruit)) (thing-y (me))))
           (thing-place! (fruit)))
         (handle-input)
         (snake-step (snake) now)
         (world-draw (world))
         (loop (current-jiffy)))))))

(define (handle-input)
  (if (char-ready?)
      (match (readch)
        ((or #\q #\) ((game-end) 'quit))
        (#\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)))
        (_ #f))
      #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))))

(define (random-choice . choices)
  (list-ref choices (random-int (length choices))))

;;; Drawing stuff

(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))

;;; World

(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 (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! (wall w x y)))
                (else)))
             world)
  (thing-pos-randomize! (me))
  (thing-place! (me))
  (thing-pos-randomize! (snake-head (snake)))
  (thing-place! (snake-head (snake)))
  (for-each (lambda (t) (thing-place! t))
            (snake-tail (snake)))
  (thing-pos-randomize! (fruit))
  (thing-place! (fruit)))

(define (thing-pos-randomize! thing)
  (let-values (((x y) (random-point (thing-world thing))))
    (thing-x-set! thing x)
    (thing-y-set! thing y)))

;;; Things

(define-record-type <thing>
  (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!))

(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))))
    (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! thing)
  (world-set! (thing-world thing) (thing-x thing) (thing-y thing) 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! 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
     ((and (thing? other)
           (<= (thing-z thing) (thing-z other)))
      (handle-collision thing other))
     (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! thing new-x new-y)))))

;;; XXX: these are hacky
(define (me? x)
  (and (thing? x)
       (eq? 'me (thing-name x))))

(define (snake-head? x)
  (and (thing? x)
       (eq? 'snake-head (thing-name x))))
;;; hacky-end

(define (handle-collision a b)
  (cond
   ((or (and (me? a) (snake-head? b))
        (and (snake-head? a) (me? b)))
    (game-lose))
   ((or (and (snake-head? a) (thing? b))
        (and (thing? a) (snake-head? b)))
    (game-win))
   (else)))

(define (game-win)
  (draw (cursor-move 10 10)
        "YOU WIN!")
  (readch)
  (newline)
  ((game-end) 'win))

(define (game-lose)
  (draw (cursor-move 10 10)
        "YOU LOSE :(")
  (readch)
  (newline)
  ((game-end) 'lose))

(define (thing-up! thing)
  (thing-move-relative! thing 0 -1))

(define (thing-down! thing)
  (thing-move-relative! thing 0 1))

(define (thing-right! thing)
  (thing-move-relative! thing 1 0))

(define (thing-left! thing)
  (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)))

(define (thing-above thing)
  (if (< (thing-y thing) 1)
      #f
      (let ((t (world-get (thing-world thing)
                          (thing-x thing)
                          (- (thing-y thing) 1))))
        (and (thing? t)
             (thing-name t)))))

(define (thing-below thing)
  (if (> (thing-y thing) (world-height (thing-world thing)))
      #f
      (let ((t (world-get (thing-world thing)
                          (thing-x thing)
                          (+ (thing-y thing) 1))))
        (and (thing? t)
             (thing-name t)))))

(define (thing-to-left thing)
  (if (< (thing-x thing) 1)
      #f
      (let ((t (world-get (thing-world thing)
                          (- (thing-x thing) 1)
                          (thing-y thing))))
        (and (thing? t)
             (thing-name t)))))

(define (thing-to-right thing)
  (if (> (thing-x thing) (world-width (thing-world thing)))
      #f
      (let ((t (world-get (thing-world thing)
                          (+ (thing-x thing) 1)
                          (thing-y thing))))
        (and (thing? t)
             (thing-name t)))))

;;; snake

(define-record-type <snake>
  (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-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 (take* xs n)
  ;;; Like `take' from SRFI 1, but doesn't choke on too-short lists.
  (unless (and (integer? n)
               (> n 0))
    (error "Must take non-negative integer" n))
  (let loop ((xs xs)
             (n n)
             (acc '()))
    (if (or (null? xs)
            (zero? n))
        (reverse acc)
        (loop (cdr xs)
              (- n 1)
              (cons (car xs) acc)))))

(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)
      (snake-update-direction! snake)
      (apply thing-move-relative!
             (snake-head snake)
             (direction->velocity (snake-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-decide-move snake) ; snake => direction
  (let* ((head (snake-head snake))
         (direction (snake-direction snake))
         (snake-x (snake-x snake))
         (snake-y (snake-y snake))
         (me-x (thing-x (me)))
         (me-y (thing-y (me)))
         (new-dir
          ;; Initial decision
          (cond
           ;; If `me' is right there, move toward it
           ((eq? (thing-above head) 'me) 'up)
           ((eq? (thing-below head) 'me) 'down)
           ((eq? (thing-to-right head) 'me) 'right)
           ((eq? (thing-to-left head) 'me) 'left)
           ;; Otherwise, if about to collide with something, dodge it.
           ((or (and (thing-above head)
                     (eq? direction 'up))
                (and (thing-below head)
                     (eq? direction 'down)))
            (if (thing-to-left head) 'right 'left))
           ((or (and (thing-to-right head)
                     (eq? direction 'right))
                (and (thing-to-left head)
                     (eq? direction 'left)))
            (if (thing-above head) 'down 'up))
           ;; Otherwise, move toward `me'
           ((< snake-x me-x)
            (if (> (abs (- snake-x me-x))
                   (abs (- snake-y me-y)))
                'right
                (if (< snake-y me-y) 'down 'up)))
           ((> snake-x me-x)
            (if (> (abs (- snake-x me-x))
                   (abs (- snake-y me-y)))
                'left
                (if (< snake-y me-y) 'down 'up)))
           ((= snake-x me-x) (cond
                              ((< snake-y me-y) 'down)
                              ((> snake-y me-y) 'up)
                              (else ((game-end) 'lose))))
           ;; Otherwise, keep going how we're going
           (else (snake-direction snake)))))
    ;; Don't let the snake double back into itself
    (cond
     ((or (and (eq? direction 'right)
               (eq? new-dir 'left))
          (and (eq? direction 'left)
               (eq? new-dir 'right)))
      (if (< snake-y me-y) 'down 'up))
     ((or (and (eq? direction 'up)
               (eq? new-dir 'down))
          (and (eq? direction 'down)
               (eq? new-dir 'up)))
      (if (< snake-x me-x) 'right 'left))
     (else new-dir))))

(define (snake-update-direction! snake)
  (snake-direction-set! snake (snake-decide-move snake)))