λ2.2節
問題 2.17
問題 2.18
問題 2.19
問題 2.20
問題 2.21
問題 2.22
問題 2.23
問題 2.24
問題 2.25
問題 2.26
問題 2.27
問題 2.28
問題 2.29
問題 2.30
問題 2.31
問題 2.32
問題 2.33
問題 2.34
問題 2.35
問題 2.36
問題 2.37
問題 2.38
問題 2.39
問題 2.40
問題 2.41
問題 2.42
問題 2.43
問題 2.44
問題 2.45
問題 2.46
問題 2.47
問題 2.48
問題 2.49
問題 2.50
問題 2.51
問題 2.52
図形言語
問題 2.17
(define (last-pair l)
(if (null? (cdr l))
l
(last-pair (cdr l))))
問題 2.18
(define (reverse l)
(if (null? l)
'()
(append (reverse (cdr l)) (list (car l)))))
問題 2.19
(define (first-denomination coin-values)
(car coin-values))
(define (except-first-denomination coin-values)
(cdr coin-values))
(define (no-more? coin-values)
(null? coin-values))
問題 2.20
(define (same-parity first . rest)
(define (sp f r)
(cond ((null? r) '())
((= (remainder f 2) (remainder (car r) 2))
(cons (car r) (sp f (cdr r))))
(else (sp f (cdr r)))))
(cons first (sp first rest)))
(same-parity 1 2 3 4 5 6 7) ==> (1 3 5 7)
(same-parity 2 3 4 5 6 7) ==> (2 4 6)
問題 2.21
(define (square-list items)
(if (null? items)
'()
(cons (square (car items)) (square-list (cdr items)))))
(define (square-list items)
(map (lambda (x) (square x)) items))
問題 2.22
(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)
となる. 最初nilのanswerに12, 22, 32, ...の順に
consしていくからである.
(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)) ==> ((((() . 1) . 4) . 9) . 16)
となる. 2乗の計算の順は前の定義と同じだが,
2乗したものをcdrの位置へconsしている. 2乗したものはリストでないから,
ドット表記のconsのリストが出来てしまう.
問題 2.23
(define (for-each proc list)
(if (null? list) '()
(begin (proc (car list))
(for-each proc (cdr list)))))
(for-each (lambda (x) (newline) (display x))
(list 57 321 88)) ==>
57
321
88
問題 2.24
(list 1 (list 2 (list 3 4))) ==> (1 (2 (3 4)))
問題 2.25
(car (cdaddr '(1 3 (5 7) 9))) ==> 7
(caar '((7))) ==> 7
(cadadr (cadadr (cadadr '(1 (2 (3 (4 (5 (6 7))))))))) ==> 7
問題 2.26
(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 l)
(if (pair? l)
(append (deep-reverse (cdr l))
(list (deep-reverse (car l))))
l))
(deep-reverse '(1 (2 (3 (4 (5 (6 7))))))) ==> ((((((7 6) 5) 4) 3) 2) 1)
問題 2.28
(define (fringe l)
(if (pair? l)
(if (pair? (car l))
(append (fringe (car l)) (fringe (cdr l)))
(cons (car l) (fringe (cdr l))))
l))
(fringe '(1 (2 (3 (4 (5 (6 7))))))) ==> (1 2 3 4 5 6 7)
問題 2.29
(define (make-mobile left right)
(list left right))
(define (make-branch length structure)
(list length structure))
(define (left-branch mobile) (car mobile))
(define (right-branch mobile) (cadr mobile))
(define (branch-length branch) (car branch))
(define (branch-structure branch) (cadr branch))
(define (total-weight mobile)
(if (not (pair? mobile)) mobile
(let ((left-b (left-branch mobile))
(right-b (right-branch mobile)))
(let ((left-s (branch-structure left-b))
(right-s (branch-structure right-b)))
(+ (total-weight left-s)
(total-weight right-s))))))
(define (balanced? mobile)
(if (not (pair? mobile)) #t
(let ((left-b (left-branch mobile))
(right-b (right-branch mobile)))
(let ((left-s (branch-structure left-b))
(right-s (branch-structure right-b)))
(and
(= (* (branch-length left-b)
(total-weight left-s))
(* (branch-length right-b)
(total-weight right-s)))
(balanced? left-s) (balanced? right-s))))))
(define mymobile '((6 ((1 2) (2 1))) (3 ((2 4) (4 2)))))
(total-weight mymobile) ==> 9
(balanced? mymobile) ==> #t
問題 2.30
(define (square-tree tree)
(cond ((null? tree) '())
((pair? tree) (cons (square-tree (car tree))
(square-tree (cdr tree))))
(else (* tree tree))))
(square-tree (list 1
(list 2 (list 3 4) 5)
(list 6 7)))
(define (square-tree tree)
(if (pair? tree)
(map (lambda (x) (square-tree x)) tree)
(* tree tree)))
(square-tree (list 1
(list 2 (list 3 4) 5)
(list 6 7))) ==> (1 (4 (9 16) 25) (36 49))
問題 2.31
(define (tree-map f tree)
(cond ((null? tree) '())
((not (pair? tree)) (f tree))
(else (cons (tree-map f (car tree))
(tree-map f (cdr tree))))))
(tree-map square (list 1
(list 2 (list 3 4) 5)
(list 6 7))) ==> (1 (4 (9 16) 25) (36 49))
問題 2.32
(define (subsets s)
(if (null? s)
(list '())
(let ((rest (subsets (cdr s))))
(append rest (map (lambda (x) (cons (car s) x))
rest)))))
(subsets '(1 2 3)) ==> (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3))
問題 2.33
(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)) '() sequence))
(map (lambda (x) (* x x)) '(0 1 2 3)) ==> (0 1 4 9)
(define (append seq1 seq2)
(accumulate cons seq2 seq1))
(append '(a b c) '(x y z)) ==> (a b c x y z)
(define (length sequence)
(accumulate (lambda (x y) (+ y 1)) 0 sequence))
(length '(a b c d)) ==> 4
問題 2.34
(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 higer-terms)
(+ (* higer-terms x) this-coeff))
0
coefficient-sequence))
(horner-eval 2 (list 1 3 0 5 0 1)) ==> 79
;; a0a1a2a3a4a5
;; (+ (expt 2 5)
;; (* 5 (expt 2 3))
;; (* 3 (expt 2 1)) 1) = 79
問題 2.35
(define (count-leaves t)
(accumulate + 0
(map (lambda (x) (if (pair? x) (count-leaves x) 1)) t)))
問題 2.36
(define (accumulate-n op init seqs)
(if (null? (car seqs))
'()
(cons (accumulate op init (map car seqs))
(accumulate-n op init (map cdr seqs)))))
問題 2.37
(define (dot-product v w)
(accumulate + 0 (map * v w)))
(define (matrix-*-vector m v)
(map (lambda (x) (dot-product v x)) m))
(define (transpose mat)
(accumulate-n cons '() mat))
(define (matrix-*-matrix m n)
(let ((cols (transpose n)))
(map (lambda (x)
(map (lambda (y) (dot-product x y)) cols)) m)))
問題 2.38
(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)
fold-leftとfold-rightが同じ値になるには, 二項演算opが可換
(commutative つまり a op b = b op a)でなければならない.
問題 2.39
(define (reverse sequence)
(fold-right (lambda (x y) (append y (list x))) '() sequence))
(define (reverse sequence)
(fold-left (lambda (x y) (cons y x)) '() sequence))
問題 2.40
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
(define (enumerate-interval low high)
(if (> low high)
'()
(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 (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(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? (unique-pairs n))))
(define (prime? n)
(define (smallest-divisor n)
(define (find-divisor n test-divisor)
(define (next x)
(if (= x 2) 3
(+ x 2)))
(define (square x) (* x x))
(define (divides? a b)
(= (remainder b a) 0))
(cond ((> (square test-divisor) n) n)
((divides? test-divisor n) test-divisor)
(else (find-divisor n (next test-divisor)))))
(find-divisor n 2))
(= n (smallest-divisor n)))
(prime-sum-pairs 6) ==>
((2 1 3) (3 2 5) (4 1 5) (4 3 7) (5 2 7) (6 1 7) (6 5 11))
問題 2.41
(define (flatmap proc seq)
(accumulate append '() (map proc seq)))
(define (enumerate-interval low high)
(if (> low high)
'()
(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 (unique-triples n)
(flatmap (lambda (i)
(map (lambda (j) (cons i j))
(unique-pairs (- i 1))))
(enumerate-interval 1 n)))
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (s-sum-triples n s)
(filter (lambda (x) (= (apply + x) s))
(unique-triples n)))
(s-sum-triples 10 15) ==> ((6 5 4) (7 5 3) (7 6 2) (8 4 3)
(8 5 2) (8 6 1) (9 4 2) (9 5 1) (10 3 2) (10 4 1))
問題 2.42
(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 (flatmap proc seq)
(accumulate append '() (map proc seq)))
(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)
'()
(cons low (enumerate-interval (+ low 1) high))))
(define (filter predicate sequence)
(cond ((null? sequence) '())
((predicate (car sequence))
(cons (car sequence)
(filter predicate (cdr sequence))))
(else (filter predicate (cdr sequence)))))
(define (adjoin-position new-row k rest-of-queens)
(cons new-row rest-of-queens))
(define (safe? k positions)
(define (safe1 x n)
(or (= n k)
(let ((y (list-ref positions n)))
(and (not (= x y))
(not (= (- x y) n))
(not (= (- y x) n))
(safe1 x (+ n 1))))))
(safe1 (car positions) 1))
(define empty-board '())
(queens 8) ==>
((4 2 7 3 6 8 5 1) (5 2 4 7 3 8 6 1) (3 5 2 8 6 4 7 1) (3 6 4 2 8 5 7 1)
(5 7 1 3 8 6 4 2) (4 6 8 3 1 7 5 2) (3 6 8 1 4 7 5 2) (5 3 8 4 7 1 6 2)
(5 7 4 1 3 8 6 2) (4 1 5 8 6 3 7 2) (3 6 4 1 8 5 7 2) (4 7 5 3 1 6 8 2)
(6 4 2 8 5 7 1 3) (6 4 7 1 8 2 5 3) (1 7 4 6 8 2 5 3) (6 8 2 4 1 7 5 3)
(6 2 7 1 4 8 5 3) (4 7 1 8 5 2 6 3) (5 8 4 1 7 2 6 3) (4 8 1 5 7 2 6 3)
(2 7 5 8 1 4 6 3) (1 7 5 8 2 4 6 3) (2 5 7 4 1 8 6 3) (4 2 7 5 1 8 6 3)
(5 7 1 4 2 8 6 3) (6 4 1 5 8 2 7 3) (5 1 4 6 8 2 7 3) (5 2 6 1 7 4 8 3)
(6 3 7 2 8 5 1 4) (2 7 3 6 8 5 1 4) (7 3 1 6 8 5 2 4) (5 1 8 6 3 7 2 4)
(1 5 8 6 3 7 2 4) (3 6 8 1 5 7 2 4) (6 3 1 7 5 8 2 4) (7 5 3 1 6 8 2 4)
(7 3 8 2 5 1 6 4) (5 3 1 7 2 8 6 4) (2 5 7 1 3 8 6 4) (3 6 2 5 8 1 7 4)
(6 1 5 2 8 3 7 4) (8 3 1 6 2 5 7 4) (2 8 6 1 3 5 7 4) (5 7 2 6 3 1 8 4)
(3 6 2 7 5 1 8 4) (6 2 7 1 3 5 8 4) (3 7 2 8 6 4 1 5) (6 3 7 2 4 8 1 5)
(4 2 7 3 6 8 1 5) (7 1 3 8 6 4 2 5) (1 6 8 3 7 4 2 5) (3 8 4 7 1 6 2 5)
(6 3 7 4 1 8 2 5) (7 4 2 8 6 1 3 5) (4 6 8 2 7 1 3 5) (2 6 1 7 4 8 3 5)
(2 4 6 8 3 1 7 5) (3 6 8 2 4 1 7 5) (6 3 1 8 4 2 7 5) (8 4 1 3 6 2 7 5)
(4 8 1 3 6 2 7 5) (2 6 8 3 1 4 7 5) (7 2 6 3 1 4 8 5) (3 6 2 7 1 4 8 5)
(4 7 3 8 2 5 1 6) (4 8 5 3 1 7 2 6) (3 5 8 4 1 7 2 6) (4 2 8 5 7 1 3 6)
(5 7 2 4 8 1 3 6) (7 4 2 5 8 1 3 6) (8 2 4 1 7 5 3 6) (7 2 4 1 8 5 3 6)
(5 1 8 4 2 7 3 6) (4 1 5 8 2 7 3 6) (5 2 8 1 4 7 3 6) (3 7 2 8 5 1 4 6)
(3 1 7 5 8 2 4 6) (8 2 5 3 1 7 4 6) (3 5 2 8 1 7 4 6) (3 5 7 1 4 2 8 6)
(5 2 4 6 8 3 1 7) (6 3 5 8 1 4 2 7) (5 8 4 1 3 6 2 7) (4 2 5 8 6 1 3 7)
(4 6 1 5 2 8 3 7) (6 3 1 8 5 2 4 7) (5 3 1 6 8 2 4 7) (4 2 8 6 1 3 5 7)
(6 3 5 7 1 4 2 8) (6 4 7 1 3 5 2 8) (4 7 5 2 6 1 3 8) (5 7 2 6 3 1 4 8))
問題 2.43
問題2.42のqueensはqueen-colsを最初(queen-cols 8)で呼ぶ.
その中では(queen-cols 7)を1回呼んで, そのそれぞれに1から8を追加し,
解かどうか調べる. (queen-cols 7)の中では, (queen-cols 6)を1回呼ぶ.
以下これを繰り返す.
一方, 本文のqueensでは(queen-cols 8)はまず1から8を生成し,
そのそれぞれに対して(queen-cols 7)を呼ぶので, 合計8回呼ばれる.
同様にそのそれぞれで(queen-cols 6)は8回呼ばれる. 以下これを繰り返す.
したがって
| k | 8 | 7 | 6 | 5 | 4 | 3 | 2 | 1 |
| 呼ばれる回数 | 1 | 8 | 8^2 | 8^3 | 8^4 | 8^5 | 8^6 | 8^7 |
この合計は (8^8 - 1)/7. 問題2.42の方は8回だから, それをTとすれば
((8^8 - 1)/ 7)/ 8 ≒ 8^6
問題 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
(define (split op1 op2)
(lambda (painter n)
(if (= n 0)
painter
(let ((smaller ((split op1 op2) painter (- n 1))))
(op1 painter (op2 smaller smaller))))))
問題 2.46
(define (make-vect xcor ycor)
(cons xcor ycor))
(define (xcor-vect vector)
(car vector))
(define (ycor-vect vector)
(cdr vector))
(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))))
問題 2.47
(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))
(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))
問題 2.48
(define (make-segment startpoint endpoint)
(cons startpoint endpoint))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cdr segment))
問題 2.49
(define outline-painter
(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 0 1))
(make-segment (make-vect 0 1) (make-vect 0 0)))))
(define X-painter
(segments->painter
(list (make-segment (make-vect 0 0) (make-vect 1 1))
(make-segment (make-vect 1 0) (make-vect 0 1)))))
(define diamond-painter
(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)))))
(define wave-painter
(segments->painter
(list (make-segment (make-vect 0.000 0.645) (make-vect 0.154 0.411))
(make-segment (make-vect 0.154 0.411) (make-vect 0.302 0.588))
(make-segment (make-vect 0.302 0.588) (make-vect 0.354 0.497))
(make-segment (make-vect 0.354 0.497) (make-vect 0.245 0.000))
(make-segment (make-vect 0.419 0.000) (make-vect 0.497 0.171))
(make-segment (make-vect 0.497 0.171) (make-vect 0.575 0.000))
(make-segment (make-vect 0.748 0.000) (make-vect 0.605 0.462))
(make-segment (make-vect 0.605 0.462) (make-vect 1.000 0.142))
(make-segment (make-vect 1.000 0.354) (make-vect 0.748 0.657))
(make-segment (make-vect 0.748 0.657) (make-vect 0.582 0.657))
(make-segment (make-vect 0.582 0.657) (make-vect 0.640 0.857))
(make-segment (make-vect 0.640 0.857) (make-vect 0.575 1.000))
(make-segment (make-vect 0.419 1.000) (make-vect 0.354 0.857))
(make-segment (make-vect 0.354 0.857) (make-vect 0.411 0.657))
(make-segment (make-vect 0.411 0.657) (make-vect 0.285 0.657))
(make-segment (make-vect 0.285 0.657) (make-vect 0.154 0.605))
(make-segment (make-vect 0.154 0.605) (make-vect 0.000 0.857)))))
問題 2.50
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1.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 1.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)))
問題 2.51
(define (below painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-below
(transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(paint-above
(transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(paint-below frame)
(paint-above frame)))))
(define (below painter1 painter2)
(rotate90
(beside (rotate270 painter1)
(rotate270 painter2))))
問題 2.52
;a
(define wave
(list (make-segment (make-vect 0.000 0.645) (make-vect 0.154 0.411))
(make-segment (make-vect 0.154 0.411) (make-vect 0.302 0.588))
(make-segment (make-vect 0.302 0.588) (make-vect 0.354 0.497))
(make-segment (make-vect 0.354 0.497) (make-vect 0.245 0.000))
(make-segment (make-vect 0.419 0.000) (make-vect 0.497 0.171))
(make-segment (make-vect 0.497 0.171) (make-vect 0.575 0.000))
(make-segment (make-vect 0.748 0.000) (make-vect 0.605 0.462))
(make-segment (make-vect 0.605 0.462) (make-vect 1.000 0.142))
(make-segment (make-vect 1.000 0.354) (make-vect 0.748 0.657))
(make-segment (make-vect 0.748 0.657) (make-vect 0.582 0.657))
(make-segment (make-vect 0.582 0.657) (make-vect 0.640 0.857))
(make-segment (make-vect 0.640 0.857) (make-vect 0.575 1.000))
(make-segment (make-vect 0.419 1.000) (make-vect 0.354 0.857))
(make-segment (make-vect 0.354 0.857) (make-vect 0.411 0.657))
(make-segment (make-vect 0.411 0.657) (make-vect 0.285 0.657))
(make-segment (make-vect 0.285 0.657) (make-vect 0.154 0.605))
(make-segment (make-vect 0.154 0.605) (make-vect 0.000 0.857))
(make-segment (make-vect 0.428 0.828) (make-vect 0.471 0.840));左目 追加
(make-segment (make-vect 0.528 0.840) (make-vect 0.571 0.828));右目 追加>
))
((segments->painter wave) unit-square)
;b
(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)))))
;((corner-split (segments->painter wave) 2) unit-square)
;c
(define (corner-split painter n)
(if (= n 0)
(flip-horiz 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-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 (square-limit painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split painter n))))
(define (identity x) x)
(define (image->painter)
(lambda (frame)
(let ((origin ((frame-coord-map frame) (make-vect 0 0)))
(edge1 ((frame-coord-map frame) (make-vect 1.0 0)))
(edge2 ((frame-coord-map frame) (make-vect 0 1.0))))
(newline)
(display (list (- (car edge1) (car origin))
(- (cdr edge1) (cdr origin))
(- (car edge2) (car origin))
(- (cdr edge2) (cdr origin))
(car origin) (cdr origin))))))
((square-limit (image->painter) 2) unit-square)
図形言語
単位方形のフレームに頂点を結んでXを描くには
X の segment-list を作る
(define X
(list (make-segment (make-vect 0 0) (make-vect 1 1))
(make-segment (make-vect 0 1) (make-vect 1 0))))
これをペインタ(フレームに作用させる)手続きに変える
(define X-painter
(segment->painter X))
一方単位方形のフレームを定義する.
(define unit-square
(make-frame (make-vect 0 0) ;; 原点
(make-vect 1 0) ;; x軸の単位ベクトル
(make-vect 0 1)) ;; y軸の単位ベクトル
ペインタをフレームに作用させる
(X-painter unit-frame)
以下に図形言語の手続きがある. このファイルをpictlangという
pictlang
(define (draw-line p0 p1) ;;点p0からp1への線を引く
;;PostScriptのコマンドをだす.
(display (list (* (xcor-vect p0) 400)
(* (ycor-vect p0) 400)
'moveto
(* (xcor-vect p1) 400)
(* (ycor-vect p1) 400)
'lineto
'stroke))
(newline))
(define (make-vect xcor ycor)
(cons xcor ycor))
(define (xcor-vect vector)
(car vector))
(define (ycor-vect vector)
(cdr vector))
(define (make-segment startpoint endpoint)
(cons startpoint endpoint))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cdr segment))
(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))
(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 (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 (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)))
(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 (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 triangle
(list (make-segment (make-vect 0 0) (make-vect 0.5 1))
(make-segment (make-vect 0.5 1) (make-vect 1 0))
(make-segment (make-vect 1 0) (make-vect 0 0))))
(define wave
(list (make-segment (make-vect 0.000 0.645) (make-vect 0.154 0.411))
(make-segment (make-vect 0.154 0.411) (make-vect 0.302 0.588))
(make-segment (make-vect 0.302 0.588) (make-vect 0.354 0.497))
(make-segment (make-vect 0.354 0.497) (make-vect 0.245 0.000))
(make-segment (make-vect 0.419 0.000) (make-vect 0.497 0.171))
(make-segment (make-vect 0.497 0.171) (make-vect 0.575 0.000))
(make-segment (make-vect 0.748 0.000) (make-vect 0.605 0.462))
(make-segment (make-vect 0.605 0.462) (make-vect 1.000 0.142))
(make-segment (make-vect 1.000 0.354) (make-vect 0.748 0.657))
(make-segment (make-vect 0.748 0.657) (make-vect 0.582 0.657))
(make-segment (make-vect 0.582 0.657) (make-vect 0.640 0.857))
(make-segment (make-vect 0.640 0.857) (make-vect 0.575 1.000))
(make-segment (make-vect 0.419 1.000) (make-vect 0.354 0.857))
(make-segment (make-vect 0.354 0.857) (make-vect 0.411 0.657))
(make-segment (make-vect 0.411 0.657) (make-vect 0.285 0.657))
(make-segment (make-vect 0.285 0.657) (make-vect 0.154 0.605))
(make-segment (make-vect 0.154 0.605) (make-vect 0.000 0.857))))
(define unit-square
(make-frame (make-vect 0 0) (make-vect 1 0)
(make-vect 0 1)))
(define (beside painter1 painter2)
(let ((split-point (make-vect 0.5 0.0)))
(let ((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)))
(let ((paint-below
(transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(paint-above
(transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(paint-below frame)
(paint-above frame)))))
(define triangle-painter
(segments->painter triangle))
(newline)
(triangle-painter unit-square)
(newline)
((flip-vert triangle-painter) unit-square)
(newline)
((beside triangle-painter (flip-vert triangle-painter))
unit-square)
(define wave-painter
(segments->painter wave))
(wave-painter unit-square)
(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)))))
(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))))))
((below triangle-painter (flip-vert triangle-painter)) unit-square)
(display "showpage") (newline)
((right-split triangle-painter 4) unit-square)
(display "showpage") (newline)
((corner-split wave-painter 4) unit-square)
(display "showpage") (newline)
(define (split op1 op2)
(lambda (painter n)
(if (= n 0)
painter
(let ((smaller ((split op1 op2) painter (- n 1))))
(op1 painter (op2 smaller smaller))))))
(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 (rotate90 painter)
(transform-painter painter
(make-vect 1.0 0.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)
(rotate90
(beside (rotate270 painter1)
(rotate270 painter2))))