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