]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ch2_2_4.rkt
Solution to 4.44. A bit too verbose. Can be improved by better
[sicp.git] / src / sicp / ch2_2_4.rkt
1 #lang racket/load
2 ;#lang planet neil/sicp
3 (require (planet "sicp.ss" ("soegaard" "sicp.plt" 2 1)))
4 ;(require (planet neil/sicp:1:13))
5
6 (define (identity x) x)
7
8 (define (flipped-pairs painter)
9   (let ((painter2 (beside painter (flip-vert painter))))
10     (below painter2 painter2)))
11
12 (paint (flipped-pairs einstein))
13
14 (define (right-split painter n)
15   (if (= n 0)
16       painter
17       (let ((smaller (right-split painter (- n 1))))
18         (beside painter (below smaller smaller)))))
19
20 (paint (right-split einstein 2))
21
22 (define (corner-split painter n)
23   (if (= n 0)
24       painter
25       (let ((up (up-split painter (- n 1)))
26             (right (right-split painter (- n 1))))
27         (let ((top-left (beside up up))
28               (bottom-right (below right right))
29               (corner (corner-split painter (- n 1))))
30           (below (beside painter bottom-right)
31                  (beside top-left corner))))))
32
33 (define (square-limit painter n)
34   (let ((corner (corner-split painter n)))
35     (let ((half (beside (flip-horiz corner) corner)))
36       (below (flip-vert half) half))))
37
38 ;; ex 2.44
39 (define (up-split painter n)
40   (if (= n 0)
41       painter
42       (let ((smaller (up-split painter (- n 1))))
43         (below painter (beside smaller smaller)))))
44
45 (paint (up-split einstein 2))
46
47 ;; higher order operations
48 (define (square-of-four tl tr bl br)
49   (lambda (painter)
50     (let ((top (beside (tl painter) (tr painter)))
51           (bottom (beside (bl painter) (br painter))))
52       (below bottom top))))
53
54 (define (flipped-pairs2 painter)
55   (let ((combine4 (square-of-four identity flip-vert
56                                   identity flip-vert)))
57     (combine4 painter)))
58
59 (paint (flipped-pairs2 einstein))
60
61 ;; square-limit in terms of square-of-four
62 (define (square-limit2 painter n)
63   (let ((square (square-of-four flip-horiz identity
64                                 rotate180  flip-vert)))
65     (square (corner-split painter n))))
66
67 (paint (square-limit2 einstein 1))
68
69 ;; ex 2.45
70 (define (split op1 op2)
71   (lambda (painter n)
72     (if (= n 0)
73         painter
74         (let ((smaller ((split op1 op2) painter (- n 1))))
75           (op1 painter (op2 smaller smaller))))))
76
77 (define usplit (split below beside))
78 (define rsplit (split beside below))
79
80 ;; ex 2.46
81 ;; A vector running from origin to (x,y) can be represented by a cons cell
82 (define (make-vect x y) (cons x y))
83 (define (xcor-vect v)   (car v))
84 (define (ycor-vect v)   (cdr v))
85
86 ;; vector operations
87 (define (add-vect v1 v2)
88   (make-vect (+ (xcor-vect v1) (xcor-vect v2))
89              (+ (ycor-vect v1) (ycor-vect v2))))
90
91 (define (sub-vect v1 v2)
92   (make-vect (- (xcor-vect v1) (xcor-vect v2))
93              (- (ycor-vect v1) (ycor-vect v2))))
94
95 (define (scale-vect s v)
96   (make-vect (* s (xcor-vect v))
97              (* s (ycor-vect v))))
98
99 ;; ex 2.47
100 ;; a
101 (define (make-frame1 origin edge1 edge2)
102   (list origin edge1 edge2))
103
104 (define (origin-frame1 frame)
105   (car frame))
106
107 (define (edge1-frame1 frame)
108   (car (cdr frame)))
109
110 (define (edge2-frame1 frame)
111   (car (cdr (cdr frame))))
112
113 ;; b
114 (define (make-frame2 origin edge1 edge2)
115   (cons origin (cons edge1 edge2)))
116
117 (define (origin-frame2 frame)
118   (car frame))
119
120 (define (edge1-frame2 frame)
121   (car (cdr frame)))
122
123 (define (edge2-frame2 frame)
124   (cdr (cdr frame)))
125
126 ;; for now use option a.
127 (define origin-frame origin-frame1)
128 (define edge1-frame  edge1-frame1)
129 (define edge2-frame  edge2-frame1)
130
131 ;;; frames
132 (define (frame-coord-map frame)
133   (lambda (v)
134     (add-vect (origin-frame frame)
135               (add-vect (scale-vect (xcor-vect v) (edge1-frame frame))
136                         (scale-vect (ycor-vect v) (edge2-frame frame))))))
137
138 ;; ex 2.48
139 (define (make-segment v1 v2)    (cons v1 v2))
140 (define (start-segment segment) (car segment))
141 (define (end-segment segment)   (cdr segment))
142
143 ;; ex 2.49
144 ;; a. The painter that draws the outline of the designated frame.
145 (define one  0.99)
146 (define zero 0)
147
148 (define (outline frame)
149   ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one zero))
150                             (make-segment (make-vect one zero) (make-vect one one))
151                             (make-segment (make-vect one one) (make-vect zero one))
152                             (make-segment (make-vect zero one) (make-vect zero zero))))
153    frame))
154
155 ;; b.  The painter that draws an ``X'' by connecting opposite corners of the frame.
156 (define (x-connect frame)
157   ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one one))
158                             (make-segment (make-vect zero one) (make-vect one zero))))
159    frame))
160     
161 ;; c.  The painter that draws a diamond shape by connecting the midpoints of the 
162 ;;     sides of the frame.
163 (define (diamond frame)
164   (let ((v1 (make-vect 0.5 0))
165         (v2 (make-vect 0.999 0.5))
166         (v3 (make-vect 0.5 0.999))
167         (v4 (make-vect 0 0.5)))
168     ((segments->painter (list (make-segment v1 v2)
169                               (make-segment v2 v3)
170                               (make-segment v3 v4)
171                               (make-segment v4 v1))) 
172      frame)))
173
174 ;; d. The wave painter. 
175 (define (waveman frame)
176   (let ((p1 (make-vect 0.25 0))
177         (p2 (make-vect 0.4 0.4))
178         (p3 (make-vect 0.25 0.5))
179         (p4 (make-vect 0.15 0.4))
180         (p5 (make-vect 0 0.7))
181         (p6 (make-vect 0 0.8))
182         (p7 (make-vect 0.15 0.55))
183         (p8 (make-vect 0.25 0.6))
184         (p9 (make-vect 0.4 0.6))
185         (p10 (make-vect 0.35 0.75))
186         (p11 (make-vect 0.4 0.9))
187         (p12 (make-vect 0.6 0.9))
188         (p13 (make-vect 0.65 0.75))
189         (p14 (make-vect 0.6 0.6))
190         (p15 (make-vect 0.8 0.6))
191         (p16 (make-vect 0.999 0.25))
192         (p17 (make-vect 0.999 0.1))
193         (p18 (make-vect 0.6 0.4))
194         (p19 (make-vect 0.75 0))
195         (p20 (make-vect 0.65 0))
196         (p21 (make-vect 0.5 0.2))
197         (p22 (make-vect 0.35 0)))
198     (let ((s1 (make-vect p1 p2))
199           (s2 (make-vect p2 p3))
200           (s3 (make-vect p3 p4))
201           (s4 (make-vect p4 p5))
202           (s5 (make-vect p6 p7))
203           (s6 (make-vect p7 p8))
204           (s7 (make-vect p8 p9))
205           (s8 (make-vect p9 p10))
206           (s9 (make-vect p10 p11))
207           (s10 (make-vect p12 p13))
208           (s11 (make-vect p13 p14))
209           (s12 (make-vect p14 p15))
210           (s13 (make-vect p15 p16))
211           (s14 (make-vect p17 p18))
212           (s15 (make-vect p18 p19))
213           (s16 (make-vect p20 p21))
214           (s17 (make-vect p21 p22)))
215       ((segments->painter (list s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15 s16 s17))
216        frame))))
217
218