File size: 4,421 Bytes
3b70664 | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | (in-package #:nekod.selfmod)
;; Evolutionary optimizer: genetic algorithm over container spec populations
;; Selection -> Crossover -> Mutation -> Evaluation -> next generation
;; ---- Crossover operators ----------------------------------------------------
(defun crossover-specs (spec-a spec-b)
"Single-point crossover between two container specs.
Returns two children specs."
(let ((child-a (copy-structure spec-a))
(child-b (copy-structure spec-b)))
;; Swap restart policies
(rotatef (container-spec-restart-policy child-a)
(container-spec-restart-policy child-b))
;; Mix env vars: child-a gets first half of A env + second half of B env
(let* ((env-a (container-spec-env spec-a))
(env-b (container-spec-env spec-b))
(mid-a (ceiling (length env-a) 2))
(mid-b (ceiling (length env-b) 2)))
(setf (container-spec-env child-a)
(append (subseq env-a 0 mid-a)
(subseq env-b mid-b)))
(setf (container-spec-env child-b)
(append (subseq env-b 0 mid-b)
(subseq env-a mid-a))))
(values child-a child-b)))
;; ---- Selection operators ----------------------------------------------------
(defun tournament-select (population scores &optional (k 3))
"Tournament selection: pick K random candidates, return the fittest."
(let* ((n (length population))
(candidates (loop repeat k collect (random n)))
(best-idx (first (sort candidates #'>
:key (lambda (i) (nth i scores))))))
(nth best-idx population)))
(defun roulette-select (population scores)
"Fitness-proportionate (roulette wheel) selection."
(let* ((total (reduce #'+ scores))
(pick (random (max total 0.001)))
(running 0.0))
(loop for spec in population
for score in scores
do (incf running score)
when (>= running pick)
return spec
finally (return (car (last population))))))
;; ---- Diversity measure ------------------------------------------------------
(defun population-diversity (population)
"Measure diversity as fraction of specs with unique restart policies."
(let ((policies (mapcar #'container-spec-restart-policy population)))
(/ (length (remove-duplicates policies)) (max (length population) 1))))
;; ---- Full evolutionary step -------------------------------------------------
(defun evolutionary-step (population telemetry
&key (mutation-rate 0.15)
(crossover-rate 0.6)
(elitism 2))
"Full evolutionary step: selection, crossover, mutation, elitism.
Returns next-generation population of same size."
(let* ((n (length population))
(scores (mapcar (lambda (s) (fitness s telemetry)) population))
;; Elites survive unchanged
(sorted-pairs (sort (mapcar #'cons population scores) #'> :key #'cdr))
(elites (mapcar #'car (subseq sorted-pairs 0 (min elitism n))))
(next (copy-list elites)))
;; Fill rest via crossover + mutation
(loop while (< (length next) n)
do (let ((parent-a (tournament-select population scores))
(parent-b (tournament-select population scores)))
(if (< (random 1.0) crossover-rate)
(multiple-value-bind (child-a child-b)
(crossover-specs parent-a parent-b)
(push (or (mutate-spec child-a mutation-rate) child-a) next)
(when (< (length next) n)
(push (or (mutate-spec child-b mutation-rate) child-b) next)))
(push (or (mutate-spec parent-a mutation-rate) parent-a) next))))
(subseq next 0 n)))
;; ---- Convergence check ------------------------------------------------------
(defun converged-p (population telemetry &optional (threshold 0.01))
"Check if population has converged (fitness variance < threshold)."
(let* ((scores (mapcar (lambda (s) (fitness s telemetry)) population))
(mean (/ (reduce #'+ scores) (max (length scores) 1)))
(var (/ (reduce #'+ (mapcar (lambda (s) (expt (- s mean) 2)) scores))
(max (length scores) 1))))
(< var threshold)))
|