Update to include up to 2.74
This commit is contained in:
Oliver Payne
parent
7049dafa50
commit
a72f7f9b7c
|
|
@ -0,0 +1,133 @@
|
|||
#lang sicp
|
||||
|
||||
(define (deriv exp var)
|
||||
(cond ((number? exp) 0)
|
||||
((variable? exp)
|
||||
(if (same-variable? exp var) 1 0))
|
||||
((sum? exp)
|
||||
(make-sum (deriv (addend exp) var)
|
||||
(deriv (augend exp) var)))
|
||||
((product? exp)
|
||||
(make-sum
|
||||
(make-product (multiplier exp)
|
||||
(deriv (multiplicand exp) var))
|
||||
(make-product (deriv (multiplier exp) var)
|
||||
(multiplicand exp))))
|
||||
((exponentiation? exp) ;;(make-product (exponent exp) (deriv (base exp) var))
|
||||
(let ((e (exponent exp))
|
||||
(b (base exp)))
|
||||
(make-product e
|
||||
(make-product
|
||||
(make-exponentiation b (- e 1))
|
||||
(deriv b var)))))
|
||||
(else
|
||||
(error "unknown expression type -- DERIV" exp))))
|
||||
|
||||
;; representing algebraic expressions
|
||||
|
||||
(define (variable? x) (symbol? x))
|
||||
|
||||
(define (same-variable? v1 v2)
|
||||
(and (variable? v1) (variable? v2) (eq? v1 v2)))
|
||||
|
||||
;;(define (make-sum a1 a2) (list '+ a1 a2))
|
||||
|
||||
;;(define (make-product m1 m2) (list '* m1 m2))
|
||||
|
||||
(define (more-than-2-terms x) (pair? (cdddr x)))
|
||||
|
||||
;;(define (sum? x)
|
||||
;; (and (pair? x) (eq? (car x) '+)))
|
||||
;;
|
||||
;;(define (addend s) (cadr s))
|
||||
;;
|
||||
;;(define (augend s)
|
||||
;; (if (more-than-2-terms s)
|
||||
;; (cons '+ (cddr s))
|
||||
;; (caddr s)))
|
||||
;;
|
||||
;;(define (product? x)
|
||||
;; (and (pair? x) (eq? (car x) '*)))
|
||||
;;
|
||||
;;(define (multiplier p) (cadr p))
|
||||
;;
|
||||
;;(define (multiplicand p)
|
||||
;; (if (more-than-2-terms p)
|
||||
;; (cons '* (cddr p))
|
||||
;; (caddr p)))
|
||||
|
||||
|
||||
;: (deriv '(+ x 3) 'x)
|
||||
;: (deriv '(* x y) 'x)
|
||||
;: (deriv '(* (* x y) (+ x 3)) 'x)
|
||||
|
||||
|
||||
;; With simplification
|
||||
|
||||
;;(define (make-sum a1 a2)
|
||||
;; (cond ((=number? a1 0) a2)
|
||||
;; ((=number? a2 0) a1)
|
||||
;; ((and (number? a1) (number? a2)) (+ a1 a2))
|
||||
;; (else (list '+ a1 a2))))
|
||||
|
||||
(define (=number? exp num)
|
||||
(and (number? exp) (= exp num)))
|
||||
|
||||
;;(define (make-product m1 m2)
|
||||
;; (cond ((or (=number? m1 0) (=number? m2 0)) 0)
|
||||
;; ((=number? m1 1) m2)
|
||||
;; ((=number? m2 1) m1)
|
||||
;; ((and (number? m1) (number? m2)) (* m1 m2))
|
||||
;; (else (list '* m1 m2))))
|
||||
|
||||
|
||||
;; Exercise 2.56
|
||||
|
||||
(define (make-exponentiation b p)
|
||||
(cond ((=number? p 0) 1)
|
||||
((=number? p 1) b)
|
||||
((and (number? b) (number? p)) (expt b p))
|
||||
(else (list '** b p))))
|
||||
|
||||
(define (base e) (cadr e))
|
||||
(define (exponent e) (caddr e))
|
||||
|
||||
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
|
||||
|
||||
|
||||
;; Exercise 2.58
|
||||
|
||||
(define (make-sum a1 a2)
|
||||
(cond ((=number? a1 0) a2)
|
||||
((=number? a2 0) a1)
|
||||
((and (number? a1) (number? a2)) (+ a1 a2))
|
||||
((product? a2) (list a1 '+ (multiplier a2) '* (multiplicand a2)))
|
||||
(else (list a1 '+ a2))))
|
||||
|
||||
(define (make-product m1 m2)
|
||||
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
|
||||
((=number? m1 1) m2)
|
||||
((=number? m2 1) m1)
|
||||
((and (number? m1) (number? m2)) (* m1 m2))
|
||||
(else (list m1 '* m2))))
|
||||
|
||||
(define (sum? x)
|
||||
(and (pair? x) (eq? (cadr x) '+)))
|
||||
|
||||
(define (addend s) (car s))
|
||||
|
||||
;; Special case of multiplication distributing across addition. It
|
||||
;; should be possible to rewrite augend and/or multiplicand to deal
|
||||
;; with this case
|
||||
|
||||
(define (augend s)
|
||||
(if (product? (cddr s))
|
||||
(cddr s)
|
||||
(caddr s)))
|
||||
|
||||
(define (product? x)
|
||||
(and (pair? x) (eq? (cadr x) '*)))
|
||||
|
||||
(define (multiplier p) (car p))
|
||||
|
||||
(define (multiplicand p) (caddr p))
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
#lang sicp
|
||||
|
||||
|
||||
;;(define (element-of-set? x set)
|
||||
;; (cond ((null? set) false)
|
||||
;; ((equal? x (car set)) true)
|
||||
;; (else (element-of-set? x (cdr set)))))
|
||||
|
||||
;;(define (adjoin-set x set)
|
||||
;; (if (element-of-set? x set)
|
||||
;; set
|
||||
;; (cons x set)))
|
||||
|
||||
;;(define (intersection-set set1 set2)
|
||||
;; (cond ((or (null? set1) (null? set2)) '())
|
||||
;; ((element-of-set? (car set1) set2)
|
||||
;; (cons (car set1)
|
||||
;; (intersection-set (cdr set1) set2)))
|
||||
;; (else (intersection-set (cdr set1) set2))))
|
||||
|
||||
|
||||
;;(define (union-set set1 set2)
|
||||
;; (cond ((null? set1) set2)
|
||||
;; ((null? set2) set1)
|
||||
;; ((not (element-of-set? (car set1) set2))
|
||||
;; (cons (car set1) (union-set (cdr set1) set2)))
|
||||
;; (else (union-set (cdr set1) set2))))
|
||||
|
||||
;; With duplicates
|
||||
|
||||
;;(define (adjoin-set x set) (cons x set))
|
||||
|
||||
;;(define (union-set set1 set2) (append set1 set2))
|
||||
|
||||
;; Efficiency is dependent on the number duplicates in the underlying list
|
||||
;; This increases with each operation. For smaller numbers of duplicates
|
||||
;; adjoin and union should be much cheaper than the no-duplicate versions.
|
||||
|
||||
;; ORDERED
|
||||
|
||||
(define (element-of-set? x set)
|
||||
(cond ((null? set) false)
|
||||
((= x (car set)) true)
|
||||
((< x (car set)) false)
|
||||
(else (element-of-set? x (cdr set)))))
|
||||
|
||||
(define (intersection-set set1 set2)
|
||||
(if (or (null? set1) (null? set2))
|
||||
'()
|
||||
(let ((x1 (car set1)) (x2 (car set2)))
|
||||
(cond ((= x1 x2)
|
||||
(cons x1
|
||||
(intersection-set (cdr set1)
|
||||
(cdr set2))))
|
||||
((< x1 x2)
|
||||
(intersection-set (cdr set1) set2))
|
||||
((< x2 x1)
|
||||
(intersection-set set1 (cdr set2)))))))
|
||||
|
||||
(define (adjoin-set x set)
|
||||
(cond ((null? set) (list x))
|
||||
((equal? x (car set)) set)
|
||||
((< x (car set)) (cons x set))
|
||||
(else (adjoin-set x (cdr set)))))
|
||||
|
||||
(define (union-set set1 set2)
|
||||
(cond ((null? set1) set2)
|
||||
((null? set2) set1)
|
||||
(else
|
||||
(let ((x1 (car set1))
|
||||
(x2 (car set2)))
|
||||
(cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
|
||||
((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
|
||||
(else (cons x2 (union-set set1 (cdr set2)))))))))
|
||||
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
#lang sicp
|
||||
|
||||
;; BINARY TREES
|
||||
(define (entry tree) (car tree))
|
||||
|
||||
(define (left-branch tree) (cadr tree))
|
||||
|
||||
(define (right-branch tree) (caddr tree))
|
||||
|
||||
(define (make-tree entry left right)
|
||||
(list entry left right))
|
||||
|
||||
(define (element-of-set? x set)
|
||||
(cond ((null? set) false)
|
||||
((= x (entry set)) true)
|
||||
((< x (entry set))
|
||||
(element-of-set? x (left-branch set)))
|
||||
((> x (entry set))
|
||||
(element-of-set? x (right-branch set)))))
|
||||
|
||||
(define (adjoin-set x set)
|
||||
(cond ((null? set) (make-tree x '() '()))
|
||||
((= x (entry set)) set)
|
||||
((< x (entry set))
|
||||
(make-tree (entry set)
|
||||
(adjoin-set x (left-branch set))
|
||||
(right-branch set)))
|
||||
((> x (entry set))
|
||||
(make-tree (entry set)
|
||||
(left-branch set)
|
||||
(adjoin-set x (right-branch set))))))
|
||||
|
||||
;; Ordered
|
||||
(define (intersection-ordered-list set1 set2)
|
||||
(if (or (null? set1) (null? set2))
|
||||
'()
|
||||
(let ((x1 (car set1)) (x2 (car set2)))
|
||||
(cond ((= x1 x2)
|
||||
(cons x1
|
||||
(intersection-ordered-list (cdr set1)
|
||||
(cdr set2))))
|
||||
((< x1 x2)
|
||||
(intersection-ordered-list (cdr set1) set2))
|
||||
((< x2 x1)
|
||||
(intersection-ordered-list set1 (cdr set2)))))))
|
||||
|
||||
(define (union-ordered-list set1 set2)
|
||||
(cond ((null? set1) set2)
|
||||
((null? set2) set1)
|
||||
(else
|
||||
(let ((x1 (car set1))
|
||||
(x2 (car set2)))
|
||||
(cond ((= x1 x2) (cons x1 (union-ordered-list (cdr set1) (cdr set2))))
|
||||
((< x1 x2) (cons x1 (union-ordered-list (cdr set1) set2)))
|
||||
(else (cons x2 (union-ordered-list set1 (cdr set2)))))))))
|
||||
|
||||
|
||||
;; EXERCISE 2.63
|
||||
(define (tree->list-1 tree)
|
||||
(if (null? tree)
|
||||
'()
|
||||
(append (tree->list-1 (left-branch tree))
|
||||
(cons (entry tree)
|
||||
(tree->list-1 (right-branch tree))))))
|
||||
|
||||
(define (tree->list-2 tree)
|
||||
(define (copy-to-list tree result-list)
|
||||
(if (null? tree)
|
||||
result-list
|
||||
(copy-to-list (left-branch tree)
|
||||
(cons (entry tree)
|
||||
(copy-to-list (right-branch tree)
|
||||
result-list)))))
|
||||
(copy-to-list tree '()))
|
||||
|
||||
(define (list->tree elements)
|
||||
(car (partial-tree elements (length elements))))
|
||||
|
||||
(define (partial-tree elts n)
|
||||
(if (= n 0)
|
||||
(cons '() elts)
|
||||
(let ((left-size (quotient (- n 1) 2)))
|
||||
(let ((left-result (partial-tree elts left-size)))
|
||||
(let ((left-tree (car left-result))
|
||||
(non-left-elts (cdr left-result))
|
||||
(right-size (- n (+ left-size 1))))
|
||||
(let ((this-entry (car non-left-elts))
|
||||
(right-result (partial-tree (cdr non-left-elts)
|
||||
right-size)))
|
||||
(let ((right-tree (car right-result))
|
||||
(remaining-elts (cdr right-result)))
|
||||
(cons (make-tree this-entry left-tree right-tree)
|
||||
remaining-elts))))))))
|
||||
|
||||
(define tree1
|
||||
(make-tree 7
|
||||
(make-tree 3
|
||||
(make-tree 1 '() '())
|
||||
(make-tree 5 '() '()))
|
||||
(make-tree 9
|
||||
'()
|
||||
(make-tree 11 '() '()))))
|
||||
|
||||
(define tree2
|
||||
(make-tree 3
|
||||
(make-tree 1 '() '())
|
||||
(make-tree 7
|
||||
(make-tree 5 '() '())
|
||||
(make-tree 9
|
||||
'()
|
||||
(make-tree 11 '() '())))))
|
||||
|
||||
(define tree3
|
||||
(make-tree 5
|
||||
(make-tree 3
|
||||
(make-tree 1 '() '())
|
||||
'())
|
||||
(make-tree 9
|
||||
(make-tree 7 '() '())
|
||||
(make-tree 11 '() '()))))
|
||||
|
||||
(define tree4
|
||||
(make-tree 1 '()
|
||||
(make-tree 3 '()
|
||||
(make-tree 5 '()
|
||||
(make-tree 7 '()
|
||||
(make-tree 9 '()
|
||||
(make-tree 11 '() '())))))))
|
||||
|
||||
(define set1 (list->tree '(1 2 3 4)))
|
||||
(define set2 (list->tree '(3 4 5 6)))
|
||||
|
||||
;; 2.65
|
||||
|
||||
;; list->tree and tree->list-2 are O(n). So are intersection and union for
|
||||
;; ordered lists. So the following are O(n).
|
||||
(define (intersection-set set1 set2)
|
||||
(list->tree
|
||||
(intersection-ordered-list
|
||||
(tree->list-2 set1)
|
||||
(tree->list-2 set2))))
|
||||
|
||||
(define (union-set set1 set2)
|
||||
(list->tree
|
||||
(union-ordered-list
|
||||
(tree->list-2 set1)
|
||||
(tree->list-2 set2))))
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
#lang sicp
|
||||
|
||||
(define (entry tree) (car tree))
|
||||
|
||||
(define (left-branch tree) (cadr tree))
|
||||
|
||||
(define (right-branch tree) (caddr tree))
|
||||
|
||||
(define (make-tree entry left right)
|
||||
(list entry left right))
|
||||
|
||||
(define (element-of-set? x set)
|
||||
(cond ((null? set) false)
|
||||
((= x (entry set)) true)
|
||||
((< x (entry set))
|
||||
(element-of-set? x (left-branch set)))
|
||||
((> x (entry set))
|
||||
(element-of-set? x (right-branch set)))))
|
||||
|
||||
(define key car)
|
||||
|
||||
(define (lookup given-key set-of-records)
|
||||
(cond ((null? set-of-records) false)
|
||||
((= given-key (key (entry set-of-records))) (entry set-of-records))
|
||||
((< given-key (key (entry set-of-records)))
|
||||
(lookup given-key (left-branch set-of-records)))
|
||||
(else (lookup given-key (right-branch set-of-records)))))
|
||||
|
||||
(define records
|
||||
(make-tree '(3 three)
|
||||
(make-tree '(1 one) '() '())
|
||||
(make-tree '(5 five)
|
||||
(make-tree '(4 four) '() '())
|
||||
(make-tree '(7 seven) '() '()))))
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
#lang sicp
|
||||
|
||||
;;;SECTION 2.3.3
|
||||
|
||||
;; representing
|
||||
|
||||
(define (make-leaf symbol weight)
|
||||
(list 'leaf symbol weight))
|
||||
|
||||
(define (leaf? object)
|
||||
(eq? (car object) 'leaf))
|
||||
|
||||
(define (symbol-leaf x) (cadr x))
|
||||
|
||||
(define (weight-leaf x) (caddr x))
|
||||
|
||||
(define (make-code-tree left right)
|
||||
(list left
|
||||
right
|
||||
(append (symbols left) (symbols right))
|
||||
(+ (weight left) (weight right))))
|
||||
|
||||
(define (left-branch tree) (car tree))
|
||||
|
||||
(define (right-branch tree) (cadr tree))
|
||||
|
||||
(define (symbols tree)
|
||||
(if (leaf? tree)
|
||||
(list (symbol-leaf tree))
|
||||
(caddr tree)))
|
||||
|
||||
(define (weight tree)
|
||||
(if (leaf? tree)
|
||||
(weight-leaf tree)
|
||||
(cadddr tree)))
|
||||
|
||||
;; decoding
|
||||
(define (decode bits tree)
|
||||
(define (decode-1 bits current-branch)
|
||||
(if (null? bits)
|
||||
'()
|
||||
(let ((next-branch
|
||||
(choose-branch (car bits) current-branch)))
|
||||
(if (leaf? next-branch)
|
||||
(cons (symbol-leaf next-branch)
|
||||
(decode-1 (cdr bits) tree))
|
||||
(decode-1 (cdr bits) next-branch)))))
|
||||
(decode-1 bits tree))
|
||||
|
||||
(define (choose-branch bit branch)
|
||||
(cond ((= bit 0) (left-branch branch))
|
||||
((= bit 1) (right-branch branch))
|
||||
(else (error "bad bit -- CHOOSE-BRANCH" bit))))
|
||||
|
||||
;; sets
|
||||
|
||||
(define (adjoin-set x set)
|
||||
(cond ((null? set) (list x))
|
||||
((< (weight x) (weight (car set))) (cons x set))
|
||||
(else (cons (car set)
|
||||
(adjoin-set x (cdr set))))))
|
||||
|
||||
(define (make-leaf-set pairs)
|
||||
(if (null? pairs)
|
||||
'()
|
||||
(let ((pair (car pairs)))
|
||||
(adjoin-set (make-leaf (car pair)
|
||||
(cadr pair))
|
||||
(make-leaf-set (cdr pairs))))))
|
||||
|
||||
|
||||
(define sample-tree
|
||||
(make-code-tree (make-leaf 'A 4)
|
||||
(make-code-tree
|
||||
(make-leaf 'B 2)
|
||||
(make-code-tree (make-leaf 'D 1)
|
||||
(make-leaf 'C 1)))))
|
||||
|
||||
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
|
||||
|
||||
(define (memq item x)
|
||||
(cond ((null? x) false)
|
||||
((eq? item (car x)) x)
|
||||
(else (memq item (cdr x)))))
|
||||
|
||||
(define (encode-branch symbol tree)
|
||||
(let ((left-sym (symbols (left-branch tree)))
|
||||
(right-sym (symbols (right-branch tree))))
|
||||
(cond ((memq symbol left-sym) (cons 0 (left-branch tree)))
|
||||
((memq symbol right-sym) (cons 1 (right-branch tree)))
|
||||
(else (cons '() '())))))
|
||||
|
||||
(define (encode-symbol symbol tree)
|
||||
(if (null? tree) '()
|
||||
(let ((code (car (encode-branch symbol tree)))
|
||||
(branch (cdr (encode-branch symbol tree))))
|
||||
(if (not (null? code))
|
||||
(if (leaf? branch)
|
||||
(list code)
|
||||
(cons code (encode-symbol symbol branch)))
|
||||
(error symbol "not in tree")))))
|
||||
|
||||
|
||||
(define (encode message tree)
|
||||
(if (null? message)
|
||||
'()
|
||||
(append (encode-symbol (car message) tree)
|
||||
(encode (cdr message) tree))))
|
||||
|
||||
;; EXERCISE 2.69
|
||||
|
||||
(define (successive-merge leaf-set)
|
||||
(if (null? (cdr leaf-set))
|
||||
(car leaf-set)
|
||||
(let ((element1 (car leaf-set))
|
||||
(element2 (cadr leaf-set)))
|
||||
(successive-merge
|
||||
(adjoin-set (make-code-tree element1 element2)
|
||||
(cddr leaf-set))))))
|
||||
|
||||
|
||||
(define (generate-huffman-tree pairs)
|
||||
(successive-merge (make-leaf-set pairs)))
|
||||
|
||||
;; 2.70
|
||||
|
||||
(define song-pairs '((a 2) (get 2) (sha 3) (wah 1) (boom 1) (job 2) (na 16) (yip 9)))
|
||||
|
||||
(define song-tree (generate-huffman-tree song-pairs))
|
||||
|
||||
(define song '(get a job sha na na na na na na na na get a job sha na na na na na na na na sha yip yip yip yip yip yip yip yip yip sha boom))
|
||||
|
||||
(define encoded-length (length (encode song song-tree))) ;; 83 bits
|
||||
|
||||
;; Song is 36 symobls long. A fixed-length code would require 3-bits per symbol (8 symbols). So the
|
||||
;; song would need 36*3=108 bits.
|
||||
|
||||
;; 2.71
|
||||
|
||||
(define pairs-5 '((a 1) (b 2) (c 4) (d 8) (e 16)))
|
||||
|
||||
(define pairs-10 (append pairs-5
|
||||
'((f 32) (g 64) (h 128) (i 256) (j 512))))
|
||||
|
||||
;; To encode the most frequent symbol requires 1 bit. To encode the most frequent symbol requires
|
||||
;; n-1 bits (where there are n symbols with weights 1,...,2^{n-1}). The resulting huffman tree in this
|
||||
;; case is the most unbalanced tree possible, so is n-1 deep.
|
||||
|
||||
;; 2.72
|
||||
;; To encode the most frequent symbol requires a single lookup into n-1 symbols plus a lookup of
|
||||
;; 1 symbol. The tree is only 1 deep for this case, so O(n).
|
||||
;; For the least frequent symbol, we need to look up from (n-1) symbols and 1 symbol, then (n-2) symbols
|
||||
;; and one symbol. This repeats n times, so O(n^2).
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
#lang sicp
|
||||
|
||||
(define (variable? x) (symbol? x))
|
||||
|
||||
(define (same-variable? v1 v2)
|
||||
(and (variable? v1) (variable? v2) (eq? v1 v2)))
|
||||
|
||||
(define (=number? exp num)
|
||||
(and (number? exp) (= exp num)))
|
||||
|
||||
(define (make-sum a1 a2)
|
||||
(cond ((=number? a1 0) a2)
|
||||
((=number? a2 0) a1)
|
||||
((and (number? a1) (number? a2)) (+ a1 a2))
|
||||
(else (list '+ a1 a2))))
|
||||
|
||||
(define (make-product m1 m2)
|
||||
(cond ((or (=number? m1 0) (=number? m2 0)) 0)
|
||||
((=number? m1 1) m2)
|
||||
((=number? m2 1) m1)
|
||||
((and (number? m1) (number? m2)) (* m1 m2))
|
||||
(else (list '* m1 m2))))
|
||||
|
||||
(define (sum? x)
|
||||
(and (pair? x) (eq? (cadr x) '+)))
|
||||
|
||||
(define (addend s) (car s))
|
||||
|
||||
;; Special case of multiplication distributing across addition. It
|
||||
;; should be possible to rewrite augend and/or multiplicand to deal
|
||||
;; with this case
|
||||
|
||||
(define (augend s)
|
||||
(if (product? (cddr s))
|
||||
(cddr s)
|
||||
(caddr s)))
|
||||
|
||||
(define (product? x)
|
||||
(and (pair? x) (eq? (cadr x) '*)))
|
||||
|
||||
(define (multiplier p) (car p))
|
||||
|
||||
(define (multiplicand p) (caddr p))
|
||||
|
||||
;; 2.73: (a) The logic to decide how to derive expressions was moved from the derive
|
||||
;; procedure into the table. It isn't possible to use number and variable in the data
|
||||
;; dispatch because they don't have a tag that could be used to distinguish them.
|
||||
|
||||
;; (b)
|
||||
|
||||
;;;-----------
|
||||
;;;from section 3.3.3 for section 2.4.3
|
||||
;;; to support operation/type table for data-directed dispatch
|
||||
|
||||
(define (assoc key records)
|
||||
(cond ((null? records) false)
|
||||
((equal? key (caar records)) (car records))
|
||||
(else (assoc key (cdr records)))))
|
||||
|
||||
(define (make-table)
|
||||
(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))
|
||||
(define get (operation-table 'lookup-proc))
|
||||
(define put (operation-table 'insert-proc!))
|
||||
|
||||
;;;-----------
|
||||
|
||||
(define (deriv exp var)
|
||||
(cond ((number? exp) 0)
|
||||
((variable? exp) (if (same-variable? exp var) 1 0))
|
||||
(else ((get 'deriv (operator exp)) (operands exp)
|
||||
var))))
|
||||
|
||||
(define (operator exp) (car exp))
|
||||
|
||||
(define (operands exp) (cdr exp))
|
||||
|
||||
|
||||
(define (deriv-sum operands var)
|
||||
(cond ((null? operands) 0)
|
||||
((null? (cdr operands)) (deriv (car operands) var))
|
||||
(else (make-sum (deriv (car operands) var)
|
||||
(deriv (cadr operands) var)))))
|
||||
|
||||
(define (deriv-prod operands var)
|
||||
(cond ((null? operands) 1)
|
||||
((null? (cdr operands)) (deriv (car operands) var))
|
||||
(else
|
||||
(let ((op1 (car operands))
|
||||
(op2 (cadr operands)))
|
||||
(make-sum (make-product op1 (deriv op2 var))
|
||||
(make-product (deriv op1 var) op2))))))
|
||||
|
||||
(define (make-exponentiation b p)
|
||||
(cond ((=number? p 0) 1)
|
||||
((=number? p 1) b)
|
||||
((and (number? b) (number? p)) (expt b p))
|
||||
(else (list '** b p))))
|
||||
|
||||
(define (base e) (cadr e))
|
||||
(define (exponent e) (caddr e))
|
||||
|
||||
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
|
||||
|
||||
(define (deriv-exp operands var)
|
||||
(let ((base (car operands))
|
||||
(exponent (cadr operands)))
|
||||
(make-product exponent
|
||||
(make-product
|
||||
(make-exponentiation base (- exponent 1))
|
||||
(deriv base var)))))
|
||||
|
||||
(put 'deriv '+ deriv-sum)
|
||||
(put 'deriv '* deriv-prod)
|
||||
(put 'deriv '** deriv-exp)
|
||||
|
|
@ -0,0 +1,161 @@
|
|||
#lang sicp
|
||||
|
||||
;; UNORDERED
|
||||
|
||||
(define (element-of-set? x set)
|
||||
(cond ((null? set) false)
|
||||
((equal? x (car set)) true)
|
||||
(else (element-of-set? x (cdr set)))))
|
||||
|
||||
(define (adjoin-set x set)
|
||||
(if (element-of-set? x set)
|
||||
set
|
||||
(cons x set)))
|
||||
|
||||
(define (list->set l)
|
||||
(if (null? l) '()
|
||||
(adjoin-set (car l) (list->set (cdr l)))))
|
||||
|
||||
;;;-----------
|
||||
;;;from section 3.3.3 for section 2.4.3
|
||||
;;; to support operation/type table for data-directed dispatch
|
||||
|
||||
(define (assoc key records)
|
||||
(cond ((null? records) false)
|
||||
((equal? key (caar records)) (car records))
|
||||
(else (assoc key (cdr records)))))
|
||||
|
||||
(define (make-table)
|
||||
(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))
|
||||
(define get (operation-table 'lookup-proc))
|
||||
(define put (operation-table 'insert-proc!))
|
||||
|
||||
;;;-----------
|
||||
(define (attach-tag type-tag contents)
|
||||
(cons type-tag contents))
|
||||
|
||||
(define (type-tag datum)
|
||||
(if (pair? datum)
|
||||
(car datum)
|
||||
(error "Bad tagged datum -- TYPE-TAG" datum)))
|
||||
|
||||
(define (contents datum)
|
||||
(if (pair? datum)
|
||||
(cdr datum)
|
||||
(error "Bad tagged datum -- CONTENTS" datum)))
|
||||
|
||||
;;(define (lookup given-key set-of-records)
|
||||
;;(cond ((null? set-of-records) false)
|
||||
;;((equal? given-key (key (car set-of-records)))
|
||||
;;(car set-of-records))
|
||||
;;(else (lookup given-key (cdr set-of-records)))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; Division a
|
||||
;; File is a tagged set of records. Because we don't mix record types
|
||||
;; within files, there is no need to tag the records as well.
|
||||
;;
|
||||
;; (tag {record1,...,record2})
|
||||
|
||||
;;(define (make-file-a records)
|
||||
;;(attach-tag 'div-a
|
||||
;;(cond ((null? records)
|
||||
|
||||
(define (lookup key)
|
||||
(lambda (given-key set-of-records)
|
||||
(cond ((null? set-of-records) false)
|
||||
((equal? given-key (key (car set-of-records)))
|
||||
(car set-of-records))
|
||||
(else ((lookup key) given-key (cdr set-of-records))))))
|
||||
|
||||
|
||||
(define (install-div-a-package)
|
||||
(define (key record) (car (contents record)))
|
||||
(define (tag x) (attach-tag 'div-a x))
|
||||
(define (name record) (car record))
|
||||
(define (address record) (cadr record))
|
||||
(define (salary record) (caddr record))
|
||||
(define (make-record name address salary)
|
||||
(tag (list name address salary)))
|
||||
|
||||
(put 'name 'div-a name)
|
||||
(put 'address 'div-a address)
|
||||
(put 'salary 'div-a salary)
|
||||
(put 'lookup 'div-a (lookup key))
|
||||
(put 'make-record 'div-a make-record)
|
||||
(put 'make-file 'div-a (lambda (l) (tag (list->set l))))
|
||||
(put 'get-record 'div-a (lookup key)))
|
||||
|
||||
(install-div-a-package)
|
||||
(define r1 ((get 'make-record 'div-a) "Bob" "Bob's address" 12345))
|
||||
(define r2 ((get 'make-record 'div-a) "Alice" "Alice's address" 54321))
|
||||
(define file-a ((get 'make-file 'div-a) (list r1 r2)))
|
||||
|
||||
(define (install-div-b-package)
|
||||
(define (key record) (car (contents record)))
|
||||
(define (tag x) (attach-tag 'div-b x))
|
||||
(define (name record) (car record))
|
||||
(define (address record) (caddr record))
|
||||
(define (salary record) (cadr record))
|
||||
(define (make-record name address salary)
|
||||
(tag (list name salary address)))
|
||||
|
||||
(put 'name 'div-b name)
|
||||
(put 'address 'div-b address)
|
||||
(put 'salary 'div-b salary)
|
||||
(put 'lookup 'div-b (lookup key))
|
||||
(put 'make-record 'div-b make-record)
|
||||
(put 'make-file 'div-b (lambda (l) (tag (list->set l))))
|
||||
(put 'get-record 'div-b (lookup key)))
|
||||
|
||||
(install-div-b-package)
|
||||
(define r3 ((get 'make-record 'div-b) "Peter" "Peter's address" 1111))
|
||||
(define r4 ((get 'make-record 'div-b) "Paul" "Paul's address" 2222))
|
||||
(define file-b ((get 'make-file 'div-b) (list r3 r4)))
|
||||
|
||||
(define (get-record name file)
|
||||
((get 'get-record (type-tag file)) name (contents file)))
|
||||
|
||||
(define (get-salary record)
|
||||
((get 'salary (type-tag record)) (contents record)))
|
||||
|
||||
(define (find-employee-record name files)
|
||||
(if (null? files) #f
|
||||
(let ((file (car files)))
|
||||
(or ((get 'get-record (type-tag file)) name (contents file))
|
||||
(find-employee-record name (cdr files))))))
|
||||
|
||||
;; To add a new division, it is necessary to put the corresponding constructors
|
||||
;; and selectors into the table with put, ensuring that each record and file is
|
||||
;; tagged.
|
||||
Loading…
Reference in New Issue