B木

B木をWikipediaの記事*1を参考にしてcommon lispで実装してみた。

実装

実装コード。
コメント抜きで140行程度。
オンメモリ。最適化なし。
※ 末尾に全部まとめた(+ コメント無し)のソースコード有り

;;;; パッケージ定義
(defpackage btree
  (:use :common-lisp)
  (:shadow :common-lisp get set remove)
  (:export make      ; B木作成
           get       ; 検索および挿入(setf (get ...))
           remove))  ; 削除
(in-package :btree)

;;;; 補助関数群
;; 常にnilを返す
(defun return-nil (&rest _)
  (declare (ignore _))
  nil)

;; 常に三番目の引数を返す
(defun identity3 (_1 _2 x)
  (declare (ignore _1 _2))
  x)

;;;; 構造体関連
;; 一つのノードが保持する子ノードの上限
;; これを-1したものがB木のオーダーとなる
(defconstant +NODE-CHILDREN-LIMIT+ 5)

;; ノード構造体
(defstruct node
  key                        ; キー
  value                      ; 値
  (children '() :type list)  ; 子ノードのリスト ※1

#|
※1: この先頭の要素は常に#(NODE :KEY :HEAD)というメタノードとなる。
　   ※ メタノードはchildren内のいかなる要素よりも小さい値を(仮想的に)有するノード
　   
　   childrenの要素(ノード)は常に以下の条件を満たしている。
　   a) ある要素の値(key)は、それより後方(cdr部)の兄弟要素の値よりも常に小さい(= ソートされている)
　   b) children内の要素の値は、親ノードの値よりも常に大きい
　   c) children内の要素の値は、親ノードの後方の兄弟の値よりも常に小さい
|#

;; B木のルートノード作成関数
(defun make-root-node ()
  ;; :keyに:rootや:headを与えているのは単なる目印であり、プログラム上意味はない
  (make-node :key :root :children (list (make-node :key :head))))

;; B木構造体
(defstruct btree
  (root-node t :type node)       ; ルートノード
  (test    #'< :type function))  ; キーの比較関数

;; B木作成関数
(defun make (&key (test #'<))
  (make-btree :root-node (make-root-node) :test test))

;;;; B木のノード探索関数
;;;; 以下は、検索/挿入/削除の各処理で利用されるテンプレート的な関数

;; 与えられたキーに対応するノードを検索する。
;;
;; この関数はノードの検索以外は何もせず、
;; 具体的な処理は、その検索の各段階で、引数で与えられた関数を呼び出すことで行う。
;;
;; on-success: 
;;  - ノードが見つかった場合に呼び出される関数
;;  - 関数: (lambda (親ノード 前方の兄弟ノードを先頭(car部)とするリスト 該当ノード) ...)
;;  - 各ノード の関係:   #親ノード#
;;                          |
;;                  #先頭ノード# -> ... -> #前方の兄弟ノード# -> #該当ノード# -> ...
;;
;; on-failure:
;;  - 該当ノードが存在しなかった場合に呼び出される関数
;;  - 関数: (lambda (親ノード keyよりも小さい最後の兄弟ノード) ...)
;;           ※ 第二引数は常に葉ノード (検索に失敗する地点が常に葉ノードなため)
;;
;; on-return:
;;  - 探索パス上の各ノードに対する処理からのリターン時に、その返り値を引数として呼び出される関数
;;  ※ 検索処理は、各ノードごとに再帰的に行われる
;;  - 関数: (lambda (親ノード 復帰元ノードをchildrenに有するノード 返り値) ...)
;;
;; on-root-return:
;;  - 検索処理の最後(ルートノードからの復帰時)に呼び出される関数
;;  - 関数: (lambda (返り値) ...)
(defun find-node-case (key btree &key on-success
                                      (on-failure #'return-nil)
                                      (on-return #'identity3)
                                      (on-root-return #'identity))
  (declare (function on-success on-failure on-return on-root-return))
  (with-slots (root-node test) btree
    (labels ((recur (parent)
               (loop FOR prev ON (node-children parent)  ; :headを除いた全ての子ノードに対して以下の処理を行う
                     FOR node = (second prev)            ; :headを飛ばすためにsecond関数で要素を取得する
                     WHILE (and node (funcall test (node-key node) key)) ; node.key < key の間はループ
                 FINALLY
                 ;; node.key >= key or (null node)
                 (return
                  (cond ((and node (not (funcall test key (node-key node))))  ; 該当ノード発見# !(node.key < key) and !(key < node.key) ==> node.key == key
                         (funcall on-success parent prev node))
                        ((node-children (car prev))                           ; 子ノードを探索 & 返り値に対して関数適用
                         (funcall on-return parent prev (recur (car prev))))
                        (t                                                    ; keyに対応するノードは存在しない
                         (funcall on-failure parent prev))))))) 
      (funcall on-root-return (recur root-node)))))  ; ルートノードから探索開始 & 返り値に対して関数適用

;;;; 検索
;; キーに紐付く値を検索する
(defun get (key btree)
  (find-node-case key btree
    :on-success
    (lambda (_1 _2 node)
      (declare (ignore _1 _2))
      (node-value node))))  ; 該当ノードが存在した場合に、その値を返すだけ

;;;; 挿入
;; 汎変数定義: set関数呼び出しに置換
(defsetf get (key btree) (new-value)
  `(set ,key ,new-value ,btree))

;; 要素を挿入する
(defun set (key value btree)
  (with-slots (root-node) btree
    (find-node-case key btree
      :on-success
      (lambda (_1 _2 node)
        (declare (ignore _1 _2))
        ;; 既にキーが存在する場合は、値を上書き
        (setf (node-value node) value) 
        nil)

      :on-failure
      (lambda (parent prev)
        ;; 新しいキーの場合は、ノード(要素)を作成してprevノードの後ろに挿入する
        (insert-node parent prev (make-node :key key :value value)))

      :on-return
      (lambda (parent prev split-node)
        (when split-node
          ;; 一つ下のレベルのノードで、子ノードの分割が行なわれた場合は、
          ;; 分割の基準となったノード(新しく親となったノード)の挿入処理を行う
          (insert-node parent prev split-node)))

      :on-root-return
      (lambda (split-node)
        ;; 一つ下のレベルのノードで、子ノードの分割が行なわれた場合の処理。
        ;; 基本的に:on-returnでの処理と同様だが、ルートノードの場合は、
        ;; 新たなルートノードを作成して、その下に(子ノードとして)
        ;; 旧ルートノードと分割基準ノードを配置する必要がある。
        (when split-node
          (let* ((new-root (make-root-node))
                 (new-root-child (car (node-children new-root))))
            (setf (node-children new-root-child) (node-children root-node))
            (insert-node new-root-child (node-children new-root) split-node)
            (setf root-node new-root))))))
  value)

;; ノードを新しく挿入する
;; node: 挿入されるノード
;; prev: nodeが挿入される一つ前の場所
;; parent: nodeの親となるノード
(defun insert-node (parent prev node)
  (push node (cdr prev))                ; 挿入: prev -> next ==> prev -> node -> next
  (node-split (node-children parent)))  ; 分割: 保持可能な子ノードの数には上限があるので、それを越えて場合は分割する

;; 子ノードの分割処理を行う。
;; 分割を行う必要がない場合は、nilを返す。
;; 分割が行なわれた場合は、基準となった(新たに親となった)ノードを返す。
(defun node-split (nodes)
  (when (> (length nodes) +NODE-CHILDREN-LIMIT+)  ; 分割を行う必要があるかどうか
    (let* ((mid (floor (length nodes) 2))
           (split-left-tail (nthcdr (1- mid) nodes))  ; 基準ノードより小さいノード
           (split-node      (nth mid nodes))          ; 基準ノード
           (split-right     (nthcdr (1+ mid) nodes))) ; 基準ノードより大きいノード

      ; 基準ノードよりも小さいノード群は、基準ノードの手前で区切る
      (setf (cdr split-left-tail) nil)
      
      ; 基準ノードよりも大きいノード群は、基準ノードの子ノードへと移動する
      (setf (node-children split-node)
            (cons (make-node :key :head :children (node-children split-node)) ; 基準ノードの既存の子ノードは、孫ノードへと移動する
                  split-right))

      ; 基準ノードを返す。このノードは、後で親ノードの兄弟ノードとして追加される必要がある
      split-node)))

;;;; 削除
;;;; ※ 木のバランスを維持することを考慮していないので、以下の削除を繰り返すと効率が悪くなる恐れがある

;; キーに対応する要素を削除する
(defun remove (key btree)
  (with-slots (root-node) btree
    (find-node-case key btree
      :on-success
      (lambda (parent prev node)
        ;; 対応するノードがある場合
        (if (node-children node)
            ;; 削除ノードが子孫ノードを有する場合は、
            ;; その子孫ノードの内で最小のもので置き換えることで、削除とする
            (setf (second prev) (replace-minnode-to-root node))
          (progn
            ;; 削除ノードが葉ノードの場合は、単に削除する
            (setf (cdr prev) (cddr prev))    ; prev -> node -> next ==> prev -> next

            ;; 削除によって無分岐(:headのみ)のノードとなった場合は、そのノードを取り去る
            ;; parent -> 削除によって:headのみとなった子ノード -> grandchild ==> paren -> grandchild
            (cut-nobranch-node! parent)))))))

;; 無分岐子ノードの除去
(defmacro cut-nobranch-node! (node)
  `(when (= 1 (length #1=(node-children ,node)))  ; 子ノードの数が1 == :headノードのみなら、
     (setf #1# (node-children (first #1#)))))     ; 孫ノードで置き換える

;; 削除ノードを、そのノードの子孫内の最小ノードで置き換えたものを返す
(defun replace-minnode-to-root (node)
  (let ((min (pickup-minnode node)))                ; 最小ノードを取り出す
    (setf (node-children min) (node-children node)) ; minノードの子ノードに、削除ノードの子ノードを設定する
    min))

;; 最小ノードを探して、取り出す。
;; 探索方法は以下の通り。
;; 1) :headノードが子ノードを有している間は、それを辿る
;; 2) 一番下の:headノードに辿り着いたら、その次の兄弟が最小ノード
(defun pickup-minnode (node)
  (let ((fst (first #1=(node-children node))))  ; :headノード
    (if (node-children fst)
        ;; :headノードの子ノードを探索
        (pickup-minnode fst)     
      ;; 最小ノード発見  
      (let ((min (second #1#)))    
        ;; 最小ノードを取り出す(削除する)
        (setf (cdr #1#) (cddr #1#)
              (node-children fst) (node-children min))
        ;; 無分岐ノードが発生した場合は、除去する
        (unless (eq parent root-node)
          (cut-nobranch-node! node))
        min))))

実行例

実行例。

;; 作成
(defvar *bt* (btree:make))
--> *BT*

*BT*
--> #S(BTREE::BTREE
       :ROOT-NODE #S(BTREE::NODE
                     :KEY :ROOT
                     :VALUE NIL
                     :CHILDREN (#S(BTREE::NODE
                                   :KEY :HEAD
                                   :VALUE NIL
                                   :CHILDREN NIL)))
       :TEST #<FUNCTION <>)

;; 挿入
(setf (btree:get 100 *bt*) :a)
--> :A

*bt*
--> #S(BTREE::BTREE
       :ROOT-NODE #S(BTREE::NODE
                     :KEY :ROOT
                     :VALUE NIL
                     :CHILDREN (#S(BTREE::NODE :KEY :HEAD :VALUE NIL :CHILDREN NIL)
                                #S(BTREE::NODE :KEY 100 :VALUE :A :CHILDREN NIL)))
       :TEST #<FUNCTION <>)

(loop FOR i FROM 50 BELOW 500 BY 100
      DO (setf (btree:get i *bt*) :b))
--> NIL

*bt*
--> #S(BTREE::BTREE
        :ROOT-NODE #S(BTREE::NODE
                 :KEY :ROOT
                 :VALUE NIL
                 :CHILDREN (#S(BTREE::NODE
                               :KEY :HEAD
                               :VALUE NIL
                               :CHILDREN (#S(BTREE::NODE
                                             :KEY :HEAD
                                             :VALUE NIL
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 50
                                             :VALUE :B
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 100
                                             :VALUE :A
                                             :CHILDREN NIL)))
                            #S(BTREE::NODE
                               :KEY 150
                               :VALUE :B
                               :CHILDREN (#S(BTREE::NODE
                                             :KEY :HEAD
                                             :VALUE NIL
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 250
                                             :VALUE :B
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 350
                                             :VALUE :B
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 450
                                             :VALUE :B
                                             :CHILDREN NIL)))))
        :TEST #<FUNCTION <>)

;; 検索
(btree:get 350 *bt*)
--> :B

(btree:get 300 *bt*)
--> NIL  ; 検索失敗: 値NILとの区別がつかない

;; 削除
(progn (btree:remove 50 *bt*)
       (btree:remove 150 *bt*)
       (btree:remove 250 *bt*)
       *bt*)
--> #S(BTREE::BTREE
         :ROOT-NODE #S(BTREE::NODE
                 :KEY :ROOT
                 :VALUE NIL
                 :CHILDREN (#S(BTREE::NODE
                               :KEY :HEAD
                               :VALUE NIL
                               :CHILDREN (#S(BTREE::NODE
                                             :KEY :HEAD
                                             :VALUE NIL
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 100
                                             :VALUE :A
                                             :CHILDREN NIL)))
                            #S(BTREE::NODE
                               :KEY 350
                               :VALUE :B
                               :CHILDREN (#S(BTREE::NODE
                                             :KEY :HEAD
                                             :VALUE NIL
                                             :CHILDREN NIL)
                                          #S(BTREE::NODE
                                             :KEY 450
                                             :VALUE :B
                                             :CHILDREN NIL)))))
         :TEST #<FUNCTION <>)

ソースコード

コメント無しの全ソースコード。
コピペ用。

(defpackage btree
  (:use :common-lisp)
  (:shadow :common-lisp get set remove)
  (:export make
           get
           remove))
(in-package :btree)

(defun return-nil (&rest _)
  (declare (ignore _))
  nil)

(defun identity3 (_1 _2 x)
  (declare (ignore _1 _2))
  x)

(defconstant +NODE-CHILDREN-LIMIT+ 5)
(defstruct node
  key
  value
  (children '() :type list))

(defun make-root-node ()
  (make-node :key :root :children (list (make-node :key :head))))

(defstruct btree
  (root-node t :type node)
  (test    #'< :type function))

(defun make (&key (test #'<))
  (make-btree :root-node (make-root-node) :test test))

(defun find-node-case (key btree &key on-success
                                      (on-failure #'return-nil)
                                      (on-return #'identity3)
                                      (on-root-return #'identity))
  (declare (function on-success on-failure on-return on-root-return))
  (with-slots (root-node test) btree
    (labels ((recur (parent)
               (loop FOR prev ON (node-children parent)
                     FOR node = (second prev)
                     WHILE (and node (funcall test (node-key node) key))
                 FINALLY
                 (return
                  (cond ((and node (not (funcall test key (node-key node))))
                         (funcall on-success parent prev node))
                        ((node-children (car prev))
                         (funcall on-return parent prev (recur (car prev))))
                        (t
                         (funcall on-failure parent prev)))))))
      (funcall on-root-return (recur root-node)))))


(defun get (key btree)
  (find-node-case key btree
    :on-success
    (lambda (_1 _2 node)
      (declare (ignore _1 _2))
      (node-value node))))

(defun node-split (nodes)
  (when (> (length nodes) +NODE-CHILDREN-LIMIT+)
    (let* ((mid (floor (length nodes) 2))
           (split-left-tail (nthcdr (1- mid) nodes))
           (split-node      (nth mid nodes))
           (split-right     (nthcdr (1+ mid) nodes)))
      (setf (cdr split-left-tail) nil)
      (setf (node-children split-node)
            (cons (make-node :key :head :children (node-children split-node))
                  split-right))
      split-node)))

(defun insert-node (parent prev node)
  (push node (cdr prev))
  (node-split (node-children parent)))

(defun set (key value btree)
  (with-slots (root-node) btree
    (find-node-case key btree
      :on-success
      (lambda (_1 _2 node)
        (declare (ignore _1 _2))
        (setf (node-value node) value)
        nil)

      :on-failure
      (lambda (parent prev)
        (insert-node parent prev (make-node :key key :value value)))

      :on-return
      (lambda (parent prev split-node)
        (when split-node
          (insert-node parent prev split-node)))

      :on-root-return
      (lambda (split-node)
        (when split-node
          (let* ((new-root (make-root-node))
                 (new-root-child (car (node-children new-root))))
            (setf (node-children new-root-child) (node-children root-node))
            (insert-node new-root-child (node-children new-root) split-node)
            (setf root-node new-root))))))
  value)

(defsetf get (key btree) (new-value)
  `(set ,key ,new-value ,btree))

(defmacro cut-nobranch-node! (node)
  `(when (= 1 (length #1=(node-children ,node)))
     (setf #1# (node-children (first #1#)))))

(defun pickup-minnode (node)
  (let ((fst (first #1=(node-children node))))
    (if (node-children fst)
        (pickup-minnode fst)
      (let ((min (second #1#)))
        (setf (cdr #1#) (cddr #1#)
              (node-children fst) (node-children min))
        (cut-nobranch-node! node)
        min))))

(defun replace-minnode-to-root (node)
  (let ((min (pickup-minnode node)))
    (setf (node-children min) (node-children node))
    min))

(defun remove (key btree)
  (with-slots (root-node) btree
    (find-node-case key btree
      :on-success
      (lambda (parent prev node)
        (if (node-children node)
            (setf (second prev) (replace-minnode-to-root node))
          (progn
            (setf (cdr prev) (cddr prev))
            (unless (eq parent root-node)
              (cut-nobranch-node! parent))))))))

*1:最終更新 2010年10月2日 (土) 05:32