193 lines
4.5 KiB
Scheme
193 lines
4.5 KiB
Scheme
(define (make-vect x y) (cons x y))
|
|
(define (xcor-vect v) (car v))
|
|
(define (ycor-vect v) (cdr 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 (* (xcor-vect v) s)
|
|
(* (ycor-vect v) s)))
|
|
|
|
|
|
;; 2.47
|
|
|
|
(define (make-frame origin edge1 edge2)
|
|
(list origin edge1 edge2))
|
|
|
|
(define (origin-frame frame)
|
|
(car frame))
|
|
|
|
(define (edge1-frame frame)
|
|
(cadr frame))
|
|
|
|
(define (edge2-frame frame)
|
|
(caddr frame))
|
|
|
|
;(define (make-frame origin edge1 edge2)
|
|
;(cons origin (cons edge1 edge2)))
|
|
;
|
|
;(define (origin-frame frame)
|
|
; (car frame))
|
|
;
|
|
;(define (edge1-frame frame)
|
|
; (cadr frame))
|
|
;
|
|
;(define (edge2-frame frame)
|
|
; (cddr frame))
|
|
|
|
;; 2.48
|
|
|
|
(define (make-segment start end)
|
|
(cons start end))
|
|
|
|
(define (start-segment segment)
|
|
(car segment))
|
|
|
|
(define (end-segment segment)
|
|
(cdr segment))
|
|
|
|
|
|
;; 2.49
|
|
|
|
(define (for-each f l)
|
|
(if (not (null? l))
|
|
(begin (f (car l))
|
|
(for-each f (cdr l)))))
|
|
|
|
(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 (draw-line start end)
|
|
(print "(" start " -> " end ")"))
|
|
|
|
(define (segments->painter segment-list)
|
|
(lambda (frame)
|
|
(for-each
|
|
(lambda (segment)
|
|
(draw-line
|
|
((frame-coord-map frame) (start-segment segment))
|
|
((frame-coord-map frame) (end-segment segment))))
|
|
segment-list)))
|
|
|
|
(define frame (make-frame (make-vect 1 1) (make-vect 1 0) (make-vect 0 1)))
|
|
(define bottom-left (make-vect 0 0))
|
|
(define top-left (make-vect 0 1))
|
|
(define top-right (make-vect 1 1))
|
|
(define bottom-right (make-vect 1 0))
|
|
(define top (make-vect 0.5 1))
|
|
(define bottom (make-vect 0.5 0))
|
|
(define left (make-vect 0 0.5))
|
|
(define right (make-vect 1 0.5))
|
|
|
|
(define outline-painter (segments->painter
|
|
(list
|
|
(make-segment bottom-left bottom-right)
|
|
(make-segment bottom-right top-right)
|
|
(make-segment top-right top-left)
|
|
(make-segment top-left bottom-left))))
|
|
|
|
(define x-painter
|
|
(segments->painter
|
|
(list
|
|
(make-segment bottom-left top-right)
|
|
(make-segment bottom-right top-left))))
|
|
|
|
(define diamond-painter
|
|
(segments->painter
|
|
(list
|
|
(make-segment bottom left)
|
|
(make-segment left top)
|
|
(make-segment top right)
|
|
(make-segment right bottom))))
|
|
|
|
|
|
;; 2.50
|
|
|
|
(define (transform-painter painter origin corner1 corner2)
|
|
(lambda (frame)
|
|
(let ((m (frame-coord-map frame)))
|
|
(let ((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 0 1)
|
|
(make-vect 0 0)
|
|
(make-vect 1 1)))
|
|
|
|
(define (rotate90 painter)
|
|
(transform-painter painter
|
|
(make-vect 1.0 0.0)
|
|
(make-vect 1.0 1.0)
|
|
(make-vect 0.0 0.0)))
|
|
|
|
(define (beside painter1 painter2)
|
|
(let ((split-point (make-vect 0.5 0.0)))
|
|
(let ((paint-left
|
|
(transform-painter painter1
|
|
(make-vect 0.0 0.0)
|
|
split-point
|
|
(make-vect 0.0 1.0)))
|
|
(paint-right
|
|
(transform-painter painter2
|
|
split-point
|
|
(make-vect 1.0 0.0)
|
|
(make-vect 0.5 1.0))))
|
|
(lambda (frame)
|
|
(paint-left frame)
|
|
(paint-right frame)))))
|
|
|
|
(define (below painter1 painter2)
|
|
(let ((split-point (make-vect 0 0.5)))
|
|
(let ((paint-bottom
|
|
(transform-painter
|
|
painter1
|
|
(make-vect 0 0)
|
|
(make-vect 1 0)
|
|
split-point))
|
|
(paint-top
|
|
(transform-painter
|
|
painter2
|
|
split-point
|
|
(make-vect 1 0.5)
|
|
(make-vect 0 1))))
|
|
(lambda (frame)
|
|
(paint-bottom frame)
|
|
(paint-top frame)))))
|
|
|
|
(define (below-rot painter1 painter2)
|
|
(rotate270
|
|
(beside (rotate90 painter1)
|
|
(rotate90 painter2))))
|