src/main.lisp @ 614ad4a1d44e

(in-package :dark)

;;;; Global -------------------------------------------------------------------
(defconstant +black+ (boots:rgb 0 0 0))
(defconstant +white+ (boots:rgb 255 255 255))
(defconstant +amber+ (boots:rgb #xFB #x7D #x01))
(defconstant +default+ (boots:attr :fg +amber+ :bg +black+))
(defconstant +reverse+ (boots:attr :fg +black+ :bg +amber+))
(defconstant +ooc+ (boots:attr :fg +white+ :bg +black+))

(defvar *event* nil)
(defvar *mods* nil)

(defvar *countdown* nil)
(defvar *seed* nil)


;;;; Assets -------------------------------------------------------------------
(defparameter *asset/splash* (alexandria:read-file-into-string "assets/splash.txt"))
(defparameter *asset/journal* (alexandria:read-file-into-string "assets/journal.txt"))


;;;; Utils --------------------------------------------------------------------
(defparameter *pcg* (pcg:make-pcg))

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

(defun press-any-key ()
  (boots:read-event)
  (values))

(defmacro with-in-game-colors (&body body)
  `(let ((boots:*border-attr* +default+))
     ,@body))

(defmacro with-ooc-colors (&body body)
  `(let ((boots:*border-attr* +ooc+))
     ,@body))

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

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


(defvar *debug* (make-ring-buffer))

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



;;;; Splash -------------------------------------------------------------------
(defun draw/splash (pad)
  (boots:draw pad 0 0 *asset/splash*))

(defun splash ()
  (with-ooc-colors
    (with-ui (boots:make-canvas :width 50 :height 10 :border t :margin t
                                :fill-char #\space
                                :fill-attr +default+
                                :draw #'draw/splash)
      (boots:redraw)
      (press-any-key)))
  (chiron))


;;;; Journal ------------------------------------------------------------------
(defun draw/journal (pad)
  (boots:draw pad 0 0 *asset/journal* +default+))


;;;; Email --------------------------------------------------------------------
(defun draw/email (pad)
  (boots:draw pad 0 0 "this is ur email" +default+))



;;;; Chiron -------------------------------------------------------------------
(defun human-countdown ()
  (nest
    (multiple-value-bind (remaining) (truncate *countdown* internal-time-units-per-second))
    (multiple-value-bind (days remaining) (truncate remaining (* 60 60 24)))
    (multiple-value-bind (hours remaining) (truncate remaining (* 60 60)))
    (multiple-value-bind (mins remaining) (truncate remaining 60))
    (multiple-value-bind (secs) (truncate remaining))
    (format nil "~Dd ~2,'0Dh ~2,'0Dm ~2,'0Ds" days hours mins secs)))

(defun draw/chiron/top-bar (pad)
  (boots:draw pad 0 0 "CHIRON" (boots:attr :fg +black+ :bg +amber+ :bold t))
  (let ((closing (format nil "Window closes in: ~A" (human-countdown))))
    (boots:draw pad (- (boots:width pad) (length closing)) 0
                closing +reverse+)))

(defun draw/chiron/bottom-bar (pad)
  (boots:draw pad 0 0 "user: elf@chiron" +reverse+)
  (draw-right pad (1- (boots:width pad)) 0
              (format nil "(SEED ~X)" *seed*) +reverse+))


(defparameter *chiron/top-bar*
  (boots:make-canvas :height 1 :margin-bottom 1
                     :fill-char #\space
                     :fill-attr +reverse+ :draw #'draw/chiron/top-bar))

(defparameter *chiron/bottom-bar*
  (boots:make-canvas :height 1 :margin-top 1
                     :fill-char #\space
                     :fill-attr +reverse+ :draw #'draw/chiron/bottom-bar))


(defparameter *chiron/journal* (boots:make-canvas :draw #'draw/journal))
(defparameter *chiron/email* (boots:make-canvas :draw #'draw/email))

(defparameter *chiron* (boots:pile ()))

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

(defun key-name (key)
  (case key 
    (#\tab "tab")
    (t (string key))))

(defun select-box (heading options)
  (with-chiron-layer
      (boots:stack (:margin t :width 20 :height (+ (length options) 2) :border t
                    :fill-char #\space :fill-attr +default+)
        (boots:canvas (:fill-char #\space :fill-attr +default+ :height 1 :border-bottom t) (pad)
          (boots:draw pad
                      (truncate (- (boots:width pad) (length heading)) 2)
                      0 heading +default+))
        (boots:canvas (:fill-char #\space :fill-attr +default+) (pad)
          (iterate (for y :from 0)
                   (for (key description result) :in options)
                   (boots:draw pad 0 y (format nil "[~A] ~A" (key-name key)
                                               description) +default+))))
    (third (iterate
             (boots:redraw)
             (for (values e m) = (boots:read-event))
             (unless (handle-global-event e m)
               (thereis (find-if (lambda (option)
                                   (boots:event= option e m))
                                 options :key #'first)))))))

(defun select ()
  (select-box "SELECT"
              '((#\m "Mail" :mail)
                (#\j "Journal" :journal)
                (#\q "Log Out" :quit)
                (#\tab "Nevermind" :nevermind))))

(defun chiron ()
  (with-ui *chiron*
    (with-chiron-layer (boots:stack (:fill-char #\space :fill-attr +default+)
                         *chiron/top-bar*
                         *chiron/journal*
                         *chiron/bottom-bar*)
      (iterate
        (timing real-time :per-iteration-into delta)
        (decf *countdown* delta)
        (boots:redraw)
        (event-case (boots:read-event-no-hang)
          (#\tab (dbg "~S" (select)))
          (t nil))))))


;;;; 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-ooc-colors
    (with-ui (boots:make-canvas :width 30 :height 10 :border t :margin t
                                :fill-char #\space
                                :fill-attr +ooc+
                                :draw #'draw/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))))))))


;;;; Main ---------------------------------------------------------------------
(defun init ()
  (rb-clear *debug*)
  (setf *seed* (cl:random (expt 2 60) (cl:make-random-state))
        *pcg* (pcg:make-pcg :seed *seed*)
        *countdown* (* internal-time-units-per-second
                       (+ (* 60 60 24 15)
                          (random 0 (* 60 60 4))))))

(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/dark"
    :executable t
    :save-runtime-options t
    :toplevel #'dark:toplevel))