Last updated October 13, 2003
Click here for additional Software for genetic programming, genetic algorithms, and other evolutionary computation techniques
---------------------------------------------------------------------------------------------
As you requested, I am including herewith, FOR YOUR INFORMATION AND
INSPECTION ONLY, a copy of my "SIMPLE LISP" software for genetic
programming. Please be advised that this software is copyrighted and
is the subject of my United States patents 4,935,877 5,136,686, and
5,148,513, foreign counterparts, and other patents pending.
IF YOU WISH TO USE THIS SOFTWARE, you may have a royalty-free,
non-exclusive license under these proprietary rights, without the
right of sublicense, to use (but not to make or sell) the software
for academic purposes only and only then if you receive no money
or other valuable consideration as a result of its use.
Neither the software (or copies thereof) nor this license is
transferable for any reason. This license grants you the right
to make copies of the software which are necessary for your use,
and your use only, provided each copy incorporates this license.
The programs, procedures, and applications presented in this software
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.
If you wish such a license under these terms, please indicate so
by signing and dating a copy of this notice and returning it to me
at John Koza, Box K, Los Altos, California 94023 USA.
I would like the above license and hereby agree to the terms set forth above.
LICENSEE:
NAME (Print) ____________________________
Signature _________________________________
Date _______________
PHYSICAL ADDRESS _______________________________
CITY, STATE, ZIP _______________________________
COUNTRY _____________________________
E-MAIL ADDRESS _______________________________________
PHONE ___________________________
;;;---------------------------------------------------------------------------------------------
;;; 1) The first component is the Kernel of the Genetic
;;; Programming implementation. This is the domain-independent
;;; code which can be used to execute a variety of different
;;; problems, three of which are provided.
;;; 2) The second component concerns optimizations for the evaluation
;;; of individuals. These include the function Fast-Eval, which
;;; can be used in your fitness functions to speed things up.
;;; Also shown are the "pseudo-macro"s shown in the book.
;;; The instalation of this form of optimization is not portable
;;; between different Common Lisp implementations.
;;; Source conditionalizations have been provided so that
;;; this code should work without alteration under:
;;; Texas Instruments Common Lisp version 6.1
;;; Macintosh Common LISP (Allegro/Coral) versions 1.3.2 and 2.0b1
;;; Lucid Common LISP version 4.0.x, 4.1
;;; Allegro Common LISP (Franz inc.) version 4.1
;;; If you are running under anything other than these you
;;; may be able to use one or other of the implementations
;;; (search for #+), but you may have to hack something new
;;; up for yourself. The example of the implementations
;;; provided should make life simpler.
;;; It is worth noting that the performance improvement that
;;; can result from the pseudo-macro mechanism is usually
;;; substantial and can sometimes be tenfold. Thus, if you are
;;; likely to be addressing any problems in which control of
;;; evaluation of arguments is necessary, particularly in problems
;;; that exhibit side-effects as a result of evaluating either
;;; the functions or the terminals in the function/terminal sets
;;; then is is very much worth your while to get this working
;;; on your own particular implementation.
;;; 3) The third component is the domain independent part of the
;;; program editing tool.
;;; 4) Is the definition of a set of rules for simplifying
;;; Boolean sexpressions.
;;; 5) Is the problem-specific code necessary to define and run
;;; the symbolic regression problem for 0.5x**2.
;;; 6) Is the code necessary to implement the Boolean 3-Majority-On
;;; problem
;;; 7) Is the code necessary to implement the Discrete Non-Hamstrung
;;; Squard Car problem.
;;; 8) Is a pair of test functions. Test-GPP will execute all of the
;;; example test sexpressions shown in the book, printing out the tests
;;; as they are performed. Time-Test-GPP runs test-GPP, sending the
;;; output from the tests to a log file, printing out the time taken
;;; at the end.
;;; 9) Commented out at the bottom you will find all of the forms
;;; provided in the book as examples of how to switch on the pseudo
;;; macro and fast-eval optimizations. If you want to use these
;;; you need only compile this section out of the editor or remove
;;; the #| and |# marks and recompile the file.
;;; Notes: When compiling you might get a warning about
;;; there being two definitions for the variable X
;;; and for the functions sort-population-by-fitness and
;;; define-function-set-for-MAJORITY-ON.
;;; This is intentional, so as to make the code below
;;; mirror the book as accurately as possible. Although
;;; these warnings will not in any way prevent the GPP
;;; from working, you may choose to remove the second
;;; definition of (defvar X) and also whichever of the
;;; definitions of sort-population-by-fitness you do not
;;; want. The default version of sort-population-by-fitness
;;; that you will get (i.e. the second) is the one which is
;;; likely to be most reproducible in behavior across
;;; platforms, but not necessarily the fastest. The first
;;; definition of define-function-set-for-MAJORITY-ON is
;;; the more common usage for Boolean problems with each
;;; function represented in the function set just once.
;;;---------------------------------------------------------------------------------------------
;;; Copyright (c) John Koza, All rights reserved.
;;; U.S. Patent #4,935,877. Other patents pending.
;;;---------------------------------------------------------------------------------------------
;;; Kernel
(defstruct individual
program
(standardized-fitness 0)
(adjusted-fitness 0)
(normalized-fitness 0)
(hits 0))
(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 *fitness-proportionate-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 *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 six problem-specific functions needed to
;; specify this problem as returned by a call to
;; problem-function
(multiple-value-bind (function-set-creator
terminal-set-creator
fitness-cases-creator
fitness-function
parameter-definer
termination-predicate)
(funcall problem-function)
;; Get the function set and its associated
;; argument map
(multiple-value-bind (function-set argument-map)
(funcall 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 ((terminal-set (funcall terminal-set-creator)))
;; Create the population
(let ((population
(create-population
size-of-population function-set argument-map
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 function-set
argument-map 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
"~%Fitness-proportionate reproduction fraction:~50T~D"
*fitness-proportionate-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 "~%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-population (size-of-population function-set
argument-map 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-individual-program
function-set argument-map terminal-set
(ecase *method-of-generation*
((:full :grow) *max-depth-for-new-individuals*)
(:ramped-half-and-half
(+ minimum-depth-of-trees
(mod individual-index
(- *max-depth-for-new-individuals*
minimum-depth-of-trees)))))
t
(ecase *method-of-generation*
(:full t)
(:grow nil)
(:ramped-half-and-half
full-cycle-p))))))
;; Check if we have already created this program.
;; If not then store it and move on.
;; If we have then try again.
(cond ((< individual-index (length seeded-programs))
(setf (aref population individual-index)
(make-individual :program new-program))
(incf individual-index))
((not (gethash new-program
*generation-0-uniquifier-table*))
(setf (aref population individual-index)
(make-individual :program new-program))
(setf (gethash new-program
*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-program
(function-set argument-map terminal-set
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)
idual.
(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 ((indivividual-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 populationf 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.gh (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
(do () ((or (>= low index2)
(>= (individual-normalized-fitness
(aref population index2)) pivot)))
(decf index2))
(when (>= index1 index2) (return nil))
(rotatef (aref population index1) (aref population i (sort-popul)
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-progs into the old onesw
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
-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
ams (+ 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))
ment-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
n
(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)
(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-floa)))))
(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 (lengtividual-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 (population-size (l)
(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)))
-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-integeoints 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
(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)))
er 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
*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 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 function-set argument-map 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.
(let ((mutation-point
(random-integer (count-crossover-points program)))
;; Create a brand new subtree.
(new-subtree
(create-individual-program
function-set argument-map terminal-set
*max-depth-for-new-subtrees-in-mutants* t nil)))
(let ((new-program (list (copy-tree program))))
(multiple-value-bind (subtree-pointer fragment)
;; Get the pointer to the mutation point.
(get-subtree (first new-program)
new-program 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 (first new-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."
#+Lucid (unless (typep *seed* 'integer) (setq *seed* (round *seed*)))
(assert (not (zerop *seed*)) () "*seed* cannot be zero.")
(let ((multiplier #+Lucid 16807 #-Lucid 16807.0d0);16807 is (expt 7 5)
(modulus #+Lucid 2147483647 #-Lucid 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
(#+lucid float #-lucid progn (/ *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))))
;;;---------------------------------------------------------------------------------------------
;;; Streamlined EVAL
(defmacro fast-eval-fun ()
"A code body that does fast evaluation of a
functional expression."
'(ecase (length expr)
(1 (funcall fef))
(2 (funcall fef
(fast-eval
(second expr))))
(3 (funcall fef
(fast-eval (second expr))
(fast-eval
(third expr))))
(4 (funcall fef
(fast-eval (second expr))
(fast-eval (third expr))
(fast-eval
(fourth expr))))))
#+TI
(defun fast-eval (expr)
"A fast evaluator that can be used with the
Genetic Programming Paradigm for the TI Explorer."
(cond ((consp expr)
(let ((function (first expr)))
(if (eq 'quote function)
(second expr)
(let ((fef (symbol-function function)))
(cond ((and (consp fef)
(eq'pseudo-macro (first fef)))
(apply (second fef) (rest expr)))
(t (fast-eval-fun)))))))
((symbolp expr) (symbol-value expr))
(t expr)))
#+:CCL
(defvar *pseudo-macro-tag* (compile nil '(lambda () nil)))
#+:CCL
(defun fast-eval (expr)
"A fast evaluator that can be used with the
Genetic Programming Paradigm for Macintosh Common Lisp."
(cond ((consp expr)
(let ((function (first expr)))
(if (eq 'quote function)
(second expr)
(let ((fef (symbol-function function)))
(cond ((eq fef *pseudo-macro-tag*)
(apply (symbol-value function)
(rest expr)))
(t (fast-eval-fun)))))))
((symbolp expr) (symbol-value expr))
(t expr)))
#+EXCL
(defun fast-eval (expr)
"A fast evaluator that can be used with the
Genetic Programming Paradigm for Franz Lisp."
(cond ((consp expr)
(let ((function (first expr)))
(if (eq 'quote function)
(second expr)
(let ((fef (symbol-function function)))
(cond ((compiled-function-p fef)
(fast-eval-fun))
;; Then ASSUME we are a pseudo
;; macro and are bound.
(t (apply (symbol-value function)
(rest expr))))))))
((symbolp expr) (symbol-value expr))
(t expr)))
#+Lucid
(defconstant *pseudo-macro-flag-position* 20)
#+Lucid
(defun fast-eval (expr)
"A fast evaluator that can be used with the
Genetic Programming Paradigm for Lucid Lisp."
(declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
(cond ((consp expr)
(let ((function (first expr)))
(if (eq 'quote function)
(second expr)
(let ((fef (symbol-function function)))
(if (logbitp (the fixnum *pseudo-macro-flag-position*)
(the fixnum
(system:procedure-ref
fef system:procedure-flags)))
;; Then ASSUME we are a pseudo
;; macro and are bound.
(apply (symbol-value function) (rest expr))
(fast-eval-fun))))))
((symbolp expr) (symbol-value expr))
(t expr)))
(defun install-pseudo-macro (name implementation)
"Install a pseudo-macro called Name, which is implemented by the function
Implementation."
#+(or EXCL Lucid :CCL)
(setf (symbol-value name) implementation)
(setf (symbol-function name)
#+:CCL *pseudo-macro-tag*
#+Lucid implementation
#-(or Lucid :CCL)
(list #+TI 'pseudo-macro
#+(or EXCL :CCL) 'lambda
#-(or TI EXCL :CCL)
(error "A conditionalization for your lisp ~
must be added to install-pseudo-macro")
implementation))
#+Lucid
(setf (ldb (byte 1 *pseudo-macro-flag-position*)
(system:procedure-ref implementation system:procedure-flags))
1)
(format t "~&;;; Installed ~S as the implementation of ~S"
implementation name))
;;; Detect those implementations that know about fast-eval
(eval-when (compile load eval)
#+(or Lucid EXCL TI :CCL)
(pushnew :Fast-Eval *features*)
nil)
#-:Fast-Eval
(warn "No implementation-specific version of fast-eval ~
has been written. Please write your own using ~
the examples provided.")
(defun ifltz-implementation (then-clause else-clause)
"An example implementation of a pseudo-macro. Note that the
arguments are evaluated using fast-eval explicitly.
This implements ifltz, the if x < 0 then do Then-clause
else do the Else-clause."
(declare (special x))
(if (< x 0) (fast-eval then-clause) (fast-eval else-clause)))
;;; Registers ifltz-implementation as the implementation
;;; of ifltz
#+:Fast-eval
(install-pseudo-macro 'ifltz #'ifltz-implementation)
(defun my-if-implementation (condition then-clause else-clause)
"Implements MY-IF, which is a pseudo-macro just like IF."
(if (fast-eval condition)
(fast-eval then-clause)
(fast-eval else-clause)))
;;; Registers my-if-implementation as the implementation of
;;; my-if
#+:Fast-eval
(install-pseudo-macro 'my-if #'my-if-implementation)
(defun sand (a b)
"Strict AND"
(and a b))
(defun sor (a b)
"Strict OR"
(or a b))
;;;---------------------------------------------------------------------------------------------
;;; Editor for simplifying sexpressions
(defun edit-top-level-sexpression (sexpression rule-base)
"Applies the rules in RULE-BASE to edit SEXPRESSION into
a simpler form."
(let ((location (list sexpression)))
(edit-sexpression rule-base location sexpression)
location))
(defun edit-sexpression (rule-base location sexpression)
"Given a rule base (list of rules), an sexpression and the
location of that sexpression in the containing expression,
applies the rules to the sexpression and its arguments
recursively. The rules are reapplied until a quiescent state
is achieved."
;; Apply the edit rules to each of the arguments.
;; If something changes, try again.
(when (consp sexpression)
(do* ((args (rest sexpression) (rest args))
(arg (first args) (first args))
(arg-location (rest sexpression) (rest arg-location))
(changed-p
(edit-sexpression rule-base arg-location arg)
(edit-sexpression rule-base arg-location arg)))
((not args)
(when changed-p
(edit-sexpression rule-base location sexpression)))
nil))
;; Apply the edit rules to this expression. Say that
;; something has changed if any rule fires.
(let ((changed-p nil))
(dolist (clause rule-base)
(let ((condition (second clause))
(action (third clause)))
(let ((applicable-p (funcall condition sexpression)))
(when applicable-p
(funcall action location sexpression)
(setf changed-p t)))))
changed-p))
(defun constant-expression-p (sexpression)
"Is true of an sexpression if it evaluates to a constant.
Note that this can be a problem domain specific problem."
(if (consp sexpression)
(do* ((args (rest sexpression) (rest args))
(arg (first args) (first args)))
((not args) t)
(unless (constant-expression-p arg)
(return nil)))
;;; Assumes that variable quantities are always symbols
;;; and assumes that any symbol that is not self-
;;; evaluating is not constant (this will fail for pi)
;;; so to solve more general problems some extra
;;; convention would be required.
(or (not (symbolp sexpression))
(keywordp sexpression)
(and (boundp sexpression)
(eq sexpression (symbol-value sexpression))))))
(defmacro def-edit-rule (rule-name rule-base (sexpression-name)
&key condition action)
"Declares an edit rule called RULE-NAME in the RULE-BASE.
SEXPRESSION-NAME is the local name to be given to the
sexpression on which this rule is being invokes. The
CONDITION clause is evaluated, and if it is true, the
ACTION clause is evaluated. The action clause should
make calls to REPLACE-SEXPRESSION to perform an edit."
(assert (and condition action) ()
"Both a condition and an action must be supplied.")
`(setf ,rule-base
(cons (list ',rule-name
#'(lambda (,sexpression-name) ,condition)
#'(lambda (location ,sexpression-name)
,sexpression-name ,action))
(remove (assoc ',rule-name ,rule-base :test #'eq)
,rule-base))))
(defmacro replace-sexpression (new-sexpression)
"The form to use in an edit rule that registers an edit.
For example, if the sexpression being edited is to be
replaced with the first argument to the function of the
sexpression then we would say: (replace-sexpression (second
the-sexpression)), where the-sexpression is the name of the
sexpression supplied as an argument to def-edit-rule. This
example would be useful if the function in question was an
identity function. Thus:
(def-edit-rule remove-identity-functions *my-rule-base*
(the-sexpression)
:condition (and (consp the-sexpression)
(eq (first the-sexpression) 'identity))
:action (replace-sexpression (second the-sexpression)))"
`(setf (first location) ,new-sexpression))
;;;---------------------------------------------------------------------------------------------
;;; Rule base.
(defvar *boolean-rules* nil
"The rule base for Boolean problems.")
;;; Transforms expressions of the form (not (not <xxx>)) into ;;;
<xxx>.
(def-edit-rule not-not-x->-x *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(consp (second sexpression))
(eq (first sexpression) 'not)
(eq (first (second sexpression)) 'not))
:action (replace-sexpression (second (second sexpression))))
;;; Transforms expressions of the form (or <xxx> t) into t.
(def-edit-rule or-t->-t *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(eq 'or (first sexpression))
(dolist (arg (rest sexpression) nil)
(when (and (constant-expression-p arg)
(eval arg))
(return t))))
:action (replace-sexpression t))
;;; Transforms expressions of the form (and nil <xxx>) into nil.
(def-edit-rule and-nil->-nil *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(eq 'and (first sexpression))
(dolist (arg (rest sexpression) nil)
(when (and (constant-expression-p arg)
(not (eval arg)))
(return t))))
:action (replace-sexpression nil))
;;; Transforms expressions of the form (and t <xxx>) into <xxx>.
(def-edit-rule and-t->-x *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(eq 'and (first sexpression))
(dolist (arg (rest sexpression) nil)
(when (and (constant-expression-p arg)
(eval arg))
(return t))))
:action (let ((remaining-args
(remove-if #'(lambda (arg)
(and (constant-expression-p arg)
(eval arg)))
(rest sexpression))))
(replace-sexpression
(case (length remaining-args)
(0 t)
(1 (first remaining-args))
(otherwise (cons 'and remaining-args))))))
;;; Transforms expressions of the form (or <xxx> nil) into
;;; <xxx>.
(def-edit-rule or-nil->-x *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(eq 'or (first sexpression))
(dolist (arg (rest sexpression) nil)
(when (and (constant-expression-p arg)
(not (eval arg)))
(return t))))
:action (let ((remaining-args
(remove-if #'(lambda (arg)
(and (constant-expression-p arg)
(not (eval arg))))
(rest sexpression))))
(replace-sexpression
(case (length remaining-args)
(0 nil)
(1 (first remaining-args))
(otherwise (cons 'or remaining-ar <zzz>) will be transformed in
;;; <xxx> <yyy> <zzz>).
(def-edit-rule polyadicize *boolean-rules* (sexpression)
:condition (and (consp sexpression)
(member (first sexpression) '(and or)
:test #'eq)
(dolist (arg (rest sexprxpression)))
(return t))))
:action (let ((interesting-arg
(dolist (arg (rest sexpression) nil)
(when (and (consp arg)
(eq (first arg)
(append (rest interesting-arg)
(remove interesting-arg
ues '(x :floating-point-random-constant))
)
(defun define-function-set-for-REGRESSION ()
(values '(+ - * %)
'(2 2 2 2))
)
(defun % (numerator denominator)
"The Protected Division Function"
s-fitness-case)=;02denominator) 1 (/ numerator denominator)))
(setf fitness-cases (make-array *number-of-fitness-cases*)) ;03
(format t "~%Fitness cases") ;04
(dotimes (index *number-of-fitness-cases*) ;05
(setf x (/ index *number-of-fitness-cases*)) ;06
(setf this-fitness-case (make-REGRESSION-fitness-case)) ;07
(setf (aref fitness-cases index) this-fitness-case) ;08
this-fitness-case)-;13e-independent-varia7m--More--(73%)
(* 0.5 x x)) ;14
(format t "~% ~D ~D ~D" ;15
index ;16
(float x) ;17
(REGRESSION-fitness-case-target this-fitness-case)) ;18
) ;19
(values fitness-cases) ;20
) ;21
) ;22
(defun REGRESSION-wrapper (result-from-program)
et (raw-fitness hits standardized-fitness x target-value ;03
difference value-from-program this-fitness-case) ;04
(setf raw-fitness 0.0) ;05
(setf hits 0) ;06
(dotimes (index *number-of-fitness-cases*) ;07
(setf this-fitness-case (aref fitness-cavalue ;12
(REGRESSION-fitness-case-target ;13
this-fitness-case)) ;14
(setf value-from-program ;15
(REGRESSION-wrapper (eval program))) ;16
(setf difference (abs (- target-value ;17
value-from-progr (values standardized-fit2
) ;23
) ;24
(defun define-parameters-for-REGRESSION ()
(setf *number-of-fitness-cases* 10)
(setf *max-depth-for-new-individuals* 6)
(setf *max-depth-for-individuals-after-crossover* 17)
(setf *fitness-proportionate-reproduction-fraction* 0.1)
(setf *crossover-at-any-point-fection* :fitness-proportionate)
(setf *method-of-generation* :ramped-half-and-half)
(values)
)
(defun define-termination-criterion-for-REGRESSION ;01
(current-generation ;02
maximum-generations ;03
best-standardized-fitness ;04
best-hits) ;05
(declare (ignore best-standardized-fitness)) ;06
(values ;07
(defun REGRESSION ()
(values 'define-function-set-for-REGRESSION
'define-terminal-set-for-REGRESSION
'define-fitness-cases-for-REGRESSION
'evaluate-standardized-fitness-for-REGRESSION
'define-parameters-for-REGRESSION
'define-termination-criterion-for-REGRESSION
)
)
;;;---------------------------------------------------------------------------------------------
inal-set-for-MAJO)
(values '(d2 d1 d0))
)
(defun define-function-set-for-MAJORITY-ON ()
(values '(and or not)
'( 2 2 1)
)
)
(defun define-function-set-for-MAJORITY-ON ()
(values '(and and or not)
'( 2 3 2 1)
)
)
(defstruct MAJORITY-ON-fitness-case
d0
d1
d2
*number-of-fitness-cases*))
(format t "~%Fitness cases")
(setf index 0)
(dolist (d2 '(t nil))
(dolist (d1 '(t nil))
(dolist (d0 '(t nil))
(setf fitness-case
(make-MAJORITY-ON-fitness-case)
)
(setf (MAJORITY-ON-fitness-case-d0 fitness-case) d0)
(setf (MAJORITY-ON-fitness-case-d1 fitness-case) d1)
rget fitness-case)
(or (and d2 d1 (not d0))
(and d2 (not d1) d0)
(or (and (not d2) d1 d0)
(and d2 d1 d0)
)
)
)
(setf (aref fitness-cases index) fitness-case)
(incf index)
(format t
"~% ~D ~S ~S ~S ~S"
index d2 d1 d0
(MAJO )
)
)
)
(values fitness-cases)
)
)
(defun MAJORITY-ON-wrapper (result-from-program)
(values result-from-program)
)
(defun evaluate-standardized-fitness-for-MAJORITY-ON
(program fitness-cases)
(let (raw-fitness hits standardized-fitness targeber-of-fitness-cases*)
(setf fitness-case (aref fitness-cases index))
(setf d0 (MAJORITY-ON-fitness-case-d0 fitness-case))
(setf d1 (MAJORITY-ON-fitness-case-d1 fitness-case))
(setf d2 (MAJORITY-ON-fitness-case-d2 fitness-case))
(setf target-value
(MAJeq target-value value-from-program))
(incf raw-fitness (if match-found 1.0 0.0))
(when match-found (incf hits))
)
(setf standardized-fitness (- 8 raw-fitness))
(values standardized-fitness hits)
)
)
(defun define-parameters-for-MAJORITY-ON ()
(setf *number-of-fitness-cases* 8)
(setf *max-depth-for-new-individuals* 6) (setf *fitness-proportionate-reprod)
(setf *crossover-at-any-point-fraction* 0.2)
(setf *crossover-at-function-point-fraction* 0.7)
(setf *method-of-selection* :fitness-proportionate)
(setf *method-of-generation* :ramped-half-and-half)
(values)
)
(defun define-termination-criterion-for-MAJORITY-ON
(current-generation
maximum-generations
be(values (or (>= current-generation maximum-generations)
(>= best-hits *number-of-fitness-cases*)
)
)
)
(defun MAJORITY-ON ()
(values 'define-function-set-for-MAJORITY-ON
'define-terminal-set-for-MAJORITY-ON
'define-fitn-criterion-for-MAJORITY-ON
)
)
;;;---------------------------------------------------------------------------------------------
;;; Discrete non-hamstrung squadcar problem
(defvar x)
(defvar y)
(defun define-terminal-set-for-NON-HAMSTRUNG-SQUAD-CAR ()
(values '((goN) (goE) (goS) (goW)))
)
(defun define-function-set-for-NON-HAMSTRUNG-SQUAD-CAR ()
(values '(ifX ifY)
'( 3 3)
f y (+ y *speed-ratio*))
)
(defun goE ()
(setf x (- x *speed-ratio*))
)
(defun goW ()
(setf x (+ x *speed-ratio*))
)
#+TI (setf sys:inhibit-displacing-flag t)
(defmacro ifX (lt-0-arg eq-0-arg gt-0-arg)
`(cond ((>= x *speed-ratio*) (eval ',gt-0-arg))
((<= x (- *speed-ratio*)) (eval ',lt-0-arg)) *speed-ratio*) (eval ')
((<= y (- *speed-ratio*)) (eval ',lt-0-arg))
(t (eval ',eq-0-arg))
)
)
(defmacro ifX-evader (lt-0-arg eq-0-arg gt-0-arg)
`(cond ((>= x 1) (eval ',gt-0-arg))
((<= x -1) (eval ',lt-0-arg))
(t (eval ',eq-0-arg))
)
(t (eval ',eq-0-arg))
)
)
(defun goN-evader ()
(setf y (+ y 1))
)
(defun goS-evader ()
(setf y (- y 1))
)
(defun goE-evader ()
(setf x (+ x 1))
)
(defun goW-evader ()
(setf x (- x 1))
)
(defstruct NON-HAMSTRUNG-SQUAD-CAR-fitness-case
x
y
)
(defun define-fitness-cases-for-NO (format t "~%Fitness cases")
(setf index 0)
(dolist (x '(-5 5))
(dolist (y '(-5 5))
(setf fitness-case
(make-NON-HAMSTRUNG-SQUAD-CAR-fitness-case)
)
(setf (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-x
fitness-case
)
x
)
(setf (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-y
fitness-case
)
y
)
(setf (aref fitness-cases index) fitness-case)
(incf index)
(format t "~% ~D ~S ~S" index x y)
)
)
(values fitness-cases)
)
)
(defun NON-HAMSTRUNG-SQUAD-CAR-wrapper (argument)
(values argument)
)
(defun evaluate-standardized-fitness-for-NON-HAMSTRUNG-SQUAD-CAR
(program fitness-cases)
(let (raw-fitness hits standardized-fitness
e-delta-x e-delta-y p-delta-x p-delta-y
time-tally old-x old-y
criterion
(number-of-time-steps 50)
)
(setf criterion *speed-ratio*)
(setf raw-fitness 0.0)
(setf hits 0)
(dotimes (icase *number-of-fitness-cases*)
(setf x (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-x
(aref fitness-cases icase)
)
)
(setf y (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-y
(aref fitness-cases icase)
)
)
(setf time-tally 0.0)
(catch :terminate-fitness-case-simulation
(dotimes (istep number-of-time-steps)
(setf old-x x)
(setf old-y y)
(when (and (<= (abs x) criterion)
(<= (abs y) criterion)
)
(incf hits)
(throw :terminate-fitness-case-simulation
:scored-a-hit
)
)
;; Note: (x,y) is position of the Evader.
;; Changing the position of EVADER changes X and Y.
;; Execute evader player for this time step
(eval '(ifY-evader
(goS-evader)
(ifX-evader (goW-evader)
(goS-evader) (goE-evader)
)
(goN-evader)
)
)
(setf e-delta-x (- old-x x))
(setf e-delta-y (- old-y y))
;; Reset position for Pursuer player.
(setf x old-x)
(setf y old-y)
(NON-HAMSTRUNG-SQUAD-CAR-wrapper (eval program))
(setf p-delta-x (- old-x x))
(setf p-delta-y (- old-y y))
;; Integrate x and y changes.
(setf x (- old-x (+ p-delta-x e-delta-x)))
(setf y (- old-y (+ p-delta-y e-delta-y)))
(incf time-tally)
)
)
(incf raw-fitness time-tally)
)
(setf standardized-fitness raw-fitness)
(values standardized-fitness hits)
)
)
(defun define-parameters-for-NON-HAMSTRUNG-SQUAD-CAR ()
(setf *number-of-fitness-cases* 4)
(setf *max-depth-for-new-individuals* 6)
(setf *max-depth-for-new-subtrees-in-mutants* 4)
(setf *max-depth-for-individuals-after-crossover* 17)
(setf *fitness-proportionate-reproduction-fraction* 0.1)
(setf *crossover-at-any-point-fraction* 0.2)
(setf *crossover-at-function-point-fraction* 0.7)
(setf *method-of-selection* :fitness-proportionate)
(setf *method-of-generation* :ramped-half-and-half)
(values)
)
(defun define-termination-criterion-for-NON-HAMSTRUNG-SQUAD-CAR
(current-generation
maximum-generations
best-standardized-fitness
best-hits)
(declare (ignore best-hits best-standardized-fitness))
(values (>= current-generation maximum-generations))
)
(defun NON-HAMSTRUNG-SQUAD-CAR ()
(values
'define-function-set-for-NON-HAMSTRUNG-SQUAD-CAR
'define-terminal-set-for-NON-HAMSTRUNG-SQUAD-CAR
'define-fitness-cases-for-NON-HAMSTRUNG-SQUAD-CAR
'evaluate-standardized-fitness-for-NON-HAMSTRUNG-SQUAD-CAR
'define-parameters-for-NON-HAMSTRUNG-SQUAD-CAR
'define-termination-criterion-for-NON-HAMSTRUNG-SQUAD-CAR
)
)
;;;---------------------------------------------------------------------------------------------
;;; Test harness.
(defun test-gpp (&optional (report-stream *standard-output*))
(let ((tests
'((print (edit-top-level-sexpression '(and x t) *boolean-rules*))
(run-genetic-programming-system 'REGRESSION 1.0 1 50)
(run-genetic-programming-system
'REGRESSION 1.0 1 1 '(* 0.5 x x))
(run-genetic-programming-system
'MAJORITY-ON 1.0 1 1
'(or (and d2 d1 (not d0))
(and d2 (not d1) d0)
(or (and (not d2) d1 d0)
(and d2 d1 d0))))
(run-genetic-programming-system
'NON-HAMSTRUNG-SQUAD-CAR 1.0 1 1
'(ifX (goW) (ifY (goS) (goS) (goN)) (goE)))
(print-population
(run-genetic-programming-system 'REGRESSION 1.0 1 50))
(run-genetic-programming-system 'REGRESSION 1.0 31 200)
(run-genetic-programming-system 'MAJORITY-ON 1.0 21 100)
(run-genetic-programming-system
'NON-HAMSTRUNG-SQUAD-CAR 1.0 21 100))))
(dolist (form tests)
(eval form)
(format report-stream "~&Finished test ~S" form))))
(defun time-test-gpp (&optional (path "gpp-test.text"))
(let ((current-output-stream *standard-output*))
(with-open-file (*standard-output* path
:direction :output
:if-exists :supersede)
(time (test-gpp current-output-stream)))))
#|
;;; Commented out region containing patches necessary to
;;; check out fast-eval and the pseudo-macro feature.
(defun evaluate-standardized-fitness-for-REGRESSION ;01
(program fitness-cases) ;02
(let (raw-fitness hits standardized-fitness x target-value ;03
difference value-from-program this-fitness-case) ;04
(setf raw-fitness 0.0) ;05
(setf hits 0) ;06
(dotimes (index *number-of-fitness-cases*) ;07
(setf this-fitness-case (aref fitness-cases index)) ;08
(setf x ;09
(REGRESSION-fitness-case-independent-variable ;10
this-fitness-case)) ;11
(setf target-value ;12
(REGRESSION-fitness-case-target ;13
this-fitness-case)) ;14
(setf value-from-program ;15
(REGRESSION-wrapper (fast-eval program))) ;16
(setf difference (abs (- target-value ;17
value-from-program))) ;18
(incf raw-fitness difference) ;19
(when (< difference 0.01) (incf hits))) ;20
(setf standardized-fitness raw-fitness) ;21
(values standardized-fitness hits) ;22
) ;23
) ;24
(defun evaluate-standardized-fitness-for-MAJORITY-ON
(program fitness-cases)
(let (raw-fitness hits standardized-fitness target-value
match-found value-from-program fitness-case
)
(setf raw-fitness 0.0)
(setf hits 0)
(dotimes (index *number-of-fitness-cases*)
(setf fitness-case (aref fitness-cases index))
(setf d0 (MAJORITY-ON-fitness-case-d0 fitness-case))
(setf d1 (MAJORITY-ON-fitness-case-d1 fitness-case))
(setf d2 (MAJORITY-ON-fitness-case-d2 fitness-case))
(setf target-value
(MAJORITY-ON-fitness-case-target fitness-case))
(setf value-from-program
(MAJORITY-ON-wrapper (fast-eval program)))
(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 (- 8 raw-fitness))
(values standardized-fitness hits)
)
)
(defun evaluate-standardized-fitness-for-NON-HAMSTRUNG-SQUAD-CAR
(program fitness-cases)
(let (raw-fitness hits standardized-fitness
e-delta-x e-delta-y p-delta-x p-delta-y
time-tally old-x old-y
criterion
(number-of-time-steps 50)
)
(setf criterion *speed-ratio*)
(setf raw-fitness 0.0)
(setf hits 0)
(dotimes (icase *number-of-fitness-cases*)
(setf x (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-x
(aref fitness-cases icase)
)
)
(setf y (NON-HAMSTRUNG-SQUAD-CAR-fitness-case-y
(aref fitness-cases icase)
)
)
(setf time-tally 0.0)
(catch :terminate-fitness-case-simulation
(dotimes (istep number-of-time-steps)
(setf old-x x)
(setf old-y y)
(when (and (<= (abs x) criterion)
(<= (abs y) criterion)
)
(incf hits)
(throw :terminate-fitness-case-simulation
:scored-a-hit
)
)
;; Note: (x,y) is position of the Evader.
;; Changing the position of EVADER changes X and Y.
;; Execute evader player for this time step
(fast-eval '(ifY-evader
(goS-evader)
(ifX-evader (goW-evader)
(goS-evader) (goE-evader)
)
(goN-evader)
)
)
(setf e-delta-x (- old-x x))
(setf e-delta-y (- old-y y))
;; Reset position for Pursuer player.
(setf x old-x)
(setf y old-y)
(NON-HAMSTRUNG-SQUAD-CAR-wrapper (fast-eval program))
(setf p-delta-x (- old-x x))
(setf p-delta-y (- old-y y))
;; Integrate x and y changes.
(setf x (- old-x (+ p-delta-x e-delta-x)))
(setf y (- old-y (+ p-delta-y e-delta-y)))
(incf time-tally)
)
)
(incf raw-fitness time-tally)
)
(setf standardized-fitness raw-fitness)
(values standardized-fitness hits)
)
)
(defun define-function-set-for-MAJORITY-ON ()
(values '(sand sor not)
'( 2 2 1)
)
)
(defun ifX-implementation (lt-0-arg eq-0-arg gt-0-arg)
(cond ((>= x *speed-ratio*) (fast-eval gt-0-arg))
((<= x (- *speed-ratio*)) (fast-eval lt-0-arg))
(t (fast-eval eq-0-arg))
)
)
(install-pseudo-macro 'ifX #'ifX-implementation)
(defun ifY-implementation (lt-0-arg eq-0-arg gt-0-arg)
(cond ((>= y *speed-ratio*) (fast-eval gt-0-arg))
((<= y (- *speed-ratio*)) (fast-eval lt-0-arg))
(t (fast-eval eq-0-arg))
)
)
(install-pseudo-macro 'ifY #'ifY-implementation)
(defun ifX-evader-implementation (lt-0-arg eq-0-arg gt-0-arg)
(cond ((>= x 1) (fast-eval gt-0-arg))
((<= x -1) (fast-eval lt-0-arg))
(t (fast-eval eq-0-arg))
)
)
(install-pseudo-macro 'ifX-evader #'ifX-evader-implementation)
(defun ifY-evader-implementation (lt-0-arg eq-0-arg gt-0-arg)
(cond ((>= y 1) (fast-eval gt-0-arg))
((<= y -1) (fast-eval lt-0-arg))
(t (fast-eval eq-0-arg))
)
)
(install-pseudo-macro 'ifY-evader #'ifY-evader-implementation)
(defun test-gpp (&optional (report-stream *standard-output*))
(let ((tests
'((print (edit-top-level-sexpression '(and x t)
*boolean-rules*))
(run-genetic-programming-system 'REGRESSION 1.0 1 50)
(run-genetic-programming-system
'REGRESSION 1.0 1 1 '(* 0.5 x x))
(run-genetic-programming-system
'MAJORITY-ON 1.0 1 1
'(sor (sand d2 (sand d1 (not d0)))
(sor (sand d2 (sand (not d1) d0))
(sor (sand (not d2) (sand d1 d0))
(sand d2 (sand d1 d0))))))
(run-genetic-programming-system
'NON-HAMSTRUNG-SQUAD-CAR 1.0 1 1
'(ifX (goW) (ifY (goS) (goS) (goN)) (goE)))
(print-population
(run-genetic-programming-system 'REGRESSION 1.0 1 50))
(run-genetic-programming-system 'REGRESSION 1.0 31 200)
(run-genetic-programming-system 'MAJORITY-ON 1.0 21 100)
(run-genetic-programming-system
'NON-HAMSTRUNG-SQUAD-CAR 1.0 21 100))))
(dolist (form tests)
(eval form)
(format report-stream "~&Finished test ~S" form))))
;;; End of commented out section.
· The home page of Genetic Programming Inc. at www.genetic-programming.com.
· For information about the field of genetic programming in general, visit www.genetic-programming.org
· The home page of John R. Koza at Genetic Programming Inc. (including online versions of most papers) and the home page of John R. Koza at Stanford University
· For information about John Koza’s course on genetic algorithms and genetic programming at Stanford University
· Information about the 1992 book Genetic Programming: On the Programming of Computers by Means of Natural Selection, the 1994 book Genetic Programming II: Automatic Discovery of Reusable Programs, the 1999 book Genetic Programming III: Darwinian Invention and Problem Solving, and the 2003 book Genetic Programming IV: Routine Human-Competitive Machine Intelligence. Click here to read chapter 1 of Genetic Programming IV book in PDF format.
· For information on 3,198
papers (many on-line) on genetic programming (as of June 27, 2003) by over 900
authors, see William Langdon’s bibliography on
genetic programming.
· For information on the Genetic Programming and Evolvable Machines journal published by Kluwer Academic Publishers
· For information on the Genetic Programming book series from Kluwer Academic Publishers, see the Call For Book Proposals
· For information about the annual Genetic and Evolutionary Computation (GECCO) conference (which includes the annual GP conference) to be held on June 26–30, 2004 (Saturday – Wednesday) in Seattle and its sponsoring organization, the International Society for Genetic and Evolutionary Computation (ISGEC). For information about the annual Euro-Genetic-Programming Conference to be held on April 5-7, 2004 (Monday – Wednesday) at the University of Coimbra in Coimbra Portugal. For information about the 2003 and 2004 Genetic Programming Theory and Practice (GPTP) workshops held at the University of Michigan in Ann Arbor. For information about the annual NASA/DoD Conference on Evolvable Hardware Conference (EH) to be held on June 24-26 (Thursday-Saturday), 2004 in Seattle.