今回は簡単な例題として「二分木」を作ってみましょう。拙作のページ「二分探索木」では構造体を使って二分木を実装しましたが、オブジェクト指向を使っても簡単にプログラムを作ることができます。
今回作成する二分木は節に要素をひとつ格納することとし、重複した要素は含まないものとします。クラス名は TREE-SET としました。キーを比較する関数は TREE-SET のインスタンスを生成するときに指定します。キーワード :obj= には 2 つの引数が等しいときに真を返す述語を渡し、:obj< には第 1 引数が第 2 引数より小さい場合に真を返す述語を渡します。デフォルトでは :obj= が #'eql で、:obj< が #'< とします。
これだけでは面白くないので、要素からキーを取り出す関数をキーワード :key で指定できるようにします。たとえば、コンスセル (a . b) を要素とする場合、:key に #'car を指定すると、コンスセルの CAR 部をキーとして二分木を構成します。#'cdr を指定すると、CDR 部をキーとして二分木が構成されます。:key を指定することで、ハッシュ表のようなキーと値を組にした辞書的な使い方も可能です。:key のデフォルトは関数 identity とします。
クラス TREE-SET で公開するメソッドを下表に示します。
| メソッド | 機能 |
|---|---|
| tree-get tree key | tree から key を持つ要素を求める |
| tree-put tree value | tree に要素 value を追加する |
| tree-delete tree key | tree から key を持つ要素を削除する |
| tree-get-min tree | tree から最小値を求める |
| tree-get-max tree | tree から最大値を求める |
| tree-delete-min tree | tree から最小値を削除する |
| tree-delete-max tree | tree から最大値を削除する |
| tree-fold-left tree func init | tree の要素に畳み込みを行う |
| tree-fold-right tree func init | tree の要素に畳み込みを行う |
| tree-for-each tree func | tree の要素に関数 func を適用する |
| tree-copy tree | tree をコピーする |
| tree-emptyp tree | tree が空の場合は T を返す |
| tree-length tree | tree の要素数を求める |
:key を指定しない場合、引数 KEY と引数 VALUE に違いはありませんが、:key を指定する場合、二分木に格納する要素と KEY は異なるデータになります。たとえば、コンスセル (a . b) を格納する場合、tree-put の引数 VALUE はコンスセルになり、他のメソッドの引数 KEY は CAR 部のデータになります。また、tree-get の返り値はキーではなくコンスセルになります。
それではプログラムを作りましょう。最初に、節 (ノード) と二分木を表すクラスを定義します。次のリストを見てください。
リスト : クラスの定義 ;;; 節の定義 (defclass node () ((item :accessor node-item :initform nil :initarg :item) (left :accessor node-left :initform nil :initarg :left) (right :accessor node-right :initform nil :initarg :right))) ;;; 二分木の定義 (defclass tree-set () ((root :accessor tree-root :initform nil :initarg :root) (obj= :accessor tree-obj= :initform #'eql :initarg :obj=) (obj< :accessor tree-obj< :initform #'< :initarg :obj<) (key :accessor tree-key :initform #'identity :initarg :key)))
節はクラス NODE で表します。スロット ITEM にデータを、LEFT に左の子を、RIGHT に右の子を格納します。二分木はクラス TREE-SET で表します。スロット ROOT に二分木のルートを格納します。終端 (空の木) は NIL で表します。
TREE-SET のスロット OBJ= と OBJ< には要素を比較する述語をセットします。OBJ= には 2 つの引数が等しいときに真を返す述語を、OBJ< には第 1 引数が第 2 引数よりも小さい場合に真を返す述語をセットします。デフォルトの値は #'eql と #'< です。スロット KEY には要素からキーを取り出す関数をセットします。デフォルトは引数をそのまま返す関数 identity です。
ここで、スロットのアクセスで役に立つマクロを紹介しましょう。マクロ with-slots を使うと、指定したスロットをレキシカル変数のようにアクセスすることができます。
(with-slots (スロット名 ...) インスタンス Ｓ式 ...)
スロット名を指定すると、その名前でスロットにアクセスすることができます。もちろん、setf や setq で値を代入することもできます。また、スロット名のほかに、(変数名 スロット名) と指定することもできます。この場合、指定した変数名でスロットにアクセスすることができます。
簡単な使用例を示しましょう。
* (defclass bar ()
((a :initform 10) (b :initform 20) (c :initform 30)))
#<STANDARD-CLASS COMMON-LISP-USER::BAR>
* (defmethod baz ((z bar))
(with-slots (a b c) z (+ a b c)))
#<STANDARD-METHOD COMMON-LISP-USER::BAZ (BAR) {10023CC4F3}>
* (setq x (make-instance 'bar))
#<BAR {10023D09F3}>
* (baz x)
60
クラス BAR にはスロット A, B, C があります。メソッド BAZ は 3 つのスロットの合計値を求めます。with-slots でスロット名 A, B, C を指定しているので、変数 A, B, C でスロットにアクセスすることができます。
マクロ with-slots を使うと、スロットをあたかもレキシカル変数のようにアクセスすることができますが、実際のアクセスには slot-value を使っていることに注意してください。つまり、指定された変数名のアクセスは、slot-value でスロットにアクセスするようにマクロ展開されるわけです。
もうひとつ便利なマクロを紹介します。マクロ with-accessors は with-slots と同様に、指定した変数名を使ってスロットにアクセスすることができます。
(with-accessors ((変数名 アクセスメソッド) ...) インスタンス Ｓ式 ...)
アクセスメソッドは :accessor で指定したメソッド名です。with-accessors は指定した変数名でアクセスメソッドに対応するスロットにアクセスすることができます。もちろん、setf や setq で値を代入することもできます。
簡単な使用例を示しましょう。
* (defclass bar ()
((a :accessor bar-a :initform 10)
(b :accessor bar-b :initform 20)
(c :accessor bar-c :initform 30)))
#<STANDARD-CLASS COMMON-LISP-USER::BAR>
* (defmethod baz ((z bar))
(with-accessors ((a bar-a) (b bar-b) (c bar-c)) z
(+ a b c)))
#<STANDARD-METHOD COMMON-LISP-USER::BAZ (BAR) {1001C5C3F3}>
* (setq x (make-instance 'bar))
#<BAR {1001C608E3}>
* (baz x)
60
クラス BAR にはスロット A, B, C があります。メソッド baz は 3 つのスロットの合計値を求めます。with-accessors で変数名 A, B, C と対応するアクセスメソッドを指定します。これで変数名 A, B, C でスロット A, B, C にアクセスすることができます。
マクロ with-accessors を使うと、スロットをあたかもレキシカル変数のようにアクセスすることができますが、実際のアクセスには :accessor で指定したメソッドを使っていることに注意してください。指定された変数名のアクセスは :accessor のメソッドでスロットにアクセスするようにマクロ展開されます。
ところで、これらのマクロはとても便利ですが、参考文献『LISP 原書第 3 版 (1) (2)』には with-slots や with-accessors を使ったプログラムの例題が見当たりません。defclass の :accessor で指定したメソッドを使うのが CLOS のオーソドックスなプログラミングスタイルなのかもしれません。
次は、二分木の中から key を探索するメソッド tree-get を作ります。
リスト : データの探索
(defun node-get (node key key-of obj= obj<)
(loop
(with-slots (item left right) node
(cond ((null node) (return nil))
((funcall obj= key (funcall key-of item))
(return item))
((funcall obj< key (funcall key-of item))
(setf node left))
(t (setf node right))))))
(defmethod tree-get ((tree tree-set) key)
(node-get (tree-root tree)
key
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree)))
メソッド tree-get はスロット KEY, OBJ=, OBJ< から関数を取り出して node-get に渡します。node-get はこれらの関数を使って二分木から KEY と等しいデータを探します。NODE のスロットは with-slots を使うと簡単にアクセスすることができます。このとき、ITEM に関数 KEY-OF を適用することを忘れないでください。あとは、とくに難しいところないでしょう。
次は二分木にデータを挿入するメソッド tree-put を作ります。
リスト : データの挿入
(defun node-put (node key value key-of obj= obj<)
(labels ((put-sub (node)
(with-slots (item left right) node
(cond ((null node)
(make-instance 'node :item value))
((funcall obj= key (funcall key-of item))
(setf item value)
node)
((funcall obj< key (funcall key-of item))
(setf left (put-sub left))
node)
(t
(setf right (put-sub right))
node)))))
(put-sub node)))
(defmethod tree-put ((tree tree-set) value)
(setf (tree-root tree)
(node-put (tree-root tree)
(funcall (tree-key tree) value)
value
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree))))
実際の処理は node-put の局所関数 put-sub で行います。node-put を呼び出すとき、引数 VALUE からキーを取り出して渡すことに注意してください。キーの比較は tree-get と同じです。NODE が終端であれば、新しい節を make-instance で作成して返します。同じキーが見つかった場合、節の ITEM を VALUE に書き換えます。こうするとキー以外の値を更新することができるので便利です。
次はデータを削除するメソッド tree-delete を作ります。
リスト : データの削除
(defun node-delete (node key key-of obj= obj<)
(labels ((delete-sub (node)
(with-slots (item left right) node
(cond ((null node) (throw 'not-found nil))
((funcall obj= key (funcall key-of item))
(cond ((null left) right)
((null right) left)
(t
(setf item (node-search-min right)
right (node-delete-min right))
node)))
((funcall obj< key (funcall key-of item))
(setf left (delete-sub left))
node)
(t
(setf right (delete-sub right))
node)))))
(delete-sub node)))
(defmethod tree-delete ((tree tree-set) key)
(if (tree-root tree)
(catch 'not-found
(setf (tree-root tree)
(node-delete (tree-root tree)
key
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree)))
t)))
tree-delete はデータを削除したときは T を、KEY が見つからずにデータを削除できなかった場合は NIL を返します。実際の処理は node-delete の局所関数 delete-sub で行います。NODE が NIL の場合、KEY が見つからなかったので throw で大域脱出して NIL を返します。
キーの比較は tree-get, tree-put と同じです。木の途中にある節を削除する場合は、節の値を右部分木の最小値に置き換えてから、最小値を格納していた節を削除します。最小値を探す関数が node-search-min で、最小値を削除する関数が node-delete-min です。
次は二分木を巡回する高階関数 tree-for-each を作ります。次のリストを見てください。
リスト : 二分木の巡回
(defun node-for-each (node func)
(with-slots (item left right) node
(when node
(node-for-each left func)
(funcall func item)
(node-for-each right func))))
(defmethod tree-for-each ((tree tree-set) func)
(node-for-each (tree-root tree) func))
実際の処理は関数 node-for-each で行います。処理は簡単で、通りがけ順で二分木を巡回して、要素 ITEM に関数 FUNC を適用するだけです。
次は畳み込みを行う tree-fold-left と tree-fold-right を作ります。
リスト : 畳み込み
(defun node-fold-left (node func a)
(with-slots (item left right) node
(if (null node)
a
(node-fold-left right
func
(funcall func (node-fold-left left func a) item)))))
(defun node-fold-right (node func a)
(with-slots (item left right) node
(if (null node)
a
(node-fold-right left
func
(funcall func item (node-fold-right right func a))))))
(defmethod tree-fold-left ((tree tree-set) func init)
(node-fold-left (tree-root tree) func init))
(defmethod tree-fold-right ((tree tree-set) func init)
(node-fold-right (tree-root tree) func init))
実際の処理は関数 node-fold-left と node-fold-right で行います。node-fold-left は通りがけ順で畳み込みを行い、node-fold-right は node-fold-left の逆順 (右の子 -> 節 -> 左の子) で畳み込みを行います。したがって、node-fold-left は小さいデータから順番に、node-fold-right は大きなデータから順番に畳み込みが行われます。関数 func を呼び出すとき、node-fold-left と node-fold-right では引数の順番が逆になることに注意してください。
あとのメソッドは簡単なので説明は割愛いたします。詳細はプログラムリストをお読みください。
それでは簡単な実行例を示しましょう。なお、プログラムはパッケージ TREE_SET にまとめておき、カレントディレクトリにあるものとします。
* (require :tree_set "tree_set.lisp")
("TREE_SET")
* (use-package :tree_set)
T
* (setq xs nil)
NIL
* (dotimes (x 16) (push (random 1000) xs))
NIL
* xs
(16 351 282 196 549 99 299 954 993 5 991 300 889 750 758 860)
* (setq a (make-instance 'tree-set))
#<TREE-SET {1002347493}>
* (dolist (x xs) (tree-put a x))
NIL
* (tree-for-each a #'(lambda (x) (format t "~D " x)))
5 16 99 196 282 299 300 351 549 750 758 860 889 954 991 993
NIL
* (tree-emptyp a)
NIL
* (tree-length a)
16
(dolist (x xs) (tree-delete a x)
(tree-for-each a #'(lambda (x) (format t "~D " x))) (terpri))
5 99 196 282 299 300 351 549 750 758 860 889 954 991 993
5 99 196 282 299 300 549 750 758 860 889 954 991 993
5 99 196 299 300 549 750 758 860 889 954 991 993
5 99 299 300 549 750 758 860 889 954 991 993
5 99 299 300 750 758 860 889 954 991 993
5 299 300 750 758 860 889 954 991 993
5 300 750 758 860 889 954 991 993
5 300 750 758 860 889 991 993
5 300 750 758 860 889 991
300 750 758 860 889 991
300 750 758 860 889
750 758 860 889
750 758 860
758 860
860
NIL
* (tree-emptyp a)
T
* (tree-length a)
0
正常に動作していますね。次は :key を指定した例を示します。
* (setq b (make-instance 'tree-set :key #'car :obj= #'string= :obj< #'string<))
#<TREE-SET {1002641B03}>
* (dolist (x xs) (tree-put b (cons (princ-to-string x) x)))
NIL
* (tree-for-each b #'(lambda (x) (format t "~S~%" x)))
("16" . 16)
("196" . 196)
("282" . 282)
("299" . 299)
("300" . 300)
("351" . 351)
("5" . 5)
("549" . 549)
("750" . 750)
("758" . 758)
("860" . 860)
("889" . 889)
("954" . 954)
("99" . 99)
("991" . 991)
("993" . 993)
NIL
* (dolist (x (mapcar #'princ-to-string xs)) (format t "~S~%" (tree-get b x)))
("16" . 16)
("351" . 351)
("282" . 282)
("196" . 196)
("549" . 549)
("99" . 99)
("299" . 299)
("954" . 954)
("993" . 993)
("5" . 5)
("991" . 991)
("300" . 300)
("889" . 889)
("750" . 750)
("758" . 758)
("860" . 860)
NIL
* (tree-delete b "549")
T
* (tree-delete b "549")
NIL
* (tree-for-each b #'(lambda (x) (format t "~S~%" x)))
("16" . 16)
("196" . 196)
("282" . 282)
("299" . 299)
("300" . 300)
("351" . 351)
("5" . 5)
("750" . 750)
("758" . 758)
("860" . 860)
("889" . 889)
("954" . 954)
("99" . 99)
("991" . 991)
("993" . 993)
NIL
このように、:KEY を指定することでハッシュ表と同じような動作を行わせることもできます。ただし、今回のプログラムは単純な二分木なので、バランスが崩れると性能は大きく劣化してしまいます。もしも、実用的に使うのであれば、赤黒木 (2 色木) のような平衡木をプログラムしたほうがよいでしょう。
;;;
;;; tree_set.l : 二分探索木
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
;;;
(provide :tree_set)
(defpackage :tree_set (:use :cl))
(in-package :tree_set)
(export '(tree-set tree-get tree-put tree-delete tree-get-min tree-get-max
tree-delete-min tree-delete-max tree-for-each tree-emptyp
tree-fold-left tree-fold-right tree-copy tree-length))
(in-package "TREE_SET")
;;; メソッドの宣言
(defgeneric tree-get (tree key))
(defgeneric tree-put (tree value))
(defgeneric tree-delete (tree key))
(defgeneric tree-get-min (tree))
(defgeneric tree-get-max (tree))
(defgeneric tree-delete-min (tree))
(defgeneric tree-delete-max (tree))
(defgeneric tree-for-each (tree func))
(defgeneric tree-emptyp (tree))
(defgeneric tree-fold-left (tree func init))
(defgeneric tree-fold-right (tree func init))
(defgeneric tree-copy (tree))
(defgeneric tree-length (tree))
;;; 節の定義
(defclass node ()
((item :accessor node-item :initform nil :initarg :item)
(left :accessor node-left :initform nil :initarg :left)
(right :accessor node-right :initform nil :initarg :right)))
;;; 二分木の定義
(defclass tree-set ()
((root :accessor tree-root :initform nil :initarg :root)
(obj= :accessor tree-obj= :initform #'eql :initarg :obj=)
(obj< :accessor tree-obj< :initform #'< :initarg :obj<)
(key :accessor tree-key :initform #'identity :initarg :key)))
;;;
;;; 作業用関数
;;;
;;; 探索
(defun node-get (node key key-of obj= obj<)
(loop
(with-slots (item left right) node
(cond ((null node) (return nil))
((funcall obj= key (funcall key-of item))
(return item))
((funcall obj< key (funcall key-of item))
(setf node left))
(t (setf node right))))))
;;; 挿入
(defun node-put (node key value key-of obj= obj<)
(labels ((put-sub (node)
(with-slots (item left right) node
(cond ((null node)
(make-instance 'node :item value))
((funcall obj= key (funcall key-of item))
(setf item value)
node)
((funcall obj< key (funcall key-of item))
(setf left (put-sub left))
node)
(t
(setf right (put-sub right))
node)))))
(put-sub node)))
;;; 最小値を求める
(defun node-search-min (node)
(with-slots (item left) node
(if (null left)
item
(node-search-min left))))
;;; 最大値を求める
(defun node-search-max (node)
(with-slots (item right) node
(if (null right)
item
(node-search-max right))))
;;; 最小値を削除する
(defun node-delete-min (node)
(with-slots (left right) node
(cond ((null left) right)
(t
(setf left (node-delete-min left))
node))))
;;; 最大値を削除する
(defun node-delete-max (node)
(with-slots (left right) node
(cond ((null right) left)
(t
(setf right (node-delete-max right))
node))))
;;; 削除
(defun node-delete (node key key-of obj= obj<)
(labels ((delete-sub (node)
(with-slots (item left right) node
(cond ((null node) (throw 'not-found nil))
((funcall obj= key (funcall key-of item))
(cond ((null left) right)
((null right) left)
(t
(setf item (node-search-min right)
right (node-delete-min right))
node)))
((funcall obj< key (funcall key-of item))
(setf left (delete-sub left))
node)
(t
(setf right (delete-sub right))
node)))))
(delete-sub node)))
;;; 巡回
(defun node-for-each (node func)
(with-slots (item left right) node
(when node
(node-for-each left func)
(funcall func item)
(node-for-each right func))))
;;; 畳み込み
(defun node-fold-left (node func a)
(with-slots (item left right) node
(if (null node)
a
(node-fold-left right
func
(funcall func (node-fold-left left func a) item)))))
(defun node-fold-right (node func a)
(with-slots (item left right) node
(if (null node)
a
(node-fold-right left
func
(funcall func item (node-fold-right right func a))))))
;;; 木のコピー
(defun node-copy (node)
(with-slots (item left right) node
(if (null node)
nil
(make-instance 'node
:item item
:left (node-copy left)
:right (node-copy right)))))
;;;
;;; メソッドの定義
;;;
;;; 探索
(defmethod tree-get ((tree tree-set) key)
(node-get (tree-root tree)
key
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree)))
;;; 挿入
(defmethod tree-put ((tree tree-set) value)
(setf (tree-root tree)
(node-put (tree-root tree)
(funcall (tree-key tree) value)
value
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree))))
;;; 削除
(defmethod tree-delete ((tree tree-set) key)
(if (tree-root tree)
(catch 'not-found
(setf (tree-root tree)
(node-delete (tree-root tree)
key
(tree-key tree)
(tree-obj= tree)
(tree-obj< tree)))
t)))
;;; 最小値を求める
(defmethod tree-get-min ((tree tree-set))
(if (tree-root tree)
(node-search-min (tree-root tree))))
;;; 最大値を求める
(defmethod tree-get-max ((tree tree-set))
(if (tree-root tree)
(node-search-max (tree-root tree))))
;;; 最小値を削除
(defmethod tree-delete-min ((tree tree-set))
(with-slots (root) tree
(if root
(prog1
(node-search-min root)
(setf root (node-delete-min root))))))
;;; 最大値を削除
(defmethod tree-delete-max ((tree tree-set))
(with-slots (root) tree
(if root
(prog1
(node-search-max root)
(setf root (node-delete-max root))))))
;;; 巡回
(defmethod tree-for-each ((tree tree-set) func)
(node-for-each (tree-root tree) func))
;;; 空か
(defmethod tree-emptyp ((tree tree-set))
(null (tree-root tree)))
;;; 畳み込み
(defmethod tree-fold-left ((tree tree-set) func init)
(node-fold-left (tree-root tree) func init))
(defmethod tree-fold-right ((tree tree-set) func init)
(node-fold-right (tree-root tree) func init))
;;; コピー
(defmethod tree-copy ((tree tree-set))
(make-instance 'tree-set
:root (node-copy (tree-root tree))
:obj= (tree-obj= tree)
:obj< (tree-obj< tree)
:key (tree-key tree)))
;;; 要素数を求める
(defmethod tree-length ((tree tree-set))
(tree-fold-left tree #'(lambda (n x) (declare (ignore x)) (1+ n)) 0))