--- a/.lispwords Mon Aug 01 15:16:37 2016 +0000
+++ b/.lispwords Tue Aug 02 14:31:39 2016 +0000
@@ -1,2 +1,3 @@
(1 spit)
(1 recursively)
+(2 state-machine)
--- a/Makefile Mon Aug 01 15:16:37 2016 +0000
+++ b/Makefile Tue Aug 02 14:31:39 2016 +0000
@@ -1,4 +1,4 @@
.PHONY:
-quickutils.lisp: make-quickutils.lisp
+vendor/quickutils.lisp: make-quickutils.lisp
sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
--- a/make-quickutils.lisp Mon Aug 01 15:16:37 2016 +0000
+++ b/make-quickutils.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -1,13 +1,14 @@
(ql:quickload 'quickutil)
(qtlc:save-utils-as
- "quickutils.lisp"
+ "vendor/quickutils.lisp"
:utilities '(
:with-gensyms
:once-only
:compose
:curry
:rcurry
+ :parse-body
; :n-grams
:define-constant
; :switch
--- a/package.lisp Mon Aug 01 15:16:37 2016 +0000
+++ b/package.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -3,7 +3,7 @@
#:cl
#:iterate
#:cl-arrows
- #:sand.quickutils)
+ #:silt.quickutils)
(:export
#:zap%
#:%
@@ -11,6 +11,8 @@
#:recur
#:dis
#:spit
+ #:d
+ #:clamp
#:dlambda
@@ -39,8 +41,10 @@
#:->))
(defpackage #:silt
- (:use #:cl
- #:iterate
- #:cl-arrows
- #:silt.quickutils
- #:silt.utils))
+ (:use
+ #:cl
+ #:iterate
+ #:cl-arrows
+ #:silt.quickutils
+ #:silt.utils
+ #:state-machine))
--- a/quickutils.lisp Mon Aug 01 15:16:37 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,226 +0,0 @@
-;;;; This file was automatically generated by Quickutil.
-;;;; See http://quickutil.org for details.
-
-;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :DEFINE-CONSTANT) :ensure-package T :package "SILT.QUICKUTILS")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package "SILT.QUICKUTILS")
- (defpackage "SILT.QUICKUTILS"
- (:documentation "Package that contains Quickutil utility functions.")
- (:use #:cl))))
-
-(in-package "SILT.QUICKUTILS")
-
-(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
- :MAKE-GENSYM-LIST :ONCE-ONLY
- :ENSURE-FUNCTION :COMPOSE :CURRY
- :RCURRY :DEFINE-CONSTANT))))
-
- (deftype string-designator ()
- "A string designator type. A string designator is either a string, a symbol,
-or a character."
- `(or symbol string character))
-
-
- (defmacro with-gensyms (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(let ,(mapcar (lambda (name)
- (multiple-value-bind (symbol string)
- (etypecase name
- (symbol
- (values name (symbol-name name)))
- ((cons symbol (cons string-designator null))
- (values (first name) (string (second name)))))
- `(,symbol (gensym ,string))))
- names)
- ,@forms))
-
- (defmacro with-unique-names (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(with-gensyms ,names ,@forms))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun make-gensym-list (length &optional (x "G"))
- "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
-using the second (optional, defaulting to `\"G\"`) argument."
- (let ((g (if (typep x '(integer 0)) x (string x))))
- (loop repeat length
- collect (gensym g))))
- ) ; eval-when
-
- (defmacro once-only (specs &body forms)
- "Evaluates `forms` with symbols specified in `specs` rebound to temporary
-variables, ensuring that each initform is evaluated only once.
-
-Each of `specs` must either be a symbol naming the variable to be rebound, or of
-the form:
-
- (symbol initform)
-
-Bare symbols in `specs` are equivalent to
-
- (symbol symbol)
-
-Example:
-
- (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
- (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
- (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
- (names-and-forms (mapcar (lambda (spec)
- (etypecase spec
- (list
- (destructuring-bind (name form) spec
- (cons name form)))
- (symbol
- (cons spec spec))))
- specs)))
- ;; bind in user-macro
- `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
- gensyms names-and-forms)
- ;; bind in final expansion
- `(let (,,@(mapcar (lambda (g n)
- ``(,,g ,,(cdr n)))
- gensyms names-and-forms))
- ;; bind in user-macro
- ,(let ,(mapcar (lambda (n g) (list (car n) g))
- names-and-forms gensyms)
- ,@forms)))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;;; To propagate return type and allow the compiler to eliminate the IF when
- ;;; it is known if the argument is function or not.
- (declaim (inline ensure-function))
-
- (declaim (ftype (function (t) (values function &optional))
- ensure-function))
- (defun ensure-function (function-designator)
- "Returns the function designated by `function-designator`:
-if `function-designator` is a function, it is returned, otherwise
-it must be a function name and its `fdefinition` is returned."
- (if (functionp function-designator)
- function-designator
- (fdefinition function-designator)))
- ) ; eval-when
-
- (defun compose (function &rest more-functions)
- "Returns a function composed of `function` and `more-functions` that applies its ;
-arguments to to each in turn, starting from the rightmost of `more-functions`,
-and then calling the next one with the primary value of the last."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (reduce (lambda (f g)
- (let ((f (ensure-function f))
- (g (ensure-function g)))
- (lambda (&rest arguments)
- (declare (dynamic-extent arguments))
- (funcall f (apply g arguments)))))
- more-functions
- :initial-value function))
-
- (define-compiler-macro compose (function &rest more-functions)
- (labels ((compose-1 (funs)
- (if (cdr funs)
- `(funcall ,(car funs) ,(compose-1 (cdr funs)))
- `(apply ,(car funs) arguments))))
- (let* ((args (cons function more-functions))
- (funs (make-gensym-list (length args) "COMPOSE")))
- `(let ,(loop for f in funs for arg in args
- collect `(,f (ensure-function ,arg)))
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (lambda (&rest arguments)
- (declare (dynamic-extent arguments))
- ,(compose-1 funs))))))
-
-
- (defun curry (function &rest arguments)
- "Returns a function that applies `arguments` and the arguments
-it is called with to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- ;; Using M-V-C we don't need to append the arguments.
- (multiple-value-call fn (values-list arguments) (values-list more)))))
-
- (define-compiler-macro curry (function &rest arguments)
- (let ((curries (make-gensym-list (length arguments) "CURRY"))
- (fun (gensym "FUN")))
- `(let ((,fun (ensure-function ,function))
- ,@(mapcar #'list curries arguments))
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (lambda (&rest more)
- (apply ,fun ,@curries more)))))
-
-
- (defun rcurry (function &rest arguments)
- "Returns a function that applies the arguments it is called
-with and `arguments` to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- (multiple-value-call fn (values-list more) (values-list arguments)))))
-
-
- (defun %reevaluate-constant (name value test)
- (if (not (boundp name))
- value
- (let ((old (symbol-value name))
- (new value))
- (if (not (constantp name))
- (prog1 new
- (cerror "Try to redefine the variable as a constant."
- "~@<~S is an already bound non-constant variable ~
- whose value is ~S.~:@>" name old))
- (if (funcall test old new)
- old
- (restart-case
- (error "~@<~S is an already defined constant whose value ~
- ~S is not equal to the provided initial value ~S ~
- under ~S.~:@>" name old new test)
- (ignore ()
- :report "Retain the current value."
- old)
- (continue ()
- :report "Try to redefine the constant."
- new)))))))
-
- (defmacro define-constant (name initial-value &key (test ''eql) documentation)
- "Ensures that the global variable named by `name` is a constant with a value
-that is equal under `test` to the result of evaluating `initial-value`. `test` is a
-function designator that defaults to `eql`. If `documentation` is given, it
-becomes the documentation string of the constant.
-
-Signals an error if `name` is already a bound non-constant variable.
-
-Signals an error if `name` is already a constant variable whose value is not
-equal under `test` to result of evaluating `initial-value`."
- `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
- ,@(when documentation `(,documentation))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(with-gensyms with-unique-names once-only compose curry rcurry
- define-constant)))
-
-;;;; END OF quickutils.lisp ;;;;
--- a/silt.asd Mon Aug 01 15:16:37 2016 +0000
+++ b/silt.asd Tue Aug 02 14:31:39 2016 +0000
@@ -13,7 +13,10 @@
:serial t
:components
- ((:file "quickutils") ; quickutils package ordering crap
+ ((:module "vendor"
+ :serial t
+ :components ((:file "quickutils")
+ (:file "state-machine")))
(:file "package")
(:module "src"
:serial t
--- a/src/main.lisp Mon Aug 01 15:16:37 2016 +0000
+++ b/src/main.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -1,50 +1,93 @@
(in-package #:silt)
-
(defparameter *running* nil)
(defparameter *running* t)
(defparameter *width* 1)
(defparameter *height* 1)
-(defun render ()
- (charms:move-cursor charms:*standard-window*
- (- (floor *width* 2) 3)
- (floor *height* 2))
- (charms:write-string-at-cursor charms:*standard-window* "S I L T")
- (charms:move-cursor charms:*standard-window* 0 0))
-
-
-(defun tick ()
- )
-
-(defun handle-input ()
- (let ((input (charms:get-char charms:*standard-window* :ignore-error t)))
- (case input
- ((nil) nil)
- (#\q (setf *running* nil)))))
(defun manage-screen ()
(multiple-value-bind (w h)
(charms:window-dimensions charms:*standard-window*)
(setf *width* w *height* h)))
+
+(defmacro render (&body body)
+ `(prog2
+ (progn
+ (manage-screen)
+ (charms:clear-window charms:*standard-window*))
+ (progn ,@body)
+ (charms:refresh-window charms:*standard-window*)))
+
+(defun clamp-w (x)
+ (clamp 0 (1- *width*) x))
+
+(defun clamp-h (y)
+ (clamp 0 (1- *height*) y))
+
+(defun write-centered (string x y)
+ (charms:write-string-at-point
+ charms:*standard-window*
+ string
+ (clamp-w (- x (floor (length string) 2)))
+ (clamp-h y)))
+
+(defun write-left (string x y)
+ (charms:write-string-at-point
+ charms:*standard-window*
+ string
+ (clamp-w x)
+ (clamp-h y)))
+
+
+(defun render-title ()
+ (render
+ (let ((cx (floor *width* 2))
+ (cy (floor *height* 2)))
+ (write-centered "S I L T" cx cy)
+ (write-centered "Press any key to start..." cx (1+ cy)) )))
+
+(defun render-intro ()
+ (render
+ (charms:move-cursor charms:*standard-window*
+ (- (floor *width* 2) 3)
+ (floor *height* 2))
+ (write-left "Welcome to Silt." 0 0)
+ (write-left "You are the god of a toroidal world." 0 1)))
+
+
+(defun handle-input-title ()
+ (charms:disable-non-blocking-mode charms:*standard-window*)
+ (charms:get-char charms:*standard-window*))
+
+(defun handle-input-intro ()
+ (charms:disable-non-blocking-mode charms:*standard-window*)
+ (charms:get-char charms:*standard-window*))
+
+
+(defparameter *game*
+ (state-machine ()
+ ((title ()
+ (render-title)
+ (handle-input-title)
+ (transition intro))
+ (intro ()
+ (render-intro)
+ (handle-input-intro)
+ (transition quit))
+ (quit ()
+ 'goodbye))
+ (transition title)))
+
+
(defun run ()
(setf *running* t)
(charms:with-curses ()
(charms:disable-echoing)
(charms:enable-raw-input :interpret-control-characters t)
- (charms:enable-non-blocking-mode charms:*standard-window*)
-
- (iterate
- (while *running*)
- (charms:clear-window charms:*standard-window*)
- (manage-screen)
- (handle-input)
- (tick)
- (render)
- (charms:refresh-window charms:*standard-window*)
- (sleep 0.03))))
-
+ ; (charms:enable-non-blocking-mode charms:*standard-window*)
+ (invoke-state-machine *game*)))
; (run)
--- a/src/utils.lisp Mon Aug 01 15:16:37 2016 +0000
+++ b/src/utils.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -70,6 +70,28 @@
,@body))
+;;;; Maths
+(defun d (n sides &optional (plus 0))
+ "Roll some dice.
+
+ (d 1 4) -> roll 1d4
+ (d 2 8) -> roll 2d8
+ (d 1 10 -1) -> roll 1d10-1
+
+ "
+ (+ (iterate (repeat n)
+ (sum (1+ (random sides))))
+ plus))
+
+(defun clamp (from to n)
+ (let ((max (max from to))
+ (min (min from to)))
+ (cond
+ ((> n max) max)
+ ((< n min) min)
+ (t n))))
+
+
;;;; dlambda
(defmacro dlambda (&rest clauses)
(with-gensyms (message arguments)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -0,0 +1,248 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "vendor/quickutils.lisp" :utilities '(:WITH-GENSYMS :ONCE-ONLY :COMPOSE :CURRY :RCURRY :PARSE-BODY :DEFINE-CONSTANT) :ensure-package T :package "SILT.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "SILT.QUICKUTILS")
+ (defpackage "SILT.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "SILT.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:STRING-DESIGNATOR :WITH-GENSYMS
+ :MAKE-GENSYM-LIST :ONCE-ONLY
+ :ENSURE-FUNCTION :COMPOSE :CURRY
+ :RCURRY :PARSE-BODY :DEFINE-CONSTANT))))
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-gensym-list (length &optional (x "G"))
+ "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop repeat length
+ collect (gensym g))))
+ ) ; eval-when
+
+ (defmacro once-only (specs &body forms)
+ "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun compose (function &rest more-functions)
+ "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+ (define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (defun parse-body (body &key documentation whole)
+ "Parses `body` into `(values remaining-forms declarations doc-string)`.
+Documentation strings are recognized only if `documentation` is true.
+Syntax errors in body are signalled and `whole` is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+
+ (defun %reevaluate-constant (name value test)
+ (if (not (boundp name))
+ value
+ (let ((old (symbol-value name))
+ (new value))
+ (if (not (constantp name))
+ (prog1 new
+ (cerror "Try to redefine the variable as a constant."
+ "~@<~S is an already bound non-constant variable ~
+ whose value is ~S.~:@>" name old))
+ (if (funcall test old new)
+ old
+ (restart-case
+ (error "~@<~S is an already defined constant whose value ~
+ ~S is not equal to the provided initial value ~S ~
+ under ~S.~:@>" name old new test)
+ (ignore ()
+ :report "Retain the current value."
+ old)
+ (continue ()
+ :report "Try to redefine the constant."
+ new)))))))
+
+ (defmacro define-constant (name initial-value &key (test ''eql) documentation)
+ "Ensures that the global variable named by `name` is a constant with a value
+that is equal under `test` to the result of evaluating `initial-value`. `test` is a
+function designator that defaults to `eql`. If `documentation` is given, it
+becomes the documentation string of the constant.
+
+Signals an error if `name` is already a bound non-constant variable.
+
+Signals an error if `name` is already a constant variable whose value is not
+equal under `test` to result of evaluating `initial-value`."
+ `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+ ,@(when documentation `(,documentation))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(with-gensyms with-unique-names once-only compose curry rcurry
+ parse-body define-constant)))
+
+;;;; END OF vendor/quickutils.lisp ;;;;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/state-machine.lisp Tue Aug 02 14:31:39 2016 +0000
@@ -0,0 +1,139 @@
+;;;; https://bitbucket.org/tarballs_are_good/lisp-random/src/a57dc2cd93ee6aa689d9b68f3f6eb62f7dd67cd2/state-machine.lisp
+(defpackage #:state-machine
+ (:use #:cl)
+ (:export
+ #:state-machine
+ #:invoke-state-machine
+ #:transition))
+
+(in-package #:state-machine)
+
+;;;; state-machine.lisp
+;;;;
+;;;; Copyright (c) 2015 Robert Smith
+;;;;
+;;;; This file is an attempt to build a relatively efficient state
+;;;; machine abstraction.
+
+;;;; Bugs: SBCL complains about modifying constant data. I don't know if it is right or if I am right.
+
+;;; (ql:quickload :alexandria)
+
+(defclass state-machine ()
+ ((states :initarg :states
+ :reader state-machine-states
+ :documentation "A list of the names of each state.")
+ (transition-graph :initarg :transition-graph
+ :reader state-machine-transition-graph
+ :documentation "A hash table containing the state names as keys and a list of possible transitions as values.")
+ (invocation-function :initarg :invocation-function
+ :reader state-machine-invocation-function
+ :documentation "The multivariate function to invoke to enter the state machine.")))
+
+(defgeneric invoke-state-machine (sm &rest args)
+ (:method ((sm state-machine) &rest args)
+ (apply (state-machine-invocation-function sm) args)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun contains-duplicates-p (list &key (test 'eql))
+ (/= (list-length list)
+ (list-length (remove-duplicates list :test test))))
+)
+
+(defmacro transition (state &rest args)
+ (declare (ignore state args))
+ (error "Transition is an internal macro to DEFINE-STATE-MACHINE."))
+
+(defmacro state-machine (args state-definitions &body body)
+ "Create a state machine which takes the arguments ARGS the body BODY. Return a state machine object which can be invoked with the arguments ARGS.
+
+STATE-DEFINITIONS is a list of state definitions. It looks much like the definition of a LABELS function definition:
+
+ (state-name arguments
+ [documentation]
+ [declarations]
+ forms ...)
+
+Within the state definitions, however, there is a macro defined called TRANSITION which transitions to one of the other states immediately without return. (The use of TRANSITION ensures that a tail call will happen.)
+
+BODY can enter the state machine
+
+\(It is allowed, but discouraged, to bypass the use of TRANSITION by simply calling the state name as a function instead.)"
+ (let ((states (mapcar #'first state-definitions))
+ (transition-graph (make-hash-table)))
+ (labels ((construct-state (state-def)
+ (destructuring-bind (name args . body) state-def
+ (multiple-value-bind (forms decls doc)
+ (silt.quickutils:parse-body body :documentation t)
+ ;; This is a LABELS function definition.
+ `(,name ,args
+ ,@(and doc (list doc))
+ ,@decls
+ (macrolet ((transition (state &rest args)
+ (unless (member state ',states)
+ (error "The state ~S in the transition ~
+ occurring in the state ~S ~
+ is not a valid."
+ state
+ ',name))
+ (pushnew state
+ (gethash ',name ,transition-graph))
+ `(return-from ,',name
+ (,state ,@args))))
+ ,@forms))))))
+ (when (contains-duplicates-p states)
+ (warn "There are duplicate state names in the state machine."))
+ (multiple-value-bind (forms decls doc)
+ (silt.quickutils:parse-body body :documentation t)
+ `(make-instance
+ 'state-machine
+ :states ',(remove-duplicates states)
+ :transition-graph ',transition-graph
+ :invocation-function
+ (lambda ,args
+ ,@(and doc (list doc))
+ ,@decls
+ (labels ,(mapcar #'construct-state state-definitions)
+ (macrolet ((transition (state &rest args)
+ (unless (member state ',states)
+ (error "The state ~S in the initial transition ~
+ is not a valid."
+ state))
+ (pushnew state
+ (gethash nil ,transition-graph))
+ `(,state ,@args)))
+ ,@forms))))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Examples ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defparameter *beer-machine*
+ (state-machine (count)
+ ((decide (current-count)
+ (if (= 1 current-count)
+ (transition last-case)
+ (transition general-case current-count)))
+ (general-case (current-count)
+ (format t "~D bottles of beer on the wall, ~D bottles of beer.~%~
+ Take one down, pass it around, ~D bottle~:P of beer on ~
+ the wall...~%"
+ current-count
+ current-count
+ (1- current-count))
+ (transition decide (1- current-count)))
+ (last-case ()
+ (format t "If that one bottle should happen to fall, what a waste ~
+ of alcohol!")))
+ (transition decide count)))
+
+(defparameter *tail-call-test*
+ (state-machine (x)
+ ((even (x)
+ (if (zerop x)
+ t
+ (transition odd (1- x))))
+ (odd (x)
+ (if (zerop x)
+ nil
+ (transition even (1- x)))))
+ (even x)))