;; -*- gauche -*-
;; Finite State Machines and the GoF State pattern

(define-class <FSM> ()
  ((states :accessor states)
   (current :accessor current)
   (transition :accessor transition)))

(define-method initialize ((self <FSM>) initargs)
  (set! (states self)
        `((A . ,(make <State-A>))
          (B . ,(make <State-B>))
          (C . ,(make <State-C>))))
  (set! (current self) 'A)
  (set! (transition self)
        '((A . (C B A))
          (B . (A C B))
          (C . (B C C)))))

(define-method next-state ((self <FSM>) msg)
  (let ((transitions (assoc (current self) (transition self))))
    (set! (current self)
          (case msg
            ((on) (car transitions))
            ((off) (cadr transitions))
            ((ack) (caddr transitions))))))

(define-method on ((self <FSM>))
  (on (cdr (assoc (current self) (states self))))
  (next-state self 'on))

(define-method off ((self <FSM>))
  (off (cdr (assoc (current self) (states self))))
  (next-state self 'off))

(define-method ack ((self <FSM>))
  (ack (cdr (assoc (current self) (states self))))
  (next-state self 'ack))

(define-class <State> () ())
(define-method on ((self <State>)) (print "error"))
(define-method off ((self <State>)) (print "error"))
(define-method ack ((self <State>)) (print "error"))

(define-class <State-A> (<State>) ())
(define-method on ((self <State-A>)) (print "A + on = C"))
(define-method off ((self <State-A>)) (print "A + off = B"))
(define-method ack ((self <State-A>)) (print "A + ack = A"))

(define-class <State-B> (<State>) ())
(define-method on ((self <State-B>)) (print "B + on = A"))
(define-method off ((self <State-B>)) (print "B + off = C"))

(define-class <State-C> (<State>) ())
(define-method on ((self <State-C>)) (print "C + on = B"))

(define fsm (make <FSM>))
(ack fsm)
(off fsm)
(ack fsm)
(on fsm)

;; same as above, but simplified
(define (make-fsm)
  (let ((states '(A B C))
        (messages '(on off ack))
        (current 'A)
        (transitions
         '((A . (C B A))                ; on off ack
           (B . (A C B))
           (C . (B C C))))
        (transitions-with-actions
         '((A (on C (print "A + on = C"))
              (off B (print "A + off = B"))
              (ack A (print "A + ack = A")))
           (B (on A (print "B + on = A"))
              (off C (print "B + off = C"))
              (ack B (print "error")))
           (C (on B (print "C + on = B"))
              (off C (print "error"))
              (ack C (print "error"))))))
    ;; old ------------------------------
    (define (next-state-for-message msg)
      (let1 tr (cdr (assoc current transitions))
        (case msg
          ((on) (car tr))
          ((off) (cadr tr))
          ((ack) (caddr tr)))))

    (define (next-state-for-message+actions msg)
      (let* ((rules (cdr (assoc current transitions-with-actions)))
             (next (assoc msg rules)))
        (unless (null? (cddr next))
          ;(print "action: " (caddr next))
          (eval (caddr next) (current-module)))
        (cadr next)))

    (define (set-next-state msg)
      (set! current (next-state-for-message+actions msg)))
    ;; end old ------------------------------

    (define (next-state-and-action-for msg)
      (let1 tuple (assoc msg (cdr (assoc current transitions-with-actions)))
        (values (cadr tuple) (if (null? (cddr tuple))
                                 #f
                                 (caddr tuple)))))

    (lambda args
      (let1 msg (car args)
        (cond ((member msg messages)
               (receive (next-state action) (next-state-and-action-for msg)
                 (eval action (current-module))
                 (set! current next-state)))
              (else (print "unknown message " msg)))))))

(let1 fsm (make-fsm)
  (map (cut fsm <>) '(ack off ack off on ack on on)))

;; TODO translate a FSM definition (below) into a real FSM (above)
(define-macro (define-state-machine name . definition)
  (print "defining " name)
  (print "defs: " definition)
  `(define (,(string->symbol #`"make-fsm-,name"))
     (lambda args
       (print "fsm: " args))))

;; state machine definition
(define-state-machine "button"
  (states '(on off))
  (initial-state off)
  (messages '(push))
  ;; message <name> <current-state>
  (transitions
   (on + push = off)
   (off + push = on)))

(define-state-machine "huston/dp"
  (states '(A B C))
  (initial-state A)
  (messages '(on off ack))
  (transitions
   (default + on = error)
   (default + off = error)
   (default + ack = error)
   (A + on = C
      (action Product.Validate))
   (A + off = B
      (action (print "new state is B")))
   (A + ack = A)
   (B + on = A)
   (B + off = C)
   (C + on = B)))

(define fsm (make-fsm-huston/dp))
(fsm 'ack)
(fsm 'on)
(fsm 'on)