mona-clojure.clj

(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)))]
      (assoc p :points (assoc (:points p) n (mutate (get (:points p) n) 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)