#lang racket
(require racket/draw)
;; I can't get racket/draw to draw an image for me on windows. However, you can
;; use this program to create an image and save it to file as outlined below.
;; Unfortunately you have to reload the file every time you want to make a new
;; image.
;; To create a picture using racket/draw and save it to file:
;; 1. Create a bitmap:
(define target (make-bitmap 640 640))
;; 2. Create a drawing context that draws to the bitmap:
(define dc (new bitmap-dc% [bitmap target]))
;; 3. Create a special frame called canvas that fits the drawing context:
(define canvas (make-frame (make-vect 0 0)
(make-vect 640 0)
(make-vect 0 640)))
;; 4. Call the painter on the canvas. For example,
;; ((square-limit wave 4) canvas)
;; 5. Save the image to file:
;; (send target save-file "filename.png" 'png)
;; NOTES:
;; 1. This only works with painters created by calling segments->painter. In
;; fact the only place the drawing program calls racket/draw is in the
;; segments->painter function.
;; 2. racket/draw has the origin in the upper-left corner, x-coordinates get
;; bigger to the right, and y-coordinates get bigger as you go down the image.
;; 3. racket/draw requires the use of exact integers as coordinates. This is why
;; we use a 640 x 640 frame and use fractions to describe unit-square vectors.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; vectors, frames, and segments
;; A vector is a list of x- and y-coordinates.
(define (make-vect x y) (list x y))
(define (xcor-vect v) (first v))
(define (ycor-vect v) (second 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))))
;; A frame is a list of three vectors, an origin, an edge1, and an edge2.
(define (make-frame origin edge1 edge2)
(list origin edge1 edge2))
(define (origin-frame frame)
(first frame))
(define (edge1-frame frame)
(second frame))
(define (edge2-frame frame)
(third frame))
;; A segment is a pair of vectors, a start segment and an end segment.
(define (make-segment v1 v2)
(list v1 v2))
(define (start-segment segment)
(first segment))
(define (end-segment segment)
(second segment))
;; create a painter
(define (segments->painter segment-list)
(lambda (frame)
(define m (frame-coord-map frame))
(map
(lambda (segment)
(define v1 (m (start-segment segment)))
(define v2 (m (end-segment segment)))
(send dc draw-line
(xcor-vect v1)
(ycor-vect v1)
(xcor-vect v2)
(ycor-vect v2)))
segment-list)))
;; transform a painter to fit a frame
(define (my-identity painter)
painter)
(define (frame-coord-map frame)
(lambda (v) ; vectors in unit square -> vectors in frame
(add-vect
(origin-frame frame)
(add-vect (scale-vect (xcor-vect v)
(edge1-frame frame))
(scale-vect (ycor-vect v)
(edge2-frame frame))))))
(define (transform-painter painter origin corner1 corner2)
(lambda (frame)
(define m (frame-coord-map frame))
(define 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 1)
(make-vect 1 1)
(make-vect 0 0)))
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1 0)
(make-vect 0 0)
(make-vect 1 1)))
(define (rotate90 painter)
(transform-painter painter
(make-vect 0 1)
(make-vect 0 0)
(make-vect 1 1)))
(define (rotate180 painter)
(transform-painter painter
(make-vect 1 1)
(make-vect 0 1)
(make-vect 1 0)))
(define (rotate270 painter)
(transform-painter painter
(make-vect 1 0)
(make-vect 1 1)
(make-vect 0 0)))
;; combining painters
(define (below painter1 painter2)
(define split-point (make-vect 0 1/2))
(define paint-below (transform-painter painter1
split-point
(make-vect 1 1/2)
(make-vect 0 1)))
(define paint-above (transform-painter painter2
(make-vect 0 0)
(make-vect 1 0)
split-point))
(lambda (frame)
(begin
(paint-below frame)
(paint-above frame))))
(define (beside painter1 painter2)
(define split-point (make-vect 1/2 0))
(define paint-left (transform-painter painter1
(make-vect 0 0)
split-point
(make-vect 0 1)))
(define paint-right (transform-painter painter2
split-point
(make-vect 1 0)
(make-vect 1/2 1)))
(lambda (frame)
(begin (paint-left frame)
(paint-right frame))))
(define (split comb1 comb2)
(lambda (painter n)
(cond [(zero? n) painter]
[else
(define smaller ((split comb1 comb2) painter (sub1 n)))
(comb1 painter (comb2 smaller smaller))])))
(define right-split (split beside below))
(define up-split (split below beside))
(define (corner-split painter n)
(cond [(zero? n) painter]
[else
(define up (up-split painter (sub1 n)))
(define right (right-split painter (sub1 n)))
(define top-left (beside up up))
(define bottom-right (below right right))
(define corner (corner-split painter (sub1 n)))
(beside (below painter top-left)
(below bottom-right corner))]))
(define (square-of-four tl tr bl br)
(lambda (painter)
(define top (beside (tl painter) (tr painter)))
(define bottom (beside (bl painter) (br painter)))
(below bottom top)))
(define (square-limit painter n)
(define combine4 (square-of-four flip-horiz
my-identity
rotate180
flip-vert))
(combine4 (corner-split painter n)))
;; specific painters
(define outline-segments
(list (make-segment (make-vect 0 0)
(make-vect 0 1))
(make-segment (make-vect 0 0)
(make-vect 1 0))
(make-segment (make-vect 0 1)
(make-vect 1 1))
(make-segment (make-vect 1 0)
(make-vect 1 1))))
(define outline-painter (segments->painter outline-segments))
(define x-segments
(list (make-segment (make-vect 0 0)
(make-vect 1 1))
(make-segment (make-vect 0 1)
(make-vect 1 0))))
(define x-painter (segments->painter x-segments))
(define diamond-segments
(list (make-segment (make-vect 1/2 0)
(make-vect 1 1/2))
(make-segment (make-vect 1 1/2)
(make-vect 1/2 1))
(make-segment (make-vect 1/2 0)
(make-vect 0 1/2))
(make-segment (make-vect 0 1/2)
(make-vect 1/2 1))))
(define diamond-painter (segments->painter diamond-segments))
(define wave-segments
(list
; head
(make-segment (make-vect 3/8 0)
(make-vect 5/8 0))
(make-segment (make-vect 3/8 0)
(make-vect 3/8 1/4))
(make-segment (make-vect 3/8 1/4)
(make-vect 5/8 1/4))
(make-segment (make-vect 5/8 0)
(make-vect 5/8 1/4))
; arms
(make-segment (make-vect 0 1/4)
(make-vect 1 3/4))
; body
(make-segment (make-vect 1/2 1/4)
(make-vect 1/2 3/4))
; legs
(make-segment (make-vect 1/4 1)
(make-vect 1/2 3/4))
(make-segment (make-vect 1/2 3/4)
(make-vect 3/4 1))))
(define wave (segments->painter wave-segments))
;; TRY THESE
;; unfortunately you have to uncomment them out one at a time and reload between images
;; ((up-split outline-painter 6) canvas)
;; (send target save-file "test-image-up-6-outline.png" 'png)
;; ((right-split x-painter 6) canvas)
;; (send target save-file "test-image-right-6-x.png" 'png)
;; ((corner-split diamond-painter 6) canvas)
;; (send target save-file "test-image-corner-6-diamond.png" 'png)
;; ((square-limit wave 6) canvas)
;; (send target save-file "test-image-square-6-wave.png" 'png)
Comments