Hierarchical Data and the Closure Property Exercises

2.2

Representing Sequences

(define one-through-four (list 1 2 3 4))

one-through-four => '(1 2 3 4)
(car one-through-four) => 1
(cdr one-through-four) => '(2 3 4)
(car (cdr one-through-four)) => 2
(cons 10 one-through-four) => '(10 1 2 3 4)
(cons 5 one-through-four) => '(5 1 2 3 4)

List operations

Iterative list-ref:

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

(define squares (list 1 4 9 16 25))
(list-ref squares 3) => 16

Recursive length:

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

(define odds (list 1 3 5 7))
(length odds) => 4

Iterative length:

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

(length odds) => 4

Recursive append:

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

(append squares odds) => '(1 4 9 16 25 1 3 5 7)
(append odds squares) => '(1 3 5 7 1 4 9 16 25)

Exercise 2.17

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

(last-pair (list 23 72 149 34)) => '(34)

Exercise 2.18

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

(reverse (list 1 4 9 16 25)) => '(25 16 9 4 1)

Exercise 2.19

Generalizing count-change from Example: Counting change to work with any currency:

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

(define (cc amount coins)
  (cond ((= amount 0) 1)
        ((< amount 0) 0)
        ((no-more? coins) 0)
        (else
         (+ (cc amount
                (except-first-denom coins))
            (cc (- amount (first-denom coins))
                coins)))))

(define first-denom car)
(define except-first-denom cdr)
(define no-more? null?)

(cc 20 uk-coins) => 293

The order of the coin list does not affect the answer produced by cc:

(cc 100 us-coins) => 292
(cc 100 (reverse us-coins)) => 292
(cc 100 (list 5 50 1 25 10)) => 292

The tree recursion will explore every possible combination. It makes no difference if you start with combinations that prefer fewer, larger coins, or with the combination that only uses pennies, or anything in between.

Exercise 2.20

(define (same-parity . xs)
  (define (helper pred xs)
    (cond ((null? xs) xs)
          ((pred (car xs))
           (cons (car xs)
                 (helper pred (cdr xs))))
          (else (helper pred (cdr xs)))))
  (cond ((null? xs) xs)
        ((even? (car xs)) (helper even? xs))
        (else (helper odd? xs))))

(same-parity 1 2 3 4 5 6 7) => '(1 3 5 7)
(same-parity 2 3 4 5 6 7) => '(2 4 6)

Mapping over lists

(define (scale-list items factor)
  (if (null? items)
      '()
      (cons (* (car items) factor)
            (scale-list (cdr items) factor))))
(scale-list (list 1 2 3 4 5) 10) => '(10 20 30 40 50)

(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 (list 1 2 3 4 5) 10) => '(10 20 30 40 50)

Exercise 2.21

Imports: Compound Procedures square

(define (square-list xs)
  (if (null? xs)
      '()
      (cons (square (car xs))
            (square-list (cdr xs)))))
(square-list (list 1 2 3 4)) => '(1 4 9 16)

(define (square-list xs) (map square xs))
(square-list (list 1 2 3 4)) => '(1 4 9 16)

Exercise 2.22

Imports: Compound Procedures square

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

(square-list (list 1 2 3 4)) => '(16 9 4 1)

Louis’s procedure reverses the order of the list because of the way he builds the result. His first iteration creates a pair whose car is (square (car things)) and whose cdr is the empty list, and further recursions prepend to this list. So the last item of the result is the first item of the original list, and vice versa.

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

(square-list (list 1 2 3 4 5)) => '(((((() . 1) . 4) . 9) . 16) . 25)

Interchanging the arguments to cons doesn’t work because now each cdr is a number, not a pair. The result is not a proper list, so Scheme prints it in explicit (car . cdr) notation. It is essentially the same reversed list as before, just the roles of carand cdr have been swapped.

Exercise 2.23

(define (for-each f xs)
  (unless (null? xs)
    (f (car xs))
    (for-each f (cdr xs))))

(for-each
 (lambda (x)
   (newline)
   (display x))
 (list 57 321 88))
=$> ["57" "321" "88"]

Hierarchical Structures

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

(define x (cons (list 1 2) (list 3 4)))
(length x) => 3
(count-leaves x) => 4

(list x x) => '(((1 2) 3 4) ((1 2) 3 4))
(length (list x x)) => 2
(count-leaves (list x x)) => 8

Exercise 2.24

(list 1 (list 2 (list 3 4))) => '(1 (2 (3 4)))

Box-and-pointer structure: Tree interpretation:

Exercise 2.25

(car (cdr (car (cdr (cdr '(1 3 (5 7) 9))))))
=> 7

(car (car '((7))))
=> 7

(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr
  '(1 (2 (3 (4 (5 (6 7))))))))))))))))))
=> 7

Exercise 2.26

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

(append x y) => '(1 2 3 4 5 6)
(cons x y) => '((1 2 3) 4 5 6)
(list x y) => '((1 2 3) (4 5 6))

Exercise 2.27

(define (deep-reverse x)
  (if (pair? x)
      (map deep-reverse (reverse x))
      x))

(define x '((1 2) (3 4)))
(reverse x) => '((3 4) (1 2))
(deep-reverse x) => '((4 3) (2 1))

Exercise 2.28

(define (fringe t)
  (cond ((null? t) t)
        ((pair? (car t))
         (append (fringe (car t))
                 (fringe (cdr t))))
        (else (cons (car t)
                    (fringe (cdr t))))))

(define x '((1 2) (3 4)))
(fringe x) => '(1 2 3 4)
(fringe (list x x)) => '(1 2 3 4 1 2 3 4)
(fringe '((((5) 2) ((3 2) 9)))) => '(5 2 3 2 9)

Exercise 2.29

(define (make-mobile left right) (list left right))
(define (make-branch length structure) (list length structure))

a. Selectors:

(define left-branch car)
(define right-branch cadr)
(define branch-length car)
(define branch-structure cadr)

b. Total weight:

(define (mobile-weight mobile)
  (+ (branch-weight (left-branch mobile))
     (branch-weight (right-branch mobile))))

(define (branch-weight branch)
  (let ((struct (branch-structure branch)))
    (if (number? struct)
        struct
        (mobile-weight struct))))

c. Balance:

(define (torque branch)
  (* (branch-length branch)
     (branch-weight branch)))

(define (mobile-balanced? mobile)
  (and (= (torque (left-branch mobile))
          (torque (right-branch mobile)))
       (branch-balanced? (left-branch mobile))
       (branch-balanced? (right-branch mobile))))

(define (branch-balanced? branch)
  (let ((struct (branch-structure branch)))
    (or (number? struct)
        (mobile-balanced? struct))))

d. If make-mobile and make-branch use cons instead of list, all we need to do is change the right-branch and branch-structure selectors:

(define make-mobile cons)
(define make-branch cons)

(define right-branch cdr)
(define branch-structure cdr)

Mapping over trees

(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) 5) (6 7)) 10) => '(10 (20 (30 40) 50) (60 70))

(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) 5) (6 7)) 10) => '(10 (20 (30 40) 50) (60 70))

Exercise 2.30

Imports: Compound Procedures square

(define tree '(1 (2 (3 4) 5) (6 7)))
(define squared-tree '(1 (4 (9 16) 25) (36 49)))

Direct recursion:

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

(square-tree tree) => squared-tree

Using map:

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

(square-tree tree) => squared-tree

Exercise 2.31

Imports: Compound Procedures square, Exercise 2.30 squared-tree tree

Direct recursion:

(define (tree-map f t)
  (cond ((null? t) '())
        ((not (pair? t)) (f t))
        (else (cons (tree-map f (car t))
                    (tree-map f (cdr t))))))

(define (square-tree tree) (tree-map square tree))
(square-tree tree) => squared-tree

Using map:

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

(define (square-tree tree) (tree-map square tree))
(square-tree tree) => squared-tree

Exercise 2.32

The set of all subsets, or powerset, is defined recursively for finite sets:

For the empty set, $\mathcal{P}(\varnothing) = \{\varnothing\}$ .
Given set $S$ and any $x$ , $\mathcal{P}(S \cup \{x\}) = \mathcal{P}(S) \cup \{R \cup \{x\} \ | \ R \in \mathcal{P}(S)\}.$

This leads to the following implementation:

(define (subsets s)
  (if (null? s)
      (list '())
      (let ((first-item (car s))
            (subsets-rest (subsets (cdr s))))
        (append subsets-rest
                (map (lambda (set) (cons first-item set))
                     subsets-rest)))))

(subsets '()) => '(())
(subsets '(1)) => '(() (1))
(subsets '(1 2)) => '(() (2) (1) (1 2))
(subsets '(1 2 3)) => '(() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))

Sequences as Conventional Interfaces

Imports: Compound Procedures square, Exercise 1.19 fib

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

(define (even-fibs n)
  (define (next k)
    (if (> k n)
        '()
        (let ((f (fib k)))
          (if (even? f)
              (cons f (next (+ k 1)))
              (next (+ k 1))))))
  (next 0))

(even-fibs 10) => '(0 2 8 34)

Sequence operations

Imports: Compound Procedures square, Exercise 1.19 fib

(map square (list 1 2 3 4 5)) => '(1 4 9 16 25)

(define (filter pred xs)
  (cond ((null? xs) '())
        ((pred (car xs))
         (cons (car xs) (filter pred (cdr xs))))
        (else (filter pred (cdr xs)))))

(filter odd? (list 1 2 3 4 5)) => '(1 3 5)

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

(accumulate + 0 (list 1 2 3 4 5)) => 15
(accumulate * 1 (list 1 2 3 4 5)) => 120
(accumulate cons '() (list 1 2 3 4 5)) => '(1 2 3 4 5)

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

(enumerate-interval 2 7) => '(2 3 4 5 6 7)

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

(enumerate-tree (list 1 (list 2 (list 3 4)) 5)) => '(1 2 3 4 5)

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

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

(define (even-fibs n)
  (accumulate cons '() (filter even? (map fib (enumerate-interval 0 n)))))

(even-fibs 10) => '(0 2 8 34)

(define (list-fib-squares n)
  (accumulate cons '() (map square (map fib (enumerate-interval 0 n)))))

(list-fib-squares 10) => '(0 1 1 4 9 25 64 169 441 1156 3025)

(define (product-of-squares-of-odd-elements sequence)
  (accumulate * 1 (map square (filter odd? sequence))))

(product-of-squares-of-odd-elements (list 1 2 3 4 5)) => 225

Exercise 2.33

Imports: Sequence operations accumulate

(define (map f xs)
  (accumulate (lambda (x y) (cons (f x) y)) '() xs))
(define (append xs ys)
  (accumulate cons ys xs))
(define (length xs)
  (accumulate (lambda (x n) (+ n 1)) 0 xs))

Exercise 2.34

Imports: Sequence operations accumulate

(define (horner-eval x coefs)
  (accumulate (lambda (coef higher-terms)
                (+ (* higher-terms x) coef))
              0
              coefs))

(define x 2)
(horner-eval x '(1 3 0 5 0 1))
=> (+ 1 (* 3 x) (* 5 (expt x 3)) (expt x 5))
=> 79

Exercise 2.35

Imports: Sequence operations accumulate enumerate-tree

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

(count-leaves '(1 2 (3 (4) 5) (6 7))) => 7

Exercise 2.36

Imports: Sequence operations accumulate

(define (accumulate-n op init seqs)
  (if (null? (car seqs))
      '()
      (cons (accumulate op init (map car seqs))
            (accumulate-n op init (map cdr seqs)))))

(accumulate-n + 0 '((1 2 3) (4 5 6) (7 8 9) (10 11 12))) => '(22 26 30)

Exercise 2.37

Imports: Sequence operations accumulate, Exercise 2.36 accumulate-n

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

(define (matrix-*-vector m v)
  (map (lambda (u) (dot-product u 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 mat '((1 2 3) (4 5 6) (7 8 9)))
(define identity '((1 0 0) (0 1 0) (0 0 1)))
(matrix-*-vector mat (car identity)) => (map car mat)
(matrix-*-matrix mat identity) => mat
(matrix-*-matrix identity mat) => mat

Exercise 2.38

Imports: Sequence operations accumulate

(define fold-right accumulate)

(define (fold-left op init xs)
  (define (iter result rest)
    (if (null? rest)
        result
        (iter (op result (car rest))
              (cdr rest))))
  (iter init xs))

(fold-right / 1 (list 1 2 3)) => 3/2
(fold-left / 1 (list 1 2 3)) => 1/6
(fold-right list '() (list 1 2 3)) => '(1 (2 (3 ())))
(fold-left list '() (list 1 2 3)) => '(((() 1) 2) 3)

For fold-left and fold-right to produce the smae value on any sequence, op must satisfy the following two properties:

Commutative: (= (op x y) (op y x))
Associative: (= (op x (op y z)) (op (op x y) z))

Exercise 2.39

Imports: Exercise 2.38 fold-left fold-right

(define (reverse xs)
  (fold-right (lambda (x y) (append y (list x))) '() xs))

(reverse (list 1 2 3 4 5)) => '(5 4 3 2 1)

(define (reverse xs)
  (fold-left (lambda (x y) (cons y x)) '() xs))

(reverse (list 1 2 3 4 5)) => '(5 4 3 2 1)

Nested mappings

Imports: Sequence operations accumulate enumerate-interval filter, Exercise 1.23 prime?

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

(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 5) => '((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7))

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

(define (remove item sequence)
  (filter (lambda (x) (not (equal? x item))) sequence))

(permutations '(a b c)) => '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))

Exercise 2.40

Imports: Sequence operations enumerate-interval filter, Nested mappings flatmap make-pair-sum prime-sum?

(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 5) => '((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7))

Exercise 2.41

Imports: Sequence operations enumerate-interval filter, Nested mappings flatmap

(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 (triple-sums n s)
  (filter (lambda (t)
            (= s (+ (car t) (cadr t) (caddr t))))
          (unique-triples n)))

(triple-sums 8 10) => '((5 3 2) (5 4 1) (6 3 1) (7 2 1))

Exercise 2.42

Imports: Sequence operations enumerate-interval filter, Nested mappings flatmap

(define make-position list)
(define get-row car)
(define get-col cadr)

(define empty-board '())
(define (adjoin-position row col board)
  (cons (make-position row col) board))

(define (safe? positions)
  (let ((row1 (get-row (car positions))))
    (define (helper rest-of-queens cols-apart)
      (or (null? rest-of-queens)
          (let ((row2 (get-row (car rest-of-queens))))
            (and (not (= row1 row2))
                 (not (= row1 (- row2 cols-apart)))
                 (not (= row1 (+ row2 cols-apart)))
                 (helper (cdr rest-of-queens) (+ cols-apart 1))))))
    (helper (cdr positions) 1)))

I’ve moved queen-cols to the top level so that Exercise 2.43 can access it.

(define (queen-cols k board-size)
  (if (= k 0)
      (list empty-board)
      (filter safe?
              (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) board-size)))))

(define (queens board-size)
  (queen-cols board-size board-size))

(queens 0) => '(())
(queens 1) => '(((1 1)))

The number of solution for each board size matches OEIS sequence A000170:

(map (lambda (n) (length (queens n))) (enumerate-interval 0 8))
=> '(1 1 0 0 2 10 4 40 92)

Here is the first solution (out of 92) it gives for the eight-queens puzzle:

(car (queens 8)) => '((4 8) (2 7) (7 6) (3 5) (6 4) (8 3) (5 2) (1 1))

Plotting it on a chess board, we can see that no queen is under attack:

Exercise 2.43

Imports: Exercise 2.42 queen-cols

Interchanging the nested mappings slows down the program because the queen-cols recursion gets re-evaluated for every enumerate-interval result. If the recursive call was bound outside the mappings using let, then either nesting would be fine.

To quantify how much slower it is, we will analyze both solutions. Let $T_k$ and $T'_k$ be the number of operations performed by (queen-cols k 8) using the original program and Louis’s program, respectively, and let $N_k$ be the number of results it returns. In the base case, $T_0 = T'_0 = C_0$ for some constant $C_0$ . For $k \ge 1$ , we have $T_k = T_{k-1} + W_k$ where $T_{k-1}$ is due to the recursive call and $W_k$ represents the other work done by queen-cols. Since Louis’s program repeats the recursive call, it takes $T'_k = 8T'_{k-1} + W_k$ operations. $W_k$ included $C_1$ constant work; $C_2$ for each of the $8N_{k-1}$ candidate boards it maps and filters; and $C_3$ in safe? for each of the $k$ positions in all the boards. Put together, we have

W_k = C_1 + (C_2 + C_3k)8N_{k-1}.

Let’s implement these equations in Scheme:

(define C0) (define C1) (define C2) (define C3)

(define (T k) (if (= k 0) C0 (+ (T (- k 1)) (W k))))
(define (T-louis k) (if (= k 0) C0 (+ (* 8 (T-louis (- k 1))) (W k))))

(define (W k) (+ C1 (* (+ C2 (* C3 k)) 8 (N (- k 1)))))
(define (N k) (length (queen-cols k 8)))

To estimate how much slower Louis’s program is, all we have to do is choose reasonable values for the constants and then divide $T'_8$ by $T_8$ .

(define (louis-slowdown v0 v1 v2 v3)
  (set! C0 v0) (set! C1 v1) (set! C2 v2) (set! C3 v3)
  (inexact (/ (T-louis 8) (T 8))))

(louis-slowdown 1 1 01 01) ~> 1598.2301736709533
(louis-slowdown 1 3 10 15) ~> 1355.8443654944654
(louis-slowdown 0 5 10 05) ~> 1667.9916268313882

Louis’s program is slower than the original by three orders of magnitude.

Example: A Picture Language

The picture language

Imports: Transforming and combining painters beside flip-vert, Exercise 2.44 up-split, Exercise 2.49 wave, Exercise 2.50 flip-horiz, Exercise 2.51 below

(define wave2 (beside wave (flip-vert wave)))
(define wave4 (below wave2 wave2))

(define (flipped-pairs painter)
  (let ((painter2 (beside painter (flip-vert painter))))
    (below painter2 painter2)))

(define (right-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (right-split painter (- n 1))))
        (beside painter (below smaller smaller)))))

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1))))
        (let ((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)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))

Exercise 2.44

Imports: Transforming and combining painters beside, Exercise 2.51 below

(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
        (below painter (beside smaller smaller)))))

Higher-order operations

Imports: The picture language corner-split, Transforming and combining painters beside flip-vert identity, [Exercise 2.50] flip-horiz rotate180, [Exercise 2.51] below

(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 (flipped-pairs painter)
  (let ((combine4 (square-of-four identity flip-vert
                                  identity flip-vert)))
    (combine4 painter)))

(define (square-limit painter n)
  (let ((combine4 (square-of-four flip-horiz identity
                                  rotate180 flip-vert)))
    (combine4 (corner-split painter n))))

Exercise 2.45

Imports: Transforming and combining painters beside, [Exercise 2.51] below

(define (split comb split-comb)
  (define (splitter painter n)
    (if (= n 0)
        painter
        (let ((smaller (splitter painter (- n 1))))
          (comb painter (split-comb smaller smaller)))))
  splitter)

(define right-split (split beside below))
(define up-split (split below beside))

Frames

Imports: Exercise 2.46 add-vect scale-vect xcor-vect ycor-vect, Exercise 2.47 edge1-frame edge2-frame origin-frame

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

Exercise 2.46

(define make-vect cons)
(define xcor-vect car)
(define ycor-vect cdr)

(define (add-vect u v)
  (make-vect (+ (xcor-vect u) (xcor-vect v))
             (+ (ycor-vect u) (ycor-vect v))))
(define (sub-vect u v)
  (make-vect (- (xcor-vect u) (xcor-vect v))
             (- (ycor-vect u) (ycor-vect v))))
(define (scale-vect s v)
  (make-vect (* s (xcor-vect v))
             (* s (ycor-vect v))))

(add-vect (make-vect 1 2) (make-vect 3 4)) => (make-vect 4 6)
(sub-vect (make-vect 1 2) (make-vect 3 4)) => (make-vect -2 -2)
(scale-vect 2 (make-vect 1 2)) => (make-vect 2 4)

Exercise 2.47

First representation:

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

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

Second representation:

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

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

Painters

Imports: Frames frame-coord-map, Exercise 2.48 end-segment start-segment

(define (draw-line p1 p2)
  (display (format "Line from ~s to ~s\n" p1 p2)))

(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment)
       (draw-line ((frame-coord-map frame)
                   (start-segment segment))
                  ((frame-coord-map frame)
                   (end-segment segment))))
     segment-list)))

Exercise 2.48

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

Exercise 2.49

Imports: Painters segments->painter, Exercise 2.46 make-vect, Exercise 2.48 make-segment

a. The painter that draws the outline of the designated frame:

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

b. The painter that draws an “X” by connecting opposite corners of the frame:

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

c. The painter that draws a diamond shape by connecting the midpoints of the sides of the frame:

(define diamond
  (segments->painter
   (list (make-segment (make-vect 0.5 0.0) (make-vect 1.0 0.5))
         (make-segment (make-vect 0.0 0.5) (make-vect 0.5 1.0))
         (make-segment (make-vect 0.0 0.5) (make-vect 0.5 0.0))
         (make-segment (make-vect 0.5 1.0) (make-vect 1.0 0.5)))))

d. The wave painter:

(define wave-segments
  (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 wave
  (segments->painter wave-segments))

Transforming and combining painters

Imports: Frames frame-coord-map, Exercise 2.46 make-vect sub-vect, Exercise 2.47 make-frame

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

(define (identity painter) painter)

(define (flip-vert painter)
  (transform-painter
   painter
   (make-vect 0 1)
   (make-vect 1 1)
   (make-vect 0 0)))

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

(define (rotate90 painter)
  (transform-painter
   painter
   (make-vect 1 0)
   (make-vect 1 1)
   (make-vect 0 0)))

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

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0)))
    (let ((paint-left
           (transform-painter
            painter1
            (make-vect 0 0)
            split-point
            (make-vect 0 1)))
          (paint-right
           (transform-painter
            painter2
            split-point
            (make-vect 1 0)
            (make-vect 0.5 1))))
      (lambda (frame)
        (paint-left frame)
        (paint-right frame)))))

Exercise 2.50

Imports: Transforming and combining painters transform-painter, Exercise 2.46 make-vect

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

Exercise 2.51

Imports: Transforming and combining painters beside rotate90 transform-painter, Exercise 2.46 make-vect, Exercise 2.50 rotate270

Anologous to the beside procedure:

(define (below painter1 painter2)
  (let ((split-point (make-vect 0 0.5)))
    (let ((paint-bottom
           (transform-painter
            painter1
            (make-vect 0 0)
            (make-vect 1 0.5)
            split-point))
          (paint-top
           (transform-painter
            painter2
            split-point
            (make-vect 1 0.5)
            (make-vect 0 1))))
      (lambda (frame)
        (paint-bottom frame)
        (paint-top frame)))))

In terms of beside and rotations:

(define (below painter1 painter2)
  (rotate90
   (beside (rotate270 painter1)
           (rotate270 painter2))))

Exercise 2.52

Imports: The pitcture language right-split, Higher-order operations square-of-four, Painters segments->painter, Transforming and combining painters beside, Exercise 2.44 up-split, Exercise 2.46 make-vect, Exercise 2.48 make-segment, Exercise 2.49 wave-segments, Exercise 2.50 flip-horiz, Exercise 2.51 below

a. I changed wave to add a smile:

(define smile-segments
  (list (make-segment (make-vect 0.46 0.13) (make-vect 0.46 0.17))
        (make-segment (make-vect 0.46 0.24) (make-vect 0.50 0.27))
        (make-segment (make-vect 0.54 0.13) (make-vect 0.54 0.17))
        (make-segment (make-vect 0.54 0.24) (make-vect 0.50 0.27))))
(define wave
  (segments->painter (append wave-segments smile-segments)))

b. I changed corner-split to use only one copy of the up-split and right-split images instead of two:

(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1)))
            (corner (corner-split painter (- n 1))))
        (beside (below painter up)
                (below right corner)))))

c. I changed square-limit to orient the corners differently:

(define (square-limit painter n)
  (let ((quarter (corner-split painter n)))
    (let ((flipped (flip-horiz quarter)))
      (square-of-four flipped quarter flipped quarter))))