Utilities for henderson's picture language.

diff --git a/src/pictlang/core.clj b/src/pictlang/core.clj
new file mode 100644 (file)
index 0000000..79bf6dc
--- /dev/null
+++ b/src/pictlang/core.clj
@@ -0,0 +1,36 @@
+(ns pictlang.core
+  (:import [javax.swing JPanel JFrame]
+           [java.awt Color Graphics Graphics2D]
+           [java.awt.image BufferedImage]))
+
+(def dim-frame [256 256])
+
+(def img   (BufferedImage. (dim-frame 0) (dim-frame 1) (BufferedImage/TYPE_INT_RGB)))
+(def bg    (.getGraphics img))
+
+(defn draw-line [v1 v2]
+  (.setPaint bg Color/RED)
+  (.drawLine bg
+             (- (dim-frame 0) (* (first v1) (dim-frame 0)))
+             (- (dim-frame 1) (* (second v1) (dim-frame 1)))
+             (- (dim-frame 0) (* (first v2) (dim-frame 0)))
+             (- (dim-frame 1) (* (second v2) (dim-frame 1)))))
+
+(defn start-picture []
+  (let [frame (JFrame.)
+        panel (doto (proxy [JPanel] []
+                      (paint [g]
+                             (.drawImage g img 0 0 this))))]
+    (doto bg
+      (.setColor Color/BLACK)      
+      (.fillRect 0 0 (dim-frame 0) (dim-frame 1)))
+    
+    (doto frame
+      (.add panel)
+      (.setSize (dim-frame 0) (dim-frame 1))
+      (.show)
+      (.setDefaultCloseOperation JFrame/EXIT_ON_CLOSE))))
+
+(defn show [picture frame]
+  (picture frame))
+

diff --git a/src/pictlang/pictures.clj b/src/pictlang/pictures.clj
new file mode 100644 (file)
index 0000000..04e143e
--- /dev/null
+++ b/src/pictlang/pictures.clj
@@ -0,0 +1,44 @@
+(ns pictlang.pictures
+  (:use [pictlang.utils :only (make-vect make-segment segments->painter)]))
+
+(defn wave [frame]
+  (let [p01 (make-vect 0.40 1.00)
+        p02 (make-vect 0.60 1.00)
+        p03 (make-vect 0.00 0.80)
+        p04 (make-vect 0.35 0.80)
+        p05 (make-vect 0.65 0.80)
+        p06 (make-vect 0.00 0.60)
+        p07 (make-vect 0.30 0.60)
+        p08 (make-vect 0.40 0.60)
+        p09 (make-vect 0.60 0.60)
+        p10 (make-vect 0.70 0.60)
+        p11 (make-vect 0.20 0.55)
+        p12 (make-vect 0.30 0.55)
+        p13 (make-vect 0.35 0.50)
+        p14 (make-vect 0.65 0.50)
+        p15 (make-vect 0.20 0.45)
+        p16 (make-vect 1.00 0.40)
+        p17 (make-vect 0.50 0.20)
+        p18 (make-vect 1.00 0.20)
+        p19 (make-vect 0.25 0.00)
+        p20 (make-vect 0.40 0.00)
+        p21 (make-vect 0.60 0.00)
+        p22 (make-vect 0.75 0.00)]
+    ((segments->painter
+      (list (make-segment p01 p04)
+            (make-segment p04 p08)
+            (make-segment p08 p07)
+            (make-segment p07 p11)
+            (make-segment p11 p03)
+            (make-segment p06 p15)
+            (make-segment p15 p12)
+            (make-segment p12 p13)
+            (make-segment p13 p19)
+            (make-segment p20 p17)
+            (make-segment p17 p21)
+            (make-segment p22 p14)
+            (make-segment p14 p18)
+            (make-segment p16 p10)
+            (make-segment p10 p09)
+            (make-segment p09 p05)
+            (make-segment p05 p02))) frame)))
\ No newline at end of file

diff --git a/src/pictlang/utils.clj b/src/pictlang/utils.clj
new file mode 100644 (file)
index 0000000..a9a6b90
--- /dev/null
+++ b/src/pictlang/utils.clj
@@ -0,0 +1,176 @@
+(ns pictlang.utils
+  (:use [sicp.ex2_23 :only (for-each)]
+        [pictlang.core :only (draw-line)]))
+
+(declare flip-vert up-split flip-horiz transform-painter rotate90 rotate270)
+
+(defn make-vect [x y]
+  (list x y))
+
+(defn xcor-vect [v]
+  (first v))
+
+(defn ycor-vect [v]
+  (second v))
+
+(defn add-vect [v1 v2]
+  (make-vect (+ (xcor-vect v1)
+                (xcor-vect v2))
+             (+ (ycor-vect v1)
+                (ycor-vect v2))))
+
+(defn sub-vect [v1 v2]
+  (make-vect (- (xcor-vect v1)
+                (xcor-vect v2))
+             (- (ycor-vect v1)
+                (ycor-vect v2))))
+
+(defn scale-vect [v s]
+  (make-vect (* s (xcor-vect v))
+             (* s (ycor-vect v))))
+
+(defn make-frame [origin edge1 edge2]
+  (list origin edge1 edge2))
+
+(defn origin-frame [frame]
+  (first frame))
+
+(defn edge1-frame [frame]
+  (second frame))
+
+(defn edge2-frame [frame]
+  (first (rest (rest frame))))
+
+;; we define a segment as a list of 2 vectors
+(defn make-segment [v1 v2]
+  (list v1 v2))
+
+(defn start-segment [segment]
+  (first segment))
+
+(defn end-segment [segment]
+  (second segment))
+
+
+(defn beside [painter1 painter2]
+  (let [split-point (make-vect 0.5 0)
+        paint-left (transform-painter painter1
+                                      (make-vect 0 0)
+                                      split-point
+                                      (make-vect 0 1))
+        paint-right (transform-painter painter2
+                                       split-point
+                                       (make-vect 1 0)
+                                       (make-vect 0.5 1))]
+    (fn [frame]
+      (paint-left frame)
+      (paint-right frame))))
+
+(defn below [painter1 painter2]
+  (rotate90 (beside (rotate270 painter1) (rotate270 painter2))))
+
+(defn flipped-pairs [painter]
+  (let [painter2 (beside painter (flip-vert painter))]
+    (below painter2 painter2)))
+
+(defn right-split [painter n]
+  (if (= n 0)
+    painter
+    (let [smaller (right-split painter (- n 1))]
+      (beside painter (below smaller smaller)))))
+
+(defn corner-split [painter n]
+  (if (= n 0)
+    painter
+    (let [up       (up-split painter (- n 1))
+          right    (right-split painter (- n 1))
+          top-left (beside up up)
+          bottom-right (below right right)
+          corner   (corner-split painter (- n 1))]
+      (beside (below painter top-left)
+              (below bottom-right corner)))))
+
+(defn square-limit [painter n]
+  (let [quarter (corner-split painter n)
+        half    (beside (flip-horiz quarter) quarter)]
+    (below (flip-vert half) half)))
+
+(defn frame-coord-map [frame]
+  (fn [v]
+    (add-vect
+     (origin-frame frame)
+     (add-vect (scale-vect (edge1-frame frame) (xcor-vect v))
+               (scale-vect (edge2-frame frame) (ycor-vect v))))))
+
+(defn segments->painter [segment-list]
+  (fn [frame]
+    (for-each
+     (fn [segment]
+       (draw-line
+        ((frame-coord-map frame) (start-segment segment))
+        ((frame-coord-map frame) (end-segment segment))))
+     segment-list)))
+
+
+;; transformation
+(defn transform-painter [painter origin corner1 corner2]
+  (fn [frame]
+    (let [m (frame-coord-map frame)
+          new-origin (m origin)]
+      (painter (make-frame new-origin
+                           (sub-vect (m corner1) new-origin)
+                           (sub-vect (m corner2) new-origin))))))
+
+(defn flip-vert [painter]
+  (transform-painter painter
+                     (make-vect 0 1)
+                     (make-vect 1 1)
+                     (make-vect 0 0)))
+
+(defn shrink-to-upper-right [painter]
+  (transform-painter painter
+                     (make-vect 0.5 0.5)
+                     (make-vect 1 0.5)
+                     (make-vect 0.5 1)))
+
+(defn rotate90 [painter]
+  (transform-painter painter
+                     (make-vect 1 0)
+                     (make-vect 1 1)
+                     (make-vect 0 0)))
+
+(defn squash-inwards [painter]
+  (transform-painter painter
+                     (make-vect 0.0 0.0)
+                     (make-vect 0.65 0.35)
+                     (make-vect 0.35 0.65)))
+
+
+(defn up-split [painter n]
+  (if (= n 0)
+    painter
+    (let [smaller (up-split painter (- n 1))]
+      (below painter (beside smaller smaller)))))
+
+(defn split [f1 f2]
+  (letfn [(split-fn [painter n]
+                    (if (= n 0)
+                      painter
+                      (let [smaller (split-fn painter (- n 1))]
+                        (f1 painter (f2 smaller smaller)))))]
+    split-fn))
+
+(def right-split (split beside below))
+(def up-split    (split below beside))
+
+(defn flip-horiz [painter]
+  (transform-painter painter
+                     (make-vect 1 0)
+                     (make-vect 0 0)
+                     (make-vect 1 1)))
+
+(defn rotate180 [painter]
+  ((repeatedly 2 rotate90) painter))
+
+(defn rotate270 [painter]
+  ((repeatedly 3 rotate90) painter))