source: project/release/4/lookup-table/branches/primitive/lookup-table.scm @ 14514

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

Rename of basic ops.

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