onomat.l1

#!/usr/bin/env l1

(def MAXROOM-SIZE 20)
(def MINROOM-SIZE 4)
(def MSGBOX-MIN-X 1)
(def MSGBOX-MIN-Y 2)
(def MSGBOX-MAX-X 30)
(def MSGBOX-MAX-Y 20)

(defn listlen (msg)
  (let ((words-len (apply + (map (comp len split) msg)))
        (spaces-len (dec (len msg))))
    (+ words-len spaces-len)))

(defn write-width-centered (h msg)
  (let* ((dims (screen-size))
         (w (- (/ (car dims) 2)
               (/ (listlen msg) 2))))
    (screen-write w h msg)))

(defn press-any-key () (screen-get-key))

(defn intro ()
  (screen-clear)
  (write-width-centered 10 '(O N O M A T))
  (write-width-centered 12 '(press any key to continue))
  (press-any-key)
  (screen-clear))

(defn minmax (x mn mx)
  (max mn (min mx x)))

(defn make-room (screen-dims)
  (let* ((w (first screen-dims))
         (h (second screen-dims))
         (room-width (minmax (inc (randint (dec w)))
                             MINROOM-SIZE
                             MAXROOM-SIZE))
         (room-height (minmax (inc (randint (dec h)))
                              MINROOM-SIZE
                              MAXROOM-SIZE))
         (available-w (- w room-width MSGBOX-MAX-X))
         (available-h (- h room-height))
         (room-pos-w (+ MSGBOX-MAX-X (inc (randint available-w))))
         (room-pos-h (inc (randint available-h))))
    (list room-pos-w
          room-pos-h
          room-width
          room-height)))

(defn room-x (room)      (nth 0 room))
(defn room-y (room)      (nth 1 room))
(defn room-width (room)  (nth 2 room))
(defn room-height (room) (nth 3 room))

(defn random-position-in-room (room)
  (list (+ (room-x room) (randint (room-width room)))
        (+ (room-y room) (randint (room-height room)))))

(defn draw-room (glyph room)
  (foreach h (map (partial + (room-y room))
                  (range (room-height room)))
    (screen-write (room-x room) h
                  (list (fuse (repeat (room-width room)
                                      glyph))))))

(defn make-player (player-position)
  player-position)

(defn player-x (player)
  (first player))

(defn player-y (player)
  (second player))

(defn draw-player (player)
  (screen-write (player-x player)
                (player-y player)
                (list ATSIGN)))

(defn update-pos (l n f)
  (doc (update nth position of a list by applying f to the
               value of the nth element, leaving the others
               unchanged))
  (when (< n (len l))
    (concat (take n l)
            (list (f (nth n l)))
            (drop (inc n) l))))

(defn move-player (player delta)
  (list (+ (player-x player) (first delta))
        (+ (player-y player) (second delta))))

(defn valid-move (room x y delta)
  (and (<= (room-x room)
           (+ x (first delta))
           (+ (room-x room) (room-width room) -1))
       (<= (room-y room)
           (+ y (second delta))
           (+ (room-y room) (room-height room) -1))))

(defn monster-glyph ()
  (randchoice '(X x Ж χ ⤬ 𝗑)))

(defn make-monster (room)
  (list* (monster-glyph) (random-position-in-room room)))

(defn monster-pos (monster) (cdr monster))

(defn monster-x (monster) (cadr monster))

(defn monster-y (monster) (caddr monster))

(defn monster-char (monster) (car monster))

(defn monsters-for-room (room)
  (repeatedly (inc (randint 4))
              (partial make-monster room)))

(defn draw-monster (monster)
  (screen-write (monster-x monster)
                (monster-y monster)
                (list (monster-char monster))))

(defn calc-delta (x1 x2)
  (let ((delta (- x2 x1)))
    (if (zero? delta)
      0
      (/ delta (abs delta)))))

(defn monster-at? (monsters x y)
  ;; FIXME: Getting inefficient.  Better for a crowded board to
  ;; associate one or more occupants with room locations?
  (some (lambda (m) (and (= x (monster-x m))
                         (= y (monster-y m))))
        monsters))

(defn move-monster (room player monsters monster)
  (let* ((px (player-x player))
         (py (player-y player))
         (mx (monster-x monster))
         (my (monster-y monster))
         (dx (calc-delta px mx))
         (dy (calc-delta py my))
         (r (isqrt (+ (** (- px mx) 2) (** (- py my) 2)))))
    (cond
      ((pos? (randint (inc r))) monster)
      ((monster-at? monsters (- mx dx) (- my dy)) monster)
      ;; FIXME: breaks monster encapsulation:
      (t (list (car monster) (- mx dx) (- my dy))))))

(defmacro prepend! (x l)
  `(set! ~l (cons ~x ~l)))

(defmacro append-circular! (x l)
  `(set! ~l (concat2 (take 30 ~l) (list ~x))))

(defn line-points (x1 y1 x2 y2)
  (cond ((= x1 x2)
         (map (comp (lambda (q) (list x1 q))
                    (partial + (min y1 y2)))
              (range (inc (abs (- y2 y1))))))
        ((= y1 y2)
         (map (comp (lambda (q) (list q y1))
                    (partial + (min x1 x2)))
              (range (inc (abs (- x2 x1))))))
        (t (let* ((x x2)
                  (y y2)
                  (ret (list (list x y))))
             (while (< x1 x)
               (let ((delta (if (> x2 x1) -1 1)))
                 (set! x (+ x delta))
                 (set! y (+ y2 (/ (* (- x x2)
                                     (- y2 y1))
                                  (- x2 x1))))
                 (prepend! (list x y) ret)))
             ret))))

(defn draw-line (chratom x1 y1 x2 y2)
  (let ((points (line-points x1 y1 x2 y2)))
    (foreach p points
      (screen-write (car p) (cadr p) (list chratom)))))

(defn draw-box (glyph x1 y1 x2 y2)
  (draw-line glyph x1 y1 x1 y2)
  (draw-line glyph x1 y2 x2 y2)
  (draw-line glyph x2 y1 x2 y2)
  (draw-line glyph x1 y1 x2 y1))

(defn fill-box (glyph x1 y1 x2 y2)
  (foreach h (map (partial + y1)
                  (range (- y2 y1)))
    (screen-write x1 h (list (fuse (repeat (- x2 x1) glyph))))))

(def msgbox-msgs ())

(defn list-to-atom (l)
  (fuse (interpose SPACE l)))

(defn render-msgs (max-msg-y)
  ;; (draw-box '/
  ;;           MSGBOX-MIN-X
  ;;           (- max-msg-y 20)
  ;;           MSGBOX-MAX-X max-msg-y)
  (foreach pair (enumerate msgbox-msgs)
    (screen-write (inc MSGBOX-MIN-X)
                  (+ max-msg-y -19 (car pair))
                  (list (list-to-atom (cadr pair))))))

(defn printm (x)
  (append-circular! x msgbox-msgs))

(defn hkeyline (key msg)
  `(~key ~COLON ~@msg))

(let ((C COLON))
  (def help-message `((~QMARK           ~C this message)
                      (q                ~C quit)
                      (~PERIOD          ~C wait)
                      (h or left arrow  ~C left)
                      (l or right arrow ~C right)
                      (k or up arrow    ~C up)
                      (j or down arrow  ~C down)
                      (b                ~C down and left)
                      (y                ~C up and left)
                      (u                ~C up and right)
                      (n                ~C down and right)
                      (t                ~C teleport (dangerous!)))))

(defn clear-box ()
  (fill-box SPACE
            (inc MSGBOX-MIN-X)
            (inc MSGBOX-MIN-Y)
            (inc MSGBOX-MAX-X)
            (inc MSGBOX-MAX-Y)))

(defn main ()
  (let ((player-alive t)
        (continue t)
        (turns 0)
        (monsters ()))
    (with-screen
      (intro)
      (printm '(Welcome to The Room.))
      (printm `(Press ~QUOTE ~QMARK ~QUOTE for help.))
      (try
        (let* ((dims (screen-size))
               (w (first dims))
               (h (second dims))
               (room (make-room dims))
               (player-pos (random-position-in-room room))
               (player (make-player player-pos))
               (move-if-valid
                 (lambda (coords)
                   (when (valid-move room
                                     (player-x player)
                                     (player-y player)
                                     coords)
                     (set! player (move-player player coords)))))
               (_ (set! monsters (monsters-for-room room)))
               (add-monster!
                 (lambda ()
                   (printm (exclaim '(a monster has spawned)))
                   (prepend! (make-monster room) monsters)))
               (teleport
                 (lambda ()
                   (printm '(You teleport.))
                   (add-monster!)
                   (add-monster!)
                   (set! player (random-position-in-room room))))
               (dohelp
                 (lambda ()
                   (let ((save-msgs msgbox-msgs))
                     (clear-box)
                     (set! msgbox-msgs help-message)
                     (render-msgs (dec h))
                     (screen-get-key)
                     (clear-box)
                     (set! msgbox-msgs save-msgs)
                     (render-msgs (dec h)))))
               (update-monsters!
                 (lambda ()
                   (when (zero? (randint 5))
                     (add-monster!))
                   (set! monsters
                         (map (partial move-monster room player monsters)
                              monsters))
                   (foreach m monsters
                     (draw-monster m)
                     (when (and (= (monster-x m)
                                   (player-x player))
                                (= (monster-y m)
                                   (player-y player)))
                       (set! player-alive ())
                       (set! continue ()))))))
          (draw-room PERIOD room)
          (draw-player player)
          (foreach m monsters
            (draw-monster m))
          (while (and continue player-alive)
            (set! turns (inc turns))
            (render-msgs (dec h))
            (let ((k (screen-get-key)))
              (cond
                ((= k 'q) (set! continue ()))
                ((or (= k 'h) (= k 'LEFTARROW))
                 (move-if-valid '(-1 0)))
                ((or (= k 'l) (= k 'RIGHTARROW))
                 (move-if-valid '(1 0)))
                ((or (= k 'k) (= k 'UPARROW))
                 (move-if-valid '(0 -1)))
                ((or (= k 'j) (= k 'DOWNARROW))
                 (move-if-valid '(0 1)))
                ((= k 'y) (move-if-valid '(-1 -1)))
                ((= k 'u) (move-if-valid '(1 -1)))
                ((= k 'b) (move-if-valid '(-1 1)))
                ((= k 'n) (move-if-valid '(1 1)))
                ((= k 't) (teleport))
                ((= k '?) (dohelp)))
              (when-not (= k '?)
                (draw-room PERIOD room)
                (draw-player player)
                (update-monsters!))))
          (when-not player-alive
            (printm (exclaim '(YOU DIED)))
            (render-msgs (dec h))
            (screen-write (player-x player) (player-y player) '(%))
            (screen-get-key)
            (printm '(Press any key...))
            (render-msgs (dec h))
            (screen-get-key)))
        (catch e
          (screen-end)
          (println e))))
    (println)
    (when-not player-alive
      (printl `(You were eaten by a monster after ~turns turns.
                    Your score is ~(* turns (len monsters)) points.)))
    (printl (exclaim '(thanks for playing)))
    (println)))

(main)