Programmer 7500/MAX_PROGRAMMERS.iso/CLIPPER/MISC/AIE9009.ZIP/METAMORF.LSP

Text File | 1990-08-14 | 21.1 KB | 762 lines

;;;
;;; METAMORPH CODE BY SCOTT AUSTIN
;;; AS PUBLISHED IN THE AUGUST 1990 ISSUE OF AI EXPERT
;;; COPYRIGHT (c) 1990 BY SCOTT AUSTIN AND AI EXPERT
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; LOADMETA IS THE FUNCTION TO LOAD THE
;;; FILES CONTAINING THE VARIOUS METAMORPH FUNCTIONS.
;;;

(DEFUN LOADMETA ()
   (LOAD "ALPHABETS")
   (LOAD "RANDOM-FUNCTIONS")
   (LOAD "POPULATION-FUNCTIONS")
   (LOAD "SELECTION-FUNCTIONS")
   (LOAD "FITNESS-FUNCTIONS")
   (LOAD "BINARY-FUNCTIONS")
   (LOAD "REPRO-FUNCTIONS")
   (LOAD "MATING-LISTS-FUNCTIONS")
   (LOAD "ADJUSTCNT-FUNCTIONS")
   (LOAD "STRATEGY-FUNCTIONS")
   (LOAD "EVOLVER-FUNCTIONS")
   (LOAD "VARIATION-FUNCTIONS")
   (LOAD "CRSOVR-FUNCTIONS-1")
   (LOAD "CRSOVR-FUNCTIONS-2")
   (LOAD "MUTATE-FUNCTIONS")
   (LOAD "SUPPORT")
   (LOAD "DISPLAY"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; METAMORPH IS THE MAIN FUNCTION. INIT-FUNCTIONS  FILE CONTAINS
;;; THE PARAMETER INITILIZATION LISTS, PLOT-SETUP IS THE
;;; GRAPHING INITILIZATION FUNCTION, INITIAL-GENERATION  IS
;;; THE FUNCTION WHICH CONTROLS THE CREATION OF THE
;;; RANDOMLY GENERATED INITIAL POPULATION. SELECTION AND
;;;VARIATION ARE FUNCTIONS WHICH CONTAIN THE GENETIC
;;; OPERATORS OF EVALUATION, CROSSOVER AND MUTATION. PLOT
;;; EVOLUTION AND NEW-GEN-LIST  ARE THE FUNCTIONS WHICH PLOT
;;; THE POPULATION EVOLUTIONAL HISTORY, AND CREATES THE
;;; POPULATION LIST FOR THE NEXT GENERATION
;;;

(DEFUN METAMORPH ()
   (LOAD "INIT-FUNCTIONS")
   (PLOT-SETUP)
   (INITIAL-GENERATION POPULATION-PARAMS)
   (CATCH 'EXIT
      (DOTIMES (GENCOUNT NUMGENS)
         (SELECTION GENCOUNT POPULATION-LIST EVALPOP-PARAMS ATTRIBUTESLIST)
         (VARIATION GENCOUNT FITNESSLIST STRATEGY-PARAMS
          CROSSOVER-PARAMS MUTATE-PARAMS POP-SIZE CHROMOSOME-LENGTH ATTRIBUTESLIST)
         (PLOT-EVOLUTION GENCOUNT)
         (NEW-GEN-LIST GENCOUNT POP-SIZE SURVIVORSLIST MUTATED-EVOLVERS ATTRIBUTESLIST))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; INITIALIZATION LISTS AND PARAMETERS
;;;

(SETF ATTRIBUTESLIST NIL)

;;;

(SETF FITNESSLIST NIL)

;;;

(SETF GENHISTORYLIST NIL)

;;;

(SETF TOTAL-CROSSOVERS 0)

;;;

(SETF CROSSOVER-PARAMS (LIST 'RANDOM 0.7))

;;;

(SETF TOTAL-MUTATIONS 0)

;;;

(SETF MUTATE-PARAMS (LIST 0.01 SIMPLE-BINARY))

;;;

(SETF NUMGENS 10)

;

(SETF POPULATION-PARAMS (LIST 20 14 SIMPLE-BINARY))
;
; LIST SYNTAX IS <POP-SIZE> <STRING-LENGTH> <ALPHABET>
;

;;;

(SETF EBC-LIST (LIST 'XNTH XNTHLIST))

;;;

(SETF EVALPOP-PARAMS (LIST 'EVAL-BINARY-CHROMOSOMES EBC-LIST))

;;;
;;; STRATEGY-PARAMS LIST CONTAINS THE SELECTION PARAMETERS
;;;

(SETF STRATEGY-PARAMS (LIST 'ELITIST 0.9))
;
; LIST SYNTAX IS <SELECTION STRATEGY> <GENERATION GAP>
;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; FUNCTIONS TO GENERATE INITIAL POPULATION
;;;

(DEFUN INITIAL-GENERATION (POP-PARAMS)
   (APPLY 'FUNCALL 'MAKE-RANDOM-POPULATION POP-PARAMS))

;;;
;;; MAKE-RANDOM-POPULATION GENERATES A
;;; RANDOM POPULATION OF STRINGS  WHERE THE
;;; USER SPECIFIES THE POPULATION-SIZE, STRING-LENGTH AND ALPHABET
;;;

(DEFUN MAKE-RANDOM-POPULATION (POPULATION-SIZE STRING-LENGTH ALPHABET
 &OPTIONAL ALPHA-PARAMETERS)
   (SETF POP-SIZE POPULATION-SIZE)
   (SETF POPULATION-LIST NIL)
   (DOTIMES (COUNT POP-SIZE)
      (PUSH (CONS COUNT (MAKE-RANDOM-STRING STRING-LENGTH ALPHABET ALPHA-PARAMETERS))
                      POPULATION-LIST))
         (SETF POPULATION-LIST (REVERSE POPULATION-LIST)))

;;;
;;; MAKE-RANDOM-STRING GENERATES A RANDOM
;;; STRING OF TOKENS WHERE THE LENGTH AND
;;; ALPHABET ARE USER SPECIFIED
;;;

(DEFUN MAKE-RANDOM-STRING (STRING-LENGTH ALPHABET &OPTIONAL ALPHA-PARAMETERS)
   (SETF RANDOM-STRING NIL)
   (SETF CHROMOSOME-LENGTH STRING-LENGTH)
   (DOTIMES (COUNT STRING-LENGTH)
      (PUSH (MAKE-RANDOM-TOKEN ALPHABET  ALPHA-PARAMETERS) RANDOM-STRING))
           RANDOM-STRING)

;;;
;;; MAKE-RANDOM-TOKEN GENERATES A RANDOM
;;; TOKEN FROM A USER SUPPLIED ALPHABET
;;;

(DEFUN MAKE-RANDOM-TOKEN (ALPHABET &OPTIONAL ALPHA-PARAMETERS)
   (IF (LISTP ALPHABET)
          (SECOND (ASSOC (RANDOM (LENGTH ALPHABET))ALPHABET))
      (APPLY 'FUNCALL ALPHABET ALPHA- PARAMETERS)))

;;;
;;; SOME ALPHABETS
;;;
;;; ENGLISH ALPHABET
;;;

(SETQ ALPHA
   '((0 A) (1 B) (2 C) (3 D) (4 E) (5 F) (6 G) (7 H) (8 I) (9 J) (10 K)
     (11 L) (12 M) (13 N) (14 O) (15 P) (16 Q) (17 R) (18 S) (19 T) (20 U)
     (21 V) (22 W) (23 X) (24 Y) (25 Z) (26 _)))

;;;
;;; ELF IS A FUNCTION TO GENERATE ENGLISH LETTERS IN THE SAME
;;; PROPORTION AS THEY APPEAR IN THE LANGUAGE. THE LETTER "E"
;;; IS MOST COMMON AND APPEARS 12.62% OF THE TIME OVER LONG
;;; SAMPLES OF TEXT. "Z" IS THE LEAST COMMON AND APPEARS ONLY
;;; .09% OF THE TIME.
;;;

(DEFUN ELF ()
   (SETQ NUM (RANDOM 0.1262))
   (COND
      ((<= NUM 9.0E-4) 'Z)
      ((<= NUM 0.0010) 'Q)
      ((<= NUM 0.0015) 'J)
      ((<= NUM 0.0019) 'X)
      ((<= NUM 0.0065) 'K)
      ((<= NUM 0.0099) 'V)
      ((<= NUM 0.0154) 'B)
      ((<= NUM 0.0172) 'Y)
      ((<= NUM 0.0189) 'W)
      ((<= NUM 0.0195) 'G)
      ((<= NUM 0.0203) 'P)
      ((<= NUM 0.0234) 'F)
      ((<= NUM 0.0254) 'M)
      ((<= NUM 0.0272) 'U)
      ((<= NUM 0.0311) 'C)
      ((<= NUM 0.0395) 'D)
      ((<= NUM 0.0411) 'L)
      ((<= NUM 0.0551) 'H)
      ((<= NUM 0.0615) 'R)
      ((<= NUM 0.0650) 'S)
      ((<= NUM 0.0711) 'N)
      ((<= NUM 0.0734) 'I)
      ((<= NUM 0.0761) 'A)
      ((<= NUM 0.0765) 'O)
      ((<= NUM 0.0933) 'T)
      ((<= NUM 0.1262) 'E)))

;;;
;;; EWF IS A FUNCTION FOR GENERATING THE 26 MOST COMMONLY
;;; USED ENGLISH WORDS ACCORDING TO THE FREQUENCY THEY
;;; APPEAR IN LARGE SAMPLES OF ENGLISH TEXT.
;;;

(DEFUN EWF ()
   (SETQ NUM (RANDOM 0.07))
   (COND
      ((<= NUM 0.0044) 'FROM)
      ((<= NUM 0.0045) 'BUT)
      ((<= NUM 0.0046) 'ARE)
      ((<= NUM 0.0047) 'NOT)
      ((<= NUM 0.0050) 'HAD)
      ((<= NUM 0.0051) 'THIS)
      ((<= NUM 0.0052) 'I)
      ((<= NUM 0.0053) 'BY)
      ((<= NUM 0.0054) 'AT)
      ((<= NUM 0.0064) 'BE)
      ((<= NUM 0.0067) 'ON)
      ((<= NUM 0.0070) 'HIS)
      ((<= NUM 0.0073) 'AS)
      ((<= NUM 0.0074) 'WITH)
      ((<= NUM 0.0088) 'IT)
      ((<= NUM 0.0095) 'FOR)
      ((<= NUM 0.0096) 'HE)
      ((<= NUM 0.0098) 'WAS)
      ((<= NUM 0.0101) 'IS)
      ((<= NUM 0.0106) 'THAT)
      ((<= NUM 0.0213) 'IN)
      ((<= NUM 0.0232) 'A)
      ((<= NUM 0.0261) 'TO)
      ((<= NUM 0.0289) 'AND)
      ((<= NUM 0.0364) 'OF)
      ((<= NUM 0.0700) 'THE)))

;;;
;;; BINARY ALPHABET
;;;

(SETF SIMPLE-BINARY '((0 0) (1 1)))

;;;
;;; AUGMENTED BINARY ALPAHBET
;;;

(SETF BINARYPLUS '((0 0) (1 1) (2 *)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SELECTION FUNCTIONS
;;;

(DEFUN FIND-FITNESS (POPLIS EVAL-PARAMS)
   (SETF EVAL-FUNCTION (FIRST EVAL-PARAMS))
   (SETF EVAL-FUNC-PARMS (CONS POPLIS (SECOND EVAL-PARAMS)))
   (APPLY 'FUNCALL EVAL-FUNCTION EVAL-FUNC-PARMS))

;;;

(DEFUN NUM-EVOLVERS (POPSIZE GAPFACT)
   (IF (EQUAL GAPFACT 1) (SETQ NUMTOEVOLVE POPSIZE)
      (SETQ NUMTOEVOLVE (FLOOR (* POPSIZE GAPFACT)))))

;;;

(DEFUN GET-SURVIVORS (NUMEVOL POPSIZE FITLIS)
   (SETF SURVIVORSLIST NIL)
   (SETF NUM-SURVIVORS (- POPSIZE NUMEVOL))
   (GET-MOST-FIT POPULATION-LIST MOSTFIT)
   (PUSH MOSTFITLIS SURVIVORSLIST)
   (MAKE-SURVIVORS-POOL FITLIS)
   (GET-SURVIVOR-STRINGS NUM-SURVIVORS SURV-POOL)
   (SETF SURVIVORSLIST (REVERSE SURVIVORSLIST)))

;;;

(DEFUN GET-MOST-FIT (POPLIS MOSFIT)
   (SETF MOSTFITSYMBOL (FIRST MOSFIT))
   (SETF MOSTFITTAG (LIST MOSTFITSYMBOL (THIRD MOSFIT)))
   (SETF MOSTFITSTRING (CDR (ASSOC MOSTFITSYMBOL POPULATION-LIST)))
   (SETF MOSTFITLIS (LIST MOSTFITSTRING MOSTFITTAG)))

;;;

(DEFUN MAKE-SURVIVORS-POOL (FITLIS)
   (SETF SANS-BEST (CDR FITLIS))
   (SETF SANS-WORST (CDR (REVERSE SANS-BEST)))
   (SETF SURV-POOL (REVERSE SANS-WORST)))

;;;

(DEFUN GET-SURVIVOR-STRINGS (NUMSURV SURVPOOL)
   (SETF TEMPSURV SURVPOOL)
   (DOTIMES (COUNT1 (- NUM-SURVIVORS 1))
      (SETF SURVELEMENT (NTH COUNT1 SURV-POOL))
      (SETF SURVSYMBOL (FIRST SURVELEMENT))
      (SETF SURVIVORTAG (LIST SURVSYMBOL 'SURVIVOR))
      (SETF SURVSTRING (CDR (ASSOC SURVSYMBOL POPULATION-LIST)))
      (SETF SURVLIS (LIST SURVSTRING SURVIVORTAG))
      (PUSH SURVLIS SURVIVORSLIST)))

;;;

(DEFUN GET-EVOLVERS (REPROLIST POPSIZE)
   (SETF TEMPREPRO REPROLIST)
   (SETF EVOLVERS NIL)
   (DOTIMES (COUNT1 POPSIZE)
      (SETF REPELM (POP TEMPREPRO))
      (IF (NOT (EQUAL (SECOND REPELM) 0))
             (PUSH REPELM EVOLVERS))))

;;;

(DEFUN GET-CHROMOSOME-SYMBOLS (POPLIST)
   (SETF SYMBOLSLIST (MAPCAR 'FIRST POPLIST)))

;;;

(DEFUN GET-CHROMOSOMES (POPLIST)
   (SETF CHROMOLIST (MAPCAR 'CDR POPLIST)))

;;;

(DEFUN GET-CHROMOSOME-LENGTH (CHROLIS)
   (SETF CHROMOLENGTH (LENGTH (FIRST CHROLIS))))

;;;

(DEFUN APPLY-EVALUATION-FUNCTION (NOMLIST FUNC FUNCTIONLIST)
   (SETF TEMPNORMLIST NOMLIST)
   (SETF FITNESSLIST NIL)
   (SETF TEMPFUNCLIST FUNCTIONLIST)
   (DOTIMES (COUNT1 (LENGTH NOMLIST))
      (RPLACA TEMPFUNCLIST (POP TEMPNORMLIST))
      (PUSH (LIST (APPLY 'FUNCALL FUNC TEMPFUNCLIST) COUNT1) FITNESSLIST))
   (SETF FITNESSLIST
      (SORT FITNESSLIST #'> :KEY
         '(LAMBDA (X)
            (CAR X))))
   (SETF FITNESSLIST (MAPCAR 'REVERSE FITNESSLIST))
   (MOSTFITSYMBOL FITNESSLIST)
   (LEASTFITSYMBOL FITNESSLIST))

;;;

(DEFUN MOSTFITSYMBOL (FITLIS)
   (SETF MOSTFIT (CONS-LAST (FIRST FITLIS) 'MOSTFIT)))

;;;

(DEFUN LEASTFITSYMBOL (FITLIS)
   (SETF LEASTFIT (CONS-LAST (CAR (LAST FITLIS)) 'LEASTFIT)))

;;;

(DEFUN TERM-CRITERIA (FITLIS)
   (IF (EQUAL (SECOND (FIRST FITLIS)) 1.0)
         (THROW 'EXIT 'GOAL)))

;;;
;;; EVALUATION FUNCTIONS
;;;

(DEFUN EVAL-BINARY-CHROMOSOMES (POPLIS FUNC FUNCTIONLIST)
   (PARSE-POP-LIST POPLIS)
   (NORM-TO-MAX CHROMOLIST)
   (APPLY-EVALUATION-FUNCTION NORMLIST FUNC FUNCTIONLIST))

;;;

(DEFUN PARSE-POP-LIST (POPLIST)
   (GET-CHROMOSOME-SYMBOLS POPLIST)
   (GET-CHROMOSOMES POPLIST)
   (GET-CHROMOSOME-LENGTH CHROMOLIST))

;;;
;;;
;;;

(DEFUN NORM-TO-MAX (CHROMOS)
   (MAXINTEGER CHROMOLENGTH)
   (SETF INTEGERVALS (MAPCAR 'MAKE-INTEGER CHROMOS))
   (SETF NORMLIST
      (MAPCAR
       '(LAMBDA (INTVAL
                              (FLOAT (/ INTVAL MAXINTVAL)) INTEGERVALS)))

;;;

(DEFUN MAXINTEGER (CHROMOSOMELENGTH)
   (SETF MAXINTVAL (- (EXPT 2 CHROMOSOMELENGTH) 1)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; VARIATION FUNCTIONS
;;;

(DEFUN VARIATION (GENCNT FITLIS STRAT-PARAMS CRSOVR-PARAMS MUTA-PARAMS POPSIZE
                                           CHROMOLEN ATTRIBSLIS)
   (PARSE-FITLIS FITNESSLIST)
   (REPRODUCE FITNESS STRATEGY-PARAMS POPSIZE)
   (APPLYCROSSOVER CRSOVR-PARAMS POPULATION-LIST MATES-LIST CHROMOLEN)
   (SETF EVOLVERSLIST (APPEND NOCROSSLIST EVOLVERSLIST))
   (APPLYMUTATION MUTA-PARAMS EVOLVERSLIST))

;;;

(DEFUN PARSE-FITLIS (FITLIS)
   (SETF FITNESS-ORDER (MAPCAR 'FIRST FITLIS))
   (SETF FITNESS (MAPCAR 'SECOND FITLIS)))

;;;
;;; REPRODUCTION FUNCTIONS
;;;

(DEFUN REPRODUCE (FITNES STRATEGY-PARAMS POPSIZE)
   (MAKE-REPRO-POOL FITNES POPSIZE STRATEGY-PARAMS)
   (GET-EVOLVERS REPRO-LIST POPSIZE)
   (MAKE-MATES-LIST EVOLVERS POPSIZE))


;;;
;;; REPRO-LIST HAS STRUCTURE ((<STRING#> <REPRO-CNT>)...)
;;;

(DEFUN MAKE-REPRO-POOL (FITNES POPSIZE STRATEGY-PARAMS)
   (SETF REPRO-LIST NIL)
   (LIST-AVERAGE FITNES)
   (PROBSELECT FITNES)
   (EXPECTED-COUNT FITNES AVGFITNESS)
   (SELECTION-STRATEGY FITNESSLIST EXPECTED-COUNT-LIST POPSIZE STRATEGY-PARAMS)
   (ADJUST-COUNT ACTUAL-COUNT-LIST NUMTOEVOLVE)
   (SETF TEMPCNT ACTUAL-COUNT-LIST)
   (DOTIMES (COUNT1 POPSIZE)
      (PUSH (LIST COUNT1 (POP TEMPCNT)) REPRO-LIST))
   (SETF REPRO-LIST (REVERSE REPRO-LIST)))

;;;

(DEFUN LIST-AVERAGE (FITNES)
   (SETF AVGFITNESS (/ (SUM-LIST FITNES) (LENGTH FITNES))))

;;;
;;; PROBSELECT COMPUTES THE STRING BY STRING SELECTION PROBABILITIES GIVEN
;;; THE FITNESS LIST
;;;

(DEFUN PROBSELECT (FITNES)
   (SETF PSELECT-LIST NIL)
   (SETF LISTSUM (SUM-LIST FITNES))
   (SETF TEMPFIT-LIST FITNES)
   (DOTIMES (COUNT1 (LENGTH FITNES))
      (PUSH (/ (POP TEMPFIT-LIST) LISTSUM) PSELECT-LIST))
   (SETF PSELECT-LIST (REVERSE PSELECT-LIST)))

;;;
;;; GIVEN THE FITNESSLIST THE FUNCTION AND AVERAGE FITNESS EXPECTED-COUNT
;;; COMPUTES THE EXPECTED NUMBER OF TIMES A STRING SHOULD BE REPRODUCED
;;;

(DEFUN EXPECTED-COUNT (FITNES AVGFIT)
   (SETF TEMPLIST FITNES)
   (SETF EXPECTED-COUNT-LIST NIL)
   (DOTIMES (COUNT1 (LENGTH FITNES))
      (PUSH (/ (POP TEMPLIST) AVGFIT) EXPECTED-COUNT-LIST))
   (SETF EXPECTED-COUNT-LIST (REVERSE EXPECTED-COUNT-LIST)))

;;;

(DEFUN SELECTION-STRATEGY (FITLIS EXPCNTLIST POPSIZE STRATEGY-PARAMS)
   (SETF STRATEGY (FIRST STRATEGY-PARAMS))
   (SETF GAPFACTOR (SECOND STRATEGY-PARAMS))
   (IF (EQUAL STRATEGY 'PURE) (PURE-STRATEGY EXPCNTLIST POPSIZE)
      (ELITIST-STRATEGY FITLIS EXPCNTLIST POPSIZE GAPFACTOR)))

;;;

(DEFUN PURE-STRATEGY (EXPCNTLIST POPSIZE)
   (SETF NUMTOEVOLVE POPSIZE)
   (SETF ACTUAL-COUNT-LIST (RNDEDCNT EXPCNTLIST)))

;;;

(DEFUN RNDEDCNT (EXPCNTLIST)
   (MAPCAR 'ROUND EXPCNTLIST))


;;;

(DEFUN ELITIST-STRATEGY (FITLIS EXPCNTLST POPSIZE GAPFACT)
   (NUM-EVOLVERS POPSIZE GAPFACT)
   (GET-SURVIVORS NUMTOEVOLVE POPSIZE FITLIS)
   (SETF ACTUAL-COUNT-LIST
      (RNDEDCNT
         (MAPCAR
            '(LAMBDA (X)
               (* X GAPFACT))
            EXPCNTLST))))


;;;
;;; THE ACTUAL REPRODUCTION COUNT IS COMPUTED BY ROUNDING THE EXPECTED
;;; COUNT TO THE NEAREST INTEGER. NOTE THAT THIS MAY YIELD A NEW POPULATION
;;; SIZE SLIGHTLY LARGER OR SMALLER THAN THE ACTUAL SIZE, THIS MAY REQUIRE
;;; ADJUSTING THE POPULATION CORRESPONDINGLY UP OR DOWN TO KEEP IT
;;; CONSTANT.  SUM-LIST IS A SUPPORT FUNCTION
;;;

(DEFUN ADJUST-COUNT (ACTCNTLIS NUMEVL)
   (SETF LISTCNT '0)
   (SETF NUMELEMENTS (SUM-LIST ACTCNTLIS))
   (IF (< NUMELEMENTS NUMTOEVOLVE)
         (ADJUSTUP NUMELEMENTS ACTCNTLIS NUMEVL))
   (IF (> NUMELEMENTS NUMEVL)
         (ADJUSTDOWN NUMELEMENTS ACTCNTLIS NUMEVL)))

;;;

(DEFUN ADJUSTUP (NUMELM CNTLIS POPSIZE)
   (SETF SIZEDIF (- POPSIZE NUMELM))
   (DOTIMES (COUNT1 SIZEDIF)
      (RPLACNTH CNTLIS (+ 1 (NTH COUNT1 CNTLIS)) COUNT1)))

;;;

(DEFUN ADJUSTDOWN (NUMELM CNTLIS POPSIZE)
   (SETF LISUM NUMELM)
   (SETF ELEMENTVAL (NTH LISTCNT CNTLIS))
   (IF (= ELEMENTVAL 0)
          (SKIP-VALUE))
   (IF (> ELEMENTVAL 0)
          (DECREMENT-VALUE CNTLIS LISTCNT))
   (SETF SIZEDIF (- LISUM POPSIZE))
   (IF (>= SIZEDIF 1)
         (ADJUSTDOWN LISUM CNTLIS POPSIZE)))

;;;

(DEFUN SKIP-VALUE ()
   (IF (EQUAL ELEMENTVAL '0)
         (SETF LISTCNT (+ 1 LISTCNT))) LISTCNT)

;;;

(DEFUN DECREMENT-VALUE (CNTLIS ELEMENTCNT)
   (RPLACNTH CNTLIS (- ELEMENTVAL 1) ELEMENTCNT)
   (SETF LISTCNT (+ 1 LISTCNT))
   (SETF LISUM (- LISUM 1)))

;;;

(DEFUN MAKE-MATES-LIST (EVLVRS POPSIZE)
   (SETF MATES-LIST NIL)
   (SETF TEMPREPRO EVLVRS)
   (SETF LENEVOLVERS (LENGTH EVLVRS))
   (DOTIMES (COUNT1 LENEVOLVERS)
      (SETF REPROELEMENT (POP TEMPREPRO))
      (SETF FIRSTPARENT (FIRST REPROELEMENT))
      (SETF REPROCNT (SECOND REPROELEMENT))
      (SELECT-MATE FIRSTPARENT REPROCNT POPSIZE)))

;;;
;;; SELECT-MATE SELECTS A MATE GIVEN THE FIRST PARENT AND THE REPRODUCTION
;;; SIZE. MATE SELECTION IS FROM THE PREVIOUS GENERATION. NOT-SAME-NUMBER IS
;;; A SUPPORT FUNCTION
;;;

(DEFUN SELECT-MATE (FIRSTPAR REPRO-CNT POPSIZE)
   (DOTIMES (COUNT2 REPRO-CNT)
      (SETF SECONDPARENT (NOT-SAME-NUMBER FIRSTPAR POPSIZE))
      (PUSH (LIST FIRSTPAR SECONDPARENT) MATES-LIST)))


;;;
;;; CROSSOVER FUNCTIONS
;;;
;;; THE FOLLOWING FUNCTIONS PERFORM THE SPLITTING AND
;;; FUSING OF STRING STRUCTURES ASSOCIATED WITH THE
;;; CROSSOVER GENETIC OPERATOR. AFTER THE PARENT STRINGS
;;; HAVE CROSSED OVER OFFSPRING1 IS KEPT FOR THE
;;; NEXT GENERATION
;;;;

(DEFUN APPLYCROSSOVER (CRSPARAMS POPLIST MATESLIST STRINGLENGTH)
   (SETF LOCUS (FIRST CRSPARAMS))
   (SETF PROBCRSOVR (SECOND CRSPARAMS))
   (CROSSOVER LOCUS PROBCRSOVR POPLIST MATESLIST
     STRINGLENGTH))

;;;

(DEFUN CROSSOVER (LOCUS PCROSS POPLIST MATESLIST STRINGLENGTH)
   (SETF TEMPMATES MATESLIST)
   (SETF NOCROSS NIL)
   (SETF NUMEVOLV (LENGTH MATESLIST))
   (SETF EVOLVERSLIST NIL)
   (DOTIMES (COUNT1 NUMEVOLV)
      (SETF PARS (POP TEMPMATES))
      (CROSSOVERTEST LOCUS PCROSS PARS)))

;;;

(DEFUN CROSSOVERTEST (LOCUS PCROSS PARENTS)
   (IF (PROBCROSS PCROSS)
         (CROSSOVERFUNC LOCUS PARENTS)
         (PUSH PARENTS NOCROSS))
   (GET-NONCROSSERS NOCROSS POPULATION-LIST))

;;;

(DEFUN GET-NONCROSSERS (NOCROS POPLIS)
   (SETF NOCROSSLIST NIL)
   (DOTIMES (COUNT1 (LENGTH NOCROS))
      (SETF NOCRSER (FIRST (POP NOCROS)))
      (SETF NOCRSSTRING (CDR (ASSOC NOCRSER POPLIS)))
      (PUSH (LIST NOCRSSTRING (LIST NOCRSER 'NOCROSSOVER))
                  NOCROSSLIST)))

;;;

(DEFUN CROSSOVERFUNC (LOCUS PARENTS)
   (IF (NUMBERP LOCUS)
         (SETF CROSSOVER-LOCUS LOCUS)
         (RANDOM-CROSSOVER-LOCUS CHROMOSOME-LENGTH))
   (GET-PARENT-STRINGS POPULATION-LIST PARENTS)
   (SETF PARENTS-LOCUS (CONS-LAST PARENTS CROSSOVER-LOCUS))
   (SPLIT-STRING CROSSOVER-LOCUS PARENT1)
   (SETF FORE1 FOREPART)
   (SETF AFT1 AFTPART)
   (SPLIT-STRING CROSSOVER-LOCUS PARENT2)
   (SETF FORE2 FOREPART)
   (SETF AFT2 AFTPART)
   (SETF OFFSPRING1 (FUSESTRINGS FORE1 AFT2))
   (SETF OFFSPRING2 (FUSESTRINGS FORE2 AFT1))
   (SETF OFFSPRING OFFSPRING1)
   (SETF OFFSPRINGLIST (LIST OFFSPRING PARENTS-LOCUS))
   (PUSH OFFSPRINGLIST EVOLVERSLIST))


;;;
;;; PROBCROSS IS A FUNCTION WHICH TAKES THE USER SPECIFIED
;;; CROSSOVER PROBABILITY "PCROSS" AND COMPARES THAT WITH A
;;; UNIFORMLY GENERATED RANDOM NUMBER "CROSSPROB" TO
;;; DETERMINE IF CROSSOVER SHOULD OCCUR, THE CROSSOVER
;;; COUNTER IS INCREMENTED BY 1 IF CROSSOVER IS TO TAKE PLACE.
;;;

(DEFUN PROBCROSS (PCROSS)
   (SETF CROSSPROB (RANDOM 1.0))
   (IF (< CROSSPROB PCROSS)
          (SETF TOTAL-CROSSOVERS (+ 1 TOTAL-CROSSOVERS)))
   (< CROSSPROB PCROSS))

;;;
;;; RANDOM-CROSSOVER-LOCUS IS THE FUNCTION TO RANDOMLY
;;; GENERATE THE CROSSOVER POINT GIVEN THE LENGTH OF THE
;;; STRING, CROSSOVER IS CONSTRAINED TO OCCUR BETWEEN THE
;;; FIRST AND LAST SITES EXCLUSIVELY I.E. (0 < CROSS-OVER-LOCUS < L),
;;; WHERE L IS THE STRING LENGTH AND SITES ARE NUMBERED FROM 0.
;;;

(DEFUN RANDOM-CROSSOVER-LOCUS (STRINGLENGTH)
   (SETF CROSSOVER-LOCUS (RANDOM STRINGLENGTH))
   (IF (= 0 CROSSOVER-LOCUS)
          (RANDOM-CROSSOVER-LOCUS STRINGLENGTH)))

;;;

(DEFUN GET-PARENT-STRINGS (POPLIST PARENTS)
   (SETF PARENT1 (CDR (ASSOC (FIRST PARENTS) POPLIST)))
   (SETF PARENT2 (CDR (ASSOC (SECOND PARENTS) POPLIST))))

;;;
;;; SPLIT-STRING IS A FUNCTION TO SPLIT THE STRING AT THE
;;; CROSSOVER POINT WHICH CAN BE EITHER RANDOMLY CHOSEN OR
;;; USER SPECIFIED.
;;;

(DEFUN SPLIT-STRING (LOCUS STRING)
   (SETF FOREPART (BUTTAIL STRING LOCUS))
   (SETF AFTPART (NTHCDR LOCUS STRING)))

;;;

(DEFUN FUSESTRINGS (FORE AFT)
   (APPEND FORE AFT))

;;;
;;; MUTATION FUNCTIONS
;;;
;;;
;;; MUTATE-POPULATION APPLIES THE MUTATE-A-STRING FUNCTION TO THE MUTATING
;;; POPULATION
;;;

(DEFUN APPLYMUTATION (MUTA-PARAMS EVLSLIS)
   (SETF PMUTE (FIRST MUTA-PARAMS))
   (SETF ALPHABET (SECOND MUTA-PARAMS))
   (MUTATE-POPULATION EVLSLIS PMUTE ALPHABET))

;;;

(DEFUN MUTATE-POPULATION (POPULATION PMUTATE ALPHABET)
   (SETF MUTATED-EVOLVERS NIL)
   (SETF RANK-ORDER (MAPCAR 'CADR POPULATION))
   (SETF CHROMOSOMES (MAPCAR 'CAR POPULATION))
   (SETF MUTANTCNT 0)
   (DOTIMES (COUNT1 (LENGTH POPULATION))
      (SETF TEMPCHROMO (POP CHROMOSOMES))
      (SETF MUTATEDSTRING (MUTATE-A-STRING TEMPCHROMO PMUTATE ALPHABET))
      (PUSH (LIST MUTATEDSTRING (POP RANK-ORDER)) MUTATED-EVOLVERS)))

;;; MUTATE-A-STRING TAKES AN OBJECT STRING, THE MUTATION PROBABILITY AND THE
;;; USER SPECIFIED ALPHABET AND SUPPLIES ALTERNATE CHARACTERS FOR THE SITES
;;; WHERE THE MUTATE FUNCTION IS NON-NIL
;;;

(DEFUN MUTATE-A-STRING (OBJECT-STRING PMUTATE ALPHABET)
   (SETF TEMPOBJECT (COPY-LIST OBJECT-STRING))
   (SETF TEMP-STRING OBJECT-STRING)
   (DOTIMES (COUNT1 (LENGTH OBJECT-STRING))
      (SETF TOKEN (POP TEMP-STRING))
      (IF (PROBMUTATE PMUTATE)
         (RPLACNTH TEMPOBJECT (NOT-SAME-TOKEN TOKEN ALPHABET) COUNT1)))
   TEMPOBJECT)

;;;

(DEFUN PROBMUTATE (PMUTATE)
   (SETF MUTATEPROB (RANDOM 1.0))
   (IF (< MUTATEPROB PMUTATE) (SETF MUTANTCNT (+ 1 MUTANTCNT)))
        (< MUTATEPROB PMUTATE))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(DEFUN NEW-GEN-LIST (GENCNT POPSIZE SURVLIS EVOLIS ATTRIBSLIS)
   (SETF POPULATION-LIST NIL)
   (SETF NEWGENLIS (APPEND SURVLIS EVOLIS))
   (SETF NEWPOPLIS (MAPCAR 'FIRST NEWGENLIS))
   (SETF POPATSLIS (MAPCAR 'SECOND NEWGENLIS))
   (DOTIMES (COUNT1 POPSIZE)
      (PUSH (CONS COUNT1 (POP NEWPOPLIS)) POPULATION-LIST)
      (PUSH (CONS COUNT1 (POP POPATSLIS)) ATTRIBUTESLIST))
   (SETF POPULATION-LIST (REVERSE POPULATION-LIST))
   (SETF ATTRIBUTESLIST (REVERSE ATTRIBUTESLIST)))

;;;
;;; END OF SOURCE CODE
;;;