Make genetic operator dispatch more modular and extensible

This commit is contained in:
Lee Spector 2020-12-08 22:59:44 -05:00
parent 09d5455da3
commit 0a5a655181

View File

@ -80,26 +80,61 @@
individuals in the population." individuals in the population."
[pop argmap] [pop argmap]
{:plushy {:plushy
(let [prob (rand) (let [r (rand)
[xover add del] (if (:diploid argmap) op (loop [accum 0.0
[diploid-crossover diploid-uniform-addition diploid-uniform-deletion] ops-probs (vec (:variation argmap))]
[crossover uniform-addition uniform-deletion]) (if (empty? ops-probs)
xover-prob (or (:crossover (:variation argmap)) 0) :reproduction
umad-prob (or (:umad (:variation argmap)) 0) (let [[op1 prob1] (first ops-probs)]
flip-prob (or (:diploid-flip (:variation argmap)) 0)] (if (>= (+ accum prob1) r)
(cond op1
(< prob xover-prob) (recur (+ accum prob1)
(xover (:plushy (selection/select-parent pop argmap)) (rest ops-probs))))))]
(:plushy (selection/select-parent pop argmap))) (case op
:crossover
(crossover
(:plushy (selection/select-parent pop argmap))
(:plushy (selection/select-parent pop argmap)))
; ;
(< prob (+ xover-prob umad-prob)) :umad
(del (add (:plushy (selection/select-parent pop argmap)) (-> (:plushy (selection/select-parent pop argmap))
(:instructions argmap) (uniform-addition (:instructions argmap) (:umad-rate argmap))
(:umad-rate argmap)) (uniform-deletion (:umad-rate argmap)))
(:umad-rate argmap))
; ;
(< prob (+ xover-prob umad-prob flip-prob)) :uniform-addition
(diploid-flip (:plushy (selection/select-parent pop argmap)) (-> (:plushy (selection/select-parent pop argmap))
(:diploid-flip-rate 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))))))})