Finished up to 2.51 (skipped 2.52)

This commit is contained in:
Oliver Payne 2021-11-28 22:28:14 +00:00
parent 7d513dccf6
commit 944efce5df
1 changed files with 192 additions and 0 deletions

192
2_46.sch Normal file
View File

@ -0,0 +1,192 @@
(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))))