summaryrefslogtreecommitdiffstats
path: root/emacs.d/lisp/rudel/.svn/text-base/rudel-state-machine.el.svn-base
blob: d96bcc7d76b145d83ff234cf49ae84ed32534ae7 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
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