《Common Lisp: An Introduction to Symbolic Computing》第14.11節的Keyboard Exercise。個人答案。

首先，設計好簡單的狀態機，主要有節點（node）和聯繫（arc）。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 簡單有限狀態機（Finite State Machines, FSMs）
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 全局變量

(defvar *nodes*)        ; 儲存節點用
(defvar *arcs*)         ; 儲存關聯用
(defvar *current-node*) ; 當前的節點

;; 初始化函數
(defun initialize ()
  (setf *nodes* nil
        *arcs* nil
        *current-node* nil))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 節點

;; 節點結構
(defstruct (node (:print-function print-node))
  name
  inputs
  outputs)

(defun print-node (node stream depth)
  (format stream "#<Node ~A>" (node-name node)))

;; 節點建立宏
(defmacro defnode (name)
  `(add-node ',name))

(defun add-node (name)
  (let ((new-node (make-node :name name)))
    (setf *nodes* (nconc *nodes* (list new-node)))
    new-node))

;; 節點查找函數
(defun find-node (name)
  (or (find name *nodes* :key #'node-name)
      (error "No node named ~A exists." name)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 聯繫

;; 聯繫結構
(defstruct (arc (:print-function print-arc))
  from
  to
  label
  action)

(defun print-arc (arc stream depth)
  (format stream "#<ARC ~A / ~A / ~A>"
          (node-name (arc-from arc))
          (arc-label arc)
          (node-name (arc-to arc))))

;; 聯繫建立宏
(defmacro defarc (from label to &optional action)
  `(add-arc ',from ',label ',to ',action))

(defun add-arc (from-name label to-name action)
  (let* ((from (find-node from-name))
         (to (find-node to-name))
         (new-arc (make-arc :from from
                            :label label
                            :to to
                            :action action)))
    (setf *arcs* (nconc *arcs* (list new-arc)))
    (setf (node-outputs from)
          (nconc (node-outputs from) (list new-arc)))
    (setf (node-inputs to)
          (nconc (node-inputs to) (list new-arc)))
    new-arc))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 主要函數

;; 狀態機運行函數
(defun fsm (&optional (starting-point 'start))
  (setf *current-node* (find-node starting-point))
  (do nil
      ((null (node-outputs *current-node*)) nil)
      (one-transition)))

(defun one-transition ()
  (format t "~&State ~A.   Input: "
          (node-name *current-node*))
  (let* ((ans (read))
         (arc (find ans (node-outputs *current-node*) :key #'arc-label)))
    (unless arc
      (format t "~&No arc from ~A has label ~A.~%"
              (node-name *current-node*) ans)
      (return-from one-transition nil))
    (let ((new (arc-to arc)))
      (format t "~&~A" (arc-action arc))
      (setf *current-node* new))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; FSMs之——自動售賣機
;; 此機出售15美分的口香糖和20美分的薄荷糖
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 初始化
(initialize)

;; 建立節點
(defnode start)
(defnode have-5)
(defnode have-10)
(defnode have-15)
(defnode have-20)
(defnode end)

;; 建立聯繫
(defarc start nickel have-5 "Clunk!")
(defarc start dime have-10 "Clink!")
(defarc start coin-return start "Nothing to return.")
(defarc have-5 nickel have-10 "Clunk!")
(defarc have-5 dime have-15 "Clink!")
(defarc have-5 coin-return start "Returned five cents.")
(defarc have-10 nickel have-15 "Clunk!")
(defarc have-10 dime have-20 "Clink!")
(defarc have-10 coin-return start "Returned ten cents.")
(defarc have-15 nickel have-20 "Clunk!")
(defarc have-15 dime have-20 "Nickel change.")
(defarc have-15 gum-button end "Deliver gum.")
(defarc have-15 coin-return start "Returned fifteen cents.")
(defarc have-20 nickel have-20 "Nickel returned.")
(defarc have-20 dime have-20 "Dime returned.")
(defarc have-20 gum-button end "Deliver gum, nickel change.")
(defarc have-20 mint-button end "Deliver mints.")
(defarc have-20 coin-return start "Returned twenty cents.")

;; 然後開始測試吧！
(fsm) ; 接著可輸入nickel、dime、coin-return、gum-button、mint-button

節點函數化

現在，為了提升狀態機的速度（若狀態機複雜化），要避免用find-node搜索所有節點。直接將節點變為函數，利用cond直接跳轉到對應節點函數。

例如，將start節點變成：

(defun start (input-syms &aux (this-input (first input-syms)))

  (cond ((null input-syms) 'start)

        ((equal this-input 'nickel)

         (format t "~&~A" "Clunk!")

         (have-5 (rest input-syms)))

        ((equal this-input 'dime)

         (format t "~&~A" "Clink!")

         (have-10 (rest input-syms)))

        ((equal this-input 'coin-return)

         (format t "~&~A" "Nothing to return.")

         (start (rest input-syms)))

        (t (error "No arc from ~A with label ~A." 'start this-input))))

;; 聯繫->函數
(defun compile-arc (arc)
  `((equal this-input ',(arc-label arc))
    (format t "~&~A" ,(arc-action arc))
    (,(node-name (arc-to arc)) (rest input-syms))))

;; 節點->函數
(defun compile-node (node)
  `(cond ((null input-syms) ',(node-name node))
         ,@(mapcar #'compile-arc
                   (node-outputs node))
         (t (error "No arc from ~A with label ~A."
                   ',(node-name node) this-input))))

;; 所有節點->函數
(defmacro compile-machine ()
  `(progn
     ,@(mapcar #'(lambda (node)
                   `(defun ,(node-name node) (input-syms &aux
                                                          (this-input
                                                          (first input-syms))) 
                      ,(compile-node node)))
               *nodes*)
     'done))

;; 對比了一下書中的答案，發現自己真的嫩得可以啊 @_@

;; OK，現在試試以下面的表達式開始測試
(compile-machine)
(start '(nickel nickel dime dime gum-button))

太神奇了……執行完(Compile-Machine)的那一刻，很興奮>_<

假如再這樣有限狀態機就更快了：

;; 真正的Compilation
(mapcar #'(lambda (node)
            (compile (node-name node)))
        *nodes*)

• 本博相關文章
• 在其它博客的相關文章