Common Lisp Programming

●トライとパトリシア

今回は簡単な例題として、「トライ (trie) 」と「パトリシア (patricia) 」というデータ構造を作ってみましょう。どちらも木構造の一種で、根 (root) から葉 (leaf) までの経路が一つの文字列に対応します。トライやパトリシアは文字列を高速に探索することができますが、それだけではなく、共通の接頭辞 (common prefix) を持つ文字列、たとえば 'abc' で始まる文字列を簡単に見つけることができます。

●トライとは？

トライは文字列の集合を表すのに都合のよいデータ構造です。トライの語源は、「検索 (retrieval) 」という言葉の真ん中 (trie) に由来しています。トライは木構造の一種であり、根から葉までの経路がひとつの単語に対応します。次の図を見てください。

                      Ｔ
                    ／  ＼
                  ／      ＼
                ／          ＼
              ／              ＼
            Ａ                  Ｈ
          ／│＼              ／│＼
        ／  │  ＼          ／  │  ＼
      ／    │    ＼      ／    │    ＼
    Ｉ      Ｋ      Ｌ  Ａ      Ｅ      Ｉ
    │      │    ／│  │    ／│      │
    Ｌ      Ｅ  Ｋ  Ｌ  Ｔ  $6  Ｎ      Ｓ
    │      │  │  │  │      │      │
    $1      $2  $3  $4  $5      $7      $8

{ TAIL, TAKE, TALK, TALL, THAT, THE, THEN, THIS }  

        図 1 : 文字列の集合を表したトライ

上図は文字列の集合をトライで表現したものです。ここでは葉を $ で表しています。たとえば、葉 $6 までたどると、それは "THEN" という文字列を表しています。また、文字列 "THE" をトライから探す場合は、節を順番にたどっていって、葉 $6 に達した時点で "THE" を見つけることができます。もし、節 E の子に葉 $6 がなければ、THE はトライに存在しないことになります。

この例は文字列ですが、リスト (a b c d) やベクタ #(e f g h) などのデータも「トライ」で表すことができます。

●トライの実装方法

さて、トライの実現方法ですが、二分木と同様に子を格納するスロットを用意すれば簡単です。たとえば、英大文字と葉を示す $ がデータとすると、ひとつの節から最大 27 の子に分岐します。この場合、子を格納するスロットを child とし、$ を含めてサイズが 27 のベクタを child にセットすればいいでしょう。

ただし、データの種類が多くなるとベクタのサイズが大きくなるので、メモリを大量に消費してしまうのが欠点です。このため、トライを二分木のように構成する方法があります。次の図を見てください。

●─→・
│
↓
●─────────→●→NULL
│                    │
↓                    ↓
●─→●─→●→NULL  ●─→●─→●→NULL  
↓    ↓    ↓        ↓    ↓    ↓
・    ・    ・        ・    ・    ・

縦が親子関係を表し、横が兄弟関係を表す。

    図 2 : トライを二分木で表す

上図に示すように、縦に親子関係が伸びていき、横に兄弟の関係が伸びていくと考えてください。ようするに、二分木の右部分木が兄弟関係を表し、左部分木が親子の関係を表しているわけです。今回は Lisp でプログラムを作るので、子は Lisp らしくリストに格納して、それを child にセットすることにしましょう。つまり、二分木ではなく「多分木」になります。この場合、トライをたどるときにリストの中から子を探す処理が必要になりますが、プログラムは簡単になります。

次は、トライで公開するメソッドを表 1 に示します。

引数 tree はトライを表します。引数 seq には列型 (sequence) のデータを渡します。メソッド trie-match は seq の有無だけではなく、seq が見つからない場合でも途中まで一致したした長さを返すことにします。

●クラスの定義

それでは CLOS でプログラムを作りましょう。最初にクラスを定義します。

リスト 1 : トライの定義

; 節
(defclass node ()
  ((item  :accessor node-item  :initarg :item  :initform nil)
   (child :accessor node-child :initarg :child :initform nil)))

; トライ
(defclass trie ()
  ((root :accessor trie-root
         :initform (make-instance 'node)   ; ヘッダ
         :initarg  :root)
   (obj= :accessor trie-obj=
         :initform #'eql
         :initarg  :obj=)))

節はクラス node で表します。スロット item に列型データの要素をセットし、スロット child に子を格納したリストをセットします。トライのクラス名は trie とします。スロット root にはヘッダ用の節を格納します。ヘッダの item はダミーで nil に初期化します。そして、スロットobj= に 2 つの引数が等しいか調べる述語をセットします。デフォルトの述語は eql です。

次に、終端 (葉) を表す節を初期化します。

リスト 2 : 終端の初期化

;;; 終端
(defvar *term*)

; 終端の初期化
(defmethod initialize-instance ((obj trie) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (unless (boundp '*term*)
    (setf *term* (make-instance 'node))))

終端はグローバル変数 *term* にセットします。この処理はメソッド initialize-instance で行います。*term* が未束縛の場合にのみ、make-instance で node のインスタンスを生成して *term* にセットします。

●節の操作関数

次は節を操作する関数を作ります。

リスト 3 : 節の操作関数

; 子を探す
(defun trie-search-child (node x obj=)
  (find x (node-child node) :key #'node-item :test obj=))

; 子を追加する
(defun insert-child (node x)
  (let ((new-node (make-instance 'node :item x)))
    (push new-node (node-child node))
    new-node))

; 終端のチェック
(defun search-terminal (node)
  (consp (member *term* (node-child node))))

; 終端を追加する
(defun insert-terminal (node)
  (push *term* (node-child node))
  t)

; 終端を削除する
(defun delete-terminal (node)
  (setf (node-child node)
        (remove *term* (node-child node)))
  t)

trie-search-child は節 node の child から x を持つ子を探します。この処理は列関数 find を使うと簡単です。キーワード :key に #'node-item を指定して、節から比較するデータを取り出します。比較関数はキーワード :test で指定します。insert-child は節 node に x を持つ子を挿入します。make-instance で新しい節 new-node を生成し、それをスロット child の先頭に追加します。

search-terminal は node のスロット child に終端があるか調べます。真偽値 (t or nil) を返したいので、member の返り値を consp でチェックしています。insert-terminal は node の子に終端を挿入します。delete-terminal は node の子から終端を削除します。

●データの探索

次はデータを探索するメソッド trie-match を作ります。

リスト 4 : データの探索

(defun node-match (node seq obj=)
  (dotimes (x (length seq)
              (values (search-terminal node) x))
    (let ((p (trie-search-child node (elt seq x) obj=)))
      (if (null p)
          (return (values nil x))
        (setf node p)))))

(defmethod trie-match ((tree trie) (seq sequence))
  (node-match (trie-root tree) seq (trie-obj= tree)))

実際の処理は関数 node-match で行います。列関数 elt で引数 seq の要素をひとつずつ取り出して、トライをたどっていきます。elt を使っているので、seq が列型データ (sequence) であれば動作します。trie-search-child で seq の要素と等しい子を探して変数 p にセットします。見つからなければ return で (values nil x) を返します。x がマッチングした長さになります。等しい子を見つけたら p を node にセットして、次の要素と比較します。seq の要素をすべてチェックしたら、最後に終端オブジェクトがあるか確認します。

values は多値を返す関数です。values の説明は拙作のページ Common Lisp 入門 : 複数の値を返す方法（多値） をお読みください。

●データの挿入

次はデータを挿入するメソッド trie-put を作ります。

リスト 5 : データの挿入

(defun node-put (node seq obj=)
  (dolist (x (coerce seq 'list))
    (let ((p (trie-search-child node x obj=)))
      (setf node (if p p (insert-child node x)))))
  ; 終端を挿入
  (unless (search-terminal node)
    (insert-terminal node)))

(defmethod trie-put ((tree trie) seq)
  (node-put (trie-root tree) seq (trie-obj= tree)))

引数 seq を coerce でリストに変換します。そして、dolist で要素をひとつずつ取り出して、トライに追加していきます。取り出した要素 x を持つ子を trie-search-child で探して変数 p にセットします。p が真の場合、x と等しい子が見つかったので、pを node にセットして次の要素をチェックします。

見つからない場合は insert-child を呼び出して、要素 x を格納した節を node の child に追加します。そして、新しい節を node にセットします。最後に、search-terminal で終端をチェックします。もしも終端があれば、すでに seq はトライに含まれています。そうでなければ新しいデータなので、insert-terminal で終端を追加します。

●データの削除

次はデータを削除するメソッド trie-delete を作ります。

リスト 6 : データの削除

(defun node-delete (node seq obj=)
  (dolist (x (coerce seq 'list)
             (when (search-terminal node)
               (delete-terminal node)))
    (let ((p (trie-search-child node x obj=)))
      (if (null p)
          (return)
        (setf node p)))))

(defmethod trie-delete ((tree trie) seq)
  (node-delete (trie-root tree) seq (trie-obj= tree)))

データの削除は seq に対応する葉を削除するだけです。この場合、不要になった節 (node) が残ったままになるので、メモリを余分に消費する欠点があります。今回はこの対策を行っていません。ご注意ください。興味のある方は不要になった節を取り除くようにプログラムを改造してみてください。

トライをたどる処理は今までと同じです。トライをたどれない場合は、削除するデータがないので nil を返します。あとは、最後に search-terminal で終端をチェックし、データがあれば終端を delete-terminal で削除するだけです。

●巡回と畳み込み

次は巡回と畳み込みを行うメソッド trie-for-each と trie-fold を作ります。

リスト 7 : 巡回

(defun node-for-each (node func a)
  (if (eq *term* node)
      (funcall func (reverse a))
    (let ((a1 (cons (node-item node) a)))
      (dolist (x (node-child node))
        (node-for-each x func a1)))))

(defmethod trie-for-each ((tree trie) func)
  (dolist (x (node-child (trie-root tree)))
    (node-for-each x func nil)))

巡回の処理は関数 node-for-each で行います。引数 a は累積変数で、節の item をリストに格納したものです。node が終端の場合、reverse で a を反転して関数 func に渡します。そうでなければ、節の item を a に追加し、dolist で node の子を順番にたどります。

リスト 8 : 畳み込み

(defun node-fold (node func seq a)
  (if (eq *term* node)
      (funcall func (reverse seq) a)
    (let ((seq1 (cons (node-item node) seq)))
      (dolist (x (node-child node) a)
        (setf a (node-fold x func seq1 a))))))

(defmethod trie-fold ((tree trie) func a)
  (dolist (x (node-child (trie-root tree)) a)
    (setf a (node-fold x func nil a))))

畳み込みの処理は関数 node-fold で行います。引数 seq が節の item を格納するリストで、引数 a が畳み込み用の累積変数です。node が終端の場合、関数 func に (reverse seq) と a を渡して呼び出します。そうでなければ、節の item を seq に追加し、dolist で node の子を順番にたどります。このとき、node-fold の返り値で変数 a の値を更新することを忘れないでください。最後に a の値を返します。

●共通接頭辞を持つデータの探索

最後に共通接頭辞 (common prefix) を持つデータを求めるメソッド trie-common-prefix を作ります。

リスト 9 : 共通接頭辞を持つデータを求める

(defun node-common-prefix (node seq obj= a)
  (dolist (x (coerce seq 'list)
             (node-fold node #'cons (cdr a) nil))
    (push x a)
    (let ((p (trie-search-child node x obj=)))
      (if (null p)
          (return)
        (setf node p)))))

(defmethod trie-common-prefix ((tree trie) seq)
  (node-common-prefix (trie-root tree) seq (trie-obj= tree) nil))

実際の処理は関数 node-common-prefix で行います。引数 seq に接頭辞 (prefix) を渡します。引数 a には節の item を格納するリストをセットします。seq の探索が成功したら、node-fold を呼び出して、接頭辞から下の部分木にあるデータを求めるだけです。node-fold を呼び出すとき、最初の node の要素が重複するので、(cdr a) で先頭要素を取り除いています。

後のメソッドは簡単なので説明は割愛いたします。詳細は プログラムリスト をお読みください。

●実行例

それでは、簡単な実行例を示します。プログラムはパッケージ TRIE にまとめておき、compile-file でコンパイルしてカレントディレクトリにあるものとします。

> (require :trie "trie")     ; 修正 2010/09/19
;; Loading file ...
;; Loaded file ...
T
> (use-package :trie)        ; 修正 2010/09/19
T
> (setq *random-state* (make-random-state t))
#S(RANDOM-STATE
   #*1101100000001111000000000000000010011110001001110101000011110000)
> (setq a (make-instance 'trie))
#
> (dotimes (x 10) (trie-insert a (princ-to-string (random 5000000))))
NIL
> (trie-for-each a #'print)

(#\3 #\5 #\1 #\6 #\0 #\2 #\5)
(#\4 #\4 #\5 #\3 #\1 #\1 #\9)
(#\4 #\3 #\5 #\6 #\7 #\5 #\2)
(#\1 #\0 #\6 #\1 #\6 #\7 #\3)
(#\1 #\0 #\1 #\0 #\8 #\9 #\8)
(#\2 #\8 #\4 #\8 #\7 #\9)
(#\2 #\0 #\6 #\3 #\6 #\1 #\3)
(#\2 #\4 #\2 #\6 #\8 #\4 #\8)
(#\8 #\9 #\2 #\2 #\3 #\9)
(#\8 #\9 #\1 #\4 #\0 #\9)
NIL
> (trie-match a "284879")
T ;
6
> (trie-match a "206301")
NIL ;
4
> (trie-delete a "3516025")
T
> (trie-delete a "3516025")
NIL
> (trie-match a "3516025")
NIL ;
7
> (trie-common-prefix a "10")
((#\1 #\0 #\1 #\0 #\8 #\9 #\8) (#\1 #\0 #\6 #\1 #\6 #\7 #\3))

正常に動作していますね。もうひとつ簡単な例として suffix trie を作成してみましょう。サフィックス (suffix : 接尾辞) とは、文字列のある位置から末尾までの文字列のことです。たとえば、文字列 "abcd" のサフィックスは abcd, bcd, cd, d の 4 つになります。このサフィックスをトライで表したものが suffix trie で、文字列の照合などに用いられるデータ構造です。このほかに、サフィックスを辞書順に並べた配列 suffix array や、suffix trie を改良した suffix tree というデータ構造もあります。

suffix trie は、サフィックスを順番にトライに追加していくだけで作成できます。次のリストを見てください。

リスト 10 : suffix trie の作成

(require :trie "trie")       ; 修正 2010/09/19
(use-package :trie)          ; パッケージをキーワードで指定

(defun make-suffix-trie (data)
  (let ((x (make-instance 'trie)))
    (dotimes (n (length data))
      (trie-put x (subseq data n)))
    (trie-for-each x #'print)))

とても簡単な方法ですが、データが多くなると時間がかかるのが欠点です。データ数を N とすると、実行時間は N² に比例します。ご注意くださいませ。

それでは実行例を示します。

> (make-suffix-trie "aeadacab")

(#\b)
(#\c #\a #\b)
(#\d #\a #\c #\a #\b)
(#\e #\a #\d #\a #\c #\a #\b)
(#\a #\b)
(#\a #\c #\a #\b)
(#\a #\d #\a #\c #\a #\b)
(#\a #\e #\a #\d #\a #\c #\a #\b)
NIL
> (make-suffix-trie '(a e a d a c a b))

(B)
(C A B)
(D A C A B)
(E A D A C A B)
(A B)
(A C A B)
(A D A C A B)
(A E A D A C A B)
NIL

●パトリシアとは？

トライはとても便利なデータ構造ですが、節にはひとつの文字しか格納できないため、文字列の種類が多くなるとメモリを大量に消費してしまいます。このため、文字ではなく文字列を節に格納する方法があります。次の図を見てください。

                      Ｔ
                    ／  ＼
                  ／      ＼
                ／          ＼
              ／              ＼
            Ａ                  Ｈ
          ／│＼              ／│＼
        ／  │  ＼          ／  │  ＼
      ／    │    ＼      ／    │    ＼
   "IL"    "KE"     Ｌ "AT"     Ｅ     "IS"
    │      │    ／│  │    ／│      │
    $1      $2  Ｋ  Ｌ  $5  $6  Ｎ      $8
                │  │          │
                $3  $4          $7

{ TAIL, TAKE, TALK, TALL, THAT, THE, THEN, THIS }  

        図 3 : 文字列の集合を表したパトリシア

"TAIL" をトライで表すと T - A - I - L となりますが、I の子は L しかありませんね。この部分は "IL" とまとめることができます。つまり、節には部分文字列を格納するわけです。このように、トライにおいて分岐していない節をひとつにまとめたものを「パトリシア (Patricia Tree) 」と呼ぶことがあります。

パトリシアの場合、データの探索は節の部分文字列を比較していくだけなので、簡単に実現できます。ところが、データの挿入はちょっとだけ複雑になります。たとえば、パトリシアが "ab" - "cdef" という状態で、ここに文字列 "abcdgh" を挿入してみましょう。

挿入する文字列の先頭 2 文字と最初の節 "ab" は一致するので、次の節 "cdef" と残りの文字列 "cdgh" を比較します。"cd" は一致しますが、それ以降で不一致になりますね。この場合、節 "cdef" を不一致の位置で分割します。つまり、節 "cdef" を "cd" - "ef" と分割し、節 "cd" に新しい節 "gh" を追加するのです。このあと、終端オブジェクトを追加すれば、パトリシアに "abcdgh" を挿入することができます。

このように、パトリシアにデータを挿入する場合、節の分割が必要になるためプログラムは複雑になります。そのかわり、パトリシアはトライに比べて節の個数を少なくすることができるので、トライよりも少ないメモリで文字列の集合を表すことができます。

●パトリシアのクラス定義

それではプログラムを作りましょう。最初にパトリシアを表すクラスを定義します。

リスト 11 : クラス定義

(defclass patricia (trie) ())

クラス trie を継承してクラス patricia を定義します。新しく追加するスロットはありません。メソッドは trie-match, trie-put, trie-delete, trie-common-prefix をオーバーライドします。あとのメソッドはパトリシアでもそのまま利用することができます。

●部分列のマッチング

パトリシアをプログラムする場合、部分列のマッチングを判定する処理がポイントになりますが、Common Lisp には mismatch という便利な列関数があるので簡単です。

mismatch seq1 seq2

列型データ seq1 と seq2 を要素ごとに比較し、それらの長さが等しくてすべての要素が一致すれば nil を返します。そうでなければ、不一致になった seq1 の位置を返します。mismatch は拙作のページ Common Lisp 入門 : 列関数 で説明したキーワード :from-end, :test, :test-not, :key, :start1, :end1, :start2, :end2 を使用することができます。

簡単な例を示しましょう。

(mismatch "abc" "abc")   => nil
(mismatch "abcd" "abef") => 2
(mismatch "abc" "def")   => 0
(mismatch "abcabcabc" "abc" :start1 3 :end1 6) => nil
(mismatch "abcabcabc" "abd" :start1 3 :end1 6) => 5
(mismatch "abc"   "abcde") => 3
(mismatch "abcde" "abc")   => 3

●子の探索

mismatch を使うと、子を探す処理は簡単にプログラムできます。次のリストを見てください。

リスト 12 : データと部分的に一致する子を探す

(defun patricia-search-child (node seq si obj=)
  (dolist (x (node-child node))
    (unless (eq x *term*)
      (let ((n (mismatch (node-item x) seq :test obj= :start2 si)))
        (if (or (null n) (plusp n))
            ; 発見
            (return (values x n)))))))

関数 patricia-search-child は、node の child から子をひとつずつ取り出して、mismatch で data と比較します。引数 si が seq のマッチング開始位置を表します。mismatch の返り値 n が nil または 0 より大きければ、最低でもひとつの要素がマッチングしているので、values で node と n を返します。mismatch の返り値は第 1 引数で不一致になった位置を表していることに注意してください。マッチングする要素が見つからない場合は nil を返します。

●最長一致の探索

次はパトリシアをたどる関数 node-longest-match を作ります。

リスト 13 : node から最長一致する節を求める

(defun node-longest-match (node seq obj=)
  (let ((si 0))
    (loop
      (multiple-value-bind (next n)
          (patricia-search-child node seq si obj=)
        (cond ((null next)
               ; 見つからない : node (si) まで一致
               (return (values node si 0)))
              ((null n)
               ; seq と一致
               (return (values next (+ si (length (node-item next))) 0)))
              ((< n (length (node-item next)))
               ; next の途中まで一致
               (return (values next (+ si n) n)))
              (t; next と一致
               (setf node next)
               (incf si n)))))))

関数 node-longest-match はパトリシアをたどって、引数 seq と最も長く一致する位置を求めます。node-longest-match は、最後に一致した節 (node)、seq と一致した長さ (match)、節の item と一致した長さ (sub-match) を返します。節の item と全て一致した場合、sub-match の値は 0 とします。このメソッドはパトリシアを操作するメソッドから呼び出されます。

最初に seq の照合開始位置を表す変数 si を 0 に初期化します。次に、patricia-search-child を呼び出して、その返り値を変数 next と n で受け取ります。next が偽の場合、子は見つからなかったので照合は失敗です。node と si まではマッチしているので、(values node si 0) を返します。

n が偽の場合は、節 next の item で seq と照合が成功しました。next と seq の長さと 0 を返します。seq の長さは (+ si (length (node-item next))) で求めることができます。n が next の item よりも短い場合、節 next の途中で不一致になりました。next と (+ si n) と n を返します。あとは next の item と一致した場合です。si に n を加算して、次の子と照合します。

●データの探索

関数 node-longest-match を作れば、データの探索は簡単です。次のリストを見てください。

リスト 14 : データの探索

; データの探索
(defmethod trie-match ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (cond ((and (zerop sub-match)
                (= (length seq) match))
           ; 終端のチェック
           (values (search-terminal node) match))
          (t
           (values nil match)))))

node-longest-match を呼び出して、返り値を変数 node, match, sub-match で受け取ります。sub-match が 0 で、かつ match が seq と同じ長さであれば終端をチェックします。終端が見つかれば探索成功となります。それ以外の場合は節の途中でマッチングが終わっているので探索は失敗となります。

●データの挿入

次はデータを挿入するメソッド trie-put を作ります。

リスト 15 : データの挿入

(defmethod trie-put ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (cond ((zerop sub-match)
           (if (= (length seq) match)
               ; 終端のチェック
               (unless (search-terminal node)
                 (insert-terminal node))
             ; node に新しい節を追加する
             (insert-terminal (insert-child node (subseq seq match)))))
          (t
           ; node を分割して新しい節を追加する
           (let ((new-node (make-instance 'node :item (subseq (node-item node) sub-match))))
             (setf (node-item node) (subseq (node-item node) 0 sub-match))
             (setf (node-child new-node) (node-child node))
             (setf (node-child node) (list new-node))
             (insert-terminal (if (= (length seq) match)
                                  node
                                (insert-child node (subseq seq match)))))))))

node-longest-match を呼び出すところはデータの探索と同じです。sub-match が 0 の場合、node の子に終端または新しい節を追加します。match が seq の長さと同じ場合は、node に終端を追加するだけです。そうでなければ、insert-child で node の子に新しい節を追加して、その節に終端を追加します。

sub-match が 0 でない場合、node を sub-match の位置で二分割します。このとき、新しい節 new-node に sub-match から後ろのデータを格納します。node の item は先頭から sub-match - 1 までのデータに更新します。そして、node の child を new-node の child にセットして、node の child を (list new-node) に更新します。これで node と new-node を接続することができます。

あとは、終端を挿入するだけです。match が seq の長さと同じならば、node の子に終端を挿入します。そうでなければ、seq にはまだデータが残っているので、node の子に新しいデータ (subseq seq match) を挿入し、新しい節の子に終端を挿入します。

●データの削除

次はデータを削除するメソッド trie-delete を作ります。

リスト 16 : データの削除

(defmethod trie-delete ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (when (and (zerop sub-match)
               (= (length seq) match)
               (search-terminal node))
      (delete-terminal node))))

データの削除は簡単です。node-longest-match を呼び出して、sub-match が 0 で、match が seq の長さと等しく、node の子に終端がある場合は、削除するデータが存在します。delete-terminal で終端を取り除くだけです。

●共通接頭辞を持つデータの探索

最後に共通接頭辞を持つデータを求めるメソッド trie-common-prefix を作ります。

リスト 17 : 共通接頭辞を持つデータを求める

(defmethod trie-common-prefix ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (when (= (length seq) match)
      (let ((a nil)
            (seq1 (if (zerop sub-match)
                      (list seq)
                    (list (subseq (node-item node) sub-match) seq))))
        (dolist (x (node-child node) a)
          (setf a (node-fold x #'cons seq1 a)))))))

node-longest-match を呼び出して、match が seq の長さと同じであれば、接頭辞が seq と同じデータがパトリシア内に存在します。このとき、sub-match が 0 ならば、node の item は最後まで seq と一致しています。seq1 に (list seq) をセットします。sub-match が 0 でない場合、item の途中まで一致しています。item の sub-match 以降のデータを取り出して、seq といっしょにリストに格納して seq1 にセットします。あとは node-fold を呼び出すだけです。

●実行例（その２）

それでは、実際に試してみましょう。

> (require :trie "trie")          ; 修正 2010/09/19
;; Loading file ...
;; Loaded file 
T
> (use-package :trie)             ; 修正 2010/09/19
T
> (setq *random-state* (make-random-state t))
#S(RANDOM-STATE
   #*1001010000010011000000000000000001010101000011000011000111100111)
> (setq a (make-instance 'patricia))
#<PATRICIA #x1026D6A1>
> (dotimes (x 10) (trie-put a (princ-to-string (random 5000000))))
NIL
> (trie-for-each a #'print)

("2613956")
("10" "03246")
("10" "14114")
("3" "579553")
("3" "078861")
("3" "730594")
("4" "033461")
("4" "288901")
("4" "16246")
("911989")
NIL
> (trie-match a "1003246")
T ;
7
> (trie-match a "100")
NIL ;
3
> (trie-delete a "911989")
T
> (trie-delete a "911989")
NIL
> (trie-match a "911989")
NIL ;
6
> (trie-common-prefix a "10")
(("10" "14114") ("10" "03246"))
> (trie-common-prefix a "4")
(("4" "16246") ("4" "288901") ("4" "033461"))

正常に動作していますね。もうひとつ簡単な実行例として suffix tree を作ってみましょう。suffix tree は suffix trie の改良したもので、サフィックスを順番にパトリシアに追加していくだけで作成できます。次のリストを見てください。

リスト 18 : suffix tree の作成

(defun make-suffix-tree (data)
  (let ((x (make-instance 'patricia)))
    (dotimes (n (length data))
      (trie-put x (subseq data n)))
    (trie-for-each x #'print)))

とても簡単な方法ですが、データが多くなると時間がかかるのが欠点です。データ数を N とすると、実行時間は N² に比例します。ご注意くださいませ。

それでは実行例を示します。

> (make-suffix-tree "aeadacab")

("b")
("cab")
("dacab")
("eadacab")
("a" "b")
("a" "cab")
("a" "dacab")
("a" "eadacab")
NIL
> (make-suffix-tree '(a e a d a c a b))

((B))
((C A B))
((D A C A B))
((E A D A C A B))
((A) (B))
((A) (C A B))
((A) (D A C A B))
((A) (E A D A C A B))
NIL

suffix trie を構成する場合、データ数を N とすると N² に比例するメモリが必要になりますが、suffix tree は N に比例するメモリで構成することができます。また、データ数 N に比例する時間で suffix tree を構築するアルゴリズムもあります。suffix tree は suffix trie よりも省メモリなので、いろいろな文字列処理の高速化に利用することができます。最近は suffix tree よりも省メモリのデータ構造である suffix array も注目されています。

●プログラムリスト

;
; trie.l : トライ
;
;          Copyright (C) 2010 Makoto Hiroi
;
;
; 修正 2010/09/19
;
;   1. パッケージ名を "TRIE" に変更
;   2. defpackage に (:use "COMMON-LISP") を追加
;   3. :export の指定を文字列に変更
;
(provide "TRIE")
(defpackage "TRIE"
  (:use "COMMON-LISP")
  (:export "TRIE" "PATRICIA"
           "TRIE-PUT" "TRIE-MATCH" "TRIE-DELETE"
           "TRIE-FOLD" "TRIE-FOR-EACH" "TRIE-LENGTH"
           "TRIE-CLEAR" "TRIE-COMMON-preFIX"
   ))

(in-package "TRIE")

; メソッドの宣言
(defgeneric trie-match (trie seq))
(defgeneric trie-put (trie seq))
(defgeneric trie-delete (trie seq))
(defgeneric trie-for-each (trie func))
(defgeneric trie-fold (trie func a))
(defgeneric trie-common-prefix (trie seq))
(defgeneric trie-length (trie))
(defgeneric trie-clear (trie))

;;; 終端
(defvar *term*)

;;; クラス定義

; 節
(defclass node ()
  ((item  :accessor node-item  :initarg :item  :initform nil)
   (child :accessor node-child :initarg :child :initform nil)))

; トライ
(defclass trie ()
  ((root :accessor trie-root
         :initform (make-instance 'node)   ; ヘッダ
         :initarg  :root)
   (obj= :accessor trie-obj=
         :initform #'eql
         :initarg  :obj=)))

; 終端の初期化
(defmethod initialize-instance ((obj trie) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (unless (boundp '*term*)
    (setf *term* (make-instance 'node))))


;;; 節の操作関数

; 子を探す
(defun trie-search-child (node x obj=)
  (find x (node-child node) :key #'node-item :test obj=))

; 子を追加する
(defun insert-child (node x)
  (let ((new-node (make-instance 'node :item x)))
    (push new-node (node-child node))
    new-node))

; 終端のチェック
(defun search-terminal (node)
  (consp (member *term* (node-child node))))

; 終端を追加する
(defun insert-terminal (node)
  (push *term* (node-child node))
  t)

; 終端を削除する
(defun delete-terminal (node)
  (setf (node-child node)
        (remove *term* (node-child node)))
  t)

;;; メソッドの定義

; 探索
(defun node-match (node seq obj=)
  (dotimes (x (length seq)
              (values (search-terminal node) x))
    (let ((p (trie-search-child node (elt seq x) obj=)))
      (if (null p)
          (return (values nil x))
        (setf node p)))))

(defmethod trie-match ((tree trie) (seq sequence))
  (node-match (trie-root tree) seq (trie-obj= tree)))

; 挿入
(defun node-put (node seq obj=)
  (dolist (x (coerce seq 'list))
    (let ((p (trie-search-child node x obj=)))
      (setf node (if p p (insert-child node x)))))
  ; 終端を挿入
  (unless (search-terminal node)
    (insert-terminal node)))

(defmethod trie-put ((tree trie) seq)
  (node-put (trie-root tree) seq (trie-obj= tree)))

; 削除
(defun node-delete (node seq obj=)
  (dolist (x (coerce seq 'list)
             (when (search-terminal node)
               (delete-terminal node)))
    (let ((p (trie-search-child node x obj=)))
      (if (null p)
          (return)
        (setf node p)))))

(defmethod trie-delete ((tree trie) seq)
  (node-delete (trie-root tree) seq (trie-obj= tree)))

; 巡回
(defun node-for-each (node func a)
  (if (eq *term* node)
      (funcall func (reverse a))
    (let ((a1 (cons (node-item node) a)))
      (dolist (x (node-child node))
        (node-for-each x func a1)))))

(defmethod trie-for-each ((tree trie) func)
  (dolist (x (node-child (trie-root tree)))
    (node-for-each x func nil)))

; 畳み込み
(defun node-fold (node func seq a)
  (if (eq *term* node)
      (funcall func (reverse seq) a)
    (let ((seq1 (cons (node-item node) seq)))
      (dolist (x (node-child node) a)
        (setf a (node-fold x func seq1 a))))))

(defmethod trie-fold ((tree trie) func a)
  (dolist (x (node-child (trie-root tree)) a)
    (setf a (node-fold x func nil a))))


; 共通接頭辞を持つデータを求める
(defun node-common-prefix (node seq obj= a)
  (dolist (x (coerce seq 'list)
             (node-fold node #'cons (cdr a) nil))
    (push x a)
    (let ((p (trie-search-child node x obj=)))
      (if (null p)
          (return)
        (setf node p)))))

(defmethod trie-common-prefix ((tree trie) seq)
  (node-common-prefix (trie-root tree) seq (trie-obj= tree) nil))

; 要素数を求める
(defmethod trie-length ((tree trie))
  (trie-fold tree #'(lambda (x a) (declare (ignore x)) (1+ a)) 0))

; クリア
(defmethod trie-clear ((tree trie))
  (setf (node-child (trie-root tree)) nil))


;;;
;;; patricia tree
;;;

;;; クラス定義
(defclass patricia (trie) ())

; データを含む子を探す
(defun patricia-search-child (node seq si obj=)
  (dolist (x (node-child node))
    (unless (eq x *term*)
      (let ((n (mismatch (node-item x) seq :test obj= :start2 si)))
        (if (or (null n) (plusp n))
            ; 発見
            (return (values x n)))))))

; node から最長一致する節を求める
(defun node-longest-match (node seq obj=)
  (let ((si 0))
    (loop
      (multiple-value-bind (next n)
          (patricia-search-child node seq si obj=)
        (cond ((null next)
               ; 見つからない : node (si) まで一致
               (return (values node si 0)))
              ((null n)
               ; seq と一致
               (return (values next (+ si (length (node-item next))) 0)))
              ((< n (length (node-item next)))
               ; next の途中まで一致
               (return (values next (+ si n) n)))
              (t; next と一致
               (setf node next)
               (incf si n)))))))


;
; データの探索
;
(defmethod trie-match ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (cond ((and (zerop sub-match)
                (= (length seq) match))
           ; 終端のチェック
           (values (search-terminal node) match))
          (t
           (values nil match)))))

;
; データの挿入
;
(defmethod trie-put ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (cond ((zerop sub-match)
           (if (= (length seq) match)
               ; 終端のチェック
               (unless (search-terminal node)
                 (insert-terminal node))
             ; node に新しい節を追加する
             (insert-terminal (insert-child node (subseq seq match)))))
          (t
           ; node を分割して新しい節を追加する
           (let ((new-node (make-instance 'node :item (subseq (node-item node) sub-match))))
             (setf (node-item node) (subseq (node-item node) 0 sub-match))
             (setf (node-child new-node) (node-child node))
             (setf (node-child node) (list new-node))
             (insert-terminal (if (= (length seq) match)
                                  node
                                (insert-child node (subseq seq match)))))))))

; 削除
(defmethod trie-delete ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (when (and (zerop sub-match)
               (= (length seq) match)
               (search-terminal node))
      (delete-terminal node))))

; 共通接頭辞を持つデータを求める
(defmethod trie-common-prefix ((tree patricia) (seq sequence))
  (multiple-value-bind (node match sub-match)
      (node-longest-match (trie-root tree) seq (trie-obj= tree))
    (when (= (length seq) match)
      (let ((a nil)
            (seq1 (if (zerop sub-match)
                      (list seq)
                    (list (subseq (node-item node) sub-match) seq))))
        (dolist (x (node-child node) a)
          (setf a (node-fold x #'cons seq1 a)))))))