Give up the part on package installation in chapter 2 of SICP
This commit is contained in:
parent
576ac44fc9
commit
96a3779265
|
|
@ -50,3 +50,812 @@
|
|||
(display (y-point P))
|
||||
(display ")")
|
||||
(newline))
|
||||
|
||||
; Exercise 2.3
|
||||
(define (square x) (* x x))
|
||||
(define mk-vec cons) ; Same x-point and y-point
|
||||
(define (add-vec u v)
|
||||
(mk-vec (+ (x-point u) (x-point v))
|
||||
(+ (y-point u) (y-point v))))
|
||||
(define (mul-vec u k)
|
||||
(mk-vec (* (x-point u) k) (* (y-point u) k)))
|
||||
(define (sub-vec u v)
|
||||
(add-vec u (mul-vec v -1)))
|
||||
(define (len-vec u)
|
||||
(sqrt (+ (square (x-point u)) (square (y-point u)))))
|
||||
(define (seg2vec d)
|
||||
(sub-vec (end-segment d) (start-segment d)))
|
||||
(define (length-segment d) (len-vec (seg2vec d)))
|
||||
(define (mk-rect-segs segment height)
|
||||
; Let's call the rectangle ABCD and AB is the first segment.
|
||||
; Then height is signed and is negative when the angle BAD is negative.
|
||||
(let* ((vector (seg2vec segment))
|
||||
(len (len-vec vector))
|
||||
(x (x-point vector))
|
||||
(y (y-point vector))
|
||||
(AD (mul-vec (mk-vec (- y) x) (/ height len)))
|
||||
(A (start-segment segment))
|
||||
(D (add-vec A AD))
|
||||
(segAD (make-segment A D)))
|
||||
(lambda (m)
|
||||
(cond ((= m 0) len)
|
||||
((= m 1) (abs height))
|
||||
((= m 2) segment)
|
||||
((= m 3) segAD)
|
||||
(else (error "Unexpected value of argument: rect-segs" m))))))
|
||||
(define (mk-rect-points A B height)
|
||||
(let* ((vector (sub-vec B A))
|
||||
(len (len-vec vector))
|
||||
(x (x-point vector))
|
||||
(y (y-point vector))
|
||||
(AD (mul-vec (mk-vec (- y) x) (/ height len)))
|
||||
(D (add-vec A AD)))
|
||||
(lambda (m)
|
||||
(cond ((= m 0) len)
|
||||
((= m 1) (abs height))
|
||||
((= m 2) B)
|
||||
((= m 3) A)
|
||||
((= m 4) D)
|
||||
(else (error "Unexpected value of argument: rect-points" m))))))
|
||||
(define (width-rect rect) (rect 0))
|
||||
(define (height-rect rect) (rect 1))
|
||||
(define (p-rect-segs rect)
|
||||
(* (+ (width-rect rect) (height-rect rect)) 2))
|
||||
(define (s-rect-segs rect)
|
||||
(* (width-rect rect) (height-rect rect)))
|
||||
|
||||
; Exercise 2.4
|
||||
(define (cons-procedural x y) (lambda (m) (m x y)))
|
||||
(define (car-procedural z) (z (lambda (x y) x)))
|
||||
(define (cdr-procedural z) (z (lambda (x y) y)))
|
||||
|
||||
; Exercise 2.5
|
||||
(define (cons-arithmetic a b) (* (expt 2 a) (expt 3 b)))
|
||||
(define (car-arithmetic c)
|
||||
(if (= (remainder c 2) 0)
|
||||
(inc (car-arithmetic (/ c 2)))
|
||||
0))
|
||||
(define (cdr-arithmetic c)
|
||||
(if (= (remainder c 3) 0)
|
||||
(inc (car-arithmetic (/ c 3)))
|
||||
0))
|
||||
|
||||
; Exercise 2.6
|
||||
(define zero (lambda (f) identity))
|
||||
(define (add-one n)
|
||||
(lambda (f) (lambda (x) (f ((n f) x)))))
|
||||
(define one (lambda (f) (lambda (x) (f x))))
|
||||
(define two (lambda (f) (lambda (x) (f (f x)))))
|
||||
(define (add m n)
|
||||
(lambda (f) (lambda (x) ((m f) ((n f) x)))))
|
||||
|
||||
; Exercise 2.7
|
||||
(define make-interval cons)
|
||||
(define upper-bound cdr)
|
||||
(define lower-bound car)
|
||||
(define (add-interval x y)
|
||||
(make-interval (+ (lower-bound x) (lower-bound y))
|
||||
(+ (upper-bound x) (upper-bound y))))
|
||||
; Exercise 2.8
|
||||
(define (sub-interval x y)
|
||||
(make-interval (- (lower-bound x) (upper-bound y))
|
||||
(- (upper-bound x) (lower-bound y))))
|
||||
(define (mul-interval x y)
|
||||
(let ((xl (lower-bound x))
|
||||
(xu (upper-bound x))
|
||||
(yl (lower-bound y))
|
||||
(yu (upper-bound y)))
|
||||
(let ((p1 (* xl yl))
|
||||
(p2 (* xl yu))
|
||||
(p3 (* xu yl))
|
||||
(p4 (* xu yu)))
|
||||
(make-interval (min p1 p2 p3 p4)
|
||||
(max p1 p2 p3 p4)))))
|
||||
; Exercise 2.10
|
||||
(define (div-interval x y)
|
||||
(let ((upper (upper-bound y))
|
||||
(lower (lower-bound y)))
|
||||
(if (<= (* upper lower) 0)
|
||||
(error "Cannot divide by an interval that spans 0")
|
||||
(mul-interval x (make-interval (/ 1.0 upper)
|
||||
(/ 1.0 lower))))))
|
||||
; Exercise 2.12
|
||||
(define (make-center-percent c p)
|
||||
(let ((b1 (* c (- 100 p) 0.01))
|
||||
(b2 (* c (+ 100 p) 0.01)))
|
||||
(make-interval (min b1 b2) (max b1 b2))))
|
||||
(define (center-interval i)
|
||||
(/ (+ (lower-bound i) (upper-bound i)) 2))
|
||||
(define (percent-interval i)
|
||||
(let ((u (upper-bound i))
|
||||
(l (lower-bound i)))
|
||||
(/ (- u l) (+ u l) 0.01)))
|
||||
(define (width-interval i)
|
||||
(/ (- (upper-bound i) (lower-bound i)) 2))
|
||||
; Exercise 2.13
|
||||
(define (par1 r1 r2)
|
||||
(div-interval (mul-interval r1 r2)
|
||||
(add-interval r1 r2)))
|
||||
(define (par2 r1 r2)
|
||||
(let ((one (make-interval 1 1)))
|
||||
(div-interval one
|
||||
(add-interval (div-interval one r1)
|
||||
(div-interval one r2)))))
|
||||
|
||||
; Exercise 2.17
|
||||
(define (last-pair items)
|
||||
(let ((coulder (cdr items)))
|
||||
(if (null? coulder)
|
||||
items
|
||||
(last-pair coulder))))
|
||||
|
||||
; Exercise 2.18
|
||||
(define (reverse l)
|
||||
(define (reverse-iter l r)
|
||||
(if (null? l)
|
||||
r
|
||||
(reverse-iter (cdr l) (cons (car l) r))))
|
||||
(reverse-iter l nil))
|
||||
|
||||
; Exercise 2.19
|
||||
(define (cc amount coin-values)
|
||||
(define first-denomination car)
|
||||
(define except-first-denomination cdr)
|
||||
(define no-more? null?)
|
||||
(cond ((= amount 0) 1)
|
||||
((or (< amount 0) (no-more? coin-values)) 0)
|
||||
(else (+ (cc amount
|
||||
(except-first-denomination coin-values))
|
||||
(cc (- amount (first-denomination coin-values))
|
||||
coin-values)))))
|
||||
|
||||
; Exercise 2.20
|
||||
(define (same-parity first . remain)
|
||||
(define (same-parity-iter checker l)
|
||||
(if (null? l)
|
||||
nil
|
||||
(let ((carl (car l))
|
||||
(coulder (same-parity-iter checker (cdr l))))
|
||||
(if (checker carl)
|
||||
(cons carl coulder)
|
||||
coulder))))
|
||||
(cons first (same-parity-iter (if (even? first) even? odd?) remain)))
|
||||
|
||||
; Exercise 2.21
|
||||
(define (square-list-by-hand items)
|
||||
(if (null? items)
|
||||
nil
|
||||
(cons (square (car items))
|
||||
(square-list-by-hand (cdr items)))))
|
||||
(define (square-list items) (map square items))
|
||||
|
||||
; Exercise 2.23
|
||||
(define (phor-each f l)
|
||||
(if (not (null? l))
|
||||
(begin (f (car l))
|
||||
(phor-each f (cdr l)))))
|
||||
|
||||
; Exercise 2.25
|
||||
(define (last-of-nest l)
|
||||
(cond ((not (pair? l)) l)
|
||||
((or (null? (cdr l)) (pair? (car l))) (last-of-nest (car l)))
|
||||
(else (last-of-nest (cdr l)))))
|
||||
|
||||
; Exercise 2.27
|
||||
(define (deep-reverse l)
|
||||
(define (deep-iter l r)
|
||||
(cond ((null? l) r)
|
||||
((pair? l) (deep-iter (cdr l)
|
||||
(cons (deep-reverse (car l)) r)))
|
||||
(else l)))
|
||||
(deep-iter l nil))
|
||||
|
||||
; Exercise 2.28
|
||||
(define (fringe l)
|
||||
(cond ((null? l) nil)
|
||||
((pair? l) (append (fringe (car l))
|
||||
(fringe (cdr l))))
|
||||
(else (list l))))
|
||||
|
||||
; Exercise 2.29
|
||||
(define (make-mobile left right) (list left right))
|
||||
(define (make-branch len struct) (cons len struct))
|
||||
(define left-branch car)
|
||||
(define right-branch cadr)
|
||||
(define branch-length car)
|
||||
(define branch-structure cdr)
|
||||
(define (total-weight mobile)
|
||||
(if (pair? mobile)
|
||||
(+ (total-weight (branch-structure (left-branch mobile)))
|
||||
(total-weight (branch-structure (right-branch mobile))))
|
||||
mobile))
|
||||
(define (balanced-mobile? mobile)
|
||||
(if (pair? mobile)
|
||||
(let ((left (left-branch mobile))
|
||||
(right (right-branch mobile)))
|
||||
(let ((left-struct (branch-structure left))
|
||||
(right-struct (branch-structure right)))
|
||||
(and (= (* (total-weight left-struct)
|
||||
(branch-length left))
|
||||
(* (total-weight right-struct)
|
||||
(branch-length right)))
|
||||
(balanced-mobile? left-struct)
|
||||
(balanced-mobile? right-struct))))
|
||||
true))
|
||||
|
||||
; Exercise 2.30
|
||||
(define (square-tree-by-hand tree)
|
||||
(cond ((null? tree) nil)
|
||||
((pair? tree) (cons (square-tree-by-hand (car tree))
|
||||
(square-tree-by-hand (cdr tree))))
|
||||
(else (square tree))))
|
||||
(define (square-tree tree)
|
||||
(map (lambda (subtree)
|
||||
(if (pair? subtree)
|
||||
(square-tree subtree)
|
||||
(square subtree)))
|
||||
tree))
|
||||
|
||||
; Exercise 2.31
|
||||
(define (tree-map mapping tree)
|
||||
(map (lambda (subtree)
|
||||
(if (pair? subtree)
|
||||
(tree-map mapping subtree)
|
||||
(mapping subtree)))
|
||||
tree))
|
||||
|
||||
; Exercise 2.32
|
||||
(define (subsets s)
|
||||
(if (null? s)
|
||||
(list nil)
|
||||
(let ((rest (subsets (cdr s)))
|
||||
(first (car s)))
|
||||
(append rest
|
||||
(map (lambda (subset) (cons first subset))
|
||||
rest)))))
|
||||
|
||||
(define (filter predicate sequence)
|
||||
(cond ((null? sequence) nil)
|
||||
((predicate (car sequence)) (cons (car sequence)
|
||||
(filter predicate (cdr sequence))))
|
||||
(else (filter predicate (cdr sequence)))))
|
||||
(define (accumulate op last sequence)
|
||||
(if (null? sequence)
|
||||
last
|
||||
(op (car sequence)
|
||||
(accumulate op last (cdr sequence)))))
|
||||
(define (enumerate-interval low high)
|
||||
(if (> low high)
|
||||
nil
|
||||
(cons low (enumerate-interval (inc low) high))))
|
||||
(define enumerate-tree fringe)
|
||||
|
||||
; Exercise 2.33
|
||||
(define (map-accum p sequence)
|
||||
(accumulate (lambda (x y) (cons (p x) y))
|
||||
nil
|
||||
sequence))
|
||||
(define (append-accum seq1 seq2)
|
||||
(accumulate cons seq2 seq1))
|
||||
(define (length-accum sequence)
|
||||
(accumulate (lambda (current rest) (inc rest)) 0 sequence))
|
||||
|
||||
; Exercise 2.34
|
||||
(define (horner-eval x coefficient-sequence)
|
||||
(accumulate (lambda (this-coeff higher-terms)
|
||||
(+ this-coeff (* x higher-terms)))
|
||||
0
|
||||
coefficient-sequence))
|
||||
|
||||
; Exercise 2.35
|
||||
(define (count-leaves t)
|
||||
(accumulate + 0 (map (lambda (x) (if (pair? x) (count-leaves x) 1)) t)))
|
||||
|
||||
; Exercise 2.36
|
||||
(define (accumulate-n op last seqs)
|
||||
(if (null? (car seqs))
|
||||
nil
|
||||
(cons (accumulate op last (map car seqs))
|
||||
(accumulate-n op last (map cdr seqs)))))
|
||||
|
||||
; Exercise 2.37
|
||||
(define (dot-product v w) (accumulate + 0 (map * v w)))
|
||||
(define (matrix-*-vector m v)
|
||||
(map (lambda (vector) (dot-product vector v)) m))
|
||||
(define (transpose m)
|
||||
(accumulate-n cons nil m))
|
||||
(define (matrix-*-matrix m n)
|
||||
(let ((cols (transpose n)))
|
||||
(map (lambda (vec) (matrix-*-vector cols vec)) m)))
|
||||
|
||||
; Exercise 2.38
|
||||
(define fold-right accumulate)
|
||||
(define (fold-left op initial sequence)
|
||||
(define (iter result rest)
|
||||
(if (null? rest)
|
||||
result
|
||||
(iter (op result (car rest))
|
||||
(cdr rest))))
|
||||
(iter initial sequence))
|
||||
|
||||
; Exercise 2.39
|
||||
(define (reverse-left sequence)
|
||||
(fold-left (lambda (x y) (cons y x)) nil sequence))
|
||||
(define (reverse-right sequence)
|
||||
(fold-right (lambda (x y) (append y (list x))) nil sequence))
|
||||
|
||||
(define (smallest-divisor n)
|
||||
(define (find-divisor test-divisor)
|
||||
(cond ((> (square test-divisor) n) n)
|
||||
((= (remainder n test-divisor) 0) test-divisor)
|
||||
(else (find-divisor (+ test-divisor 2)))))
|
||||
(if (even? n) 2 (find-divisor 3)))
|
||||
(define (prime? n) (and (> n 1) (= (smallest-divisor n) n)))
|
||||
(define (prime-sum? pair) (prime? (+ (car pair) (cdr pair))))
|
||||
|
||||
(define (flatmap proc seq) (accumulate append nil (map proc seq)))
|
||||
(define (make-pair-sum pair)
|
||||
(let ((a (car pair))
|
||||
(d (cdr pair)))
|
||||
(list a d (+ a d))))
|
||||
; Exercise 2.40
|
||||
(define (unique-pairs low high)
|
||||
(flatmap (lambda (i)
|
||||
(map (lambda (j) (cons i j))
|
||||
(enumerate-interval low (dec i))))
|
||||
(enumerate-interval (inc low) high)))
|
||||
(define (prime-sum-pairs n)
|
||||
(map make-pair-sum
|
||||
(filter prime-sum? (unique-pairs 1 n))))
|
||||
|
||||
(define (remove item sequence)
|
||||
(filter (lambda (x) (not (= x item)))
|
||||
sequence))
|
||||
(define (permutations s)
|
||||
(if (null? s)
|
||||
(list nil)
|
||||
(flatmap (lambda (x)
|
||||
(map (lambda (p) (cons x p))
|
||||
(permutations (remove x s))))
|
||||
s)))
|
||||
|
||||
; Exercise 2.41
|
||||
(define (triples-of-sum s n)
|
||||
(define (unique-triples low high)
|
||||
(flatmap (lambda (i)
|
||||
(map (lambda (pair) (list i (car pair) (cdr pair)))
|
||||
(unique-pairs low (dec i))))
|
||||
(enumerate-interval (+ low 2) high)))
|
||||
(filter (lambda (triple) (= (accumulate + 0 triple) s))
|
||||
(unique-triples 1 n)))
|
||||
|
||||
; Exercise 2.42
|
||||
(define (queens board-size)
|
||||
(define empty-board nil)
|
||||
(define (adjoin-position row col lst)
|
||||
(cons (cons row col) lst))
|
||||
(define (safe? k positions)
|
||||
(if (= k 1)
|
||||
true
|
||||
(let ((row (car (car positions)))
|
||||
(rest (cdr positions)))
|
||||
(accumulate (lambda (x y) (and x y))
|
||||
true
|
||||
(map (lambda (v)
|
||||
(let ((x (car v))
|
||||
(y (cdr v)))
|
||||
(not (or (= x row)
|
||||
(= (abs (/ (- x row) (- y k))) 1)))))
|
||||
rest)))))
|
||||
(define (queen-cols k)
|
||||
(if (= k 0)
|
||||
(list empty-board)
|
||||
(filter (lambda (positions) (safe? k positions))
|
||||
(flatmap (lambda (rest-of-queens)
|
||||
(map (lambda (new-row)
|
||||
(adjoin-position new-row
|
||||
k
|
||||
rest-of-queens))
|
||||
(enumerate-interval 1 board-size)))
|
||||
(queen-cols (- k 1))))))
|
||||
(queen-cols board-size))
|
||||
|
||||
; Exercise 2.54
|
||||
(define (equal?? a b)
|
||||
(let ((pa (pair? a))
|
||||
(pb (pair? b)))
|
||||
(cond ((and pa pb) (and (equal?? (car a) (car b))
|
||||
(equal?? (cdr a) (cdr b))))
|
||||
((not (or pa pb)) (eq? a b))
|
||||
(else false))))
|
||||
|
||||
(define variable? symbol?)
|
||||
(define (same-variable? v1 v2)
|
||||
(and (variable? v1) (variable? v2) (eq? v1 v2)))
|
||||
(define (=number? poly num)
|
||||
(and (number? poly) (= poly num)))
|
||||
|
||||
; Exercise 2.57
|
||||
(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 (sum? x) (and (pair? x) (eq? (car x) '+)))
|
||||
(define addend cadr)
|
||||
(define (augend x)
|
||||
(let ((dd (cddr x)))
|
||||
(if (null? (cdr dd)) (car dd) (cons '* dd))))
|
||||
|
||||
(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 (product? x) (and (pair? x) (eq? (car x) '*)))
|
||||
(define multiplier cadr)
|
||||
(define (multiplicand x)
|
||||
(let ((dd (cddr x)))
|
||||
(if (null? (cdr dd)) (car dd) (cons '* dd))))
|
||||
|
||||
; Exercise 2.56
|
||||
(define (make-exponentiation u n)
|
||||
(cond ((=number? n 0) 1)
|
||||
((=number? n 1) u)
|
||||
((and (number? u) (number? n)) (expt u n))
|
||||
(else (list '** u n))))
|
||||
(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))
|
||||
(define base cadr)
|
||||
(define exponent caddr)
|
||||
|
||||
(define (deriv poly var)
|
||||
(cond ((number? poly) 0)
|
||||
((variable? poly) (if (same-variable? poly var) 1 0))
|
||||
((sum? poly) (make-sum (deriv (addend poly) var)
|
||||
(deriv (augend poly) var)))
|
||||
((product? poly) (let ((u (multiplier poly))
|
||||
(v (multiplicand poly)))
|
||||
(make-sum (make-product u (deriv v var))
|
||||
(make-product (deriv u var) v))))
|
||||
((exponentiation? poly)
|
||||
(let ((u (base poly))
|
||||
(n (exponent poly)))
|
||||
(make-product (make-product n (make-exponentiation u (make-sum n -1)))
|
||||
(deriv u var))))
|
||||
(else (error "unknown expression type: DERIV" poly))))
|
||||
|
||||
; Exercise 2.58
|
||||
(define (memq item x)
|
||||
(cond ((null? x) false)
|
||||
((eq? (car x) item) x)
|
||||
(else (memq item (cdr x)))))
|
||||
(define (make-infix-sum a b)
|
||||
(cond ((=number? a 0) b)
|
||||
((=number? b 0) a)
|
||||
((and (number? a) (number? b)) (+ a b))
|
||||
(else (list a '+ b))))
|
||||
(define (sum-infix? x) (memq '+ x))
|
||||
(define (addend-infix x)
|
||||
(define (iter a b)
|
||||
(if (eq? (car b) '+)
|
||||
a
|
||||
(iter (append a (list (car b))) (cdr b))))
|
||||
(if (eq? (cadr x) '+)
|
||||
(car x)
|
||||
(iter '() x)))
|
||||
(define (augend-infix x)
|
||||
(let ((b (cdr (memq '+ x))))
|
||||
(if (null? (cdr b)) (car b) b)))
|
||||
|
||||
(define (make-infix-product a b)
|
||||
(cond ((or (=number? a 0) (=number? b 0)) 0)
|
||||
((=number? a 1) b)
|
||||
((=number? b 1) a)
|
||||
((and (number? a) (number? b)) (* a b))
|
||||
(else (list a '* b))))
|
||||
(define (product-infix? x)
|
||||
(and (not (sum-infix? x))
|
||||
(memq '* x)))
|
||||
(define multiplier-infix car)
|
||||
(define (multiplicand-infix x)
|
||||
(let ((b (cddr x)))
|
||||
(if (null? (cdr b)) (car b) b)))
|
||||
|
||||
(define (deriv-infix poly var)
|
||||
(cond ((number? poly) 0)
|
||||
((variable? poly) (if (same-variable? poly var) 1 0))
|
||||
((sum-infix? poly)
|
||||
(make-infix-sum (deriv-infix (addend-infix poly) var)
|
||||
(deriv-infix (augend-infix poly) var)))
|
||||
((product-infix? poly)
|
||||
(let ((u (multiplier-infix poly))
|
||||
(v (multiplicand-infix poly)))
|
||||
(make-infix-sum (make-infix-product u (deriv-infix v var))
|
||||
(make-infix-product (deriv-infix u var) v))))
|
||||
(else (error "unknown expression type: DERIV" poly))))
|
||||
|
||||
(define (element-of-uset? x uset)
|
||||
(cond ((null? uset) false)
|
||||
((equal? x (car uset)) true)
|
||||
(else (element-of-uset? x (cdr uset)))))
|
||||
(define (adjoin-uset x uset)
|
||||
(if (element-of-uset? x uset)
|
||||
uset
|
||||
(cons x uset)))
|
||||
(define (intersection-uset uset1 uset2)
|
||||
(cond ((or (null? uset1) (null? uset2)) '())
|
||||
((element-of-uset? (car uset1) uset2)
|
||||
(cons (car uset1) (intersection-uset (cdr uset1) uset2)))
|
||||
(else (intersection-uset (cdr uset1) uset2))))
|
||||
; Exercise 2.59
|
||||
(define (union-uset uset1 uset2)
|
||||
(if (null? uset1)
|
||||
uset2
|
||||
(union-uset (cdr uset1) (adjoin-uset (car uset1) uset2))))
|
||||
|
||||
; Exercise 2.60
|
||||
(define element-of-dset? element-of-uset?)
|
||||
(define adjoin-dset cons)
|
||||
(define intersection-dset intersection-uset)
|
||||
(define union-dset append)
|
||||
|
||||
(define (element-of-oset? x oset)
|
||||
(cond ((null? oset) false)
|
||||
((= x (car oset)) true)
|
||||
((< x (car oset)) false)
|
||||
(else (element-of-oset? x (cdr oset)))))
|
||||
(define (intersection-oset oset1 oset2)
|
||||
(if (or (null? oset1) (null? oset2))
|
||||
'()
|
||||
(let ((x1 (car oset1))
|
||||
(x2 (car oset2)))
|
||||
(cond ((= x1 x2) (cons x1 (intersection-oset (cdr oset1) (cdr oset2))))
|
||||
((< x1 x2) (intersection-oset (cdr oset1) oset2))
|
||||
((> x1 x2) (intersection-oset oset1 (cdr oset2)))))))
|
||||
; Exercise 2.61
|
||||
(define (adjoin-oset x oset)
|
||||
(if (null? oset)
|
||||
(cons x '())
|
||||
(let ((a (car oset)))
|
||||
(cond ((< x a) (cons x oset))
|
||||
((= x a) oset)
|
||||
(else (cons a (adjoin-oset x (cdr oset))))))))
|
||||
; Exercise 2.62
|
||||
(define (union-oset oset1 oset2)
|
||||
(if (or (null? oset1) (null? oset2))
|
||||
'()
|
||||
(let ((x1 (car oset1))
|
||||
(x2 (car oset2)))
|
||||
(cond ((= x1 x2) (cons x1 (union-oset (cdr oset1) (cdr oset2))))
|
||||
((< x1 x2) (cons x1 (union-oset (cdr oset1) oset2)))
|
||||
(else (cons x2 (union-oset oset1 (cdr oset2))))))))
|
||||
|
||||
(define (make-tree entry left right)
|
||||
(list entry left right))
|
||||
(define tree-entry car)
|
||||
(define tree-left cadr)
|
||||
(define tree-right caddr)
|
||||
(define (element-of-tset? x tset)
|
||||
(if (null? tset)
|
||||
false
|
||||
(let ((entry (tree-entry tset)))
|
||||
(cond ((< x entry) (element-of-tset? x (tree-left tset)))
|
||||
((> x entry) (element-of-tset? x (tree-right tset)))
|
||||
(else true)))))
|
||||
(define (adjoin-tset x tset)
|
||||
(if (null? tset)
|
||||
(make-tree x '() '())
|
||||
(let ((entry (tree-entry tset))
|
||||
(left (tree-left tset))
|
||||
(right (tree-right tset)))
|
||||
(cond ((< x entry) (make-tree entry (adjoin-tset x left) right))
|
||||
((> x entry) (make-tree entry left (adjoin-tset x right)))
|
||||
(else tset)))))
|
||||
|
||||
; Exercise 2.63
|
||||
(define (tree->list tree)
|
||||
(define (iter rest result)
|
||||
(if (null? rest)
|
||||
result
|
||||
(iter (tree-left rest)
|
||||
(cons (tree-entry rest)
|
||||
(iter (tree-right rest) result)))))
|
||||
(iter tree '()))
|
||||
|
||||
; Exercise 2.64
|
||||
(define (list->tree elements)
|
||||
(define (partial-tree elts size)
|
||||
(if (= size 0)
|
||||
(cons '() elts)
|
||||
(let* ((left-size (quotient (dec size) 2))
|
||||
(right-size (- size left-size 1))
|
||||
(left-result (partial-tree elts left-size))
|
||||
(left-tree (car left-result))
|
||||
(non-left-elts (cdr left-result))
|
||||
(right-result (partial-tree (cdr non-left-elts) right-size))
|
||||
(right-tree (car right-result))
|
||||
(this-entry (car non-left-elts))
|
||||
(remaining-elts (cdr right-result)))
|
||||
(cons (make-tree this-entry left-tree right-tree)
|
||||
remaining-elts))))
|
||||
(car (partial-tree elements (length elements))))
|
||||
|
||||
; Exercise 2.65
|
||||
(define (union-tset tset1 tset2)
|
||||
(list->tree (union-oset (tree->list tset1)
|
||||
(tree->list tset2))))
|
||||
(define (intersection-tset tset1 tset2)
|
||||
(list->tree (intersection-oset (tree->list tset1)
|
||||
(tree->list tset2))))
|
||||
|
||||
; Exercise 2.66
|
||||
(define (lookup-tset given-key tset-of-records)
|
||||
(define key identity)
|
||||
(if (null? tset-of-records)
|
||||
false
|
||||
(let ((current-key (key (tree-entry tset-of-records))))
|
||||
(cond ((< given-key current-key)
|
||||
(lookup-tset given-key (tree-left tset-of-records)))
|
||||
((> given-key current-key)
|
||||
(lookup-tset given-key (tree-right tset-of-records)))
|
||||
(else (tree-entry tset-of-records))))))
|
||||
|
||||
(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 (symbols tree)
|
||||
(if (leaf? tree)
|
||||
(list (symbol-leaf tree))
|
||||
(caddr tree)))
|
||||
(define (weight tree)
|
||||
(if (leaf? tree)
|
||||
(weight-leaf tree)
|
||||
(cadddr tree)))
|
||||
(define (make-code-tree left right)
|
||||
(list left
|
||||
right
|
||||
(append (symbols left) (symbols right))
|
||||
(+ (weight left) (weight right))))
|
||||
(define (decode 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))))
|
||||
(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 (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))))))
|
||||
|
||||
; Exercise 2.68
|
||||
(define (encode message tree)
|
||||
(define (encode-symbol symbol tree)
|
||||
(if (leaf? tree)
|
||||
'()
|
||||
(let ((left (left-branch tree))
|
||||
(right (right-branch tree)))
|
||||
(cond ((element-of-uset? symbol (symbols left))
|
||||
(cons 0 (encode-symbol symbol left)))
|
||||
((element-of-uset? symbol (symbols right))
|
||||
(cons 1 (encode-symbol symbol right)))
|
||||
(else (error "symbol is not in tree: ENCODE-SYMBOL" symbol))))))
|
||||
(if (null? message)
|
||||
'()
|
||||
(append (encode-symbol (car message) tree)
|
||||
(encode (cdr message) tree))))
|
||||
|
||||
; Exercise 2.69
|
||||
(define (generate-huffman-tree pairs)
|
||||
(define (successive-merge pairs)
|
||||
(if (< (length pairs) 2)
|
||||
(car pairs)
|
||||
(successive-merge (adjoin-set (make-code-tree (car pairs) (cadr pairs))
|
||||
(cddr pairs)))))
|
||||
(successive-merge (make-leaf-set pairs)))
|
||||
|
||||
; Exercise 2.70
|
||||
(define lyrics
|
||||
(encode '(Get a job
|
||||
Sha na na na na na na na na
|
||||
Get a job
|
||||
Sha na na na na na na na na
|
||||
Wah yip yip yip yip yip yip yip yip yip
|
||||
Sha boom)
|
||||
(generate-huffman-tree '((a 2) (Get 2) (Sha 3) (Wah 1)
|
||||
(boom 1) (job 2) (na 16) (yip 9)))))
|
||||
|
||||
; Exercise 2.71
|
||||
(define (encoded-size n)
|
||||
(let* ((alphabet (enumerate-interval 0 (dec n)))
|
||||
(tree (generate-huffman-tree (map (lambda (k) (list k (expt 2 k)))
|
||||
alphabet))))
|
||||
(map (lambda (k) (length (encode (list k) tree))) alphabet)))
|
||||
|
||||
(define attach-tag cons)
|
||||
(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 (rectangular? z) (eq? (type-tag z) 'rectangular))
|
||||
(define (polar? z) (eq? (type-tag z) 'polar))
|
||||
|
||||
(define (real-part-rectangular z) (car z))
|
||||
(define (imag-part-rectangular z) (cdr z))
|
||||
(define (magnitude-rectangular z)
|
||||
(sqrt (+ (square (real-part-rectangular z))
|
||||
(square (imag-part-rectangular z)))))
|
||||
(define (angle-rectangular z)
|
||||
(atan (imag-part-rectangular z)
|
||||
(real-part-rectangular z)))
|
||||
(define (make-from-real-imag-rectangular x y)
|
||||
(attach-tag 'rectangular (cons x y)))
|
||||
(define (make-from-mag-ang-rectangular r a)
|
||||
(attach-tag 'rectangular
|
||||
(cons (* r (cos a)) (* r (sin a)))))
|
||||
|
||||
(define (real-part-polar z)
|
||||
(* (magnitude-polar z) (cos (angle-polar z))))
|
||||
(define (imag-part-polar z)
|
||||
(* (magnitude-polar z) (sin (angle-polar z))))
|
||||
(define (magnitude-polar z) (car z))
|
||||
(define (angle-polar z) (cdr z))
|
||||
(define (make-from-real-imag-polar x y)
|
||||
(attach-tag 'polar
|
||||
(cons (sqrt (+ (square x) (square y)))
|
||||
(atan y x))))
|
||||
(define (make-from-mag-ang-polar r a)
|
||||
(attach-tag 'polar (cons r a)))
|
||||
|
||||
(define (real-part z)
|
||||
(cond ((rectangular? z) (real-part-rectangular (contents z)))
|
||||
((polar? z) (real-part-polar (contents z)))
|
||||
(else (error "Unknown type: REAL-PART" z))))
|
||||
(define (imag-part z)
|
||||
(cond ((rectangular? z) (imag-part-rectangular (contents z)))
|
||||
((polar? z) (imag-part-polar (contents z)))
|
||||
(else (error "Unknown type: IMAG-PART" z))))
|
||||
(define (magnitude z)
|
||||
(cond ((rectangular? z) (magnitude-rectangular (contents z)))
|
||||
((polar? z) (magnitude-polar (contents z)))
|
||||
(else (error "Unknown type: MAGNITUDE" z))))
|
||||
(define (angle z)
|
||||
(cond ((rectangular? z) (angle-rectangular (contents z)))
|
||||
((polar? z) (angle-polar (contents z)))
|
||||
(else (error "Unknown type: ANGLE" z))))
|
||||
|
||||
(define make-from-real-imag make-from-real-imag-rectangular)
|
||||
(define make-from-mag-ang make-from-mag-ang-polar)
|
||||
(define (add-complex z1 z2)
|
||||
(make-from-real-imag (+ (real-part z1) (real-part z2))
|
||||
(+ (imag-part z1) (imag-part z2))))
|
||||
(define (sub-complex z1 z2)
|
||||
(make-from-real-imag (- (real-part z1) (real-part z2))
|
||||
(- (imag-part z1) (imag-part z2))))
|
||||
(define (mul-complex z1 z2)
|
||||
(make-from-mag-ang (* (magnitude z1) (magnitude z2))
|
||||
(+ (angle z1) (angle z2))))
|
||||
(define (div-complex z1 z2)
|
||||
(make-from-mag-ang (/ (magnitude z1) (magnitude z2))
|
||||
(- (angle z1) (angle z2))))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,90 @@
|
|||
#lang sicp
|
||||
(#%require sicp-pict)
|
||||
|
||||
(define (flipped-pairs painter)
|
||||
(let ((painter2 (beside painter (flip-vert painter))))
|
||||
(below painter2 painter2)))
|
||||
|
||||
(define (right-spilt painter n)
|
||||
(if (= n 0)
|
||||
painter
|
||||
(let ((smaller (right-spilt painter (dec n))))
|
||||
(beside painter (below smaller smaller)))))
|
||||
|
||||
(define (up-split painter n)
|
||||
(if (= n 0)
|
||||
painter
|
||||
(let ((smaller (up-split painter (dec n))))
|
||||
(below painter (beside smaller smaller)))))
|
||||
|
||||
(define (corner-spilt painter n)
|
||||
(if (= n 0)
|
||||
painter
|
||||
(let ((up (up-split painter (dec n)))
|
||||
(right (right-spilt painter (dec n))))
|
||||
(let ((top-left (beside up up))
|
||||
(bottom-right (below right right))
|
||||
(corner (corner-spilt painter (dec n))))
|
||||
(beside (below painter top-left)
|
||||
(below bottom-right corner))))))
|
||||
|
||||
(define (square-limit painter n)
|
||||
(let ((quarter (corner-spilt painter n)))
|
||||
(let ((half (beside (flip-horiz quarter) quarter)))
|
||||
(below (flip-vert half) half))))
|
||||
|
||||
(define (square-of-four tl tr bl br)
|
||||
(lambda (painter)
|
||||
(let ((top (beside (tl painter) (tr painter)))
|
||||
(bottom (beside (bl painter) (br painter))))
|
||||
(below bottom top))))
|
||||
|
||||
(define (split children-parent children)
|
||||
(lambda (parent n)
|
||||
(if (= n 0)
|
||||
parent
|
||||
(let ((child ((split children-parent children) parent (dec n))))
|
||||
(children-parent parent (children child child))))))
|
||||
|
||||
(define make-vect cons)
|
||||
(define xcor-vect car)
|
||||
(define ycor-vect cdr)
|
||||
(define (add-vect v1 v2)
|
||||
(make-vect (+ (xcor-vect v1) (xcor-vect v2))
|
||||
(+ (ycor-vect v1) (ycor-vect v2))))
|
||||
(define (sub-vect v1 v2)
|
||||
(make-vect (- (xcor-vect v1) (xcor-vect v2))
|
||||
(- (ycor-vect v1) (ycor-vect v2))))
|
||||
(define (scale-vect s v)
|
||||
(make-vect (* s (xcor-vect v))
|
||||
(* s (ycor-vect v))))
|
||||
|
||||
(define (make-frame origin edge1 edge2)
|
||||
(cons origin (cons edge1 edge2)))
|
||||
(define origin-frame car)
|
||||
(define edge1-frame cadr)
|
||||
(define edge2-frame cddr)
|
||||
|
||||
(define (outline frame)
|
||||
(segments->painter (list (make-segment (make-vect 0 0)
|
||||
(make-vect 1 0))
|
||||
(make-segment (make-vect 1 0)
|
||||
(make-vect 1 1))
|
||||
(make-segment (make-vect 1 1)
|
||||
(make-vect 0 1))
|
||||
(make-segment (make-vect 0 1)
|
||||
(make-vect 0 0)))))
|
||||
(define (xxx frame)
|
||||
(segments->painter (list (make-segment (make-vect 0 0)
|
||||
(make-vect 1 1))
|
||||
(make-segment (make-vect 1 0)
|
||||
(make-vect 0 1)))))
|
||||
(define (diamond frame)
|
||||
(segments->painter (list (make-segment (make-vect 0.5 0.0)
|
||||
(make-vect 1.0 0.5))
|
||||
(make-segment (make-vect 1.0 0.5)
|
||||
(make-vect 0.5 1.0))
|
||||
(make-segment (make-vect 0.5 1.0)
|
||||
(make-vect 0.0 0.5))
|
||||
(make-segment (make-vect 0.0 0.5)
|
||||
(make-vect 0.5 0.0)))))
|
||||
Loading…
Reference in New Issue