]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex3_24.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ex3_24.rkt
1 #lang r5rs
2
3 (define error display)
4
5 (define (make-table same-key?)
6   (let ((local-table (list '*table*)))
7     (define (assoc key records)
8       (cond 
9         ((null? records) #f)
10         ((same-key? key (car (car records))) (car records))
11         (else (assoc key (cdr records)))))
12     
13     (define (lookup key-1 key-2)
14       (let ((subtable (assoc key-1 (cdr local-table))))
15         (if subtable
16             (let ((record (assoc key-2 (cdr subtable))))
17               (if record
18                   (cdr record)
19                   #f))
20             #f)))
21     (define (insert! key-1 key-2 value)
22       (let ((subtable (assoc key-1 (cdr local-table))))
23         (if subtable
24             (let ((record (assoc key-2 (cdr subtable))))
25               (if record
26                   (set-cdr! record value)
27                   (set-cdr! subtable
28                             (cons (cons key-2 value)
29                                   (cdr subtable)))))
30             (set-cdr! local-table 
31                       (cons (list key-1
32                                   (cons key-2 value))
33                             (cdr local-table)))))
34       'ok)
35     (define (dispatch m)
36       (cond
37         ((eq? m 'lookup-proc) lookup)
38         ((eq? m 'insert-proc!) insert!)
39         (else (error "Unknown operation -- TABLE"))))
40     dispatch))
41
42 ;(define operation-table (make-table equal?))
43 ;(define get (operation-table 'lookup-proc))
44 ;(define put (operation-table 'insert-proc!))
45
46 #|
47 > (define numeric-table 
48     (make-table (lambda (key-1 key-2) (< (abs (- key-2 key-1)) 2))))
49 > (define get-val (numeric-table 'lookup-proc))
50 > (define put-val (numeric-table 'insert-proc!))
51 > (put-val '1 1 1)
52 'ok
53 > (put-val '4 4 16)
54 'ok
55 > (get-val '4 4)
56 16
57 > (get-val '5 4)
58 16
59
60 |#