積木の移動
今回は簡単な例題として、積木を指定の位置に移動するプログラムを作ってみましょう。このプログラムは 参考文献 1 第 21 章「クラスとメソッドを用いた積木の世界」 を参考にしました。ただし、積木の種類を 1 つに減らして超簡略化しています。その分だけプログラムも簡単になります。次の図を見てください。
上図のように同じ種類の積木が 8 個テーブルの上に置いてあります。ハンドは積木をひとつだけ持ち上げて移動することができます。この積木を指定した積木の上、またはテーブルの上に移動するメソッド put-on を作りましょう。put-on は第 1 引数に移動する積木、第 2 引数に移動先の積木またはテーブルを指定します。簡単な動作例を示します。
* (put-on b2 b0) Move HAND to 2 from 0 Grasp B2 Move B2 to top of B0 at location 0 Ungrasp B2 NIL
上図の状態で積木 B2 を B0 の上に置きます。最初にハンドを位置 2 へ移動して、積木 B2 をつかみます。そして、B2 を位置 0 にある B0 の上へ移動してから B2 を離します。これで、B0 の上に B2 が置かれた状態になります。
次に、この状態で B0 を B7 へ移動します。この場合、最初に B0 の上にある B2 をテーブルへ置いてから B0 を B7 へ移動します。動作例は次のようになります。
* (put-on b0 b7) Grasp B2 Move B2 to top of TABLE at location 2 Ungrasp B2 Move HAND to 0 from 2 Grasp B0 Move B0 to top of B7 at location 7 Ungrasp B0 NIL
B2 をつかんでテーブルの空き場所へ置きます。それから、B0 をつかんで B7 へ移動します。このように、邪魔な積木がある場合は、そのブロックをテーブルへ移動させるわけです。テーブルには積木を置く十分な空き場所があるので、ブロックの移動は必ず成功します。この処理は put-on を再帰呼び出しすれば簡単に実現できます。
●クラスの定義
それではプログラムを作りましょう。最初にクラスを定義します。次のリストを見てください。
リスト : クラス定義 ;;; 基本クラス (defclass base-block () ((name :accessor block-name :initarg :name) (position :accessor block-position :initarg :position) (supported-for :accessor block-supported-for :initform nil) (supported-by :accessor block-supported-by :initarg :supported-by :initform nil))) ;;; テーブル (defclass table (base-block) ((space-position :accessor table-space-position :initform nil))) ;;; 積木 (defclass sblock (base-block) ()) ;;; ハンド (defclass hand () ((name :accessor hand-name :initarg :name :initform 'hand) (position :accessor hand-position :initarg :position) (grasping :accessor hand-grasping :initform nil)))
必要なオブジェクトはテーブル、積木、ハンドの 3 つです。テーブルと積木の上には他の積木を置くことができるので、この共通部分を BASE-BLOCK というクラスで表すことにします。そして、BASE-BLOCK を継承してテーブルを表すクラス TABLE と積木を表すクラス SBLOCK を作成します。ハンドを表すクラスは HAND とします。
クラス BASE-BLOCK のスロット NAME はオブジェクトの名前、POSITION はオブジェクトの位置を表します。SUPPORTED-BY は自分の下にある (支持されている) オブジェクト、SUPPORTED-FOR は自分の上にある (支持している) オブジェクトを格納します。
たとえば、テーブルの上に積木 B0 があり、B0 の上に B2 がある場合、B0 の SUPPORTED-BY にはテーブルのインスタンスがセットされ、SUPPORTED-FOR には B2 のインスタンスがセットされます。積木の上に何も置かれていない場合、SUPPORTED-FOR の値は NIL になります。また、ハンドで持ち上げられている状態では SUPPORTED-BY の値は NIL になります。
クラス TABLE のスロット SPACE-POSITION は空き場所の位置を表します。積木をテーブルへ移動する場合、SPACE-POSITION から空き場所を求めて積木をそこへ置きます。テーブルには複数の積木が置かれているので、TABLE の SUPPORTED-FOR は積木のインスタンスをリストに格納してセットすることにします。テーブルと積木で SUPPORTED-FOR にセットするデータ型が異なりますが、この違いは積木を移動するメソッドで対応することができます。
積木を表すクラス SBLOCK には追加するスロットはありません。クラス SBLOCK を定義することで、テーブルと積木が別のオブジェクトであることを表します。クラス HAND のスロット NAME はハンドの名前、POSITION はハンドの位置、GRASPING はハンドがつかんでいる積木のインスタンスを表します。何もつかんでいない場合は NIL になります。
●インスタンスの生成
次は必要なインスタンスを生成する関数 init-block-world を作ります。次のリストを見てください。
リスト : 必要なインスタンスを生成する
;;; スペシャル変数の宣言
(defvar *hand*)
(defvar *table*)
;;; 初期化
(defun init-block-world ()
(setq *hand* (make-instance 'hand :position 0)
*table* (make-instance 'table :name 'table))
(let ((block-name '(b0 b1 b2 b3 b4 b5 b6 b7))
block)
(dotimes (x (length block-name))
(setq block (make-instance 'sblock
:name (nth x block-name)
:position x
:supported-by *table*))
;; インスタンスをシンボルにセット
(setf (symbol-value (nth x block-name)) block)
;; テーブルに置く
(push block (block-supported-for *table*)))))
テーブルとハンドのインスタンスはスペシャル変数 *HAND* と *TABLE* にセットします。あとは積木のインスタンスを生成して、それをテーブルに配置します。積木の名前はシンボルで表します。そして、積木のインスタンスをシンボルのスペシャル変数にセットします。これで積木の名前からインスタンスを簡単に求めることができます。
●メソッドの作成
それでは、メソッド put-on を作りましょう。put-on はひとつの積木を他の積木の上、またはテーブルの上へ置くメソッドです。したがって、引数特定子は第 1 引数が SBLOCK になり、第 2 引数が BASE-BLOCK になります。上にある積木を動かす処理は :before メソッドを使うと簡単です。次のリストを見てください。
リスト : 積木を置く
(defmethod put-on ((obj sblock) (support base-block))
(grasp obj) ; obj をつかむ
(move obj support) ; support の上まで移動
(ungrasp obj)) ; obj を離す
;;; (1) 上にあるブロックをテーブルへ移動
(defmethod put-on :before ((obj sblock) (support base-block))
(if (block-supported-for obj)
(put-on (block-supported-for obj) *table*)))
;;; (2) 移動先がブロックの場合
(defmethod put-on :before ((obj sblock) (support block))
(if (block-supported-for support)
(put-on (block-supported-for support) *table*)))
基本メソッドはとても簡単です。関数 graps でハンドを動かして積木をつかみます。そして、メソッド move で積木を指定位置まで動かして、関数 ungraps で積木を離します。
上にある積木を動かす処理は :before メソッドで行います。ハンドで積木 OBJ を持ち上げる前に、ほかの積木をテーブルへ動かします。この処理をメソッド (1) で行います。次に、移動先が積木の場合、その上にある積木を動かさないといけません。この処理をメソッド (2) で行います。
クラスの継承関係により、移動先がテーブルであればメソッド (2) は評価されず、メソッド (1) だけが評価されます。移動先が積木の場合はメソッド (2) が評価され、次にメソッド (1) が評価されます。どちらのメソッドも上に積木があれば、その積木を put-on でテーブルへ動かします。このように put-on を再帰呼び出しすることで、上にある積木をすべてテーブルへ動かすことができます。
次は積木を動かすメソッド move を作ります。SUPPORTED-FOR と SUPPORTED-BY の更新を補助メソッドに任せると、基本メソッドはとても簡単になります。次のリストを見てください。
リスト : 積木の移動
(defmethod move ((obj sblock) (support base-block))
(let ((new-position (block-position support)))
(format t "Move ~a to top of ~a at location ~a~%"
(block-name obj)
(block-name support)
new-position)
(setf (hand-position *hand*) new-position
(block-position obj) new-position)))
;;; table 用 block-position メソッド
(defmethod block-position ((obj table))
;; 空き場所を返す
(first (table-space-position obj)))
最初に移動先の位置をメソッド block-position で求め、変数 NEW-POSITION にセットします。移動先がテーブルの場合、スロット POSITION の値ではなく、積木を置く位置を返さないといけません。このため、メソッド block-position をオーバーライドしています。
このメソッドは SPACE-POSITION から空き場所の位置を取り出して返すだけです。あとは、積木の移動を format で表示して、ハンドと積木の POSITION を更新するだけです。
次は move の :before メソッドを作ります。このメソッドは動かす積木の SUPPORTED-BY と、その下にあるオブジェクトの SUPPORTED-FOR を更新します。プログラムは次のようになります。
リスト : move の :before メソッド
(defmethod move :before ((obj sblock) dummy)
(let ((support (block-supported-by obj)))
(setf (block-supported-by obj) nil)
(delete-support support obj)))
;;; 積木用
(defmethod delete-support ((support sblock) dummy)
(setf (block-supported-for support) nil))
;;; テーブル用
(defmethod delete-support ((support table) (obj sblock))
(push (block-position obj) (table-space-position support))
(setf (block-supported-for support)
(remove obj (block-supported-for support))))
動かす積木 OBJ の下にあるオブジェクトを取り出して変数 SUPPORT にセットします。そして、OBJ の SUPPPRTED-BY を NIL に書き換えて、SUPPORT の SUPPORTED-FOR から OBJ を削除します。この処理をメソッド delete-support で行います。SUPPORT には積木とテーブルがあるので、それぞれに対応するメソッドを定義します。
積木に対応する delete-support は簡単ですね。SUPPORT の SUPPORTED-FOR を NIL に書き換えるだけです。テーブルの場合、積木 OBJ が置いてある場所を空き場所 SPACE-POSITION に追加して、SUPPORTED-FOR から OBJ を削除します。
次は move の :after メソッドを作ります。このメソッドは動かした積木の SUPPORTED-BY と、その積木を置くオブジェクトの SUPPORTED-FOR を更新します。プログラムは次のようになります。
リスト : move の :after メソッド
(defmethod move :after ((obj sblock) (support base-block))
(setf (block-supported-by obj) support)
(add-support support obj))
;;; 積木用
(defmethod add-support ((support sblock) (obj sblock))
(setf (block-supported-for support) obj))
;;; テーブル用
(defmethod add-support ((support table) (obj sblock))
(push obj (block-supported-for support))
(setf (table-space-position support)
(remove (block-position obj) (table-space-position support))))
動かした積木 OBJ の SUPPORTED-BY を移動先のオブジェクト SUPPORT に更新します。そして、SUPPORT の SUPPORT-FOR をメソッド add-support で更新します。積木に対応する add-support は簡単ですね。SUPPORT の SUPPORTED-FOR を OBJ に書き換えるだけです。テーブルの場合、積木 OBJ を SUPPORTED-FOR に追加して、空き場所 SPACE-POSITION から OBJ の場所を削除します。
最後にハンドを操作する関数を作ります。ハンドはひとつしかないので、操作は関数で十分です。次のリストを見てください。
リスト : ハンドの操作
;;; ブロックをつかむ
(defun grasp (obj)
(when (/= (block-position obj) (hand-position *hand*))
;; ハンドの移動
(format t "Move ~a to ~a from ~a~%"
(hand-name *hand*)
(block-position obj)
(hand-position *hand*))
(setf (hand-position *hand*) (block-position obj)))
(format t "Grasp ~a~%" (block-name obj))
(setf (hand-grasping *hand*) obj))
;;; ブロックを離す
(defun ungrasp (obj)
(format t "Ungrasp ~a~%" (block-name obj))
(setf (hand-grasping *hand*) nil))
積木をつかむ動作は関数 grasp で行います。ハンドと積木 OBJ の位置をチェックして、位置が違う場合はハンドを移動します。次に、積木をつかむメッセージを format で表示して、GRASPING に積木 OBJ をセットします。積木を離す動作は関数 ungrasp で行います。これは GRASPING を NIL に書き換えてメッセージを表示するだけです。
●実行例
これでプログラムは完成です。さっそく実行してみましょう。
* (init-block-world) NIL * (print-table) 0 : B0 1 : B1 2 : B2 3 : B3 4 : B4 5 : B5 6 : B6 7 : B7 space position is NIL NIL * (put-on b7 b0) Move HAND to 7 from 0 Grasp B7 Move B7 to top of B0 at location 0 Ungrasp B7 NIL * (print-table) 0 : B0 B7 1 : B1 2 : B2 3 : B3 4 : B4 5 : B5 6 : B6 7 : space position is (7) NIL * (put-on b0 b7) Grasp B7 Move B7 to top of TABLE at location 7 Ungrasp B7 Move HAND to 0 from 7 Grasp B0 Move B0 to top of B7 at location 7 Ungrasp B0 NIL * (print-table) 0 : 1 : B1 2 : B2 3 : B3 4 : B4 5 : B5 6 : B6 7 : B7 B0 space position is (0) NIL
正常に動作していますね。print-table はテーブルの状態を表示する関数です。詳細は プログラムリスト をお読みくださいませ。
●プログラムの改良
ところで、このプログラムには問題点があります。次の例を見てください。
* (print-table) 0 : 1 : B1 2 : B2 3 : B3 4 : B4 5 : B5 6 : B6 7 : B7 B0 space position is (0) NIL * (put-on b0 b7) Grasp B0 Move B0 to top of TABLE at location 0 Ungrasp B0 Grasp B0 Move B0 to top of B7 at location 7 Ungrasp B0 NIL * (put-on b1 *table*) Move HAND to 1 from 7 Grasp B1 Move B1 to top of TABLE at location 1 Ungrasp B1 NIL
積木 B0 が B7 の上にある状態で (put-on b7 b0) を評価します。この場合、積木を動かす必要はありませんね。ところが、B7 をテーブルへ動かしてから、再び B7 を B0 へ移動しています。また、B1 がテーブルの上にある状態で、(put-on b1 *table*) を評価する場合も同様です。この場合も B1 を動かす必要はありませんが、B1 の移動処理が行われています。
そこで、積木の移動が必要かチェックする処理を追加します。このチェック処理を put-on の基本メソッドに追加することはできません。なぜなら、基本メソッドの前に :before メソッドが評価されるからです。
このような場合、:around メソッドを使うと簡単にチェック処理を実現できます。次のリストを見てください。
リスト : :around メソッドの定義
(defmethod put-on :around ((obj sblock) (support base-block))
(if (eq (block-supported-by obj) support)
(format t "It is not necessary to move~%")
(call-next-method)))
積木 OBJ がオブジェクト SUPPORT の上にあれば、OBJ を動かす必要はありません。format でメッセージを表示します。そうでなければ、call-next-method を評価して積木の移動処理を実行します。とても簡単ですね。
それでは実際に試してみましょう。
* (init-block-world) NIL * (put-on b1 b6) Move HAND to 1 from 0 Grasp B1 Move B1 to top of B6 at location 6 Ungrasp B1 NIL * (print-table) 0 : B0 1 : 2 : B2 3 : B3 4 : B4 5 : B5 6 : B6 B1 7 : B7 space position is (1) NIL * (put-on b1 b6) It is not necessary to move NIL * (put-on b6 *table*) It is not necessary to move NIL
正常に動作していますね。ところで、このプログラムは積木が 1 種類しかないので、オブジェクト指向の例題としては簡単すぎて面白くなかったかもしれません。参考文献 1 の「積木の世界」では、ボールや三角柱など形の違う積木や、同じ形でも大きさが異なる積木を取り扱っています。興味のある方はぜひ読んでみてください。
●プログラムリスト
;;;
;;; block.lisp : 積木の移動 (超簡易バージョン)
;;;
;;; Copyright (C) 2003-2020 Makoto Hiroi
;;;
;;;
;;; クラス定義
;;;
;;; 基本クラス
(defclass base-block ()
((name :accessor block-name :initarg :name)
(position :accessor block-position :initarg :position)
(supported-for :accessor block-supported-for :initform nil)
(supported-by :accessor block-supported-by :initarg :supported-by :initform nil)))
;;; テーブル
(defclass table (base-block)
((space-position :accessor table-space-position :initform nil)))
;;; 積木
(defclass sblock (base-block) ())
;;; ハンド
(defclass hand ()
((name :accessor hand-name :initarg :name :initform 'hand)
(position :accessor hand-position :initarg :position)
(grasping :accessor hand-grasping :initform nil)))
;;;
;;; インスタンスの生成
;;;
;;; スペシャル変数の宣言
(defvar *hand*)
(defvar *table*)
;;; 初期化
(defun init-block-world ()
(setq *hand* (make-instance 'hand :position 0)
*table* (make-instance 'table :name 'table))
(let ((block-name '(b0 b1 b2 b3 b4 b5 b6 b7))
block)
(dotimes (x (length block-name))
(setq block (make-instance 'sblock
:name (nth x block-name)
:position x
:supported-by *table*))
;; インスタンスをシンボルにセット
(setf (symbol-value (nth x block-name)) block)
;; table に置く
(push block (block-supported-for *table*)))))
;;;
;;; ハンド操作関数
;;;
;;; ハンドでブロックをつかむ
(defun grasp (obj)
(when (/= (block-position obj) (hand-position *hand*))
;; ハンドの移動
(format t "Move ~a to ~a from ~a~%"
(hand-name *hand*)
(block-position obj)
(hand-position *hand*))
(setf (hand-position *hand*) (block-position obj)))
(format t "Grasp ~a~%" (block-name obj))
(setf (hand-grasping *hand*) obj))
;;; ブロックを離す
(defun ungrasp (obj)
(format t "Ungrasp ~a~%" (block-name obj))
(setf (hand-grasping *hand*) nil))
;;;
;;; 積木の移動
;;;
(defmethod move ((obj sblock) (support base-block))
(let ((new-position (block-position support)))
(format t "Move ~a to top of ~a at location ~a~%"
(block-name obj)
(block-name support)
new-position)
(setf (hand-position *hand*) new-position
(block-position obj) new-position)))
;;; table 用メソッド (オーバーライド)
(defmethod block-position ((obj table))
;; 空き場所を返す
(first (table-space-position obj)))
;;;
;;; :before メソッド
;;;
;;; 積木用
(defmethod delete-support ((support sblock) dummy)
(setf (block-supported-for support) nil))
;;; テーブル用
(defmethod delete-support ((support table) (obj sblock))
(push (block-position obj) (table-space-position support))
(setf (block-supported-for support)
(remove obj (block-supported-for support))))
(defmethod move :before ((obj sblock) dummy)
(let ((support (block-supported-by obj)))
(setf (block-supported-by obj) nil)
(delete-support support obj)))
;;;
;;; :after メソッド
;;;
;;; 積木用
(defmethod add-support ((support sblock) (obj sblock))
(setf (block-supported-for support) obj))
;;; テーブル用
(defmethod add-support ((support table) (obj sblock))
(push obj (block-supported-for support))
(setf (table-space-position support)
(remove (block-position obj) (table-space-position support))))
(defmethod move :after ((obj sblock) (support base-block))
(setf (block-supported-by obj) support)
(add-support support obj))
;;;
;;; 積木を置く
;;;
(defmethod put-on ((obj sblock) (support base-block))
(grasp obj) ; obj をつかむ
(move obj support) ; support の上まで移動
(ungrasp obj)) ; obj を離す
;;; (1) 上にあるブロックをテーブルへ移動
(defmethod put-on :before ((obj sblock) (support base-block))
(if (block-supported-for obj)
(put-on (block-supported-for obj) *table*)))
;;; (2) 移動先がブロックの場合
(defmethod put-on :before ((obj sblock) (support sblock))
(if (block-supported-for support)
(put-on (block-supported-for support) *table*)))
;;; :around メソッドの定義
(defmethod put-on :around ((obj sblock) (support base-block))
(if (eq (block-supported-by obj) support)
(format t "It is not necessary to move~%")
(call-next-method)))
;;;
;;; テーブル表示関数
;;;
(defun print-block (block)
(when block
(format t "~A " (block-name block))
(print-block (block-supported-for block))))
(defun print-table ()
(dotimes (x 8)
(let ((block (find x (block-supported-for *table*) :key #'block-position)))
(format t "~D : " x)
(if block (print-block block))
(terpri)))
(format t "space position is ~a~%" (table-space-position *table*)))