トライ (trie)、パトリシア (patricia)、Ternary Search Tree (TST) は木構造の一種で、根 (root) から葉 (leaf) までの経路が一つの文字列に対応します。これらのデータ構造は文字列を高速に探索することができますが、それだけではなく、共通の接頭辞 (common prefix) を持つ文字列、たとえば 'abc' で始まる文字列を簡単に見つけることができます。詳しい説明は以下に示す拙作のページをお読みくださいませ。
アーカイブファイル minlib.tar.gz をインストールする、または プログラムリスト にある以下の 4 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば trie など) に配置してください。
* (asdf:test-system :trie)
; compiling file ... 略...
----- test start -----
(TRIE-P (SETQ TS (MAKE-TRIE)))
=> T OK
(TRIE-EMPTYP TS)
=> T OK
(TRIE-COUNT TS)
=> 0 OK
(PROGN
(SETQ KS '(foo bar baz oops)
VS '(10 20 30 40))
(MAPC (LAMBDA (K V) (TRIE-SET TS K V)) KS VS)
(TRIE-COUNT TS))
=> 4 OK
(TRIE-EMPTYP TS)
=> NIL OK
(MAPCAR (LAMBDA (K) (TRIE-EXISTS TS K)) '(foo Foo))
=> (T NIL) OK
(MAPCAR (LAMBDA (K) (TRIE-EXISTS TS K)) KS)
=> (T T T T) OK
(MAPCAR (LAMBDA (K) (TRIE-GET TS K)) '(foo Foo))
=> (10 NIL) OK
(MAPCAR (LAMBDA (K) (TRIE-GET TS K)) KS)
=> (10 20 30 40) OK
(LET ((A NIL))
(TRIE-MAPC TS (LAMBDA (K V) (PUSH (CONS (TO-STR K) V) A)))
(REVERSE A))
=> ((oops . 40) (baz . 30) (bar . 20) (foo . 10)) OK
(TRIE-FOLD TS NIL (LAMBDA (A K V) (CONS (CONS (TO-STR K) V) A)))
=> ((foo . 10) (bar . 20) (baz . 30) (oops . 40)) OK
(TRIE-DEL TS foo)
=> T OK
(TRIE-EXISTS TS foo)
=> NIL OK
(TRIE-COUNT TS)
=> 3 OK
(TRIE-DEL TS bar)
=> T OK
(TRIE-EXISTS TS bar)
=> NIL OK
(TRIE-COUNT TS)
=> 2 OK
(TRIE-DEL TS baz)
=> T OK
(TRIE-EXISTS TS baz)
=> NIL OK
(TRIE-COUNT TS)
=> 1 OK
(TRIE-DEL TS oops)
=> T OK
(TRIE-EXISTS TS oops)
=> NIL OK
(TRIE-COUNT TS)
=> 0 OK
(TRIE-EMPTYP TS)
=> T OK
(PROGN (MAPC (LAMBDA (K V) (TRIE-PUSH TS K V)) KS VS) (TRIE-COUNT TS))
=> 4 OK
(TRIE-PUSH TS Foo 0)
=> T OK
(TRIE-COUNT TS)
=> 5 OK
(TRIE-GET TS Foo)
=> (0) OK
(TRIE-PUSH TS Foo 1)
=> NIL OK
(TRIE-COUNT TS)
=> 5 OK
(TRIE-GET TS Foo)
=> (1 0) OK
(TRIE-POP TS Foo)
=> 1 OK
(TRIE-POP TS Foo)
=> 0 OK
(TRIE-POP TS Foo)
=> NIL OK
(TRIE-COUNT TS)
=> 5 OK
(TRIE-DEL TS Foo)
=> T OK
(TRIE-COUNT TS)
=> 4 OK
(TRIE-CLEAR TS)
=> 0 OK
(TRIE-COUNT TS)
=> 0 OK
(TRIE-EMPTYP TS)
=> T OK
(PROGN
(MAPC (LAMBDA (K) (TRIE-SET TS K T)) '(abcde abcd abc ab a))
(TRIE-COUNT TS))
=> 5 OK
(LET ((A NIL))
(TRIE-COMMON-PREFIX TS abc (LAMBDA (K V) (PUSH (CONS (TO-STR K) V) A)))
(REVERSE A))
=> ((abc . T) (abcd . T) (abcde . T)) OK
(TRIE-COUNT (SETQ CS (TRIE-COPY TS)))
=> 5 OK
(MAPCAR (LAMBDA (K) (TRIE-GET CS K)) '(abcde abcd abc ab a))
=> (T T T T T) OK
(TRIE-DEL CS abcde)
=> T OK
(TRIE-EXISTS CS abcde)
=> NIL OK
(TRIE-EXISTS TS abcde)
=> T OK
(PATRICIA-P (SETQ TS (MAKE-PATRICIA)))
=> T OK
; 結果は省略
(TERNARY-P (SETQ TS (MAKE-TERNARY)))
=> T OK
; 結果は省略
----- test end -----
TEST: 141
OK: 141
NG: 0
ERR: 0
T
;;;
;;; sample_tree.lisp : treemap と trie のサンプルプログラム
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :treemap)
(use-package :treemap)
(require :trie)
(use-package :trie)
;;; リストの比較 (xs と ys は同じ長さ)
(defun list< (xs ys)
(cond
((null xs) nil)
((< (car xs) (car ys)) t)
((> (car xs) (car ys)) nil)
(t
(list< (cdr xs) (cdr ys)))))
;;; 点 (x y z) を作る
(defun make-point ()
(list (random 100) (random 100) (random 100)))
;;;
;;; 異なる点を n 個作る
;;;
;;; 線形探索
(defun make-data (n)
(do ((a nil))
((zerop n) a)
(let ((xs (make-point)))
(unless (member xs a :test #'equal)
(decf n)
(push xs a)))))
;;; ハッシュ
(defun make-data-hash (n)
(do ((a (make-hash-table :test #'equal)))
((zerop n) a)
(let ((xs (make-point)))
(unless (gethash xs a)
(decf n)
(setf (gethash xs a) t)))))
;;; 赤黒木
(defun make-data-rbtree (n)
(do ((a (make-treemap #'equal #'list<)))
((zerop n) a)
(let ((xs (make-point)))
(unless (tree-exists a xs)
(decf n)
(tree-set a xs t)))))
;;; スプレー木
(defun make-data-splay (n)
(do ((a (make-splaytree #'equal #'list<)))
((zerop n) a)
(let ((xs (make-point)))
(unless (tree-exists a xs)
(decf n)
(tree-set a xs t)))))
;;; トライ木
(defun make-data-trie (n)
(do ((a (make-trie)))
((zerop n) a)
(let ((xs (make-point)))
(unless (trie-exists a xs)
(decf n)
(trie-set a xs t)))))
;;; パトリシア木
(defun make-data-patricia (n)
(do ((a (make-patricia)))
((zerop n) a)
(let ((xs (make-point)))
(unless (trie-exists a xs)
(decf n)
(trie-set a xs t)))))
;;; 三分木
(defun make-data-ternary (n)
(do ((a (make-ternary :elt= #'= :elt< #'<)))
((zerop n) a)
(let ((xs (make-point)))
(unless (trie-exists a xs)
(decf n)
(trie-set a xs t)))))
表 : 実行結果 (単位 : 秒)
個数 : 10000 : 20000 : 40000
-----------+-------+-------+--------
線形探索 : 0.629 : 2.500 : 10.240
ハッシュ : 0.003 : 0.007 : 0.011
赤黒木 : 0.030 : 0.050 : 0.120
スプレー木 : 0.030 : 0.060 : 0.169
トライ : 0.040 : 0.060 : 0.139
パトリシア : 0.030 : 0.070 : 0.160
三分木 : 0.010 : 0.020 : 0.050
実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz
;;;
;;; eight.lisp : 幅優先探索による 8 パズルの解法
;;;
;;; Copyright (c) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :queue)
(use-package :queue)
(require :trie)
(use-package :trie)
;;; 盤面
;;; 0 1 2
;;; 3 4 5
;;; 6 7 8
;;; 隣接リスト
(defconstant adjacent
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 駒の移動
(defun move-piece (board x space)
(let ((newbd (copy-seq board)))
(setf (aref newbd space) (aref newbd x)
(aref newbd x) 0)
newbd))
;;; 解の表示
;;; 局面 st はリスト (board space prev)
(defun print-answer (st)
(when (third st)
(print-answer (third st)))
(format t "~A~%" (first st)))
;;; 幅優先探索
(defun eight-puzzle (start goal)
;; 初期化
(let ((que (make-queue))
(chk (make-ternary :elt= #'= :elt< #'<)))
(enqueue que (list start (position 0 start) nil))
(trie-set chk start t)
(do ()
((queue-emptyp que))
(let* ((st (dequeue que))
(bd (first st))
(sp (second st)))
(when (equalp bd goal)
(print-answer st)
(return))
(dolist (x (aref adjacent sp))
(let ((newbd (move-piece bd x sp)))
(unless (trie-exists chk newbd)
(enqueue que (list newbd x st))
(trie-set chk newbd t))))))))
* (load "eight.lisp") T * (time (eight-puzzle #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0))) #(8 6 7 2 5 4 3 0 1) #(8 6 7 2 0 4 3 5 1) #(8 0 7 2 6 4 3 5 1) #(0 8 7 2 6 4 3 5 1) #(2 8 7 0 6 4 3 5 1) #(2 8 7 3 6 4 0 5 1) #(2 8 7 3 6 4 5 0 1) #(2 8 7 3 6 4 5 1 0) #(2 8 7 3 6 0 5 1 4) #(2 8 0 3 6 7 5 1 4) #(2 0 8 3 6 7 5 1 4) #(2 6 8 3 0 7 5 1 4) #(2 6 8 0 3 7 5 1 4) #(2 6 8 5 3 7 0 1 4) #(2 6 8 5 3 7 1 0 4) #(2 6 8 5 3 7 1 4 0) #(2 6 8 5 3 0 1 4 7) #(2 6 0 5 3 8 1 4 7) #(2 0 6 5 3 8 1 4 7) #(2 3 6 5 0 8 1 4 7) #(2 3 6 0 5 8 1 4 7) #(2 3 6 1 5 8 0 4 7) #(2 3 6 1 5 8 4 0 7) #(2 3 6 1 5 8 4 7 0) #(2 3 6 1 5 0 4 7 8) #(2 3 0 1 5 6 4 7 8) #(2 0 3 1 5 6 4 7 8) #(0 2 3 1 5 6 4 7 8) #(1 2 3 0 5 6 4 7 8) #(1 2 3 4 5 6 0 7 8) #(1 2 3 4 5 6 7 0 8) #(1 2 3 4 5 6 7 8 0) Evaluation took: 0.640 seconds of real time 0.648431 seconds of total run time (0.638835 user, 0.009596 system) [ Run times consist of 0.057 seconds GC time, and 0.592 seconds non-GC time. ] 101.25% CPU 92 lambdas converted 1,556,284,779 processor cycles 91,599,088 bytes consed NIL
実行時間 : 単位 (秒) トライ : 0.72 パトリシア : 0.70 三分木 : 0.64 ハッシュ表 : 0.22
* (require :trie)
("TRIE")
* (use-package :trie)
T
* (defun make-suffix (ts seq) (dotimes (x (length seq) ts) (trie-set ts (subseq seq x) t)))
MAKE-SUFFIX
* (defvar a (make-suffix (make-trie) "banana"))
A
* (trie-mapc a (lambda (k v) (format t "~s, ~s~%" k v)))
(#\n #\a), T
(#\n #\a #\n #\a), T
(#\a), T
(#\a #\n #\a), T
(#\a #\n #\a #\n #\a), T
(#\b #\a #\n #\a #\n #\a), T
NIL
* (defvar b (make-suffix (make-ternary) "banana"))
B
* (trie-mapc b (lambda (k v) (format t "~s, ~s~%" k v)))
(#\a), T
(#\a #\n #\a), T
(#\a #\n #\a #\n #\a), T
(#\b #\a #\n #\a #\n #\a), T
(#\n #\a), T
(#\n #\a #\n #\a), T
NIL
* (defvar c (make-suffix (make-patricia) "banana"))
C
* (trie-mapc c (lambda (k v) (format t "~s, ~s~%" k v)))
("na"), T
("na" "na"), T
("a"), T
("a" "na"), T
("a" "na" "na"), T
("banana"), T
NIL
* (trie-common-prefix a "an" (lambda (k v) (format t "~s, ~s~%" k v)))
(#\a #\n #\a), T
(#\a #\n #\a #\n #\a), T
NIL
* (trie-common-prefix b "an" (lambda (k v) (format t "~s, ~s~%" k v)))
(#\a #\n #\a), T
(#\a #\n #\a #\n #\a), T
NIL
* (trie-common-prefix c "an" (lambda (k v) (format t "~s, ~s~%" k v)))
("a" "an"), T
("an" "a" "na"), T
NIL
関数 make-suffix は引数 seq の suffix trie (または suffix tree) を生成します。(subseq seq x) で seq の接尾辞を作り、メソッド trie-set でトライに追加します。とても簡単な方法ですが、データが多くなると時間がかかるのが欠点です。データ数を N とすると、実行時間は N2 に比例します。とても遅いので実用的ではありません。ご注意くださいませ。
;;;
;;; trie.lisp : トライ、パトリシア、三分木
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :trie)
(defpackage :trie (:use :cl))
(in-package :trie)
(export '(trie make-trie trie-p
patricia make-patricia patricia-p
ternary make-ternary ternary-p
trie-emptyp trie-count trie-clear
trie-exists trie-get trie-set trie-del
trie-fold trie-mapc trie-push trie-pop
trie-copy trie-common-prefix
))
;;; メソッドの宣言
(defgeneric trie-emptyp (ts))
(defgeneric trie-count (ts))
(defgeneric trie-clear (ts))
(defgeneric trie-exists (ts seq))
(defgeneric trie-get (ts seq))
(defgeneric trie-set (ts seq val))
(defgeneric trie-del (ts seq))
(defgeneric trie-push (ts seq val))
(defgeneric trie-pop (ts seq))
(defgeneric trie-mapc (ts fn))
(defgeneric trie-fold (ts a fn))
(defgeneric trie-copy (ts))
(defgeneric trie-common-prefix (ts seq fn))
;;;
;;; トライ
;;;
;;; 節
(defstruct node item child (value 'none))
;;; トライ
(defstruct trie
(root (make-node)) (size 0) (elt= #'eql))
;;;
;;; 作業用操作関数
;;;
;;; 葉
(defun leaf-p (nd)
(and (node-p nd)
(not (eq (node-value nd) 'none))))
;;; 挿入
(defun node-insert (nd seq i elt=)
(if (= (length seq) i)
nd
(let ((child (find (elt seq i) (node-child nd) :key #'node-item :test elt=)))
(unless child
(setf child (make-node :item (elt seq i)))
(push child (node-child nd)))
(node-insert child seq (1+ i) elt=))))
;;; 探索
(defun node-search (nd seq i elt=)
(if (= (length seq) i)
nd
(let ((child (find (elt seq i) (node-child nd) :key #'node-item :test elt=)))
(when child
(node-search child seq (1+ i) elt=)))))
;;; 巡回
(defun node-traverse (nd func a)
(let ((a1 (cons (node-item nd) a)))
(when (leaf-p nd)
(funcall func (reverse a1) (node-value nd)))
(dolist (x (node-child nd))
(node-traverse x func a1))))
;;; 畳み込み
(defun node-fold (nd func seq a)
(let ((seq1 (cons (node-item nd) seq)))
(when (leaf-p nd)
(setf a (funcall func a (reverse seq1) (node-value nd))))
(dolist (x (node-child nd) a)
(setf a (node-fold x func seq1 a)))))
;;;
;;; メソッドの定義
;;;
;;; トライは空か
(defmethod trie-emptyp ((ts trie)) (zerop (trie-size ts)))
;;; 要素数を求める
(defmethod trie-count ((ts trie)) (trie-size ts))
;;; クリア
(defmethod trie-clear ((ts trie))
(setf (node-child (trie-root ts)) nil
(trie-size ts) 0))
;;; 挿入
(defmethod trie-set ((ts trie) seq val)
(let ((nd (node-insert (trie-root ts) seq 0 (trie-elt= ts))))
(cond
((leaf-p nd)
(setf (node-value nd) val)
nil)
(t
(setf (node-value nd) val)
(incf (trie-size ts))
t))))
(defmethod trie-push ((ts trie) seq val)
(let ((nd (node-insert (trie-root ts) seq 0 (trie-elt= ts))))
(cond
((leaf-p nd)
(setf (node-value nd) (cons val (node-value nd)))
nil)
(t
(setf (node-value nd) (list val))
(incf (trie-size ts))
t))))
;;; 探索
(defmethod trie-exists ((ts trie) seq)
(leaf-p (node-search (trie-root ts) seq 0 (trie-elt= ts))))
(defmethod trie-get ((ts trie) seq)
(let ((nd (node-search (trie-root ts) seq 0 (trie-elt= ts))))
(when (leaf-p nd)
(node-value nd))))
;;; 削除
(defmethod trie-del ((ts trie) seq)
(let ((nd (node-search (trie-root ts) seq 0 (trie-elt= ts))))
(when (leaf-p nd)
(setf (node-value nd) 'none)
(decf (trie-size ts))
(when (zerop (trie-size ts))
(setf (node-child (trie-root ts)) nil))
t)))
(defmethod trie-pop ((ts trie) seq)
(let ((nd (node-search (trie-root ts) seq 0 (trie-elt= ts))))
(when (and (leaf-p nd)
(consp (node-value nd)))
(pop (node-value nd)))))
;;; 巡回
(defmethod trie-mapc ((ts trie) func)
(dolist (x (node-child (trie-root ts)))
(node-traverse x func nil)))
;;; 畳み込み
(defmethod trie-fold ((ts trie) a func)
(dolist (x (node-child (trie-root ts)) a)
(setf a (node-fold x func nil a))))
;;; 共通接頭辞の取得
(defmethod trie-common-prefix ((ts trie) seq func)
(let ((k (coerce seq 'list)))
(let ((nd (node-search (trie-root ts) seq 0 (trie-elt= ts))))
(when nd
(when (leaf-p nd)
(funcall func k (node-value nd)))
(dolist (x (node-child nd))
(node-traverse x func (reverse k)))))))
;;; トライのコピー
(defmethod trie-copy ((ts trie))
(let ((new-ts (make-trie :elt= (trie-elt= ts))))
(trie-mapc ts (lambda (k v) (trie-set new-ts k v)))
new-ts))
;;;
;;; patricia tree
;;;
;;; 型の定義
(defstruct patricia
(root (make-node)) (size 0) (elt= #'eql))
;;; 子の探索
(defun child-search-pat (nd seq si elt=)
(dolist (x (node-child nd))
(when (funcall elt= (elt seq si) (elt (node-item x) 0))
(return x))))
;;; node から最長一致する節を求める
(defun node-longest-match (nd seq elt=)
(do ((k (length seq))
(i 0))
((>= i k) (values nd i 0))
(let ((child (child-search-pat nd seq i elt=)))
(unless child
(return (values nd i 0)))
(do* ((j 1)
(s1 (node-item child))
(k1 (length s1)))
((>= j k1) (incf i k1))
(when (or (>= (+ i j) k)
(not (funcall elt= (elt seq (+ i j)) (elt s1 j))))
;; child の途中まで一致
(return-from node-longest-match (values child (+ i j) j)))
(incf j))
(setf nd child))))
;;; 新しい節と葉を追加する
;;; nd <- new-node + val
(defun insert-new-node-leaf (nd seq val)
(let ((new-node (make-node :item seq :value val)))
(push new-node (node-child nd))
t))
;;; 節を分割する
;;; nd -> (nd - child)
(defun divide-node (nd sub-match)
(let ((child (make-node :item (subseq (node-item nd) sub-match))))
(setf (node-child child) (node-child nd)
(node-value child) (node-value nd)
(node-child nd) (list child)
(node-value nd) 'none
(node-item nd) (subseq (node-item nd) 0 sub-match))
child))
;;;
;;; メソッドの定義
;;;
;;; 空か？
(defmethod trie-emptyp ((ts patricia))
(zerop (patricia-size ts)))
;;; 要素数
(defmethod trie-count ((ts patricia))
(patricia-size ts))
;;; 空にする
(defmethod trie-clear ((ts patricia))
(setf (node-child (patricia-root ts)) nil
(patricia-size ts) 0))
;;; データの挿入
(defmethod trie-set ((ts patricia) seq val)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(cond
((zerop sub-match)
(if (= (length seq) match)
;; 終端のチェック
(cond
((leaf-p nd)
(setf (node-value nd) val)
nil)
(t
(setf (node-value nd) val)
(incf (patricia-size ts))
t))
;; nd に新しい節と葉を追加する
(progn
(insert-new-node-leaf nd (subseq seq match) val)
(incf (patricia-size ts))
t)))
(t
;; nd を sub-match で分割
;; nd - child
(divide-node nd sub-match)
(if (= (length seq) match)
(setf (node-value nd) val)
(insert-new-node-leaf nd (subseq seq match) val))
(incf (patricia-size ts))
t))))
(defmethod trie-push ((ts patricia) seq val)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(cond
((zerop sub-match)
(if (= (length seq) match)
(cond
((leaf-p nd)
(setf (node-value nd) (cons val (node-value nd)))
nil)
(t
(setf (node-value nd) (list val))
(incf (patricia-size ts))
t))
(progn
(insert-new-node-leaf nd (subseq seq match) (list val))
(incf (patricia-size ts))
t)))
(t
(divide-node nd sub-match)
(if (= (length seq) match)
(setf (node-value nd) (list val))
(insert-new-node-leaf nd (subseq seq match) (list val)))
(incf (patricia-size ts))
t))))
;;; データの探索
(defmethod trie-exists ((ts patricia) seq)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(and (zerop sub-match)
(= (length seq) match)
(leaf-p nd))))
(defmethod trie-get ((ts patricia) seq)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(when (and (zerop sub-match)
(= (length seq) match)
(leaf-p nd))
(node-value nd))))
(defmethod trie-pop ((ts patricia) seq)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(when (and (zerop sub-match)
(= (length seq) match)
(leaf-p nd)
(consp (node-value nd)))
(pop (node-value nd)))))
;;; 削除
(defmethod trie-del ((ts patricia) seq)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(when (and (zerop sub-match)
(= (length seq) match)
(leaf-p nd))
(setf (node-value nd) 'none)
(decf (patricia-size ts))
(when (zerop (patricia-size ts))
(setf (node-child (patricia-root ts)) nil))
t)))
;;; 巡回
(defmethod trie-mapc ((ts patricia) func)
(dolist (x (node-child (patricia-root ts)))
(node-traverse x func nil)))
;;; 畳み込み
(defmethod trie-fold ((ts patricia) a func)
(dolist (x (node-child (patricia-root ts)) a)
(setf a (node-fold x func nil a))))
;;; コピー
(defmethod trie-copy ((ts patricia))
(let ((new-ts (make-patricia :elt= (patricia-elt= ts))))
(trie-mapc ts (lambda (k v)
(let ((seq-type (if (stringp (car k)) 'string (car (type-of (car k))))))
(trie-set new-ts (apply #'concatenate seq-type k) v))))
new-ts))
;;; 共通接頭辞を持つデータを求める
(defmethod trie-common-prefix ((ts patricia) seq func)
(multiple-value-bind
(nd match sub-match)
(node-longest-match (patricia-root ts) seq (patricia-elt= ts))
(when (= (length seq) match)
(let ((seq1 (if (zerop sub-match)
(list seq)
(list (subseq (node-item nd) sub-match) seq))))
(when (leaf-p nd)
(funcall func seq1 (node-value nd)))
(dolist (x (node-child nd))
(node-traverse x func seq1))))))
;;;
;;; ternary search tree (三分木)
;;;
;;; 節
(defstruct node3
item left mid right (value 'none))
;;; データ型
(defstruct ternary
(root (make-node3)) (size 0) (elt= #'char=) (elt< #'char<))
;;; 葉
(defun leaf3-p (nd)
(and (node3-p nd)
(not (eq (node3-value nd) 'none))))
;;; 子の探索
(defun child-search-tst (nd x elt= elt<)
(cond
((null nd) nil)
((funcall elt= x (node3-item nd)) nd)
((funcall elt< x (node3-item nd))
(child-search-tst (node3-left nd) x elt= elt<))
(t
(child-search-tst (node3-right nd) x elt= elt<))))
;;; 子の挿入 (x は node3)
(defun child-insert-tst (nd x elt= elt<)
(cond
((null nd) x)
((funcall elt= (node3-item x) (node3-item nd)) nd)
((funcall elt< (node3-item x) (node3-item nd))
(setf (node3-left nd)
(child-insert-tst (node3-left nd) x elt= elt<))
nd)
(t
(setf (node3-right nd)
(child-insert-tst (node3-right nd) x elt= elt<))
nd)))
;;; 挿入
(defun node-insert-tst (nd seq i elt= elt<)
(if (= (length seq) i)
nd
(let ((child (child-search-tst (node3-mid nd) (elt seq i) elt= elt<)))
(unless child
(setf child (make-node3 :item (elt seq i))
(node3-mid nd) (child-insert-tst (node3-mid nd) child elt= elt<)))
(node-insert-tst child seq (1+ i) elt= elt<))))
;;; 探索
(defun node-search-tst (nd seq i elt= elt<)
(if (= (length seq) i)
nd
(let ((child (child-search-tst (node3-mid nd) (elt seq i) elt= elt<)))
(when child
(node-search-tst child seq (1+ i) elt= elt<)))))
;;; 巡回
(defun node-traverse-tst (nd func a)
(when nd
(node-traverse-tst (node3-left nd) func a)
(let ((a1 (cons (node3-item nd) a)))
(when (leaf3-p nd)
(funcall func (reverse a1) (node3-value nd)))
(node-traverse-tst (node3-mid nd) func a1))
(node-traverse-tst (node3-right nd) func a)))
;;; 畳み込み
(defun node-fold-tst (nd func seq a)
(when nd
(setf a (node-fold-tst (node3-left nd) func seq a))
(let ((seq1 (cons (node3-item nd) seq)))
(when (leaf3-p nd)
(setf a (funcall func a (reverse seq1) (node3-value nd))))
(setf a (node-fold-tst (node3-mid nd) func seq1 a)))
(setf a (node-fold-tst (node3-right nd) func seq a)))
a)
;;;
;;; メソッドの定義
;;;
;;; トライは空か
(defmethod trie-emptyp ((ts ternary)) (zerop (ternary-size ts)))
;;; 要素数を求める
(defmethod trie-count ((ts ternary)) (ternary-size ts))
;;; クリア
(defmethod trie-clear ((ts ternary))
(setf (node3-mid (ternary-root ts)) nil
(ternary-size ts) 0))
;;; 挿入
(defmethod trie-set ((ts ternary) seq val)
(let ((nd (node-insert-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(cond
((leaf3-p nd)
(setf (node3-value nd) val)
nil)
(t
(setf (node3-value nd) val)
(incf (ternary-size ts))
t))))
(defmethod trie-push ((ts ternary) seq val)
(let ((nd (node-insert-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(cond
((leaf3-p nd)
(setf (node3-value nd) (cons val (node3-value nd)))
nil)
(t
(setf (node3-value nd) (list val))
(incf (ternary-size ts))
t))))
;;; 探索
(defmethod trie-exists ((ts ternary) seq)
(leaf3-p (node-search-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(defmethod trie-get ((ts ternary) seq)
(let ((nd (node-search-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(when (leaf3-p nd)
(node3-value nd))))
;;; 削除
(defmethod trie-del ((ts ternary) seq)
(let ((nd (node-search-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(when (leaf3-p nd)
(setf (node3-value nd) 'none)
(decf (ternary-size ts))
(when (zerop (ternary-size ts))
(setf (node3-mid (ternary-root ts)) nil))
t)))
(defmethod trie-pop ((ts ternary) seq)
(let ((nd (node-search-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(when (and (leaf3-p nd)
(consp (node3-value nd)))
(pop (node3-value nd)))))
;;; 巡回
(defmethod trie-mapc ((ts ternary) func)
(node-traverse-tst (node3-mid (ternary-root ts)) func nil))
;;; 畳み込み
(defmethod trie-fold ((ts ternary) a func)
(node-fold-tst (node3-mid (ternary-root ts)) func nil a))
;;; コピー
(defmethod trie-copy ((ts ternary))
(let ((new-ts (make-ternary :elt= (ternary-elt= ts) :elt< (ternary-elt< ts))))
(trie-mapc ts (lambda (k v) (trie-set new-ts k v)))
new-ts))
;;; 共通接頭辞の取得
(defmethod trie-common-prefix ((ts ternary) seq func)
(let ((k (coerce seq 'list))
(nd (node-search-tst (ternary-root ts) seq 0 (ternary-elt= ts) (ternary-elt< ts))))
(when nd
(when (leaf3-p nd)
(funcall func k (node3-value nd)))
(node-traverse-tst (node3-mid nd) func (reverse k)))))
;;;
;;; trie_tst.lisp : trie のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :trie_tst)
(defpackage :trie_tst (:use :cl :mintst :trie))
(in-package :trie_tst)
(export '(test))
(defvar ts nil)
(defvar ks nil)
(defvar vs nil)
(defvar cs nil)
(defun to-str (xs)
(if (stringp (car xs))
(apply #'concatenate 'string xs)
(coerce xs 'string)))
(defun test-sub ()
(run (trie-emptyp ts) t)
(run (trie-count ts) 0)
(run (progn
(setq ks '("foo" "bar" "baz" "oops")
vs '(10 20 30 40))
(mapc (lambda (k v) (trie-set ts k v)) ks vs)
(trie-count ts))
4)
(run (trie-emptyp ts) nil)
(run (mapcar (lambda (k) (trie-exists ts k)) '("foo" "Foo")) '(t nil))
(run (mapcar (lambda (k) (trie-exists ts k)) ks) '(t t t t))
(run (mapcar (lambda (k) (trie-get ts k)) '("foo" "Foo")) '(10 nil))
(run (mapcar (lambda (k) (trie-get ts k)) ks) '(10 20 30 40))
(cond
((ternary-p ts)
(run (let ((a nil))
(trie-mapc ts (lambda (k v) (push (cons (to-str k) v) a)))
(reverse a))
'(("bar" . 20) ("baz" . 30) ("foo" . 10) ("oops" . 40)))
(run (trie-fold ts nil (lambda (a k v) (cons (cons (to-str k) v) a)))
'(("oops" . 40) ("foo" . 10) ("baz" . 30) ("bar" . 20))))
(t
(run (let ((a nil))
(trie-mapc ts (lambda (k v) (push (cons (to-str k) v) a)))
(reverse a))
'(("oops" . 40) ("baz" . 30) ("bar" . 20) ("foo" . 10)))
(run (trie-fold ts nil (lambda (a k v) (cons (cons (to-str k) v) a)))
'(("foo" . 10) ("bar" . 20) ("baz" . 30) ("oops" . 40)))))
(run (trie-del ts "foo") t)
(run (trie-exists ts "foo") nil)
(run (trie-count ts) 3)
(run (trie-del ts "bar") t)
(run (trie-exists ts "bar") nil)
(run (trie-count ts) 2)
(run (trie-del ts "baz") t)
(run (trie-exists ts "baz") nil)
(run (trie-count ts) 1)
(run (trie-del ts "oops") t)
(run (trie-exists ts "oops") nil)
(run (trie-count ts) 0)
(run (trie-emptyp ts) t)
(run (progn
(mapc (lambda (k v) (trie-push ts k v)) ks vs)
(trie-count ts))
4)
(run (trie-push ts "Foo" 0) t)
(run (trie-count ts) 5)
(run (trie-get ts "Foo") '(0))
(run (trie-push ts "Foo" 1) nil)
(run (trie-count ts) 5)
(run (trie-get ts "Foo") '(1 0))
(run (trie-pop ts "Foo") 1)
(run (trie-pop ts "Foo") 0)
(run (trie-pop ts "Foo") nil)
(run (trie-count ts) 5)
(run (trie-del ts "Foo") t)
(run (trie-count ts) 4)
(run (trie-clear ts) 0)
(run (trie-count ts) 0)
(run (trie-emptyp ts) t)
;;
(run (progn
(mapc (lambda (k) (trie-set ts k t)) '("abcde" "abcd" "abc" "ab" "a"))
(trie-count ts))
5)
(run (let ((a nil))
(trie-common-prefix ts "abc" (lambda (k v) (push (cons (to-str k) v) a)))
(reverse a))
'(("abc" . t) ("abcd" . t) ("abcde" . t)))
(run (trie-count (setq cs (trie-copy ts))) 5)
(run (mapcar (lambda (k) (trie-get cs k)) '("abcde" "abcd" "abc" "ab" "a"))
'(t t t t t))
(run (trie-del cs "abcde") t)
(run (trie-exists cs "abcde") nil)
(run (trie-exists ts "abcde") t))
(defun test ()
(initial)
(run (trie-p (setq ts (make-trie))) t)
(test-sub)
(run (patricia-p (setq ts (make-patricia))) t)
(test-sub)
(run (ternary-p (setq ts (make-ternary))) t)
(test-sub)
(final))
リスト : trie_tst.asd (defsystem :trie_tst :description "test for trie" :version "0.1.0" :author "Makoto Hiroi" :license "MIT" :depends-on (:mintst :trie) :components ((:file "trie_tst")) :perform (test-op (o s) (symbol-call :trie_tst :test)))