SICP/ex-3_24-xx.scm

(load "util.scm")

(display "example - tables\n")

(define (make-table same-key?)
  (define (assoc key records)
    (cond ((null? records) false)
          ((same-key? key (caar records)) (car records))
          (else (assoc key (cdr records)))))
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  false))
            false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table equal?))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

(put 'a 'b 'c)
(put 'd 'e 'f)
(assert (get 'd 'e) 'f)
(assert (get 'a 'b) 'c)

(display "\nex-3.24 - same-key?\n")

(define t (make-table (lambda (a b) (<= (abs (- a b)) 1))))
(define get (t 'lookup-proc))
(define put (t 'insert-proc!))

(put 4 2 42)
(assert (get 5 1) 42)
(assert (get 6 0) #f)


(display "\nex-3.25 - generalized tables\n")

(define (make-table same-key?)
  (define (assoc key records)
    (display "assoc ") (display key) (display " ") (display records) (newline)
    (cond ((null? records) false)
          ((same-key? key (caar records)) (car records))
          (else (assoc key (cdr records)))))
  (let ((local-table (list '*table*)))
    (define (lookup-generic . keys)
      (display keys) (newline)
      (lookup keys (cdr local-table)))
    (define (lookup keys subtable)
      (display "lookup ") (display keys) (display " ") (display subtable) (newline)
      (cond
        ((not subtable) #f)
        ((null? keys) (cdr subtable))
        (else (lookup (cdr keys) (assoc (car keys) subtable)))))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup-generic)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table equal?))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(put 'a 'b 'c)
(put 'd 'e 'f)
(assert (get 'd 'e) 'f)
;(assert (get 'a 'b) 'c)


(display "\nex-3.26\n")