sicp-2-2-4-a-picture-language

#lang racket

;;;;;;;;;;
;; 2.44 ;;
;;;;;;;;;;

(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)
    (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 (up-split painter n)
  (cond [(zero? n) painter]
        [else
          (define smaller (up-split painter (sub1 n)))
          (below painter (beside smaller smaller))]))

;;;;;;;;;;
;; 2.45 ;;
;;;;;;;;;;

(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 new-up-split (split below beside))

;;;;;;;;;;
;; 2.46 ;;
;;;;;;;;;;

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

;;;;;;;;;;
;; 2.47 ;;
;;;;;;;;;;

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

;; It is a Racket error to use first and rest with dotted pairs.  first and rest
;; can only be used with lists.  Use car and cdr for dotted pairs.

;; (define (make-frame origin edge1 edge2)
  ;; (cons origin (cons edge1 edge2)))
;; (define (origin-frame frame)
  ;; (car frame))
;; (define (edge1-frame frame)
  ;; (car (cdr frame)))
;; (define (edge2-frame frame)
  ;; (cdr (cdr frame)))


;;;;;;;;;;
;; 2.48 ;;
;;;;;;;;;;

(define (make-segment v1 v2)
  (list v1 v2))
(define (start-segment segment)
  (first segment))
(define (end-segment segment)
  (second segment))

;;;;;;;;;;
;; 2.49 ;;
;;;;;;;;;;

;; segments->painter not implemented in this file

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

;;;;;;;;;;
;; 2.50 ;;
;;;;;;;;;;

(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 (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-horiz painter)
  (transform-painter painter
                     (make-vect 1 0)
                     (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)))

;;;;;;;;;;
;; 2.51 ;;
;;;;;;;;;;

(define (rotate90 painter)
  (transform-painter painter
                     (make-vect 0 1)
                     (make-vect 0 0)
                     (make-vect 1 1)))

(define (new-below painter1 painter2)
  (rotate90 (beside (rotate270 painter1)
                    (rotate270 painter2))))

;;;;;;;;;;
;; 2.52 ;;
;;;;;;;;;;

(define hat-segment (make-segment (make-vect 5/16 1/16)
                                  (make-vect 11/16 1/16)))
;; (define hat-wave (segments->painter (cons hat-segment wave-segments)))

(define (new-corner-split painter n)
  (cond [(zero? n) painter]
        [else
          (define smaller-up (up-split painter (sub1 n)))
          (define smaller-right (right-split painter (sub1 n)))
          (below (beside painter
                         smaller-right)
                 (beside smaller-up
                         (new-corner-split painter (sub1 n))))]))

(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 (my-identity painter)
  painter)

(define (flip-vert painter)
  (transform-painter painter
                     (make-vect 0 1)
                     (make-vect 1 1)
                     (make-vect 0 0)))

(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 (new-square-limit painter n)
  (define combine4 (square-of-four flip-horiz
                                   my-identity
                                   rotate180
                                   flip-vert))
  (combine4 (corner-split painter n)))