From 9f3c6f46ff1a4b8fb1d4b9baa2f0be4a16881976 Mon Sep 17 00:00:00 2001
From: Lee Spector <lspector@hampshire.edu>
Date: Thu, 12 Oct 2023 14:39:26 -0400
Subject: [PATCH] Implement autoconstructive hypervariation umad (ah-umad)

---
 src/propeller/variation.cljc | 67 ++++++++++++++++++++++++++++++++----
 1 file changed, 60 insertions(+), 7 deletions(-)

diff --git a/src/propeller/variation.cljc b/src/propeller/variation.cljc
index 5ef743b..49b2462 100755
--- a/src/propeller/variation.cljc
+++ b/src/propeller/variation.cljc
@@ -50,8 +50,8 @@ Since `uniform-addition` and `uniform-deletion` are somewhat stochastic, you can
 
 The function `new-individual` returns a new individual produced by selection and variation of individuals in the population based on the genetic operators provided in the `:variation` map."
   {:doc/format :markdown}
-    (:require [propeller.selection :as selection]
-      [propeller.utils :as utils]))
+  (:require [propeller.selection :as selection]
+            [propeller.utils :as utils]))
 
 (defn crossover
   "Crosses over two individuals using uniform crossover, one Push instruction at a time.
@@ -172,11 +172,11 @@ The function `new-individual` returns a new individual produced by selection and
   existing instruction."
   [plushy instructions umad-rate]
   (flatten
-    (map (fn [pair]
-           (if (< (rand) umad-rate)
-             (shuffle [pair (repeatedly 2 #(utils/random-instruction instructions))])
-             [pair]))
-         (partition 2 plushy))))
+   (map (fn [pair]
+          (if (< (rand) umad-rate)
+            (shuffle [pair (repeatedly 2 #(utils/random-instruction instructions))])
+            [pair]))
+        (partition 2 plushy))))
 
 (defn uniform-deletion
   "Randomly deletes instructions from plushy at some rate."
@@ -202,6 +202,52 @@ The function `new-individual` returns a new individual produced by selection and
                    %)
                 (partition 2 plushy))))
 
+(defn ah-rates
+  [plushy protect-rate hypervariable-rate]
+  (loop [i 0
+         protected true
+         rates []
+         remainder plushy]
+    (if (empty? remainder)
+      rates
+      (if (and (not protected)
+               (= (first remainder) :protect))
+        (recur i
+               true
+               rates
+               remainder)
+        (recur (inc i)
+               (if protected
+                 (not= (first remainder) :vary)
+                 false)
+               (conj rates (if protected protect-rate hypervariable-rate))
+               (rest remainder))))))
+
+(defn ah-uniform-addition
+  "Returns plushy with new instructions possibly added before or after each
+  existing instruction. Rates are autoconstructively hypervariable."
+  [plushy instructions protect-rate hypervariable-rate]
+  (apply concat
+         (map #(if (< (rand) %2)
+                 (shuffle [%1 (utils/random-instruction instructions)])
+                 [%1])
+              plushy
+              (ah-rates plushy protect-rate hypervariable-rate))))
+
+(defn ah-uniform-deletion
+  "Randomly deletes instructions from plushy at some rate.
+   Rates are autoconstructively hypervariable."
+  [plushy protect-rate hypervariable-rate]
+  (map first
+       (remove (fn [[_ rate]]
+                 (< (rand)
+                    (if (zero? rate)
+                      0
+                      (/ 1 (+ 1 (/ 1 rate))))))
+               (map vector
+                    plushy
+                    (ah-rates plushy protect-rate hypervariable-rate)))))
+
 (defn new-individual
   "Returns a new individual produced by selection and variation of
   individuals in the population."
@@ -254,6 +300,13 @@ The function `new-individual` returns a new individual produced by selection and
              (uniform-addition (:instructions argmap) rate)
              (uniform-deletion rate)))
        ;
+       :ah-umad
+       (let [rate (utils/onenum (:umad-rate argmap))
+             ah-rate (utils/onenum (:ah-umad-rate argmap))]
+         (-> (:plushy (selection/select-parent pop argmap))
+             (ah-uniform-addition (:instructions argmap) rate ah-rate)
+             (ah-uniform-deletion rate ah-rate)))
+       ;
        :uniform-addition
        (-> (:plushy (selection/select-parent pop argmap))
            (uniform-addition (:instructions argmap)