LISPUSER

古くて新しい状態遷移 に触発されて Lisp でトレイの開閉(:OPEN, :CLOSE) と再生状態 (:STOP, :PLAY) を持つ簡単なステートマシーンを定義し てみます． Lisp 風といってもマルチパラダイムな言語ですから CLOS ？ 再帰？ など Lisper 内でも流派によって千差万別でしょう．今回はステートマシー ンを表現するクロージャを返す関数を作ります．

状態を二つ用意します．それぞれ トレイの開閉を表わす tray, 再生状態を表 す player です．これを make-cd-player の &aux パラメータとして宣言し， 初期状態を設定しておきます．

次に，アクション (:open, :close, :play, :stop) に応じた関数 (%open, %close, %play, %stop) も定義します．それぞれ cond 分で状態をチェックし て動作し，状態を書きかえてゆきます．

(defun make-cd-player (&aux (tray :CLOSE) (player :STOP))
  (labels ((%open ()
             (cond ((and (eq tray :CLOSE) (eq player :PLAY))
                    (funcall (lambda ()
                               (print ">>> STOP")
                               (setf player :STOP)
                               (print ">>> OPEN")
                               (setf tray :OPEN))))
                   ((and (eq tray :CLOSE) (eq player :STOP))
                    (funcall (lambda ()
                               (print ">>> OPEN")
                               (setf tray :OPEN))))
                   ((and t t)
                    :ignore)))
           (%close ()
             (cond ((and (eq tray :OPEN) t)
                    (funcall (lambda ()
                               (print ">>> CLOSE")
                               (setf tray :CLOSE))))
                   ((and t t)
                    :ignore)))
           (%play ()
             (cond ((and (eq tray :CLOSE) (eq player :STOP))
                    (funcall (lambda ()
                               (print ">>> PLAY")
                               (setf player :PLAY))))
                   ((and (eq tray :OPEN) t)
                    (funcall (lambda ()
                               (print ">>> CLOSE")
                               (setf tray :CLOSE)
                               (print ">>> PLAY")
                               (setf player :PLAY))))
                   ((and t t)
                    :ignore)))
           (%stop ()
             (cond ((and t (eq player :PLAY))
                    (funcall (lambda ()
                               (print ">>> STOP")
                               (setf player :STOP))))
                   ((and t t)
                    :ignore))))
    (lambda (input)
      (case input
        (:open  (%open))
        (:close (%close))
        (:play  (%play))
        (:stop  (%stop))))))

(and t t) など t で済むのに何故か非常に冗長に書いてあります．これには意図がありまして， このプログラムを元に，次のようなステートマシーンを定義するマクロを書こうと思ったためです．

(def-state-machine state-machine-cd-player ((tray :CLOSE) (player :STOP))
  (:open 
   (:CLOSE :PLAY)  -> (lambda ()
                        (print ">>> STOP")
                        (setf player :STOP)
                        (print ">>> OPEN")
                        (setf tray :OPEN))
   (:CLOSE :STOP)  -> (lambda ()
                        (print ">>> OPEN")
                        (setf tray :OPEN))
   (:any :any)     -> :ignore)
  (:close
   (:OPEN :any) -> (lambda ()
                       (print ">>> CLOSE")
                       (setf tray :CLOSE))
   (:any :any)  -> :ignore)
  (:play
     (:CLOSE :STOP) -> (lambda ()
                         (print ">>> PLAY")
                         (setf player :PLAY))
     (:OPEN :any) -> (lambda ()
                       (print ">>> CLOSE")
                       (setf tray :CLOSE)
                       (print ">>> PLAY")
                       (setf player :PLAY))
     (:any :any) -> :ignore)
  (:stop
   (:any :PLAY) -> (lambda ()
                      (print ">>> STOP")
                      (setf player :STOP))
   (:any :any)  -> :ignore))

[使用例]
CL-USER> (setf c (cd-player))
#<CLOSURE (LAMBDA (INPUT)) {982D315}>
CL-USER> (funcall c :open)

">>> OPEN" 
:OPEN
CL-USER> (funcall c :close)

">>> CLOSE" 
:CLOSE
CL-USER> (funcall c :play)

">>> PLAY" 
:PLAY
CL-USER> (funcall c :stop)

">>> STOP" 
:STOP
CL-USER> (funcall c :open)

">>> OPEN" 
:OPEN
CL-USER> (funcall c :play)

">>> CLOSE" 
">>> PLAY" 
:PLAY

さて，このマクロを展開した結果が最初に示した関数のようになればいいわけ です．ではさっそく実装してみましょう．

まず，マクロの形をイメージしましょう．関数名 (name) と状態名 (states) を展開します．

(defmacro define-state-machine (name states &body body)
`(defun ,name (&aux ,states)
   ...))

こんな感じで関数定義に展開できますね．さて，ここまでは簡単ですね．次は パラメータ body で渡ってくるフォームの変換を実施します．実は，今回はネ タのためにわざと簡単に解析できるような定義にしてあります．読み易さより もマクロ定義を優先していますので，body フォームは次のようなリストとなっ ています．

  '((:open 
    (:CLOSE :PLAY)  -> (lambda ()
                         (print ">>> STOP")
                         (setf player :STOP)
                         (print ">>> OPEN")
                         (setf tray :OPEN))
    (:CLOSE :STOP)  -> (lambda ()
                         (print ">>> OPEN")
                         (setf tray :OPEN))
    (:any :any)     -> :ignore)
   (:close
    (:OPEN :any) -> (lambda ()
                        (print ">>> CLOSE")
                        (setf tray :CLOSE))
    (:any :any)  -> :ignore)
   (:play
      (:CLOSE :STOP) -> (lambda ()
                          (print ">>> PLAY")
                          (setf player :PLAY))
      (:OPEN :any) -> (lambda ()
                        (print ">>> CLOSE")
                        (setf tray :CLOSE)
                        (print ">>> PLAY")
                        (setf player :PLAY))
      (:any :any) -> :ignore)
   (:stop
    (:any :PLAY) -> (lambda ()
                       (print ">>> STOP")
                       (setf player :STOP))
    (:any :any)  -> :ignore)))

これは

  ;; アクション定義
  (イベント
   (状態1 状態2 ...) -> 実行される処理
   (状態1 状態2 ...) -> 実行される処理)

というアクション定義を単位として，アクション定義のリストになっています． つまり body は

  ;; アクション定義
  (アクション定義1 アクション定義2 ...)

となっているわけです．さっそく，アクション定義を関数に変換する処理を考えてみましょう． 関数名はイベント名に % をつけたもを利用します．

(defun transform (action)
  (let* ((event (first action))
         (name  (intern (concatenate 'string "%" (symbol-name event)))))
    (list event name `(,name () action-body))))

これを REPL 上で試してみましょう．

CL-USER> (transform '(event (s1 s2) -> (lambda () (do-something))))
(EVENT %EVENT (%EVENT NIL ACTION-BODY))

だいぶいいですが，action-body 部の処理がありません．ここで最初の関数定義を 見直してください．cond を使って状態毎に処理を行う形式になっているはずです．

(cond ((and 状態1 状態2 ...) 処理)
      ((and 状態1 状態2 ...) 処理)
      ((and t t)             処理))

このようなフォームを実現するために以下のように action-builder という補 助関数を作ります．

(cond ,@(action-builder '((s1 s2) -> (lambda () (do-something)))))
=> (cond ((and (eq tray s1) (eq player s2))  (funcall (do-something))))

(cond ,@(action-builder '((s1 s2) -> (lambda () (do-something-1))
                          (s3 s4) -> (lambda () (do-something-2)))))
=> (cond ((and (eq tray s1) (eq player s2))  (funcall (do-something-1)))
         ((and (eq tray s3) (eq player s4))  (funcall (do-something-2))))

このように入力されるアクション定義リストによって出力がちがうので action-builder は任意個の長さのリストを処理できるように再帰関数として定 義します（別に loop や mapcar でもいいです） ．

(defun action-builder (lst)
  (if (null lst)
      nil
      (let ((states (first lst))
            (body   (third lst)))
         (cons (cons states body) (action-builder (nthcdr 3 lst))))))

できたらまた REPL で動作検証します．

CL-USER> (action-builder '((s1 s2) -> (lambda () (do-something-1))))
(((S1 S2) LAMBDA NIL (DO-SOMETHING-1)))
CL-USER> (action-builder '((s1 s2) -> (lambda () (do-something-1))
                           (s3 s4) -> (lambda () (do-something-2))))

(((S1 S2) LAMBDA NIL (DO-SOMETHING-1)) ((S3 S4) LAMBDA NIL (DO-SOMETHING-2)))

だいぶ良いかんじです．

[action-builder の出力]
(((S1 S2) . (LAMBDA NIL (DO-SOMETHING-1))
 ((S3 S4) . (LAMBDA NIL (DO-SOMETHING-2)))
[欲しい形式]
'(((and (eq tray s1) (eq player s2))  (funcall (lambda () (do-something-1))))
  ((and (eq tray s3) (eq player s4))  (funcall (lambda () (do-something-2)))))

またここで関数を導入します．必要な関数は

(gen-action '(s1 s2) '(lambda () (do-something-1)))
=> ((and (eq tray s1) (eq player s2))
    (funcall (lambda () (do-something-1))))

です．s1, s2 などと比較するための状態変数は既に用意されていると考えてかまいません． define-state-machine の第二引数 states から簡単に生成できます．例えば，

states => ((tray :CLOSE) (player :PLAY))

だったと考えれば，

(mapcar #'car states)
=> (tray player)

のように状態変数のリストが得られます．が，初期値が nil でいい場合なども 考えると`(mapcar (lambda (e) (if (atom e) e (second e))) states)` のほ うが良いでしょう．

では gen-action を作成してみましょう．

(defun gen-action (states action)
 `((and ,@(mapcar (lambda (s e) `(eq ,s ,e)) '(tray player) states))
   (funcall ,action)))

作ったら即 REPL で試します．

CL-USER> (gen-action '(:OPEN :ACTION) '(lambda () (do-something)))
((AND (EQ TRAY :OPEN) (EQ PLAYER :ACTION)) (FUNCALL (LAMBDA () (DO-SOMETHING))))

フーム．いいかんじです．ではついでに任意の状態にマッチする :any を実装してみます．

(defun gen-action (states action)
 `((and ,@(mapcar (lambda (s e) (if (eq e :any) t `(eq ,s ,e))) '(tray player) states))
   (funcall ,action)))

states の要素が :any だった場合に `(eq )` フォームではなく `t` を返すように変更するだけです． ここまでできたら，本来の目的のデータである

  (:open 
   (:CLOSE :PLAY)  -> (lambda ()
                        (print ">>> STOP")
                        (setf player :STOP)
                        (print ">>> OPEN")
                        (setf tray :OPEN))x
   (:CLOSE :STOP)  -> (lambda ()
                        (print ">>> OPEN")
                        (setf tray :OPEN))
   (:any :any)     -> :ignore)

のようなアクション定義を試してみると良いでしょう．

CL-USER> (gen-action '(:CLOSE :PLAY) '(lambda ()
                            (print ">>> STOP")
                            (setf player :STOP)
                            (print ">>> OPEN")
                            (setf tray :OPEN)))
((AND (EQ TRAY :CLOSE) (EQ PLAYER :PLAY))
 (FUNCALL
  (LAMBDA ()
    (PRINT ">>> STOP")
    (SETF PLAYER :STOP)
    (PRINT ">>> OPEN")
    (SETF TRAY :OPEN))))
CL-USER> (gen-action '(:CLOSE :STOP)  '(lambda ()
                            (print ">>> OPEN")
                            (setf tray :OPEN)))
((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
 (FUNCALL (LAMBDA () (PRINT ">>> OPEN") (SETF TRAY :OPEN))))
CL-USER> (gen-action '(:any :any)  :ignore)

((AND (EQ TRAY :ANY) (EQ PLAYER :ANY)) (FUNCALL :IGNORE))
CL-USER>     

あれあれ，良く見ると `(funcall :ignore)` という残念な分が生成されていま すね．修正しておきましょう．とりあえず，アトムの場合は funcall ではなく アトムそのものを返すようにします．

(defun gen-action (states action)
 `((and ,@(mapcar (lambda (s e) (if (eq e :any) t `(eq ,s ,e))) '(tray player) states))
   ,(if (atom action) action `(funcall ,action))))

CL-USER> (gen-action '(:any :any)  :ignore)
((AND T T) :IGNORE)

はい，これで思い通りです．ではここまでで作った transform, action-builder, gen-action を組み合わせてみましょう．

CL-USER> (defun transform (action)
  (let* ((event (first action))
         (name  (intern (concatenate 'string "%" (symbol-name event)))))
    ;; cond フォームに展開するように修正
    (list event name `(,name () (cond ,@(action-builder (rest action)))))))

(defun action-builder (lst)
  (if (null lst)
      nil
    (let ((states (first lst))
          (body   (third lst)))
      ;; gen-action を使うように修正
      (cons (gen-action states body) (action-builder (nthcdr 3 lst))))))

(defun gen-action (states action)
  `((and ,@(mapcar (lambda (s e) (if (eq e :any) t `(eq ,s ,e))) '(tray player) states))
    ,(if (atom action) action `(funcall ,action))))
GEN-ACTION
CL-USER> (transform '(:open (:CLOSE :PLAY)  -> (lambda ()
                                                  (print ">>> STOP")
                                                  (setf player :STOP)
                                                  (print ">>> OPEN")
                                                  (setf tray :OPEN))
                            (:CLOSE :STOP)  -> (lambda ()
                                                  (print ">>> OPEN")
                                                  (setf tray :OPEN))
                            (:any :any)       -> :ignore))
(:OPEN %OPEN
       (%OPEN NIL
              (COND
               ((AND (EQ TRAY :CLOSE) (EQ PLAYER :PLAY))
                (FUNCALL
                 (LAMBDA ()
                   (PRINT ">>> STOP")
                   (SETF PLAYER :STOP)
                   (PRINT ">>> OPEN")
                   (SETF TRAY :OPEN))))
               ((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
                (FUNCALL (LAMBDA () (PRINT ">>> OPEN") (SETF TRAY :OPEN))))
               ((AND T T) :IGNORE))))
CL-USER> 

となり，かなりできてきました．まとめて一つの関数にしてみます．

(defun build-state-machine (name states body
                             &aux (state-symbols (mapcar (lambda (e) (if (consp e) (first e) e)) states)))
  (labels ((transform (action)
             (let* ((event (first action))
                    (name  (intern (concatenate 'string "%" (symbol-name event)))))
               (list event name `(,name () (cond ,@(action-builder (rest action)))))))
           (action-builder (lst)
             (if (null lst)
                 nil
               (let ((states (first lst))
                     (body   (third lst)))
                 (cons (gen-action states body) (action-builder (nthcdr 3 lst))))))
           (gen-action (states action)
             `((and ,@(mapcar (lambda (s e) (if (eq e :any) t `(eq ,s ,e))) state-symbols states))
               ,(if (atom action) action `(funcall ,action) ))))
    (let ((actions (mapcar #'transform body)))
      `(defun ,name (&aux ,@states)
         ;; 作成したアクションを labels で関数に展開
         (labels (,@(mapcar #'third actions))
           (lambda (input)
             ;; 入力に応じた関数を呼び出す case フォームに展開する
             (case input
               ,@(mapcar (lambda (e) `(,(first e) (,(second e)))) actions))))))))

CL-USER> (build-state-machine 'cd-player '((tray :CLOSE) (player :STOP)) '((:open 
     (:CLOSE :PLAY)  -> (lambda ()
                          (print ">>> STOP")
                          (setf player :STOP)
                          (print ">>> OPEN")
                          (setf tray :OPEN))
     (:CLOSE :STOP)  -> (lambda ()
                          (print ">>> OPEN")
                          (setf tray :OPEN))
     (:any :any)       -> :ignore)
    (:close
     (:OPEN :any) -> (lambda ()
                       (print ">>> CLOSE")
                    (setf tray :CLOSE))
     (:any :any)       -> :ignore)
    (:play
     (:CLOSE :STOP) -> (lambda ()
                         (print ">>> PLAY")
                         (setf player :PLAY))
     (:OPEN :any) -> (lambda ()
                    (print ">>> CLOSE")
                    (setf tray :CLOSE)
                    (print ">>> PLAY")
                    (setf player :PLAY))
     (:any :any) -> :ignore)
    (:stop
     (:any :PLAY) -> (lambda ()
                        (print ">>> STOP")
                        (setf player :STOP)))))
(DEFUN CD-PLAYER (&AUX (TRAY :CLOSE) (PLAYER :STOP))
  (LABELS ((%OPEN ()
             (COND
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :PLAY))
               (FUNCALL
                (LAMBDA ()
                  (PRINT ">>> STOP")
                  (SETF PLAYER :STOP)
                  (PRINT ">>> OPEN")
                  (SETF TRAY :OPEN))))
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
               (FUNCALL (LAMBDA () (PRINT ">>> OPEN") (SETF TRAY :OPEN))))
              ((AND T T) :IGNORE)))
           (%CLOSE ()
             (COND
              ((AND (EQ TRAY :OPEN) T)
               (FUNCALL (LAMBDA () (PRINT ">>> CLOSE") (SETF TRAY :CLOSE))))
              ((AND T T) :IGNORE)))
           (%PLAY ()
             (COND
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
               (FUNCALL (LAMBDA () (PRINT ">>> PLAY") (SETF PLAYER :PLAY))))
              ((AND (EQ TRAY :OPEN) T)
               (FUNCALL
                (LAMBDA ()
                  (PRINT ">>> CLOSE")
                  (SETF TRAY :CLOSE)
                  (PRINT ">>> PLAY")
                  (SETF PLAYER :PLAY))))
              ((AND T T) :IGNORE)))
           (%STOP ()
             (COND
              ((AND T (EQ PLAYER :PLAY))
               (FUNCALL (LAMBDA () (PRINT ">>> STOP") (SETF PLAYER :STOP)))))))
    (LAMBDA (INPUT)
      (CASE INPUT
        (:OPEN (%OPEN))
        (:CLOSE (%CLOSE))
        (:PLAY (%PLAY))
        (:STOP (%STOP))))))
CL-USER> 

これで変形は完了です．あとはこれをマクロにしましょう．

(defmacro define-state-machine (name states &body body)
  (build-state-machine name states body))

これで完成です．build-state-machine 関数は define-state-machine に展開 してしまってもいいです．

CL-USER> (macroexpand-1 '(define-state-machine cd-player ((tray :CLOSE) (player :STOP))
  (:open 
   (:CLOSE :PLAY)  -> (lambda ()
                        (print ">>> STOP")
                        (setf player :STOP)
                        (print ">>> OPEN")
                        (setf tray :OPEN))
   (:CLOSE :STOP)  -> (lambda ()
                        (print ">>> OPEN")
                        (setf tray :OPEN))
     (:any :any)       -> :ignore)
  (:close
   (:OPEN :any) -> (lambda ()
                     (print ">>> CLOSE")
                     (setf tray :CLOSE))
   (:any :any)       -> :ignore)
  (:play
   (:CLOSE :STOP) -> (lambda ()
                       (print ">>> PLAY")
                       (setf player :PLAY))
   (:OPEN :any) -> (lambda ()
                     (print ">>> CLOSE")
                     (setf tray :CLOSE)
                     (print ">>> PLAY")
                     (setf player :PLAY))
   (:any :any) -> :ignore)
  (:stop
   (:any :PLAY) -> (lambda ()
                     (print ">>> STOP")
                     (setf player :STOP)))))
(DEFUN CD-PLAYER (&AUX (TRAY :CLOSE) (PLAYER :STOP))
  (LABELS ((%OPEN ()
             (COND
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :PLAY))
               (FUNCALL
                (LAMBDA ()
                  (PRINT ">>> STOP")
                  (SETF PLAYER :STOP)
                  (PRINT ">>> OPEN")
                  (SETF TRAY :OPEN))))
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
               (FUNCALL (LAMBDA () (PRINT ">>> OPEN") (SETF TRAY :OPEN))))
              ((AND T T) :IGNORE)))
           (%CLOSE ()
             (COND
              ((AND (EQ TRAY :OPEN) T)
               (FUNCALL (LAMBDA () (PRINT ">>> CLOSE") (SETF TRAY :CLOSE))))
              ((AND T T) :IGNORE)))
           (%PLAY ()
             (COND
              ((AND (EQ TRAY :CLOSE) (EQ PLAYER :STOP))
               (FUNCALL (LAMBDA () (PRINT ">>> PLAY") (SETF PLAYER :PLAY))))
              ((AND (EQ TRAY :OPEN) T)
               (FUNCALL
                (LAMBDA ()
                  (PRINT ">>> CLOSE")
                  (SETF TRAY :CLOSE)
                  (PRINT ">>> PLAY")
                  (SETF PLAYER :PLAY))))
              ((AND T T) :IGNORE)))
           (%STOP ()
             (COND
              ((AND T (EQ PLAYER :PLAY))
               (FUNCALL (LAMBDA () (PRINT ">>> STOP") (SETF PLAYER :STOP)))))))
    (LAMBDA (INPUT)
      (CASE INPUT
        (:OPEN (%OPEN))
        (:CLOSE (%CLOSE))
        (:PLAY (%PLAY))
        (:STOP (%STOP))))))