;; Author: Magnus Persson <mpersson@stkhlm.dec.com>
;;

;; A class definition of a Deterministic Finite State Machine (DFSM)
;;   DFSM = <I, Q, S, N, O>
;;   I (Input alphabet)          Q (set of state)
;;   S (Start state)             N (Next state function) : Q X I -> Q
;;   O (Output function) : Q X I -> A  (A is an arbitrary type)

;; The class object accepts the following parameters:
;;   TRANSIT-DESCRIPTION - A list with the following structure
;;   (i belongs to I, q to Q; next-q (belongs to Q) is the next
;;   state and output-thunk is the optional output behaviour):
;;   ( ...
;;    ((i . q) next-q output-thunk)
;;    ... ) 
;;   This list will automatically define the DFSM (except the start-state).
;;   Every DFSM has a state, Undefined, which is selected if the next state
;;   function N is not defined for the argument (thus, making N total)
;;   S is the start-state.
;;   TO-BE-LOGGED determines if the actual behaviour of the DFSM is logged.
;;
;; The instance object accepts the following messages:
;;   I -- The input alphabet set is returned.
;;   Q -- The set of states is returned.
;;   STATE -- Returns the current state of the DFSM.
;;   RESET reset-thunk . reset-log -- The DFSM is reset. RESET-THUNK defines
;;                                    an initialization thunk. If the optional
;;                                    RESET-LOG is set to #T, the DFSM will
;;                                    be logged in the future. #T is returned.
;;   TRANSIT input -- The DFSM is transited to the next state. If this is not
;;                    possible the DFSM is transited to UNDEFINED and #F is
;;                    returned. Otherwise, if the optional OUTPUT-THUNK is
;;                    present it is executed and its value is returned. If the
;;                    thunk is not present #T is returned.
;;   ADD-TRANSIT-DESCRIPTION! tr-description -- TR-DESCRIPTION is appended to
;;                                              the existing TRANSIT-DESCRIPTION
;;                                              in the DFSM. It is a very
;;                                              convenient operation when the
;;                                              DFSM is inherited. E.g, the
;;                                              class X contains a DFSM to which
;;                                              new functionality will be added:
;;                                              This is accomplished by:
;;                   (define-class (y ...)
;;                     (inherit (x ...))
;;                     (init
;;                       (me 'add-transit-description!
;;                        `( ...
;;                          ((i1 . s1) s2 ...)
;;                          ((i2 . s2) s1 ...)
;;                           ...))))
;;                                             In the example, two states S1, S2
;;                                             and two input symbols I1, I2
;;                                             are introduced. One of the states
;;                                             in the added transit-description
;;                                             must exist in the old TRANSIT-
;;                                             DESCRIPTION to be meaningful.

(module dfsm)

(include "../include/util.sch")
(include "../macros/extend-syntax.sc")
(include "../macros/define-class.sc")

(define-class (dfsm transit-description start-state to-be-logged)
  (locals
   ;; Some set operations
   (set-insert (lambda (element set)             ; Inserts into a set
		 (if (memq element set)
		     set
		     (cons element set))))
   (create-set (lambda (l)                       ; Creates a set of an
		 (letrec ((create-set            ; arbitrary list
			   (lambda (l)
			     (if (null? l)
				 '()
				 (set-insert (car l)
					     (create-set (cdr l)))))))
		   (create-set l))))
   ;; State
   (state 'Undefined)
   (log '()) )

  (methods
   (log (lambda () log))
   (i (lambda () (create-set (map caar transit-description))))
   (q (lambda () (create-set (cons 'Undefined (map cdar transit-description)))))
   (state (lambda () state))
   (reset (lambda (reset-thunk . reset-log)
	    (set! state start-state)
	    (reset-thunk)
	    (if (and (not (null? reset-log)) (eq? #t (car reset-log)))
		(begin
		  (set! log '())
		  (set! to-be-logged #t)))
	    #T))
   (transit (lambda (input)
	      (let* ((input-pair (cons input state))
		     (next (assoc input-pair transit-description)))
		(if to-be-logged (set! log (cons input-pair log)))
		(if (not next)
		    (begin
		      (set! state 'Undefined)
		      #F)
		    (let ((th (cddr next)))
		      (set! state (cadr next))
		      (if (not (null? th))
			  ((car th))
			  #T))))))
   (add-transit-description! (lambda (tr-description)
			       (set! transit-description
				     (append transit-description
					     tr-description))
			       #T))
   )
  (init
   ;; Some consistency checking could be done here like
   (if (not (memq start-state (me 'q)))
       (error 'State "Start state ~a cannot be exited" start-state) )))

;;; Sometimes it is convenient to replay the action of a DFSM -
;;; Of course only the logged actions are replayed.

(define (replay	dfsm)
  (dfsm 'reset (lambda () '()))
  (for-each (lambda (event-name)
	      (dfsm 'transit event-name))
	    (map car (reverse (dfsm 'log)))))