From 180a7fdbe0ad2a59c862505aef9df6a1333c2446 Mon Sep 17 00:00:00 2001
From: Lee Spector <lspector@hampshire.edu>
Date: Tue, 8 Dec 2020 22:53:37 -0500
Subject: [PATCH] Provide more modular and and extensible approach to genetic
 operator dispatch

---
 src/propeller/problems/valiant.cljc |  8 +--
 src/propeller/session.cljc          | 27 ++++++++--
 src/propeller/variation.cljc        | 76 +++++++++++++++++++++--------
 3 files changed, 82 insertions(+), 29 deletions(-)

diff --git a/src/propeller/problems/valiant.cljc b/src/propeller/problems/valiant.cljc
index e43d899..c51e9a4 100644
--- a/src/propeller/problems/valiant.cljc
+++ b/src/propeller/problems/valiant.cljc
@@ -26,10 +26,10 @@
   (vec (concat (for [i (range num-inputs)] (keyword (str "in" i)))
                (take num-inputs
                      (cycle [:boolean_xor
-                             ;:boolean_or
-                             ;:boolean_not
-                             ;:exec_if
-                             ;'close
+                             :boolean_or
+                             :boolean_not
+                             :exec_if
+                             'close
                              ])))))
 
 (defn error-function
diff --git a/src/propeller/session.cljc b/src/propeller/session.cljc
index 9f83bd4..1db83ca 100755
--- a/src/propeller/session.cljc
+++ b/src/propeller/session.cljc
@@ -190,21 +190,38 @@
 
 ;;; below is when I switched to just xor
 
+;(gp/gp {:instructions            propeller.problems.valiant/instructions
+;        :error-function          propeller.problems.valiant/error-function
+;        :max-generations         500
+;        :population-size         500
+;        :max-initial-plushy-size 50
+;        :step-limit              2000
+;        :parent-selection        :lexicase
+;        :tournament-size         2
+;        :umad-rate               0.01
+;        :diploid-flip-rate       0.01
+;        :variation               {:umad         0.5
+;                                  :crossover    0.25
+;                                  :diploid-flip 0.25
+;                                  }
+;        :elitism                 false
+;        :diploid                 true})
+
+;; separated diploid from other operators
+
 (gp/gp {:instructions            propeller.problems.valiant/instructions
         :error-function          propeller.problems.valiant/error-function
         :max-generations         500
-        :population-size         500
+        :population-size         50
         :max-initial-plushy-size 50
         :step-limit              2000
         :parent-selection        :lexicase
         :tournament-size         2
         :umad-rate               0.01
         :diploid-flip-rate       0.01
-        :variation               {:umad         0.5
-                                  :crossover    0.25
+        :variation               {:diploid-umad         0.5
+                                  :diploid-crossover    0.25
                                   :diploid-flip 0.25
                                   }
         :elitism                 false
         :diploid                 true})
-
-
diff --git a/src/propeller/variation.cljc b/src/propeller/variation.cljc
index 1c01464..b8c148b 100755
--- a/src/propeller/variation.cljc
+++ b/src/propeller/variation.cljc
@@ -80,26 +80,62 @@
   individuals in the population."
   [pop argmap]
   {:plushy
-   (let [prob (rand)
-         [xover add del] (if (:diploid argmap)
-                           [diploid-crossover diploid-uniform-addition diploid-uniform-deletion]
-                           [crossover uniform-addition uniform-deletion])
-         xover-prob (or (:crossover (:variation argmap)) 0)
-         umad-prob (or (:umad (:variation argmap)) 0)
-         flip-prob (or (:diploid-flip (:variation argmap)) 0)]
-     (cond
-       (< prob xover-prob)
-       (xover (:plushy (selection/select-parent pop argmap))
-              (:plushy (selection/select-parent pop argmap)))
+   (let [r (rand)
+         op (loop [accum 0.0
+                   ops-probs (vec (:variation argmap))]
+              (if (empty? ops-probs)
+                :reproduction
+                (let [[op1 prob1] (first ops-probs)]
+                  (if (>= (+ accum prob1) r)
+                    op1
+                    (recur (+ accum prob1)
+                           (rest ops-probs))))))]
+     (case op
+       :crossover
+       (crossover
+         (:plushy (selection/select-parent pop argmap))
+         (:plushy (selection/select-parent pop argmap)))
        ;
-       (< prob (+ xover-prob umad-prob))
-       (del (add (:plushy (selection/select-parent pop argmap))
-                 (:instructions argmap)
-                 (:umad-rate argmap))
-            (:umad-rate argmap))
+       :umad
+       (-> (:plushy (selection/select-parent pop argmap))
+           (uniform-addition (:instructions argmap) (:umad-rate argmap))
+           (uniform-deletion (:umad-rate argmap)))
        ;
-       (< prob (+ xover-prob umad-prob flip-prob))
-       (diploid-flip (:plushy (selection/select-parent pop argmap))
-                     (:diploid-flip-rate argmap))
+       :uniform-addition
+       (-> (:plushy (selection/select-parent pop argmap))
+           (uniform-addition (:instructions argmap) (:umad-rate argmap)))
        ;
-       :else (:plushy (selection/select-parent pop argmap))))})
+       :uniform-deletion
+       (-> (:plushy (selection/select-parent pop argmap))
+           (uniform-deletion (:umad-rate argmap)))
+       ;
+       :diploid-crossover
+       (diploid-crossover
+         (:plushy (selection/select-parent pop argmap))
+         (:plushy (selection/select-parent pop argmap)))
+       ;
+       :diploid-umad
+       (-> (:plushy (selection/select-parent pop argmap))
+           (diploid-uniform-addition (:instructions argmap) (:umad-rate argmap))
+           (diploid-uniform-deletion (:umad-rate argmap)))
+       ;
+       :diploid-uniform-addition
+       (-> (:plushy (selection/select-parent pop argmap))
+           (diploid-uniform-addition (:instructions argmap) (:umad-rate argmap)))
+       ;
+       :diploid-uniform-deletion
+       (-> (:plushy (selection/select-parent pop argmap))
+           (diploid-uniform-deletion (:umad-rate argmap)))
+       ;
+       :diploid-flip
+       (-> (:plushy (selection/select-parent pop argmap))
+           (diploid-flip (:diploid-flip-rate argmap)))
+       ;
+       :reproduction
+       (:plushy (selection/select-parent pop argmap))
+       ;
+       :else
+       (throw #?(:clj  (Exception. (str "No match in new-individual for " op))
+                 :cljs (js/Error
+                         (str "No match in new-individual for " op))))))})
+