genetic.clj

; Copyright (c) 2014 Vojtech Havlicek
; Permission is hereby granted, free of charge, to any person
; obtaining a copy of this software and associated documentation
; files (the "Software"), to deal in the Software without
; restriction, including without limitation the rights to use,
; copy, modify, merge, publish, distribute, sublicense, and/or sell
; copies of the Software, and to permit persons to whom the
; Software is furnished to do so, subject to the following
; conditions:

; The above copyright notice and this permission notice shall be
; included in all copies or substantial portions of the Software.

; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
; OTHER DEALINGS IN THE SOFTWARE.

; -------------------------------------------------------------
;
; Algebraic regression test v.1
;
; This is a simple GP programming trial.
; Motivated by: Introduction to Genetic Programing by M. Walker

; As an example, perform a fit through the following
; set of points 3x + 1
(def to-fit '([0, 1] [1, 4]))

; The following is an implementation of Koza's growth
; Genes to use are (di-arity functions only),
; terminals are specified as expressions for simpler parsing.
(def genes {:functions ["+", "-"], :terminals ["(+ 0 1)", "(+ 0 x)"]})

;; Function to reproduce:
;; Koza's growth:
(def settings {:terminal-probability 0.3
               :max-depth 5
               :init-population-size 100}) ; probability a Koza growth node will be terminal

;; Recursive definition of the 2-ary growth
(defn grow-rec [depth]
  (if (and (> (rand) (:terminal-probability settings)) (< depth (:max-depth settings)))

    ; True, grow further:
    (str "(" (rand-nth (:functions genes)) \space
         (grow-rec (inc depth)) \space
         (grow-rec (inc depth)) ")" )

    ; False, stop growing
    (str (rand-nth (:terminals genes))) ; Returns the terminal
    ))

;; Recursive definition pf the 2-ary full growth
(defn full-rec [depth]
  (if (< depth (:max-depth settings))

    ; True, grow further:
    (str "(" (rand-nth (:functions genes)) \space
         (grow-rec (inc depth)) \space
         (grow-rec (inc depth)) ")" )

    ; False, stop growing
    (str (rand-nth (:terminals genes))) ; Returns the terminal

    ))

;; Fitness test?
;; TODO: convert to let syntax ?
(defn fitness-test [element]
    (def weight 0)
    (dotimes [n (count to-fit)]
      (let [point (nth to-fit n)]
        (def x (first point)) ; defined as global binding to evaluate the weight in correct context
        (def dist (- (eval (read-string element)) (last point)))
        (def weight (+ weight (* dist dist))))
      )
  {:weight weight :std-weight (/ 1.0 (+ 1.0 weight)) :expression element})

;; Genetic operations:
; Reproduction
; 10% of elements selected to survive. Selection function?

; Crossover
; 2 individuals -> new 2 individuals
; 90% of the population!
; Randomly select a subtrees from both individuals & swap

;; Select a left bracket at random:
(defn get-left-bracket-at-random [tree]
  (loop [index 0
         max-index 0
         local-male tree
         max-rand 0]

    (if (= (first local-male) \( )
      (let [r (rand)]
         (if (> r max-rand)
           (recur (inc index) index (rest local-male) r)
           (recur (inc index) max-index (rest local-male) max-rand)))

      (if (= nil (next local-male))
        max-index
        (recur (inc index) max-index (rest local-male) max-rand)
      ))))

(def tree "((+ 1 1) (+ 0 1))")

(get-matching-right-bracket tree 0)
(get-matching-right-bracket tree 1)

(nth tree (get-matching-right-bracket tree 1))

;; Given the left bracket, get a matching right bracket
(defn get-matching-right-bracket [tree left-bracket]
  (loop [index (inc left-bracket)
         left-count 1
         right-count 0]
    (if (= left-count right-count)
      (dec index)


      (cond
       (= (nth tree index) \)) (recur (inc index) left-count (inc right-count))
       (= (nth tree index) \() (recur (inc index) (inc left-count) right-count)
       (< 5000 index) (println "Int overflow!" tree)
       :else (recur (inc index) left-count right-count)
        ))))

;; Perform a crossover at any point in the tree
(defn crossover [male female]
  (let [male-bra (get-left-bracket-at-random male)
        male-ket (get-matching-right-bracket male male-bra)
        male-child (subs male male-bra male-ket)

        female-bra (get-left-bracket-at-random female)
        female-ket (get-matching-right-bracket female female-bra)
        female-child (subs female female-bra female-ket)]

        {:male (str (subs male 0 male-bra) female-child (subs male male-ket))
         :female (str (subs female 0 female-bra) male-child (subs female female-ket))}
    )
  )

; Additionally: editing, mutation, permutation, encapsulation & decimation

;; Selection function: select a pair for crossover.
;; Takes a list of {:weight :std-weigth :expression} maps
(defn select-pair [fitness-tested-population
                   normalization]
  {:male (select-random fitness-tested-population normalization)
   :female (select-random fitness-tested-population normalization)}
  )

;; Selects an item at random, weighted by std. weight
(defn select-random [fitness-tested-population
                     normalization]
  (loop [index 0
         sum 0.0
         max (* (rand) normalization )
         local-fitness-tested fitness-tested-population]

    (let [next-sum (+ sum (:std-weight (first local-fitness-tested)))]
      (if (< next-sum max)
           (recur (inc index)
                  next-sum
                  max
                  (rest local-fitness-tested))

           (:expression (first local-fitness-tested))

       ))))

;; -------------------------------------------------------------
;; Algorithm loop:

;; Grow the initial population with ramped half and half method
(def population [])
(dotimes [x (:init-population-size settings)]
  (def population (conj population (full-rec (+ 1 x)))) ;; do the looping nicely?
  (def population (conj population (grow-rec (+ 1 x)))))

;; Perform genetical evolution

(def to-reproduce [])
(dotimes [k 10]
  (println "Epoch: " k " started!")
  ; Fitness proportionale selection
  ; Select the best 2 entries only to survive and crossover the rest
  (let [fitness-tested (map fitness-test population)
        normalization (reduce + (map :std-weight fitness-tested))
        to-reproduce (map :expression (take 10 (sort-by :weight fitness-tested)))]

        (loop [index 0
               new-generation to-reproduce
               mates (select-pair fitness-tested normalization)
               children (crossover (:male mates) (:female mates))]

          (if (< index 45)
              (recur (inc index)
                     (conj new-generation (:male children) (:female children))
                     (select-pair fitness-tested normalization)
                     (crossover (:male mates) (:female mates)))

               (do
                 new-generation
                 (def population new-generation)
                 )))
    (println (first to-reproduce))))