source: project/release/3/lookup-table/tags/1.7.1/lookup-table.scm @ 13885

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

Renamed to canonical style - explicit inlines a '%', internal otherwise '*' & '+'.

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