;; A genetic algorithm engine.
;;
;; Copyright Patrick May (patrick@softwarematters.org)

(in-package :org.softwarematters.ga)

;; Utility functions.
(defmacro while (test &body body)
  "A little syntactic sugar around DO."
  `(do () ((not ,test)) ,@body))

(defun bit-vector->integer (bits)
  "Create a positive integer from a bit vector."
  (reduce (lambda (first-bit second-bit) (+ (* first-bit 2) second-bit)) bits))

(defun integer->bit-vector (integer)
  "Create a bit-vector from a positive integer."
  (labels ((integer->bit-list (integer &optional (accumulator nil))
             (cond ((> integer 0) (integer->bit-list (truncate integer 2)
                                                     (push (mod integer 2)
                                                           accumulator)))
                   ((null accumulator) (push 0 accumulator))
                   (t accumulator))))
    (coerce (integer->bit-list integer) 'bit-vector)))

(defun bit-vector->gray-code (bits)
  "Convert from standard binary to binary reflected Gray code."
  (let ((gray-bits (make-array (length bits)
                               :element-type 'bit
                               :initial-element 0)))
    (dotimes (i (length bits) gray-bits)
      (if (zerop i)
          (setf (bit gray-bits i) (bit bits i)) ; big-endian
          (setf (bit gray-bits i) (logxor (bit bits (1- i)) (bit bits i)))))))

(defun gray-code->bit-vector (gray-bits)
  "Convert from binary reflected Gray code to standard binary."
  (let ((bits (make-array (length gray-bits)
                          :element-type 'bit
                          :initial-element 0)))
    (dotimes (i (length gray-bits) bits)
      (if (zerop i)
          (setf (bit bits i) (bit gray-bits i)) ; big-endian
          (setf (bit bits i) (logxor (bit bits (1- i)) (bit gray-bits i)))))))

(defun gray-code->integer (bits)
  "Use the utilities provided by the GA package to construct a function
  that computes an integer value from a bit-vector in Gray code."
  (bit-vector->integer (gray-code->bit-vector bits)))

(defun integer->gray-code (integer)
  "Create a Gray code bit-vector from a positive integer."
  (bit-vector->gray-code (integer->bit-vector integer)))

;; The genetic algorithm functions.

(defun make-genome (length &optional (distribution 0.5))
  "Create a randomized bit array of the specified LENGTH.  A value
  between 0 and 1 can be specified for DISTRIBUTION to modify the mean
  relative number of 1 bits."
  (let ((genome (make-array length :element-type 'bit :initial-element 0)))
    (map-into genome (lambda () (if (> distribution (random 1.0)) 1 0)))))

(defun mutate-genome (genome rate)
  "Flip bits in the GENOME bit-vector with a percentage chance equal to
  the specified RATE (ranging from 0 to 1)."
  (bit-xor genome (make-genome (length genome) rate)))

(defun single-crossover (parent-one parent-two)
  "Create two new genomes by crossing over PARENT-ONE and PARENT-TWO at
  a single, randomly selected point."
  (let ((crossover-point (random (length parent-one))))
    (list (concatenate 'bit-vector
                       (subseq parent-one 0 crossover-point)
                       (subseq parent-two crossover-point))
          (concatenate 'bit-vector
                       (subseq parent-two 0 crossover-point)
                       (subseq parent-one crossover-point)))))

(defun segment-crossover (parent-one parent-two &optional (segments 1))
  "Create two new genomes by crossing over SEGMENTS segments of
  PARENT-ONE and PARENT-TWO."
  (let ((child-one (copy-seq parent-one))
        (child-two (copy-seq parent-two)))
    (dotimes (i segments (list child-one child-two))
      (let* ((start (random (length child-one)))
             (end (+ start (random (- (length child-one) start))))
             (segment-one (copy-seq (subseq child-one start end)))
             (segment-two (copy-seq (subseq child-two start end))))
        (setf (subseq child-one start end) segment-two)
        (setf (subseq child-two start end) segment-one)))))

(defun make-gene-pool (size genome-length &optional (distribution 0.5))
  "Create a list of SIZE genomes, each of length GENOME-LENGTH."
  (let ((pool nil))
    (dotimes (count size pool)
      (push (make-genome genome-length distribution) pool))))

(defun most-fit-genome (gene-pool fitness-comparator)
  "Return the most fit genome in GENE-POOL based on FITNESS-COMPARATOR.
  FITNESS-COMPARATOR must take two genomes as arguments and return T if
  the first is the the most fit of the two."
  (reduce (lambda (genome-one genome-two)
            (if (funcall fitness-comparator genome-one genome-two)
                genome-one
                genome-two))
          gene-pool))

(defun tournament-select (gene-pool fitness-comparator
                          &key (tournament-size 2))
  "Randomly select TOURNAMENT-SIZE genomes from the GENE-POOL and apply
  FITNESS-COMPARATOR to return the best one.  FITNESS-COMPARATOR must
  take two genomes as arguments and return T if the first is the the
  most fit of the two."
  (let* ((pool-size (length gene-pool))
         (tournament nil))
    (while (< (length tournament) tournament-size)
      (pushnew (elt gene-pool (random pool-size)) tournament))
    (most-fit-genome tournament fitness-comparator)))

(defun evolve-gene-pool (gene-pool fitness-comparator mutation-rate)
  "Create a new gene pool of the same size as GENE-POOL by replacing
  half the population with mutated offspring of tournament selection
  winners selected by FITNESS-COMPARATOR.  The other half of the
  population consists of the parent genomes.  MUTATION-RATE must be
  between 0 and 1."
  (let ((size (length gene-pool))
        (new-pool nil))
    (dotimes (i (/ size 4) new-pool)
      (let* ((parent-one (tournament-select gene-pool fitness-comparator))
             (parent-two (tournament-select gene-pool fitness-comparator))
             (children (mapcar (lambda (genome)
                                 (mutate-genome genome mutation-rate))
                               (single-crossover parent-one parent-two))))
        (push (copy-seq parent-one) new-pool)
        (push (copy-seq parent-two) new-pool)
        (push (car children) new-pool)
        (push (cadr children) new-pool)))))

;; Solution generators

(defgeneric genome-length (problem)
  (:documentation
   "Returns the number of bits required to represent a candidate
   solution to the PROBLEM."))

(defgeneric fitness (problem genome)
  (:documentation
   "Return the fitness of the bit string GENOME in the context of the
   PROBLEM.  This value is only meaningful in that context."))

(defgeneric fitness-comparator (problem)
  (:documentation
   "Return a fitness comparator function that takes two genomes and
   returns T if the first is more fit according to the characteristics
   of the PROBLEM."))

(defun lesser-comparator (problem)
  "Return a fitness comparator function that takes two genomes and
  returns T if the first has a lower value for its fitness."
  (lambda (genome-one genome-two)
    (< (fitness problem genome-one) (fitness problem genome-two))))

(defun greater-comparator (problem)
  "Return a fitness comparator function that takes two genomes and
  returns T if the first has a higher value for its fitness."
  (lambda (genome-one genome-two)
    (> (fitness problem genome-one) (fitness problem genome-two))))

(defun average-fitness (problem gene-pool)
  "Return the average fitness of the GENE-POOL, in the context of the PROBLEM."
  (/ (apply #'+ (mapcar (lambda (genome) (fitness problem genome)) gene-pool))
     (length gene-pool)))

(defgeneric terminator (generation gene-pool)
  (:documentation
   "Return T if the run should terminate based on the current GENERATION
   and GENE-POOL."))

(defun generation-terminator (generations)
  "Return a termination function that stops processing after GENERATIONS
  generations."
  (lambda (generation gene-pool)
    (declare (ignore gene-pool))
    (>= generation generations)))

(defun fitness-terminator (problem fitness)
  "Return a termination function that stops processing when the best
  solution in the gene pool has fitness greater than or equal to FITNESS
  in the context of the PROBLEM."
  (lambda (generation gene-pool)
    (declare (ignore generation))
    (>= (fitness problem
                 (most-fit-genome gene-pool (fitness-comparator problem)))
        fitness)))

(defun solve (problem pool-size mutation-rate terminator
              &key (write-interim-results t))
  "Evolve a solution to PROBLEM using a gene pool of POOL-SIZE until
  TERMINATOR returns true.  Return the final gene pool."
  (let ((gene-pool (make-gene-pool pool-size (genome-length problem)))
        (comparator (fitness-comparator problem))
        (generation 0))
    (while (not (funcall terminator generation gene-pool))
      (setf gene-pool (evolve-gene-pool gene-pool comparator mutation-rate))
      (when write-interim-results
        (format t "~&Generation:  ~D, best fitness = ~A~%"
                generation
                (fitness problem (most-fit-genome gene-pool comparator))))
      (incf generation))
    gene-pool))