curve fitting.lisp

this code sole curve fitting using genetic programming

            allowable-depth top-node-p full-p)
  "Creates a program recursively using the specified functions
   and terminals.  Argument map is used to determine how many
   arguments each function in the function set is supposed to
   have if it is selected.  Allowable depth is the remaining
   depth of the tree we can create, when we hit zero we will
   only select terminals.  Top-node-p is true only when we
   are being called as the top node in the tree.  This allows
   us to make sure that we always put a function at the top
   of the tree.  Full-p indicates whether this individual
   is to be maximally bushy or not."
  (cond ((<= allowable-depth 0)
         ;; We've reached maxdepth, so just pack a terminal.
         (choose-from-terminal-set terminal-set))
        ((or full-p top-node-p)
         ;; We are the top node or are a full tree,
         ;; so pick only a function.
         (let ((choice (random-integer (length function-set))))
           (let ((function (nth choice function-set))
                 (number-of-arguments
                   (nth choice argument-map)))
             (cons function
                   (create-arguments-for-function
                     number-of-arguments function-set
                     argument-map terminal-set
                     (- allowable-depth 1) full-p)))))
        (:otherwise
         ;; choose one from the bag of functions and terminals.
         (let ((choice (random-integer
                         (+ (length terminal-set)
                            (length function-set)))))
           (if (< choice (length function-set))
               ;; We chose a function, so pick it out and go
               ;; on creating the tree down from here.
               (let ((function (nth choice function-set))
                     (number-of-arguments
                       (nth choice argument-map)))
                 (cons function
                       (create-arguments-for-function
                         number-of-arguments function-set
                         argument-map terminal-set
                         (- allowable-depth 1) full-p)))
               ;; We chose an atom, so pick it out.
               (choose-from-terminal-set terminal-set))))))

(defun create-arguments-for-function
           (number-of-arguments function-set
            argument-map terminal-set allowable-depth
            full-p)
  "Creates the argument list for a node in the tree.  
   Number-Of-Arguments is the number of arguments still
   remaining to be created.  Each argument is created
   in the normal way using Create-Individual-Program."
  (if (= number-of-arguments 0)
      nil
      (cons (create-individual-program
              function-set argument-map terminal-set
              allowable-depth nil full-p)
            (create-arguments-for-function
              (- number-of-arguments 1) function-set
              argument-map terminal-set
              allowable-depth full-p))))

(defun execute-generations
    (population new-programs fitness-cases maximum-generations
     fitness-function termination-predicate function-set
     argument-map terminal-set)
  "Loops until the user's termination predicate says to stop."
  (do ((current-generation 0 (+ 1 current-generation)))
      ;; loop incrementing current generation until
      ;; termination-predicate succeeds.
      ((let ((best-of-generation (aref population 0)))
         (funcall
           termination-predicate current-generation
           maximum-generations
           (individual-standardized-fitness best-of-generation)
           (individual-hits best-of-generation))))
    (when (> current-generation 0)
      ;; Breed the new population to use on this generation
      ;; (except gen 0, of course).
      (breed-new-population population new-programs function-set
                            argument-map terminal-set))
    ;; Clean out the fitness measures.
    (zeroize-fitness-measures-of-population population)
    ;; Measure the fitness of each individual.  Fitness values
    ;; are stored in the individuals themselves.
    (evaluate-fitness-of-population
      population fitness-cases fitness-function)
    ;; Normalize fitness in preparation for crossover, etc.
    (normalize-fitness-of-population population)
    ;; Sort the population so that the roulette wheel is easy.
    (sort-population-by-fitness population)
    ;; Keep track of best-of-run individual
    (let ((best-of-generation (aref population 0)))
      (when (or (not *best-of-run-individual*)
                (> (individual-standardized-fitness *best-of-run-individual*)
                   (individual-standardized-fitness best-of-generation)))
        (setf *best-of-run-individual* (copy-individual best-of-generation))
        (setf *generation-of-best-of-run-individual* current-generation)))
    ;; Print out the results for this generation.
    (report-on-generation current-generation population)))

(defun zeroize-fitness-measures-of-population (population)
  "Clean out the statistics in each individual in the
   population.  This is not strictly necessary, but it helps to
   avoid confusion that might be caused if, for some reason, we
   land in the debugger and there are fitness values associated 
   with the individual records that actually matched the program 
   that used to occupy this individual record."
  (dotimes (individual-index (length population))
    (let ((individual (aref population individual-index)))
      (setf (individual-standardized-fitness individual) 0.0)
      (setf (individual-adjusted-fitness individual) 0.0)
      (setf (individual-normalized-fitness individual) 0.0)
      (setf (individual-hits individual) 0))))

(defun evaluate-fitness-of-population (population fitness-cases
                                       fitness-function)
  "Loops over the individuals in the population evaluating and
   recording the fitness and hits."
  (dotimes (individual-index (length population))
    (let ((individual (aref population individual-index)))
      (multiple-value-bind (standardized-fitness hits)
          (funcall fitness-function
                   (individual-program individual)
                   fitness-cases)
        ;; Record fitness and hits for this individual.
        (setf (individual-standardized-fitness individual)
              standardized-fitness)
        (setf (individual-hits individual) hits)))))

(defun normalize-fitness-of-population (population)
  "Computes the normalized and adjusted fitness of each
   individual in the population."
  (let ((sum-of-adjusted-fitnesses 0.0))
    (dotimes (individual-index (length population))
      (let ((individual (aref population individual-index)))
        ;; Set the adjusted fitness.
        (setf (individual-adjusted-fitness individual)
              (/ 1.0 (+ 1.0 (individual-standardized-fitness
                              individual))))
        ;; Add up the adjusted fitnesses so that we can
        ;; normalize them.
        (incf sum-of-adjusted-fitnesses
              (individual-adjusted-fitness individual))))
    ;; Loop through population normalizing the adjusted fitness.
    (dotimes (individual-index (length population))
      (let ((individual (aref population individual-index)))
        (setf (individual-normalized-fitness individual)
              (/ (individual-adjusted-fitness individual)
                 sum-of-adjusted-fitnesses))))))

;;(defun sort-population-by-fitness (population)
;;  "Sorts the population according to normalized fitness. 
;;   The population array is destructively modified."
;;  (sort population #'> :key #'individual-normalized-fitness))

(defun sort-population-by-fitness
    (population &optional (low 0) (high (length population)))
  "Uses a trivial quicksort to sort the population destructively
   into descending order of normalized fitness." 
 (unless (>= (+ low 1) high)
    (let ((pivot (individual-normalized-fitness (aref population low)))
          (index1 (+ low 1))
          (index2 (- high 1)))
      (loop (do () ((or (>= index1 high)
                        (<= (individual-normalized-fitness
                             (aref population index1)) pivot)))
              (incf index1))
            (do () ((or (>= low index2)
                        (>= (individual-normalized-fitness
                             (aref population index2)) pivot)))
              (decf index2))
            (when (>= index1 index2) (return nil))
            (rotatef (aref population index1) (aref population index2))
            (decf index2))
      (rotatef (aref population low) (aref population (- index1 1)))
      (sort-population-by-fitness population low index1)
      (sort-population-by-fitness population index1 high)))
  population)

(defun breed-new-population
      (population new-programs function-set
       argument-map terminal-set)
  "Controls the actual breeding of the new population.  
   Loops through the population executing each operation
   (e.g., crossover, fitness-proportionate reproduction,
   mutation) until it has reached the specified fraction.  
   The new programs that are created are stashed in new-programs
   until we have exhausted the population, then we copy the new
   individuals into the old ones, thus avoiding consing a new
   bunch of individuals."
  (let ((population-size (length population)))
    (do ((index 0)
         (fraction 0 (/ index population-size)))
        ((>= index population-size))
      (let ((individual-1
              (find-individual population)))
        (cond ((and (< index (- population-size 1))
                    (< fraction
                       (+ *crossover-at-function-point-fraction*
                          *crossover-at-any-point-fraction*)))
               (multiple-value-bind (new-male new-female)
                 (funcall
                  (if (< fraction
                         *crossover-at-function-point-fraction*)
                      'crossover-at-function-points
                      'crossover-at-any-points)
                  individual-1
                  (find-individual population))
                 (setf (aref new-programs index) new-male)
                 (setf (aref new-programs (+ 1 index))
                       new-female))
               (incf index 2))
              ((< fraction
                (+ *fitness-proportionate-reproduction-fraction*
                   *crossover-at-function-point-fraction*
                   *crossover-at-any-point-fraction*))
               (setf (aref new-programs index) individual-1)
               (incf index 1))
              (:otherwise
	       (setf (aref new-programs index)
		     (mutate individual-1 function-set
			     argument-map terminal-set))
	       (incf index 1)))))
    (dotimes (index population-size)
      (setf (individual-program (aref population index))
            (aref new-programs index)))))

(defun find-individual (population)
  "Finds an individual in the population according to the
   defined selection method."
  (ecase *method-of-selection*
    (:tournament (find-individual-using-tournament-selection
                   population))
    (:fitness-proportionate-with-over-selection
      (find-fitness-proportionate-individual
        (random-floating-point-number-with-over-selection
          population)
        population))
    (:fitness-proportionate
      (find-fitness-proportionate-individual
        (random-floating-point-number 1.0) population))))

(defun random-floating-point-number-with-over-selection (population)
  "Picks a random number between 0.0 and 1.0 biased using the
   over-selection method."
  (let ((pop-size (length population)))
    (when (< pop-size 1000)
      (error "A population size of ~D is too small ~
              for over-selection." pop-size))
    (let ((boundary (/ 320.0 pop-size)))
      ;; The boundary between the over and under selected parts.
      (if (< (random-floating-point-number 1.0) 0.8)
          ;; 80% are in the over-selected part
          (random-floating-point-number boundary)
          (+ boundary
	     (random-floating-point-number (- 1.0 boundary)))))))

(defun find-individual-using-tournament-selection (population)
  "Picks two individuals from the population at random and
   returns the better one."
  (let ((individual-a
          (aref population 
                (random-integer (length population))))
        (individual-b
          (aref population 
                (random-integer (length population)))))
    (if (< (individual-standardized-fitness individual-a)
           (individual-standardized-fitness individual-b))
        (individual-program individual-a)
        (individual-program individual-b))))

(defun find-fitness-proportionate-individual
    (after-this-fitness population)
  "Finds an individual in the specified population whose
   normalized fitness is greater than the specified value.
   All we need to do is count along the population from the
   beginning adding up the fitness until we get past the
   specified point."
  (let ((sum-of-fitness 0.0)
        (population-size (length population)))
    (let ((index-of-selected-individual
            (do ((index 0 (+ index 1)))
                ;; Exit condition
                ((or (>= index population-size)
                     (>= sum-of-fitness after-this-fitness))
                 (if (>= index population-size)
                     (- (length population) 1)
                     (- index 1)))
              ;; Body.  Sum up the fitness values.
              (incf sum-of-fitness
                    (individual-normalized-fitness
                      (aref population index))))))
      (individual-program
        (aref population index-of-selected-individual)))))

(defun crossover-at-any-points (male female)
  "Performs crossover on the programs at any point
   in the trees."
  ;; Pick points in the respective trees 
  ;; on which to perform the crossover.
  (let ((male-point
          (random-integer (count-crossover-points male)))
        (female-point
          (random-integer (count-crossover-points female))))
    ;; First, copy the trees because we destructively modify the
    ;; new individuals to do the crossover.  Reselection is
    ;; allowed in the original population.  Not copying would
    ;; cause the individuals in the old population to
    ;; be modified.
    (let ((new-male   (list (copy-tree male)))