108 lines
3.4 KiB
Scheme
108 lines
3.4 KiB
Scheme
(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")
|
|
|