Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
281 lines (238 sloc) 9.2 KB
;;; Vect
(define (make-vect x y)
(cons x y))
(define (xcor-vect v)
(car v))
(define (ycor-vect v)
(cdr v))
(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))))
;;; Frame
(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 (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))))))
;;; 描画用フレーム
;;; 参考: http://www.serendip.ws/archives/816
(define (draw-line v1 v2)
(display (xcor-vect v1))
(display ",")
(display (ycor-vect v1))
(display ",")
(display (xcor-vect v2))
(display ",")
(display (ycor-vect v2))
(newline))
(define canvas-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 400.0 0.0)
(make-vect 0.0 400.0)))
;;; Segment
(define (make-segment v1 v2)
(cons v1 v2))
(define (start-segment s)
(car s))
(define (end-segment s)
(cdr s))
;;; Painter
(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 diamond->painter
(let* ((v1 (make-vect 0.5 0.0))
(v2 (make-vect 0.0 0.5))
(v3 (make-vect 1.0 0.5))
(v4 (make-vect 0.5 1.0)))
(segments->painter
(list (make-segment v1 v2)
(make-segment v1 v3)
(make-segment v2 v4)
(make-segment v3 v4)))))
;;; wave ペインタ
(define wave
(segments->painter
(list (make-segment (make-vect 0.35 0.85) (make-vect 0.40 1.00))
(make-segment (make-vect 0.65 0.85) (make-vect 0.60 1.00))
(make-segment (make-vect 0.35 0.85) (make-vect 0.40 0.65))
(make-segment (make-vect 0.65 0.85) (make-vect 0.60 0.65))
(make-segment (make-vect 0.60 0.65) (make-vect 0.75 0.65))
(make-segment (make-vect 0.40 0.65) (make-vect 0.30 0.65))
(make-segment (make-vect 0.75 0.65) (make-vect 1.00 0.35))
(make-segment (make-vect 0.60 0.45) (make-vect 1.00 0.15))
(make-segment (make-vect 0.60 0.45) (make-vect 0.75 0.00))
(make-segment (make-vect 0.50 0.30) (make-vect 0.60 0.00))
(make-segment (make-vect 0.30 0.65) (make-vect 0.15 0.60))
(make-segment (make-vect 0.30 0.60) (make-vect 0.15 0.40))
(make-segment (make-vect 0.15 0.60) (make-vect 0.00 0.85))
(make-segment (make-vect 0.15 0.40) (make-vect 0.00 0.65))
(make-segment (make-vect 0.30 0.60) (make-vect 0.35 0.50))
(make-segment (make-vect 0.35 0.50) (make-vect 0.25 0.00))
(make-segment (make-vect 0.50 0.30) (make-vect 0.40 0.00)))))
(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 (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 (beside painter1 painter2)
(let ((split-point (make-vect 0.5 0.0)))
(let ((painter-left
(transform-painter painter1
(make-vect 0.0 0.0)
split-point
(make-vect 0.0 1.0)))
(painter-right
(transform-painter painter2
split-point
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
(lambda (frame)
(painter-left frame)
(painter-right frame)))))
(define (below painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((painter-bottom
(transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(painter-top
(transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(painter-bottom frame)
(painter-top frame)))))
(define (split ope1 ope2)
(lambda (painter n)
(if (= n 0)
painter
(let ((smaller ((split ope1 ope2) painter (- n 1))))
(ope1 painter (ope2 smaller smaller))))))
(define right-split (split beside below))
(define up-split (split below beside))
(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 (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 (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-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 (identity painter)
painter)
(define (square-limit painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split painter n))))
;;; a. wave ペインタに(笑っているような)線分を加えよ
(define wave-smile
(segments->painter
(list (make-segment (make-vect 0.35 0.85) (make-vect 0.40 1.00))
(make-segment (make-vect 0.65 0.85) (make-vect 0.60 1.00))
(make-segment (make-vect 0.35 0.85) (make-vect 0.40 0.65))
(make-segment (make-vect 0.65 0.85) (make-vect 0.60 0.65))
(make-segment (make-vect 0.60 0.65) (make-vect 0.75 0.65))
(make-segment (make-vect 0.40 0.65) (make-vect 0.30 0.65))
(make-segment (make-vect 0.75 0.65) (make-vect 1.00 0.35))
(make-segment (make-vect 0.60 0.45) (make-vect 1.00 0.15))
(make-segment (make-vect 0.60 0.45) (make-vect 0.75 0.00))
(make-segment (make-vect 0.50 0.30) (make-vect 0.60 0.00))
(make-segment (make-vect 0.30 0.65) (make-vect 0.15 0.60))
(make-segment (make-vect 0.30 0.60) (make-vect 0.15 0.40))
(make-segment (make-vect 0.15 0.60) (make-vect 0.00 0.85))
(make-segment (make-vect 0.15 0.40) (make-vect 0.00 0.65))
(make-segment (make-vect 0.30 0.60) (make-vect 0.35 0.50))
(make-segment (make-vect 0.35 0.50) (make-vect 0.25 0.00))
(make-segment (make-vect 0.50 0.30) (make-vect 0.40 0.00))
;; 追加分
(make-segment (make-vect 0.40 0.85) (make-vect 0.43 0.87))
(make-segment (make-vect 0.43 0.87) (make-vect 0.46 0.85))
(make-segment (make-vect 0.54 0.85) (make-vect 0.57 0.87))
(make-segment (make-vect 0.57 0.87) (make-vect 0.60 0.85)))))
;;; b. corner-split で構成されるパターンを変更せよ
;;; up-split, right-split を1つずつ利用する
(define (corner-split2 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. square-limit (square-of-four版) を隅を異なるパターンに修正せよ
;;; 外側を向かせる
(define (square-limit2 painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split (flip-horiz painter) n))))
;;; 使用例
(wave-smile canvas-frame)
((corner-split2 wave 2) canvas-frame)
((square-limit2 wave 2) canvas-frame)
;;; 出力結果を http://sandbox.serendip.ws/sicp_drawing.html の
;;; 上から2つ目のテキストエリアにコピペし、"データ描画"を
;;; クリックして描かれる図形を確認する