SICP 演習問題 2.2
2.17
#lang Racket
(define (last-pair items)
(if (null? (cdr items))
(car items)
(last-pair (cdr items))))
2.18
繰り返し
(define (reverse items)
(define (iter items result)
(if (null? items)
result
(iter (cdr items) (cons (car items) result))))
(iter items (list)))
(define (reverse items)
(if (null? items)
(list)
(append (reverse (cdr items)) (list (car items)))))
2.19
#lang racket
(define (cc amount coin-values)
(cond ((= amount 0) 1)
((or (< amount 0) (no-more? coin-values)) 0)
(else (+ (cc amount (except-first-denomination coin-values))
(cc (- amount
(first-denomination coin-values))
coin-values)))))
(define (no-more? coin-values) (null? coin-values))
(define (except-first-denomination coin-values)
(define (iter coin-values result max)
(if (null? coin-values)
result
(let ((tmp (car coin-values)))
(if (> tmp max)
(iter (cdr coin-values) (cons max result) tmp)
(iter (cdr coin-values) (cons tmp result) max)))))
(iter (cdr coin-values) (list) (car coin-values) ))
(define (first-denomination coin-values)
(define (iter coin-values max)
(if (null? coin-values)
max
(let ((tmp (car coin-values)))
(if (> tmp max)
(iter (cdr coin-values) tmp)
(iter (cdr coin-values) max)))))
(iter (cdr coin-values) (car coin-values)))
上記実装では、リスト coin-valuesの順は, ccの答に影響しない。
理由
first-denomination、except-first-denominationが、
リスト順に関係なく、常に最大のコインを対象とするように実装しているため。
2.20
#lang racket
(define (same-parity a . b)
(let ((parity (remainder a 2)))
(define (iter rest result)
(if (null? rest)
result
(if (= (remainder (car rest) 2) parity)
(iter (cdr rest) (cons (car rest) result))
(iter (cdr rest) result))))
(reverse (iter b (list)))))
2.21
#lang Racket
(define nil (list))
(define (square x) (* x x))
(define (square-list1 items)
(if (null? items)
nil
(cons (square (car items)) (square-list1 (cdr items)))))
(define (square-list2 items)
(map (lambda (x) (square x)) items))
2.22
cons は第1引数がリストだと、 carにリスト、cdrに末尾要素への参照が入ってしまうため、 出力が1つのリストにならない。
(cons '(1 2) 3) ; => '((1 2) . 3)
他方、第1引数が非リスト、第2引数がリストの場合は、 carに先頭要素、cdrにリストへの参照が入るため、 1つのリストとして出力される。
(cons 1 '(2 3)) ; => '(1 2 3)
問題のprogramは、consの第1引数 answerがリストになるため、正しく動作しない。
以下のように、cons を append にしたら、正しく動く
(define (square-list4 items)
(define (iter things answer)
(if (null? things)
answer
(iter (cdr things)
(append answer
(list (square (car things)))))))
(iter items nil))
2.23
(define (for-each proc list)
(cond ((null? list) #t)
(else (proc (car list))
(for-each proc (cdr list)))))
2.24
略
2.25
(cdr (car (cdr (car (cdr (cdr '(1 3 '(5 7) 9)))))))
(car(cdr(car'('(7)))))
(cdr (car (cdr (car (cdr (car (cdr
(car (cdr (car (cdr (car (cdr
(car (cdr (car (cdr (car (cdr
(car (cdr
'(1 '(2 '(3 '(4 '(5 '(6 7)))))))))))))))))))))))))))
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))
2.27
(define (deep-reverse items)
(if (pair? items)
(append
(deep-reverse (cdr items))
(list (deep-reverse (car items))))
items))
2.28
(define nil (list))
(define (fringe lst)
(if (null? lst)
nil
(let ((first (car lst)))
(if (pair? first)
(append (fringe first) (fringe (cdr lst)))
(append (list first) (fringe (cdr lst)))))))
2.29 a-c
#lang Racket
(define (make-mobile left right) (list left right))
(define (make-branch length structure) (list length structure))
; 29a
(define (left-branch m) (car m))
(define (right-branch m) (car (cdr m)))
(define (branch-length b) (car b))
(define (branch-structure b) (car (cdr b)))
; 29b
(define (total-weight m)
(if (pair? m)
(+ (total-weight (branch-structure (left-branch m)))
(total-weight (branch-structure (right-branch m))))
m))
; 29c
(define (balanced? m)
(if (pair? m)
(let ((left-st (branch-structure (left-branch m)))
(left-len (branch-length (left-branch m)))
(right-st (branch-structure (right-branch m)))
(right-len (branch-length (right-branch m))))
(and
(= (* left-len (total-weight left-st))
(* right-len (total-weight right-st)))
(balanced? left-st)
(balanced? right-st)))
#t))
2.29d
アクセッサーを変えればOK（ここが抽象化の壁として機能する）
(define (right-branch m) (cdr m)) (define (branch-structure b) (cdr b))
2.30
#lang racket
(define nil '())
(define (square-tree tree)
(cond ((null? tree) nil)
((not (pair? tree)) (* tree tree))
(else (cons (square-tree (car tree))
(square-tree (cdr tree))))))
(define (square-tree2 tree)
(map (lambda (sub-tree)
(if (pair? sub-tree)
(square-tree2 sub-tree)
(* sub-tree sub-tree)))
tree))
(define (map proc items)
(if (null? items) nil
(cons (proc (car items))
(map proc (cdr items)))))
2.31
#lang racket
(define nil '())
(define (square-tree tree)
(tree-map square tree))
(define (tree-map proc tree)
(cond ((null? tree) nil)
((not (pair? tree)) (proc tree))
(else (cons (tree-map proc (car tree))
(tree-map proc (cdr tree))))))
(define (square x) (* x x))
2.32
(define (subsets s)
(if (null? s)
(list nil)
(let ((rest (subsets (cdr s))))
(append rest
(map
(lambda (x)
(cons (car s) x))
rest))))
2.33
#lang racket
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(define (length sequence)
(accumulate
(lambda (x y) (+ 1 y))
0
sequence))
(define lst (list 1 2 3 4))
(define lst2 (list 5 6 7 8))
(define (square x) (* x x))
(map square lst)
(append lst lst2)
(length lst)
2.34
#lang racket
(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))
2.35
#lang racket
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define (fringe lst)
(if (null? lst)
nil
(let ((first (car lst)))
(if (pair? first)
(append (fringe first) (fringe (cdr lst)))
(append (list first) (fringe (cdr lst)))))))
(define (count-leaves t)
(accumulate +
0
(map (lambda (x) 1) (fringe t))))
2.36
#lang racket
(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 nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
(define s (list (list 1 2 3) (list 4 5 6) (list 7 8 9) (list 10 11 12)))
(accumulate-n + 0 s)
2.37
#lang Racket
; Σ v_i w_i
(define (dot-product v w)
(accumulate + 0 (map * v w)))
; t_i = Σ m_ij v_j
(define (matrix-*-vector m v)
(map (lambda (m_i) (dot-product m_i v)) m ))
(define (transpose mat)
(accumulate-n cons nil mat))
;p_ij = Σ m_ik n_kj
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map
(lambda (m_i)
(map
(lambda (n_j) (dot-product m_i n_j))
cols))
m)))
(define nil (list))
(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 (map p sequence)
(accumulate
(lambda (x y)
(cons (p x) y))
nil
sequence))
2.38
(fold-right / 1 (list 1 2 3)) ;-> 3/2 (fold-left / 1 (list 1 2 3)) ;-> 1/6 (fold-right list nil (list 1 2 3)) ;-> '(1 (2 (3 ()))) (fold-left list nil (list 1 2 3)) ;-> '(((() 1) 2) 3)
等価となる条件は
(op a b) と (op b a) の結果が等しいこと（交換法則）
2.39
(define (reverse-right sequence)
(fold-right
(lambda (x y) (append y (list x) ))
nil
sequence))
(define (reverse-left sequence)
(fold-left
(lambda (x y) (cons y x ))
nil
sequence))
2.40
#lang racket
(require math/number-theory)
(define (uniq-pair n)
(filter prime-sum?
(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 (uniq-pair n)))
(define (flatmap proc seq)
(accumulate append nil (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))))
;accumulate
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
;map
(define (map p sequence)
(accumulate
(lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
2.41
#lang racket
(require math/number-theory)
; 0<i<j<k=<n
; i+j+k=s
(define (uniq-triple 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 (sum-triple seq)
(+ (car seq) (cadr seq) (caddr seq)))
(define (find-s-triple n s)
(define (s-sum? seq)
(if (= s (sum-triple seq)) #t #f))
(filter s-sum? (uniq-triple n)))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
;accumulate
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
;map
(define (map p sequence)
(accumulate
(lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
(uniq-triple 10)
(find-s-triple 10 10)
2.42
#lang racket
(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))
;queenの置き方
;queenの置かれた座標のリストとして定義.
;第1要素は今おいたクイーンとする
;((k col_k) (k-1 col_k-1) ... (1 col_1))
(define empty-board '())
(define (adjoin-position new-row k rest-of-queens)
(cons (cons k new-row) rest-of-queens))
;safe
;考慮すべき条件は以下の2パターン
;同じcolに存在 (col_k = col_i)
;斜めに存在 (col_k=col_i+(k-i) or col_k=col_i-(k-i) )
(define (safe? k positions)
(let ((k-queen (car positions)))
(define (iter rest-pos)
(if (null? rest-pos)
#t
(let ((i-queen (car rest-pos)))
(if (or (= (cdr k-queen) (cdr i-queen))
(= (cdr k-queen)
(+ (cdr i-queen) (- (car k-queen) (car i-queen))))
(= (cdr k-queen)
(- (cdr i-queen) (- (car k-queen) (car i-queen)))))
#f
(iter (cdr rest-pos))))))
(iter (cdr positions))))
(define (flatmap proc seq)
(accumulate append nil (map proc seq)))
(define nil (list))
(define (accumulate op initial sequence)
(if (null? sequence)
initial
(op (car sequence)
(accumulate op initial (cdr sequence)))))
(define (map p sequence)
(accumulate (lambda (x y) (cons (p x) y)) nil sequence))
(define (enumerate-interval low high)
(if (> low high)
nil
(cons low (enumerate-interval (+ low 1) high))))
2.43
2.42のflatmap
(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))))))
Louisのflatmap
(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))
2.42 は kが増える都度、(queen-cols (- k 1) のフィルタされた結果に対して適用するのに対して、 Louisは 毎回すべてのアイテムに対して適用を行うため、効率が悪い。
毎回board-size回の適用が必要になるため、結果 board-sizeboard-size 回の不要な演算が必要になる。
2.42の演算回数を T(board-size)とすると、Loiusの場合はT(board-sizeboard-size)となる。
2.44
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
2.45
#lang racket
(require sicp-pict)
;new definition
(define (split first-ope second-ope)
(define (iter painter n)
(if (= n 0)
painter
(let ((smaller (iter painter (- n 1))))
(first-ope painter (second-ope smaller smaller)))))
iter)
(define right-split2 (split beside below))
(define up-split2 (split below beside))
;old definition
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;test
(paint (right-split einstein 3))
(paint (right-split2 einstein 3))
(paint (up-split einstein 3))
(paint (up-split2 einstein 3))
2.46
(define (make-vect2 xcor ycor) (cons xcor ycor))
(define (xcor-vect vect) (car vect))
(define (ycor-vect vect) (cdr vect))
(define (add-vect v1 v2)
(make-vect2 (+ (xcor-vect v1) (xcor-vect v2))
(+ (ycor-vect v1) (ycor-vect v2))))
(define (sub-vect v1 v2)
(make-vect2 (- (xcor-vect v1) (xcor-vect v2))
(- (ycor-vect v1) (ycor-vect v2))))
(define (scale-vect scala vect)
(make-vect2 (* scala (xcor-vect vect))
(* scala (ycor-vect vect))))
2.47
;1つめ (define (make-frame1 origin edge1 edge2) (list origin edge1 edge2)) (define (origin-frame1 frame) (car frame)) (define (edge1-frame1 frame) (cadr frame)) (define (edge2-frame1 frame) (caddr frame)) ;2つめ (define (make-frame2 origin edge1 edge2) (cons origin (cons edge1 edge2))) (define (origin-frame2 frame) (car frame)) (define (edge1-frame2 frame) (cadr frame)) (define (edge2-frame2 frame) (cddr frame))
2.48
;segment (define (make-segment2 start end) (cons start end)) (define (segment-start2 segment) (car segment)) (define (segment-end2 segment) (cdr segment))
2.49
#lang Racket
(require sicp-pict)
;a
(define (frame->painter frame)
(let ((origin (frame-origin frame))
(edge1 (frame-edge1 frame))
(edge2 (frame-edge2 frame))
(end (vector-sub (vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))))
(segments->painter
(list
(make-segment origin edge1)
(make-segment origin edge2)
(make-segment edge1 end)
(make-segment edge2 end)))))
;b
(define (x-frame->painter frame)
(let ((origin (frame-origin frame))
(edge1 (frame-edge1 frame))
(edge2 (frame-edge2 frame))
(end (vector-sub (vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))))
(segments->painter
(list
(make-segment origin end)
(make-segment edge1 edge2)))))
;c
;frameの頂点ではなく菱型の各頂点を規定する
(define (mid-frame->painter frame)
(let ((org-edge1
(vector-scale 0.5
(vector-add (frame-origin frame)
(frame-edge1 frame))))
(org-edge2
(vector-scale 0.5
(vector-add (frame-origin frame)
(frame-edge2 frame))))
(end-edge1
(vector-scale 0.5
(vector-add (vector-sub
(vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))
(frame-edge1 frame))))
(end-edge2
(vector-scale 0.5
(vector-add (vector-sub
(vector-add (frame-edge1 frame) (frame-edge2 frame))
(frame-origin frame))
(frame-edge2 frame)))))
(segments->painter
(list
(make-segment org-edge1 org-edge2)
(make-segment org-edge1 end-edge1)
(make-segment org-edge2 end-edge2)
(make-segment end-edge1 end-edge2)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (cadr points))))
(cons (make-segment (make-vect (car p1) (cadr p1))
(make-vect (car p2) (cadr p2)))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
2.50
#lang Racket
(require sicp-pict)
(define (flip-horiz2 painter)
((transform-painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0))
painter))
(define (rotate1802 painter)
((transform-painter
(make-vect 1.0 1.0)
(make-vect 0.0 1.0)
(make-vect 1.0 0.0))
painter))
(define (rotate2702 painter)
(rotate180 (rotate90 painter)))
本文のtransform-painterとsicp-pictのtransfrom-painterは定義が異なる。 上記は、sicp-pict似合わせた実装。
2.51
(define (below2 painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-bottom
((transform-painter
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point)
painter1))
(paint-up
((transform-painter
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))
painter2)))
(lambda (frame)
(paint-bottom frame)
(paint-up frame)))))
(define (below3 painter1 painter2)
(rotate270
(beside
(rotate90 painter2)
(rotate90 painter1))))
2.52
a
#lang racket
(require sicp-pict)
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint smiled-wave)
b
和田先生訳がよくわからなかったので以下のように解釈。
b.Change the pattern constructed by corner-split (for example, by using only one copy of the up-split and right-split images instead of two).
corner-splitが描くパターンを変更せよ。 例）up-splitとright-splitが描くイメージを2つずつではなく1つずつだけ使用する）
#lang racket
(require sicp-pict)
(define (corner-split2 painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((corner (corner-split2 painter (- n 1))))
(beside (below painter up)
(below right corner))))))
;helper
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint (corner-split2 smiled-wave 2))
c
c.Modify the version of square-limit that uses square-of-four so as to assemble the corners in a different pattern. (For example, you might make the big Mr. Rogers look outward from each corner of the square.)
square-limit （square-of-four使う版）が違う絵を描くように変更しろ。 （例： 一番大きいMrRogerの絵が四角の四隅に配置されるようにする）
#lang racket
(require sicp-pict)
(define (square-limit2 painter n)
(let ((combine4 (square-of-four flip-vert rotate180
identity flip-horiz)))
(combine4 (corner-split2 painter n))))
;helper
(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 (corner-split2 painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((corner (corner-split2 painter (- n 1))))
(beside (below painter up)
(below right corner))))))
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
;wave
(define (points->segments points)
(if (null? (cdr points))
'()
(let ((p1 (car points))
(p2 (car (cdr points))))
(cons (make-segment (make-vect (car p1) (car (cdr p1)))
(make-vect (car p2) (car (cdr p2))))
(points->segments (cdr points))))))
(define wave
(let ((wp1 '((0.25 0)
(0.34 0.4)
(0.35 0.58)
(0.16 0.5)
(0 0.68)))
(wp2 '((0 0.78)
(0.16 0.61)
(0.30 0.7)
(0.42 0.69)
(0.35 0.82)
(0.42 1)))
(wp3 '((0.58 1)
(0.65 0.82)
(0.58 0.69)
(0.70 0.7)
(0.84 0.61)
(1.0 0.32)))
(wp4 '((0.75 0)
(0.66 0.4)
(0.65 0.58)
(0.80 0.5)
(1.0 0.22)))
(wp5 '((0.37 0)
(0.5 0.35)
(0.63 0))))
(segments->painter (append-map points->segments
(list wp1 wp2 wp3 wp4 wp5)))))
(define left
(let ((eye '((0.40 0.84)
(0.43 0.88)
(0.47 0.84)))
(mouth '((0.46 0.74)
(0.5 0.70))))
(segments->painter (append-map points->segments
(list eye mouth)))))
(define right (flip-horiz left))
(define (smiled-wave frame)
(left frame)
(right frame)
(wave frame))
;test
(paint (square-limit2 smiled-wave 2))
