;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; midgp 1.5 #| MidGP: a Common Lisp stack-based genetic programming engine similar to HiGP Author: Lee Spector History 10/31/96 - version 1 11/3/96 - version 1.1 - added ontogenetic functions and a few minor fixes 11/10/96 - version 1.2 - added file output mechanism 11/11/96 - version 1.3 - added *reproduction-preserves-fitness* and made associated changes - fixed serious bug in produce-next-generation (rotation was being performed both for the rotation and reproduction fractions) 11/19/96 - version 1.4 - added mechanisms to ease preservation of a program across multiple executions when ontogenetic functions are being used. See *use-previous-program*. 11/24/96 - version 1.5 - added a rotated-crossover genetic operator (see fill-program-by-rotated-crossover and *rotated-crossover-fraction*). - now allows lists in programs -- these are executed by funcalling the car on the cdr. - added resume-midgp Overview: MidGP is a Common Lisp implementation of a stack-based genetic programming engine similar to the HiGP system that is described in [Stoffel and Spector 1996]. (HiGP itself derives in part from a stack-based genetic programming system described in [Perkis 1994]). MidGP programs are linear sequences of instructions that are executed on a virtual stack machine. HiGP was designed in part for very high performance and for parallel execution on multiple processors -- these aspects of HiGP are not reproduced in MidGP. Some differences from HiGP: - MidGP is implemented in Lisp (rather than C) - much less attention paid to performance issues in MidGP - ephemeral random constants are implemented in MidGP in a way more similar to Koza's technique - multipoint mutation (HiGP is single? I forget!) - a rotation genetic operator has been added - although versions of the ontogenetic functions shift-left, shift-right, and segment-copy are provided, the shift functions differ from those described in [Spector & Stoffel 19961, 1996b] in that no action is taken when the stack is empty. To test this code on the provided symbolic regression problem: - Load this file. - Evaluate (run-midgp) To apply MidGP to your own problem: - Define any other midgp functions you want in the function set (see examples) - Possibly redefine generate-ephemeral-random-constant - Redefine parameters (be sure to define all parameters listed below) - Redefine evaluate-fitness-of-program, possibly also redefining *number-of-fitness-cases* and *fitness-cases*. - Comment out all sections of this file that you've redefined (parameters, generate-ephemeral-random-constant if appropriate, fitness evaluation code) - Load this file (or reload -- must be done after the parameter redefinition) - Evaluate (run-midgp) Disclaimer: This is a quick hack -- I'm making it available in case anyone wants to play with it, but it's nowhere near industrial strength. Possible enhancements: (there are many, but these are some of the obvious ones) - better, seedable random number generator to be used throughout - cleaner way to re-run produced programs References: Perkis, T. 1994. Stack-Based Genetic Programming. In Proceedings of the 1994 IEEE World Congress on Computational Intelligence, pp. 148-153. IEEE Press. Spector, L., and K. Stoffel. 1996a. Ontogenetic Programming. In Koza, John R., Goldberg, David E., Fogel, David B., and Riolo, Rick L. (editors) Genetic Programming 1996: Proceedings of the First Annual Conference, 394-399. Cambridge, MA: The MIT Press. Spector, L., and K. Stoffel. 1996b. Automatic Generation of Adaptive Programs. In From Animals to Animats 4: Proceedings of the Fourth International Conference on Simulation of Adaptive Behavior (SAB-96), 476-483. P. Maes, M. Mataric, J.-A. Meyer, J. Pollack, and S.W. Wilson (editors). Cambridge, MA: The MIT Press. Stoffel, K., and L. Spector. 1996. High-Performance, Parallel, Stack-Based Genetic Programming. In Koza, John R., Goldberg, David E., Fogel, David B., and Riolo, Rick L. (editors) Genetic Programming 1996: Proceedings of the First Annual Conference, 224-229. Cambridge, MA: The MIT Press. |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; parameters ;; comment this section out if you've defined all parameters elsewhere (defparameter *program-size* 32 "The length of each midgp program. Note that the inclusion of a noop function in the function set will allow programs to have fewer than this many work-performing steps -- so you may want to think of this as a 'maximum' program size.") (defparameter *midgp-function-set* '(noop +m -m *m /m push-x) "The function set for midgp. May include midgp functions, numeric constants, and :ephemeral-random-constant") (defparameter *number-of-functions* (length *midgp-function-set*) "The number of elements in the function set -- calculated automatically.") (defparameter *success-threshold* 0.001 "The fitness threshold at or below which a program will be considered successful -- midgp will halt when it finds a program with such a fitness.") (defparameter *population-size* 500 "The number of midgp programs in a midgp generation.") (defparameter *number-of-generations* 31 "The maximum number of generations that will be processed by midgp, including the initial random population (generation 0).") (defparameter *tournament-size* 5 "The number of programs to be compared for each selection process (e.g. to select parents for crossover.)") (defparameter *crossover-fraction* 0.60 "The percent of the next geneneration that will be produced via crossover.") (defparameter *mutation-fraction* 0.10 "The percent of the next geneneration that will be produced via mutation.") (defparameter *rotation-fraction* 0.10 "The percent of the next geneneration that will be produced via rotation.") (defparameter *rotated-crossover-fraction* 0.10 "The percent of the next geneneration that will be produced via rotated crossover.") ;; NOTE: the remainder of the next geneneration will be produced via straight ;; reproduction (defparameter *max-mutation-points* (truncate *program-size* 2) "The maximum number of points that will be changed in a single mutation.") (defparameter *reproduction-preserves-fitness* t "If non-nil, fitness will not be recalculated for individuals produced by straight reproduction from the previous generation -- the old fitness value will be used.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; global variables ;; (These are not really parameters, even though some are defined with ;; defparameter.) (defvar *midgp-stack* nil "A list containing the runtime stack during the execution of a midgp program.") (defparameter *midgp-program* (make-array (list *program-size*)) "The currently executing midgp program.") (defvar *midgp-instruction-pointer* 0 "The index of the midgp instruction to execute next.") (defvar *midgp-instruction-pointer-offset* 0 "An offset added to the instruction pointer (mod *program-size*) before executing each instruction. This can be used to simplify the implementation of shift-type ontogenetic operators.") (defparameter *this-generation* (make-array (list *population-size*)) "Holds the current population.") (defparameter *next-generation* (make-array (list *population-size*)) "Holds the next population while it is being constructed.") (defparameter *fitnesses* (make-array (list *population-size*)) "Holds the fitnesses of the current population during fitness evaluation and until the start of the production of the next generation.") (defparameter *preserved-fitnesses* (make-array (list *population-size*)) "A copy of *fitnesses* made before the production of the next generation. Used to avoid recalculating the fitness of individuals produced by straight reproduction. See *reproduction-preserves-fitness*. Also used for fitness-lookup during selection.") (defparameter *best-midgp-fitness* Most-Positive-Fixnum "Holds the fitness of the best program yet produced in a midgp run.") (defparameter *best-midgp-program* (make-array (list *program-size*)) "Holds the best program yet produced in a midgp run.") (defparameter *use-previous-program* nil "If non-nil, the program passed to execute-midgp-program will be ignored, and the program in *midgp-program* will be used instead. This is useful when ontogenetic functions are being used, to allow the effects of the ontogenetic functions to persist to the next program execution. To use this option, set *use-previous-program* to nil before the first execution of the program, and then set it to t before each subsequent execution.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; stack utilities (defun midgp-push (thing) "Pushes thing onto the midgp stack." (push thing *midgp-stack*)) (defun midgp-pop () "Pops and returns the top element on the midgp stack." (pop *midgp-stack*)) (defun sufficient-midgp-args (n) "Returns non-nil iff there are at least n items on the midgp stack. Every function in the midgp function set that takes any arguments off the stack should call this before doing anything else." (or (zerop n) (nthcdr (1- n) *midgp-stack*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; file output utility (defparameter *midgp-output-path* "midgp-output") (defun midgp-output (&rest format-args) "Interprets its arguments as FORMAT does (without a stream argument) and sends the output both to standard output (e.g. the listener) and, if *midgp-output-path* is non-nil, appends it to the file at that path." (apply #'format (cons t format-args)) (when *midgp-output-path* (with-open-file (out *midgp-output-path* :direction :output :if-exists :append :if-does-not-exist :create) (apply #'format (cons out format-args))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; stack-based virtual machine execution engine (defun execute-midgp-program (program &key (max-steps nil max-steps-provided) (preload nil) (debug nil)) "Executes the provided midgp program until it terminates or until max-steps steps have been executed. If provided, preload should be a list of values to push onto the stack prior to execution, in the order provided (first in the list is the first pushed). The function returns a symbol indicating how the program terminated. *midgp-stack* is left it its final state, from which program results can be extracted." ;; first copy the program into *midgp-program* if appropriate (unless *use-previous-program* (dotimes (i *program-size*) (setf (aref *midgp-program* i) (aref program i))) ;; these are also the cases in which the instruction offset should be reset (setq *midgp-instruction-pointer-offset* 0)) ;; preload any provided values onto an initialized stack (setq *midgp-stack* nil) (dotimes (n (length preload)) (push (nth n preload) *midgp-stack*)) ;; execute (setq *midgp-instruction-pointer* -1) (if (or debug max-steps-provided) ;; slower loop -- checks for debug & number of steps (let ((steps-executed 0)) (loop ;; if debugging, print stack (when debug (print *midgp-stack*)) ;; terminate if max steps already executed (when (and max-steps-provided (>= steps-executed max-steps)) (return :max-steps-executed)) ;; increment instruction pointer (incf *midgp-instruction-pointer*) ;; terminate if instruction pointer is out of range (unless (< -1 *midgp-instruction-pointer* *program-size*) (return :instruction-pointer-out-of-range)) ;; execute instruction (or push constant number) (let ((instruction (aref *midgp-program* (mod (+ *midgp-instruction-pointer* *midgp-instruction-pointer-offset*) *program-size*)))) (cond ((numberp instruction) (midgp-push instruction)) ((listp instruction) (funcall (car instruction) (cdr instruction))) (t (funcall instruction)))) ;; increment count of executed steps (incf steps-executed))) (loop ;; faster loop ;; increment instruction pointer (incf *midgp-instruction-pointer*) ;; terminate if instruction pointer is out of range (unless (< -1 *midgp-instruction-pointer* *program-size*) (return :instruction-pointer-out-of-range)) ;; execute instruction (or push constant number) (let ((instruction (aref *midgp-program* (mod (+ *midgp-instruction-pointer* *midgp-instruction-pointer-offset*) *program-size*)))) (cond ((numberp instruction) (midgp-push instruction)) ((listp instruction) (funcall (car instruction) (cdr instruction))) (t (funcall instruction))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; genetics (defun random-midgp-program-element () "Returns a random element for a midgp program. This will either be an element from the function set or, if :ephemeral-random-constant is selected from the function set, the result of calling generate-ephemeral-random-constant." (let ((fn (nth (random *number-of-functions*) *midgp-function-set*))) (if (eq fn :ephemeral-random-constant) (generate-ephemeral-random-constant) fn))) (defun random-midgp-program () "Returns a new random midgp program." (let ((pgm (make-array (list *program-size*)))) (dotimes (i *program-size*) (setf (aref pgm i) (random-midgp-program-element))) pgm)) (defun initialize-midgp-population () "Fills *this-generation* with new random programs. Also fills *next-generation* with random programs, just so the arrays are all allocated. Also initializes all elements of *fitnesses* to :unevaluated." (dotimes (i *population-size*) (setf (aref *this-generation* i) (random-midgp-program)) (setf (aref *next-generation* i) (random-midgp-program)) (setf (aref *fitnesses* i) :unevaluated))) (defun select-from-this-generation () "Runs a fitness tournament and returns the winning program in *this-generation*. Lower (standardized) fitnesses win. Also returns the index of the winner as a second value." (let ((winner (random *population-size*))) (dotimes (i (1- *tournament-size*)) (let ((contender (random *population-size*))) (when (< (aref *preserved-fitnesses* contender) (aref *preserved-fitnesses* winner)) (setq winner contender)))) (values (aref *this-generation* winner) winner))) (defun fill-program-by-reproduction (index) "Fills in the index-th program of *next-generation* by direct reproduction of an individual selected from *this-generation*." (multiple-value-bind (parent parent-index) (select-from-this-generation) (let ((child (aref *next-generation* index))) (dotimes (i *program-size*) (setf (aref child i) (aref parent i))) ;; copy the fitness from *preserved-fitnesses* if appropriate (when *reproduction-preserves-fitness* (setf (aref *fitnesses* index) (aref *preserved-fitnesses* parent-index)))))) (defun fill-program-by-mutation (index) "Fills in the index-th program of *next-generation* by single-point mutation of an individual selected from *this-generation*." (let ((parent (select-from-this-generation)) (child (aref *next-generation* index)) (number-of-mutations (random *max-mutation-points*))) ;; first do straight reproduction (dotimes (i *program-size*) (setf (aref child i) (aref parent i))) ;; now mutate instructions (dotimes (i number-of-mutations) (setf (aref child (random *program-size*)) (random-midgp-program-element))))) (defun fill-program-by-rotation (index) "Fills in the index-th program of *next-generation* by random rotation of an individual selected from *this-generation*." (let ((parent (select-from-this-generation)) (child (aref *next-generation* index)) (distance (random *program-size*))) (dotimes (i *program-size*) (setf (aref child (mod (+ i distance) *program-size*)) (aref parent i))))) (defun fill-program-by-crossover (index) "Fills in the index-th program of *next-generation* by crossover of two individuals selected from *this-generation*." (let ((parent1 (select-from-this-generation)) (parent2 (select-from-this-generation)) (child (aref *next-generation* index)) (crossover-point (random *program-size*))) (dotimes (i *program-size*) (if (< i crossover-point) (setf (aref child i) ;; copy first part from parent 1 (aref parent1 i)) (setf (aref child i) ;; copy second part from parent 2 (aref parent2 i)))))) (defun fill-program-by-rotated-crossover (index) "Fills in the index-th program of *next-generation* by crossover of two individuals selected from *this-generation*. Each parent is rotated random number of instructions prior to crossover." (let ((parent1 (select-from-this-generation)) (parent2 (select-from-this-generation)) (child (aref *next-generation* index)) (crossover-point (random *program-size*)) (parent1-rotation (random *program-size*)) (parent2-rotation (random *program-size*))) (dotimes (i *program-size*) (if (< i crossover-point) (setf (aref child i) ;; copy first part from parent 1 (aref parent1 (mod (+ i parent1-rotation) *program-size*))) (setf (aref child i) ;; copy second part from parent 2 (aref parent2 (mod (+ i parent2-rotation) *program-size*))))))) (defun produce-next-generation () "Uses genetic operators to produce *next-generation* from *this-generation*, and then sets *this-generation* to be the new generation." (let* ;; figure numbers to produce by each operator ((crossover-cutoff (truncate (* *crossover-fraction* *population-size*))) (mutation-cutoff (+ crossover-cutoff (truncate (* *mutation-fraction* *population-size*)))) (rotation-cutoff (+ mutation-cutoff (truncate (* *rotation-fraction* *population-size*)))) (rotated-crossover-cutoff (+ rotation-cutoff (truncate (* *rotated-crossover-fraction* *population-size*))))) ;; first prepare for fitness-preserving reproduction ;; copy the old fitnesses (dotimes (i *population-size*) (setf (aref *preserved-fitnesses* i) (aref *fitnesses* i))) ;; now make *fitnesses* :unevaluated (dotimes (i *population-size*) (setf (aref *fitnesses* i) :unevaluated)) ;; now fill *next-generation* (dotimes (i *population-size*) (cond ((< i crossover-cutoff) (fill-program-by-crossover i)) ((< i mutation-cutoff) (fill-program-by-mutation i)) ((< i rotation-cutoff) (fill-program-by-rotation i)) ((< i rotated-crossover-cutoff) (fill-program-by-rotated-crossover i)) (t (fill-program-by-reproduction i)))) ;; switch pointers to the two populations (let ((temp *this-generation*)) (setq *this-generation* *next-generation*) (setq *next-generation* temp)))) (defun evaluate-fitness-of-population () "Evaluates the fitness of all programs in *this-generation* by calling evaluate-fitness-of-program on each. Fills in *fitnesses* with the resulting values." (dotimes (i *population-size*) (if (eq (aref *fitnesses* i) :unevaluated) (setf (aref *fitnesses* i) (evaluate-fitness-of-program (aref *this-generation* i)))))) (defun report-on-population (generation-number) "Reports on the *this-generation* and returns the best fitness." (let ((best-index 0) (best-fitness MOST-POSITIVE-FIXNUM) (total-fitness 0)) (dotimes (i *population-size*) (let ((this-fitness (aref *fitnesses* i))) (incf total-fitness this-fitness) (when (< this-fitness best-fitness) ;; check for best of generation (setq best-fitness this-fitness best-index i) (when (< this-fitness *best-midgp-fitness*) ;; check for best of run (setq *best-midgp-fitness* this-fitness) (dotimes (instr *program-size*) (setf (aref *best-midgp-program* instr) (aref (aref *this-generation* i) instr))))))) (midgp-output "~%~%=== Report on Generation ~A ===" generation-number) (midgp-output "~%Average fitness: ~A, Best fitness: ~A~%Best program:~%~A~%" (float (/ total-fitness *population-size*)) best-fitness (aref *this-generation* best-index)) best-fitness)) (defun report-on-run () "Reports the best fitness and program achieved in the entire MidGP run." (midgp-output "~%~%=== Report on MidGP Run ===") (midgp-output "~%Best fitness: ~A~%Best program:~%~A~%" *best-midgp-fitness* *best-midgp-program*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; top level functions (defun run-midgp () "The main function for midgp. Call this with no arguments after everything else has been defined." ;; perform initializations (setq *best-midgp-fitness* Most-Positive-Fixnum *best-midgp-program* (make-array (list *program-size*))) (midgp-output "~%Initializing population...") (initialize-midgp-population) ;; for each generation (dotimes (i *number-of-generations*) ;; evaluate fitness (midgp-output "~%Evaluating fitness of population...") (evaluate-fitness-of-population) ;; report and exit the loop if a successful program has been found (when (<= (report-on-population i) *success-threshold*) (return)) ;; produce the next generation (unless (= i (- *number-of-generations* 1)) (midgp-output "~%Producing next generation...") (produce-next-generation))) (report-on-run)) (defun resume-midgp (num-generations) "Resumes a MidGP run after it has terminated due to the completion of *number-of-generations* generations. Note that the generation numbers printed in the output will NOT be cumulative." (midgp-output "~%~%===== RESUMING MIDGP FOR ~A GENERATIONS =====~%~%" num-generations) (midgp-output "~%Producing next generation...") (produce-next-generation) (dotimes (i num-generations) ;; evaluate fitness (midgp-output "~%Evaluating fitness of population...") (evaluate-fitness-of-population) ;; report and exit the loop if a successful program has been found (when (<= (report-on-population i) *success-threshold*) (return)) ;; produce the next generation (unless (= i (- num-generations 1)) (midgp-output "~%Producing next generation...") (produce-next-generation))) (report-on-run)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; fitness evaluation for symbolic regression of y=x^4+x^3+x^2+x (defvar *x* 0 "A variable to hold the X value for symbolic regression.") (defparameter *number-of-fitness-cases* 20 "The number of fitness cases to use in evaluating the fitness of a program.") (defparameter *fitness-cases* (make-array (list *number-of-fitness-cases*) :initial-contents (mapcar #'(lambda (x) (list x (+ (expt x 4) (expt x 3) (expt x 2) x))) '(0.12 0.22 0.33 0.44 0.55 0.66 0.77 0.88 0.99 1.0 -0.12 -0.22 -0.33 -0.44 -0.55 -0.66 -0.77 -0.88 -0.99 -1.0))) "An array of fitness cases to use in evaluating the fitness of a program.") (defun evaluate-fitness-of-program (program) "A fitness function for symbolic regression. Note that midgp uses 'standardized' fitnesses, in which lower fitness values are better." (let ((fitness-this-case 0) (total-fitness 0)) (dotimes (i *number-of-fitness-cases*) (setq *midgp-instruction-pointer-offset* 0) ;; in case ontogenetic fns were used (setq *x* (car (aref *fitness-cases* i))) (execute-midgp-program program) (setq fitness-this-case (abs (- (cadr (aref *fitness-cases* i)) (or (midgp-pop) 0)))) (incf total-fitness fitness-this-case)) total-fitness)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ephemeral random constants (defun generate-ephemeral-random-constant () "Returns a new ephemeral random constant between 0 and 1. DO NOT include this in the function set -- include :ephemeral-random-constant and this will be called when generating and mutating programs." (float (/ (random MOST-POSITIVE-FIXNUM) MOST-POSITIVE-FIXNUM))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; functions for the function set ;; Note that all functions must take their arguments from the stack (after ;; checking that there are sufficient values on the stack!), and that they ;; must push any results back onto the stack. (defun +m () "A 2-argument addition function for midgp programs." (when (sufficient-midgp-args 2) (let ((arg2 (midgp-pop)) (arg1 (midgp-pop))) (midgp-push (+ arg2 arg1))))) (defun -m () "A 2-argument subtraction function for midgp programs." (when (sufficient-midgp-args 2) (let ((arg2 (midgp-pop)) (arg1 (midgp-pop))) (midgp-push (- arg2 arg1))))) (defun *m () "A 2-argument multiplication function for midgp programs." (when (sufficient-midgp-args 2) (let ((arg2 (midgp-pop)) (arg1 (midgp-pop))) (midgp-push (* arg2 arg1))))) (defun /m () "A 2-argument protected division function for midgp programs." (when (sufficient-midgp-args 2) (let ((arg2 (midgp-pop)) (arg1 (midgp-pop))) (midgp-push (if (zerop arg2) 1 (/ arg1 arg2)))))) (defun noop () "does nothing") (defun push-x () "Pushes the value of *x* onto the midgp stack." (midgp-push *x*)) ;; ontogenetic functions -- not used in the regression example, but ;; you may want to use them in other applications. ;; NOTE: these versions of the ontogenetic functions assume that the ;; midgp stack contains integers (NOT the case in the regression example!). ;; NOTE: these versions of shift-left and shift-right differ from those ;; described in [Spector & Stoffel 19961, 1996b] in that no action is ;; taken when the stack is empty. (defparameter *scratch-midgp-program* (make-array (list *program-size*)) "An array to hold intermediary information during the execution of ontogenetic midgp functions.") (defun segment-copy () "Takes 3 arguments off the midgp stack: the start position of the segment to copy (relative to the current instruction), the length of the segment, and the position to which the segment should be copied (relative to the current instruction). All arguments are taken mod *program-size*. The effect of a call to segment-copy is to modify the currently executing program by copying the segment as indicated." (declare (optimize (speed 3) (safety 0))) (when (sufficient-midgp-args 3) (let ((arg3 (mod (midgp-pop) *program-size*)) (arg2 (mod (midgp-pop) *program-size*)) (arg1 (mod (midgp-pop) *program-size*))) ;; first copy the segment into the scratch array (dotimes (i arg2) (setf (aref *scratch-midgp-program* i) (aref *midgp-program* (mod (+ arg1 ;; add start-position ;; plus current location (+ *midgp-instruction-pointer* *midgp-instruction-pointer-offset*) ;; plus index into segment i) *program-size*)))) ;; now copy the segment back into the program (dotimes (i arg2) (setf (aref *midgp-program* (mod (+ arg3 ;; add new position ;; plus current location (+ *midgp-instruction-pointer* *midgp-instruction-pointer-offset*) ;; plus index into segment i) *program-size*)) (aref *scratch-midgp-program* i)))))) (defun shift-left () "Takes one argument off the midgp stack and rotates the currently executing program a corresponding number of times to the left. If there is no value on the stack the program is left unchanged -- note that this differs from the behavior specified in the GP96 and SAB96 papers." (declare (optimize (speed 3) (safety 0))) (when (sufficient-midgp-args 1) (let ((arg (mod (midgp-pop) *program-size*))) (setq *midgp-instruction-pointer-offset* (+ *midgp-instruction-pointer-offset* arg))))) (defun shift-right () "Takes one argument off the midgp stack and rotates the currently executing program a corresponding number of times to the right. If there is no value on the stack the program is left unchanged -- note that this differs from the behavior specified in the GP96 and SAB96 papers." (declare (optimize (speed 3) (safety 0))) (when (sufficient-midgp-args 1) (let ((arg (mod (midgp-pop) *program-size*))) (setq *midgp-instruction-pointer-offset* (- *midgp-instruction-pointer-offset* arg))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; misc utilities (defun diversity-check () "Returns a list containing, for each program in *this-generation*, the number of duplicate programs in *this-generation*." (let ((result nil)) (dotimes (i *population-size*) (let ((equivalents 0)) (dotimes (j *population-size*) (when (equalp (aref *this-generation* i) (aref *this-generation* j)) (incf equivalents))) (push equivalents result))) result)) (defun fitness-diversity-check () "Returns a list containing, for each value in *preserved-fitnesses*, the number of equivalent values in *preserved-fitnesses*." (let ((result nil)) (dotimes (i *population-size*) (let ((equivalents 0)) (dotimes (j *population-size*) (when (equalp (aref *preserved-fitnesses* i) (aref *preserved-fitnesses* j)) (incf equivalents))) (push equivalents result))) result)) :MidGP-loaded ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; test code #| ;; misc tests of sub-functions (defvar testprog) (setq testprog (random-midgp-program)) (execute-midgp-program testprog :debug t) (time (execute-midgp-program testprog)) *midgp-stack* ;; test the whole system (run-midgp) |#