More
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Wed, 21 Apr 2021 16:05:17 -0400 |
| parents |
2e93a4fe55f1 |
| children |
cb3863ea23c1 |
(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/10))
(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 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)))))))
(msg (choose "What do you want to buy?" options)))
(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))