gamao-obsoleto/fsm.lisp

;;;; fsm.lisp

#|

An FSM can be conveniently represented by means of a diagram.  Until such a
diagram is included as documentation, we'll have to content ourselves by its
faithful representation by S-expressions, see e. g. the backgammon-machine
definition in event.lisp

We use a fairly straightforward implementation of an FSM as a CASE over the
states, and a COND for each state choosing the arc.  By default the event is
ignored, i. e. we remain in the same state and do nothing.

The choice of an arc is determined by the control state, the event, and the
game state.  However, the machine only needs the value of a few boolean
variables to make the choice.  Every COND-form choosing an arc is evaluated in
a lexical scope where the variables are defined.  This scope is introduced by
the state-bindings function.  As the set of variables and the rules for their
computation varies from state to state (and from machine to machine, of
course), state-bindings is a generic function dispatching on the names of the
machine and the state.  Perhaps a better dispatch can be thought of (when I
used to have two machines, some code was duplicated), but anyway, it's a cool
opportunity to use generic functions for code generation.

The defmachine macro transform the description of a state machine into an event
handler, whose arguments are the event and the controlled objects.  Instead of
inlining the actions into the handler, we look them up at run time in the table
*machines*.  This table assigns to each machine an alist of arcs.  The keys of
the alist are S-expressions representing the start state of the arc and its
condition, the values are correspondent actions.  Actually, this is a bit more
cumbersome to implement than inlining and in theory, the runtime lookup is less
efficient.  However, the lookup is hardly the bottleneck.  On the other hand,
`interpreting' the machine allows to modify rules on the fly, which is
convenient for small fixes, and we may be saving memory by not inlining the
actions.

Perhaps STATE-BINDINGS should be moved to run time as well?

|#

(in-package #:fsm)

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defgeneric state-bindings (machine state machine-arguments))

  ;; machine, state: symbols
  ;; condition: S-expression
  ;; args: the argumenst of the machine
  ;; A part of a COND form is generated: if condition holds, look up the action
  ;; associated with the symbolic form of the condition and apply it to args.
  (defun cond-clause (machine state condition args)
    `(,condition (funcall (second (assoc '(,state ,condition) (gethash ',machine *machines*) :test #'equal))
                          ,@args)))

  ;; Collect the COND clauses into a COND form.  In each branch, setf the
  ;; state-v variable to the value of the next state.
  ;; arcs: list of plists
  (defun state-cond (state-v machine state arcs args)
    `(cond ,@(let ((clauses (list `(t ,state-v))))
               (dolist (arc (reverse arcs) clauses)
                 (push (append (cond-clause machine state (getf arc :when) args)
                               (list `(setf ,state-v ',(getf arc :to))))
                       clauses)))))

  ;; The CASE form over the states.  The car of each rule is its type.  We are
  ;; only interested in :state rules.  For any such rule, (second rule) is its
  ;; name, and (cddr rule) is the list of arcs, each arc being represented by :arc
  ;; consed onto a plist.
  (defun states-case (state-v machine rules args)
    `(case ,state-v ,@(loop for rule in rules
                            when (eql (first rule) :state)
                            collect `(,(second rule) ,(funcall (state-bindings machine (second rule) args)
                                                               (state-cond state-v
                                                                           machine
                                                                           (second rule)
                                                                           (loop for (head . tail) in (cddr rule)
                                                                                 when (eql head :arc)
                                                                                 collect tail)
                                                                           args))))))

  ;; When defining the handler, first register all the arcs.
  (defun arc-register-form (name arguments rules)
    `(progn
       ,@(loop for rule in rules
               when (eql (first rule) :state)
               append (loop for (head . tail) in (cddr rule)
                            when (eql head :arc)
                            collect `(register-arc ',name
                                                   ',(second rule)
                                                   ',(getf tail :when)
                                                   (lambda (,@arguments)
                                                     (declare (ignorable ,@arguments))
                                                     ,(getf tail :action)))))))


  (defun handler-definition-form (name arguments rules state-v)
    `(defun ,name ()
       (let ((,state-v ',(second (assoc :initial-state rules))))
         (lambda (,@arguments)
           ,(states-case state-v name rules arguments)))))

  )

(defvar *machines* (make-hash-table :test 'eq))

(defun undefine-machine (machine)
  (remhash machine *machines*))

(defun register-arc (machine state condition action)
  (push (list (list state condition)
              action)
        (gethash machine *machines*)))

(defun call-arc (machine state condition &rest args)
  (let ((action (second (assoc (list state condition)
                               (gethash machine *machines*)
                               :test #'equal))))
    (when action
      (apply action args))))

(defmacro defmachine (name (&rest arguments) &body rules)
  (let ((state-v (gensym "STATE-")))
    `(progn
       (undefine-machine ',name)
       ,(arc-register-form name arguments rules)
       ,(handler-definition-form name arguments rules state-v))))