diff options
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-base | 331 |
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 |