SICP - 5 - 层次性数据

7/24/2024

表操作

(define (list-ref items n)
  (if (= n 0)
      (car items)
      (list-ref (cdr items) (- n 1))))

(list-ref '(1 2 3) 1)

(define (length items)
  (if (null? items)
      0
      (+ 1 (length (cdr items)))))

(length '(1 2 3))

(define (length items)
  (define (length-iter a count)
    (if (null? a)
        count
        (length-iter (cdr a) (+ 1 count))))
  (length-iter items 0))

(length '(1 2 3))

(define (append list1 list2)
  (if (null? list1)
      list2
      (cons (car list1) (append (cdr list1) list2))))

(append '(1 2 3) '(4 5 6))

练习 2.17

定义 last-pair

(define (last-pair l)
  (if (null? (cdr l))
      l
      (last-pair (cdr l))))

(last-pair '(1 2 3))

练习 2.18

定义 reverse

(define (reverse items)
  (define (iter xs ys)
    (if (null? xs)
        ys
        (iter (cdr xs) (cons (car xs) ys))))
  (iter items '()))

(reverse '(1 2 3))

练习 2.19

换零钱

(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1))

(define (no-more? coin-values) (null? coin-values))

(define (first-denomination coin-values) (car coin-values))

(define (except-first-denomination coin-values) (cdr coin-values))

(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))]))

(cc 100 us-coins)

练习 2.20

过程 +、*、list 可以取任意个数的实际参数。定义这类过程的方式是采用一种 带点尾部记法 的 define 。在一个过程定义中，如果形式参数表的最后一个参数之前有一个点号，那就表明，当这一过程被实际调用时，前面各个形式参数（如果有的话）将以前面的各个实际参数为值，与平常一样。但最后一个形式参数将以所有剩下的实际参数的表为值。

采用这种记法写出过程 same-parity ，它以一个或多个整数为参数，返回所有与其第一个参数有着相同奇偶性的参数形成的表。

(define (same-parity . items)
  (let ([parity (remainder (car items) 2)])
    (define (helper xs)
      (cond [(null? xs) '()]
            [(= (remainder (car xs) 2) parity)
             (cons (car xs) (helper (cdr xs)))]
            [else (helper (cdr xs))]))
    (helper items)))

(list (same-parity 1 2 3 4 5)
      (same-parity 2 3 4 5 6))

对表的映射

`scale-list`

(define (scale-list items factor)
  (if (null? items)
      '()
      (cons (* (car items) factor)
            (scale-list (cdr items) factor))))

(scale-list '(1 2 3 4 5) 10)

`map`

(define (map proc items)
  (if (null? items)
      '()
      (cons (proc (car items))
            (map proc (cdr items)))))

(define (scale-list items factor)
  (map (lambda (x) (* x factor))
       items))

(scale-list '(1 2 3 4 5) 10)

更具有一般性的 `map` 过程

Scheme 提供的 map 以一个取 $n$ 个参数的过程和 $n$ 个表为参数，将这个过程应用于所有表的第一个元素，而后应用它们的第二个元素，如此下去，返回所有结果的表，例如：

(map + (list 1 2 3) (list 40 50 60) (list 700 800 900))

(map (lambda (x y) (+ x (* 2 y)))
  (list 1 2 3)
  (list 4 5 6))

练习 2.21

square-list 的实现

(define (square-list items)
  (define (square x) (* x x))
  (if (null? items)
      '()
      (cons (square (car items)) (square-list (cdr items)))))

(define (square-list* items)
  (define (square x) (* x x))
  (map square items))

(square-list '(1 2 3 4))

练习 2.22

square-list 的迭代实现

(define (square-list items)
  (define (square x) (* x x))
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons (square (car things))
                    answer))))
  (iter items '()))

(square-list '(1 2 3 4))

(iter '(1 2 3) '())
(iter '(2 3) '(1))
(iter '(3) '(4 1))
(iter '() '(9 4 1))

(define (square-list items)
  (define (square x) (* x x))
  (define (iter things answer)
    (if (null? things)
        answer
        (iter (cdr things)
              (cons answer
                    (square (car things))))))
  (iter items '()))

(square-list '(1 2 3 4))

练习 2.23

for-each 的实现

(define (for-each f items)
  (if (null? (cdr items))
      (f (car items))
      (begin (f (car items))
             (for-each f (cdr items)))))

(for-each
  (lambda (x) (display x) (display ", "))
  '(1 2 3))

层次性结构

实例 `count-leaves` 的实现

三种情况：

空表的 count-leaves 是 0
对于树 x 的 count-leaves 应该是 (count-leaves (car x)) 和 (count-leaves (cdr x)) 的和
一个树叶的 count-leaves 是 1

(define (count-leaves x)
  (cond [(null? x) 0]
        [(pair? x) (+ (count-leaves (car x)) (count-leaves (cdr x)))]
        [else 1]))

(count-leaves (list 1 (list 2 (list 3 4))))

练习 2.24

(list 1 (list 2 (list 3 4)))

练习 2.25

给出能从下面各表中取出 7 的 car 和 cdr 的组合

(define a '(1 3 (5 7) 9))
(car (cdr (car (cdr (cdr a)))))

(define b '((7)))
(car (car b))

(define c '(1 (2 (3 (4 (5 (6 7)))))))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr c))))))))))))

练习 2.26

(define x (list 1 2 3))
(define y (list 4 5 6))

(list (append x y)
      (cons x y)
      (list x y))

练习 2.27

deep-reverse

(define (reverse items)
  (define (iter xs ys)
    (if (null? xs)
        ys
        (iter (cdr xs) (cons (car xs) ys))))
  (iter items '()))

(define (deep-reverse items)
  (define (iter rest answer)
    (if (null? rest)
        answer
        (let ([cur (if (pair? (car rest))
                        (deep-reverse (car rest))
                        (car rest))])
          (iter (cdr rest) (cons cur answer)))))
  (iter items '()))

(define x (list (list 1 2) (list 3 4)))

(list (reverse x)
      (deep-reverse x))

练习 2.28

fringe

(define (fringe x)
  (cond [(null? x) '()]
        [(pair? x) (append (fringe (car x)) (fringe (cdr x)))]
        [else (list x)]))

(define x (list (list 1 2) (list 3 4)))

(fringe x)

练习 2.29

二叉活动体

(define (make-mobile left right)
  (list left right))

(define (make-branch length structure)
  (list length structure))

(define (left-branch mobile) (list-ref mobile 0))
(define (right-branch mobile) (list-ref mobile 1))
(define (branch-length branch) (list-ref branch 0))
(define (branch-structure branch) (list-ref branch 1))

(define (total-weight mobile)
  (if (pair? mobile)
      (+ (total-weight (branch-structure (left-branch mobile)))
         (total-weight (branch-structure (right-branch mobile))))
      mobile))

(define mobile-x
  (make-mobile (make-branch 1 (make-mobile (make-branch 1 1)
                                           (make-branch 1 2)))
               (make-branch 1 (make-mobile (make-branch 1 3)
                                           (make-branch 1 4)))))

(define mobile-balanced
  (make-mobile (make-branch 2 (make-mobile (make-branch 1 2)
                                           (make-branch 1 2)))
               (make-branch 1 (make-mobile (make-branch 1 4)
                                           (make-branch 1 4)))))

(define (is-balanced mobile)
  (if (pair? mobile)
      (let ([left-len (branch-length (left-branch mobile))]
            [right-len (branch-length (right-branch mobile))]
            [left-struct (branch-structure (left-branch mobile))]
            [right-struct (branch-structure (right-branch mobile))])
        (and (= (* left-len (total-weight left-struct))
                (* right-len (total-weight right-struct)))
             (is-balanced left-struct)
             (is-balanced right-struct)))
      #t))

(list (is-balanced mobile-x)
      (is-balanced mobile-balanced))

对树的映射

(define (scale-tree tree factor)
  (cond [(null? tree) '()]
        [(not (pair? tree)) (* tree factor)]
        [else (cons (scale-tree (car tree) factor)
                    (scale-tree (cdr tree) factor))]))

(scale-tree '((1 2) (3 4)) 2)

使用 map 的实现

(define (scale-tree tree factor)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (scale-tree sub-tree factor)
             (* sub-tree factor)))
       tree))

(scale-tree '((1 2) (3 4)) 2)

练习 2.30

定义 square-tree

(define (square x) (* x x))

(define (square-tree tree)
  (cond [(null? tree) '()]
        [(not (pair? tree)) (* tree tree)]
        [else (cons (square-tree (car tree))
                    (square-tree (cdr tree)))]))

(square-tree '((1 2) (3 4)))

(define (square x) (* x x))

(define (square-tree tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (square-tree sub-tree)
             (square sub-tree)))
       tree))

(square-tree '((1 2) (3 4)))

练习 2.31

tree-map

(define (square x) (* x x))

(define (tree-map f tree)
  (map (lambda (sub-tree)
         (if (pair? sub-tree)
             (tree-map f sub-tree)
             (f sub-tree)))
       tree))

(define (square-tree tree) (tree-map square tree))

(square-tree '((1 2) (3 4)))

练习 2.32

求集合的所有子集

(define (subsets s)
  (if (null? s)
      (list nil)
      (let ((rest (subsets (cdr s))))
        (append rest (map (lambda (subset) (append (list (car s)) subset))
                          rest)))))

(subsets '(1 2 3 4))

序列操作的抽象

实例计算值为奇数的叶子的平方和

(define (square x) (* x x))

(define (sum-odd-squares tree)
  (cond [(null? tree) 0]
        [(not (pair? tree))
         (if (odd? tree) (square tree) 0)]
        [else (+ (sum-odd-squares (car tree))
                 (sum-odd-squares (cdr tree)))]))

(sum-odd-squares '((1 2 (3)) (4 (5) 6)))

实例构造出所有偶数的斐波那契数的一个表

(define (even-fibs n)
  (define (fib-iter a b count)
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1))))

  (define (fib n) (fib-iter 1 0 n))

  (define (next k)
    (if (> k n)
        nil
        (let ([f (fib k)])
          (if (even? f)
              (cons f (next (+ k 1)))
              (next (+ k 1))))))
  (next 0))

(even-fibs 10)

信号流辅助函数

(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 initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (enumerate-tree tree)
  (cond [(null? tree) nil]
        [(not (pair? tree)) (list tree)]
        [else (append (enumerate-tree (car tree))
                      (enumerate-tree (cdr tree)))]))

实例重新实现 `sum-odd-squares` 和 `even-fibs`

(define (square x) (* x x))

(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 initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (enumerate-tree tree)
  (cond [(null? tree) nil]
        [(not (pair? tree)) (list tree)]
        [else (append (enumerate-tree (car tree))
                      (enumerate-tree (cdr tree)))]))

(define (sum-odd-squares tree)
  (accumulate +
              0
              (map square
                   (filter odd?
                           (enumerate-tree tree)))))

(sum-odd-squares '((1 2 (3)) (4 (5) 6)))

(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 initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (even-fibs n)
  (define (fib-iter a b count)
    (if (= count 0)
        b
        (fib-iter (+ a b) a (- count 1))))

  (define (fib n) (fib-iter 1 0 n))

  (accumulate cons
              nil
              (filter even?
                      (map fib
                           (enumerate-interval 0 n)))))

(even-fibs 10)

练习 2.33

将一些基本的表操作看作累积的定义

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (square x) (* x x))

(define (map p sequence)
  (accumulate (lambda (x rest) (cons (p x) rest)) nil sequence))

(map square '(1 2 3))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (append seq1 seq2)
  (accumulate cons seq2 seq1))

(append '(1 2 3) '(4 5 6))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (length sequence)
  (accumulate (lambda (x y) (+ y 1)) 0 sequence))

(length '(1 2 3))

练习 2.34

Horner 规则

对于 $x$ 的某个给定值，求出一个多项式在 $x$ 的值，也可以形式化为一种累积。假定需要求下面的多项式：

a_nx^n + a_{n-1}x^{n-1} + \cdots + a_1x + a_0

采用著名的 Horner 规则，可以构造出下面的计算：

(\cdots (a_nx + a_{n - 1})x + \cdots + a_1)x + a_0

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms) (+ (* higher-terms x) this-coeff))
              0
              coefficient-sequence))

(horner-eval 2 '(1 3 0 5 0 1))

练习 2.35

将 count-leaves 重新定义为一个累积

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (enumerate-tree tree)
  (cond [(null? tree) nil]
        [(not (pair? tree)) (list tree)]
        [else (append (enumerate-tree (car tree))
                      (enumerate-tree (cdr tree)))]))

(define (count-leaves tree)
  (accumulate + 0 (map
                   (lambda (x) 1)
                     (enumerate-tree tree))))

(count-leaves '(1 (2 (3 4))))

练习 2.36

定义 accumulate-n

accumulate-n 与 accumulate 类似，除了它的第三个参数是一个序列的序列，假定其中的每个序列的元素相同。

它用指定的累积过程去组合起所有序列的第一个元素，而后是所有序列的第二个元素，并如此做下去，返回得到的所有结果的序列。

(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 (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(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)))))

(define (dot-product v w)
  (accumulate + 0 (map * v w)))

(define (matrix-*-vector m v)
  (map (lambda (r) (dot-product r v)) m))

(define (transpose mat)
  (accumulate-n cons '() mat))

(define (matrix-*-matrix m n)
  (let ([cols (transpose n)])
    (map (lambda (r)
           (map (lambda (c)
                  (dot-product r c)) cols)) m)))

(define m
  '((1 2 3 4)
    (4 5 6 6)
    (6 7 8 9)))

(define n
  '((1 2)
    (3 4)
    (5 6)
    (7 8)))

(define v '(1 2 3 4))

(define (print-matrix m)
  (for-each
   (lambda (row)
     (display row)
     (newline)) m))

(display (dot-product v v)) (newline) (newline)
(display (matrix-*-vector m v)) (newline) (newline)
(print-matrix (transpose m)) (newline)
(print-matrix (matrix-*-matrix m n))

练习 2.38

fold-right

(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 op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(display (fold-right / 1 (list 1 2 3))) (newline) ; 3/2
(display (fold-left / 1 (list 1 2 3))) (newline) ; 1/6
(display (fold-right list nil (list 1 2 3))) (newline)
(display (fold-left list nil (list 1 2 3))) (newline)

op 满足结合率时， fold-right 和 fold-left 在任何序列上都产生相同的结果

练习 2.39

分别使用 fold-right 和 fold-left 实现 reverse

(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 (reverse sequence)
  (fold-right (lambda (x y) (append y (list x))) nil sequence))

(reverse '(1 2 3 4 5 6))

(define (fold-right op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(define (reverse sequence)
  (fold-left (lambda (x y) (cons y x)) nil sequence))

(reverse '(1 2 3 4 5 6))

嵌套映射

实例找出和为质数的序对

给定自然数 $n$ ，找出所有不同的有序对 $i$ 和 $j$ ，其中 $1 \leqslant j < i \leqslant n$ ，使得 $i + j$ 是素数。

(define (square x) (* x x))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (smallest-divisor n)
  (find-divisor n 2))

(define (divides? a b)
  (= (remainder b a) 0))

(define (find-divisor n test-divisor)
  (cond [(> (square test-divisor) n) n]
        [(divides? test-divisor n) test-divisor]
        [else (find-divisor n (+ test-divisor 1))]))

(define (prime? n)
  (if (= n 1) #f
      (= n (smallest-divisor n))))

(define (prime-sum? pair)
  (prime? (+ (car pair) (cadr pair))))

(define (make-pair-sum pair)
  (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum?
               (flatmap
                (lambda (i)
                  (map (lambda (j) (list i j))
                       (enumerate-interval 1 (- i 1))))
                (enumerate-interval 1 n)))))

(prime-sum-pairs 6)

实例生成集合元素的所有排列

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (permutations s)
  (if (null? s)
      (list nil)
      (flatmap (lambda (x)
                 (map (lambda (p) (cons x p))
                      (permutations (remove x s))))
               s)))

(permutations '(1 2 3))

实例从序列中删除某个元素

(define (remove item sequence)
  (filter (lambda (x) (not (= x item)))
          sequence))

(remove 3 '(1 2 3 3 4))

练习 2.40

定义 unique-pairs 简化 prime-sum-pairs 的实现

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (unique-pairs n)
  (flatmap (lambda (i)
             (map (lambda (j) (list i j))
                  (enumerate-interval 1 (- i 1))))
           (enumerate-interval 1 n)))

(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum? (unique-pairs n))))

(prime-sum-pairs 6)

练习 2.41

所有小于等于给定整数 $n$ 的正相异整数组成的有序三元组，每个三元组的三个元之和为给定的整数 $s$

(define (fold-right op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (fold-right op initial (cdr sequence)))))

(define (flatmap proc seq)
  (fold-right append nil (map proc seq)))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (unique-triples n)
  (flatmap (lambda (i)
             (flatmap (lambda (j)
                        (map (lambda (k) (list i j k))
                             (enumerate-interval (+ j 1) n)))
                      (enumerate-interval (+ i 1) n)))
           (enumerate-interval 1 n)))

(define (sum-triples n s)
  (define (sum lst) (fold-right (lambda (x y) (+ x y)) 0 lst))

  (filter (lambda (t) (= s (sum t)))
          (unique-triples n)))

(sum-triples 8 10)

练习 2.42

八皇后问题

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (all pre lst)
  (if (null? lst)
      #t
      (and (pre (car lst))
           (all pre (cdr lst)))))

(define (make-board-position row col) (cons row col))
(define (board-position-row pos) (car pos))
(define (board-position-col pos) (cdr pos))

(define empty-board '())

(define (adjoin-position r c rest-of-queens)
  (cons (make-board-position r c) rest-of-queens))

(define (safe? k positions)
  (let ([new-queen-position (car positions)]
        [rest-queen-positions (cdr positions)])
    (and (all (lambda (pos) (not (= (board-position-row new-queen-position)
                                    (board-position-row pos))))
               rest-queen-positions)
         (all (lambda (pos)
                 (let ([delta-row (- (board-position-row new-queen-position) (board-position-row pos))]
                       [delta-col (- (board-position-col new-queen-position) (board-position-col pos))])
                   (not (= (abs delta-row) (abs delta-col)))))
               rest-queen-positions))))

(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))

(define solutions (queens 8))
(display (length solutions))
solutions

练习 2.43

Louis Reasoner 遇到的问题

(define (louis-queens board-size)
  (define (queen-cols k)
    (if (= k 0)
        (list empty-board)
        (filter (lambda (positions) (safe? k positions))
                (flatmap (lambda (new-row)
                           (map (lambda (rest-of-queens)
                                  (adjoin-position new-row k rest-of-queens))
                                (queen-cols (- k 1))))
                         (enumerate-interval 1 board-size)))))
  (queen-cols board-size))

TODO

实例一个图形语言

练习 2.44、2.45、2.50 (Part 1)、2.51

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(define wave
  (segments->painter
   (list
    (make-segment (make-vect 0.46 0.00) (make-vect 0.37 0.22))
    (make-segment (make-vect 0.37 0.22) (make-vect 0.46 0.34))
    (make-segment (make-vect 0.46 0.34) (make-vect 0.37 0.33))
    (make-segment (make-vect 0.37 0.33) (make-vect 0.22 0.45))
    (make-segment (make-vect 0.22 0.45) (make-vect 0.00 0.28))
    (make-segment (make-vect 0.00 0.33) (make-vect 0.22 0.55))
    (make-segment (make-vect 0.22 0.55) (make-vect 0.39 0.42))
    (make-segment (make-vect 0.39 0.42) (make-vect 0.31 1.00))
    (make-segment (make-vect 0.54 0.00) (make-vect 0.63 0.22))
    (make-segment (make-vect 0.63 0.22) (make-vect 0.54 0.34))
    (make-segment (make-vect 0.54 0.34) (make-vect 0.63 0.33))
    (make-segment (make-vect 0.63 0.33) (make-vect 1.00 0.67))
    (make-segment (make-vect 1.00 0.72) (make-vect 0.61 0.42))
    (make-segment (make-vect 0.61 0.42) (make-vect 0.69 1.00))
    (make-segment (make-vect 0.39 1.00) (make-vect 0.50 0.68))
    (make-segment (make-vect 0.50 0.68) (make-vect 0.61 1.00)))))

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let* ([m (frame-coord-map frame)]
           [new-origin (m origin)])
      (painter
       (make-frame new-origin
                   (sub-vect (m corner1) new-origin)
                   (sub-vect (m corner2) new-origin))))))

(define (flip-vert painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 0.0)))

(define (flip-horiz painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

(define (beside painter1 painter2)
  (let* ([split-point (make-vect 0.5 0.0)]
         [paint-left
          (transform-painter painter1
                             (make-vect 0.0 0.0)
                             split-point
                             (make-vect 0.0 1.0))]
         [paint-right
          (transform-painter painter2
                             split-point
                             (make-vect 1.0 0.0)
                             (make-vect 0.5 1.0))])
    (lambda (frame)
      (paint-left frame)
      (paint-right frame))))

(define (below painter1 painter2)
  (let* ([split-point (make-vect 0.0 0.5)]
         [paint-bottom
          (transform-painter painter1
                             split-point
                             (make-vect 1.0 0.5)
                             (make-vect 0.0 1.0))]
         [paint-top
          (transform-painter painter2
                             (make-vect 0.0 0.0)
                             (make-vect 1.0 0.0)
                             split-point)])
    (lambda (frame)
      (paint-bottom frame)
      (paint-top frame))))

(define (split split1 split2)
  (lambda (painter n)
    (if (= n 0)
        painter
        (let ([smaller ((split split1 split2) painter (- n 1))])
          (split1 painter (split2 smaller smaller))))))

(define right-split (split beside below))

(define up-split (split below beside))

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let* ([up (up-split painter (- n 1))]
             [right (right-split painter (- n 1))]
             [top-left (beside up up)]
             [bottom-right (below right right)]
             [corner (corner-split painter (- n 1))])
        (beside (below painter top-left)
                (below bottom-right corner)))))

(define (square-limit painter n)
  (let* ([quarter (corner-split painter n)]
         [half (beside (flip-horiz quarter) quarter)])
    (below (flip-vert half) half)))

(square-limit wave 5)

练习 2.46

向量的加法、减法和伸缩

(define (make-vect x y) (cons x y))
(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 v1 (make-vect 1 2))
(define v2 (make-vect 3 4))

(display (add-vect v1 v2)) (newline)
(display (sub-vect v2 v1)) (newline)
(display (scale-vect 2 v2)) (newline)

练习 2.47

框架的表示

(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define origin-frame car)
(define edge1-frame cadr)
(define edge2-frame caddr)

(define (make-vect x y) (cons x y))

(define frame (make-frame (make-vect 0 0)
                          (make-vect 0 1)
                          (make-vect 1 0)))

(display "Origin: ") (display (origin-frame frame)) (newline)
(display "Edge1: ") (display (edge1-frame frame)) (newline)
(display "Edge2: ") (display (edge2-frame frame)) (newline)

(define (make-vect x y) (cons x y))

(define (make-frame origin edge1 edge2)
  (cons origin (cons edge1 edge2)))

(define origin-frame car)
(define edge1-frame cadr)
(define edge2-frame cddr)

(define frame (make-frame (make-vect 0 0)
                          (make-vect 0 1)
                          (make-vect 1 0)))

(display "Origin: ") (display (origin-frame frame)) (newline)
(display "Edge1: ") (display (edge1-frame frame)) (newline)
(display "Edge2: ") (display (edge2-frame frame)) (newline)

练习 2.48

线段的表示

(define (make-vect x y) (cons x y))

(define (make-segment start end)
  (cons start end))

(define start-segment car)
(define end-segment cdr)

(define seg (make-segment (make-vect 1 2)
                          (make-vect 3 4)))

(display "Start: ") (display (start-segment seg)) (newline)
(display "End: ") (display (end-segment seg)) (newline)

练习 2.49

(a) 画出给定框架边界的画家

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(segments->painter
 (list
  (make-segment (make-vect 0 0) (make-vect 0 1))
  (make-segment (make-vect 0 1) (make-vect 1 1))
  (make-segment (make-vect 1 1) (make-vect 1 0))
  (make-segment (make-vect 1 0) (make-vect 0 0))))

(b) 画出一个叉号的画家

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(segments->painter
 (list
  (make-segment (make-vect 0 0) (make-vect 1 1))
  (make-segment (make-vect 1 0) (make-vect 0 1))))

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
   (for-each
    (lambda (segment) (draw-segment frame segment))
    segment-list)))

(segments->painter
 (list
  (make-segment (make-vect 0.5 0) (make-vect 1 0.5))
  (make-segment (make-vect 1 0.5) (make-vect 0.5 1))
  (make-segment (make-vect 0.5 1) (make-vect 0 0.5))
  (make-segment (make-vect 0 0.5) (make-vect 0.5 0))))

(d) 画家 wave

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(segments->painter
 (list
  (make-segment (make-vect 0.46 0.00) (make-vect 0.37 0.22))
  (make-segment (make-vect 0.37 0.22) (make-vect 0.46 0.34))
  (make-segment (make-vect 0.46 0.34) (make-vect 0.37 0.33))
  (make-segment (make-vect 0.37 0.33) (make-vect 0.22 0.45))
  (make-segment (make-vect 0.22 0.45) (make-vect 0.00 0.28))
  (make-segment (make-vect 0.00 0.33) (make-vect 0.22 0.55))
  (make-segment (make-vect 0.22 0.55) (make-vect 0.39 0.42))
  (make-segment (make-vect 0.39 0.42) (make-vect 0.31 1.00))
  (make-segment (make-vect 0.54 0.00) (make-vect 0.63 0.22))
  (make-segment (make-vect 0.63 0.22) (make-vect 0.54 0.34))
  (make-segment (make-vect 0.54 0.34) (make-vect 0.63 0.33))
  (make-segment (make-vect 0.63 0.33) (make-vect 1.00 0.67))
  (make-segment (make-vect 1.00 0.72) (make-vect 0.61 0.42))
  (make-segment (make-vect 0.61 0.42) (make-vect 0.69 1.00))
  (make-segment (make-vect 0.39 1.00) (make-vect 0.50 0.68))
  (make-segment (make-vect 0.50 0.68) (make-vect 0.61 1.00))))

其他变换 + 练习 2.50 (Part2)

注：由于 HTML Canvas 的坐标系似乎与书中的坐标系不同，以下代码较书中有一些变化

shrink-to-upper-right

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(define wave (segments->painter
 (list
  (make-segment (make-vect 0.46 0.00) (make-vect 0.37 0.22))
  (make-segment (make-vect 0.37 0.22) (make-vect 0.46 0.34))
  (make-segment (make-vect 0.46 0.34) (make-vect 0.37 0.33))
  (make-segment (make-vect 0.37 0.33) (make-vect 0.22 0.45))
  (make-segment (make-vect 0.22 0.45) (make-vect 0.00 0.28))
  (make-segment (make-vect 0.00 0.33) (make-vect 0.22 0.55))
  (make-segment (make-vect 0.22 0.55) (make-vect 0.39 0.42))
  (make-segment (make-vect 0.39 0.42) (make-vect 0.31 1.00))
  (make-segment (make-vect 0.54 0.00) (make-vect 0.63 0.22))
  (make-segment (make-vect 0.63 0.22) (make-vect 0.54 0.34))
  (make-segment (make-vect 0.54 0.34) (make-vect 0.63 0.33))
  (make-segment (make-vect 0.63 0.33) (make-vect 1.00 0.67))
  (make-segment (make-vect 1.00 0.72) (make-vect 0.61 0.42))
  (make-segment (make-vect 0.61 0.42) (make-vect 0.69 1.00))
  (make-segment (make-vect 0.39 1.00) (make-vect 0.50 0.68))
  (make-segment (make-vect 0.50 0.68) (make-vect 0.61 1.00)))))

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let* ([m (frame-coord-map frame)]
           [new-origin (m origin)])
      (painter
       (make-frame new-origin
                   (sub-vect (m corner1) new-origin)
                   (sub-vect (m corner2) new-origin))))))

(define (shrink-to-upper-right painter)
  (transform-painter painter
                     (make-vect 0.5 0.0)
                     (make-vect 1.0 0.0)
                     (make-vect 0.5 0.5)))

(shrink-to-upper-right wave)

squash-inwards, rotate90、rotate180、rotate270

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (draw-segment frame seg)
  (let* ([coord-map (frame-coord-map frame)]
         [mapped-start (coord-map (start-segment seg))]
         [mapped-end (coord-map (end-segment seg))])
    ($line (xcor-vect mapped-start)
           (ycor-vect mapped-start)
           (xcor-vect mapped-end)
           (ycor-vect mapped-end))))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment) (draw-segment frame segment))
     segment-list)))

(define wave (segments->painter
 (list
  (make-segment (make-vect 0.46 0.00) (make-vect 0.37 0.22))
  (make-segment (make-vect 0.37 0.22) (make-vect 0.46 0.34))
  (make-segment (make-vect 0.46 0.34) (make-vect 0.37 0.33))
  (make-segment (make-vect 0.37 0.33) (make-vect 0.22 0.45))
  (make-segment (make-vect 0.22 0.45) (make-vect 0.00 0.28))
  (make-segment (make-vect 0.00 0.33) (make-vect 0.22 0.55))
  (make-segment (make-vect 0.22 0.55) (make-vect 0.39 0.42))
  (make-segment (make-vect 0.39 0.42) (make-vect 0.31 1.00))
  (make-segment (make-vect 0.54 0.00) (make-vect 0.63 0.22))
  (make-segment (make-vect 0.63 0.22) (make-vect 0.54 0.34))
  (make-segment (make-vect 0.54 0.34) (make-vect 0.63 0.33))
  (make-segment (make-vect 0.63 0.33) (make-vect 1.00 0.67))
  (make-segment (make-vect 1.00 0.72) (make-vect 0.61 0.42))
  (make-segment (make-vect 0.61 0.42) (make-vect 0.69 1.00))
  (make-segment (make-vect 0.39 1.00) (make-vect 0.50 0.68))
  (make-segment (make-vect 0.50 0.68) (make-vect 0.61 1.00)))))

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let* ([m (frame-coord-map frame)]
           [new-origin (m origin)])
      (painter
       (make-frame new-origin
                   (sub-vect (m corner1) new-origin)
                   (sub-vect (m corner2) new-origin))))))

(define (beside painter1 painter2)
  (let* ([split-point (make-vect 0.5 0.0)]
         [paint-left
          (transform-painter painter1
                             (make-vect 0.0 0.0)
                             split-point
                             (make-vect 0.0 1.0))]
         [paint-right
          (transform-painter painter2
                             split-point
                             (make-vect 1.0 0.0)
                             (make-vect 0.5 1.0))])
    (lambda (frame)
      (paint-left frame)
      (paint-right frame))))

(define (below painter1 painter2)
  (let* ([split-point (make-vect 0.0 0.5)]
         [paint-bottom
          (transform-painter painter1
                             split-point
                             (make-vect 1.0 0.5)
                             (make-vect 0.0 1.0))]
         [paint-top
          (transform-painter painter2
                             (make-vect 0.0 0.0)
                             (make-vect 1.0 0.0)
                             split-point)])
    (lambda (frame)
      (paint-bottom frame)
      (paint-top frame))))

(define (squash-inwards painter)
  (transform-painter painter
                     (make-vect 0.0 0.0)
                     (make-vect 0.65 0.35)
                     (make-vect 0.35 0.65)))

(define (rotate90 painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)
                     (make-vect 0.0 0.0)
                     (make-vect 1.0 1.0)))

(define (rotate180 painter)
  (transform-painter painter
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 0.0)))

(define (rotate270 painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 0.0)))

(below (beside (rotate180 wave) (rotate270 wave))
       (beside (squash-inwards wave) (rotate90 wave)))