SICPの図形言語をやってみました。（SICP 2.2.4 ： P.73～）
役に立つかはわかりませんが、これからやる人の参考になるものがあれば良いなと思います。
出力はPostScriptで良いや。と思ってやりましたが、テストが面倒なのであまりオススメできません。何かGUIでも作りたいなーと思っています。
ソースの全容はこちらにアップしました。
segments
segmentのリスト同士を合成するappend-segments手続きを追加してみました。ただlistを連結しているだけですけども。
各セグメントのコード（データ）は割愛。必要であればこちらにあります。
| ;;; segments (define make-segment cons) (define start-segment car) (define end-segment cdr) ; segmentsの座標をframeに対する相対値に変換
(define segments->painter
(lambda (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)))) ; segmentsを合体させる
(define append-segments
(lambda segments
(apply append segments))) |
frames
frame-coord-mapが
origin(frame) + x * edge1(frame) + y * edge2(frame)をそのままコードに直してあるだけなのはわかるのですが、どういう意味なのかよく理解できませんでした。図に描いてみたところ座標がどのように変換されるかはわかりましたが・・・、なんかよくわかりません。
フレームはいくつか適当に作ってみました。下方にサンプルがあります。
| ;;; frames (define make-frame
(lambda (origin edge1 edge2)
(list origin edge1 edge2))) (define origin-frame car) (define edge1-frame cadr) (define edge2-frame caddr) ; origin(frame) + x * edge1(frame) + y * edge2(frame)
(define frame-coord-map
(lambda (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))))))) |
frameのコードと画像。ペインタはwaveとoutlineを組み合わせてフレームの形がわかるように表示してみました。
| (define square-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 1.0 0.0)
(make-vect 0.0 1.0))) 
|
| (define parallelogram-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 0.5 0.0)
(make-vect 0.5 1)))
 |
| (define left-vert-rect-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 0.5 0.0)
(make-vect 0 1)))
 |
| (define bottom-horiz-rect-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 1.0 0.0)
(make-vect 0.0 0.5)))
 |
| (define half-square-frame
(make-frame (make-vect 0.25 0.25)
(make-vect 0.5 0.0)
(make-vect 0.0 0.5)))
 |
| (define parallelogram-narrow-frame
(make-frame (make-vect 0.0 0.0)
(make-vect 0.75 0.5)
(make-vect 0.5 0.75)))
 |
operators
ペインタの変換などを行なう手続き群。
transform-painterも上記のframe-coord-map同様よくわからず、何度か絵を描いてみてなんとかわかりました。
各手続きを適用したサンプル画像は下方あります。
| (define identity
(lambda (painter)
painter)) (define compose
(lambda (f)
(lambda (g)
(lambda (x)
(f (g x)))))) ; 実際はフレームを変形させている
; transform-relative-frameとか
; 与えられた3点を用いてframeに相対的な変換を行なう
(define transform-painter
(lambda (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)))))))) ; add
; 複数のペインタを一つのフレームに描画する
(define superpose
(lambda painters
(lambda (frame)
(for-each (lambda (painter)
(painter frame))
painters)))) ; add
; 指定した回数ペインタを連結する
(define coupling
(lambda (combinator)
(lambda (painter1 n)
((repeated (lambda (painter2)
(combinator painter1 painter2)) n)
painter1)))) ; add
(define repeated
(lambda (effecter n)
(lambda (painter)
(if (zero? n)
painter
((repeated effecter (- n 1)) (effecter painter)))))) ; add
(define quart
(lambda (vert horiz)
(lambda (painter)
(((compose vert) horiz) painter)))) |
| (define rotate90
(lambda (painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))) 
|
| ;; (define rotate180
;; (lambda (painter)
;; (transform-painter painter
;; (make-vect 1.0 1.0)
;; (make-vect 0.0 1.0)
;; (make-vect 1.0 0.0))))
(define rotate180
(lambda (painter)
((repeated rotate90 2) painter)))
 |
| ;; (define rotate270
;; (lambda (painter)
;; (transform-painter painter
;; (make-vect 0.0 1.0)
;; (make-vect 0.0 0.0)
;; (make-vect 1.0 1.0))))
(define rotate270
(lambda (painter)
((repeated rotate90 3) painter)))
 |
| (define flip-vert
(lambda (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
(lambda (painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0))))
 |
| (define left-half
(lambda (painter)
(transform-painter painter
(make-vect 0.0 0.0)
(make-vect 0.5 0.0)
(make-vect 0.0 1.0))))
 |
| (define right-half
(lambda (painter)
(transform-painter painter
(make-vect 0.5 0.0)
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
 |
| (define top-half
(lambda (painter)
(transform-painter painter
(make-vect 0.0 0.5)
(make-vect 1.0 0.5)
(make-vect 0.0 1.0)))) 
|
| (define bottom-half
(lambda (painter)
(transform-painter painter
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
(make-vect 0.0 0.5))))
 |
| ;; (lambda (painter)
;; (transform-painter painter
;; (make-vect 0.0 0.0)
;; (make-vect 0.5 0.0)
;; (make-vect 0.0 1.0)))) ;; (define beside
;; (lambda (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 beside
(lambda (painter1 painter2)
(lambda (frame)
((superpose (left-half painter1)
(right-half painter2)) frame))))
 |
| ;; (define below
;; (lambda (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
(lambda (painter1 painter2)
(lambda (frame)
((superpose (bottom-half painter1)
(top-half painter2)) frame))))
 |
| (define right-split
(split beside below))
 |
| (define up-split
(split below beside))
 |
| (define corner-split
(lambda (painter n)
(if (zero? n)
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
(lambda (painter n)
(let ((combine4 (square-of-four flip-horiz identity
rotate180 flip-vert)))
(combine4 (corner-split painter n)))))
 |
| (define cross-limit
(lambda (painter n)
(if (zero? n)
painter
(let ((cross (cross-limit painter (- n 1))))
(let ((top (beside painter cross))
(bottom (beside cross painter)))
(below bottom top))))))
 |
| (define cross-corner-limit
(coupling (lambda (painter1 painter2)
(below painter1 (beside painter1 painter2)))))
 |
| (define grid-limit
(lambda (painter n)
(if (zero? n)
painter
(grid-limit ((square-of-four identity identity
identity identity) painter)
(- n 1)))))
 |
| (define triple
(lambda (painter1 painter2 painter3)
(below
(beside painter2 painter3)
(squash-left painter1))))
 |
| (define dog-ear
(lambda (painter)
((coupling (lambda (painter1 painter2)
(triple painter2 painter1 painter2)))
painter 3)))
 |
| (define flipped-pairs
(lambda (painter)
(let ((painter2 (beside painter (flip-vert painter))))
(below painter2 painter2))))
 |
samples
その他、組み合わせのサンプル。とくに気の利いたものはありません。
| ; sample-001
((square-limit
(let ((friend (beside wave-painter (flip-horiz wave-painter))))
(below friend (flip-vert friend))) 3) square-frame)
 |
| ; sample-002
((corner-split hexagon-painter 5) square-frame)
 |
| ; sample-003
((square-limit diamond-painter 4) square-frame)
 |
| ; sample-004
((square-limit (superpose X-painter diamond-painter) 3) square-frame)
 |
| ; sample-005
((square-limit (superpose X-painter cross-painter diamond-painter) 3) square-frame)
 |
| ; sample-006
((square-limit (below (flip-vert (corner-split outline-painter 2))
(right-split outline-painter 2)) 3) square-frame)
 |
| ; sample-007
((cross-limit (right-split X-painter 2) 4) square-frame)
 |
| ; sample-008
((let ((up (up-split (superpose X-painter cross-painter outline-painter) 2)))
(cross-limit (below up (flip-vert up)) 4)) square-frame)
 |
| ; sample-009
((grid-limit wave-painter 4) square-frame)
 |
| ; sample-010
(((coupling below) wave-painter 4) square-frame) 
|
| ; sample-011
((cross-corner-limit wave-painter 4) square-frame)
 |
| ; sample-012
((triple X-painter lambda-painter Z-painter) square-frame)
 |
| ; sample-013
((square-limit (dog-ear outline-painter) 2) square-frame)
 |
| ; sample-014
((square-limit (dog-ear wave-painter) 2) square-frame)
 |
| ; sample-015
(let ((p (let ((p1 ((coupling below) wave-painter 4)))
(let ((p2 (flip-horiz p1)))
(beside p1 p2)))))
((below p (flip-vert p)) square-frame))
 |
課題
- フロントエンドGUIを作る
- 再帰曲線を描いてみる
- 空間充填線を描いてみる
- 黄金四角形とその正方形の中点を結んだ曲線を描いてみる
- 色を付けられるようにする
参考
ジェラルド・ジェイ サスマン ジュリー サスマン ハロルド エイブルソン
ピアソンエデュケーション
売り上げランキング: 51385
おすすめ度の平均:
訳が酷い
紙と鉛筆と計算機と
内容最高。翻訳最低。
食わず嫌いでした。
プログラマにとって必読の本です
0 件のコメント:
コメントを投稿