# HG changeset patch # User Steve Losh # Date 1618945984 14400 # Node ID 614ad4a1d44ed7cfec764f5b188ba7b7ae8f4a62 # Parent 05bd74b8d9c4e284674a906c5d76309c549ad044 Checkpoint before pivot diff -r 05bd74b8d9c4 -r 614ad4a1d44e .lispwords --- a/.lispwords Sun Apr 18 17:40:08 2021 -0400 +++ b/.lispwords Tue Apr 20 15:13:04 2021 -0400 @@ -0,0 +1,3 @@ +(1 stack shelf pile) +(2 canvas) +(1 with-chiron-layer) diff -r 05bd74b8d9c4 -r 614ad4a1d44e assets/journal.txt --- a/assets/journal.txt Sun Apr 18 17:40:08 2021 -0400 +++ b/assets/journal.txt Tue Apr 20 15:13:04 2021 -0400 @@ -1,2 +1,4 @@ September 22, 1987 Finally got access to a computer terminal. + +Cosmic Hyperspace Interferometer R Operations Network diff -r 05bd74b8d9c4 -r 614ad4a1d44e dark.asd --- a/dark.asd Sun Apr 18 17:40:08 2021 -0400 +++ b/dark.asd Tue Apr 20 15:13:04 2021 -0400 @@ -10,7 +10,9 @@ :depends-on (#+sbcl #:sb-sprof :alexandria :boots + :cl-pcg :iterate + :local-time :losh) :serial t diff -r 05bd74b8d9c4 -r 614ad4a1d44e scratch.lisp --- a/scratch.lisp Sun Apr 18 17:40:08 2021 -0400 +++ b/scratch.lisp Tue Apr 20 15:13:04 2021 -0400 @@ -1,5 +1,29 @@ +(in-package :dark) + (ql:quickload :bordeaux-threads) (bt:interrupt-thread (first (remove "main thread" (bt:all-threads) :key #'bt:thread-name :test-not #'string=)) (lambda () (error "stop"))) + +(ql:quickload :boots) + + +(boots%::print-attr + (boots:attr :fg (boots:rgb 1 2 3))) + + + + + + + + +abc +len = 3 +wid = 10 +10 - 3 = 7 + +0123456789 + + diff -r 05bd74b8d9c4 -r 614ad4a1d44e src/main.lisp --- a/src/main.lisp Sun Apr 18 17:40:08 2021 -0400 +++ b/src/main.lisp Tue Apr 20 15:13:04 2021 -0400 @@ -11,6 +11,9 @@ (defvar *event* nil) (defvar *mods* nil) +(defvar *countdown* nil) +(defvar *seed* nil) + ;;;; Assets ------------------------------------------------------------------- (defparameter *asset/splash* (alexandria:read-file-into-string "assets/splash.txt")) @@ -18,6 +21,11 @@ ;;;; 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)) @@ -37,6 +45,34 @@ (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*)) @@ -44,23 +80,115 @@ (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))) - (journal)) + (chiron)) ;;;; Journal ------------------------------------------------------------------ (defun draw/journal (pad) (boots:draw pad 0 0 *asset/journal* +default+)) -(defun journal () - (with-ui (boots:make-canvas :border t :fill-attr +default+ - :draw #'draw/journal) - (loop (boots:redraw) - (boots:event-case (boots:read-event-no-hang) - (#\esc (pause)))))) + +;;;; 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 -------------------------------------------------------------------- @@ -69,10 +197,10 @@ (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) @@ -84,7 +212,16 @@ ;;;; 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 diff -r 05bd74b8d9c4 -r 614ad4a1d44e src/package.lisp --- a/src/package.lisp Sun Apr 18 17:40:08 2021 -0400 +++ b/src/package.lisp Tue Apr 20 15:13:04 2021 -0400 @@ -1,3 +1,4 @@ (defpackage :dark (:use :cl :iterate :losh) + (:shadow :random) (:export :toplevel :build))