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 |#