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

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

Save of prim ver.

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