felixm
/
SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement 3.24 and start with 3.25

main
Felix Martin 2020-12-21 16:06:33 -05:00
parent d1c5b4bcb1
commit 050afa49b2
1 changed files with 104 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
ex-3_24-xx.scm
View File

@ -1,4 +1,107 @@
(load "util.scm")
(display "\nex-3.24\n")
(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")