added rudel (obby and other colab framework for emacs)

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