DAWG2(2): ソート済みファイルからのDAWG構築

前回はトライだったけど、今回はDAWGを構築。
Nをキーセットに含まれる文字の総数*1だとして、DAWGはトライと同様にO(N)で構築可能(多分間違っていないはず...)
ただし、子ノード(サブトライ)が共有可能かどうかの判定が入るので、実際には一桁程度遅くなる。※ 今回の実装では。あとGCの処理時間は考えないものとしての話。

DAWGの作り方

基本的な流れはトライの場合と同様。
ただし、各サブトライが確定した段階で、既に構築済みのものの中に共有可能(構造的に等価)なサブトライがないかどうかをチェックし、もしあればその(既存の)サブトライを流用する、という点が異なる。
共有可能かどうかの判定にはハッシュテーブルを用いるが、各サブトライのハッシュ値の計算や等価性のチェックは、ダイナミックプログラミング的なことを行うことでO(1)で実行可能。

;;;; ノード(サブトライ)の等価性チェックとハッシュ値計算のコード

;; ノードの構造体定義
;; 前回から少し変更している
;;  - 前回は子ノード群をlist型に格納して保持。(car children)の次の兄弟は、(cadr children)
;;    => 今回は、リンクリストを自前で実装。兄弟はsiblingスロットを辿ることで取得する
;;  - hashスロットを追加。一度計算したノードのハッシュ値をキャッシュしておく
(defstruct node
  (label     0 :type octet)
  (sibling nil :type (or null node))
  (child   nil :type (or null node))
  (hash     -1 :type fixnum))

;; 二つのノード(サブトライ)が等しいかどうかをチェックする
;; - 子ノードと兄弟ノードのチェックはeqチェックで行う
;;   -- もし二つの子(兄弟)ノードが等しいなら、既に共有されており、参照先は同じとなっているため。
(defun node= (node1 node2)
  (and (=  (node-label node1)   (node-label node2))     ; ラベル(バイト値)が等しい
       (eq (node-child node1)   (node-child node2))     ; 同じ子ノードを参照している
       (eq (node-sibling node1) (node-sibling node2)))) ; 同じ(次の)兄弟ノードを参照している

;; ハッシュ値計算
(defun sxhash-node (node)
  (if (null node)
      (sxhash nil)
    (with-slots (hash) node
      (when (= -1 hash)
        ;; ハッシュ値を計算してキャッシュ
        ;; 一つのノードにつき、この部分が実行されるのは一度だけ
        (setf hash (logxor (sxhash (node-label node))
                           (* (sxhash-node (node-child node)) 7)
                           (* (sxhash-node (node-sibling node)) 13))))
      hash)))

ソースコードの場所

ソースコードは末尾に掲載。
前回から(DAWG部分以外の)基本的なロジックには変化はないが、いろいろと整理したため、構成が結構(若干?)変わっている。
現状のものに対応するソースはgithubcl-dawgからも参照可能*2

計測

計測。
データは前回使ったWikipediaのタイトルに加えて、二千万個程度の文字四グラムも使用する。

# 適当なテキストデータから集めた文字四グラム
$ wc -l 4gram
21139008 4gram  

$ ls -lh 4gram
-rw-r--r-- 1 user user 251M 2010-08-23 23:28 4gram

$ ls -lh wiki.title.*
-rw-r--r-- 1 user user  52M 2010-10-15 23:38 wiki.title.250
-rw-r--r-- 1 user user  11M 2010-10-15 23:38 wiki.title.50
-rw-r--r-- 1 user user 103M 2010-10-15 23:37 wiki.title.500

$ head -10000000 4ngram | tail
シを露出
シを頂い
シを頂き
シを頂戴
シを食っ
シを食べ
シを飲み
シを飲ん
シを飼っ
シを飼料
;;;; sbcl-1.0.40
;; (require :dawg)

;; Wikipediaタイトル: 50万行
(let ((dawg))
  (time
   (setf dawg (dawg:build-from-file "wiki.title.50")))
  (dawg:node-count dawg))
Evaluation took:
  11.546 seconds of real time
  11.516720 seconds of total run time (10.960685 user, 0.556035 system)
  [ Run times consist of 5.248 seconds GC time, and 6.269 seconds non-GC time. ]
  99.75% CPU
  23,034,806,052 processor cycles
  333,611,112 bytes consed
--> 3226450  ; ノード数: 323万

;; Wikipediaタイトル: 250万行
(let ((dawg))
  (time
   (setf dawg (dawg:build-from-file "wiki.title.250")))
  (dawg:node-count dawg))
Evaluation took:
  45.157 seconds of real time
  44.906806 seconds of total run time (43.354709 user, 1.552097 system)
  [ Run times consist of 18.469 seconds GC time, and 26.438 seconds non-GC time. ]
  99.45% CPU
  90,096,322,491 processor cycles
  1,370,862,696 bytes consed
--> 10406702  ; ノード数: 1041万

;; Wikipediaタイトル: 500万行
;; - 前回(トライ)ではメモリが足りなくなったが、今回は無事終了
(let ((dawg))
  (time
   (setf dawg (dawg:build-from-file "wiki.title.500")))
  (dawg:node-count dawg))
Evaluation took:
  82.800 seconds of real time
  82.437152 seconds of total run time (80.297018 user, 2.140134 system)
  [ Run times consist of 37.622 seconds GC time, and 44.816 seconds non-GC time. ]
  99.56% CPU
  165,198,822,447 processor cycles
  1,900,704,328 bytes consed
--> 16180565  ; ノード数: 1618万

;; 四グラム: 2000万行
(let ((dawg))
  (time
   (setf dawg (dawg:build-from-file "4gram")))
  (dawg:node-count dawg))
Evaluation took:
  125.930 seconds of real time
  123.807738 seconds of total run time (120.575536 user, 3.232202 system)
  [ Run times consist of 55.635 seconds GC time, and 68.173 seconds non-GC time. ]
  98.31% CPU
  251,251,154,700 processor cycles
  2,613,241,344 bytes consed
--> 16660713  ; ノード数: 1666万

構築時間は、キー数に対してだいたい線形で、トライに比べると遅いが(自分的には)許容可能な範囲。
ノード数はWikipediaのタイトルの場合は2〜3分の1に減っている*3
四グラムの方は比較対象がないので何とも云えないが、データの性質上、末尾の重複も多いはずなので、Wikipediaのタイトルよりも圧縮率は高そう。

ソースコード

ハッシュ関数を独自実装するために、SBCL拡張機能を使っているので、SBCL依存。

;;;; ファイル名: package.lisp
;;;; 
;;;; パッケージ/スペシャル変数/型/定数 の定義
(defpackage dawg
  (:use :common-lisp)
  (:export build-from-file
           member?
           node-count))
(in-package :dawg)  ; ver 0.0.3

;; 宣言(declare)用のスペシャル変数
(defvar *fastest*   '(optimize (speed 3) (safety 0) (debug 0)))
(defvar *interface* '(optimize (speed 3) (safety 2) (debug 1)))
(defvar *muffle-warning* #+SBCL '(sb-ext:muffle-conditions sb-ext:compiler-note) 
                         #-SBCL '())

;; 型定義
(deftype octet () '(unsigned-byte 8))
(deftype octets () '(vector octet))
(deftype simple-octets () '(simple-array octet))
(deftype array-index () `(mod ,array-dimension-limit))

;; 何ビットまでがfixnumに収まるか
(defconstant +FIXNUM-LENGTH+ (integer-length most-positive-fixnum))
;;;; ファイル名: util.lisp
;;;;
;;;; 雑多なユーティリティ関数/マクロ
(in-package :dawg)

(defconstant +LINE-FEED+ #\Newline)
(defconstant +BUFFER-SIZE-LIMIT+ 102400) 

(declaim (inline string-to-octets each-file-line-bytes-impl fixnumize))

(defmacro package-alias (package &rest alias-list)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (rename-package ,package ,package ',alias-list)))
  
(defun string-to-octets (str)
  #+SBCL (sb-ext:string-to-octets str)
  #-SBCL (error "TODO: error message"))

(defun fixnumize (n)
  (ldb (byte +FIXNUM-LENGTH+ 0) n))

(defmacro each-file-line-bytes ((line-bytes start end filepath) &body body)
  `(each-file-line-bytes-impl 
    (lambda (,line-bytes ,start ,end)
      (declare (simple-octets ,line-bytes)
               ((mod #.array-dimension-limit) ,start ,end))
      ,@body)
    ,filepath))

(defun each-file-line-bytes-impl (fn filepath)
  (declare #.*muffle-warning*
           #.*fastest*
           (function fn))
  (with-open-file (in filepath :element-type 'octet)
    (let* ((buffer-size (min (or (file-length in) #1=+BUFFER-SIZE-LIMIT+) #1#))
           (buf (make-array buffer-size :element-type 'octet))
           (read-start 0)
           (lf (char-code +LINE-FEED+))
           (stack '()))
      (loop FOR read-len = (read-sequence buf in :start read-start)
        DO
        (loop WITH start = 0 
              FOR lf-pos =  (position lf buf :start read-start :end read-len)
                       THEN (position lf buf :start start      :end read-len)
              WHILE lf-pos
          DO
          (if (null stack)
              (funcall fn buf start lf-pos)
            (let ((bytes (apply #'concatenate 'octets 
                                (nreverse (cons (subseq buf start lf-pos) stack)))))
              (funcall fn bytes 0 (length bytes))
              (setf stack nil)))
          
          (setf start (1+ lf-pos))

          FINALLY
          (setf read-start 0)
          (if (zerop start) 
              (push (copy-seq buf) stack) 
            (progn (setf read-start (- read-len start))
                   (replace buf buf :end1 read-start :start2 start :end2 read-len))))
        
        (when (< read-len buffer-size)
          (return))))))
;;;; ファイル名: byte-stream.lisp
;;;;
;;;; バイト列をストリームとして扱うための構造体や関数定義
(defpackage dawg.byte-stream
  (:use :common-lisp)
  (:shadow :common-lisp read peek)
  (:export make
           read
           peek
           eat
           eos?))
(in-package :dawg.byte-stream)

(declaim (inline make read peek eat eos?))

(defstruct (byte-stream (:constructor make (bytes &key (start 0) (end (length bytes))
                                                  &aux (cur start))))
  (bytes #() :type dawg::simple-octets)
  (cur     0 :type dawg::array-index)
  (end     0 :type dawg::array-index))

(defun eat (in)
  (declare #.dawg::*fastest*)
  (incf (byte-stream-cur in))
  in)

(defun eos? (in)
  (declare #.dawg::*fastest*)
  (>= (byte-stream-cur in) (byte-stream-end in)))

(defun peek (in)
  (declare #.dawg::*fastest*)
  (if (eos? in)
      0
    (with-slots (bytes cur) in
      (aref bytes cur))))

(defun read (in)
  (declare #.dawg::*fastest*)
  (prog1 (peek in)
    (eat in)))
(in-package :dawg)
(package-alias :dawg.byte-stream :byte-stream)

(declaim (inline make-node))

(defstruct node
  (label     0 :type octet)
  (sibling nil :type (or null node))
  (child   nil :type (or null node))
  (hash     -1 :type fixnum))

;; ハッシュテーブル用: 二つのノードの等価性チェック
(defun node= (n1 n2)
  (declare #.*fastest*)
  (and (= (node-label n1) (node-label n2))
       (eq (node-child n1) (node-child n2))
       (eq (node-sibling n1) (node-sibling n2))))

;; ハッシュテーブル用: ノードのハッシュ値を計算する
(defun sxhash-node (node)
  (declare #.*fastest*)
  (if (null node)
      #.(sxhash nil)
    (with-slots (hash) (the node node)
      (when (= -1 hash)
        (setf hash (logxor (sxhash (node-label node))
                           (fixnumize (* (sxhash-node (node-child node)) 7))
                           (fixnumize (* (sxhash-node (node-sibling node)) 13)))))
      hash)))

;; nodeと構造的に同じ既存のノード(サブトライ)が存在するかどうかをチェックし、
;; 存在する場合は既存のノードを返す。
;; ※ 名前は適当
(defun memoize (node memo)
  (declare #.*fastest*)
  (if (null node)
      nil
    (or (gethash node memo)    ; 同じノードが存在する?
        (progn 
          ;; 上のチェックで該当するノードが見つからなかった場合:
          ;; まず子や兄弟に対して、共有チェックを行う
          (setf (node-child node) (memoize (node-child node) memo)
                (node-sibling node) (memoize (node-sibling node) memo))
          ;; 子や兄弟更新後に、もう一度チェック
          (gethash node memo))

        ;; ユニークなノードなので、新たに追加する
        (setf (gethash node memo) node))))

(defun push-child (in parent)
  (declare #.*fastest*) 
  (let ((new-node (make-node :label (byte-stream:peek in))))
    ;; parentの先頭の子ノードを新しいノードに入れ替える
    ;; 今まで先頭だった子ノードは、new-nodeの兄弟ノードに
    (setf (node-sibling new-node) (node-child parent)
          (node-child parent) new-node)
    (unless (byte-stream:eos? in)
      (push-child (byte-stream:eat in) new-node))))

(defun insert (in parent memo)
  (declare #.*fastest*)
  (let ((node (node-child parent)))
    (if (or (null node)
            (/= (byte-stream:peek in) (node-label node)))
        (progn 
          ;; 以下の一行以外は、前回と基本的に同様
          (setf (node-child parent) (memoize node memo))  ; 共有チェックを行う
          (push-child in parent))
      (insert (byte-stream:eat in) node memo)))) 

(sb-ext:define-hash-table-test node= sxhash-node) ; 独自のハッシュ関数を定義 (SBCL拡張機能)
(defun build-from-file (filepath)
  (declare #.*fastest*)
  (let* ((trie (make-node))
         (memo (make-hash-table :test #'node=))  ; 共有可能かどうかを判定するためのハッシュテーブル
         (cnt 0))
    (declare (fixnum cnt))
    (each-file-line-bytes (bytes beg end filepath)
      ;; 進捗表示: 外し忘れてた ...
      (when (zerop (mod (incf cnt) 5000))
        (print (list (hash-table-count memo) cnt)))
      (let ((in (byte-stream:make bytes :start beg :end end)))
        (declare (dynamic-extent in))
        (values (insert in trie memo))))
    (setf trie (memoize trie memo))   ; 共有チェックを行う
    trie))

(defun member?-impl (in node)
  (declare #.*fastest*)
  (cond ((null node) nil)
        ((= (byte-stream:peek in) (node-label node))
         (or (byte-stream:eos? in)
             (member?-impl (byte-stream:eat in) (node-child node))))
        ((< (byte-stream:peek in) (node-label node))
         (member?-impl in (node-sibling node)))))

(defun member? (key trie)
  (declare #.*fastest*)
  (let ((in (byte-stream:make (string-to-octets key))))
    (member?-impl in (node-child trie))))

(defun node-count-impl (node memo)
  (when (and node (not (gethash node memo)))
    (setf (gethash node memo) t)
    (node-count-impl (node-child node) memo)
    (node-count-impl (node-sibling node) memo)))

(defun node-count (trie)
  (let ((memo (make-hash-table :test #'eq)))
    (node-count-impl trie memo)
    (hash-table-count memo)))

(package-alias :dawg.byte-stream)

*1:今回の実装では文字列をバイト列として扱っているので、正確にはバイト数

*2:v0.0.3。前回に対応するソースはv0.0.1

*3:キーセットが変われば圧縮率も変わるので、あくまでも目安。一般にキー数が増えるほど圧縮率は高くなる(傾向があるはず)。