SICP习题解答：第二章（上）

;; 2.1
(define (make-rat n d)
  (if (< d 0)
      (make-rat (- n) (- d))
      (cons n d)))
 
;; 2.2
(define (make-point x y)
  (cons x y))
(define (x-point p)
  (car p))
(define (y-point p)
  (cdr p))
(define (make-segment start end)
  (cons start end))
(define (start-segment s)
  (car s))
(define (end-segment s)
  (cdr s))
(define (midpoint-segment s)
  (let ((a (start-segment s))
        (b (end-segment s)))
    (make-point (/ (+ (x-point a) (x-point b)) 2)
                (/ (+ (y-point a) (y-point b)) 2))))
 
;; 2.3
 
; 第一种表示
(define (make-rect mid-point width height)
  (cons mid-point
        (cons (/ width 2) (/ height 2))))
(define (rect-left r)
  (- (x-point (car r)) (car (cdr r))))
(define (rect-right r)
  (+ (x-point (car r)) (car (cdr r))))
(define (rect-bottom r)
  (- (y-point (car r)) (cdr (cdr r))))
(define (rect-top r)
  (+ (y-point (car r)) (cdr (cdr r))))
 
; 第二种表示
(define (make-rect bottom-left top-right)
  (cons bottom-left top-right))
(define (rect-left r)
  (x-point (car r)))
(define (rect-right r)
  (x-point (cdr r)))
(define (rect-bottom r)
  (y-point (car r)))
(define (rect-top r)
  (y-point (cdr r)))
 
; 公用函数
(define (rect-width r)
  (- (rect-right r) (rect-left r)))
(define (rect-height r)
  (- (rect-top r) (rect-bottom r)))
(define (rect-area r)
  (* (rect-width r) (rect-height r)))
(define (rect-perimeter r)
  (* 2 (+ (rect-width r) (rect-height r))))
 
;; 2.4
(define (my-cons x y)
  (lambda (m) (m x y)))
(define (my-car z)
  (z (lambda (p q) p)))
(define (my-cdr z)
  (z (lambda (p q) q)))
 
;; 2.5
(define (cons-n x y) ; x and y are natural numbers
  (if (= x 0)
      (if (= y 0) 1
          (* 3 (cons x (- y 1))))
      (* 2 (cons (- x 1) y))))
(define (car-n z)
  (if (= 0 (remainder z 2))
      (+ 1 (car (/ z 2)))
      0))
(define (cdr-n z)
  (if (= 0 (remainder z 3))
      (+ 1 (cdr (/ z 3)))
      0))
 
;; 2.6 目前最激动人心的题目
(define zero
  (lambda (f) (lambda (x) x)))
(define (add-1 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)))))
 
;; 2.7 为什么这么重复的题目啊
(define (make-interval a b) (cons a b))
(define (lower-bound x) (car x))
(define (upper-bound x) (cdr x))
 
;; 2.8
(define (sub-interval x y)
  (make-interval (- (lower-bound x) (upper-bound y))
                 (- (upper-bound x) (lower-bound y))))
 
;; 2.9 对于加法，结果的上（下）界即两上（下）界之和，故宽度就是两宽度之和，即(a-b)+(c-d)=(a-c)-(b-d)。减法有相同的结论。对于乘法，(a-b)*(c-d)!=(ac-bd)；例如宽度相同的(0,1)、(1,2)、(2,3)两两做乘法运算得到(0,2)、(0,3)、(2,6)三个宽度不同的区间。除法类似。
 
;; 2.10
(define (div-interval x y)
  (if (and (< (lower-bound y) 0) (< 0 (upper-bound)))
      (error "Divide by a interval that contains zero -- div-interval")
      (mul-interval x
                    (make-interval (/ 1 (upper-bound y))
                                   (/ 1 (lower-bound y))))))
 
;; 2.11 其实归结起来只有三种情况：0、1或2个区间包括0。
(define (print-interval i)
  (display "[")
  (display (lower-bound i))
  (display ",")
  (display (upper-bound i))
  (display "]\n"))
(define (neg-interval i)
  (make-interval (- (lower-bound i)) (- (upper-bound i))))
(define (mul-interval x y)
  (define (do-it a b c d)
    (cond ((< b 0) (neg-interval(do-it (- b) (- a) c d)))
          ((< d 0) (neg-interval(do-it a b (- d) (- c))))
          ((and (> a 0) (< c 0)) (do-it c d a b))
          ((and (< a 0) (> c 0)) (make-interval (* a d) (* b d)))
          ((and (< a 0) (< c 0)) (make-interval 0 (max (* a c) (* b d))))
          ((and (> a 0) (> c 0)) (make-interval (* a c) (* b d))))
    )
  (let ((a (lower-bound x))
        (b (upper-bound x))
        (c (lower-bound y))
        (d (upper-bound y)))
    (do-it a b c d)))
;;;
(define (mul-interval-test-cases)
  (print-interval (mul-interval (make-interval 2 3) (make-interval 4 5)))
  (print-interval (mul-interval (make-interval 2 3) (make-interval -4 5)))
  (print-interval (mul-interval (make-interval 2 3) (make-interval -5 -4)))
  (print-interval (mul-interval (make-interval -2 3) (make-interval 4 5)))
  (print-interval (mul-interval (make-interval -2 3) (make-interval -4 5)))
  (print-interval (mul-interval (make-interval -2 3) (make-interval -5 -4)))
  (print-interval (mul-interval (make-interval -3 -2) (make-interval 4 5)))
  (print-interval (mul-interval (make-interval -3 -2) (make-interval -4 5)))
  (print-interval (mul-interval (make-interval -3 -2) (make-interval -5 -4))))
 
;; 2.12
(define (make-center-percent center percent)
  (define delta (/ (* center percent) 100))
  (make-interval (- center percent) (+ center percent)))
(define (center i)
  (/ (+ (lower-bound i) (upper-bound i)) 2))
(define (percent i)
  (abs (* 50 (/ (- (upper-bound i) (lower-bound i)) (center i)))))
(define (print-center-percent i)
  (display (center i))
  (display "±")
  (display (percent i))
  (newline)
  )
 
;; 2.13 a(1+b%)*c(1+d%)=ac(1+b%+d%+b%d%)~=ac(1+b%+d%)
 
;; 2.14 程序将 (div-interval A A) 与 (div-interval A B) 做相同的处理，而没有意识到前者的两个参数并非是独立的。也即，当同一个变量在式子中多次出现时，程序不能意识到它的每次出现必须取相同的值。
(define (check-interval-arithmetic)
  (let ((A (make-interval 2 3))
        (B (make-interval 2 3)))
    (print-interval (div-interval A A))
    (print-interval (div-interval A B))))
(define (check-interval-arithmetic-center-percent)
  (let ((A (make-center-percent 100.0 3))
        (B (make-center-percent 100.0 3)))
    (print-center-percent (div-interval A A))
    (print-center-percent (div-interval A B))))
 
;; 2.15 我认为这公式的两个形式是完全等价的，在Alyssa系统上产生的区间限界不同，是由于Alyssa系统的本质缺陷，而非两个形式的优劣。
 
;; 2.16 当同一个变量在式子中多次出现时，程序不能意识到它的每次出现必须取相同的值。每个变量出现的次数不同会导致Alyssa系统得出的结果不同。无缺陷的区间算术包等价于以下问题：多变量的多项式，每个变量有其取值范围，求多项式的值的取值范围。这个问题属于 Interval Computation 的范畴：http://www.lsi.upc.edu/~robert/mirror/interval-comp/
 
;; 2.17
(define (last-pair l)
  (cond ((null? (cdr l)) l)
        (else (last-pair (cdr l)))))
 
;; 2.18
(define (reverse l)
  (define (do-it a b)
    (if (null? a) b
        (do-it (cdr a) (cons (car a) b))))
  (do-it l nil))
 
;; 2.19
(define (cc amount coin-values)
  (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)))))
(define (no-more? l) (null? l))
(define (except-first-denomination l) (cdr l))
(define (first-denomination l) (car l))
; 根据问题的定义，改变表中元素的顺序不会影响回答。
 
;; 2.20
(define (same-parity x . s)
  (define (iter a)
    (if (null? a) nil
        (let ((b (iter (cdr a))))
          (if (even? (- x (car a)))
              (cons (car a) b) b))))
  (cons x (iter s)))
 
;; 2.21
(define (square-list items)
  (if (null? items)
      nil
      (cons (square (car items)) (square-list (cdr items)))))
 
(define (square-list items)
  (map square items))
 
;; 2.22 第一个程序中，程序从前往后处理things中的元素，却每次把平方后的元素加到answer的头部，故结果的顺序会相反。第二个程序中，当cons的两个参数分别是list和元素时，结果并不是把元素加到list后面。
 
;; 2.23
(define (for-each f l)
  (cond ((not (null? l))
         (f (car l))
         (for-each f (cdr l)))))
 
;; 2.24 (1 (2 (3 4)))。
 
;; 2.25
(car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))
(car (car '((7))))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr '(1 (2 (3 (4 (5 (6 7))))))))))))))))))
 
;; 2.26
; (1 2 3 4 5 6)
; ((1 2 3) 4 5 6)
; ((1 2 3) (4 5 6))
 
;; 2.27
(define (deep-reverse t)
  (if (list? t)
      (map deep-reverse (reverse t))
      l))
 
;; 2.28
(define (fringe t)
  (cond ((null? t) nil)
        ((list? t) (append (fringe (car t)) (fringe (cdr t))))
        (else (list t))))
 
;; 2.29
(define (make-mobile left right)
  (list left right))
(define (make-branch length structure)
  (list length structure))
 
; (a)
(define (left-branch mobile)
  (car mobile))
(define (right-branch mobile)
  (cadr mobile))
(define (branch-length branch)
  (car branch))
(define (branch-structure branch)
  (cadr branch))
 
; (b)
(define (total-weight x)
  (if (number? x)
      x
      (+ (total-weight (branch-structure (left-branch x))) (total-weight (branch-structure (right-branch x))))))
 
;  (c)
(define (branch-torque x) 
  (* (total-weight (branch-structure x)) 
     (branch-length x)))
 
(define (balanced? x)
  (cond ((number? x) true)
        (else
         (let ((left (left-branch x))
               (right (right-branch x)))
           (and (= (branch-torque left) (branch-torque right)) (balanced? (branch-structure left)) (balanced? (branch-structure right)))))))
 
; (d) 只需更改right-branch和branch-structure中的cadr为cdr
 
;; 2.30
; 直接定义
(define (square-tree t)
  (cond ((null? t) nil)
        ((number? t) (square t))
        (else (cons (square-tree (car t)) (square-tree (cdr t))))))
 
; 使用高阶函数
(define (square-tree t)
  (map (lambda (x)
         (if (list? x)
             (square-tree x)
             (square x)))
       t))
 
;; 2.31
(define (tree-map f t)
  (map (lambda (x)
         (if (list? x)
             (tree-map x)
             (f x)))
       t))
 
;; 2.32 将子集分为包含与不包含(car s)两种情况。
(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
        (append rest (map (lambda (x) (cons (car s) x)) rest)))))
 
;; 2.33
(define (unary-map p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(define (apppend seq1 seq2)
  (accumulate cons seq2 seq1))
(define (length sequence)
  (accumulate (lambda (x y) (+ 1 y)) 0 sequence))
 
;; 2.34
(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms) (+ this-coeff (* x higher-terms)))
              0
              coefficient-sequence))
 
;; 2.35
(define (count-leaves t)
  (accumulate (lambda (x y)
                (+
                 (if (list? x) (count-leaves x) 1)
                 y))
              0
              t))
; 或
(define (count-leaves t)
  (accumulate + 0 (map (lambda (x) (if (list? x) (count-leaves x) 1)) t)))
 
;; 2.36
(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      nil
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))
 
;; 2.37
(define (dot-product v w)
  (accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
  (map (lambda (x) (dot-product x v)) m))
(define (transpose mat)
  (accumulate-n cons nil mat))
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda (x) (matrix-*-vector cols x)) m)))
 
;; 2.38
(define (fold-left op initial sequence)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter initial sequence))
(define fold-right accumulate)
; 3/2
; 1/6
; (1 (2 (3 ())))
; (((() 1) 2) 3)
; 结合律，以及inital是op的零元。
 
;; 2.39
(define (reverse sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))
(define (reverse sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))
 
;; 2.40
(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))
(define (unique-pairs n)
  (flatmap
   (lambda (i) 
     (map
      (lambda (x) (cons x i))
      (enumerate-interval 1 (- i 1))))
   (enumerate-interval 1 n)))
 
;; 2.41
(define (pair-sum-no-more-than n)
  (flatmap
   (lambda (x)
     (map (lambda (y) (cons y x))
          (enumerate-interval 1 (min (- x 1) (- n x)))))
   (enumerate-interval 1 (- n 1))))
(define (triple-sum-is n)
  (filter
   (lambda (x) (not (or (= (car x) (cadr x)) (= (car x) (caddr x)))))
   (map
    (lambda (x) (list (- n (car x) (cdr x)) (car x) (cdr x)))
    (pair-sum-no-more-than (- n 1)))))
 
;; 2.42
(define empty-board nil)
(define (safe? k p)
  (define (not-same p)
    (null? (filter (lambda (x) (= (car p) x)) (cdr p))))
  (and
   (not-same p)
   (not-same (map + p (enumerate-interval 1 k)))
   (not-same (map + p (reverse (enumerate-interval 1 k))))))
(define (adjoin-position n k r)(cons n r))
(define (queens board-size)
  (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))
 
;; 2.43 原程序中每个 (queen-cols k) 只需调用一次，而这个程序中，为了计算 (queen-cols k)，需要调用 k 次 (queen-cols (- k 1))；大约需要k!T的时间。
 
;; 2.44
(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
        (below painter (beside smaller smaller)))))
 
;; 2.45
(define (split combo1 combo2)
  (lambda (painter n)
    (if (= n 0)
        painter
        (let ((smaller (up-split painter (- n 1))))
          (combo1 painter (combo2 smaller smaller))))))
 
;; 2.46
(define (make-vect x y)
  (cons x y))
(define (xcor-vect v)
  (car v))
(define (ycor-vect v)
  (cdr v))
(define (add-vect v w)
  (make-vect (+ (xcor-vect v) (xcor-vect w))
             (+ (ycor-vect v) (ycor-vect w))))
(define (sub-vect v w)
  (make-vect (- (xcor-vect v) (xcor-vect w))
             (- (ycor-vect v) (ycor-vect w))))
(define (scale-vect s v)
  (make-vect (* s (xcor-vect v))
             (* s (ycor-vect v))))
 
;; 2.47
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))
(define (origin-frame frame)
  (car frame))
(define (edge1-frame frame)
  (cadr frame))
(define (edge2-frame frame)
  (caddr frame))
 
(define (make-frame origin edge1 edge2)
  (cons origin (cons edge1 edge2)))
(define (edge2-frame frame)
  (cddr frame))
 
;; 2.48
(define (make-segment v w)
  (cons v w))
(define (start-segment s)
  (car s))
(define (end-segment s)
  (cdr s))
 
;; 2.49
; (a)
(define outline-painter
  (let ((left-bottom (make-vect 0 0))
        (left-top (make-vect 0 1))
        (right-bottom (make-vect 1 0))
        (right-top (make-vect 1 1)))
    (segments->painter (list
                        (make-segment left-top left-bottom)
                        (make-segment left-bottom right-bottom)
                        (make-segment right-bottom right-top)
                        (make-segment right-top left-top)))))
; (b)
(define X-painter
  (let ((left-bottom (make-vect 0 0))
        (left-top (make-vect 0 1))
        (right-bottom (make-vect 1 0))
        (right-top (make-vect 1 1)))
    (segments->painter (list
                        (make-segment left-bottom right-top)
                        (make-segment left-top right-bottom)))))
; (c)
(define diamond-painter
  (let ((bottom (make-vect 0.5 0))
        (left (make-vect 0 0.5))
        (top (make-vect 0.5 1))
        (right (make-vect 1 0.5)))
    (segments->painter (list
                        (make-segment bottom left)
                        (make-segment left top)
                        (make-segment top right)
                        (make-segment right bottom)))))
; (d) 来源 http://d.hatena.ne.jp/laughing/20081115/1226737187，有修正
(define wave
  (let ((p0 (make-vect 0.4 1.0))
        (p1 (make-vect 0.35 0.8))
        (p2 (make-vect 0.4 0.6))
        (p3 (make-vect 0.3 0.6))
        (p4 (make-vect 0.15 0.55))
        (p5 (make-vect 0 0.8))
        (p6 (make-vect 0 0.6))
        (p7 (make-vect 0.15 0.4))
        (p8 (make-vect 0.3 0.55))
        (p9 (make-vect 0.35 0.5))
        (p10 (make-vect 0.3 0))
        (p11 (make-vect 0.4 0))
        (p12 (make-vect 0.5 0.3))
        (p13 (make-vect 0.6 0))
        (p14 (make-vect 0.7 0))
        (p15 (make-vect 0.6 0.45))
        (p16 (make-vect 1.0 0.2))
        (p17 (make-vect 1.0 0.4))
        (p18 (make-vect 0.8 0.6))
        (p19 (make-vect 0.6 0.6))
        (p20 (make-vect 0.65 0.8))
        (p21 (make-vect 0.6 1.0)))
    (segments->painter 
     (list
      (make-segment p0 p1)
      (make-segment p1 p2)
      (make-segment p2 p3)
      (make-segment p3 p4)
      (make-segment p4 p5)
      (make-segment p6 p7)
      (make-segment p7 p8)
      (make-segment p8 p9)
      (make-segment p9 p10)
      (make-segment p11 p12)
      (make-segment p12 p13)
      (make-segment p14 p15)
      (make-segment p15 p16)
      (make-segment p17 p18)
      (make-segment p18 p19)
      (make-segment p19 p20)
      (make-segment p20 p21)))))
 
;; 2.50
(define (flip-horiz painter)
  (transform-painter painter
                     (make-vect 1 0)
                     (make-vect 0 0)
                     (make-vect 1 1)))
(define (rotate-180 painter)
  (transform-painter painter
                     (make-vect 1 1)
                     (make-vect 0 1)
                     (make-vect 1 0)))
(define (rotate-270 painter)
  (transform-painter painter
                     (make-vect 0 1)
                     (make-vect 0 0)
                     (make-vect 1 1)))
 
;; 2.51
(define (below painter1 painter2)
  (let ((paint-bottom
         (transform-painter painter1
                            (make-vect 0 0)
                            (make-vect 1 0)
                            (make-vect 0 0.5)))
        (paint-top
         (transform-painter painter2
                            (make-vect 0 0.5)
                            (make-vect 1 0.5)
                            (make-vect 0 1))))
    (lambda (frame)
      (paint-bottom frame)
      (paint-top frame))))
(define (below painter1 painter2)
  (rotate-270 (beside (rotate-90 painter1) (rotate-90 painter2))))
 
;; 2.52
; (a) 略
; (b)
(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter n))
            (right (right-split painter n)))
        (let ((top-left up)
              (bottom-right right)
              (corner (corner-split painter (- n 1))))
          (beside (below painter top-left)
                  (below bottom-right corner))))))
; (c)
(define (square-limit painter n)
  (let ((combine4 (square-of-four identity flip-horiz
                                  flip-vert rotate180)))
    (combine4 (corner-split painter n))))