#|
 
genesis.lisp
 
Copyright (C) 2008 Jake Voytko
 
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation
files (the "Software"), to deal in the Software without restriction,
including without limitation the rights to use, copy, modify, merge,
publish, distribute, sublicense, and/or sell copies of the Software,
and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
 
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
 
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
|#
 
 
(in-package "GENESIS")
 
(load "./utility.lisp")
 
(defstruct RULE
  "Defines a Genesis rule, consisting of a function (of arbitrary
  arguments) and a list that evaluates to the function."
  list fun)
 
 
(defvar *CURRENT-POPULATION* nil
  "Stores the current population. This should be stored as a list. Be
  aware that this is reset by a call to (genetic-algorithm).")
 
 
(defvar *MAX-RULE-SIZE* 15
  "Since some of the evolution functions cause the size of a rule set to grow non-linearly, we provide a maximum rule size.")
 
 
(defun prep-population (starting-rules population-size)
  "Sets 'rule-array' to an array of 'population-size' length, and with
  the initial element 'starting-rules'."
  (make-array (list population-size) :initial-element starting-rules))
 
  
(defun modify-rule-list (f list)
  "Decide by 'coin-flip' whether or not to replace each element
  of 'list' with the result of a function 'f'."
  (labels ((recurse-rule-list (f list)
             (if (null list)
                 nil
                 (cons (if (coin-flip)
                           (new-rule f)
                           (car list))
                       (modify-rule-list f (cdr list))))))
    (recurse-rule-list f list)))
 
 
(defun new-rule (rule-fun)
  "Defines a new instance of the RULE struct from the list generated by
  rule-fun."
  (labels ((gen-new-rule (fun)
             (let ((rule (funcall fun)))
               (make-rule :list rule
                          :fun
                          (eval (list 'lambda '(num)
                                      rule))))))
    (do ((rule (gen-new-rule rule-fun) (gen-new-rule rule-fun)))
        ((not (null (prune-bad-rules (list rule)))) rule))))
 
 
(defun add-to-rule-list (f list)
  "Decide by 'coin-flip' whether or not to append new elements
  to 'list' with the result of function 'f'. Appends at least
  one new rule."
  (append list (at-least-once (lambda () (new-rule f)))))
 
 
(defun prune-bad-rules (rules)
  "Removes rules that evaluate to a number. This may or may not survive;
  it may be designed away, which would be preferable."
  (if (null rules)
      nil
      (let ((value (ignore-errors (eval (rule-list (car rules))))))
        (if (numberp value)
            (prune-bad-rules (cdr rules))
            (cons (car rules) (prune-bad-rules (cdr rules)))))))
 
 
(defun funcall-best (population fitness-fun arg)
  "Calls (funcall-rules .. 'arg') with the best function in 'population'
  as determined by 'fitness-fun'"
  (funcall-rules
   (reduce (lambda (a b)
             (let ((fit-a (funcall fitness-fun a))
                   (fit-b (funcall fitness-fun a)))
               (if (< fit-a fit-b) a b)))
           population)
   arg))
          
 
 
(defun funcall-rules (rules arg)
  "Actually perform a function call with the rules!"
  (let ((val arg))
    (dolist (fn rules)
      (setf val (funcall (rule-fun fn) val)))
    val))
 
 
(defun remove-item-from-list (list index)
  "Removes the element at index 'index' from the input list."
  (labels ((remove-from-list (lst ind &optional (i 0))
             (if (null lst)
                 nil
                 (if (eql ind i)
                     (remove-from-list (cdr lst) ind (+ i 1))
                     (cons (car lst)
                           (remove-from-list (cdr lst) ind (+ i 1)))))))
    (remove-from-list list index)))
    
 
 
(defun remove-random-item (rules)
  "Removes a random item from the list, except when 'rules' has a
  single element."
  (if (or (null rules) (= 1 (length rules)))
      rules
      (let ((rule (random (length rules))))
        (remove-item-from-list rules rule))))
    
 
 
(defmacro mutate-rule-list (rule-fun rules)
  "Destructively modifies a list of rules by randomly adding and
replacing rules."
  `(progn
    (when (coin-flip) (setf ,rules (remove-random-item ,rules)))
    (when (coin-flip) (setf ,rules (add-to-rule-list ,rule-fun ,rules)))
    (when (coin-flip) (setf ,rules (modify-rule-list ,rule-fun ,rules)))))
 
 
(defun random-merge-rules (rule1 rule2)
  "Randomly merges elements of the lists rule1 and rule2 together."
  (if (eql rule1 rule2)
      rule1
      (merge 'list rule1 rule2 (lambda (a b) (coin-flip)))))
 
 
(defun random-breed (rule1 rule2)
  "Creates a new rule who has rule1 and rule2 as a parent by inserting
  subsequences of rule2 into rule1. Extra insertions decided by coin-flip."
  (let* ((new-dna (random-subsequence rule2))
         (start-pos (random (length rule1)))
         (end-pos (+ (random (- (length rule1) start-pos))
                     1 start-pos)))
    (splice rule1 new-dna start-pos end-pos)))
 
 
(defmacro breed-rules (rule1 rule2)
  "Destructively breed genes from rule2 into rule1."
  `(when (not (or (null ,rule1) (null ,rule2)))
     (setf ,rule1 
           (if (coin-flip)
               (random-merge-rules ,rule1 ,rule2)))))
;               (random-breed ,rule1 ,rule2)))))
 
 
(defun run-generation (rule-fun fitness-fun)
  "Runs a single generation, and update critters in place instead of keeping
  the n best."
  (dotimes (rulenum (length *CURRENT-POPULATION*))
    (let* ((cur-rule (aref *CURRENT-POPULATION* rulenum))
           (rules-score (funcall fitness-fun cur-rule))
           (rule-variation (copy-list cur-rule)))
      (if (> (random 6) 0)
          (mutate-rule-list rule-fun rule-variation)
          (breed-rules rule-variation
                       (copy-list (random-array-element *CURRENT-POPULATION*))))
      (when (> (length rule-variation) *MAX-RULE-SIZE*)
        (setf rule-variation (subseq rule-variation 0 *MAX-RULE-SIZE*)))
      (when (<= (funcall fitness-fun rule-variation)
                rules-score)
        (setf (aref *CURRENT-POPULATION* rulenum) rule-variation)))))
                                     
 
 
(defun genetic-algorithm (generations starting-rules rule-fun
                          fitness-fun &key (population-size 10))
  "Runs 'generations' number of generations. The rules are initially
  set to to 'starting-rules', the rule generating function is
  'rule-fun', and the evaluation function is 'fitness-fun'"
  (setf *CURRENT-POPULATION* (prep-population starting-rules population-size))
  (dotimes (gen-num generations)
    (format t "~A~%" gen-num)
    (run-generation rule-fun fitness-fun)))