Common Lisp optimal formula finder (using genetic algorithms)

ga.lisp

(ql:quickload :bordeaux-threads)

(defpackage :genetic
  (:use :cl))
(in-package :genetic)

(defvar *target* 345)

(defun ^ (num pow)
  (if (< pow 1)
      1
      (* num (^ num (1- pow)))))

(defparameter *target-size* (^ 10 (length (write-to-string (abs *target*)))))
(defparameter *subform-probability* 0.3)
(defparameter *default-max-rand-value* (* *target-size* 2))
(defparameter *symbol-table* #(+ - *))
(defparameter *mutate-prob* 0.03)
(defparameter *mutate-value-max* 4)
(defparameter *fitness-survival-minimum* 1/1000)
(defparameter *num-animals* 64)

(defun random-symbol (&key exclude)
  "Grab a random symbol from the global symbol table. Supports excluding of a
  particular symbol (only one at the moment, though)."
  (let ((symbol-table (if exclude
                          (remove-if (lambda (x)
                                       (eql x exclude))
                                     *symbol-table*)
                          *symbol-table*)))
    (aref symbol-table (random (length symbol-table)))))

(defun random-number (&key (max *default-max-rand-value*))
  "Wrapper around random number generator."
  (random max))

(defun random-genome (&key (min-depth 1) (max-depth 2) (depth-level 0))
  "Create a random genome."
  (when (> depth-level max-depth)
    (return-from random-genome (random-number)))
  (if (or (< depth-level min-depth) (< (random 1.0) *subform-probability*))
      (list (random-symbol)
            (random-genome :depth-level (1+ depth-level))
            (random-genome :depth-level (1+ depth-level)))
      (random-number)))

(defmacro appendf (list value)
  "Append a value to a list, destructive"
  `(setf ,list (append ,list (list ,value))))

(defun get-tree-locations (tree &key parent)
  "Given a list (with or without embedded lists) find each leaf node of that
  tree and compile a list of paths to get the them. For instance for the list:
      '(1 2 (8 (3 4) 4))
  you get
      ((0) (1) (2 0) (2 1 0) (2 1 1) (2 2))
  Each one of those elements is an (nth ...)able set of values. For instance in
  this case, the path (2 1 1) would expand to (nth 1 (nth 1 (nth 2 tree))), and
  yield the value 4.

  This is very useful for being able to locate/modify specific leaf nodes of a
  tree by putting all the nodes in a flat list that's easy to select from."
  (let ((locations nil)
        (i 0)
        (num-items 0))
    (dolist (leaf tree)
      (let ((cur-loc (append parent (list i))))
        (if (listp leaf)
            (multiple-value-bind (new-locations count) (get-tree-locations leaf :parent cur-loc)
              (setf locations (append locations new-locations))
              (incf num-items count))
            (progn
              (appendf locations cur-loc)
              (incf num-items))))
      (incf i))
    (values locations
            num-items)))

(defun get-tree-location-from-path (tree tree-path)
  "Takes a path generated by get-tree-locations and given the same tree given to
  get-tree-locations, will return the parent list of the element referenced by
  the path and the nth element of the parent list the value exists in. The
  reason for returning the parent list is so that the parent list can be changed
  and the references to that list can be updated as well.

  This works really well with the mutate function, which needs to actually 
  modify the genome tree structure."
  (let ((leaf tree)
        (path tree-path)
        (nodes (length tree-path))
        (i 0))
    (dolist (n path)
      (when (= i (- nodes 1))
        (return))
      (setf leaf (nth n leaf))
      (incf i))
    (values leaf
            (car (last path)))))

(defun mutate-value (value)
  "If a value is numeric, mutate it via addition/subtraction. Otherwise, pretend
  we never called this function."
  (if (numberp value)
      (+ value (- (random (* 2 *mutate-value-max*)) *mutate-value-max*))
      value))

(defun mutate (genome)
  "Performs a mutation on a genome (assuming probability allows it). Works by
  parsing the genome tree and pulling out direct paths to all the nodes. It
  picks a path at random and mutates the contained value."
  (let ((genome (copy-tree genome)))
    (when (< (random 1.0) *mutate-prob*)
      (let* ((nodes (get-tree-locations genome))
             (random-node (nth (random (length nodes)) nodes)))
        (multiple-value-bind (node index)
            (get-tree-location-from-path genome random-node)
          (let ((val (nth index node)))
            (setf (nth index node) (if (symbolp val)
                                       (random-symbol :exclude val)
                                       (mutate-value val)))))))
    genome))

(defun crossover (mom dad)
  "Crossover two genomes."
  (let ((mom (copy-tree mom))
        (dad (copy-tree dad)))
    (let ((tmp (nth 1 dad)))
      (setf (nth 1 dad) (nth 1 mom)
            (nth 1 mom) tmp)
      (values mom dad))))

(defun calculate-fitness (genome)
  (handler-case
    (let ((val (eval genome))
          (complexity (multiple-value-bind (paths num-items) (get-tree-locations genome) num-items)))
      (let ((performance (/ 1 (1+ (abs (- *target* val))))))
        (if (= performance 1)
            performance
            ;(* performance (- 1 (* (log complexity) .08))))))
            performance)))
    (error () nil)))

(defclass animal ()
  ((genome :accessor animal-genome :initarg :genome :initform (random-genome))
   (fitness :accessor animal-fitness :initform 0)))

(defmethod find-mate ((animal animal) (pop list))
  (let ((pop (sort (remove-if (lambda (a) (equal animal a)) pop)
                   (lambda (a1 a2) (< (animal-fitness a1) (animal-fitness a2))))))
    (let* ((pop-min (animal-fitness (car (last pop))))
           (adjusted-fitness (mapcar (lambda (a) (list (* (animal-fitness a) (/ 1 pop-min)) a)) pop))
           (pop-max-adjusted (car (car (last adjusted-fitness))))
           (rand-val (random (coerce pop-max-adjusted 'double-float))))
      (dolist (f adjusted-fitness)
        ;(when (>= (car f) rand-val)
          (return-from find-mate (cadr f))))))

(defun epoch (population)
  (let ((new-population nil)
        (winner nil)
        (avg-fitness 0)
        (max-fitness 0)
        (min-fitness 99999))
    (dolist (a population)
      (let ((fitness (animal-fitness a)))
        (when (or (null fitness) (< fitness *fitness-survival-minimum*))
            ;; die motherfucker 
            (format t "(died) ")
            (setf (animal-genome a) (random-genome))
            (setf (animal-fitness a) (calculate-fitness (animal-genome a)))
            (setf fitness (animal-fitness a)))
        (format t "animal: ~a   ~a~%" fitness (animal-genome a))
        (when (< max-fitness fitness)
          (setf max-fitness fitness))
        (when (< fitness min-fitness)
          (setf min-fitness fitness))
        (when (= fitness 1)
          (format t "WINNER!~%")
          (setf winner a))
        (incf avg-fitness fitness))
      (multiple-value-bind (mom dad)
          (crossover (animal-genome a)
                     (animal-genome (find-mate a population)))
        (push (make-instance 'animal :genome (mutate mom)) new-population)
        (push (make-instance 'animal :genome (mutate dad)) new-population))
      (when (<= *num-animals* (length new-population))
        (return)))
    (values new-population
            winner
            (/ avg-fitness (length new-population))
            max-fitness
            min-fitness)))

(defun run-population (population)
  (dolist (a population)
    (setf (animal-fitness a) (calculate-fitness (animal-genome a))))
  population)

(defun main ()
  (let ((population (loop for x from 1 to *num-animals* collect (make-instance 'animal))))
    (dotimes (i 1000)
      (setf population (run-population population))
      (multiple-value-bind (new-population winner avg-fitness max-fitness min-fitness)
          (epoch population)
        (when winner
          (format t "~%~%We got a winner! (only took ~a generations)~%  ~a = ~a~%" i (animal-genome winner) (eval (animal-genome winner)))
          (return-from main winner))
        (setf population new-population)
        (format t "~%pop avg: ~f, pop max: ~f, pop min: ~f~%-------------~%" avg-fitness max-fitness min-fitness)))))