第二章习题 2.33 - 2.51 的解答。
E-2.33:
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
; -----------------------------------------------------------------------
(define (my-map p sequence)
(accumulate (lambda (x y) (append (list x) y)) (list) sequence))
(define (my-append seq1 seq2)
(accumulate cons seq2 seq1))
(define (my-length sequence)
(accumulate (lambda (x y) (if (null? sequence)
0
(+ 1 y))) 0 sequence))
; -----------------------------------------------------------------------
(my-map + (list 1 2 3 4 5))
(my-append (list 1 2 3) (list 5 6 7))
(my-length (list 1 3 4))
E-2.34:
(load "2.33.scm")
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms)
(+ this-coeff (* higher-terms x)))
0
coefficient-sequence))
; -------------------------------------------------------
(horner-eval 2 (list 1 3 0 5 0 1))
</pre>
E-2.35:
<pre lang='scheme' line='1' src='2.35.scm'>
(load "2.33.scm") ; accumulate
(define (count-leaves t)
(accumulate + 0 (map (lambda (x)
(if (pair? x)
(count-leaves x)
1))
t)))
; -----------------------------------------------
(define x (list (list 1 2) (list 3 4)))
(count-leaves x)
E-2.36:
(load "2.33.scm")
(define (accumulate-n op init seqs)
(if (null? (car seqs))
(list)
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
; ------------------------------------------------
(define s (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
(accumulate-n + 0 s)
E-2.37: 这题真是个复用的好例子。
(load "2.33.scm")
(load "2.36.scm")
(define (matrix-*-vector m v)
(map (lambda (x) (accumulate + 0 (map * x v))) m))
(define (transpose m)
(accumulate-n (lambda (x y) (append (list x) y))
(list) m))
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (x) (matrix-*-vector cols x))
m)))
; -----------------------------------------------------------------
(define m (list (list 1 2 3) (list 4 5 6) (list 7 8 9)))
(define v (list 1 4 7))
(matrix-*-vector m v)
(transpose m)
(matrix-*-matrix m m)
E-2.38: op 要满足交换律。
(load "2.33.scm")
(define (my-fold-right op initial sequence)
(accumulate op initial sequence))
(define (my-fold-left op initial sequence)
(define (iter result rest)
(if (null? rest)
result
(iter (op result (car rest))
(cdr rest))))
(iter initial sequence))
; ---------------------------------------------
(my-fold-right / 1 (list 1 2 3))
(my-fold-left / 1 (list 1 2 3))
(my-fold-right list (list) (list 1 2 3))
(my-fold-left list (list) (list 1 2 3))
E-2.39:
(load "2.38.scm")
(define (my-reverse sequence)
(my-fold-right (lambda (x y) (append y (list x))) (list) sequence))
(define (my-reverse-2 sequence)
(my-fold-left (lambda (x y) (append (list y) x)) (list) sequence))
; -----------------------------------------------------------------
(my-reverse-2 (list 1 2 3 4 5))
E-2.40:
(define (filter predicate sequence)
(if (null? sequence)
(list)
(if (predicate (car sequence))
(append (list (car sequence)) (filter predicate (cdr sequence)))
(filter predicate (cdr sequence)))))
; -----------------------------------------------------------------
(load "1.22.scm") ; prime?
(load "2.33.scm") ; accumulate
(define (enumerate-interval a b)
(if (> a b)
(list)
(append (list a) (enumerate-interval (+ a 1) b))))
(define (unique-pairs n)
(accumulate append
(list)
(map (lambda (i)
(map (lambda (j) (list i j))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n))))
(define (make-pair-sum pair)
(list (car pair) (cadr pair) (+ (car pair) (cadr pair))))
(define (prime-sum? pair)
(prime? (+ (car pair) (cadr pair))))
(define (prime-sum-pairs n)
(map make-pair-sum
(filter prime-sum? (unique-pairs n))))
; -----------------------------------------------------------------
(unique-pairs 5)
(prime-sum-pairs 5)
E-2.41: 生成 3 元组的时候比生成 2 元组麻烦点，不能直接连写 3 个 map，而是在第二个循环的时候先 flatmap 一下去掉一层，相当生成 2 元组时最外层的 accumulate。
(load "2.40.scm")
(define (flatmap proc seq)
(accumulate append (list) (map proc seq)))
(define (unique-triples n)
(flatmap (lambda (i)
(flatmap (lambda (j)
(map (lambda (k) (list i j k))
(enumerate-interval 1 (- j 1))))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 1 n)))
(define (s-triples s)
(filter (lambda (x)
(= (accumulate + 0 x) s))
(unique-triples s)))
; --------------------------------------------------------
(s-triples 11)
E-2.42: 刚开始想不到 safe? 只有一个列参数怎样能判断和其它皇后的位置关系，网上搜了答案（参考资料 [1]）后发现可以通过 adjoin-position 传递要判断的当前行数，并且在 adjoin-position 中不必保留列信息。具体的实现没仔细看，经过这一点提示后自己实现了一个。程序是按列来添加皇后的，与习惯的按行添加不同，这也带来了不少麻烦。
(load "2.41.scm")
(define empty-board (list))
(define (safe? col1 positions)
(define (safe-pos? row1 row2 col2)
(cond ((= row1 row2) #f)
((= col1 col2) #f)
((= (abs (- row1 row2)) (abs (- col1 col2))) #f)
(else #t)))
(define (recur row1 row col2)
(if (null? row)
#t
(if (not (safe-pos? row1 (car row) col2))
#f
(recur row1 (cdr row) (- col2 1)))))
(if (null? positions)
#t
(recur (car positions) (cdr positions) (length (cdr positions)))))
(define (adjoin-position new-row k rest-of-queens)
;(map display (list "join result -> " (append (list new-row) rest-of-queens) "\n"))
(append (list new-row) rest-of-queens))
; ----------------------------------------------------------------------------
(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))
; ----------------------------------------------------------------------------
(queens 4)
adjoin-position 的作用是添加新行位置，其中并没有保留列信息（题目中的参数 k 没有使用，因为在 safe? 中已经有了 k）。返回的 list（假设名字为 row，长度为 size，从 1 开始计数）表示的意思是：row[i] 表示皇后位于第 row[i] 行第 (size - i + 1) 列（其中 1<=i<=size）。例如 row 为 (3 1 4 2)，从左往右分别表示皇后的位置为：第 3 行第 4 列，第 1 行第 3 列，第 4 行第 2 列，第 2 行第 1 列。adjoin-position 只负责添加新的行位置（具体行为看注释打印的内容），至于是否合法是由 queen-cols 中的 filter 来判断的，即 safe?。
safe? 函数判断新增加列的所有位置中，哪个位置（即处于新增加列中的哪一行）是合法的。其中的 recur 函数为递归判断新增加的位置与之前的位置是否有冲突；safe-pos? 判断某个位置 (row1, col1) 是否和已经存在的位置 (row2, col2) 有冲突（是否在同一行，是否在同一列，是否在对角线上）。
E-2.43: 内层循环中的 queen-cols 重复计算了，本来已经确定了的位置在每次 flatmap 时都要重新算一遍。
E-2.44: 将 right-split 中 beside 和 below 的位置交换。
E-2.45:
(define (split op1 op2)
(define (helper painter n)
(if (= n 0)
painter
(let ((smaller (helper painter (- n 1))))
(op1 painter (op2 smaller smaller)))))
helper)
E-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 a b)
(make-vect (+ (xcor-vect a) (xcor-vect b))
(+ (ycor-vect a) (ycor-vect b))))
(define (sub-vect a b)
(make-vect (- (xcor-vect a) (xcor-vect b))
(- (ycor-vect a) (ycor-vect b))))
(define (scale-vect v s)
(make-vect (* s (xcor-vect v))
(* s (ycor-vect v))))
E-2.47:
(define (origin-frame f)
(car f))
(define (edge1-frame f)
(cadr f))
(define (edge2-frame f)
(caddr f))
; ------------------------------------
(define (edge2-frame f)
(cddr f))
E-2.48: 因为之前实现的 for-each 使用了 list，因此这里也使用 list 而不是 cons。
(define (make-segment a b)
(list a b))
(define (start-segment s)
(car s))
(define (end-segment s)
(cadr s))
E-2.49:
(define origin (make-vect 0 0))
(define top-left (make-vect 0 1))
(define top-right (make-vect 1 1))
(define bottom-right (make-vect 1 0))
; ---------------------------------------------------------------
(define outlint-segment-list (list (make-segment origin top-left)
(make-segment top-left top-right)
(make-segment top-right bottom-right)
(make-segment bottom-right origin)))
(define (outline frame)
((segment->painter outlint-segment-list) frame))
; ---------------------------------------------------------------
(define opposite-segment-list (list (make-segment origin top-right)
(make-segment top-left bottom-right)))
(define (opposite frame)
((segment->painter opposite-segment-list) frame))
; ---------------------------------------------------------------
(define diamond-segment-list (list (make-segment origin (make-vect 0 0.5))
(make-segment top-left (make-vect 0.5 1))
(make-segment (make-vect 1 0.5) bottom-right)
(make-segment (make-vect 0.5 0) origin)))
(define (diamond frame)
((segment->painter diamond-segment-list) frame))
E-2.50:
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1 0)
(make-vect 0 0)
(make-vect 1 1)))
(define (rotate180 painter)
(transform-painter painter
(make-vect 1 1)
(make-vect 0 1)
(make-vect 1 0)))
(define (rotate270 painter)
(transform-painter painter
(make-vect 0 1)
(make-vect 0 0)
(make-vect 1 1)))
E-2.51:
(define (below painter1 painter2)
(let ((split-point (make-vect 0 0.5)))
(let ((paint-bottom (transform-painter painter1
(make-vect 0 0)
split-point
(make-vect 1 0)))
(paint-top (transform-painter painter2
split-point
(make-vect 0 1)
(make-vect 1 0.5))))
(lambda (frame)
(paint-top frame)
(paint-bottom frame)))))
; ---------------------------------------------------------------
(define (below2 painter1 painter2)
(rotate90 (beside (rotate270 painter1) (rotate270 painter2))))