(in-package :GECO) #| Genetic Evolution through Combination of Objects (GECO) Copyright (C) 1992,1993 George P. W. Williams, Jr. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |# ;;; population methods (defmethod SHARED-INITIALIZE :AFTER ((pop population) slot-names &REST initargs &KEY random) (declare (ignore slot-names initargs)) (unless (slot-boundp pop 'organisms) (when (size pop) (setf (organisms pop) (make-organisms-vector pop (size pop))) (when random (make-organisms pop :random random))))) (defmethod MAKE-ORGANISMS-VECTOR ((self population) size) (make-array size)) (defmethod MAKE-ORGANISM ((pop population) &KEY random no-chromosomes) (make-instance (organism-class pop) :population pop :random random :no-chromosomes no-chromosomes)) (defmethod MAKE-ORGANISMS ((pop population) &KEY random &AUX (organisms (organisms pop))) (dotimes (i (size pop)) (setf (aref organisms i) (make-organism pop :random random)))) (defmethod EVALUATE ((pop population) (plan genetic-plan) &AUX (orgs (organisms pop))) (dotimes (i (length orgs)) (let ((org (aref orgs i))) (if (dbg-p :score) (if (score org) (let ((orig-score (score org))) (evaluate org plan) (incf (evaluation-number (ecosystem pop))) (when (/= orig-score (score org)) (dbgo "~%**** bad score: orig=~F, now=~F" orig-score (score org)) (break))))) (unless (score org) (evaluate org plan)))) (normalize-score pop (setf (statistics pop) (make-population-statistics pop)) plan)) (defmethod MAKE-POPULATION-STATISTICS ((pop population)) (make-instance (population-statistics-class pop) :population pop)) (defmethod COMPUTE-STATISTICS ((pop population)) "This method should only be used if the statistics need to be recomputed. They are initially computed when the population-statistics instance is first created for the population." (compute-statistics (statistics pop))) (defmethod COMPUTE-BINARY-ALLELE-STATISTICS ((population population)) "Returns a list of vectors (one per binary chromosome in the organisms of the population) of counts by locus of non-zero alleles." (with-accessors ((orgs organisms)) population (let ((counts-list (mapcar #'(lambda (chr) (make-array (size chr) :element-type 'fixnum :initial-element 0)) ;; assume chromosomes of all organisms are the same size (genotype (aref orgs 0))))) (dotimes (org# (size population)) (do* ((chromosome-ptr (genotype (aref orgs org#)) (rest chromosome-ptr)) (chromosome (first chromosome-ptr) (first chromosome-ptr)) (counts-ptr counts-list (rest counts-ptr)) (counts (first counts-ptr) (first counts-ptr))) ((null chromosome-ptr)) (when (typep chromosome 'binary-chromosome) (dotimes (locus# (size chromosome)) (if (/= 0 (locus chromosome locus#)) (incf (aref counts locus#))))))) counts-list))) (defmethod NORMALIZE-SCORE ((pop population) (stats population-statistics) (plan genetic-plan) &AUX (orgs (organisms pop))) "Normalize all the score values for each organism in the population, according to the genetic plan plan, and update the population-statistics with normalized values (using compute-normalized-statistics)." (unless (= (max-score stats) (min-score stats)) ;; don't normalize if the population is completely converged, or we'll get arithmetic exceptions (dotimes (i (length orgs)) (normalize-score (aref orgs i) stats plan)) (compute-normalized-statistics stats))) #| There are a number of different ways to normalize the score values. With some plans and evaluation functions, it may not even be necessary, though beware that the score should always be >= 0. See Chapter 4 of Goldberg's book, under the sections on Scaling Mechanisms and Ranking Procedures. Note that some selection procedures are also based on ranking. |# (defmethod CONVERGED-P ((pop population) &AUX (pop-size (size pop)) (organisms (organisms pop)) (stats (statistics pop)) threshold (passing-count 0) (as-good-as-test (as-good-as-test pop))) "A predicate which returns true (non-NIL) when the population has converged. This method defines convergence as either of the following: 1. The entire population is converged to a single score value; or 2. At least convergence-fraction of the current population has a normalized score value which is as good as convergence-threshold-margin of the population. Here, as good as is determined using the function returned by the as-good-as-test generic function of the population." (if (dbg-p :converge) (dbgo "~&---CONVERGE-P: generation=~4D, threshold=~,3F" (generation-number (ecosystem pop)) (convergence-threshold-margin pop))) (if (= (max-score stats) (min-score stats)) (progn (if (dbg-p :converge) (dbgo "~& population is completely converged, score=~F" (max-score stats))) T) (progn (setq threshold (convergence-threshold-margin pop)) (dotimes (i pop-size) (if (funcall as-good-as-test (normalized-score (aref organisms i)) threshold) (incf passing-count))) (if (dbg-p :converge) (dbgo "~& passing-count=~3D and passing-fraction=~,3F" passing-count (float (/ passing-count pop-size)))) (>= (float (/ passing-count pop-size)) (convergence-fraction pop))))) ;;; The following could be :allocation :per-class slots if/when this can be implemented efficiently & portably: (defmethod POPULATION-STATISTICS-CLASS ((pop population)) 'population-statistics) ;;; Methods for maximizing-score-mixin (defmethod MAXIMIZING-P ((pop maximizing-score-mixin)) t) (defmethod MINIMIZING-P ((pop maximizing-score-mixin)) nil) (defmethod BETTER-THAN-TEST ((pop maximizing-score-mixin)) #'>) (defmethod AS-GOOD-AS-TEST ((pop maximizing-score-mixin)) #'>=) (defmethod CONVERGENCE-FRACTION ((pop maximizing-score-mixin)) 0.95) (defmethod CONVERGENCE-THRESHOLD-MARGIN ((pop maximizing-score-mixin)) 0.95) (defmethod BEST-ORGANISM-ACCESSOR ((pop maximizing-score-mixin)) #'max-organism) (defmethod WORST-ORGANISM-ACCESSOR ((pop maximizing-score-mixin)) #'min-organism) (defmethod BEST-ORGANISM ((pop maximizing-score-mixin)) (max-organism (statistics pop))) (defmethod WORST-ORGANISM ((pop maximizing-score-mixin)) (min-organism (statistics pop))) ;;; Methods for minimizing-score-mixin (defmethod MAXIMIZING-P ((pop minimizing-score-mixin)) nil) (defmethod MINIMIZING-P ((pop minimizing-score-mixin)) t) (defmethod BETTER-THAN-TEST ((pop minimizing-score-mixin)) #'<) (defmethod AS-GOOD-AS-TEST ((pop minimizing-score-mixin)) #'<=) (defmethod CONVERGENCE-FRACTION ((pop minimizing-score-mixin)) 0.95) (defmethod CONVERGENCE-THRESHOLD-MARGIN ((pop minimizing-score-mixin)) 0.05) (defmethod BEST-ORGANISM ((pop minimizing-score-mixin)) #'min-organism) (defmethod WORST-ORGANISM ((pop minimizing-score-mixin)) #'max-organism)