Clojure: Genetic Mona Lisa problem in 250 beautiful lines

Clojure is surrounded by hype these days. The word on the streets is that Clojure is the Next Big Thing. It has access to the largest library of code and it proposes a nice solution the to the concurrency problem. Lots more has been said...

But I haven't seen a lot of code.

So I set out to make a small but meaningful program in Clojure to get a sense of it's potential.

I give Clojure two thumbs up, and I think you'll do too.

The Mona Lisa Problem

The program I present tries to paint Mona Lisa with a small number of semi-transparent colored polygons. It does so by using Darwin's theory of evolution to evolve programs that draw Mona Lisa.

Here's the simplified algorithm:
1. Generate an initial population of programs
2. Take the n best programs of the current population
3. Create Children from the best programs by mating and mutating them
4. Replace the current population with the n-best and the children programs
5. Repeat from 2 until satisfied

See my more complete java version for details and don't miss Roger Alsing's seminal post.

Clojure is Lisp

Lisp code can be treated as data. That makes evolving programs painless. My Genetic Algorithm simply evolves lambdas. Running the evolved programs is a matter of calling 'eval.

The program is side-effects free(almost!). The majority of the program is functional. There are only two sources of side-effects:
1. Drawing on the canvas
2. Handling the GUI

Clojure is Java

It can be distributed and run anywhere. Clojure is compiled to Java bytecodes.

Clojure can use Java objects directly without wrappers. I was able to create a cross-platform GUI in a few lines with Swing.

Let me illustrate this by creating an object deriving from JPanel that overides the paint method to draw a green rectangle.

(def rec-panel (proxy [JPanel] []
                 (paint [graphics]
                   (doto graphics
                     (.setColor Color/green)
                     (.fillRect 0 0 10 10)))))

Parallelism

I painlessly parallelized my code because it is side-effects free. Clojure provides primitives that can parallelize functional code.

The bottleneck of the application is calculating the fitness of each individual of a population. In functional terms, it is expressed by mapping each individual to it's fitness using 'map with 'fitness function as it's first argument and the population as it's second argument.

Clojure provides the 'pmap function to make that mapping parallel. It divides the work between worker threads and it uses as many of them as you have CPU cores.

Thus, writing functionaly allowed me to parallelize my code by adding one 'p' character.

See clojure.parallel.

Performance

Performance wasn't a concern when I wrote the application. I tried to keep it simple. After all, that is the purpose of using a high-level language.

Surprisingly, the fitness function(the bottleneck) runs faster in Clojure than in Java. Unfortunately I don't have time to dig into this now.

Here's a graph comparing the run time the fitness function in Java and Clojure. The measure is the average of 25 samples of 100 runs of the fitness function in each language.



Here's the benchmark for reference.

A deal breaker

Lambdas are not garbage collected.

Yes. That means lambdas can be the cause of memory leaks.

As described by Charles Nutter, each lambda in Clojure is an anonymous class in Java. The problem is that classes are never garbage collected. They reside in a special place called the PermGen.

No need to say, my program quickly fills up the PermGen.

The only solution for now is to extend the PermGen.

java -XX:MaxPermSize=1024m -cp clojure.jar clojure.lang.Repl mona-clojure.clj

I don't think this is a problem for most applications though.

EDIT: As of r1232, lambdas created in eval can be GCed. Thanks to Christophe Grand for pointing it out.

The Mona Lisa Challenge

Let's see what your favorite language can do. The challenge is to write a small program that solves the Mona Lisa problem using Genetic Programming.

Show us some code!

Some of the languages I'd like to see are Haskell, Factor, Potion, Ioke, Erlang among lots of others.

Don't forget to leave a link in the comment section of this post.

The code

Here's the github repository.

Please read the source code with syntax highlighting on github.

The following is the full code listing for the impatient only.

(import
  '(java.awt Graphics Graphics2D Color Polygon)
  '(java.awt.image BufferedImage PixelGrabber)
  '(java.io File)
  '(javax.imageio ImageIO)
  '(javax.swing JFrame JPanel JFileChooser))

; ---------------------------------------------------------------------
; This section defines the building blocks of the genetic programs.

; color :: Integer -> Integer -> Integer -> Integer -> Color
(defn color [red blue green alpha] {:type :Color :red red :blue blue :green green :alpha alpha})

; point :: Integer -> Integer -> Point
(defn point [x y] {:type :Point :x x :y y})

; polygon :: Color -> [Point] -> Polygon
(defn polygon [color points] {:type :Polygon :color color :points points})

; draw-polygon :: Graphics -> Polygon -> Nothing
(defn draw-polygon [graphics polygon]
  (doto graphics
    (.setColor (new Color (:red (:color polygon)) 
                          (:blue (:color polygon))
                          (:green (:color polygon))
                          (:alpha (:color polygon))))
    (.fillPolygon (let [jpolygon (new Polygon)]
                    (doseq [p (:points polygon)] (. jpolygon (addPoint (:x p) (:y p))))
                    jpolygon)))
  nil)

; ----------------------------------------------------------------------
; This sections defines helper functions.

; random-double :: Double
(defn random-double
  "Returns a double between -1.0 and 1.0."
  []
  (- (* 2 (rand)) 1))

; remove-item :: Sequence -> Integer -> Sequence
(defn remove-item
  "Returns a sequence without the n-th item of s."
  [s n]
  (cond
    (vector? s) (into (subvec s 0 n)
                (subvec s (min (+ n 1) (count s)) (count s)))
    (list? s) (concat (take n s)
                      (drop (inc n) s))))

; replace-item :: [a] -> Integer -> a -> [a]
(defn replace-item
  "Returns a list with the n-th item of l replaced by v."
  [l n v]
  (concat (take n l) (list v) (drop (inc n) l)))

; grab-pixels :: BufferedImage -> [Integer]
(defn grab-pixels
  "Returns an array containing the pixel values of image."
  [image]
  (let [w (. image (getWidth))
        h (. image (getHeight))
        pixels (make-array (. Integer TYPE) (* w h))]
    (doto (new PixelGrabber image 0 0 w h pixels 0 w)
      (.grabPixels))
    pixels))

; ----------------------------------------------------------------------
; This sections define the primitives of the genetic algorithm.

; program :: S-Expression -> Maybe Integer -> Maybe BufferedImage -> Program
(defn program [code fitness image] {:type :Program :code code :fitness fitness :image image})

; initial-program :: Program
(def initial-program (program '(fn [graphics]) nil nil))

; program-header :: Program -> S-Expression
(defn program-header [p] (take 2 (:code p)))

; program-expressions :: Program -> S-Expression
(defn program-expressions [p] (drop (count (program-header p)) (:code p)))

; mutate :: a -> Map -> a
(defmulti mutate :type)

; mutate :: Color -> Map -> Color
(defmethod mutate :Color [c settings]
  (let [dr (int (* (:red c) (random-double)))
        dg (int (* (:green c) (random-double)))
        db (int (* (:blue c) (random-double)))
        da (int (* (:alpha c) (random-double)))]
    (assoc c :red (max (min (- (:red c) dr) 255) 0)
             :green (max (min (- (:green c) dg) 255) 0)
             :blue (max (min (- (:blue c) db) 255) 0)
             :alpha (max (min (- (:alpha c) da) 255) 0))))

; mutate :: Point -> Map -> Point
(defmethod mutate :Point [p settings]
  (let [dx (int (* (:x p) (random-double)))
        dy (int (* (:y p) (random-double)))]
    (assoc p :x (max (min (- (:x p) dx) (:image-width settings)) 0)
             :y (max (min (- (:y p) dy) (:image-height settings)) 0))))

; mutate :: Polygon -> Map -> Polygon
(defmethod mutate :Polygon [p settings] 
  ; mutate-point :: Polygon -> Map -> Polygon
  (defn mutate-point [p settings]
    (let [n (rand-int (count (:points p)))]
      (update-in p [:points n] (fn [point] (mutate point settings)))))

  ; mutate-color :: Polygon -> Map -> Polygon
  (defn mutate-color [p settings] (assoc p :color (mutate (:color p) settings)))
  
  (let [roulette (rand-int 2)]
    (cond
      (= 0 roulette) (mutate-point p settings)
      (= 1  roulette) (mutate-color p settings))))

; mutate :: Program -> Map -> Program
(defmethod mutate :Program [p settings]
  ; add-polygon :: Program -> Map -> Program
  (defn add-polygon [p settings]
    (assoc p :code 
             (concat (:code p)
                     [(list 'draw-polygon
                            (first (nth (:code initial-program) 1))
                            (polygon
                              (color (rand-int 255) (rand-int 255) (rand-int 255) (rand-int 255))
                              (vec (map 
                                 (fn [n]
                                     (point 
                                       (rand-int (:image-width settings))
                                       (rand-int (:image-height settings))))
                                 (range 5)))))])
             :fitness nil :image nil))

  ; remove-polygon :: Program -> Map -> Program
  (defn remove-polygon [p settings]
    (let [n (rand-int (count (program-expressions p)))]
      (assoc p :code (concat (program-header p)
                             (remove-item (program-expressions p) n))
               :fitness nil :image nil)))

  ; mutate-polygon :: Program -> Map -> Program
  (defn mutate-polygon [p settings]
    (let [expressions (program-expressions p)
          n (rand-int (count expressions))
          target (nth expressions n)]
      (assoc p :code
               (concat (program-header p)
                       (replace-item expressions
                                     n
                                     (list (nth target 0)
                                           (nth target 1)
                                           (mutate (nth target 2) settings))))
               :fitness nil :image nil)))
  
  (let [polygon-count (count (program-expressions p))
        roulette (cond
                   (empty? (program-expressions p)) 4
                   (>= polygon-count (:max-polygons settings)) (rand-int 4)
                   :else (rand-int 5))]
    (cond
      (> 3 roulette) (mutate-polygon p settings)
      (= 3 roulette) (remove-polygon p settings)
      (= 4 roulette) (add-polygon p settings))))

; fitness :: Program -> Map -> Program
(defn fitness [individual settings]
  (if (:fitness individual)
    individual
    (let [gen-image (new BufferedImage (:image-width settings)
                                       (:image-height settings)
                                       BufferedImage/TYPE_INT_ARGB)
          src-pixels (:source-pixels settings)]
      (apply (eval (:code individual)) [(. gen-image (createGraphics))])
      (def gen-pixels (grab-pixels gen-image))
      (loop [i (int 0)
             lms (int 0)]
        (if (< i (alength gen-pixels))
          (let [src-color (new Color (aget src-pixels i))
                gen-color (new Color (aget gen-pixels i))
                dr (- (. src-color (getRed)) (. gen-color (getRed)))
                dg (- (. src-color (getGreen)) (. gen-color (getGreen)))
                db (- (. src-color (getBlue)) (. gen-color (getBlue)))]
            (recur (unchecked-inc i) (int (+ lms (* dr dr) (* dg dg) (* db db )))))
          (assoc individual :fitness lms :image gen-image))))))

; select :: [Program] -> Map -> [Program]
(defn select [individuals settings]
  (take (:select-rate settings)
        (sort-by :fitness
                 (pmap (fn [i] (fitness i settings))
                       individuals))))

; evolve :: Map -> Nothing
(defn evolve [settings]
  (loop [i 0
         population (list initial-program)]
    (let [fittest (select population settings)
          newborns (map (fn [i] (mutate i settings)) fittest)]
      ((:new-generation-callback settings (fn [a b])) i fittest)
      (when-not (= (first population) (first fittest))
        ((:new-fittest-callback settings (fn [a b])) i fittest))
      (recur (inc i) (concat fittest newborns)))))

; ----------------------------------------------------------------------
; This sections defines the graphical interface.

; main :: Nothing
(defn main []
  (def file-chooser (new JFileChooser))
  (doto file-chooser
    (.setCurrentDirectory (new File "."))
    (.showOpenDialog nil))
  
  (let [jframe (new JFrame "Fittest Program")
        fittest (atom (list initial-program))
        image (ImageIO/read (. file-chooser (getSelectedFile)))
        settings {:image-width (. image (getWidth))
                  :image-height (. image (getHeight))
                  :source-pixels (grab-pixels image)
                  :select-rate 1 :max-polygons 50
                  :new-fittest-callback (fn [i f]
                                            (swap! fittest (fn [o n] n) f)
                                            (. jframe (repaint)))}]
    (doto jframe
      (.setSize (. image (getWidth)) (. image (getHeight)))
      (.add (proxy [JPanel] []
        (paint [g]
          (doto g 
            (.setColor Color/white)
            (.fillRect 0 0 (. image (getWidth)) (. image (getHeight)))
            (.drawImage (:image (first @fittest)) nil 0 0)))))
      (.setVisible true))
    (evolve settings)))

(main)