├── .emacs ├── LICENSE ├── README.md ├── abacus.asd ├── abacus.lisp └── example.lisp /.emacs: -------------------------------------------------------------------------------- 1 | (modify-syntax-entry ?\| "(]" lisp-mode-syntax-table) 2 | (modify-syntax-entry ?\] ")|" lisp-mode-syntax-table) 3 | 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Chris Kohlhepp 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in 13 | the documentation and/or other materials provided with the 14 | distribution. 15 | 16 | * Neither Chris Kohlhepp nor the names of contributors to the 17 | software may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Abacus 2 | 3 | 4 | ## Overview 5 | 6 | Abacus is a set of macros that unify Common Lisp syntax for deep destructuring pattern matching from Optima and CL-ALGEBRAIC-DATA-TYPES that is modelled on universal quantification. Abacus also provides an extended syntax for pattern matching of both Optima patterns and CL-ALGEBRAIC-DATA-TYPES using a syntax that leans on Haskell and OCaml. This syntax uses the OR symbol | to introduce match expressions and the arrow symbol => to introduce match expressions. 7 | 8 | A detailed elaboration may be found at 9 | 10 | ## Example Use of S-Expression Based Syntax: 11 | 12 | Somewhere defining an algebraic data type... 13 | 14 | (adt:defdata (batter-ingredient) 15 | (milk float) 16 | (flour float) 17 | (eggs integer)) 18 | 19 | Then somewhere else we dispatch on a variable called message. 20 | The naming message is arbitrary and could be any variable name. 21 | 22 | (amatch message 23 | 24 | ... 25 | 26 | (all when (algebraic-guard all batter-ingredient) 27 | (algebraic-match-with 28 | ((milk ml) ; constructor pattern 29 | (format t "~%Adding ~a milliliters of milk" ml)) 30 | ((flour gr) ; constructor pattern 31 | (format t "~%Adding ~a grams of flour" gr)) 32 | ((eggs numeggs) ; constructor pattern 33 | (format t "~%Adding ~a egg(s)" numeggs)))) 34 | 35 | ... ) 36 | 37 | ## Example Use of Extended Syntax: 38 | 39 | Somewhere defining an algebraic data type... 40 | 41 | (adt:defdata (batter-ingredient) 42 | (milk float) 43 | (flour float) 44 | (eggs integer)) 45 | 46 | Enable extended match syntax programmatically 47 | 48 | (use-extended-match-syntax) 49 | 50 | Then somewhere else we dispatch on a variable called message. 51 | The naming message is arbitrary and could be any variable name. 52 | 53 | 54 | (amatch message 55 | 56 | 57 | ; Algebraic Type 58 | (all when (algebraic-guard all batter-ingredient) 59 | (algebraic-match-with 60 | | (milk ml) => 61 | (format t "~%Adding ~a milliliters of milk" ml)] 62 | | (flour gr) => 63 | (format t "~%Adding ~a grams of flour" gr)] 64 | | (eggs numeggs) => 65 | (format t "~%Adding ~a egg(s)" numeggs) ] ) ) 66 | 67 | ; Deep destructuring match on a conventional data structure 68 | ; ... here a list based pair of symbols, one constant, one variable 69 | | (list :add myvariable) => 70 | 71 | ... do something with "myvariable" 72 | 73 | ] 74 | 75 | ... further match clauses 76 | 77 | ) 78 | 79 | 80 | Optionally revert to conventional syntax 81 | 82 | (disable-extended-match-syntax) 83 | 84 | 85 | -------------------------------------------------------------------------------- /abacus.asd: -------------------------------------------------------------------------------- 1 | ;;;; abacus.asd 2 | ;;;; Copyright (c) 2014 Christoph Kohlhepp 3 | 4 | (defsystem "abacus" 5 | :description "Common Lisp Syntat Extension to unify OPTIMA and CL-ALGEABRAIC-DATA-TYPES" 6 | :version "0.1" 7 | :author "Chris Kohlhepp" 8 | :licence "All rights reserved" 9 | :depends-on ("optima" "cl-algebraic-data-type" "let-over-lambda") 10 | :components ((:file "abacus")) 11 | ) 12 | -------------------------------------------------------------------------------- /abacus.lisp: -------------------------------------------------------------------------------- 1 | ;;;; abavus.lisp 2 | ;;;; Copyright (c) 2014 Christoph Kohlhepp 3 | 4 | (defpackage :abacus 5 | ; import namespaces from the following packages 6 | (:use :common-lisp :optima :let-over-lambda) 7 | 8 | ; abacus package exported symbols 9 | (:export #:amatch 10 | #:algebraic-match-with 11 | #:algebraic-guard 12 | #:use-extended-match-syntax 13 | #:disable-extended-match-syntax 14 | :left-bracket 15 | :right-bracket 16 | :*readtables-stack*)) 17 | 18 | ;; Export needed functionality from let-over-lambda 19 | (in-package #:let-over-lambda) 20 | (export 'defmacro!) 21 | 22 | ;;; Define package Abacus 23 | (in-package :abacus) 24 | 25 | ;;;=============================== 26 | ;;; Extended Pattern Match Syntax 27 | ;;;=============================== 28 | 29 | ;; Stack of Lisp syntax tables 30 | ;; We use this to modify and restore current syntax tables 31 | (defvar *readtables-stack* nil) 32 | 33 | ;; Our pairwise delimiters - retain idiomatically Lisp outlook on scope. 34 | ;; What to use here is purely a judgement call... 35 | ;; [] are a possibility - yet Clojure uses this for argument sequences. 36 | ;; We deem readable pattern matching more paramount to the language. 37 | ;; So presently we use the OR symbol to start and ] to delimit. 38 | (defconstant left-bracket #\|) 39 | (defconstant right-bracket #\]) 40 | 41 | (defmacro use-extended-match-syntax () 42 | "A macro to enable the extended match syntax; 43 | eval-when controls when this is executed" 44 | '(eval-when (:compile-toplevel :load-toplevel :execute) 45 | (push *readtable* *readtables-stack*) 46 | (setq *readtable* (copy-readtable)) 47 | (set-macro-character right-bracket 'read-delimiter) 48 | (set-macro-character left-bracket 'read-expression ))) 49 | 50 | (defmacro disable-extended-match-syntax () 51 | "A macro to disable the extended match syntax; 52 | eval-when controls when this is executed" 53 | '(eval-when (:compile-toplevel :load-toplevel :execute) 54 | (setq *readtable* (pop *readtables-stack*)))) 55 | 56 | 57 | (defun tokenequal (x y) 58 | "A function which compares tokens based on aesthetic rendering equivalence, 59 | deliberately ignoring which package a symbol is interned in; only found to behave 60 | differently from equalp predicate in the context of reader macros. 61 | Compiler macros seem unaffected." 62 | (let ((xstring (format nil "~A" x)) 63 | (ystring (format nil "~A" y))) 64 | (equal xstring ystring))) 65 | 66 | 67 | (defun parse-match-forms (forms) 68 | "A macro using defun syntax as we don't care about delaying evaluation of arguments here as 69 | we will be called by way of the Lisp reader itself via (read-expression) dispatching 70 | through the *readtable*. We essentially don't have to worry about macro hygine here. 71 | This parses an expression of the form | token ... token => token ... token ] 72 | and returns an s-expression of the form ((token token) (token token)) to be consumed 73 | by algebraic-match-with macro. Malformed syntax raises appropriate compiler errors." 74 | 75 | (if (not forms) 76 | ;; case |] empty expression - raise compiler error 77 | (error "ABACUS: Empty match |] operation") 78 | (progn 79 | ;; Debug statement; uncommment as necessary 80 | ;; (format t "~%; compiling ABACUS: parsing forms ~S" forms) 81 | (if (not (eq 1 (count '=> forms :test #'tokenequal))) 82 | ;; case [token...token] but no => 83 | (error "ABACUS: Synax error. Match clause must contain exaxtly 1 => symbol") 84 | 85 | ;; let* is analog to OCaml let...in construct 86 | (let* ((arrow-position (position '=> forms :test #'tokenequal)) 87 | (pattern-specifier (subseq forms 0 arrow-position))) 88 | 89 | ;; Don't make copy of match expression; we retain all formatting 90 | ;; inclusive of line feeds --- useful when examining debug statements 91 | ;; We do, however, copy the pattern-specifier via subeq 92 | (loop for x from 0 to arrow-position do (setf forms (cdr forms))) 93 | (let ((match-expression forms)) 94 | 95 | (if (not pattern-specifier) 96 | ;; case |=> token ... token] 97 | (error "ABACUS: No pattern specifier given to match |]") 98 | (if (not match-expression) 99 | ;; case | token...token =>] 100 | (error "ABACUS: No match expression given to match [~S]" pattern-specifier) 101 | (progn 102 | ;; All good, generate code 103 | 104 | ;; Debug statement; uncommment as necessary 105 | ;;(format t "~%; compiling ABACUS: generating ~S" 106 | ;; `(,@pattern-specifier ,@match-expression)) 107 | `(,@pattern-specifier ,@match-expression)))))))))) 108 | 109 | 110 | (defun read-expression (stream char) 111 | "A function to be associated, via the Lisp syntax read table, 112 | with the reading of pattern matching expressions" 113 | (declare (ignore char)) 114 | (let* ((match-list (read-delimited-list right-bracket stream t))) 115 | (parse-match-forms match-list))) 116 | 117 | (defun read-delimiter (stream char) 118 | "A function to be associated, via the Lisp syntax read table, 119 | with the delimiter of pattern matching expressions. 120 | We need this as otherwise the simple expression '|x => x] 121 | would fail to parse since x] would be read as an atom resulting in END-OF-FILE." 122 | (declare (ignore stream)) 123 | (error "Delimiter of pattern matching expressions ~S found without preceeding pattern match" char)) 124 | 125 | ;;;================================================================ 126 | ;;; Unified handling of Optima Expressions and Algebraic Data Types 127 | ;;;================================================================ 128 | 129 | (defvar abacus-typespec nil) ;; This variable is used only in the compilation process, 130 | ;; but having this declaration here silences the compiler 131 | ;; warning about an othwerwise undefined variable at runtime 132 | 133 | 134 | (defmacro amatch (arg &body clauses) 135 | "[Macro] amatch 136 | amatch arg &body clauses 137 | Same as Optima MATCH, except that handling of algebraic types is enabled" 138 | 139 | ;; This macro needs no once-only to ensure hygene as long as each input 140 | ;; is expanded but once. This is presently the case. Adjust if necessary in the future. 141 | 142 | (if (not (boundp 'abacus-typespec)) ;; Forward declaration of algebraic type specification for 143 | (defvar abacus-typespec nil)) ;; use by algebraic-guard in compile time expansion 144 | `(let ((abacus-it nil)) ;; Pitch forward match term for use by algebraic-match-with 145 | (match ,arg ,@clauses))) ;; in expansion for run-time use by atd:match macro 146 | 147 | 148 | 149 | (defmacro algebraic-match-with (&body clauses) 150 | " Macro wrapper around cl-algebraic:match 151 | abacus-typespec is generated at compile time by algebraic-guard 152 | and initially defvar'ed by amatch. 153 | abacus-it is also set by code generated by algebraic-guard 154 | but at runtime." 155 | (if (or (not (boundp 'abacus-typespec)) (not abacus-typespec)) 156 | (progn 157 | (error "~%ALGEBRAIC-MATCH-WITH no type specification! Did you use algebraic-guard?") 158 | (setf abacus-typespec nil)) 159 | (format t "~%; compiling (ALGEBRAIC-MATCH-WITH over type ~A...)" abacus-typespec)) 160 | `(progn 161 | ;; Uncomment to generate compiler warning 162 | ;;(if (not (boundp 'abacus-it )) 163 | ;; (warn "~%ALGEBRAIC-MATCH-WITH no match argument! Did you use algebraic-guard?") 164 | (adt:match ,abacus-typespec abacus-it ,@clauses))) 165 | 166 | ;; Note use of o! and g! prefixes and defmacro! macro from Let-Over-Lambda. 167 | ;; O-Bang provides automatic once-only bindings to gensyms 168 | ;; G-Bang dereferences through these gensyms inside the macro. 169 | ;; We guard the argument for macro hygene in this way, but not the type. 170 | ;; Dereferencing a type ought to be side-effect free 171 | 172 | (defmacro! algebraic-guard (o!arg argtype) 173 | "Macro type guard - same as typep, except that it checks for algebraic type also 174 | and sets the abacus-match local variables abacus-it and abacus-typespec to 175 | reflect the last guarded instance and type; expects type argument un-quoted unlike typep" 176 | 177 | (setf abacus-typespec argtype) 178 | 179 | ;; Uncomment to obtain compiler notes 180 | (format t "~%; compiling (ALGEBRAIC-GUARD over type ~A...)" abacus-typespec) 181 | 182 | `(progn 183 | (setf abacus-it ,g!arg) 184 | (and (typep ,g!arg ',argtype ) 185 | (adt:algebraic-data-type-p ',argtype)) 186 | ) 187 | ) 188 | -------------------------------------------------------------------------------- /example.lisp: -------------------------------------------------------------------------------- 1 | 2 | 3 | ;build & import via (asdf:load-system :bakery) 4 | (defpackage :bakery 5 | ; import namespaces from the following packages 6 | (:use :common-lisp :cl-actors :optima :bordeaux-threads :cells :abacus) 7 | 8 | ; bakery package exported symbols 9 | (:export #:baker 10 | :cake 11 | :batter-ingredient 12 | :milk 13 | :flour 14 | :eggs)) 15 | 16 | 17 | (in-package :bakery) 18 | 19 | 20 | ; (adt:algebraic-type-p 'batter-ingredient) 21 | 22 | 23 | ;(defun get-constructor-symbols (adt) 24 | ; (mapcar #'car (adt:get-constructors adt))) 25 | 26 | ; (eq 'milk (first (get-constructor-symbols 'batter-ingredient))) 27 | 28 | ; (get-constructor-symbols 'batter-ingredient) 29 | 30 | (adt:defdata (batter-ingredient) 31 | (milk float) 32 | (flour float) 33 | (eggs integer)) 34 | 35 | (adt:defdata (icing-ingredient) 36 | (sugar keyword)) 37 | 38 | (adt:defdata (decoration-ingredient) 39 | (candles keyword)) 40 | 41 | 42 | (defun construct-accumulator () 43 | "A closure constructor, lambda-over-let-over-lambda pattern" 44 | (let ((elements (list))) 45 | (lambda (element) 46 | (setf elements (remove nil (adjoin element elements))) 47 | elements))) 48 | 49 | (defvar *all-ingredients-fu* nil) 50 | (defvar *all-dones-fu* nil) 51 | 52 | 53 | (declaim (sb-ext:muffle-conditions style-warning)) 54 | (declaim (sb-ext:muffle-conditions sb-kernel:redefinition-with-defmethod)) 55 | 56 | 57 | 58 | ;; The model defines nodes and how edges connect them to build up a computation graph. 59 | ;; Incidentally the model derives from the Common Lisp Object System (CLOS) 60 | ;; Hence Common Lisp object oriented semntics and syntax hold. 61 | 62 | (defmodel cake () 63 | ( 64 | 65 | ; Closures 66 | ;--------- 67 | (allingredientsfu :cell nil :accessor allingredientsfu :initform *all-ingredients-fu*) 68 | (alldonesfu :cell nil :accessor alldonesfu :initform *all-dones-fu*) 69 | 70 | ; Constraints 71 | ;------------ 72 | 73 | ; To have batter we need milk, eggs & flour 74 | (batter :reader batter :initform '(:milk :eggs :flour)) 75 | 76 | ; To have an iced cake we must have sugar topping 77 | (icing :reader icing :initform '(:sugar)) 78 | 79 | ; To have a birthday cake we must have candles 80 | (decoration :reader decoration :initform '(:candles)) 81 | 82 | ; Basic actions that need to be performed 83 | (todos :reader todos :initform '(:knead :bake :decorate)) 84 | 85 | ; Events Nodes 86 | ;------------- 87 | 88 | ; A new ingredient is mixed in 89 | (mixin :initform (c-in nil)) 90 | 91 | ; A new action is performed 92 | (action :accessor action :initform (c-in nil)) 93 | 94 | ; Dependent Nodes & inir forms represent Edges 95 | ;--------------------------------------------- 96 | 97 | ; At any time the total set of ingredients 98 | ; is the set union of the last mixin and all previous ingredients 99 | (ingredients 100 | :accessor ingredients 101 | :initform (c? (funcall (allingredientsfu self) (mixin self)))) 102 | 103 | 104 | ; At any time the set of done actions or "dones"" 105 | ; is the set union of the last action and all previus actions 106 | (dones 107 | :accessor dones 108 | :initform (c? (funcall (alldonesfu self) (action self)))) 109 | 110 | ; Batter predicate "batter-p": At any time batterp is satisfied 111 | ; if the batter constraint set is a subset of the ingredients. 112 | ; This model permits adding other ingredients, such as spices 113 | ; so the subset relationship is a good fit here. 114 | (batter-p 115 | :accessor batter-p 116 | :initform (c? (subsetp (batter self) (ingredients self)))) 117 | 118 | ; All done predicate "alldone-p": At any time we are "all done" 119 | ; if the set difference of todos and the set of dones is an emty set 120 | ; This essentially says, follow the recipe. If you perform other tasks 121 | ; we don't warrant the outcome. The cake may be destroyed. 122 | (alldone-p 123 | :accessor alldone-p 124 | :initform (c? (not (set-difference (todos self) (dones self))))) 125 | 126 | ) 127 | ) 128 | 129 | 130 | ;; Of course there is room for things to go wrong here 131 | ;; but this is the realistic model of a cake. It's passive. 132 | ;; Stick on candles before baking, and you get a molten mess of wax. 133 | ;; However tempting it may be to model desired invariants at this 134 | ;; level, we should not. We will, however encode predicates as 135 | ;; dependent nodes. 136 | 137 | 138 | (declaim (sb-ext:unmuffle-conditions style-warning)) 139 | (declaim (sb-ext:unmuffle-conditions sb-kernel:redefinition-with-defmethod)) 140 | 141 | 142 | ;; Observers are triggered when there is a change in an oberved cell 143 | ;; 144 | ;; self has ref to model instance 145 | ;; old value is in old-value 146 | ;; new value is in new-value 147 | ;; 148 | ;; Note in particular that we don't have to track before and after states. 149 | ;; These are provided by the FRP framework each time we are triggered, 150 | ;; and represent the delta of change. This is particularly useful 151 | ;; in modelling rate of change problems. Note also how terse the model is. 152 | ;; If you ever had the displeasure of modelling the observer pattern in 153 | ;; Java or C++, you will appreciate this. 154 | 155 | (defobserver batter-p ((self cake)) 156 | "An observer on cell batter-p on instances of cake models" 157 | (if new-value ; new 158 | (format t "~%CAKE OBSERVER: Batter now complete" ))) 159 | 160 | (defobserver alldone-p ((self cake)) 161 | "An observer on cell alldone-p on instances of cake models" 162 | (if new-value ; new 163 | (format t "~%CAKE OBSERVER: Cake is all done" ))) 164 | 165 | (defobserver ingredients ((self cake)) 166 | "An observer on cell ingredients on instances of cake models" 167 | (format t "~%CAKE OBSERVER: Ingredients now ~A" new-value )) 168 | 169 | (defobserver dones ((self cake)) 170 | "An observer on cell dones on instances of cake models" 171 | (format t "~%CAKE OBSERVER: Completed tasks now ~A" new-value )) 172 | 173 | 174 | 175 | (defvar *auxprint* nil) 176 | 177 | ;(trace "BAKERY") 178 | ;(untrace "BAKERY")) 179 | ;(use-package :bakery) 180 | ;(trace traci:traci-connect :break t) 181 | ; (trace "BAKERY" :break t) 182 | 183 | (defun auxprint-on () 184 | (setf *auxprint* t)) 185 | 186 | (defun auxprint-off () 187 | (setf *auxprint* nil)) 188 | 189 | (defun auxprint (x) 190 | (if *auxprint* 191 | (print x *standard-output*) 192 | (format t "~%"))) 193 | 194 | 195 | ;; An abstraction of RULES/INVARIANTS 196 | ;; Only state is cake itself 197 | 198 | (use-extended-match-syntax) 199 | 200 | (defactor baker 201 | 202 | ; State Form - let bindings for actor local state 203 | ;------------------------------------------------ 204 | ((*all-ingredients-fu* (construct-accumulator)) 205 | (*all-dones-fu* (construct-accumulator)) 206 | (mycake (make-instance 'cake))) 207 | 208 | ; Message Form - We match on a single argument 209 | ;--------------------------------------------- 210 | (message) 211 | 212 | ; Behavior Form 213 | ;------------- 214 | (amatch message 215 | 216 | (it when (algebraic-guard it batter-ingredient) 217 | (algebraic-match-with 218 | ((milk ml) ; constructor pattern 219 | (format t "~%Adding ~a milliliters of milk" ml)) 220 | ((flour gr) ; constructor pattern 221 | (format t "~%Adding ~a grams of flour" gr)) 222 | ((eggs numeggs) ; constructor pattern 223 | (format t "~%Adding ~a egg(s)" numeggs)))) 224 | 225 | [ it when (algebraic-guard it batter-ingredient) => 226 | (algebraic-match-with 227 | [ (milk ml) => 228 | (format t "~%Adding ~a milliliters of milk" ml) ] 229 | [ (flour gr) => 230 | (format t "~%Adding ~a grams of flour" gr) ] 231 | [ (eggs numeggs) => 232 | (format t "~%Adding ~a egg(s)" numeggs) ] ) ] 233 | 234 | ; match adding batter ingredients only 235 | [(list :add ingredient) when 236 | (member ingredient (batter mycake)) => 237 | 238 | (if (batter-p mycake) ; batter already done ? 239 | (format t "~%ERROR: Batter complete. Don't need ~A" ingredient ) 240 | (if (member ingredient (ingredients mycake)) 241 | (format t "~%Error: Already have ~A in batter" ingredient ) 242 | (setf (mixin mycake) ingredient)))] ; update cake here 243 | 244 | ; match adding icing ingredients but only after baking 245 | [(list :add ingredient) when 246 | (and (member ingredient (icing mycake)) 247 | (member :bake (dones mycake))) => 248 | 249 | (if (member ingredient (ingredients mycake)) 250 | (format t "~%ERROR: Already have ~A on cake" ingredient) 251 | (setf (mixin mycake) ingredient))] ; update cake here 252 | 253 | ; match adding decoration ingredients but only after baking 254 | ((list :add ingredient) when 255 | (and (member ingredient (decoration mycake)) 256 | (member :bake (dones mycake))) 257 | 258 | (if (member ingredient (ingredients mycake)) 259 | (format t "~%ERROR: Already have ~A on cake" ingredient ) 260 | (progn 261 | (setf (mixin mycake) ingredient) ; update cake here 262 | (setf (action mycake) :decorate)))) ; update cake here 263 | 264 | ; match actions 265 | ((list :act todo) when 266 | (member todo (todos mycake)) 267 | 268 | (if (alldone-p mycake) ; cake already finished? 269 | (format t "~%ERROR: Cake is finished. Decline to do ~A" todo ) 270 | (if (member todo (dones mycake)) ; todo already done? 271 | (format nil "~%ERROR: Already did ~A" todo ) 272 | 273 | (cond ((equal todo :bake) ; bake only after kneading dough 274 | (if (not (member :knead (dones mycake))) 275 | (format t "~%ERROS: Knead batter first. Can't do ~A" todo ) 276 | (setf (action mycake) todo) ; update cake here 277 | ) 278 | ) 279 | ((equal todo :knead) ; knead dough only after batter complete 280 | (if (not (batter-p mycake)) 281 | (format t "~%ERROR: Batter not ready. Can't knead dough" ) 282 | (setf (action mycake) todo) ; update cake here 283 | ) 284 | ) 285 | (t (format t "~%ERROR: Don't know ~A" todo )))))) 286 | 287 | ; fall-through 288 | (_ 289 | (format t "~%ERROR: recipe error")) 290 | 291 | ) 292 | 293 | ; Match next message 294 | ;------------------- 295 | next) 296 | 297 | 298 | ; Construct like so 299 | ; (defvar mrbean (baker) 300 | ; (send mrbean :connect) 301 | --------------------------------------------------------------------------------