src/pictlang/utils.clj

   1 (ns pictlang.utils
   2   (:use [sicp.ex2_23 :only (for-each)]
   3         [pictlang.core :only (draw-line)]))
   4
   5 (declare flip-vert up-split flip-horiz transform-painter rotate90 rotate270)
   6
   7 (defn make-vect [x y]
   8   (list x y))
   9
  10 (defn xcor-vect [v]
  11   (first v))
  12
  13 (defn ycor-vect [v]
  14   (second v))
  15
  16 (defn add-vect [v1 v2]
  17   (make-vect (+ (xcor-vect v1)
  18                 (xcor-vect v2))
  19              (+ (ycor-vect v1)
  20                 (ycor-vect v2))))
  21
  22 (defn sub-vect [v1 v2]
  23   (make-vect (- (xcor-vect v1)
  24                 (xcor-vect v2))
  25              (- (ycor-vect v1)
  26                 (ycor-vect v2))))
  27
  28 (defn scale-vect [v s]
  29   (make-vect (* s (xcor-vect v))
  30              (* s (ycor-vect v))))
  31
  32 (defn make-frame [origin edge1 edge2]
  33   (list origin edge1 edge2))
  34
  35 (defn origin-frame [frame]
  36   (first frame))
  37
  38 (defn edge1-frame [frame]
  39   (second frame))
  40
  41 (defn edge2-frame [frame]
  42   (first (rest (rest frame))))
  43
  44 ;; we define a segment as a list of 2 vectors
  45 (defn make-segment [v1 v2]
  46   (list v1 v2))
  47
  48 (defn start-segment [segment]
  49   (first segment))
  50
  51 (defn end-segment [segment]
  52   (second segment))
  53
  54
  55 (defn beside [painter1 painter2]
  56   (let [split-point (make-vect 0.5 0)
  57         paint-left (transform-painter painter1
  58                                       (make-vect 0 0)
  59                                       split-point
  60                                       (make-vect 0 1))
  61         paint-right (transform-painter painter2
  62                                        split-point
  63                                        (make-vect 1 0)
  64                                        (make-vect 0.5 1))]
  65     (fn [frame]
  66       (paint-left frame)
  67       (paint-right frame))))
  68
  69 (defn below [painter1 painter2]
  70   (rotate90 (beside (rotate270 painter1) (rotate270 painter2))))
  71
  72 (defn flipped-pairs [painter]
  73   (let [painter2 (beside painter (flip-vert painter))]
  74     (below painter2 painter2)))
  75
  76 (defn right-split [painter n]
  77   (if (= n 0)
  78     painter
  79     (let [smaller (right-split painter (- n 1))]
  80       (beside painter (below smaller smaller)))))
  81
  82 (defn corner-split [painter n]
  83   (if (= n 0)
  84     painter
  85     (let [up       (up-split painter (- n 1))
  86           right    (right-split painter (- n 1))
  87           top-left (beside up up)
  88           bottom-right (below right right)
  89           corner   (corner-split painter (- n 1))]
  90       (beside (below painter top-left)
  91               (below bottom-right corner)))))
  92
  93 (defn square-limit [painter n]
  94   (let [quarter (corner-split painter n)
  95         half    (beside (flip-horiz quarter) quarter)]
  96     (below (flip-vert half) half)))
  97
  98 (defn frame-coord-map [frame]
  99   (fn [v]
 100     (add-vect
 101      (origin-frame frame)
 102      (add-vect (scale-vect (edge1-frame frame) (xcor-vect v))
 103                (scale-vect (edge2-frame frame) (ycor-vect v))))))
 104
 105 (defn segments->painter [segment-list]
 106   (fn [frame]
 107     (for-each
 108      (fn [segment]
 109        (draw-line
 110         ((frame-coord-map frame) (start-segment segment))
 111         ((frame-coord-map frame) (end-segment segment))))
 112      segment-list)))
 113
 114
 115 ;; transformation
 116 (defn transform-painter [painter origin corner1 corner2]
 117   (fn [frame]
 118     (let [m (frame-coord-map frame)
 119           new-origin (m origin)]
 120       (painter (make-frame new-origin
 121                            (sub-vect (m corner1) new-origin)
 122                            (sub-vect (m corner2) new-origin))))))
 123
 124 (defn flip-vert [painter]
 125   (transform-painter painter
 126                      (make-vect 0 1)
 127                      (make-vect 1 1)
 128                      (make-vect 0 0)))
 129
 130 (defn shrink-to-upper-right [painter]
 131   (transform-painter painter
 132                      (make-vect 0.5 0.5)
 133                      (make-vect 1 0.5)
 134                      (make-vect 0.5 1)))
 135
 136 (defn rotate90 [painter]
 137   (transform-painter painter
 138                      (make-vect 1 0)
 139                      (make-vect 1 1)
 140                      (make-vect 0 0)))
 141
 142 (defn squash-inwards [painter]
 143   (transform-painter painter
 144                      (make-vect 0.0 0.0)
 145                      (make-vect 0.65 0.35)
 146                      (make-vect 0.35 0.65)))
 147
 148
 149 (defn up-split [painter n]
 150   (if (= n 0)
 151     painter
 152     (let [smaller (up-split painter (- n 1))]
 153       (below painter (beside smaller smaller)))))
 154
 155 (defn split [f1 f2]
 156   (letfn [(split-fn [painter n]
 157                     (if (= n 0)
 158                       painter
 159                       (let [smaller (split-fn painter (- n 1))]
 160                         (f1 painter (f2 smaller smaller)))))]
 161     split-fn))
 162
 163 (def right-split (split beside below))
 164 (def up-split    (split below beside))
 165
 166 (defn flip-horiz [painter]
 167   (transform-painter painter
 168                      (make-vect 1 0)
 169                      (make-vect 0 0)
 170                      (make-vect 1 1)))
 171
 172 (defn rotate180 [painter]
 173   ((repeatedly 2 rotate90) painter))
 174
 175 (defn rotate270 [painter]
 176   ((repeatedly 3 rotate90) painter))