;;; -*- Mode:Common-Lisp; Package:FOO; Base:10 -*-
;===========================
;;; Boolean Even-5-Parity Problem
(defvar d0)
(defvar d1)
(defvar d2)
(defvar d3)
(defvar d4)
(defvar arg0)
(defvar arg1)
(defvar arg2)
(defun nand (a b)
(not (and a b))
)
(defun nor (a b)
(not (or a b))
)
(defun define-terminal-set-for-EVEN-5-PARITY-ADF0 ()
(values '(arg0 arg1 arg2))
)
(defun define-function-set-for-EVEN-5-PARITY-ADF0 ()
(values '(and or nand nor)
'( 2 2 2 2)
)
)
(defun define-terminal-set-for-EVEN-5-PARITY-ADF1 ()
(values '(arg0 arg1 arg2))
)
(defun define-function-set-for-EVEN-5-PARITY-ADF1 ()
(values '(and or nand nor ADF0)
'( 2 2 2 2 3)
)
)
(defun define-terminal-set-for-EVEN-5-PARITY-RPB0 ()
(values '(d4 d3 d2 d1 d0))
)
(defun define-function-set-for-EVEN-5-PARITY-RPB0 ()
(values '(and or nand nor ADF0 ADF1)
'( 2 2 2 2 3 3)
)
)
(defvar *adf0*)
(defun adf0 (arg0 arg1 arg2)
(eval *adf0*)
)
(defvar *adf1*)
(defun adf1 (arg0 arg1 arg2)
(eval *adf1*)
)
(defstruct EVEN-5-PARITY-fitness-case
d0
d1
d2
d3
d4
target
)
;;; This definition may be superfluous in some Lisp
;;; implementations.
(defun xor (&rest args)
(let ((result nil))
(dolist (value args result)
(when value (setf result (not result)))
)
)
)
(defun define-fitness-cases-for-EVEN-5-PARITY ()
(let (fitness-case fitness-cases index)
(setf fitness-cases (make-array *number-of-fitness-cases*))
(format t "~%Fitness cases")
(setf index 0)
(dolist (d4 '(t nil))
(dolist (d3 '(t nil))
(dolist (d2 '(t nil))
(dolist (d1 '(t nil))
(dolist (d0 '(t nil))
(setf fitness-case
(make-EVEN-5-PARITY-fitness-case)
)
(setf (EVEN-5-PARITY-fitness-case-d0 fitness-case) d0)
(setf (EVEN-5-PARITY-fitness-case-d1 fitness-case) d1)
(setf (EVEN-5-PARITY-fitness-case-d2 fitness-case) d2)
(setf (EVEN-5-PARITY-fitness-case-d3 fitness-case) d3)
(setf (EVEN-5-PARITY-fitness-case-d4 fitness-case) d4)
(setf (EVEN-5-PARITY-fitness-case-target fitness-case)
(not (xor d4 d3 d2 d1 d0))
)
(setf (aref fitness-cases index) fitness-case)
(incf index)
(format t
"~% ~3D ~10S~10S~10S~10S~10S~15S"
index d4 d3 d2 d1 d0
(EVEN-5-PARITY-fitness-case-target
fitness-case
)
)
)
)
)
)
)
(values fitness-cases)
)
)
(defun EVEN-5-PARITY-wrapper (result-from-program)
(values result-from-program)
)
(defun evaluate-standardized-fitness-for-EVEN-5-PARITY
(program fitness-cases)
(let (raw-fitness hits standardized-fitness target-value
match-found value-from-program fitness-case rpb0
)
(setf raw-fitness 0.0)
(setf hits 0)
(setf rpb0 (ADF-program-RPB0 program))
(setf *adf0* (ADF-program-ADF0 program))
(setf *adf1* (ADF-program-ADF1 program))
(dotimes (index *number-of-fitness-cases*)
(setf fitness-case (aref fitness-cases index))
(setf d0 (EVEN-5-PARITY-fitness-case-d0 fitness-case))
(setf d1 (EVEN-5-PARITY-fitness-case-d1 fitness-case))
(setf d2 (EVEN-5-PARITY-fitness-case-d2 fitness-case))
(setf d3 (EVEN-5-PARITY-fitness-case-d3 fitness-case))
(setf d4 (EVEN-5-PARITY-fitness-case-d4 fitness-case))
(setf target-value
(EVEN-5-PARITY-fitness-case-target fitness-case))
(setf value-from-program
(EVEN-5-PARITY-wrapper (eval rpb0)))
(setf match-found (eq target-value value-from-program))
(incf raw-fitness (if match-found 1.0 0.0))
(when match-found (incf hits))
)
(setf standardized-fitness (- 32 raw-fitness))
(values standardized-fitness hits)
)
)
(defun define-parameters-for-EVEN-5-PARITY ()
(setf *number-of-fitness-cases* 32)
(setf *max-depth-for-new-individuals* 5)
(setf *max-depth-for-new-subtrees-in-mutants* 4)
(setf *max-depth-for-individuals-after-crossover* 17)
(setf *reproduction-fraction* 0.1)
(setf *crossover-at-any-point-fraction* 0.2)
(setf *crossover-at-function-point-fraction* 0.7)
(setf *method-of-selection* :tournament)
(setf *tournament-size* 7)
(setf *method-of-generation* :ramped-half-and-half)
(values)
)
(defun define-termination-criterion-for-EVEN-5-PARITY
(current-generation
maximum-generations
best-standardized-fitness
best-hits)
(declare (ignore best-standardized-fitness))
(values (or (>= current-generation maximum-generations)
(>= best-hits *number-of-fitness-cases*)
)
)
)
(defun EVEN-5-PARITY ()
(values 'define-function-set-for-EVEN-5-PARITY-ADF0
'define-function-set-for-EVEN-5-PARITY-ADF1
'define-function-set-for-EVEN-5-PARITY-RPB0
'define-terminal-set-for-EVEN-5-PARITY-ADF0
'define-terminal-set-for-EVEN-5-PARITY-ADF1
'define-terminal-set-for-EVEN-5-PARITY-RPB0
'define-fitness-cases-for-EVEN-5-PARITY
'evaluate-standardized-fitness-for-EVEN-5-PARITY
'define-parameters-for-EVEN-5-PARITY
'define-termination-criterion-for-EVEN-5-PARITY
)
)
;-----------------------------------------------------------------
;;; Tests.
(run-genetic-programming-system
'EVEN-5-PARITY 1.0 1 1
(make-ADF-program
:adf0 '(or (and arg0 arg1)
(and (nand arg0 arg0)
(nand arg1 arg1))) ;;; (EQV arg0 arg1)
:adf1 '(nand (or (and arg0 arg1)
(and (nand arg0 arg0) (nand arg1 arg1)))
(or (and arg0 arg1)
(and (nand arg0 arg0)
(nand arg1 arg1)))) ;;; (XOR arg0 arg1)
:rpb0 '(adf1 (adf0 (adf0 d0 d1 d0) (adf0 d2 d3 d0) d0)
d4 d0)))
;============================================================
;;; Kernel
(defstruct individual
program
(standardized-fitness 0)
(adjusted-fitness 0)
(normalized-fitness 0)
(hits 0))
;;; A data structure to represent the ADFs within a program.
;;; We supply a print method to map the internal
;;; representation into the usual progn/defun form.
;;; The print function has hard-wired into it the arglists
;;; of the ADFs. These would be parameterised in a more
;;; flexible implementation.
(defstruct
(adf-program
(:print-function
(lambda (instance stream depth)
(declare (ignore depth))
(format stream
"(progn (defun ADF0 (ARG0 ARG1 ARG2)~
~% (values ~S))~
~% (defun ADF0 (ARG0 ARG1 ARG2)~
~% (values ~S))~
~% (values ~S))"
(adf-program-adf0 instance)
(adf-program-adf1 instance)
(adf-program-rpb0 instance)))))
adf0
adf1
rpb0)
(defvar *number-of-fitness-cases* :unbound
"The number of fitness cases")
(defvar *max-depth-for-new-individuals* :unbound
"The maximum depth for individuals of the initial
random generation")
(defvar *max-depth-for-individuals-after-crossover* :unbound
"The maximum depth of new individuals created by crossover")
(defvar *reproduction-fraction* :unbound
"The fraction of the population that will experience fitness
proportionate reproduction (with reselection)
during each generation")
(defvar *crossover-at-any-point-fraction* :unbound
"The fraction of the population that will experience
crossover at any point in the tree (including terminals)
during each generation")
(defvar *crossover-at-function-point-fraction* :unbound
"The fraction of the population that will experience
crossover at a function (internal) point in the tree
during each generation.")
(defvar *max-depth-for-new-subtrees-in-mutants* :unbound
"The maximum depth of new subtrees created by mutation")
(defvar *method-of-selection* :unbound
"The method of selecting individuals in the population.
Either :fitness-proportionate, :tournament or
:fitness-proportionate-with-over-selection.")
(defvar *tournament-size* :unbound
"The group size to use when doing tournament selection.")
(defvar *method-of-generation* :unbound
"Can be any one of :grow, :full, :ramped-half-and-half")
(defvar *seed* :unbound
"The seed for the Park-Miller congruential randomizer.")
(defvar *best-of-run-individual* :unbound
"The best individual found during this run.")
(defvar *generation-of-best-of-run-individual* :unbound
"The generation at which the best-of-run individual was found.")
(defun run-genetic-programming-system
(problem-function
seed
maximum-generations
size-of-population
&rest seeded-programs)
;; Check validity of some arguments
(assert (and (integerp maximum-generations)
(not (minusp maximum-generations)))
(maximum-generations)
"Maximum-generations must be a non-negative ~
integer, not ~S" maximum-generations)
(assert (and (integerp size-of-population)
(plusp size-of-population))
(size-of-population)
"Size-Of-Population must be a positive integer, ~
not ~S" size-of-population)
(assert (or (and (symbolp problem-function)
(fboundp problem-function))
(functionp problem-function))
(problem-function)
"Problem-Function must be a function.")
(assert (numberp seed) (seed)
"The randomizer seed must be a number")
;; Set the global randomizer seed.
(setf *seed* (coerce seed 'double-float))
;; Initialize best-of-run recording variables
(setf *generation-of-best-of-run-individual* 0)
(setf *best-of-run-individual* nil)
;; Get the problem-specific functions needed to
;; specify this problem as returned by a call to
;; problem-function
(multiple-value-bind (adf0-function-set-creator
adf1-function-set-creator
rpb0-function-set-creator
adf0-terminal-set-creator
adf1-terminal-set-creator
rpb0-terminal-set-creator
fitness-cases-creator
fitness-function
parameter-definer
termination-predicate)
(funcall problem-function)
;; Get the function sets and associated
;; argument maps
(multiple-value-bind (adf0-function-set adf0-argument-map)
(funcall adf0-function-set-creator)
(multiple-value-bind (adf1-function-set adf1-argument-map)
(funcall adf1-function-set-creator)
(multiple-value-bind (rpb0-function-set rpb0-argument-map)
(funcall rpb0-function-set-creator)
;; Set up the parameters using parameter-definer
(funcall parameter-definer)
;; Print out parameters report
(describe-parameters-for-run
maximum-generations size-of-population)
;; Set up the terminal-set using terminal-set-creator
(let ((adf0-terminal-set
(funcall adf0-terminal-set-creator))
(adf1-terminal-set
(funcall adf1-terminal-set-creator))
(rpb0-terminal-set
(funcall rpb0-terminal-set-creator)))
;; Create the population
(let ((population
(create-population
size-of-population
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-terminal-set
seeded-programs)))
;; Define the fitness cases using the
;; fitness-cases-creator function
(let ((fitness-cases
(funcall fitness-cases-creator))
;; New-Programs is used in the breeding of the
;; new population. Create it here to reduce
;; consing.
(new-programs
(make-array size-of-population)))
;; Now run the Genetic Programming Paradigm using
;; the fitness-function and termination-predicate provided
(execute-generations
population new-programs fitness-cases
maximum-generations fitness-function
termination-predicate
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-terminal-set)
;; Finally print out a report
(report-on-run)
;; Return the population and fitness cases
;; (for debugging)
(values population fitness-cases)))))))))
(defun report-on-run ()
"Prints out the best-of-run individual."
(let ((*print-pretty* t))
(format t "~5%The best-of-run individual program ~
for this run was found on ~%generation ~D and had ~
a standardized fitness measure ~
of ~D and ~D hit~P. ~%It was:~%~S"
*generation-of-best-of-run-individual*
(individual-standardized-fitness
*best-of-run-individual*)
(individual-hits *best-of-run-individual*)
(individual-hits *best-of-run-individual*)
(individual-program *best-of-run-individual*))))
(defun report-on-generation (generation-number population)
"Prints out the best individual at the end of each generation"
(let ((best-individual (aref population 0))
(size-of-population (length population))
(sum 0.0)
(*print-pretty* t))
;; Add up all of the standardized fitnesses to get average
(dotimes (index size-of-population)
(incf sum (individual-standardized-fitness
(aref population index))))
(format t "~2%Generation ~D: Average standardized-fitness ~
= ~S. ~%~
The best individual program of the population ~
had a ~%standardized fitness measure of ~D ~
and ~D hit~P. ~%It was: ~%~S"
generation-number (/ sum (length population))
(individual-standardized-fitness best-individual)
(individual-hits best-individual)
(individual-hits best-individual)
(individual-program best-individual))))
(defun print-population (population)
"Given a population, this prints it out (for debugging) "
(let ((*print-pretty* t))
(dotimes (index (length population))
(let ((individual (aref population index)))
(format t "~&~D ~S ~S"
index
(individual-standardized-fitness individual)
(individual-program individual))))))
(defun describe-parameters-for-run
(maximum-generations size-of-population)
"Lists the parameter settings for this run."
(format t "~2%Parameters used for this run.~
~%=============================")
(format t "~%Maximum number of Generations:~50T~D"
maximum-generations)
(format t "~%Size of Population:~50T~D" size-of-population)
(format t "~%Maximum depth of new individuals:~50T~D"
*max-depth-for-new-individuals*)
(format t "~%Maximum depth of new subtrees for mutants:~50T~D"
*max-depth-for-new-subtrees-in-mutants*)
(format t
"~%Maximum depth of individuals after crossover:~50T~D"
*max-depth-for-individuals-after-crossover*)
(format t "~%Reproduction fraction:~50T~D"
*reproduction-fraction*)
(format t "~%Crossover at any point fraction:~50T~D"
*crossover-at-any-point-fraction*)
(format t "~%Crossover at function points fraction:~50T~D"
*crossover-at-function-point-fraction*)
(format t "~%Number of fitness cases:~50T~D"
*number-of-fitness-cases*)
(format t "~%Selection method: ~50T~A" *method-of-selection*)
(format t "~%Tournament group size: ~50T~A" *tournament-size*)
(format t "~%Generation method: ~50T~A" *method-of-generation*)
(format t "~%Randomizer seed: ~50T~D" *seed*))
(defvar *generation-0-uniquifier-table*
(make-hash-table :test #'equal)
"Used to guarantee that all generation 0 individuals
are unique")
(defun create-program-branch
(function-set argument-map terminal-set
minimum-depth-of-trees maximum-depth-of-trees
individual-index full-cycle-p)
"Creates a complete branch for an ADF-containing program."
(create-individual-subtree
function-set argument-map
terminal-set
(ecase *method-of-generation*
((:full :grow) maximum-depth-of-trees)
(:ramped-half-and-half
(+ minimum-depth-of-trees
(mod individual-index
(- maximum-depth-of-trees
minimum-depth-of-trees)))))
t
(ecase *method-of-generation*
(:full t)
(:grow nil)
(:ramped-half-and-half full-cycle-p))))
(defun create-new-program (individual-index full-cycle-p
minimum-depth-of-trees
maximum-depth-of-trees
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-terminal-set)
"Creates a new individual with ADF structure."
(make-adf-program
:adf0
(create-program-branch
adf0-function-set adf0-argument-map
adf0-terminal-set minimum-depth-of-trees
maximum-depth-of-trees individual-index full-cycle-p)
:adf1
(create-program-branch
adf1-function-set adf1-argument-map
adf1-terminal-set minimum-depth-of-trees
maximum-depth-of-trees individual-index full-cycle-p)
:rpb0
(create-program-branch
rpb0-function-set rpb0-argument-map
rpb0-terminal-set minimum-depth-of-trees
maximum-depth-of-trees individual-index full-cycle-p)))
(defun create-population (size-of-population
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-terminal-set
seeded-programs)
"Creates the population. This is an array of size
size-of-population that is initialized to contain individual
records. The Program slot of each individual is initialized
to a suitable random program except for the first N programs,
where N = (length seeded-programs). For these first N
individuals the individual is initialized with the respective
seeded program. This is very useful in debugging."
(let ((population (make-array size-of-population))
(minimum-depth-of-trees 1)
(attempts-at-this-individual 0)
(full-cycle-p nil))
(do ((individual-index 0))
((>= individual-index size-of-population))
(when (zerop (mod individual-index
(max 1 (- *max-depth-for-new-individuals*
minimum-depth-of-trees))))
(setf full-cycle-p (not full-cycle-p)))
(let ((new-program
(if (< individual-index (length seeded-programs))
;; Pick a seeded individual
(nth individual-index seeded-programs)
;; Create a new random program.
(create-new-program
individual-index full-cycle-p
minimum-depth-of-trees
;; We count one level of depth for the
;; root above all of the branches that
;; get evolved.
(- *max-depth-for-new-individuals* 1)
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-terminal-set))))
;; Check if we have already created this program.
;; If not then store it and move on.
;; If we have then try again.
(let ((program-as-list
(list (adf-program-adf0 new-program)
(adf-program-adf1 new-program)
(adf-program-rpb0 new-program))))
;; Turn the defstruct representation of the
;; program into a list so that it can be
;; compared using an EQUAL hash table.
;; defstruct instances have to be compared with EQUALP
(cond ((< individual-index (length seeded-programs))
(setf (aref population individual-index)
(make-individual :program new-program))
(incf individual-index))
((not (gethash program-as-list
*generation-0-uniquifier-table*))
(setf (aref population individual-index)
(make-individual :program new-program))
(setf (gethash program-as-list
*generation-0-uniquifier-table*)
t)
(setf attempts-at-this-individual 0)
(incf individual-index))
((> attempts-at-this-individual 20)
;; Then this depth has probably filled up, so
;; bump the depth counter.
(incf minimum-depth-of-trees)
;; Bump the max depth too to keep in line with
;; new minimum.
(setf *max-depth-for-new-individuals*
(max *max-depth-for-new-individuals*
minimum-depth-of-trees)))
(:otherwise
(incf attempts-at-this-individual))))))
;; Flush out uniquifier table to that no pointers
;; are kept to generation 0 individuals.
(clrhash *generation-0-uniquifier-table*)
;; Return the population that we've just created.
population))
(defun choose-from-terminal-set (terminal-set)
"Chooses a random terminal from the terminal set.
If the terminal chosen is the ephemeral
:Floating-Point-Random-Constant,
then a floating-point single precision random constant
is created in the range -5.0->5.0.
If :Integer-Random-Constant is chosen then an integer random
constant is generated in the range -10 to +10."
(let ((choice (nth (random-integer (length terminal-set))
terminal-set)))
(case choice
(:floating-point-random-constant
;; pick a random number in the range -5.0 ---> +5.0.
;; Coerce it to be single precision floating-point.
;; Double precision is more expensive
;; A similar clause to this could be used to coerce it
;; to double prevision if you really need
;; double precision.
;; This is also the place to modify if you need a range
;; other than -5.0 ---> +5.0.
(coerce (- (random-floating-point-number 10.0) 5.0)
'single-float))
(:integer-random-constant
;; pick a random integer in the range -10 ---> +10.
(- (random-integer 21) 10))
(otherwise choice))))
(defun create-individual-subtree
(function-set argument-map terminal-set
allowable-depth top-node-p full-p)
"Creates a subtree 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-subtree."
(if (= number-of-arguments 0)
nil
(cons (create-individual-subtree
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
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-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
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-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 breed-new-population
(population new-programs
adf0-function-set adf0-argument-map adf0-terminal-set
adf1-function-set adf1-argument-map adf1-terminal-set
rpb0-function-set rpb0-argument-map rpb0-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
(+ *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
adf0-function-set adf0-argument-map
adf0-terminal-set
adf1-function-set adf1-argument-map
adf1-terminal-set
rpb0-function-set rpb0-argument-map
rpb0-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 pick-k-random-individual-indices (k max)
"Returns a list of K random numbers between 0 and (- max 1)."
(let ((numbers nil))
(loop for number = (random-integer max)
unless (member number numbers :test #'eql)
do (push number numbers)
until (= (length numbers) k))
numbers))
(defun find-individual-using-tournament-selection (population)
"Picks *tournament-size* individuals from the population at
random and returns the best one."
(let ((numbers (pick-k-random-individual-indices
*tournament-size* (length population))))
(loop with best = (aref population (first numbers))
with best-fitness
= (individual-standardized-fitness best)
for number in (rest numbers)
for individual = (aref population number)
for this-fitness
= (individual-standardized-fitness individual)
when (< this-fitness best-fitness)
do (setf best individual)
(setf best-fitness this-fitness)
finally (return (individual-program best)))))
(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 select-branch (within-program)
"Returns two values:
- A keyword in {:ADF0, :ADF1, :RPB0} to denote a
branch selected at random. The selection of the
branch is biased according to the number of
points in that branch.
- The subtree for the branch selected."
(let ((adf0 (adf-program-adf0 within-program))
(adf1 (adf-program-adf1 within-program))
(rpb0 (adf-program-rpb0 within-program)))
(let ((adf0-points (count-crossover-points adf0))
(adf1-points (count-crossover-points adf1))
(rpb0-points (count-crossover-points rpb0)))
(let ((selected-point
(random-integer
(+ adf0-points adf1-points rpb0-points))))
(cond ((< selected-point adf0-points) (values :adf0 adf0))
((< selected-point (+ adf1-points adf0-points))
(values :adf1 adf1))
(t (values :rpb0 rpb0)))))))
(defun adf-program-branch (branch program)
"Returns a branch from Program selected by the keyword Branch."
(ecase branch
(:adf0 (adf-program-adf0 program))
(:adf1 (adf-program-adf1 program))
(:rpb0 (adf-program-rpb0 program))))
(defun copy-individual-substituting-branch
(branch new-branch-subtree program-to-copy)
"Makes a copy of Program-To-Copy only substituting
the branch selected by Branch with the new branch
subtree created by crossover."
(make-adf-program
:adf0 (if (eq :adf0 branch)
new-branch-subtree
(copy-tree (adf-program-adf0 program-to-copy)))
:adf1 (if (eq :adf1 branch)
new-branch-subtree
(copy-tree (adf-program-adf1 program-to-copy)))
:rpb0 (if (eq :rpb0 branch)
new-branch-subtree
(copy-tree (adf-program-rpb0 program-to-copy)))))
(defun crossover-selecting-branch
(how-to-crossover-function male female)
"Performs crossover on the programs Male and Female by calling
the function How-To-Crossover-Function, which will cause it
to perform crossover at either function points or at any point.
The crossover happens between a compatible pair of branches
in the two parents.
Once the crossover has happened the function returns two new
individuals to insert into the next generation."
(let ((branch (select-branch male)))
(multiple-value-bind (new-male-branch new-female-branch)
(funcall how-to-crossover-function
(adf-program-branch branch male)
(adf-program-branch branch female))
(values (copy-individual-substituting-branch
branch new-male-branch male)
(copy-individual-substituting-branch
branch new-female-branch female)))))
(defun crossover-at-any-points (male female)
"Performs crossover on the programs at any point
in the trees."
(crossover-selecting-branch
#'crossover-at-any-points-within-branch male female))
(defun crossover-at-any-points-within-branch (male female)
"Performs crossover on the program branches at any point
in the subtrees."
;; 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)))
(new-female (list (copy-tree female))))
;; Get the pointers to the subtrees indexed by male-point
;; and female-point
(multiple-value-bind (male-subtree-pointer male-fragment)
(get-subtree (first new-male) new-male male-point)
(multiple-value-bind
(female-subtree-pointer female-fragment)
(get-subtree
(first new-female) new-female female-point)
;; Modify the new individuals by smashing in the
;; (copied) subtree from the old individual.
(setf (first male-subtree-pointer) female-fragment)
(setf (first female-subtree-pointer) male-fragment)))
;; Make sure that the new individuals aren't too big.
(validate-crossover male new-male female new-female))))
(defun count-crossover-points (program)
"Counts the number of points in the tree (program).
This includes functions as well as terminals."
(if (consp program)
(+ 1 (reduce #'+ (mapcar #'count-crossover-points
(rest program))))
1))
(defun max-depth-of-tree (tree)
"Returns the depth of the deepest branch of the
tree (program)."
(if (consp tree)
(+ 1 (if (rest tree)
(apply #'max
(mapcar #'max-depth-of-tree (rest tree)))
0))
1))
(defun get-subtree (tree pointer-to-tree index)
"Given a tree or subtree, a pointer to that tree/subtree and
an index return the component subtree that is numbered by
Index. We number left to right, depth first."
(if (= index 0)
(values pointer-to-tree (copy-tree tree) index)
(if (consp tree)
(do* ((tail (rest tree) (rest tail))
(argument (first tail) (first tail)))
((not tail) (values nil nil index))
(multiple-value-bind
(new-pointer new-tree new-index)
(get-subtree argument tail (- index 1))
(if (= new-index 0)
(return
(values new-pointer new-tree new-index))
(setf index new-index))))
(values nil nil index))))
(defun validate-crossover (male new-male female new-female)
"Given the old and new males and females from a crossover
operation check to see whether we have exceeded the maximum
allowed depth. If either of the new individuals has exceeded
the maxdepth then the old individual is used."
(let ((male-depth (max-depth-of-tree (first new-male)))
(female-depth (max-depth-of-tree (first new-female))))
(values
(if (or (= 1 male-depth)
(>= male-depth ;; >= counts 1 depth for root above
;; branches.
*max-depth-for-individuals-after-crossover*))
male
(first new-male))
(if (or (= 1 female-depth)
(>= female-depth
*max-depth-for-individuals-after-crossover*))
female
(first new-female)))))
(defun crossover-at-function-points (male female)
"Performs crossover on the two programs at a function
(internal) point in a randomly selected branch of the trees."
(crossover-selecting-branch
#'crossover-at-function-points-within-branch male female))
(defun crossover-at-function-points-within-branch (male female)
"Performs crossover on the two program branches at a function
(internal) point in the trees."
;; Pick the function (internal) points in the respective trees
;; on which to perform the crossover.
(let ((male-point
(random-integer (count-function-points male)))
(female-point
(random-integer (count-function-points female))))
;; Copy the trees because we destructively modify the new
;; individuals to do the crossover and 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)))
(new-female (list (copy-tree female))))
;; Get the pointers to the subtrees indexed by male-point
;; and female-point
(multiple-value-bind (male-subtree-pointer male-fragment)
(get-function-subtree
(first new-male) new-male male-point)
(multiple-value-bind
(female-subtree-pointer female-fragment)
(get-function-subtree
(first new-female) new-female female-point)
;; Modify the new individuals by smashing in
;; the (copied) subtree from the old individual.
(setf (first male-subtree-pointer) female-fragment)
(setf (first female-subtree-pointer) male-fragment)))
;; Make sure that the new individuals aren't too big.
(validate-crossover male new-male female new-female))))
(defun count-function-points (program)
"Counts the number of function (internal) points
in the program."
(if (consp program)
(+ 1 (reduce #'+ (mapcar #'count-function-points
(rest program))))
0))
(defun get-function-subtree (tree pointer-to-tree index)
"Given a tree or subtree, a pointer to that tree/subtree and
an index return the component subtree that is labeled with
an internal point that is numbered by Index. We number left
to right, depth first."
(if (= index 0)
(values pointer-to-tree (copy-tree tree) index)
(if (consp tree)
(do* ((tail (rest tree) (rest tail))
(argument (first tail) (first tail)))
((not tail) (values nil nil index))
(multiple-value-bind
(new-pointer new-tree new-index)
(if (consp argument)
(get-function-subtree
argument tail (- index 1))
(values nil nil index))
(if (= new-index 0)
(return
(values new-pointer new-tree new-index))
(setf index new-index))))
(values nil nil index))))
(defun mutate
(program
adf0-function-set adf0-argument-map adf0-terminal-set
adf1-function-set adf1-argument-map adf1-terminal-set
rpb0-function-set rpb0-argument-map rpb0-terminal-set)
"Mutates the argument program by picking a random point in
the tree and substituting in a brand new subtree created in
the same way that we create the initial random population."
;; Pick the mutation point.
(multiple-value-bind (branch branch-tree)
(select-branch program)
(let ((mutation-point
(random-integer (count-crossover-points branch-tree)))
;; Create a brand new subtree.
(new-subtree
(create-individual-subtree
(case branch
(:adf0 adf0-function-set)
(:adf1 adf1-function-set)
(:rpb0 rpb0-function-set))
(case branch
(:adf0 adf0-argument-map)
(:adf1 adf1-argument-map)
(:rpb0 rpb0-argument-map))
(case branch
(:adf0 adf0-terminal-set)
(:adf1 adf1-terminal-set)
(:rpb0 rpb0-terminal-set))
*max-depth-for-new-subtrees-in-mutants* t nil)))
(let ((new-branch (list (copy-tree branch-tree))))
(multiple-value-bind (subtree-pointer fragment)
;; Get the pointer to the mutation point.
(get-subtree (first new-branch)
new-branch mutation-point)
;; Not interested in what we're snipping out.
(declare (ignore fragment))
;; Smash in the new subtree.
(setf (first subtree-pointer) new-subtree))
(values (copy-individual-substituting-branch
branch (first new-branch) program)
new-subtree)))))
(defun park-miller-randomizer ()
"The Park-Miller multiplicative congruential randomizer
(CACM, October 88, Page 1195). Creates pseudo random floating
point numbers in the range 0.0 < x <= 1.0. The seed value
for this randomizer is called *seed*, so you should
record/set this if you want to make your runs reproducible."
(assert (not (zerop *seed*)) () "*seed* cannot be zero.")
(let ((multiplier 16807.0d0);16807 is (expt 7 5)
(modulus 2147483647.0d0))
;2147483647 is (- (expt 2 31) 1)
(let ((temp (* multiplier *seed*)))
(setf *seed* (mod temp modulus))
;;Produces floating-point number in the range
;; 0.0 < x <= 1.0
(/ *seed* modulus))))
(defun random-floating-point-number (n)
"Returns a pseudo random floating-point number
in range 0.0 <= number < n"
(let ((random-number (park-miller-randomizer)))
;; We subtract the randomly generated number from 1.0
;; before scaling so that we end up in the range
;; 0.0 <= x < 1.0, not 0.0 < x <= 1.0
(* n (- 1.0d0 random-number))))
(defun random-integer (n)
"Returns a pseudo-random integer in the range 0 ---> n-1."
(let ((random-number (random-floating-point-number 1.0)))
(floor (* n random-number))))
;;------------------
;; The programs, procedures, and applications presented in this book have been tested with care. Neither the publisher nor the author offer any warranties of fitness or merchantability for any particular purpose or accept any liability with respect to these programs, procedures, and applications. U.S. patent number 4,935,877 and patents pending.
;; The programs, procedures, and applications presented in this book have been included for their instructional value. The publisher and author offer NO WARRANTY OF FITNESS OR MERCHANTABILITY FOR ANY PARTICULAR PURPOSE or accept any liability with respect to these programs, procedures, and applications.