Naive-FSM

fsm.lisp

(in-package :cl-user)

(defpackage :naive-fsm
  (:use :cl)
  (:export
   #:new-mm
   #:state
   #:on
   #:mwhen
   #:trigger
   #:states))

(in-package :naive-fsm)

(defclass micro-machine ()
  ((state :reader state
          :initarg :state
          :initform nil
          :type symbol)
   (transitions :reader transitions
                :initarg :transitions
                :initform (make-hash-table :test #'equalp)
                :type hash-table)
   (callbacks :reader callbacks
              :initarg :callbacks
              :initform (make-hash-table :test #'equalp)
              :type hash-table)))

(defun new-mm (state)
  (make-instance 'micro-machine :state state))

(define-condition invalid-event (error)
  ((msg :initarg :msg :reader msg)))

(define-condition invalid-state (error)
  ((msg :initarg :msg :reader msg)))

(defmethod on ((mm micro-machine) key cb)
  (push cb (gethash key (callbacks mm))))

(defmethod mwhen ((mm micro-machine) event transition)
  (setf (gethash event (transitions mm)) transition))

(defmethod trigger? ((mm micro-machine) event)
  (with-slots (transitions state) mm
    (if (gethash event transitions)
        (cdr (assoc state (gethash event transitions)))
        (error 'invalid-event :msg (format nil "Event: ~A is invalid" event)))))

(defmethod change ((mm micro-machine) new-state event payload)
  (with-slots (transitions state callbacks) mm
    (setf state new-state)
    (let ((cbs (remove-if #'null (cons (gethash event callbacks) (gethash '_all callbacks)))))
      (mapcar #'(lambda (f) (funcall f mm event payload)) cbs)
      t)))

(defmethod trigger ((mm micro-machine) event &optional (payload nil))
  (let ((s (trigger? mm event)))
    (if s
        (change mm s event payload)
        nil)))

(defmethod states ((mm micro-machine))
  (remove-duplicates (mapcar #'car (transitions mm))))