;;; rudel-state-machine.el --- A simple state machine for Rudel
;;
;; Copyright (C) 2009 Jan Moringen
;;
;; Author: Jan Moringen <scymtym@users.sourceforge.net>
;; Keywords: Rudel, FSM
;; X-RCS: $Id:$
;;
;; This file is part of Rudel.
;;
;; Rudel is free software: you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Rudel is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Rudel. If not, see <http://www.gnu.org/licenses>.
;;; Commentary:
;;
;; This is a simple implementation of a finite state machine
;; (FSM). The is modeled by rudel-state-machine class, objects of
;; which contain state objects of classes derived from
;; rudel-state. There are no explicit transition rules, since states
;; specify their successors.
;;; History:
;;
;; 0.1 - Initial revision
;;; Code:
;;
(eval-when-compile
(require 'cl))
(require 'eieio)
(require 'rudel-errors)
(require 'rudel-compat) ;; for pulsing progress reporter
;;; Errors related to the state machine
;;
;; rudel-state-error
(intern "rudel-state-error")
(put 'rudel-state-error 'error-conditions
'(error
rudel-error rudel-state-error))
(put 'rudel-state-error 'error-message
"Invalid state or state transition")
;; rudel-invalid-successor-state
(intern "rudel-invalid-successor-state")
(put 'rudel-invalid-successor-state 'error-conditions
'(error
rudel-error rudel-state-error rudel-invalid-successor-state))
(put 'rudel-invalid-successor-state 'error-message
"Invalid successor state in state transition")
;; rudel-entered-error-state
(intern "rudel-entered-error-state")
(put 'rudel-entered-error-state 'error-conditions
'(error
rudel-error rudel-state-error rudel-entered-error-state))
(put 'rudel-entered-error-state 'error-message
"Transition to error state")
;; rudel-no-start-state
(intern "rudel-no-start-state")
(put 'rudel-no-start-state 'error-conditions
'(error
rudel-error rudel-state-error rudel-no-start-state))
(put 'rudel-no-start-state 'error-message
"No start state specified for state machine")
;;; Class rudel-state
;;
(defclass rudel-state ()
()
"A state that can be used in state machines."
:abstract t)
(defgeneric rudel-accept ((this rudel-state) &rest arguments)
"Executed when the machine receives an event while in state THIS.")
(defgeneric rudel-enter ((this rudel-state) &rest arguments)
"Executed when the machine switches to state THIS.")
(defgeneric rudel-leave ((this rudel-state))
"Executed when the machine leaves state THIS.")
;;; Class rudel-state-machine
;;
(defclass rudel-state-machine ()
((states :initarg :states
:type list ;; alist
:initform nil
:documentation
"A list (NAME . STATE) conses where NAME is a symbol
and STATE is an object of a class derived from rudel-state.")
(state :initarg :state
:type rudel-state-child
:documentation
"The current state of the machine."))
"A finite state machine.")
(defmethod initialize-instance :after ((this rudel-state-machine)
&rest slots)
"Set current state of THIS to a proper initial value.
If a start state is specified in the arguments to the
constructor, that state is used. If there is no such state, the
list of states is search for a state named start. If that fails
as well, the first state in the state list is used."
(with-slots (states) this
;; Find a suitable start state and switch to it.
(let ((start (or (plist-get slots :start)
(car (assoc 'start states))
(when (length states)
(car (nth 0 states))))))
(unless start
(signal 'rudel-no-start-state nil))
;; Make start state the current state and call send an enter
;; message.
(let ((start (cdr (assoc start states))))
(oset this :state start)
(rudel--switch-to-return-value
this start (rudel-enter start)))))
)
(defmethod rudel-find-state ((this rudel-state-machine) name)
"Return state object for symbol NAME."
(with-slots (states) this
(cdr (assoc name states))))
(defmethod rudel-register-state ((this rudel-state-machine) name state)
"Register STATE and its NAME with THIS state machine."
(object-add-to-list this :states (cons name state) t))
(defmethod rudel-register-states ((this rudel-state-machine) states)
"Register STATES with THIS state machine.
STATES is a list of cons cells whose car is a symbol - the name
of the state - and whose cdr is a class."
(dolist (symbol-and-state states)
(destructuring-bind (name . class) symbol-and-state
(rudel-register-state
this name (make-instance class (symbol-name name)))))
)
(defmethod rudel-current-state ((this rudel-state-machine) &optional object)
"Return name and, optionally, state object of the current state of THIS.
If OBJECT is non-nil, (NAME . OBJECT) is returned. Otherwise,
just NAME."
(with-slots (states state) this
(let ((state-symbol (car (find state states :key #'cdr :test #'eq))))
(if object
(cons state-symbol state)
state-symbol)))
)
(defmethod rudel-accept ((this rudel-state-machine) &rest arguments)
"Process an event described by ARGUMENTS."
(with-slots (state) this
;; Let the current state decide which state is next.
(let ((next (apply #'rudel-accept state arguments)))
(cond
;; If NEXT is nil, a symbol or a state object, we switch states
;; without passing any data.
((or (null next) (symbolp next) (rudel-state-child-p next))
(rudel-switch this next))
;; If NEXT is a list, it contains the symbol of the successor
;; state and additional data.
((listp next)
(apply #'rudel-switch this next))
;; Other types cannot be processed.
(t
(signal 'wrong-type-argument (list (type-of next)))))))
)
(defmethod rudel-switch ((this rudel-state-machine) next
&rest arguments)
"Leave current state and switch to state NEXT.
ARGUMENTS are passed to the `rudel-enter' method of the successor
state."
(with-slots (states state) this
(cond
;; When NEXT is a state object, use it.
((rudel-state-child-p next))
;; When NEXT is nil, stay in the current state.
((null next)
(setq next state))
;; When NEXT is a symbol (but not nil), look up the corresponding
;; state. Signal an error, if there is none.
((symbolp next)
(let ((next-state (assoc next states)))
(unless next-state
(signal 'rudel-invalid-successor-state
(list next '<- state)))
(setq next (cdr next-state))))
;; Other types cannot be processed.
(t
(signal 'wrong-type-argument (list (type-of next)))))
;; Unless the successor state is equal to the current state, leave
;; the current state and switch to the successor.
(if (and (eq state next)
(null arguments))
;; Return state
state
;; Notify (old) current state.
(rudel-leave state)
;; Update current state.
(setq state next)
;; Notify (new) current state. Using the call's value as next
;; state is a bit dangerous since a long sequence of immediate
;; state switches could exhaust the stack.
(rudel--switch-to-return-value
this state (apply #'rudel-enter state arguments))))
)
(defmethod rudel--switch-to-return-value ((this rudel-state-machine)
state next)
"Switch from STATE to the next state indicated by NEXT.
STATE is the current state.
NEXT can nil, a list or a `rudel-state' object."
(cond
;; Remain in current state.
((null next)
state)
;; NEXT contains next state and arguments to pass to it when
;; switching.
((listp next)
(apply #'rudel-switch this next))
;; Otherwise NEXT is a `rudel-state' object.
(t
(rudel-switch this next)))
)
(defmethod object-print ((this rudel-state-machine) &rest strings)
"Add current state to the string representation of THIS."
(if (slot-boundp this 'state)
(with-slots (state) this
(apply #'call-next-method
this
(format " state: %s"
(object-name-string state))
strings))
(call-next-method this " state: #start"))
)
;;; Miscellaneous functions
;;
(defun rudel-state-wait (machine success-states
&optional error-states callback)
"Repeatedly call CALLBACK until MACHINE is in a state in SUCCESS-STATES or ERROR-STATES.
MACHINE should be of type rudel-state-machine-child or at least
have a method `rudel-get-state'.
SUCCESS-STATES and ERROR-STATES are lists which contain the
names (as symbols) of success and error states respectively.
This function does not return when MACHINE enters states not in
SUCCESS-STATES or ERROR-STATES. As a result, a deadlock can occur
when MACHINE deadlocks or cycles through states not in either
list infinitely.
When non-nil, CALLBACK has to be a function that accepts one
argument of the form (SYMBOL . STATE) where SYMBOL is the name
symbol of the current state and STATE is the state object."
;; Wait until MACHINE enter a state in SUCCESS-STATES or
;; ERROR-STATES.
(let ((result
(catch 'state-wait
(while t
;; Retrieve current state.
(destructuring-bind (symbol . state)
(rudel-current-state machine t)
;; Check against success and error states.
(when (memq symbol success-states)
(throw 'state-wait (cons 'success (cons symbol state))))
(when (memq symbol error-states)
(throw 'state-wait (cons 'error (cons symbol state))))
;; Update progress indicator and sleep.
(when callback
(funcall callback (cons symbol state)))
(sleep-for 0.05))))))
(when callback
(funcall callback t))
;; If MACHINE ended up in an error state, signal
(unless (eq (car result) 'success)
(signal 'rudel-entered-error-state (cdr result)))
;; Return state
(cdr result))
)
(provide 'rudel-state-machine)
;;; rudel-state-machine.el ends here
