Common Lispでゲーム用の状態遷移マシン 完成？

やっと、コード書く時間がとれたので、記録用に書きます。

singletonクラス作成用のパッケージ

とりあえず、singletonをつくるためのパッケージを作成しました。
http://cadr.g.hatena.ne.jp/g000001/20081202/1228199756
この記事が超参考になりました。

closer-mopを使うことで、特定の実装に依存しないでsingletonが実現できますね。
素晴らしいです。

(defpackage :singleton
  (:use :cl )
  (:export #:define-singleton-class
	   ))

(in-package :singleton)
(defclass singleton-meta (standard-class)
  ((%the-singleton-instance :initform () )))

(defmethod make-instance ((class singleton-meta) &key)
  (with-slots (%the-singleton-instance) class
    (if %the-singleton-instance
        %the-singleton-instance
        (let ((ins (call-next-method)))
          (setf %the-singleton-instance ins)
          ins))))

(defmethod c2mop:validate-superclass ((class singleton-meta)
                                      (super standard-class))
  'T)
(defmethod c2mop:validate-superclass ((class singleton-meta)
                                (superclass standard-class))
  ;; it's OK for a standard class to be a superclass of a singleton
  ;; class
  'T)

(defmethod c2mop:validate-superclass ((class singleton-meta)
                                (superclass singleton-meta))
  ;; it's OK for a singleton class to be a subclass of a singleton class
  'T)

(defmethod c2mop:validate-superclass ((class standard-class)
                                (superclass singleton-meta))
  ;; but it is not OK for a standard class which is not a singleton class
  ;; to be a subclass of a singleton class
  nil)

(defmacro define-singleton-class (name supers &rest args)
  (and (assoc :metaclass args)
       (error "Metaclass already specified."))
  `(defclass ,name ,supers ,@args
     (:metaclass singleton-meta)))

状態遷移マシン自体のパッケージ

状態遷移マシンは、こんな感じで実装してみました。
state-machine:stateを継承しているクラスを使うことを想定しています。

(in-package :cl)
(defpackage :state-machine
  (:use :cl :singleton)
  (:export #:state
  	   #:state-machine
	   #:set-current-state
	   #:set-prev-state
	   #:set-global-state
	   #:change-state
	   #:enter
	   #:execute
	   #:exit
	   #:update
	   #:current-state ) )
(in-package :state-machine)
(singleton:define-singleton-class state ()
  ())
(defmethod enter ((state-instance state) &rest arg) )
(defmethod execute ((state-instance state) &rest arg) )
(defmethod exit ((state-instance state) &rest arg) )
(defclass state-machine ()
  ((owner :initarg :owner)
   (current-state :initform nil  :accessor current-state)
   (prev-state :initform nil :accessor prev-state)
   (global-state :initform nil :accessor global-state)))

(defmethod set-current-state ((obj state-machine) s)
  (setf (current-state obj) s))
(defmethod set-prev-state ((obj state-machine) s)
  (setf (prev-state obj) s))
(defmethod set-global-state ((obj state-machine) s)
  (setf (global-state obj) s))  
    
(defmethod update ((obj state-machine))
  (when (not (null (global-state obj)))
    (execute (make-instance (global-state obj))))
  (when (not (null (current-state obj)))
    (execute (make-instance (current-state obj)))))

(defmethod change-state ((obj state-machine) new-state)
  (setf (prev-state obj) (current-state obj))
  (exit (make-instance (current-state obj)))
  (setf (current-state obj) new-state)
  (enter (make-instance (current-state obj))))

実際の例

こんな感じで、状態遷移マシンを構成してみます。

(singleton:define-singleton-class getup (state-machine:state)  ())
(singleton:define-singleton-class goodnight (state-machine:state) ())

(defmethod state-machine:enter ((state-instance getup) &rest arg) 
  (declare (ignore arg))
  (format t "enter getup~%"))
(defmethod state-machine:execute ((state-instance getup) &rest arg) 
  (declare (ignore arg))
  (format t "exec getup~%"))
(defmethod state-machine:exit ((state-instance getup) &rest arg) 
  (declare (ignore arg))
  (format t "exit getup~%"))

(defmethod state-machine:enter ((state-instance goodnight) &rest arg) 
  (declare (ignore arg))
  (format t "enter goodnight~%"))
(defmethod state-machine:execute ((state-instance goodnight) &rest arg) 
  (declare (ignore arg))
  (format t "exec  goodnight~%"))
(defmethod state-machine:exit ((state-instance goodnight) &rest arg) 
  (declare (ignore arg))
  (format t "exit  goodnight~%"))

(setf fsm (make-instance 'state-machine:state-machine))
(state-machine:set-current-state fsm  'getup)
(state-machine:update fsm)

さて、実際に実行してみると

CL-USER> (state-machine:update fsm)
exec getup
NIL
CL-USER> (state-machine:update fsm)
exec getup
NIL
CL-USER> (state-machine:update fsm)
exec getup
NIL
CL-USER> (state-machine:change-state fsm 'goodnight)
exit getup
enter goodnight
NIL
CL-USER> (state-machine:update fsm)
exec  goodnight
NIL

いい感じですねー。

課題

• 状態遷移のためのstateを継承したクラスの定義が面倒くさい。パッケージをわざわざ指定するのは面倒くさい。

解決方法をちょっと考えてみます...。