• R/O
  • SSH
  • HTTPS

unf: Commit


Commit MetaInfo

Revision55 (tree)
Time2011-11-19 19:11:45
Authorphjgt

Log Message

ハッシュテーブルライブラリ追加

Change Summary

Incremental Difference

--- trunk/lisp/lib/dict-0.0.2/package.lisp (nonexistent)
+++ trunk/lisp/lib/dict-0.0.2/package.lisp (revision 55)
@@ -0,0 +1,18 @@
1+(defpackage dict
2+ (:use :common-lisp)
3+ (:shadow :common-lisp get set remove count map)
4+ (:export dict
5+ make
6+ count
7+ get
8+ remove
9+ each
10+ map))
11+(in-package :dict)
12+
13+(deftype positive-fixnum () `(integer 0 ,most-positive-fixnum))
14+(deftype fixnum-length () `(integer 0 ,(integer-length most-positive-fixnum)))
15+(deftype hash-function () #+SBCL `(function (t) (values positive-fixnum))
16+ #-SBCL 'function)
17+(defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0)))
18+(defvar *interface* '(optimize (speed 3) (safety 2) (debug 1)))
--- trunk/lisp/lib/dict-0.0.2/util.lisp (nonexistent)
+++ trunk/lisp/lib/dict-0.0.2/util.lisp (revision 55)
@@ -0,0 +1,17 @@
1+(in-package :dict)
2+
3+(declaim (inline acons!))
4+
5+(defmacro a.if (exp then else)
6+ `(let ((it ,exp))
7+ (if it
8+ ,then
9+ ,else)))
10+
11+(defun acons! (key value list &key test)
12+ (loop FOR x IN list
13+ WHEN (funcall test key (car x))
14+ DO (setf (cdr x) value)
15+ (return (values list nil))
16+ FINALLY
17+ (return (values `(,(cons key value) . ,list) t))))
--- trunk/lisp/lib/dict-0.0.2/COPYING (nonexistent)
+++ trunk/lisp/lib/dict-0.0.2/COPYING (revision 55)
@@ -0,0 +1,21 @@
1+The MIT License
2+
3+Copyright (c) 2010 Takeru Ohta <phjgt308@gmail.com>
4+
5+Permission is hereby granted, free of charge, to any person obtaining a copy
6+of this software and associated documentation files (the "Software"), to deal
7+in the Software without restriction, including without limitation the rights
8+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+copies of the Software, and to permit persons to whom the Software is
10+furnished to do so, subject to the following conditions:
11+
12+The above copyright notice and this permission notice shall be included in
13+all copies or substantial portions of the Software.
14+
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
21+THE SOFTWARE.
--- trunk/lisp/lib/dict-0.0.2/dict.lisp (nonexistent)
+++ trunk/lisp/lib/dict-0.0.2/dict.lisp (revision 55)
@@ -0,0 +1,99 @@
1+(in-package :dict)
2+
3+(declaim (inline index make make-dict count))
4+
5+(defstruct dict
6+ (count 0 :type positive-fixnum)
7+ (next-resize-trigger 0 :type positive-fixnum)
8+ (root-bitlen 0 :type fixnum-length)
9+ (root #() :type simple-vector)
10+ (test #'eql :type function)
11+ (hash #'sxhash :type hash-function))
12+
13+(defun make (&key (test #'eql) (hash #'sxhash))
14+ (declare #+SBCL (sb-ext:muffle-conditions sb-ext:compiler-note)
15+ (function test)
16+ (hash-function hash))
17+ (make-dict :next-resize-trigger (* 16 4)
18+ :root-bitlen 4
19+ :test test
20+ :hash hash
21+ :root (make-array 16 :initial-element '())))
22+
23+(defun count (dict)
24+ (dict-count dict))
25+
26+(defun index (len hash-code)
27+ (ldb (byte len 0) hash-code))
28+
29+(defun get (key dict)
30+ (declare #.*interface* (dict dict))
31+ (with-slots (root root-bitlen hash test) dict
32+ (declare #.*fastest*)
33+ (let ((entries (aref root (index root-bitlen (funcall hash key)))))
34+ (a.if (assoc key entries :test test)
35+ (values (cdr it) t)
36+ (values nil nil)))))
37+
38+(defun resize (dict)
39+ (declare #.*fastest* (dict dict))
40+ (with-slots (root root-bitlen next-resize-trigger hash) dict
41+ (let ((new-root (make-array (* (length root) 16) :initial-element nil))
42+ (new-root-bitlen (+ root-bitlen 4)))
43+ (declare (fixnum-length new-root-bitlen))
44+ (loop FOR entries ACROSS root
45+ DO
46+ (loop FOR e IN entries
47+ FOR index = (index new-root-bitlen (funcall hash (car e)))
48+ DO
49+ (push e (aref new-root index))))
50+ (setf next-resize-trigger (the positive-fixnum (* next-resize-trigger 16))
51+ root new-root
52+ root-bitlen new-root-bitlen))))
53+
54+(defun set (key value dict)
55+ (declare #.*interface* (dict dict))
56+ (with-slots (root root-bitlen count next-resize-trigger hash test) dict
57+ (let ((index (index root-bitlen (funcall hash key))))
58+ (multiple-value-bind (new-list added?) (acons! key value (aref root index) :test test)
59+ (when added?
60+ (setf (aref root index) new-list)
61+ (incf count)
62+ (when (= count next-resize-trigger)
63+ (resize dict))))))
64+ value)
65+
66+(defsetf get (key dict) (new-value)
67+ `(set ,key ,new-value ,dict))
68+
69+(defun remove (key dict)
70+ (declare #.*interface* (dict dict))
71+ (with-slots (root root-bitlen hash test count) dict
72+ (declare #.*fastest*)
73+ (let ((index (index root-bitlen (funcall hash key)))
74+ (exists? nil))
75+ (setf #1=(aref root index)
76+ (delete-if (lambda (e)
77+ (and (funcall test key (car e))
78+ (decf count)
79+ (setf exists? t)))
80+ (the list #1#)))
81+ exists?)))
82+
83+(defmacro each ((entry dict &optional result-form) &body body)
84+ (let ((entries (gensym)))
85+ `(loop FOR ,entries ACROSS (dict-root ,dict)
86+ DO
87+ (loop FOR ,entry IN ,entries
88+ DO
89+ (locally ,@body))
90+ FINALLY
91+ (return ,result-form))))
92+
93+(defun map (fn dict)
94+ (declare #.*interface*
95+ (dict dict)
96+ (function fn))
97+ (let ((acc '()))
98+ (each (e dict (nreverse acc))
99+ (push (funcall fn (car e) (cdr e)) acc))))
--- trunk/lisp/lib/dict-0.0.2/README (nonexistent)
+++ trunk/lisp/lib/dict-0.0.2/README (revision 55)
@@ -0,0 +1,35 @@
1+[概要]
2+・ハッシュテーブル
3+
4+[API]
5+= package# dict
6+ メインパッケージ
7+
8+= function# (make &key test hash) => dict
9+ ハッシュテーブルを作成する。
10+ - test: キーの等値性判定関数。デフォルトは#'eql。
11+ - hash: キーのハッシュ値算出関数。デフォルトは#'sxhash。
12+
13+= function# (count dict) => count
14+ ハッシュテーブルに格納されている要素数を取得する。
15+
16+= function# (get key dict) => (values value bool)
17+ キーに紐付く値を取得する。
18+ 該当する値がある場合は(values 値 t)が、ない場合は(values nil nil)が返る。
19+
20+= function# (setf (get key dict) new-value) => new-value
21+ キーに値を紐付ける。
22+ 既にキーがハッシュテーブル内に存在する場合は、その値が更新される。
23+ 存在しない場合は、キーと値が新たに追加される。
24+
25+= function# (remove key dict) => bool
26+ キーに対応する要素をハッシュテーブルから削除する。
27+ 該当する要素が存在していた場合はtを、そうでない場合はnilを返す。
28+
29+= function# (map fn dict) => list
30+ ハッシュテーブル内の各要素に関数fnを適用し、その結果をリストにして返す。
31+
32+= macro# (each (entry dict &optoinal result-form) &body body) => result-form
33+ ハッシュテーブル内の各要素を走査する。
34+ 走査中の要素がentryに束縛された状態で、bodyが実行される。
35+ 全ての走査が終了した後、result-formが実行され、その結果が式の返り値となる。
Show on old repository browser