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

Last change on this file since 14485 was 14485, checked in by Kon Lovett, 10 years ago

Save.

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