Pivot
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Tue, 20 Apr 2021 18:01:32 -0400 |
| parents |
614ad4a1d44e |
| children |
60483297353d |
(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))
;;;; State --------------------------------------------------------------------
(defvar *event* nil)
(defvar *mods* nil)
(defvar *seed* nil)
(defvar *debug* (make-ring-buffer))
(defvar *pcg* (pcg:make-pcg))
(defvar *elapsed* nil)
(defvar *panels* nil)
(defvar *unlocked* nil)
(defvar *messages* (make-ring-buffer :size 16))
(defvar *calories* 0.0)
;;;; Config -------------------------------------------------------------------
(defparameter *forage-chance* 0.1)
(defparameter *calories-per-second* 1.0)
;;;; 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 unlock (&rest keys)
(apply #'hset-insert! *unlocked* keys))
(defun unlockedp (key)
(hset-contains-p *unlocked* key))
(defun msg (string &rest args)
(rb-push *messages* (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
(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))))
(defun make-mushrooms ()
(make-items 'mushroom
'((chantrelle "Chantrelle mushroom" :calories 60)
(matsutake "Matsutake mushroom" :calories 200))))
;;;; Inventory ----------------------------------------------------------------
(defvar *inventory* nil)
(defvar *inventory-index* nil)
(defparameter *sections* '(tools mushrooms))
(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 -------------------------------------------------------------------
(defun eat (mushroom)
(incf *calories* (calories mushroom))
(inv-dec mushroom))
(defun attempt-to-eat ()
(let ((options (inv-section-items 'mushrooms :only-owned t)))
(if (null options)
nil
(progn (msg "You feel hungry. You eat a mushroom.")
(eat (random-elt options #'random))))))
(defun tick/hunger (delta)
(let ((consumed (* delta *calories-per-second*)))
(setf *calories* (max 0.0 (- *calories* consumed)))
(when (zerop *calories*)
(attempt-to-eat))))
;;;; 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-ooc-colors
(with-ui *ui/splash*
(boots:redraw)
(press-key #\space)))
(game))
;;;; Panels -------------------------------------------------------------------
(defclass* panel ()
((draw-function)
(selected)
(key)
(ui)))
(defgeneric panel-name (panel))
;;;; Forest -------------------------------------------------------------------
(defparameter *ui/forest/forage*
(boots:make-canvas :height 1 :margin-bottom 1 :draw 'draw/forest/forage))
(defparameter *ui/forest*
(boots:shelf (:fill-char #\space :fill-attr +default+)
*ui/forest/forage*))
(defclass* forest (panel)
((ui :initform *ui/forest*)
(key :initform 'forest)))
(defmethod panel-name ((p forest))
"Forest")
(defun draw/forest/forage (pad)
(when (unlockedp 'forage)
(boots:draw pad 0 0 "[Forage for mushrooms]" +default+)))
(chancery:define-rule (random-forage :distribution :weighted)
(1 'chantrelle)
(1 'matsutake))
(defun press/forage ()
(if (randomp *forage-chance*)
(progn (msg "You found a mushroom.")
(inv-inc 'mushrooms (random-forage)))
(msg "You don't find anything.")))
;;;; 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/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*)))
(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)
(draw-center pad 0 "INVENTORY" +bold+)
(iterate
(with y = 2)
(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 *ui/game*))
(unwind-protect (progn ,@body)
(pop (boots:children *ui/game*)))))
(defun tick (delta)
(tick/hunger delta))
(defun game ()
(with-ui *ui/game*
(iterate
(timing real-time :per-iteration-into delta)
(incf *elapsed* delta)
(tick (/ (float delta 1.0d0) internal-time-units-per-second))
(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/forage))
(#\tab (msg "TODO"))
(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)
(boots:draw pad 0 0 "Paused" +ooc+)
(boots:draw pad 0 2 "[R]esume" +ooc+)
(boots:draw pad 0 3 "[Q]uit Game" +ooc+))
(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 (+ 3 (length *asset/help*))
:border t :margin t
:fill-char #\space :fill-attr +default+
:draw 'draw/help))
(defun draw/help (pad)
(boots:draw pad 0 0 "HELP" +default+)
(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
*calories* (* 1.0 10)
*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
(with-in-game-colors
(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))