# HG changeset patch # User Steve Losh # Date 1470148299 0 # Node ID 9fada4d535fcebfff1b1968fb8b64e91e6c50016 # Parent 6c1b8faa556923a8cf97c7587e247afdf7545472 State machine, vendoring, etc diff -r 6c1b8faa5569 -r 9fada4d535fc .lispwords --- 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) diff -r 6c1b8faa5569 -r 9fada4d535fc Makefile --- 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)' diff -r 6c1b8faa5569 -r 9fada4d535fc make-quickutils.lisp --- 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 diff -r 6c1b8faa5569 -r 9fada4d535fc package.lisp --- 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)) diff -r 6c1b8faa5569 -r 9fada4d535fc quickutils.lisp --- 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 ;;;; diff -r 6c1b8faa5569 -r 9fada4d535fc silt.asd --- 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 diff -r 6c1b8faa5569 -r 9fada4d535fc src/main.lisp --- 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) diff -r 6c1b8faa5569 -r 9fada4d535fc src/utils.lisp --- 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) diff -r 6c1b8faa5569 -r 9fada4d535fc vendor/quickutils.lisp --- /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 ;;;; diff -r 6c1b8faa5569 -r 9fada4d535fc vendor/state-machine.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)))