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