読者です 読者をやめる 読者になる 読者になる

ハッシュトライ

common lisp utility algorithm

最近ちょくちょくトライを使いたくなることがあるので、少しまとまったハッシュトライの実装を書いておく。
位置付け的には開発用。使用頻度が高いようなら、もう少しちゃんとしたものに書き直す。
※ 2010/01/03: print-objectメソッド追加、common-prefix-search関数追加、hash-trieから冗長なtestフィールドを除外

ソースコード

依存: common-utils or nlet,a.when.a.if

(defpackage :hash-trie
  (:use :common-lisp :common-utils) ; nlet, a.if, a.whenは、common-utilsパッケージ内で定義されている
  (:export :make-trie
           :get-node :get-node1
           :get-elem :get-elem1
           :rem-elem :rem-elem1
           :common-prefix-search
           :map-trie
           :to-list
           :element-count
           :hash-trie))
(in-package :hash-trie)

(defstruct (hash-trie (:constructor 
                       make-trie (&key (test 'eql) 
                                  &aux (hash (make-hash-table :test test)))))
  hash)

(declaim (ftype (function (hash-trie) fixnum) element-count))
(defmethod print-object ((o hash-trie) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (format stream "~S ~A ~S ~D" 
            :test  (hash-table-test (hash-trie-hash o))
            :count (element-count o))))

(defmacro get-node1 (key trie) `(gethash ,key (hash-trie-hash ,trie)))
(defmacro rem-node1 (key trie) `(remhash ,key (hash-trie-hash ,trie)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((ELEMENT-NODE-KEY '#.(gensym)))
    (defmacro get-elem1 (trie) `(gethash ',ELEMENT-NODE-KEY (hash-trie-hash ,trie)))
    (defmacro rem-elem1 (trie) `(remhash ',ELEMENT-NODE-KEY (hash-trie-hash ,trie)))
    (defun element-node-key-p (key) (eq key ELEMENT-NODE-KEY))))

(defun coerce-to-list (seq)
  (if (listp seq) seq (coerce seq 'list)))

(defun get-node-force (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        trie
      (a.if #1=(get-node1 (car keys) trie)
          (self (cdr keys) it)
        (self (cdr keys) (setf #1# (make-trie :test (hash-table-test
                                                     (hash-trie-hash trie)))))))))

;; --> (values key-seqに一致したノード                          ; 一致するノードが無かった場合はnil
;;             key-seqの要素に一致した最後のノード              ; ≒ 検索に失敗したノード
;;             trieの中に見つかったkey-seqの最後の要素の位置+1) ; ≒ 検索に失敗した要素位置
(defun get-node (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie) (i 0))
    (if (null keys)
        (values trie trie i)
      (a.if (get-node1 (car keys) trie)
          (self (cdr keys) it (1+ i))
        (values nil trie i)))))

(defun get-elem (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        (get-elem1 trie)
      (a.if (get-node1 (car keys) trie)
           (self (cdr keys) it)
        (values nil nil)))))

(defsetf get-elem (key-seq trie) (new-value)
  `(let ((terminal-node (get-node-force ,key-seq ,trie)))
     (setf (get-elem1 terminal-node) ,new-value)
     ,new-value))

(defun map-trie (fn trie)
  (nlet self ((trie trie) keys)
    (maphash (lambda (key val)
               (if (element-node-key-p key)
                   (funcall fn (reverse keys) val)
                 (self val (cons key keys))))
             (hash-trie-hash trie))))

(defun to-list (trie)
  (nlet self ((trie trie))
    (let ((acc '()))
      (maphash (lambda (key val)
                 (push
                  (if (element-node-key-p key)
                      val
                    (cons key (self val)))
                  acc))
               (hash-trie-hash trie))
      acc)))

(defun element-count (trie &aux (count 0))
  (nlet self ((trie trie))
    (maphash (lambda (key val)
               (if (element-node-key-p key)
                   (incf count)
                 (self val)))
             (hash-trie-hash trie)))
  count)

;; key-seqに対応する要素が存在した場合はtを、しなかった場合はnilを返す
;; 要素削除後にできる空ノードも合わせて削除される
(defun rem-elem (key-seq trie)
  (nlet self ((keys (coerce-to-list key-seq)) (trie trie))
    (if (null keys)
        (rem-elem1 trie)
      (a.when (get-node1 (car keys) trie)
        (prog1 (self (cdr keys) it)
          (when (zerop (hash-table-count (hash-trie-hash it)))
            (rem-node1 (car keys) trie)))))))

(defun common-prefix-search (key-seq trie)
  (let ((elems '()))
    (nlet self ((keys (coerce-to-list key-seq)) (trie trie) (i 0))
      (when keys
        (let ((node (get-node1 (car keys) trie)))
          (when node
            (a.when (get-elem1 node)
              (push (list i it node) elems))
            (self (cdr keys) node (1+ i))))))
    (values (nreverse elems))))

;; [TODO]
;;  - key-seqを引数に取る関数には、:startおよび:endキーワード引数を指定できるようにする
;;  - リスト以外の列が渡された場合の処理の効率化   ※ 現状は全部(coerce ... 'list)しているので非効率
;;  - 整理/コメント
;;  - etc

仕様説明を兼ねた使用例

> (rename-package :hash-trie :hash-trie '(:trie))

;;;;;;;;;;;;;;;;;;;
;;;; 基本的な使い方
;; 作成
> (defvar *trie* (trie:make-trie))  ; testキーワード引数が指定可能(デフォルトは#'eql)。test引数は、内部で利用しているハッシュテーブルに渡される
--> *TRIE*

;; 要素追加
> (setf (trie:get-elem "abc" *trie*) :val1)
--> :VAL1

;; 要素取得: 返り値の形式は、gethashと同様
> (trie:get-elem "abc" *trie*)
--> :VAL1
    T

> (trie:get-elem "ab" *trie*)
--> NIL 
    NIL

;; 要素数取得: 毎回全要素を走査するので遅い
> (trie:element-count *trie*)
--> 1

;; 要素追加2: キーの列がリストでも配列でも区別しない
> (setf (trie:get-elem '(#\a #\b #\e #\f) *trie*) :val2)
--> VAL2

;; リスト(ツリー)に変換
> (trie:to-list *trie*)
--> ((#\a (#\b (#\e (#\f :VAL2)) 
               (#\c :VAL1))))

;; マッピング
> (trie:map-trie (lambda (k v) (format t "KEY:~A, VAL:~A~%" k v)) *trie*)
KEY:(a b c), VAL:VAL1
KEY:(a b e f), VAL:VAL2
--> NIL


;;;;;;;;;;;;;;;;;
;;;; その他の関数
;; ノード取得(検索)
;; ※ get-nodeで取得したノードは、それ自体がhash-trieなので、hash-trieに対する任意の関数が適用可能
> (trie:get-node "ab" *trie*)
--> #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B1B4491}> ; キー列"ab"に対応するノード
    #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B1B4491}> ; 同上
    2                         ; 検索に失敗したキー列の要素の位置。今回は成功したので、(length "ab")

;; ノード取得(検索): 失敗時
> (trie:get-node "abcd" *trie*)
--> NIL                      ; 取得に失敗  
    #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 1 {B1B46D1}> ; 最後に使われたノード  ※"abc"に対応するノード
    3                        ; 検索に失敗した要素の位置 ※ 3=="d"の位置で失敗

;; 呼び出しを複数に分けた場合
> (eq (trie:get-node "abef" *trie*)
      (trie:get-node "ef" (trie:get-node "ab" *trie*)))
--> T 


;; 要素削除
> (trie:rem-elem "abef" *trie*)
--> T

> (trie:to-list *trie*)
--> ((#\a (#\b (#\c :VAL1))))

;; - get-elem1,rem-elem1は、それぞれ空列を渡した場合のget-elem,rem-elemと等しい
;; - get-node1は、要素数が1の列を渡した場合のget-nodeと等しい
> (trie:get-elem1 (trie:get-node1 #\c (trie:get-node1 #\b (trie:get-node1 #\a *trie*))))
--> :VAL1
    T

;; rem-elem1(or 空列を渡したrem-elem)の場合、要素削除後に要素を持たないゴミノードが残ってしまう
;;   ==> ルートノード(*trie*)に対して、(trie:rem-elem "abc" *trie*)を呼び出した方が良い
> (trie:rem-elem1 (trie:get-node1 #\c (trie:get-node1 #\b (trie:get-node1 #\a *trie*))))
--> T

> (trie:to-list *trie*)
--> ((#\a (#\b (#\c))))

> (trie:element-count *trie*)
--> 0

;; common-prefix-search
> (let ((trie (trie:make-trie)))
    (dolist (k '("東京都" "東京" "京都府" "東京都立図書館"))
      (setf (trie:get-elem k trie) k))
    (setf *trie* trie))
--> #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 4 {B07F231}>

> (trie:common-prefix-search "東京都立図書館に出かける" *trie*)
--> ((1 "東京" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 3 {B07F711}>)
     (2 "東京都" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 2 {B07F951}>)
     (6 "東京都立図書館" #<HASH-TRIE:HASH-TRIE :TEST EQL :COUNT 1 {B080991}>))

>  (progn (princ (trie:to-list (third (first *)))) 'done)
--> (東京 
     (((((館 
          東京都立図書館)))) 
      東京都))

a.when, a.if 

アナフォリックwhenとアナフォリックif。
『On Lisp』のawhen,aifマクロと同機能。 ※ 個人的にはアナフォリックマクロは、'a'で始めるより'a.'で始める方が好きなので、名前は若干異なっている。

(defmacro a.when (expr &body body)
  `(let ((,it ,expr))
     (when ,it
       ,@body)))

(defmacro a.if (expr consequent &optional alternative)
  `(let ((,it ,expr))
     (if ,it
         ,consequent
       ,alternative)))