Add alternation genetic operator; mul3 enhancements

src/propeller/problems/boolean/mul3.cljc

@@ -104,6 +104,61 @@
                 [:output :c0]
                 (state/peek-stack state :boolean)))))
 
+
+(def-instruction
+  :c5
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c5 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
+(def-instruction
+  :c4
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c4 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
+(def-instruction
+  :c3
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c3 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
+(def-instruction
+  :c2
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c2 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
+(def-instruction
+  :c1
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c1 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
+(def-instruction
+  :c0
+  ^{:stacks [:boolean :output]}
+  (fn [state]
+    (let [val (:c0 (:output state))]
+      (if (boolean? val)
+        (state/push-to-stack state :boolean val)
+        state))))
+
 (def-instruction
   :boolean_bufa
   ^{:stacks #{:boolean}}
@@ -113,7 +168,6 @@
                       [:boolean :boolean]
                       :boolean)))
 
-
 (def-instruction
   :boolean_nota
   ^{:stacks #{:boolean}}
@@ -164,12 +218,18 @@
         :set-c2 ;; defined here
         :set-c1 ;; defined here
         :set-c0 ;; defined here
-;; PROVIDE ACCESS ALSO TO c0-c5?
+        :c5 ;; defined here
-        ;; AND/OR BOOLEAN TAGGING?
+        :c4 ;; defined here
+        :c3 ;; defined here
+        :c2 ;; defined here
+        :c1 ;; defined here
+        :c0 ;; defined here
+        
+        ;; BOOLEAN TAGGING?
 
         ;; Recommended by Kalkreuth et al: BUFa, NOTa, AND, OR, XOR, NAND, NOR, XNOR
-        :boolean_bufa ;; defined here
+        ;:boolean_bufa ;; defined here
-        :boolean_nota ;; defined here
+        ;:boolean_nota ;; defined here
         :boolean_and
         :boolean_or
         :boolean_xor
@@ -177,10 +237,12 @@
         :boolean_nor ;; defined here
         :boolean_xnor ;; defined here
 
+        :boolean_not ;; added to compensate for commenting out :boolean_nota
+
         ;:boolean_pop
-        ;:boolean_dup
+        :boolean_dup
-        ;:boolean_swap
+        :boolean_swap
-        ;:boolean_rot
+        :boolean_rot
 
         ;:exec_pop
         ;:exec_dup
@@ -247,8 +309,11 @@
      :parent-selection         :lexicase
      ;:parent-selection         :tournament
      :tournament-size          5
-     :umad-rate                0.01
+     :umad-rate                0.05
-     :variation                {:umad 1
+     :alternation-rate         0.05
+     :alignment-deviation      1
+     :variation                {:umad 0.5
+                                :alternation 0.5
                                 :reproduction 0
                                 :tail-aligned-crossover 0
                                 }

src/propeller/utils.cljc

@@ -105,3 +105,26 @@ multicore processor utilization, and 4) takes only one coll so far."
                    (apply await agents)
                    (doall (map deref agents)))))
      :cljs (mapv f coll)))
+
+(def PI
+  #?(:clj Math/PI
+     :cljs js/Math.PI))
+
+(defn log [x]
+  #?(:clj  (Math/log x)
+     :cljs (js/Math.log x)))
+
+(defn round [x]
+  #?(:clj  (Math/round x)
+     :cljs (js/Math.round x)))
+
+(defn gaussian-noise-factor
+  "Returns gaussian noise of mean 0, std dev 1."
+  []
+  (* (Math/sqrt (* -2.0 (log (rand))))
+      (Math/cos (* 2.0 PI (rand)))))
+
+(defn perturb-with-gaussian-noise
+  "Returns n perturbed with std dev sd."
+  [sd n]
+  (+ n (* sd (gaussian-noise-factor))))

src/propeller/variation.cljc

@@ -71,6 +71,29 @@ The function `new-individual` returns a new individual produced by selection and
                  shorter-padded
                  longer))))
 
+(defn alternation
+  "Alternates between the two parent genomes."
+  [genome1 genome2 {:keys [alternation-rate alignment-deviation] :as argmap}]
+  (let [alternation-rate (or alternation-rate 0)
+        alignment-deviation (or alignment-deviation 0)]
+    (loop [i 0
+           use-genome1 (rand-nth [true false])
+           result-genome []
+           iteration-budget (+ (count genome1) (count genome2))]
+      (if (or (>= i (count (if use-genome1 genome1 genome2))) ;; finished current program
+              (<= iteration-budget 0)) ;; looping too long
+        result-genome ;; Return
+        (if (< (rand) alternation-rate)
+          (recur (max 0 (+ i (utils/round (* alignment-deviation
+                                             (utils/gaussian-noise-factor)))))
+                 (not use-genome1)
+                 result-genome
+                 (dec iteration-budget))
+          (recur (inc i)
+                 use-genome1
+                 (conj result-genome (nth (if use-genome1 genome1 genome2) i))
+                 (dec iteration-budget)))))))
+
 (defn tail-aligned-crossover
   "Crosses over two individuals using uniform crossover, one Push instruction at a time.
    Pads shorter one from the beginning of the list of instructions."
@@ -217,7 +240,7 @@ The function `new-individual` returns a new individual produced by selection and
        ; uniform mutation by addition and deletion is a uniform mutation operator which
        ;first adds genes with some probability before or after every existing gene and then
        ;deletes random genes from the resulting genome
-
+       ;
        :rumad
        (let [parent-genome (:plushy (selection/select-parent pop argmap))
              after-addition (uniform-addition parent-genome
@@ -228,13 +251,13 @@ The function `new-individual` returns a new individual produced by selection and
                                         (count parent-genome))]
          (uniform-deletion after-addition effective-addition-rate))
        ; Adds and deletes instructions in the parent genome with the same rate
-
+       ;
        :vumad ;; variable umad: :umad-rate is interpreted as max, actual uniform 0-max
        (let [rate (rand (:umad-rate argmap))]
          (-> (:plushy (selection/select-parent pop argmap))
              (uniform-addition (:instructions argmap) rate)
              (uniform-deletion rate)))
-
+       ;
        :uniform-addition
        (-> (:plushy (selection/select-parent pop argmap))
            (uniform-addition (:instructions argmap) (:umad-rate argmap)))
@@ -284,6 +307,11 @@ The function `new-individual` returns a new individual produced by selection and
        (-> (:plushy (selection/select-parent pop argmap))
            (diploid-flip (:diploid-flip-rate argmap)))
        ;
+       :alternation
+       (alternation (:plushy (selection/select-parent pop argmap))
+                    (:plushy (selection/select-parent pop argmap))
+                    argmap)
+       ;
        :reproduction
        (:plushy (selection/select-parent pop argmap))
        ;