;; Copyright Tarvydas-Sanford Controls Inc.
;; License: MIT Open Source.

#|
This macro implements state machines with entry, exit and transition code.

Usage:

(defmethod xyz ((obj object-with-state)) event ...)
  (with-slots (state) obj
    (machine (state)
      (default-state
       ( ... entry-code form ... )
       ( ... action form ... )
       ( ... exit-code form ... ))
      (state-2
       ( ... entry-code form ... )
       (case event  ;; example action code
         (:mouse-move ...)
         (:left-pressed (go-state dragging))
         (:left-released ...))
       ( ... exit-code form ... ))
      (dragging
       ( ... entry-code form ... )
       ( ... action form ... )
       ( ... exit-code form ... ))
      ...)))

Changing states is accomplished by the

(go-state state-name)

macro, which can appear anywhere in the above forms.

Explanation:

State names are simple symbols (e.g. "default-state", "state-2", "state-3" above).

The default state is the first state to appear in the machine.

The first time that the machine is executed, it enters the default state.  This
causes the entry-code of the default state to execute, followed by immediate
execution of the action code of the default state.

On all other visits to the machine, the action code of the "current state"
is executed.  The current state is maintained by the macro in the variable 
given in the macro definition.

When a go-state is encountered, the current state is exited and the next state
is entered.  This causes the following sequence of actions:

(a) The exit form for the current state is evaluated.
(b) The state variable is changed to the new state.
(c) The entry form for the new state is evaluated.
(d) The machine gives up control flow (i.e. to the forms following
    the machine).  The machine remains armed for execution the
    next time control flow passes through it.

Note that go-state calls should not appear in exit code (since the exit code
will be re-evaluated).

Go-state calls can appear in entry code and action code.  Control flow jumps
immediately to the exit code of the current state when a go-state is encountered
(N.B. this means that a go-state in entry code will cause the action code of
that state to skipped).

Typical usage is to place a "case" form in the action code.  The case form typically
evaluates the incoming event and executes appropriate code.  If the action code
does not call go-state, the state remains unchanged and the same action will be
visited on the next step of the machine.  "Transition" code is code that appears
on a transition arc in a state diagram.  In using this macro, transition code is
manually implemented as code executed immediately prior to a go-state call (obviously,
shared transition code can be wrapped in a shared function).

Nested / hierarchical state machines can be implemented manually.  For example,
a function containing another state machine can be called as part of the action
code for a hierarchical state.  Upon return, the action code examines the return
value and chooses appropriate state-changing actions.  For example:

action code: (if (eq :quit (inner-machine self event))
                 (go-state idle)
               ; else don't change state
               )


Implementation note: this macro uses Lisp GO's wherever it can.  Common Lisp does
not have a computed goto - a "case" is used instead.

|#


(defmacro machine (state-var-list default-state &rest state-list)
  (unless (and (listp state-var-list)
               (listp default-state)
               (symbolp (car state-var-list))
               (= 4 (length default-state))
               (symbolp (car default-state))
               (every #'(lambda (x) (listp x)) (cdr default-state))
               (every #'(lambda (x) (and (= 4 (length x))
                                         (symbolp (car x))
                                         (every #'(lambda (y) (listp y)) (cdr x))))
                      state-list))
    (error "badly formed machine"))
  (let ((first-time (gensym "first-time-"))
        (next (gensym "next-"))
        (state-var (car state-var-list))
        (default-state-id (first default-state))
        (state-ids (mapcar #'car state-list)))
    (flet ((gen-name (sym str)
             (intern (concatenate 'string (symbol-name sym) (string-upcase str)))))
      `(macrolet ((go-state (where)
                    `(progn
                       (setq ,',next ',,'where)
                       (go exits))))
         (prog ((,first-time (null ,state-var))
                ,next)
           (when ,first-time
             (go ,(gen-name default-state-id "-entry")))
           actions
           (case ,state-var
             (,default-state-id (go ,(gen-name default-state-id "-action")))
             ,@(mapcar
                #'(lambda (s)
                    `(,s (go ,(gen-name s "-action"))))
                state-ids)
             (otherwise (return ,state-var)))
           entries
           (case ,state-var
             (,default-state-id (go ,(gen-name default-state-id "-entry")))
             ,@(mapcar
                #'(lambda (s)
                    `(,s (go ,(gen-name s "-entry"))))
                state-ids)
             (otherwise (return ,state-var)))
           exits
           (case ,state-var
             (,default-state-id (go ,(gen-name default-state-id "-exit")))
             ,@(mapcar
                #'(lambda (s)
                    `(,s (go ,(gen-name s "-exit"))))
                state-ids)
             (otherwise (return ,state-var)))
           ,(gen-name default-state-id "-entry")
           (setq ,state-var ',default-state-id)
           ,(second default-state)
           (unless ,first-time
             (return ',state-var))
           ,(gen-name default-state-id "-action")
           ,(third default-state)
           (return ',state-var)
           ,(gen-name default-state-id "-exit")
           ,(fourth default-state)
           (setq ,state-var ,next)
           (go entries)
           ,@(apply 'append
                    (mapcar
                     #'(lambda (s)
                         (let ((name (first s))
                               (entry (second s))
                               (action (third s))
                               (exit (fourth s)))
                           `(,(gen-name name "-entry")
                             (setq ,state-var ',name)
                             ,entry
                             (return ',name)
                             ,(gen-name name "-action")
                             ,action
                             (return ',name)
                             ,(gen-name name "-exit")
                             ,exit
                             (setq ,state-var ,next)
                             (go entries))))
                     state-list)))))))