SICP §2.2.4（図形言語　その９　[ファイルの分割]）

さて、前エントリまででものすごくたくさんのコードを生成したわけだが、ちょっとカオス化してきたのでファイルを分割してみようと思う。と言っても難しく考えるわけじゃなく、ただ各種手続きを複数ファイルに分割し、main.scm で load するだけの単純なものにするというだけのこと。

今まで生成してきたコードは、大まかにつぎのように分けられると思う。

vector.scm	ベクタ関連の手続きをまとめたファイル。
segment.scm	線分関連の手続きをまとめたファイル。
frame.scm	フレーム関連の手続きをまとめたファイル。
painter.scm	ペインタ関連の手続きをまとめたファイル。
main.scm	起動ファイル。main 手続きを含んでいる。

これらの指針に基づいて各構成子、選択子、及び前エントリで記述しておいた各種ペインタ変換手続き等も含めて分類していくと、こんな感じになる。（あ、ちなみに全てのファイルは同一ディレクトリに格納する感じ。）

vector.scm

;;; ==============================
;;; ベクタ関連
;;; ==============================
;構成子・選択子
(define (make-vect x y)
  (cons x y))

(define (xcor-vect v)
  (car v))

(define (ycor-vect v)
  (cdr v))

;ベクタ演算
(define (op-vect op v_1 v_2)
  (let ((x_1 (xcor-vect v_1))
	(y_1 (ycor-vect v_1))
	(x_2 (xcor-vect v_2))
	(y_2 (ycor-vect v_2)))
    (make-vect (op x_1 x_2) (op y_1 y_2))))

(define (add-vect v_1 v_2)
  (op-vect + v_1 v_2))

(define (sub-vect v_1 v_2)
  (op-vect - v_1 v_2))

(define (scale-vect s v)
  (op-vect * (make-vect s s) v))

segment.scm

;;; ==============================
;;; 有向線分関連
;;; ==============================
;構成子・選択子
(define (make-segment start end)
  (cons start end))

(define (start-segment segment)
  (car segment))

(define (end-segment segment)
  (cdr segment))

frame.scm

;;; ==============================
;;; フレーム関連
;;; ==============================
;構成子・選択子
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define (frame-origin frame)
  (car frame))

(define (frame-edge1 frame)
  (cadr frame))

(define (frame-edge2 frame)
  (caddr frame))

;フレーム座標写像
(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (frame-origin frame)
     (add-vect (scale-vect (xcor-vect v)
			   (frame-edge1 frame))
	       (scale-vect (ycor-vect v)
			   (frame-edge2 frame))))))

;;; ==============================
;;; フレームを生成
;;; ==============================
(define frame (make-frame (make-vect 0 0)
			  (make-vect 1 0)
			  (make-vect 0 1)))

実際に線分を描画する手続き（draw-line）、線分を受け取って線画を描画するペインタ手続き（segments->painter）、ペインタを汎用的に変換する手続き（transform-painter）、各種カスタマイズされたペインタ等を定義する。
更に、前エントリの変換手続きを確認するため、「家」の線画を描画するペインタをファイルの一番最後に新たに定義してみた。（菱形ペインタじゃ確認のしようがないからな。）

(use gl)
(use gl.glut)

;;; ==============================
;;; 線分描画手続！
;;; ==============================
(define (draw-line p1 p2)
  (define (t z)
    (- (* 2 z) 1))
  (gl-begin GL_LINE_LOOP)
  (gl-vertex (t (xcor-vect p1)) (t (ycor-vect p1)))
  (gl-vertex (t (xcor-vect p2)) (t (ycor-vect p2)))
  (gl-end))

;;; ==============================
;;; 線画用ペインタ生成手続
;;; ==============================
(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)
    ;受け取ったframeに元づいたベクタ変換を行う手続を m に束縛する。
    (let ((m (frame-coord-map frame)))
      ;生成したベクタ変換手続を使用して、本手続きの生成時に渡された基点ベクタを変換。
      (let ((new-origin (m origin)))
	;本手続きの生成時に渡された辺ベクタ（２つ）を手続 m で変換し、
	;更にそれらと変換後の基点ベクタとの差分を求めて新しいフレームを生成、
	;そのフレームをペインタに渡して描画を行う。
	(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)   ;新しい origin
		     (make-vect 1.0 1.0)   ;edge1 の新しい端点
		     (make-vect 0.0 0.0))) ;edge2 の新しい端点

;与えられたフレームの右上の四半分に画像を縮めるペインタ
(define (shrink-to-upper-right painter)
  (transform-painter painter
		     (make-vect 0.5 0.5)   ;origin をフレームの中心に指定
		     (make-vect 1.0 0.5)   ;edge1 を中心点から考えて指定
		     (make-vect 0.5 1.0))) ;edge2 を中心点から考えて指定

;反時計回りに 90° 回転するペインタ
(define (rotate90 painter)
  (transform-painter painter
		     (make-vect 1.0 0.0)   ;origin を右下隅に指定
		     (make-vect 1.0 1.0)   ;edge1 を右上隅に指定
		     (make-vect 0.0 0.0))) ;edge2 を原点に指定

;フレームの右上と左下を結ぶ線を中心として圧縮描画するペインタ（菱形に表示されるっぽ。）
(define (squash-inwards painter)
  (transform-painter painter
		     (make-vect 0.0 0.0)
		     (make-vect 0.65 0.35)
		     (make-vect 0.35 0.65)))

;第１引数のペインタを左側へ、第２引数のペインタを右側へ表示するペインタ
;（※「beside」ですよ〜♪）
(define (beside painter1 painter2)
  ;右側用と左側用のペインタを先に生成しちゃう。
  (let ((left (transform-painter painter1
				 (make-vect 0.0 0.0)
				 (make-vect 0.5 0.0)
				 (make-vect 0.0 1.0)))
	(right (transform-painter painter2
				  (make-vect 0.5 0.0)
				  (make-vect 1.0 0.0)
				  (make-vect 0.5 1.0))))
    ;生成したペインタを使って描画する合成ペインタを返す。
    (lambda (frame)
      (left frame)
      (right frame))))

;;; ==============================
;;; 各種ペインタ
;;; ==============================
; 菱形ペインタ
(define diamond
  (segments->painter (list
		      (make-segment (make-vect 0.0 0.5)
				    (make-vect 0.5 1.0))
		      (make-segment (make-vect 0.5 1.0)
				    (make-vect 1.0 0.5))
		      (make-segment (make-vect 1.0 0.5)
				    (make-vect 0.5 0.0))
		      (make-segment (make-vect 0.5 0.0)
				    (make-vect 0.0 0.5)))))

; 家ペインタ
(define house
  (segments->painter (list
		      (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.2 0.5))
		      (make-segment (make-vect 0.2 0.5)
				    (make-vect 0.2 0.0))
		      (make-segment (make-vect 0.2 0.0)
				    (make-vect 0.8 0.0))
		      (make-segment (make-vect 0.8 0.0)
				    (make-vect 0.8 0.5))
		      (make-segment (make-vect 0.8 0.5)
				    (make-vect 1.0 0.5))
		      (make-segment (make-vect 1.0 0.5)
				    (make-vect 0.8 0.7))
		      (make-segment (make-vect 0.8 0.7)
				    (make-vect 0.8 0.9))
		      (make-segment (make-vect 0.8 0.9)
				    (make-vect 0.7 0.9))
		      (make-segment (make-vect 0.7 0.9)
				    (make-vect 0.7 0.8))
		      (make-segment (make-vect 0.7 0.8)
				    (make-vect 0.5 1.0)))))

main.scm

さて、最後に main.scm だけど、disp 手続きの中でペインタを呼んでいる箇所を書き換えることで、前エントリのチェックができる！
以下のコードの中で、「(house frame)」を記述している箇所を、試したいペインタで書き直せばいいわけだ。

#!/usr/bin/gosh
(use gl)
(use gl.glut)

(load "./vector.scm")
(load "./segment.scm")
(load "./frame.scm")
(load "./painter.scm")

;;; ==============================
;;; 図形言語テスト用定形ロジック
;;; ==============================
(define (init)
  (gl-clear-color 1.0 1.0 1.0 1.0))

(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-color 0.0 0.0 0.0 0.0)

  ;線画を描画！
  (house frame)
  

  (gl-flush))

(define (main args)
  (glut-init args)
  (glut-create-window "Painter Line Test")
  (glut-display-func disp)
  (init) 
  (glut-main-loop)
  0)