ソート済みファイルからO(1)のメモリ使用量でDoubleArrayを構築する方法 #前半

格納するキー数に大してO(1)のメモリ使用量で、DoubleArrayを構築する方法を思いついたので、その実装メモ。
今回はその前半。
いきなりDoubleArrayの実装を行うとやや複雑となるので、まずはより単純な通常のトライ(オンメモリ)の実装から始める。

基本的な考え方

例えば、以下のようなキーセットがあるとする。

東京カネカ食品販売
東京カルテット
東京ガスエネルギー
東京ガス都市開発
東京クラウン
東西

これらを上から挿入してトライを構築していく過程は、以下の図のようになる。

この図の内の白色、オレンジ、灰色のノードは、それぞれ「最後に挿入されたキーに対応するノード」、「一つ前に挿入されたキーに対応するノード」、「それ以前に挿入されたキーに対応するノード」を表す。※ 左の定義で、白色とオレンジの領域が重なる場合は、白色が優先される。白色と灰色、オレンジと灰色も同様。
キーセットが既にソートされているという前提上、一度オレンジ・灰色となったノードが再び白色になることはない。
つまり、これら(オレンジ or 灰色)のノード(サブトライ)の構造はこの時点で確定しており、以降のキー挿入で変化することはないので、別にオンメモリで保持しておく必要もない。
この確定した部分を順次(DoubleArray形式に変換して)ファイルに書き出していけば、メモリ上に保持するのは白色のノードだけで良いことになる。
で、白色のノードはキーセットサイズに依存しない(個々のキーの長さにのみ依存する)ので、キーセットサイズに対してO(1)のメモリ使用量でDoubleArrayが構築できることになる。

オンメモリトライの実装

DoubleArrayの実装の前に、まずは簡単なリストを使ったトライの実装から入る。
まずはパッケージ定義など。

(defpackage trie
  (:use common-lisp)
  (:export build
           member?))
(in-package :trie)

;; octet-stream: SBCL等のユニコード文字列をバイトストリームとして扱うためのパッケージ
;; - http://d.hatena.ne.jp/sile/20110807/1312720282
(rename-package :octet-stream :octet-stream '(:stream))

次はノード用の構造体を用意(ついでに定数もここで定義しておく)。

(defstruct node
  (label      0 :type (unsigned-byte 8))  ; ノードのラベル
  (children '() :type list))              ; 子ノードのリスト ※ 実装上の都合でラベルの降順に並んでいる

(defmethod print-object ((o node) stream)
  (print-unreadable-object (o stream :type t :identity t)))

(defconstant +EOS_LABEL+ #x00)  ; 文字列の終端を表すラベル値  ※ 0を特別扱いしている関係上、キーにヌル文字を含むことはできない

ソート済みファイルからトライを構築する関数。

(defun build (filepath)
  (with-open-file (in filepath)
    (loop WITH trie = (make-node)
          FOR line = (read-line in nil nil)
          WHILE line
      DO
      (insert (stream:make line) trie)
      FINALLY
      (change-active-node trie)
      (return trie))))

(defun insert (in parent &aux (node (car (node-children parent))))
  (if (null node)
      (insert-new-nodes in parent)           ; 新規ノードを挿入
    (if (/= (stream:peek in) (node-label node))
        (progn (change-active-node parent)   ; 白色 => オレンジ、になったノードを処理する
               (insert-new-nodes in parent)) ; 新規ノードを挿入
      (insert (stream:eat in) node))))  ; 既存ノードを共有

;; 文字列終端に達するまでノードを追加する
(defun insert-new-nodes (in parent)
  (if (stream:eos? in)
      (push (make-node :label +EOS_LABEL+) (node-children parent))
    (let ((new-node (make-node :label (stream:read in))))
      (push new-node (node-children parent))
      (insert-new-nodes in new-node))))

(defun change-active-node (parent)
  (let ((fixed-node (car (node-children parent))))
    (declare (ignore fixed-node))))  ; 今回は何もしない

最後は検索関数。

(defun member? (key trie)
  (labels ((eos-node? (node)
             (let ((last-child (car (last (node-children node)))))
               (= (node-label last-child) +EOS_LABEL+)))
           (recur (in node)
             (if (stream:eos? in)
                 (eos-node? node)
               (let ((child (find (stream:read in) (node-children node) :key #'node-label)))
                 (when child
                   (recur in child))))))
    (recur (stream:make key) trie)))

以上でオンメモリトライの実装は終了。
次回は、これをベースにしてDoubleArrayを実装する。

ソースコード全体

(defpackage trie
  (:use common-lisp)
  (:export build
           member?))
(in-package :trie)

(rename-package :octet-stream :octet-stream '(:stream))

;;;;;;;;;;;;;
;;; defstruct
(defstruct node
  (label      0 :type (unsigned-byte 8))
  (children '() :type list))

(defmethod print-object ((o node) stream)
  (print-unreadable-object (o stream :type t :identity t)))

(defconstant +EOS_LABEL+ #x00)

;;;;;;;;;
;;; build
(defun build (filepath)
  (with-open-file (in filepath)
    (loop WITH trie = (make-node)
          FOR line = (read-line in nil nil)
          WHILE line
      DO
      (insert (stream:make line) trie)
      FINALLY
      (change-active-node trie)
      (return trie))))

(defun insert (in parent &aux (node (car (node-children parent))))
  (if (null node)
      (insert-new-nodes in parent)
    (if (/= (stream:peek in) (node-label node))
        (progn (change-active-node parent)
               (insert-new-nodes in parent))
      (insert (stream:eat in) node))))

(defun insert-new-nodes (in parent)
  (if (stream:eos? in)
      (push (make-node :label +EOS_LABEL+) (node-children parent))
    (let ((new-node (make-node :label (stream:read in))))
      (push new-node (node-children parent))
      (insert-new-nodes in new-node))))

(defun change-active-node (parent)
  (let ((fixed-node (car (node-children parent))))
    (declare (ignore fixed-node))))

;;;;;;;;;;;
;;; member?
(defun member? (key trie)
  (labels ((eos-node? (node)
             (let ((last-child (car (last (node-children node)))))
               (= (node-label last-child) +EOS_LABEL+)))
           (recur (in node)
             (if (stream:eos? in)
                 (eos-node? node)
               (let ((child (find (stream:read in) (node-children node) :key #'node-label)))
                 (when child
                   (recur in child))))))
    (recur (stream:make key) trie)))