(define (last-pair lst)
(if (null? (cdr lst))
lst
(last-pair (cdr lst))))
(define (reverse lst)
(define (iter lst result)
(if (null? lst)
result
(iter (cdr lst) (cons (car lst) result))))
(iter lst nil))
(define (no-more? coins)
(null? coins))
(define (first-denomination coins)
(car coins))
(define (except-first-denomination coins)
(cdr coins))
The order of denominations doesn’t affect the result. Because both procedures compute all possible combinations.
(define (same-parity f . r)
(define (equiv? a b)
(or (and a b)
(and (not a) (not b))))
(let ((p (even? f)))
(define (choose r)
(cond ((null? r) nil)
((equiv? p (even? (car r)))
(cons (car r) (choose (cdr r))))
(else
(choose (cdr r)))))
(cons f (choose r))))
(define (square-list items)
(if (null? items)
nil
(cons (* (car items) (car items))
(square-list (cdr items)))))
(define (square-list items)
(map (lambda (x) (* x x)) items))
The first one will generate a reversed result because the first element of items is attached to the front of answer every iteration;
The latter one doesn’t work because it will finally produce a structure like (((((() . 1) . 2) . 3) . 4) . 5) , which is not even a list.
(define (for-each proc items)
(define (iter items)
(cond ((not (null? items))
(proc (car items))
(iter (cdr items)))))
(iter items))
The interpreter prints (1 (2 (3 4))) .
(car (cdr (car (cdr (cdr lst)))))
(car (car lst))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr lst))))))))))))
(1 2 3 4 5 6)
((1 2 3) 4 5 6)
((1 2 3) (4 5 6))
(define (deep-reverse tree)
(define (iter tree result)
(cond ((null? tree) result)
((pair? tree)
(iter (cdr tree)
(cons (deep-reverse (car tree))
result)))
(else tree)))
(iter tree nil))
I made use of the append procedure defined previously.
(define (fringe tree)
(cond ((null? tree) nil)
((pair? tree)
(append (fringe (car tree))
(fringe (cdr tree))))
(else (list tree))))
a.
(define (left-branch mobile)
(car mobile))
(define (right-branch mobile)
(car (cdr mobile)))
(define (branch-length mobile)
(car mobile))
(define (branch-structure mobile)
(car (cdr mobile)))
b.
(define (total-weight object)
(if (number? object)
object
(+ (total-weight (branch-structure (left-branch object)))
(total-weight (branch-structure (right-branch object))))))
c.
(define (torque branch)
(* (branch-length branch)
(total-weight (branch-structure branch))))
(define (balanced? object)
(or (number? object)
(and (= (torque (left-branch object))
(torque (right-branch object)))
(balanced? (branch-structure (left-branch object)))
(balanced? (branch-structure (right-branch object))))))
d.
(define (left-branch mobile)
(car mobile))
(define (right-branch mobile)
(cdr mobile))
(define (branch-length mobile)
(car mobile))
(define (branch-structure mobile)
(cdr mobile))
Only four procedures have to be changed. That’s the convenience abstraction barriers bring to us.
(define (square-tree tree)
(cond ((null? tree) nil)
((pair? tree)
(cons (square-tree (car tree))
(square-tree (cdr tree))))
(else (* tree tree))))
(define (tree-map proc tree)
(cond ((null? tree) nil)
((pair? tree)
(cons (tree-map proc (car tree))
(tree-map proc (cdr tree))))
(else (proc tree))))
Another solution uses map :
(define (tree-map proc tree)
(map (lambda (subtree)
(cond ((null? subtree) nil)
((pair? subtree)
(tree-map proc subtree))
(else (proc subtree))))
tree))
(define (subset s)
(if (null? s)
(list nil)
(let ((rest (subset (cdr s))))
(append rest
(map (lambda (lst)
(cons (car s) lst))
rest)))))
Initially I wrongly wrote nil instead of (list nil) , which always generates an empty list.
It works, because the set of all subsets is a union of:
(define (map proc seq)
(accumulate (lambda (x y)
(cons (proc x) y))
nil
seq))
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(define (length seq)
(accumulate (lambda (x y) (+ y 1)) 0 seq))
(define (horner-eval x coefficient-sequence)
(accumulate (lambda (this-coeff higher-terms)
(+ (* higher-terms x) this-coeff))
0
coefficient-sequence))
(define (count-leaves tree)
(accumulate
(lambda (x y)
(+ (cond ((null? x) 0)
((pair? x)
(count-leaves x))
(else 1))
y))
0
tree))
(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)))))
Another version uses a separately defined transpose procedure:
(define (transpose seqs)
(if (null? (car seqs))
nil
(cons (map car seqs)
(transpose (map cdr seqs)))))
(define (accumulate-n op init seqs)
(map (lambda (x)
(accumulate op init x))
(transpose seqs)))
(define (matrix-*-vector m v)
(map (lambda (x) (dot-product x v)) m))
(define (transpose mat)
(if (null? (car mat))
nil
(cons (map car mat)
(transpose (map cdr mat)))))
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (x) (matrix-*-vector cols x))
m)))
3/2
1/6
(1 (2 (3 ())))
(((() 1) 2) 3)
op should have commutativity and associativity simultaneously:
Commutativity alone is not enough, such as $x\;{\rm op}\;y=x^2+y^2$ ;
Associativity alone is not enough, such as matrix multiplications.
(define (reverse seq)
(fold-right (lambda (x y) (append y (list x)))
nil
seq))
(define (reverse seq)
(fold-left (lambda (x y) (cons y x))
nil
seq))
(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))))
(define (make-triples n s)
(define (eligible? triple)
(and (< (cadr triple) (caddr triple))
(<= (caddr triple) n)))
(filter eligible?
(flatmap
(lambda (i)
(map (lambda (j)
(list j i (- s i j)))
(enumerate-interval 1 (- i 1))))
(enumerate-interval 2 n))))
(define empty-board nil)
(define (adjoin-position new-row k rest-of-queens)
(append rest-of-queens (list (list new-row k))))
(define (safe? k positions)
(define (row-of pos) (car pos))
(define (col-of pos) (cadr pos))
(let ((new-queen
(car (filter (lambda (pos) (= (col-of pos) k))
positions)))
(rest-of-queens
(filter (lambda (pos) (not (= (col-of pos) k)))
positions)))
(define (examine unexamined-queens)
(cond ((null? unexamined-queens) #t)
((let ((x1 (row-of (car unexamined-queens)))
(y1 (col-of (car unexamined-queens)))
(x2 (row-of new-queen))
(y2 (col-of new-queen)))
(or (= (+ x1 y1) (+ x2 y2))
(= (+ x1 y2) (+ x2 y1))
(= x1 x2)
(= y1 y2))) #f)
(else (examine (cdr unexamined-queens)))))
(examine 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))
I also wrote a more abstract version that defines
(define (two-queens-safe? q1 q2)
(let ((x1 (row-of q1))
(y1 (col-of q1))
(x2 (row-of q2))
(y2 (col-of q2)))
(not (or (= (+ x1 y1) (+ x2 y2))
(= (+ x1 y2) (+ x2 y1))
(= x1 x2)
(= y1 y2)))))
to check whether two queens are safe with respect to each other. And uses
(accumulate (lambda (another-queen result)
(and (two-queens-safe? new-queen another-queen)
result))
#t
rest-of-queens)
to replace the original examine procedure. I gave it up thinking that it would sacrifice the readability of my program. But this level of abstraction provides a fundamental basis for the algorithm analyses in Exercise 2.43.
Exchanging the order of the mapping causes (queen-cols (- k 1)) to be invoked for every element in (enumerate-interval 1 board-size) .
Let’s say that $A_{k,n}$ is the number of all ways to place queens in the first $k$ columns of an $n\times n$ board. For the $8\times8$ case, we have
$$\begin{array}{r|ccccccccc}k&0&1&2&3&4&5&6&7&8\\A_{k,8}&1&8&42&140&344&568&550&312&92\end{array}$$
Since that two-queens-safe? defined in Exercise 2.42 takes a constant time to determine whether two queens are safe with respect to each other, we stipulate that it is the primitive operation. Let’s say $B_{k,n}$ is the number of times two-queens-safe? to be invoked when calling (queen-cols k) of the original algorithm on an $n\times n$ board. We have the recurrence
$$B_{k,n}=\begin{cases}0\,,&\text{if $k=0$}\,;\\n(k-1)A_{k-1,n}+B_{k-1,n}\,,&\text{if $k>0$}\,.\end{cases}$$
In the recurrence above, multiply $A_{k-1,n}$ by $n(k-1)$ means we have to attach $n$ possible new queens to each of ways to place previous queens, and filter each of them, during which the new queen has to be examined with the other $k-1$ queens.
In the original algorithm, $B_{8,8}=81696$ .
Exchanging the order of mapping causes (queen-cols (- k 1)) to be invoked $n$ times instead of once, the recurrence is simply
$$B^\prime_{k,n}=\begin{cases}0\,,&\text{if $k=0$}\,;\\n(k-1)A_{k-1,n}+nB^\prime_{k-1,n}\,,&\text{if $k>0$}\,.\end{cases}$$
In Louis’ algorithm, $B^\prime_{8,8}=59878720$ , about $733\cdot B_{8,8}$ . So the required time is about $733T$ .
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter
(beside smaller smaller)))))
(define (split proc1 proc2)
(define (impl painter n)
(if (= n 0)
painter
(let ((smaller (impl painter (- n 1))))
(proc1 painter
(proc2 smaller smaller)))))
impl)
(define (make-vect xcor ycor) (list xcor ycor))
(define (xcor-vect vect) (car vect))
(define (ycor-vect vect) (cadr vect))
(define (add-vect vect1 vect2)
(make-vect (+ (xcor-vect vect1) (xcor-vect vect2))
(+ (ycor-vect vect1) (ycor-vect vect2))))
(define (sub-vect vect1 vect2)
(make-vect (- (xcor-vect vect1) (xcor-vect vect2))
(- (ycor-vect vect1) (ycor-vect vect2))))
(define (scale-vect factor vect)
(make-vect (* (xcor-vect vect) factor)
(* (ycor-vect vect) factor)))
(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))
or
(define (make-frame origin edge1 edge2)
(cons origin (cons edge1 edge2)))
(define (origin-frame frame) (car frame))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (cddr frame))
(define (make-segment start end) (cons start end))
(define (start-segment segment) (car segment))
(define (end-segment segment) (cdr segment))
a.
(define outline
(segments->painter
(list (make-segment (make-vect 0.0 0.0) (make-vect 0.0 1.0))
(make-segment (make-vect 0.0 1.0) (make-vect 1.0 1.0))
(make-segment (make-vect 1.0 1.0) (make-vect 1.0 0.0))
(make-segment (make-vect 1.0 0.0) (make-vect 0.0 0.0)))))
b.
(define cross
(segments->painter
(list (make-segment (make-vect 0.0 0.0) (make-vect 1.0 1.0))
(make-segment (make-vect 0.0 1.0) (make-vect 1.0 0.0)))))
c.
(define diamond
(segments->painter
(list (make-segment (make-vect 0.5 0.0) (make-vect 1.0 0.5))
(make-segment (make-vect 1.0 0.5) (make-vect 0.5 1.0))
(make-segment (make-vect 0.5 1.0) (make-vect 0.0 0.5))
(make-segment (make-vect 0.0 0.5) (make-vect 0.5 0.0)))))
d. Too many line segments to draw, I’m skipping this.
(define (flip-horiz painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.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 0.0 1.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
(define (below painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-bottom
(transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(paint-top
(transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(paint-bottom frame)
(paint-top frame)))))
or
(define (below painter1 painter2)
(rotate270 (beside (rotate90 painter2)
(rotate90 painter1))))
a.
(define (add-segments segment-list painter)
(lambda (frame)
((segments->painter segment-list) frame)
(painter frame)))
(define smiley-wave
(add-segments (list <smiley segments>) wave))
b.
(define (corner-split painter n)
(if (= n 0)
painter
(let ((up-smaller (up-split painter (- n 1))))
(below (right-split painter n)
(beside up-smaller
(corner-split painter (- n 1)))))))
c. Made Mr. Rogers look outward.
(define (compose . procs)
(lambda (x)
(define (impl procs)
(if (null? procs)
x
((car procs) (impl (cdr procs)))))
(impl procs)))
(define (square-limit painter n)
(define (corner-split-n painter)
(corner-split painter n))
((square-of-four (compose flip-horiz corner-split-n flip-horiz)
(compose corner-split-n flip-horiz)
(compose flip-horiz flip-vert corner-split-n flip-horiz)
(compose flip-vert corner-split-n flip-horiz))
painter))