summaryrefslogtreecommitdiffstats
path: root/emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base
diff options
context:
space:
mode:
Diffstat (limited to 'emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base')
-rw-r--r--emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base331
1 files changed, 331 insertions, 0 deletions
diff --git a/emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base b/emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base
new file mode 100644
index 0000000..d96bcc7
--- /dev/null
+++ b/emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base
@@ -0,0 +1,331 @@
+;;; 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