source: project/release/4/lookup-table/trunk/lookup-table.scm @ 14484

Last change on this file since 14484 was 14484, checked in by Kon Lovett, 11 years ago

Save.

File size: 12.6 KB
Line 
1;;;; lookup-table.scm
2;;;; Kon Lovett, Apr '09
3
4(declare
5  (usual-integrations)
6  (disable-interrupts)
7  (fixnum)
8  (inline)
9  (local)
10  (no-procedure-checks) )
11
12(include "chicken-primitive-object-inlines")
13(include "chicken-primitive-alist")
14(include "chicken-primitive-srfi-9")
15(include "inline-type-checks")
16
17;;; Variant Dictionary
18
19(define-record-type/unsafe-inline-unchecked dict
20        (%make-dict data)
21        %dict?
22        (data %dict-data-ref %dict-data-set!)
23        (test %dict-test-ref %dict-test-set!)
24        (to-alist %dict->alist-ref %dict->alist-set!)
25        (ref %dict-ref-ref %dict-ref-set!)
26        (set %dict-set-ref %dict-set-set!)
27        (delete %dict-delete-ref %dict-delete-set!)
28        (for-each %dict-for-each-ref %dict-for-each-set!)
29        (merge %dict-merge-ref %dict-merge-set!)
30        (search %dict-search-ref %dict-search-set!)
31        (count %dict-count-ref %dict-count-set!)
32        (keys %dict-keys-ref %dict-keys-set!)
33        (values %dict-values-ref %dict-values-set!)
34        (exists %dict-exists-ref %dict-exists-set!) )
35
36(define-inline (%set-dict-procs! dict tst to ref set del for mrg sch cnt keys vals exsts)
37        (%dict-test-set! dict tst)
38        (%dict->alist-set! dict to)
39        (%dict-ref-set! dict ref)
40        (%dict-set-set! dict set)
41        (%dict-delete-set! dict del)
42        (%dict-for-each-set! dict for)
43        (%dict-merge-set! dict mrg)
44        (%dict-search-set! dict sch)
45        (%dict-count-set! dict cnt)
46        (%dict-keys-set! dict keys)
47        (%dict-values-set! dict vals)
48        (%dict-exists-set! dict exsts)
49        dict )
50
51(define-inline (%dict-test dict) ((%dict-test-ref dict) (%dict-data-ref dict)))
52(define-inline (%dict->alist dict) ((%dict->alist-ref dict) (%dict-data-ref dict)))
53(define-inline (%dict-ref dict key def) ((%dict-ref-ref dict) (%dict-data-ref dict) key def))
54(define-inline (%dict-set! dict key val) ((%dict-set-ref dict) (%dict-data-ref dict) key val))
55(define-inline (%dict-delete! dict key) ((%dict-delete-ref dict) (%dict-data-ref dict) key))
56(define-inline (%dict-for-each dict proc) ((%dict-for-each-ref dict) (%dict-data-ref dict) proc))
57(define-inline (%dict-merge dict1 dict2) ((%dict-merge-ref dict1) (%dict-data-ref dict1) (%dict-data-ref dict2)))
58(define-inline (%dict-search dict proc def) ((%dict-search-ref dict) (%dict-data-ref dict) proc def))
59(define-inline (%dict-count dict) ((%dict-count-ref dict) (%dict-data-ref dict)))
60(define-inline (%dict-keys dict) ((%dict-keys-ref dict) (%dict-data-ref dict)))
61(define-inline (%dict-values dict) ((%dict-values-ref dict) (%dict-data-ref dict)))
62(define-inline (%dict-exists? dict key) ((%dict-exists-ref dict) (%dict-data-ref dict) key))
63
64;; Association List
65
66(define-inline (%alist-dict-test data) (%car data))
67(define-inline (%alist-dict-alist data) (%cdr data))
68(define-inline (%alist-dict-alist-set! data al) (%set-cdr! data al))
69
70(define-inline (%set-alist-dict-procs! dict)
71        (%set-dict-procs! dict
72                alist-dict-test-ref
73                alist-dict->alist
74                alist-dict-ref
75                alist-dict-set
76                alist-dict-delete
77                alist-dict-for-each
78                alist-dict-merge
79                alist-dict-search
80                alist-dict-count
81                alist-dict-keys
82                alist-dict-values
83                alist-dict-exists?) )
84
85;; Hash Table
86
87(define-inline (%htable-dict-test data) (%car data))
88(define-inline (%htable-dict-htable data) (%cdr data))
89(define-inline (%htable-dict-htable-set! data ht) (%set-cdr! data ht))
90
91(define-inline (%set-htable-dict-procs! dict)
92        (%set-dict-procs! dict
93                htable-dict-test-ref
94                htable-dict->alist
95                htable-dict-ref
96                htable-dict-set
97                htable-dict-delete
98                htable-dict-for-each
99                htable-dict-merge
100                htable-dict-search
101                htable-dict-count
102                htable-dict-keys
103                htable-dict-values
104                htable-dict-exists?) )
105
106;; Dictionary Type
107
108(define-inline (%dict-same-kind? dict1 dict2)
109  (%eq? (%dict-test-ref dict1) (%dict-test-ref dict2)) )
110
111(define-inline (%dict-same-test? dict1 dict2) (%eq? (%dict-test dict1) (%dict-test dict2)))
112
113(define-inline (%dict-bestfit dict)
114        (if (%fx< MAGIC-LIMIT (%dict-count dict))
115      (unless (htable-dict? dict) (become-htable-dict dict))
116      (unless (alist-dict? dict) (become-alist-dict dict)) ) )
117
118;; Argument Checks
119
120(define-inline-check-type dict)
121
122(define-inline (%check-value loc obj)
123  (when (%undefined-value? obj) (error-argument-type loc obj "non-undefined value")) )
124
125;; Element count when hash-table faster
126;; (your milage may vary)
127
128(define-constant MAGIC-LIMIT 12)
129
130;;;
131
132(module lookup-table (;export
133  dict-safe-mode
134  make-dict
135  alist->dict
136  dict->alist
137  dict?
138  dict-equivalence-function
139  dict-count
140  dict-keys
141  dict-values
142  dict-ref
143  dict-set!
144  dict-exists?
145  dict-update!
146  dict-update-list!
147  dict-update-dict!
148  dict-delete!
149  dict-for-each
150  dict-search
151  dict-merge!
152  dict-print )
153
154(import scheme chicken srfi-1 srfi-69 ports data-structures extras miscmacros type-errors)
155(require-library srfi-1 srfi-69 extras miscmacros type-errors)
156
157;;;
158
159;; Argument validation & literal object return.
160
161(define *dict-safe-mode* #f)
162
163;;; Alist Dictionary
164
165(define (alist-dict-test-ref data) (%alist-dict-test data))
166
167(define (alist-dict->alist data)
168  (let ((dat (%alist-dict-alist data)))
169    (if *dict-safe-mode* (list-copy dat)
170        dat ) ) )
171
172(define (alist-dict-ref data key def)
173        (%alist-ref key (%alist-dict-alist data) (%alist-dict-test data) def) )
174
175(define (alist-dict-set data key obj)
176        (%alist-dict-alist-set!
177         data
178   (%alist-update! key obj (%alist-dict-alist data) (%alist-dict-test data))) )
179
180(define (alist-dict-delete data key)
181        (%alist-dict-alist-set!
182         data
183   (%alist-delete! key (%alist-dict-alist data) (%alist-dict-test data))) )
184
185(define (alist-dict-for-each data proc)
186        (%list-for-each/1 (lambda (cell) (proc (%car cell) (%cdr cell)))
187                          (%alist-dict-alist data)) )
188
189(define (alist-dict-merge data1 data2)
190        (let ((test (%alist-dict-test data1))
191              (al (%alist-dict-alist data1)))
192                (%list-for-each/1 (lambda (cell)
193                                    (set! al (%alist-update! (%car cell) (%cdr cell) al test)))
194                                        (%alist-dict-alist data2))
195                (%alist-dict-alist-set! data1 al) ) )
196
197(define (alist-dict-search data proc def) (%alist-find proc (%alist-dict-alist data) def))
198
199(define (alist-dict-count data) (%length (%alist-dict-alist data)))
200
201(define (alist-dict-keys data) (%list-map/1 (lambda (x) (%car x)) (%alist-dict-alist data)))
202
203(define (alist-dict-values data) (%list-map/1 (lambda (x) (%cdr x)) (%alist-dict-alist data)))
204
205(define (alist-dict-exists? data key)
206        (not (%undefined-value? (alist-dict-ref data key (%undefined-value)))) )
207
208(define (make-alist-dict test al) (%set-alist-dict-procs! (%make-dict (%cons test al))))
209
210(define (alist-dict? dict) (%eq? alist-dict-test-ref (%dict-test dict)))
211
212(define (become-alist-dict dict)
213        (%dict-data-set! dict (%cons (%dict-test dict) (%dict->alist dict)))
214        (%set-alist-dict-procs! dict) )
215
216;;; Hash-table Dictionary
217
218(define (htable-dict-test-ref data) (%htable-dict-test data))
219
220(define (htable-dict->alist data) (hash-table->alist (%htable-dict-htable data)))
221
222(define (htable-dict-ref data key def)
223        (hash-table-ref/default (%htable-dict-htable data) key def) )
224
225(define (htable-dict-set data key obj)
226        (hash-table-set! (%htable-dict-htable data) key obj) )
227
228(define (htable-dict-delete data key)
229        (hash-table-delete! (%htable-dict-htable data) key) )
230
231(define (htable-dict-for-each data proc)
232        (hash-table-for-each (%htable-dict-htable data) proc) )
233
234(define (htable-dict-merge data1 data2)
235        (%htable-dict-htable-set!
236         data1
237         (hash-table-merge! (%htable-dict-htable data1) (%htable-dict-htable data2))) )
238
239(define (htable-dict-search data proc def)
240        (let ((ht (%htable-dict-htable data))
241                                (ret #f))
242                (let ((res (let/cc return
243                 (hash-table-walk ht
244                   (lambda (key val)
245                     (when (proc key val)
246                       (set! ret #t)
247                       (return val)))))))
248                        (if ret res def) ) ) )
249
250(define (htable-dict-count data) (hash-table-size (%htable-dict-htable data)))
251
252(define (htable-dict-keys data) (hash-table-keys (%htable-dict-htable data)))
253
254(define (htable-dict-values data) (hash-table-values (%htable-dict-htable data)))
255
256(define (htable-dict-exists? data key)
257        (hash-table-exists? (%htable-dict-htable data) key) )
258
259(define (make-htable-dict test ht) (%set-htable-dict-procs! (%make-dict (%cons test ht))))
260
261(define (htable-dict? dict) (%eq? htable-dict-test-ref (%dict-test dict)))
262
263(define (become-htable-dict dict)
264        (let ((test (%dict-test dict)))
265                (%dict-data-set! dict (%cons test (alist->hash-table (%dict->alist dict) test))))
266        (%set-htable-dict-procs! dict) )
267
268;; Errors
269
270(define-error-type dict)
271
272;;
273
274(define (*dict-print dict)
275  ((rec (print-node-table dict spcr)
276    (%dict-for-each dict
277      (lambda (key val)
278        (%list-for-each/1 display spcr)
279        (cond ((%dict? val)
280                (write key) (display " :") (newline)
281                (print-node-table val (%cons "  " spcr)))
282              (else
283                (write key) (display " : ") (pretty-print val))))))
284    dict '()) )
285
286(define (*dict-update! dict key valu-func updt-func curr loc)
287  (let ((val (updt-func
288              (if (not (%undefined-value? curr)) curr
289                  (let ((val (valu-func)))
290                    (when *dict-safe-mode* (%check-value loc val))
291                    val ) ) ) ) )
292    (%dict-set! dict key val)
293    val ) )
294
295(define (+dict-update! dict key valu-func updt-func loc)
296  (when *dict-safe-mode*
297    (%check-dict loc dict)
298    (%check-procedure loc valu-func)
299    (%check-procedure loc updt-func) )
300  (let* ((curr (%dict-ref dict key (%undefined-value)))
301         (updt (*dict-update! dict key valu-func updt-func curr loc)))
302    (unless (%undefined-value? curr) (%dict-bestfit dict))
303    updt ) )
304
305;;; Globals
306
307(define-parameter dict-safe-mode *dict-safe-mode*
308  (lambda (x)
309    (set! *dict-safe-mode* x)
310    x))
311
312(define (make-dict #!optional (test eq?) (size 0))
313  (when *dict-safe-mode*
314    (%check-cardinal-fixnum 'make-dict size "size")
315    (%check-procedure 'make-dict test) )
316        (if (%fx< MAGIC-LIMIT size)
317      (make-htable-dict test (make-hash-table test))
318      (make-alist-dict test '())) )
319
320(define (alist->dict al #!optional (test eq?) (size 0))
321  (when *dict-safe-mode*
322    (%check-cardinal-fixnum 'alist->dict size "size")
323    (%check-procedure 'alist->dict test) )
324        (if (or (%fx< MAGIC-LIMIT size) (%fx< MAGIC-LIMIT (%length al)))
325      (make-htable-dict test (alist->hash-table al test))
326      (make-alist-dict test al)) )
327
328(define (dict->alist dict)
329  (when *dict-safe-mode* (%check-dict 'dict->alist dict))
330        (%dict->alist dict) )
331
332(define (dict? obj) (%dict? obj))
333
334(define (dict-equivalence-function dict)
335  (when *dict-safe-mode* (%check-dict 'dict-equivalence-function dict))
336        (%dict-test dict) )
337
338(define (dict-count dict)
339  (when *dict-safe-mode* (%check-dict 'dict-count dict))
340        (%dict-count dict) )
341
342(define (dict-keys dict)
343  (when *dict-safe-mode* (%check-dict 'dict-keys dict))
344        (%dict-keys dict) )
345
346(define (dict-values dict)
347  (when *dict-safe-mode* (%check-dict 'dict-values dict))
348        (%dict-values dict) )
349
350(define (dict-ref dict key . def)
351  (when *dict-safe-mode* (%check-dict 'dict-ref dict))
352        (%dict-ref dict key (optional def #f)) )
353
354(define (dict-set! dict key obj)
355  (when *dict-safe-mode*
356    (%check-value 'dict-set! obj)
357    (%check-dict 'dict-set! dict) )
358        (%dict-set! dict key obj)
359        (%dict-bestfit dict) )
360
361(define (dict-exists? dict key)
362  (when *dict-safe-mode* (%check-dict 'dict-exists? dict))
363  (%dict-exists? dict key) )
364
365(define (dict-update! dict key valu-func #!optional (updt-func identity))
366        (+dict-update! dict key valu-func updt-func 'dict-update!) )
367
368(define (dict-update-list! dict key . vals)
369  (+dict-update! dict key (lambda () '()) (cut fold cons <> (reverse! vals)) 'dict-update-list!) )
370
371(define (dict-update-dict! dict key)
372  (+dict-update! dict key (cut make-dict) identity 'dict-update-dict!) )
373
374(define (dict-delete! dict key)
375  (when *dict-safe-mode* (%check-dict 'dict-delete! dict))
376        (%dict-delete! dict key)
377        (%dict-bestfit dict) )
378
379(define (dict-for-each dict proc)
380  (when *dict-safe-mode*
381    (%check-dict 'dict-for-each dict)
382    (%check-procedure 'dict-for-each proc) )
383        (%dict-for-each dict proc) )
384
385(define (dict-search dict proc . def)
386  (when *dict-safe-mode*
387    (%check-dict 'dict-search dict)
388    (%check-procedure 'dict-search proc) )
389        (%dict-search dict proc (optional def #f)) )
390
391(define (dict-merge! dict . dicts)
392  (when *dict-safe-mode* (%check-dict 'dict-merge! dict))
393        (%list-for-each/1
394                (lambda (dictx)
395      (when *dict-safe-mode*
396        (%check-dict 'dict-merge! dictx)
397        (unless (%dict-same-test? dict dictx)
398          (error "cannot merge lookup-tables; incompatible test") ) )
399                        (if (%dict-same-kind? dict dictx) (%dict-merge dict dictx)
400          (%dict-for-each dictx (cut %dict-set! dict <> <>)) ) )
401                dicts)
402        (%dict-bestfit dict) )
403
404(define (dict-print dict #!optional port)
405  (if (not port) (*dict-print dict)
406      (with-output-to-port port (lambda () (*dict-print dict)) ) ) )
407
408) ;module lookup-table
Note: See TracBrowser for help on using the repository browser.