1;; Copyright (C) Panu Kalliokoski (2005). All Rights Reserved.
2;;
3;; Permission is hereby granted, free of charge, to any person obtaining a
4;; copy of this software and associated documentation files (the
5;; "Software"), to deal in the Software without restriction, including
6;; without limitation the rights to use, copy, modify, merge, publish,
7;; distribute, sublicense, and/or sell copies of the Software, and to
8;; permit persons to whom the Software is furnished to do so, subject to
9;; the following conditions:
10;;
11;; The above copyright notice and this permission notice shall be included
12;; in all copies or substantial portions of the Software.
13;;
14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
15;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22;; Latest sources:
23;;
24;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/hash-srfi.ss
25;; http://members.sange.fi/~atehwa/vc/r+d/guse/srfi/test-hash.ss
26
27
28;; ChangeLog
29;;
30;; 2007-07-23 yamaken   - Imported from
31;;                        http://srfi.schemers.org/srfi-69/srfi-69.html
32;;                        and adapted to SigScheme
33
34
35;;
36;; SigScheme adaptation
37;;
38
39(require-extension (srfi 9 23))
40
41(define inexact? (lambda (x) #f))
42(define real?    inexact?)
43
44(define expt
45  (lambda (x y)
46    (let rec ((res 1)
47              (cnt y))
48      (if (zero? cnt)
49          res
50          (rec (* res x) (- cnt 1))))))
51
52;;
53;; Main implementation
54;;
55
56;; This implementation relies on SRFI-9 for distinctness of the hash table
57;; type, and on SRFI-23 for error reporting.  Otherwise, the implementation
58;; is pure R5RS.
59
60(define *default-bound* (- (expt 2 29) 3))
61
62(define (%string-hash s ch-conv bound)
63  (let ((hash 31)
64	(len (string-length s)))
65    (do ((index 0 (+ index 1)))
66      ((>= index len) (modulo hash bound))
67      (set! hash (modulo (+ (* 37 hash)
68			    (char->integer (ch-conv (string-ref s index))))
69			 *default-bound*)))))
70
71(define (string-hash s . maybe-bound)
72  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
73    (%string-hash s (lambda (x) x) bound)))
74
75(define (string-ci-hash s . maybe-bound)
76  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
77    (%string-hash s char-downcase bound)))
78
79(define (symbol-hash s . maybe-bound)
80  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
81    (%string-hash (symbol->string s) (lambda (x) x) bound)))
82
83(define (hash obj . maybe-bound)
84  (let ((bound (if (null? maybe-bound) *default-bound* (car maybe-bound))))
85    (cond ((integer? obj) (modulo obj bound))
86	  ((string? obj) (string-hash obj bound))
87	  ((symbol? obj) (symbol-hash obj bound))
88	  ((real? obj) (modulo (+ (numerator obj) (denominator obj)) bound))
89	  ((number? obj)
90	   (modulo (+ (hash (real-part obj)) (* 3 (hash (imag-part obj))))
91		   bound))
92	  ((char? obj) (modulo (char->integer obj) bound))
93	  ((vector? obj) (vector-hash obj bound))
94	  ((pair? obj) (modulo (+ (hash (car obj)) (* 3 (hash (cdr obj))))
95			       bound))
96	  ((null? obj) 0)
97	  ((not obj) 0)
98	  ((procedure? obj) (error "hash: procedures cannot be hashed" obj))
99	  (else 1))))
100
101(define hash-by-identity hash)
102
103(define (vector-hash v bound)
104  (let ((hashvalue 571)
105	(len (vector-length v)))
106    (do ((index 0 (+ index 1)))
107      ((>= index len) (modulo hashvalue bound))
108      (set! hashvalue (modulo (+ (* 257 hashvalue) (hash (vector-ref v index)))
109			      *default-bound*)))))
110
111(define %make-hash-node cons)
112(define %hash-node-set-value! set-cdr!)
113(define %hash-node-key car)
114(define %hash-node-value cdr)
115
116(define-record-type <srfi-hash-table>
117  (%make-hash-table size hash compare associate entries)
118  hash-table?
119  (size hash-table-size hash-table-set-size!)
120  (hash hash-table-hash-function)
121  (compare hash-table-equivalence-function)
122  (associate hash-table-association-function)
123  (entries hash-table-entries hash-table-set-entries!))
124
125(define *default-table-size* 64)
126
127(define (appropriate-hash-function-for comparison)
128  (or (and (eq? comparison eq?) hash-by-identity)
129      (and (eq? comparison string=?) string-hash)
130      (and (eq? comparison string-ci=?) string-ci-hash)
131      hash))
132
133(define (make-hash-table . args)
134  (let* ((comparison (if (null? args) equal? (car args)))
135	 (hash
136	   (if (or (null? args) (null? (cdr args)))
137	     (appropriate-hash-function-for comparison) (cadr args)))
138	 (size
139	   (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
140	     *default-table-size* (caddr args)))
141	 (association
142	   (or (and (eq? comparison eq?) assq)
143	       (and (eq? comparison eqv?) assv)
144	       (and (eq? comparison equal?) assoc)
145	       (letrec
146		 ((associate
147		    (lambda (val alist)
148		      (cond ((null? alist) #f)
149			    ((comparison val (caar alist)) (car alist))
150			    (else (associate val (cdr alist)))))))
151		 associate))))
152    (%make-hash-table 0 hash comparison association (make-vector size '()))))
153
154(define (make-hash-table-maker comp hash)
155  (lambda args (apply make-hash-table (cons comp (cons hash args)))))
156(define make-symbol-hash-table
157  (make-hash-table-maker eq? symbol-hash))
158(define make-string-hash-table
159  (make-hash-table-maker string=? string-hash))
160(define make-string-ci-hash-table
161  (make-hash-table-maker string-ci=? string-ci-hash))
162(define make-integer-hash-table
163  (make-hash-table-maker = modulo))
164
165(define (%hash-table-hash hash-table key)
166  ((hash-table-hash-function hash-table)
167     key (vector-length (hash-table-entries hash-table))))
168
169(define (%hash-table-find entries associate hash key)
170  (associate key (vector-ref entries hash)))
171
172(define (%hash-table-add! entries hash key value)
173  (vector-set! entries hash
174	       (cons (%make-hash-node key value)
175		     (vector-ref entries hash))))
176
177(define (%hash-table-delete! entries compare hash key)
178  (let ((entrylist (vector-ref entries hash)))
179    (cond ((null? entrylist) #f)
180	  ((compare key (caar entrylist))
181	   (vector-set! entries hash (cdr entrylist)) #t)
182	  (else
183	    (let loop ((current (cdr entrylist)) (previous entrylist))
184	      (cond ((null? current) #f)
185		    ((compare key (caar current))
186		     (set-cdr! previous (cdr current)) #t)
187		    (else (loop (cdr current) current))))))))
188
189(define (%hash-table-walk proc entries)
190  (do ((index (- (vector-length entries) 1) (- index 1)))
191    ((< index 0)) (for-each proc (vector-ref entries index))))
192
193(define (%hash-table-maybe-resize! hash-table)
194  (let* ((old-entries (hash-table-entries hash-table))
195	 (hash-length (vector-length old-entries)))
196    (if (> (hash-table-size hash-table) hash-length)
197      (let* ((new-length (* 2 hash-length))
198	     (new-entries (make-vector new-length '()))
199	     (hash (hash-table-hash-function hash-table)))
200	(%hash-table-walk
201	  (lambda (node)
202	    (%hash-table-add! new-entries
203			      (hash (%hash-node-key node) new-length)
204			      (%hash-node-key node) (%hash-node-value node)))
205	  old-entries)
206	(hash-table-set-entries! hash-table new-entries)))))
207
208(define (hash-table-ref hash-table key . maybe-default)
209  (cond ((%hash-table-find (hash-table-entries hash-table)
210			   (hash-table-association-function hash-table)
211			   (%hash-table-hash hash-table key) key)
212	 => %hash-node-value)
213	((null? maybe-default)
214	 (error "hash-table-ref: no value associated with" key))
215	(else ((car maybe-default)))))
216
217(define (hash-table-ref/default hash-table key default)
218  (hash-table-ref hash-table key (lambda () default)))
219
220(define (hash-table-set! hash-table key value)
221  (let ((hash (%hash-table-hash hash-table key))
222	(entries (hash-table-entries hash-table)))
223    (cond ((%hash-table-find entries
224			     (hash-table-association-function hash-table)
225			     hash key)
226	   => (lambda (node) (%hash-node-set-value! node value)))
227	  (else (%hash-table-add! entries hash key value)
228		(hash-table-set-size! hash-table
229				       (+ 1 (hash-table-size hash-table)))
230		(%hash-table-maybe-resize! hash-table)))))
231
232(define (hash-table-update! hash-table key function . maybe-default)
233  (let ((hash (%hash-table-hash hash-table key))
234	(entries (hash-table-entries hash-table)))
235    (cond ((%hash-table-find entries
236			     (hash-table-association-function hash-table)
237			     hash key)
238	   => (lambda (node)
239	        (%hash-node-set-value!
240		  node (function (%hash-node-value node)))))
241	  ((null? maybe-default)
242	   (error "hash-table-update!: no value exists for key" key))
243	  (else (%hash-table-add! entries hash key
244				  (function ((car maybe-default))))
245		(hash-table-set-size! hash-table
246				       (+ 1 (hash-table-size hash-table)))
247		(%hash-table-maybe-resize! hash-table)))))
248
249(define (hash-table-update!/default hash-table key function default)
250  (hash-table-update! hash-table key function (lambda () default)))
251
252(define (hash-table-delete! hash-table key)
253  (if (%hash-table-delete! (hash-table-entries hash-table)
254			   (hash-table-equivalence-function hash-table)
255			   (%hash-table-hash hash-table key) key)
256    (hash-table-set-size! hash-table (- (hash-table-size hash-table) 1))))
257
258(define (hash-table-exists? hash-table key)
259  (and (%hash-table-find (hash-table-entries hash-table)
260			 (hash-table-association-function hash-table)
261			 (%hash-table-hash hash-table key) key) #t))
262
263(define (hash-table-walk hash-table proc)
264  (%hash-table-walk
265    (lambda (node) (proc (%hash-node-key node) (%hash-node-value node)))
266    (hash-table-entries hash-table)))
267
268(define (hash-table-fold hash-table f acc)
269  (hash-table-walk hash-table
270		       (lambda (key value) (set! acc (f key value acc))))
271  acc)
272
273(define (alist->hash-table alist . args)
274  (let* ((comparison (if (null? args) equal? (car args)))
275	 (hash
276	   (if (or (null? args) (null? (cdr args)))
277	     (appropriate-hash-function-for comparison) (cadr args)))
278	 (size
279	   (if (or (null? args) (null? (cdr args)) (null? (cddr args)))
280	     (max *default-table-size* (* 2 (length alist))) (caddr args)))
281	 (hash-table (make-hash-table comparison hash size)))
282    (for-each
283      (lambda (elem)
284	(hash-table-update!/default
285	  hash-table (car elem) (lambda (x) x) (cdr elem)))
286      alist)
287    hash-table))
288
289(define (hash-table->alist hash-table)
290  (hash-table-fold hash-table
291		   (lambda (key val acc) (cons (cons key val) acc)) '()))
292
293(define (hash-table-copy hash-table)
294  (let ((new (make-hash-table (hash-table-equivalence-function hash-table)
295  			      (hash-table-hash-function hash-table)
296			      (max *default-table-size*
297				   (* 2 (hash-table-size hash-table))))))
298    (hash-table-walk hash-table
299		     (lambda (key value) (hash-table-set! new key value)))
300    new))
301
302(define (hash-table-merge! hash-table1 hash-table2)
303  (hash-table-walk
304    hash-table2
305    (lambda (key value) (hash-table-set! hash-table1 key value)))
306  hash-table1)
307
308(define (hash-table-keys hash-table)
309  (hash-table-fold hash-table (lambda (key val acc) (cons key acc)) '()))
310
311(define (hash-table-values hash-table)
312  (hash-table-fold hash-table (lambda (key val acc) (cons val acc)) '()))
313