src/main.lisp @ cb3863ea23c1 default tip

(in-package :mycelium)

;;;; Constants ----------------------------------------------------------------
(defconstant +black+ (boots:rgb 0 0 0))
(defconstant +white+ (boots:rgb 255 255 255))
(defconstant +dark-purple+ (boots:rgb #x52 #x2F #x70))

(defconstant +default+ (boots:attr :fg +white+ :bg +black+))
(defconstant +bold+ (boots:attr :fg +white+ :bg +black+ :bold t))
(defconstant +reverse+ (boots:attr :fg +black+ :bg +white+))
(defconstant +selected+ (boots:attr :fg +white+ :bg +dark-purple+ :bold t))

(defconstant +button-default+  (boots:attr :fg +white+ :bg +black+       :bold t))
(defconstant +button-selected+ (boots:attr :fg +white+ :bg +dark-purple+ :bold t))


;;;; State --------------------------------------------------------------------
(defvar *event* nil)
(defvar *mods* nil)
(defvar *seed* nil)
(defvar *debug* (make-ring-buffer))
(defvar *pcg* (pcg:make-pcg))
(defvar *elapsed* nil)
(defvar *messages* (make-ring-buffer :size 16))
(defvar *focused* nil)


;;;; Assets -------------------------------------------------------------------
(defun load-asset (path)
  (_ path
    alexandria:read-file-into-string
    (string-right-trim '(#\newline) _)
    str:lines))

(defparameter *asset/splash* (load-asset "assets/splash.txt"))
(defparameter *asset/help* (load-asset "assets/help.txt"))


;;;; Utils --------------------------------------------------------------------
(defun random (bound &optional max inclusive?)
  (pcg:pcg-random *pcg* bound max inclusive?))

(defun press-key (event)
  (loop :until (multiple-value-call #'boots:event= event (boots:read-event)))
  (values))

(defmacro with-ui (ui &body body)
  (alexandria:with-gensyms (prev)
    `(let ((,prev (boots:root boots:*screen*)))
       (setf (boots:root boots:*screen*) ,ui)
       (unwind-protect (progn ,@body)
         (setf (boots:root boots:*screen*) ,prev)))))

(defmacro event-case (form &body clauses)
  (alexandria:with-gensyms (e m)
    `(multiple-value-bind (,e ,m) ,form
       (unless (handle-global-event ,e ,m)
         (boots:event-case (values ,e ,m)
           ,@clauses)))))

(defun handle-global-event (event mods)
  (boots:event-case (values event mods)
    (#(:ctrl #\q) (throw 'quit nil))
    (#\esc (pause) t)
    (#\? (help) t)
    (t nil)))

(defun draw-right (pad x y string attr)
  (boots:draw pad (1+ (- x (length string))) y string attr))

(defun draw-center (pad y string attr &aux
                    (s (string string))
                    (w (boots:width pad))
                    (l (length s)))
  (boots:draw pad (if (<= w l) 0 (truncate (- w l) 2))
              y s attr))

(defun dbg (&optional string &rest args)
  (if string
    (rb-push *debug* (apply #'format nil string args))
    (do-ring-buffer (s *debug*)
      (write-line s)))
  (values))

(defun msg (string &rest args)
  (rb-push *messages* (if (null args)
                        (aesthetic-string string)
                        (apply #'format nil string args))))


;;;; Items --------------------------------------------------------------------
;;; These classes don't represent individual items, but rather the whole
;;; set/count/pile of a particular type of item.

(defclass* item ()
  (section
   key
   description
   (price :initform 0)
   (owned :initform 0)))

(defclass* mushroom (item)
  ((section :initform 'mushrooms)
   (calories :initform 100)))

(defclass* tool (item)
  ((section :initform 'tools)))

(defmethod print-object ((o item) s)
  (print-unreadable-object (o s :type t)
    (format s "~A" (key o))))

(defun make-items (class data)
  (iterate
    (for (key description . initargs) :in data)
    (collect (apply #'make-instance class :key key :description description initargs))))

(defun make-tools ()
  (make-items 'tool '((trowel "Small trowel" :owned 1)
                      (bucket "Sturdy bucket" :owned 1)
                      (field-guide "Field guide" :price 1999))))

(defun make-mushrooms ()
  (make-items 'mushroom
              '((chantrelle "Chantrelle mushroom" :calories 60 :price 15)
                (matsutake "Matsutake mushroom" :calories 200 :price 1000))))



;;;; Inventory ----------------------------------------------------------------
(defvar *inventory* nil)
(defvar *inventory-index* nil)

(defparameter *sections* '(mushrooms tools))

(defun inv-ref (section key)
  ;; should have been a setf expander but time is short
  (gethash key (gethash section *inventory*)))

(defun inv-inc (o &optional key)
  (if (null key)
    (incf (owned (gethash (key o) (gethash (section o) *inventory*))) 1)
    (incf (owned (gethash key (gethash o *inventory*))) 1)))

(defun inv-dec (o &optional key)
  (if (null key)
    (decf (owned (gethash (key o) (gethash (section o) *inventory*))) 1)
    (decf (owned (gethash key (gethash o *inventory*))) 1)))

(defun inv-insert (&rest items)
  (dolist (item items)
    (setf (gethash (key item) (gethash (section item) *inventory*))
          item)))

(defun inv-section-items (section &key only-owned)
  (iterate (for (nil item) :in-hashtable (gethash section *inventory*))
           (when (or (not only-owned) (plusp (owned item)))
             (collect item))))


(defun init/inventory ()
  (setf *inventory* (make-hash-table))
  (dolist (s *sections*)
    (setf (gethash s *inventory*) (make-hash-table)))
  (apply #'inv-insert (make-mushrooms))
  (apply #'inv-insert (make-tools))
  (setf *inventory-index*
        (iterate (for s :in *sections*)
                 (for keys = (sort (alexandria:hash-table-keys (gethash s *inventory*)) #'string<))
                 (collect (list s keys)))))


;;;; Hunger -------------------------------------------------------------------
(defvar *calories* 0.0)

(defparameter *calories-per-second* 1.0)
(defparameter *calories/hungry* 100.0)
(defparameter *calories/full* 600.0)
(defparameter *calories/max* 1000.0)

(defun hungryp ()
  (< *calories* *calories/hungry*))

(defun starvingp ()
  (zerop *calories*))

(defun fullp ()
  (> *calories* *calories/full*))

(defun eat (mushroom)
  (incf *calories* (calories mushroom))
  (clampf *calories* 0 *calories/max*)
  (inv-dec mushroom))

(defun attempt-to-eat ()
  (if (fullp)
    (msg "You're too full to eat any more.")
    (let ((options (inv-section-items 'mushrooms :only-owned t)))
      (if (null options)
        (msg "You don't have any mushrooms to eat.")
        (progn (msg "You eat a mushroom.")
               (eat (random-elt options #'random))
               (when (fullp)
                 (unlock 'money)
                 (when (unlock 'sell)
                   (ensure-customer))))))))

(defun tick/hunger (delta)
  (decf *calories* (* delta *calories-per-second*))
  (clampf *calories* 0 *calories/max*))


;;;; Money --------------------------------------------------------------------
(defvar *money* 0)
(defvar *offered* nil)
(defvar *customer* nil)
(defparameter *customers-per-second* (float 1/1))


(defun human-money (money)
  (multiple-value-bind (dollars cents) (truncate money 100)
    (format nil "$~D.~2,'0D" dollars cents)))

(defun offer (section key)
  (push (cons section key) *offered*))

(chancery:define-string random-customer
  "A man"
  "A woman"
  "A mycologist"
  "A chef")

(defun ensure-customer ()
  (when (null *customer*)
    (setf *customer* (random-customer))
    t))

(defun sell (mushroom)
  (incf *money* (price mushroom))
  (inv-dec mushroom)
  (setf *customer* nil)
  (when (unlock 'buy)
    (offer 'tools 'field-guide)))

(defun attempt-to-sell ()
  (let ((options (inv-section-items 'mushrooms :only-owned t)))
    (cond ((null options) (msg "You don't have any mushrooms to sell."))
          ((null *customer*) (msg "No one wants to buy your mushrooms."))
          (t (progn (msg "You sell a mushroom.")
                    (sell (random-elt options #'random)))))))

(defun attempt-to-buy (id)
  (destructuring-bind (section . key) id
    (let* ((item (inv-ref section key))
           (price (price item)))
      (cond ((> price *money*) (msg "You can't afford that."))
            (t (progn (decf *money* price)
                      (msg "You buy ~A." (description item))
                      (alexandria:removef *offered* id :test #'equal)
                      (unlock 'hire)))))))


(defun available-to-buy ()
  (iterate (for (section . key) :in *offered*)
           (collect (inv-ref section key))))

(defun tick/customers (delta)
  (when (randomp (* *customers-per-second* delta))
    (when (ensure-customer)
      (msg "~A wanders by and wants to buy a mushroom." *customer*))))


;;;; Ambience -----------------------------------------------------------------
(defparameter *ambient-events-per-second* (float 1/60))

(chancery:define-string random-ambient
  "You hear the patter of rain on the forest canopy."
  "A bird calls in the woods."
  "The smell of loam fills your nostrils.")

(defun tick/ambience (delta)
  (when (randomp (* *ambient-events-per-second* delta))
    (if (or (hungryp) (starvingp))
      (msg "Your stomach rumbles.")
      (msg (random-ambient)))))


;;;; Splash -------------------------------------------------------------------
(defparameter *ui/splash/bg*
  (boots:make-canvas :draw 'draw/splash/bg))

(defparameter *ui/splash/card*
  (boots:make-canvas :width (reduce #'max *asset/splash* :key #'length)
                     :height (length *asset/splash*)
                     :border t :margin t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/splash/card))

(defparameter *ui/splash*
  (boots:pile ()
    *ui/splash/card*
    *ui/splash/bg*))

(defun draw/splash/card (pad)
  (iterate
    (for y :from 0)
    (for line :in *asset/splash*)
    (boots:draw pad 0 y line +default+)))

(defun draw/splash/bg (pad)
  (dotimes (x (boots:width pad))
    (dotimes (y (boots:height pad))
      (boots:draw pad x y
                  (losh:random-elt "\\/_-,.`" #'random)
                  (boots:attr :fg +dark-purple+)))))

(defun splash ()
  (with-ui *ui/splash*
    (boots:redraw)
    (press-key #\space))
  (game))


;;;; Panels -------------------------------------------------------------------
(defvar *panels* nil)

(defclass* panel ()
  ((draw-function)
   (selected)
   (key)
   (ui)))

(defgeneric panel-name (panel))
(defgeneric panel-widgets (panel))

(defun current-panel ()
  (find-if #'selected *panels*))


;;;; Widgets ------------------------------------------------------------------
(defvar *unlocked* nil)


(defun unlock (key)
  (prog1 (not (hset-contains-p *unlocked* key))
    (hset-insert! *unlocked* key)))

(defun unlockedp (key)
  (hset-contains-p *unlocked* key))


(defun widget-pos (key)
  (let ((widgets (panel-widgets (current-panel))))
    (destructuring-bind (rows cols) (array-dimensions widgets)
      (do-range ((r 0 rows)
                 (c 0 cols))
        (when (eql key (aref widgets r c))
          (return-from widget-pos (values r c)))))))

(defun widget-ref (row col)
  (let ((widgets (panel-widgets (current-panel))))
    (destructuring-bind (rows cols) (array-dimensions widgets)
      (aref widgets (mod row rows) (mod col cols)))))


(defun focusedp (key)
  (assert key)
  (eql key *focused*))

(defun focus (key)
  (assert key)
  (setf *focused* key))

(defun focus-dir (dr dc)
  (multiple-value-bind (r c) (widget-pos *focused*)
    (iterate
      (incf r dr)
      (incf c dc)
      (for key = (widget-ref r c))
      (when (and key (unlockedp key))
        (focus key)
        (return)))))


(defmacro with-widget (key (color) &body body)
  `(when (unlockedp ',key)
     (let ((,color (if (focusedp ',key) +button-selected+ +button-default+)))
       ,@body)))


(defgeneric press (widget-key))


;;;; Forest -------------------------------------------------------------------
(defparameter *ui/forest/forage*
  (boots:make-canvas :height 2 :margin-bottom 1 :draw 'draw/forest/forage))

(defparameter *ui/forest/eat*
  (boots:make-canvas :height 2 :margin-bottom 1 :draw 'draw/forest/eat))

(defparameter *ui/forest/sell*
  (boots:make-canvas :height 2 :margin-bottom 1 :draw 'draw/forest/sell))

(defparameter *ui/forest/buy*
  (boots:make-canvas :height 2 :margin-bottom 1 :draw 'draw/forest/buy))

(defparameter *ui/forest*
  (boots:shelf (:fill-char #\space :fill-attr +default+)
    (boots:stack (:fill-char #\space :fill-attr +default+)
      *ui/forest/forage*
      *ui/forest/buy*)
    (boots:stack (:fill-char #\space :fill-attr +default+)
      *ui/forest/eat*
      *ui/forest/sell*)))


(defclass* forest (panel)
  ((ui :initform *ui/forest*)
   (key :initform 'forest)))


(defmethod panel-name ((p forest)) "Forest")
(defmethod panel-widgets ((p forest)) #2A((forage eat)
                                          (buy sell)))


(defun draw/forest/forage (pad)
  (with-widget forage (c)
    (boots:draw pad 0 0 "The forest is peaceful." +default+)
    (boots:draw pad 0 1 "[Forage for mushrooms]" c)))

(defun draw/forest/eat (pad)
  (with-widget eat (c)
    (boots:draw pad 0 0 `("You " ,(cond ((fullp) "feel full")
                                        ((starvingp) "are starving")
                                        ((hungryp) "are hungry")
                                        (t "feel content"))
                          ".")
                +default+)
    (boots:draw pad 0 1 "[Eat a mushroom]" c)))

(defun draw/forest/sell (pad)
  (with-widget sell (c)
    (if *customer*
      (boots:draw pad 0 0 (format nil "~A wants to buy a mushroom." *customer*) +default+)
      (boots:draw pad 0 0 "No one wants to buy mushrooms." +default+))
    (boots:draw pad 0 1 "[Sell a mushroom]" c)))

(defun draw/forest/buy (pad)
  (with-widget buy (c)
    (if *offered*
      (boots:draw pad 0 0 "Time for a shopping trip?" +default+)
      (boots:draw pad 0 0 "Nothing's for sale right now." +default+))
    (boots:draw pad 0 1 "[Buy something]" c)))


(chancery:define-rule (random-forage :distribution :weighted)
  (1 'chantrelle)
  (1 'matsutake))


(defparameter *base-forage-chance* 0.1)

(defun forage-chance ()
  (* *base-forage-chance*
     (cond ((fullp) 1.1)
           ((hungryp) 2.0)
           ((starvingp) 0.5)
           (t 1.0))))

(defmethod press ((k (eql 'forage)))
  (if (randomp (forage-chance))
    (progn (msg "You found a mushroom.")
           (inv-inc 'mushrooms (random-forage))
           (unlock 'eat))
    (msg "You don't find anything.")))

(defmethod press ((k (eql 'eat)))
  (attempt-to-eat))

(defmethod press ((k (eql 'sell)))
  (attempt-to-sell))

(defmethod press ((k (eql 'buy)))
  (if *offered*
    (let* ((options (iterate
                     (for i :in (available-to-buy))
                     (for s = (format nil "~A - ~A"
                                      (human-money (price i))
                                      (description i)))
                     (collect (cons s (cons (section i) (key i))))))
           (chosen (choose "What do you want to buy?" options)))
      (when chosen
        (attempt-to-buy chosen)))
    (msg "There's nothing you can buy right now.")))


;;;; Game ---------------------------------------------------------------------
(defparameter *ui/game/top-bar*
  (boots:shelf (:fill-char #\space :fill-attr +default+ :height 1 :border-bottom t)
    (boots:make-canvas :fill-char #\space :fill-attr +default+
                       :draw 'draw/game/top-bar/panels
                       :margin-right t)
    (boots:make-canvas :width 10
                       :fill-char #\space :fill-attr +default+
                       :draw 'draw/game/top-bar/time)))

(defparameter *ui/game/bottom-bar*
  (boots:make-canvas :height 1 :border-top t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/game/bottom-bar))

(defparameter *ui/game/messages*
  (boots:make-canvas :height 8 :border-top t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/game/messages))

(defparameter *ui/game/inventory*
  (boots:make-canvas :width 35 :border-left t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/game/inventory))

(defparameter *ui/game/panel*
  (boots:pile ()
    (boots:make-canvas :fill-char #\? :fill-attr +default+)))

(defparameter *ui/game*
  (boots:pile (:fill-char #\space :fill-attr +default+)
    (boots:stack ()
      *ui/game/top-bar*
      (boots:shelf ()
        *ui/game/panel*
        *ui/game/inventory*)
      *ui/game/messages*
      *ui/game/bottom-bar*)))

(defvar *layer-container* *ui/game*)


(defun draw/game/bottom-bar (pad)
  (draw-right pad (1- (boots:width pad)) 0 "[?] Help [ESC] Pause/Quit" +default+))

(defun draw/game/top-bar/panels (pad)
  (boots:draw pad 0 0
              (iterate (for panel :in-vector *panels*)
                       (collect (if (selected panel) +selected+ +reverse+))
                       (collect (panel-name panel)))))

(defun draw/game/top-bar/time (pad)
  (draw-right pad (1- (boots:width pad)) 0
              (format nil "~Ds" (truncate *elapsed* internal-time-units-per-second))
              +default+))


(defun draw/game/messages (pad)
  ;; todo make reverse iteration stuff for ring buffers
  (iterate (for i :from -1 :downto (- (rb-count *messages*)))
           (for y :from 0)
    (boots:draw pad 0 y (rb-ref *messages* i) +default+)))

(defun draw/game/inventory (pad &aux (y 0))
  (when (unlockedp 'money)
    (boots:draw pad 0 y (human-money *money*) +default+)
    (incf y 2))
  (iterate
    (with h = (boots:height pad))
    (while (< y h))
    (for sy = y)
    (for (section keys) :in *inventory-index*)
    (iterate (for key :in keys)
             (for item = (inv-ref section key))
             (when (plusp (owned item))
               (incf y)
               (boots:draw pad 0 y (format nil "~6D ~A"
                                           (owned item)
                                           (description item))
                           +default+)))
    (unless (= sy y)
      ;; only draw section header if we drew anything else
      (boots:draw pad 0 sy (symbol-name section) +default+)
      (incf y 2))))



(defmacro with-layer (ui &body body)
  `(progn (push ,ui (boots:children *layer-container*))
     (unwind-protect (progn ,@body)
       (pop (boots:children *layer-container*)))))

(defun tick (delta)
  (tick/hunger delta)
  (tick/ambience delta)
  (tick/customers delta))

(defmacro ticking-loop (&body body)
  (alexandria:with-gensyms (delta)
    `(iterate
       (timing real-time :per-iteration-into ,delta)
       (incf *elapsed* ,delta)
       (tick (/ (float ,delta 1.0d0) internal-time-units-per-second))
       (progn ,@body))))

(defun game ()
  (with-ui *ui/game*
    (ticking-loop
      (setf (first (boots:children *ui/game/panel*))
            (ui (find-if #'selected *panels*)))
      (boots:redraw)
      (event-case (boots:read-event-no-hang)
        (nil (boots:wait 1/30))
        (#\newline (press *focused*))
        (#\tab (msg "TODO"))
        (:left  (focus-dir  0 -1))
        (:right (focus-dir  0  1))
        (:up    (focus-dir -1  0))
        (:down  (focus-dir  1  0))
        (t nil)))))


;;;; Chooser Box --------------------------------------------------------------
(defun choose (heading options &aux (selected 0) (n (length options)))
  ; options: (option . result)
  (with-layer (boots:canvas (:fill-char #\space :fill-attr +default+
                             :margin t :border t
                             :height (+ 2 n)
                             :width (reduce #'max options
                                            :key (alexandria:compose #'length #'car)
                                            :initial-value (length heading)))
                  (pad)
                (boots:draw pad 0 0 heading +default+)
                (iterate (for (option . nil) :in options)
                         (for i :from 0)
                         (for y :from 2)
                         (for c = (if (= i selected) +button-selected+ +button-default+))
                         (boots:draw pad 0 y option c)))
    (ticking-loop
      (setf selected (mod selected n))
      (boots:redraw)
      (boots:event-case (boots:read-event-no-hang)
        (nil nil)
        (#\newline (return-from choose (cdr (elt options selected))))
        (#\esc (return-from choose nil))
        (:up   (incf selected))
        (:down (decf selected))
        (t nil)))))


;;;; Pause --------------------------------------------------------------------
(defparameter *ui/pause*
  (boots:make-canvas :width 30 :height 4 :border t :margin t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/pause))

(defun draw/pause (pad)
  (draw-center pad 0 "PAUSE" +bold+)
  (boots:draw pad 0 2 "[R]esume" +default+)
  (boots:draw pad 0 3 "[Q]uit Game" +default+))

(defun pause ()
  (with-ui *ui/pause*
    (loop (boots:redraw)
          (multiple-value-bind (e m) (boots:read-event)
            (boots:event-case (values e m)
              ((#\r #\esc) (return-from pause))
              (#\q (throw 'quit nil))
              (t (setf *event* e *mods* m)))))))


;;;; Help --------------------------------------------------------------------
(defparameter *ui/help*
  (boots:make-canvas :width 50 :height (+ 2 (length *asset/help*))
                     :border t :margin t
                     :fill-char #\space :fill-attr +default+
                     :draw 'draw/help))

(defun draw/help (pad)
  (draw-center pad 0 "HELP" +bold+)
  (iterate (for y :from 2)
           (for line :in *asset/help*)
           (boots:draw pad 0 y line +default+)))

(defun help ()
  (with-ui *ui/help*
    (boots:redraw)
    (press-key t)))


;;;; Main ---------------------------------------------------------------------
(defun init ()
  (rb-clear *debug*)
  (rb-clear *messages*)
  (init/inventory)
  (setf *seed* (cl:random (expt 2 60) (cl:make-random-state))
        *pcg* (pcg:make-pcg :seed *seed*)
        *elapsed* 0
        *focused* 'forage
        *money* 0
        *offered* nil
        *calories* (* 1.0 60)
        *layer-container* *ui/game*
        *panels* (vector (make-instance 'forest :selected t))
        *unlocked* (make-hash-set :initial-contents '(forest forage)))
  (values))

(defun run ()
  (init)
  (boots/terminals/ansi:with-ansi-terminal (terminal :truecolor t)
    (boots:with-screen (boots:*screen* terminal)
      (boots:with-light-borders
        (catch 'quit
          (splash))))))


(defun toplevel ()
  (sb-ext:disable-debugger)
  (run))

(defun build ()
  (sb-ext:save-lisp-and-die "build/mycelium"
    :executable t
    :save-runtime-options t
    :toplevel #'mycelium:toplevel))