Make genetic operator dispatch more modular and extensible
This commit is contained in:
parent
09d5455da3
commit
0a5a655181
@ -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))))))})
|
||||||
|
Loading…
x
Reference in New Issue
Block a user