sicp-2-2-4-the-drawing-program

#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)