;;; simple-state-machines.el --- My simple state machine macro. -*- lexical-binding: t -*-

;; Author: iamtoaster
;; Version: 0.1
;; Package-Requires: (cl-lib)
;; Homepage:
;; Keywords: FSM, Macro

;; This file is not part of GNU Emacs

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This is my implementation of simple finite state machines. This package
;; provides a defstate-machine macro and an update-state function. They can be
;; combined to create a simple FSM with three states like so:
;; 
;; (ssm-defstate-machine test
;;   :states (one two three)
;;   :initial-state three
;;   :transitions ((one . two)
;;                 (two . three)
;;                 (three . one))
;;   :handlers ((two . (lambda (name) (ssm-update-state name 'three)))
;;              (three . (lambda (name) (ssm-update-state name 'one)))
;;              (one . (lambda (name) (ssm-update-state name 'two)))))
;; 
;; The code above will create a state machine with three states, appropriately
;; named 'one', 'two' and 'three', by specifying them after the :states key. The
;; initial state will be set to state 'three'. If no initial state is provided,
;; the first state in the list will be used automatically.
;; 
;; Then, we define valid transitions between states using the :transitions key.
;; If we try to change the state in a way that is not defined in this alist,
;; `update-state' will signal an error.
;;
;; Finally, we specify handlers for states using the :handlers key. See
;; `defstate-machine' for information.
;;
;; This macro call will provide us with the following variables:
;; 'test-state-table' -- Stores the state list, verbatim.
;; 'test-transition-table' -- Stores the valid transitions, verbatim.
;; 'test-current-state' -- Stores the current state.
;; 'test-state-data' -- Optional data for the current state, initialized to nil.
;; 'test-state-handlers' -- Stores the mapping from the states to their handlers,
;; verbatim.
;;
;; As well as the following functions:
;; 'test-step' -- Calls the handler for the current state.
;; 'test-set-state' -- Tries to set the current state to the provided one, and
;; signals an error if the transition is invalid.
;;
;; Here is the recreation of the counter example from
;; https://www.emacswiki.org/emacs/StateMachine
;; 
;; (ssm-defstate-machine counter
;;   :states (start count end)
;;   :transitions ((start . count)
;;                 (count . end)
;;                 (count . count))
;;   :handlers ((start . (lambda (name)
;;                         (princ "Starting...")
;;                         (terpri)
;;                         (ssm-update-state name 'count 0)))
;;              (count . (lambda (name)
;;                         (cond ((<= (ssm-get-state-data name) 10)
;;                                (princ (ssm-get-state-data name))
;;                                (ssm-update-state
;;                                 name
;;                                 'count
;;                                 (1+ (ssm-get-state-data name))))
;;                               (t (terpri) (ssm-update-state name 'end nil)))))))
;; 
;; (ssm-run-until-state 'counter 'end)
;;
;; As you can see, ssm-update-state definitely needs some love. It is unwieldy.
;;; Code:

(require 'cl-lib)

(defmacro ssm-defstate-machine (name &rest args)
  "Defines a state machine with name NAME, STATES and TRANSITIONS between
them. If INITIAL-STATE is nil, the first state will be used.

Arguments are specified as keyword/argument pairs. The following
arguments are defined:

:states LIST -- LIST should be a list of symbols each representing a
state. LIST will not be evaluated.

:transitions ALIST -- ALIST should be an alist of the form (FROM . TO)
where both FROM and TO are names of states available in the :states LIST.

:handlers ALIST -- ALIST should be an alist of the form (STATE .
HANDLER) where STATE is one of the states in the :states LIST and
HANDLER is a function that can be called by funcall. It is advised to
provide a handler for all of the state, because an error will be
signalled if you try to step on a state with no handler.

The following optional arguments are defined:

:initial-state SYMBOL -- If SYMBOL is non-nil and present in the :states
LIST, it will be set as the initial state of this state machine.
Otherwise, the first state in the :states LIST will be used.

(fn NAME &key INITIAL-STATE STATES TRANSITIONS HANDLERS)"
  (declare (indent defun))
  (let ((machine-name (symbol-name name))
        (states (plist-get args :states))
        (transitions (plist-get args :transitions))
        (handlers (plist-get args :handlers))
        (initial-state (plist-get args :initial-state)))
    (if (not initial-state)
        (setq initial-state (car states)))
    (cl-assert (cl-find initial-state states) t
               "Cannot find the initial state in the state list.")
    (dolist (entry handlers)
      (cl-assert (cl-find (car entry) states)) t)
    (dolist (entry transitions)
      (cl-assert (and (cl-find (car entry) states)
                      (cl-find (cdr entry) states))
                 nil "Invalid transition: Either the source or the target state does not exist."))
    (let ((state-table (intern (concat machine-name "-state-table")))
          (transition-table (intern (concat machine-name "-transition-table")))
          (current-state (intern (concat machine-name "-current-state")))
          (state-data (intern (concat machine-name "-state-data")))
          (step-fn (intern (concat machine-name "-step")))
          (state-set-fn (intern (concat machine-name "-set-state")))
          (handlers-table (intern (concat machine-name "-state-handlers"))))
      `(progn
         (defvar ,state-table ',states
           ,(concat "The state table of the " machine-name " state machine."))
         (defvar ,transition-table ',transitions
           ,(concat "The transitions table of the " machine-name " state machine.\n
Each entry of this alist has the form (FROM . TO)."))
         (defvar ,current-state ',initial-state
           ,(concat "The current state of the " machine-name " state machine."))
         (defvar ,state-data nil
           ,(concat "The data of the current state of the " machine-name " state machine."))
         (defvar ,handlers-table ',handlers
           ,(concat "An alist mapping states of the "
                    machine-name
                    " state machine to their respective handlers."))
         ,@(let ((handler (make-symbol "handler"))
                 (prev-state (make-symbol "prev-state")))
             `((defun ,step-fn ()
                 ,(concat "The stepping function of the "
                          machine-name
                          " state machine.\n\nIt tries to find a handler for the current state (see `"
                          (symbol-name current-state)
                          "' and\n`"
                          (symbol-name handlers-table)
                          "'),and then call it with the name of this state machine\nas its only argument.")
                 (let ((,handler (alist-get ,current-state ,handlers-table))
                       (,prev-state ,current-state))
                   (cl-assert ,handler nil "There is no handler for the current state")
                   (funcall ,handler ',name)
                   (cl-assert
                    (cl-find
                     (cons ,prev-state ,current-state)
                     ,transition-table
                     :test 'equal)
                    "Invalid state transition. State machine is now in inconsistent state.")))
               (defun ,state-set-fn (state &optional new-data)
                 ,(concat
                   "Sets the state of "
                   machine-name
                   " state machine. Signals an error if the state transition\nis invalid, see `"
                   (symbol-name transition-table)
                   "' for a list of valid transitions.")
                 (cl-assert
                  (cl-find
                   (cons ,current-state state)
                   ,transition-table
                   :test 'equal) t
                  "Invalid state transition.")
                 (setq ,current-state state
                       ,state-data new-data))))))))

(defun ssm-update-state (machine new-state new-data)
  "Updates the state of the state machine MACHINE. Signals an error if the
state transition is invalid."
  (let ((state-fn
         (intern-soft (concat (symbol-name machine) "-set-state"))))
    (funcall state-fn new-state new-data)))

(defun ssm-get-state (machine)
  "Returns the state of the specified machine."
  (let ((state
         (intern-soft (concat (symbol-name machine) "-current-state"))))
    (symbol-value state)))

(defun ssm-get-state-data (machine)
  "Returns the state data of the specified machine."
  (let ((state-data
         (intern-soft (concat (symbol-name machine) "-state-data"))))
    (symbol-value state-data)))

(defun ssm-run-until-state (machine state)
  "Steps the specified MACHINE until it enters state STATE."
  (let ((step-fn
         (intern-soft (concat (symbol-name machine) "-step"))))
    (while (not (equal (ssm-get-state machine) state))
      (funcall step-fn))))

(provide 'simple-state-machines)
;;; simple-state-machines.el ends here