(use gl)
(use gl.glut)
(define (make-vect x y)
(cons x y))
(define (xcor-vect vect)
(car vect))
(define (ycor-vect vect)
(cdr vect))
(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 (* (xcor-vect v) s)
(* (ycor-vect v) s)))
(define (make-frame origin edge1 edge2)
(list origin edge1 edge2))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (caddr frame))
(define (origin-frame frame) (car frame))
(define (make-segment x y)
(cons x y))
(define (start-segment x)
(car x))
(define (end-segment x)
(cdr x))
(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 (draw-line v1 v2)
(begin
(gl-vertex (xcor-vect v1) (ycor-vect v1))
(gl-vertex (xcor-vect v2) (ycor-vect v2))))
(define outline
(segments->painter
(list
(make-segment (make-vect 0.0 0.0) (make-vect 0.0 1.0))
(make-segment (make-vect 0.0 1.0) (make-vect 1.0 1.0))
(make-segment (make-vect 1.0 1.0) (make-vect 1.0 0.0))
(make-segment (make-vect 1.0 0.0) (make-vect 0.0 0.0)))))
(define x-line
(segments->painter
(list
(make-segment (make-vect 0.0 0.0) (make-vect 1.0 1.0))
(make-segment (make-vect 0.0 1.0) (make-vect 1.0 0.0)))))
(define diamond-line
(segments->painter
(list
(make-segment (make-vect 0.5 0.0) (make-vect 1.0 0.5))
(make-segment (make-vect 1.0 0.5) (make-vect 0.5 1.0))
(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.5 0.0)))))
(define wave
(segments->painter
(list
(make-segment (make-vect 0.5 0.5) (make-vect 0.4 0.25))
(make-segment (make-vect 0.4 0.25) (make-vect 0.5 0.0))
(make-segment (make-vect 0.5 0.0) (make-vect 0.6 0.25))
(make-segment (make-vect 0.6 0.25) (make-vect 0.5 0.5))
(make-segment (make-vect 0.5 0.5) (make-vect 0.75 0.3))
(make-segment (make-vect 0.75 0.3) (make-vect 1.0 0.5))
(make-segment (make-vect 1.0 0.5) (make-vect 0.75 0.7))
(make-segment (make-vect 0.75 0.7) (make-vect 0.5 0.5))
(make-segment (make-vect 0.5 0.5) (make-vect 0.7 0.75))
(make-segment (make-vect 0.7 0.75) (make-vect 0.5 1.0))
(make-segment (make-vect 0.5 1.0) (make-vect 0.3 0.75))
(make-segment (make-vect 0.3 0.75) (make-vect 0.5 0.5))
(make-segment (make-vect 0.5 0.5) (make-vect 0.25 0.4))
(make-segment (make-vect 0.25 0.4) (make-vect 0.0 0.5))
(make-segment (make-vect 0.0 0.5) (make-vect 0.25 0.6))
(make-segment (make-vect 0.25 0.6) (make-vect 0.5 0.5))
(make-segment (make-vect 0.0 0.0) (make-vect 1.0 1.0)))))
(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 (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 (shrink-to-upper-right painter)
(transform-painter painter
(make-vect 0.5 0.5)
(make-vect 1.0 0.5)
(make-vect 0.5 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 (squash-inwards painter)
(transform-painter painter
(make-vect 0.0 0.0)
(make-vect 0.65 0.35)
(make-vect 0.35 0.65)))
(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-bottom
(transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(paint-top
(transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(paint-top frame)
(paint-bottom frame)))))
(define (below2 painter1 painter2)
(rotate90
(beside (rotate270 painter1)
(rotate270 painter2))))
(define (split f1 f2)
(lambda (painter n)
(if (= n 0)
painter
(let ((smaller ((split f1 f2) painter (- n 1))))
(f1 painter (f2 smaller smaller))))))
(define right-split (split beside below))
(define up-split (split below beside))
(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-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 (corner-split2 painter n)
(if (= n 0)
painter
(let ((right (right-split painter (- n 1)))
(up (rotate90 (right-split (rotate270 painter) (- n 1)))))
(let ((top-left (beside up up))
(bottom-right (below right right))
(corner (corner-split2 painter (- n 1))))
(beside (below painter top-left)
(below bottom-right corner))))))
(define (corner-split3 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-split3 painter (- n 1))))
(beside (below painter top-left)
(below bottom-right corner))))))
(define (square-limit painter n)
(let ((quarter (corner-split painter n)))
(let ((half (beside (flip-horiz quarter) quarter)))
(below (flip-vert half) half))))
(define (square-limit2 painter n)
(let ((quarter (corner-split2 painter n)))
(let ((half (beside (flip-horiz quarter) quarter)))
(below (flip-vert half) half))))
(define (through x) x)
(define (square-limit3 painter n)
((square-of-four flip-horiz through
rotate180 flip-vert)
(corner-split painter n)))
(define (square-limit4 painter n)
(let ((quarter (corner-split3 painter n)))
(let ((half (beside (flip-horiz quarter) quarter)))
(below (flip-vert half) half))))
(define (main args)
(glut-init args)
(glut-init-display-mode GLUT_RGBA)
(glut-init-window-position 0 0)
(glut-init-window-size 700 700)
(glut-create-window "SICP 2.2.4")
(glut-display-func display)
(gl-enable GL_LINE_SMOOTH)
(gl-line-width 0.5)
(gl-enable GL_BLEND)
(gl-blend-func GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA)
(init)
(glut-main-loop))
(define (display)
(gl-clear-color 1.0 1.0 1.0 1.0)
(gl-clear GL_COLOR_BUFFER_BIT)
(gl-color 1.0 0.0 0.0)
(gl-begin GL_LINES)
((square-limit4 wave 3) (make-frame (make-vect -1 -1) (make-vect 2 0) (make-vect 0 2)))
(gl-end)
(gl-flush))
(define (init)
(gl-clear-color 0.0 0.0 1.0 1.0))
- 俺実装の方が大分短い。
- とはいえ柔軟性はSICP実装だなー。
