selfmod/evolve.lisp

(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)))