ynd / mona-clojure

Computer Paints Mona Lisa

This URL has Read+Write access

mona-clojure / mona-clojure.clj
raw normal view history
30723987 » ynd 2009-01-19 Initial 1 (import
2 '(java.awt Graphics Graphics2D Color Polygon)
3 '(java.awt.image BufferedImage PixelGrabber)
4 '(java.io File)
5 '(javax.imageio ImageIO)
6 '(javax.swing JFrame JPanel JFileChooser))
7
8 ; ---------------------------------------------------------------------
9 ; This section defines the building blocks of the genetic programs.
10
11 ; color :: Integer -> Integer -> Integer -> Integer -> Color
12 (defn color [red blue green alpha] {:type :Color :red red :blue blue :green green :alpha alpha})
13
14 ; point :: Integer -> Integer -> Point
15 (defn point [x y] {:type :Point :x x :y y})
16
17 ; polygon :: Color -> [Point] -> Polygon
18 (defn polygon [color points] {:type :Polygon :color color :points points})
19
20 ; draw-polygon :: Graphics -> Polygon -> Nothing
21 (defn draw-polygon [graphics polygon]
22 (doto graphics
23 (.setColor (new Color (:red (:color polygon))
24 (:blue (:color polygon))
25 (:green (:color polygon))
26 (:alpha (:color polygon))))
27 (.fillPolygon (let [jpolygon (new Polygon)]
28 (doseq [p (:points polygon)] (. jpolygon (addPoint (:x p) (:y p))))
29 jpolygon)))
30 nil)
31
32 ; ----------------------------------------------------------------------
33 ; This sections defines helper functions.
34
35 ; random-double :: Double
36 (defn random-double
37 "Returns a double between -1.0 and 1.0."
38 []
39 (- (* 2 (rand)) 1))
40
41 ; remove-item :: Sequence -> Integer -> Sequence
42 (defn remove-item
43 "Returns a sequence without the n-th item of s."
44 [s n]
45 (cond
46 (vector? s) (into (subvec s 0 n)
47 (subvec s (min (+ n 1) (count s)) (count s)))
48 (list? s) (concat (take n s)
49 (drop (inc n) s))))
50
51 ; replace-item :: [a] -> Integer -> a -> [a]
52 (defn replace-item
53 "Returns a list with the n-th item of l replaced by v."
54 [l n v]
55 (concat (take n l) (list v) (drop (inc n) l)))
56
57 ; grab-pixels :: BufferedImage -> [Integer]
58 (defn grab-pixels
59 "Returns an array containing the pixel values of image."
60 [image]
61 (let [w (. image (getWidth))
62 h (. image (getHeight))
63 pixels (make-array (. Integer TYPE) (* w h))]
64 (doto (new PixelGrabber image 0 0 w h pixels 0 w)
65 (.grabPixels))
66 pixels))
7a4839bc » ynd 2009-01-25 Added jars and jpg. 67
30723987 » ynd 2009-01-19 Initial 68 ; ----------------------------------------------------------------------
69 ; This sections define the primitives of the genetic algorithm.
70
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 71 ; program :: S-Expression -> Maybe Integer -> Maybe BufferedImage -> Program
30723987 » ynd 2009-01-19 Initial 72 (defn program [code fitness image] {:type :Program :code code :fitness fitness :image image})
73
74 ; initial-program :: Program
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 75 (def initial-program (program '(fn [graphics]) nil nil))
30723987 » ynd 2009-01-19 Initial 76
77 ; program-header :: Program -> S-Expression
78 (defn program-header [p] (take 2 (:code p)))
79
80 ; program-expressions :: Program -> S-Expression
81 (defn program-expressions [p] (drop (count (program-header p)) (:code p)))
82
83 ; mutate :: a -> Map -> a
84 (defmulti mutate :type)
85
86 ; mutate :: Color -> Map -> Color
87 (defmethod mutate :Color [c settings]
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 88 (let [dr (int (* (:red c) (random-double)))
89 dg (int (* (:green c) (random-double)))
90 db (int (* (:blue c) (random-double)))
91 da (int (* (:alpha c) (random-double)))]
30723987 » ynd 2009-01-19 Initial 92 (assoc c :red (max (min (- (:red c) dr) 255) 0)
93 :green (max (min (- (:green c) dg) 255) 0)
383db7b9 » ynd 2009-01-27 Corrected typo in mutation ... 94 :blue (max (min (- (:blue c) db) 255) 0)
651980f4 » ynd 2009-01-27 Fixed typo. 95 :alpha (max (min (- (:alpha c) da) 255) 0))))
30723987 » ynd 2009-01-19 Initial 96
97 ; mutate :: Point -> Map -> Point
98 (defmethod mutate :Point [p settings]
99 (let [dx (int (* (:x p) (random-double)))
100 dy (int (* (:y p) (random-double)))]
101 (assoc p :x (max (min (- (:x p) dx) (:image-width settings)) 0)
102 :y (max (min (- (:y p) dy) (:image-height settings)) 0))))
103
104 ; mutate :: Polygon -> Map -> Polygon
105 (defmethod mutate :Polygon [p settings]
106 ; mutate-point :: Polygon -> Map -> Polygon
107 (defn mutate-point [p settings]
108 (let [n (rand-int (count (:points p)))]
109 (assoc p :points (assoc (:points p) n (mutate (get (:points p) n) settings)))))
110
111 ; mutate-color :: Polygon -> Map -> Polygon
112 (defn mutate-color [p settings] (assoc p :color (mutate (:color p) settings)))
113
272a8352 » ynd 2009-01-20 Removed mutations of number... 114 (let [roulette (rand-int 2)]
30723987 » ynd 2009-01-19 Initial 115 (cond
272a8352 » ynd 2009-01-20 Removed mutations of number... 116 (= 0 roulette) (mutate-point p settings)
117 (= 1 roulette) (mutate-color p settings))))
30723987 » ynd 2009-01-19 Initial 118
119 ; mutate :: Program -> Map -> Program
120 (defmethod mutate :Program [p settings]
121 ; add-polygon :: Program -> Map -> Program
122 (defn add-polygon [p settings]
123 (assoc p :code
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 124 (concat (:code p)
125 [(list 'draw-polygon
126 (first (nth (:code initial-program) 1))
127 (polygon
128 (color (rand-int 255) (rand-int 255) (rand-int 255) (rand-int 255))
129 (vec (map
130 (fn [n]
131 (point
132 (rand-int (:image-width settings))
133 (rand-int (:image-height settings))))
134 (range 5)))))])
30723987 » ynd 2009-01-19 Initial 135 :fitness nil :image nil))
136
137 ; remove-polygon :: Program -> Map -> Program
138 (defn remove-polygon [p settings]
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 139 (let [n (rand-int (count (program-expressions p)))]
30723987 » ynd 2009-01-19 Initial 140 (assoc p :code (concat (program-header p)
141 (remove-item (program-expressions p) n))
142 :fitness nil :image nil)))
143
144 ; mutate-polygon :: Program -> Map -> Program
145 (defn mutate-polygon [p settings]
146 (let [expressions (program-expressions p)
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 147 n (rand-int (count expressions))
30723987 » ynd 2009-01-19 Initial 148 target (nth expressions n)]
149 (assoc p :code
150 (concat (program-header p)
151 (replace-item expressions
152 n
153 (list (nth target 0)
154 (nth target 1)
155 (mutate (nth target 2) settings))))
156 :fitness nil :image nil)))
157
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 158 (let [polygon-count (count (program-expressions p))
30723987 » ynd 2009-01-19 Initial 159 roulette (cond
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 160 (empty? (program-expressions p)) 4
161 (>= polygon-count (:max-polygons settings)) (rand-int 4)
162 :else (rand-int 5))]
30723987 » ynd 2009-01-19 Initial 163 (cond
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 164 (> 3 roulette) (mutate-polygon p settings)
165 (= 3 roulette) (remove-polygon p settings)
166 (= 4 roulette) (add-polygon p settings))))
30723987 » ynd 2009-01-19 Initial 167
168 ; fitness :: Program -> Map -> Program
169 (defn fitness [individual settings]
170 (if (:fitness individual)
171 individual
172 (let [gen-image (new BufferedImage (:image-width settings)
173 (:image-height settings)
174 BufferedImage/TYPE_INT_ARGB)
175 src-pixels (:source-pixels settings)]
226a8c84 » ynd 2009-01-24 Corrected bug in color muta... 176 (apply (eval (:code individual)) [(. gen-image (createGraphics))])
30723987 » ynd 2009-01-19 Initial 177 (def gen-pixels (grab-pixels gen-image))
178 (loop [i (int 0)
179 lms (int 0)]
180 (if (< i (alength gen-pixels))
181 (let [src-color (new Color (aget src-pixels i))
182 gen-color (new Color (aget gen-pixels i))
183 dr (- (. src-color (getRed)) (. gen-color (getRed)))
184 dg (- (. src-color (getGreen)) (. gen-color (getGreen)))
185 db (- (. src-color (getBlue)) (. gen-color (getBlue)))]
186 (recur (unchecked-inc i) (int (+ lms (* dr dr) (* dg dg) (* db db )))))
187 (assoc individual :fitness lms :image gen-image))))))
188
189 ; select :: [Program] -> Map -> [Program]
190 (defn select [individuals settings]
191 (take (:select-rate settings)
192 (sort-by :fitness
193 (pmap (fn [i] (fitness i settings))
194 individuals))))
195
196 ; evolve :: Map -> Nothing
197 (defn evolve [settings]
198 (loop [i 0
199 population (list initial-program)]
200 (let [fittest (select population settings)
201 newborns (map (fn [i] (mutate i settings)) fittest)]
202 ((:new-generation-callback settings (fn [a b])) i fittest)
203 (when-not (= (first population) (first fittest))
204 ((:new-fittest-callback settings (fn [a b])) i fittest))
205 (recur (inc i) (concat fittest newborns)))))
206
207 ; ----------------------------------------------------------------------
208 ; This sections defines the graphical interface.
209
210 ; main :: Nothing
211 (defn main []
212 (def file-chooser (new JFileChooser))
213 (doto file-chooser
214 (.setCurrentDirectory (new File "."))
215 (.showOpenDialog nil))
216
217 (let [jframe (new JFrame "Fittest Program")
218 fittest (atom (list initial-program))
219 image (ImageIO/read (. file-chooser (getSelectedFile)))
220 settings {:image-width (. image (getWidth))
221 :image-height (. image (getHeight))
222 :source-pixels (grab-pixels image)
223 :select-rate 1 :max-polygons 50
224 :new-fittest-callback (fn [i f]
225 (swap! fittest (fn [o n] n) f)
226 (. jframe (repaint)))}]
227 (doto jframe
228 (.setSize (. image (getWidth)) (. image (getHeight)))
229 (.add (proxy [JPanel] []
230 (paint [g]
231 (doto g
232 (.setColor Color/white)
233 (.fillRect 0 0 (. image (getWidth)) (. image (getHeight)))
234 (.drawImage (:image (first @fittest)) nil 0 0)))))
235 (.setVisible true))
236 (evolve settings)))
237
238 (main)