(define (make-frame origin edge1 edge2)
(list 'frame origin edge1 edge2))
(define frame-origin cadr)
(define frame-edge1 caddr)
(define frame-edge2 cadddr)
(define (load-painter file-name)
(picture->painter
(image-file->picture
(build-path (collection-path "picture")
(string-append file-name ".gif")))))
(define (load-painter file-name)
(picture->painter
(image-file->picture file-name)))
(define black (number->painter 0))
(define white (number->painter 255))
(define gray (number->painter 150))
(define diagonal-shading
(procedure->painter (lambda (x y) (* 100 (+ x y)))))
(define mark-of-zorro
(let ((v1 (make-vect .1 .9))
(v2 (make-vect .8 .9))
(v3 (make-vect .1 .2))
(v4 (make-vect .9 .3)))
(segments->painter
(list (make-segment v1 v2)
(make-segment v2 v3)
(make-segment v3 v4)))))
(require (only (lib "etc.ss")
this-expression-source-directory))
(define einstein
(load-painter
(build-path (this-expression-source-directory)
"einstein.gif")))
(define (paint painter)
(set-painter-resolution! 128)
(painter (screen-frame))
(picture-display #f *the-screen* 0 256))
(define (paint-hi-res painter)
(set-painter-resolution! 256)
(painter (screen-frame))
(picture-display #f *the-screen* 0 256))
(define paint-hires paint-hi-res)
(define (frame-coord-map frame)
(lambda (point-in-frame-coords)
(vector-add
(frame-origin frame)
(vector-add (vector-scale (vector-xcor point-in-frame-coords)
(frame-edge1 frame))
(vector-scale (vector-ycor point-in-frame-coords)
(frame-edge2 frame))))))
(define (make-relative-frame origin corner1 corner2)
(lambda (frame)
(let ((m (frame-coord-map frame)))
(let ((new-origin (m origin)))
(make-frame new-origin
(vector-sub (m corner1) new-origin)
(vector-sub (m corner2) new-origin))))))
(define (transform-painter origin corner1 corner2)
(lambda (painter)
(compose painter
(make-relative-frame
origin
corner1
corner2))))
(define flip-horiz
(transform-painter (make-vect 1 0)
(make-vect 0 0)
(make-vect 1 1)))
(define flip-vert
(transform-painter (make-vect 0 1)
(make-vect 1 1)
(make-vect 0 0)))
(define rotate90
(transform-painter (make-vect 1 0)
(make-vect 1 1)
(make-vect 0 0)))
(define rotate180 (repeated rotate90 2))
(define rotate270 (repeated rotate90 3))
(define (beside painter1 painter2)
(let ((split-point (make-vect .5 0)))
(superpose
((transform-painter zero-vector
split-point
(make-vect 0 1))
painter1)
((transform-painter split-point
(make-vect 1 0)
(make-vect .5 1))
painter2))))
(define (below painter1 painter2)
(rotate270 (beside (rotate90 painter2)
(rotate90 painter1))))
(define (superpose painter1 painter2)
(lambda (frame)
(painter1 frame)
(painter2 frame)))
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))