' This is a PowerBasic translation I have made of a Genetic Algorithm
' program in BASIC for DOS made by David A. Coley.
' The original program is available at this link:
'
' http://www.centres.ex.ac.uk/cee/ga/LGADOS.BAS
'
' The program has been written to accompany David A. Coley's fine book:
' "An Introduction to Genetic Algorithms for 'Scientists and Engineers",
' World Scientific 1998.
'
' Besides crossover and mutation this program can apply elitism
' and selection proportional to fitness ("roulettewheel selection").
'
' In the present simple illustrative version of the program the
' particular problem to be solved by the genetic algorithm is to
' maximize the function f = x^2 + sin(y) (see SUB FindFitness)
' for the following intervals: x (0 to 1) and y (-PI to PI)
' (see SUB DefineRange). The program will very fast approach the
' optimal values for x: 1 and y: PI/2 = 1.57079. This simple problem,
' which may easily be solved directly using simple mathematics,
' only serves to illustrate the method. Other more complex problems,
' which may not be solved so easily in a simple direct way e.g. the
' Traveling Salesman Problem (TSP), can be solved using
' the genetic algorithm by adapting the subroutines mentioned above
' and some other parts of the program (including
' SUB DisplayGeneration) to the problem at hand.
'
' Best regards
'
' Erik Christensen ---------- March 22, 2008
'
' P.S. See also the simple genetic algorithm demonstration program
' in this thread: http://www.powerbasic.com/support/pb...ad.php?t=36549
' program in BASIC for DOS made by David A. Coley.
' The original program is available at this link:
'
' http://www.centres.ex.ac.uk/cee/ga/LGADOS.BAS
'
' The program has been written to accompany David A. Coley's fine book:
' "An Introduction to Genetic Algorithms for 'Scientists and Engineers",
' World Scientific 1998.
'
' Besides crossover and mutation this program can apply elitism
' and selection proportional to fitness ("roulettewheel selection").
'
' In the present simple illustrative version of the program the
' particular problem to be solved by the genetic algorithm is to
' maximize the function f = x^2 + sin(y) (see SUB FindFitness)
' for the following intervals: x (0 to 1) and y (-PI to PI)
' (see SUB DefineRange). The program will very fast approach the
' optimal values for x: 1 and y: PI/2 = 1.57079. This simple problem,
' which may easily be solved directly using simple mathematics,
' only serves to illustrate the method. Other more complex problems,
' which may not be solved so easily in a simple direct way e.g. the
' Traveling Salesman Problem (TSP), can be solved using
' the genetic algorithm by adapting the subroutines mentioned above
' and some other parts of the program (including
' SUB DisplayGeneration) to the problem at hand.
'
' Best regards

'
' Erik Christensen ---------- March 22, 2008
'
' P.S. See also the simple genetic algorithm demonstration program
' in this thread: http://www.powerbasic.com/support/pb...ad.php?t=36549
Code:
' Genetic algorithm at work ' ' This is a PowerBasic translation I have made of a Genetic Algorithm ' program in BASIC for DOS made by David A. Coley. ' The original program is available at this link: ' ' http://www.centres.ex.ac.uk/cee/ga/LGADOS.BAS ' ' The program has been written to accompany David A. Coley's fine book: ' "An Introduction to Genetic Algorithms for 'Scientists and Engineers", ' World Scientific 1998. ' ' Besides crossover and mutation this program can apply elitism ' and selection proportional to fitness ("roulettewheel selection"). ' ' In the present simple illustrative version of the program the ' particular problem to be solved by the genetic algorithm is to ' maximize the function f = x^2 + sin(y) (see SUB FindFitness) ' for the following intervals: x (0 to 1) and y (-PI to PI) ' (see SUB DefineRange). The program will very fast approach the ' optimal values for x: 1 and y: PI/2 = 1.57079. This simple problem, ' which may easily be solved directly using simple mathematics, ' only serves to illustrate the method. Other more complex problems, ' which may not be solved so easily in a simple direct way e.g. the ' Traveling Salesman Problem (TSP), can be solved using ' the genetic algorithm by adapting the subroutines mentioned above ' and some other parts of the program (including ' SUB DisplayGeneration) to the problem at hand. ' ' Best regards ' ' Erik Christensen ---------- March 22, 2008 ' ' P.S. See also the simple genetic algorithm demonstration program ' in this thread: http://www.powerbasic.com/support/pbforums/showthread.php?t=36549 ' #COMPILE EXE #DIM ALL #INCLUDE "WIN32API.INC" %IDC_BUTTON1 = 1004 %IDC_BUTTON2 = 1005 %IDC_LABEL1 = 1002 %IDC_LISTBOX1 = 1006 %IDD_DIALOG1 = 101 ' FUNCTION PBMAIN() LOCAL lRslt AS LONG LOCAL hDlg AS DWORD DIALOG NEW %HWND_DESKTOP, "Genetic Algorithm Demonstration", 70, 70, 429, 239, _ %WS_POPUP OR %WS_BORDER OR %WS_DLGFRAME OR %WS_CAPTION OR _ %WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_CLIPSIBLINGS OR %WS_VISIBLE OR _ %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR %DS_SETFONT, _ %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR %WS_EX_LTRREADING OR _ %WS_EX_RIGHTSCROLLBAR, TO hDlg CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "&Run Program", 148, 212, 128, 16 CONTROL ADD BUTTON, hDlg, %IDC_BUTTON2, "E&xit", 360, 212, 56, 16 CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "Generation"+$TAB+" Max Fitness"+$TAB+$TAB+ _ "MeanFitness"+$TAB+$TAB+"X"+$TAB+$TAB+"Y", 12, 12, 404, 12 CONTROL ADD LISTBOX, hDlg, %IDC_LISTBOX1, , 12, 24, 404, 164, %WS_CHILD _ OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_VSCROLL OR _ %LBS_NOTIFY OR %LBS_USETABSTOPS, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT OR _ %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt FUNCTION = lRslt END FUNCTION ' SUB CrossOver(BYREF Mate1 AS LONG, BYREF Mate2 AS LONG, BYREF NewIndividual AS LONG, _ BYVAL TotalStringLength AS LONG, BYREF NewStrings() AS LONG, BYREF Strings() AS LONG) 'Perform single point crossover. LOCAL CrossSite AS LONG, BitB AS LONG CrossSite = INT((TotalStringLength - 1) * RND + 1) 'Pick the cross-site at random. FOR BitB = 1 TO CrossSite 'Swap bits to the left of the cross-site. NewStrings(NewIndividual, BitB) = Strings(Mate1, BitB) NewStrings(NewIndividual + 1, BitB) = Strings(Mate2, BitB) NEXT BitB FOR BitB = CrossSite + 1 TO TotalStringLength 'Swap bits to the right of the cross-site. NewStrings(NewIndividual, BitB) = Strings(Mate2, BitB) NewStrings(NewIndividual + 1, BitB) = Strings(Mate1, BitB) NEXT BitB END SUB ' SUB DefineRange(BYREF Range() AS SINGLE) 'Defines the upper and lower bounds of each unknown. 'Add other ranges using the same format if more than two unknowns in the problem. LOCAL Unknown AS LONG Unknown = 1 'the first unknown. Range(1, Unknown) = 0 'The lower bound. Range(2, Unknown) = 1 'The upper bound. Unknown = 2 'the second unknown. Range(1, Unknown) = -3.14159 Range(2, Unknown) = 3.14159 'Add other ranges if more than two unknowns in your problem. END SUB ' SUB Elite(BYREF SumFitness AS SINGLE, BYREF FittestIndividual AS LONG, BYREF Fitness() AS SINGLE, _ BYREF EliteFitness AS SINGLE, BYREF EliteString() AS LONG, BYREF EliteIntegers() AS LONG, _ BYREF EliteUnknowns() AS SINGLE, BYREF Strings() AS LONG, BYREF Integers() AS LONG, _ BYREF Unknowns() AS SINGLE, BYVAL TotalStringLength AS LONG, BYVAL NumberOfUnknowns AS LONG, _ BYVAL PopulationSize AS LONG) LOCAL BitB AS LONG, Individual AS LONG, Unknown AS LONG 'Applies elitism by replacing a randomly chosen individual by the elite member 'from the previous population if the new max fitness is less then the previous value. IF Fitness(FittestIndividual) < EliteFitness THEN Individual = INT(PopulationSize * RND + 1) 'Chosen individual to be replaced. FOR BitB = 1 TO TotalStringLength Strings(Individual, BitB) = EliteString(BitB) NEXT BitB Fitness(Individual) = EliteFitness FOR Unknown = 1 TO NumberOfUnknowns Integers(Individual, Unknown) = EliteIntegers(Unknown) Unknowns(Individual, Unknown) = EliteUnknowns(Unknown) NEXT Unknown FittestIndividual = Individual END IF FOR BitB = 1 TO TotalStringLength EliteString(BitB) = Strings(FittestIndividual, BitB) NEXT BitB EliteFitness = Fitness(FittestIndividual) FOR Unknown = 1 TO NumberOfUnknowns EliteIntegers(Unknown) = Integers(FittestIndividual, Unknown) EliteUnknowns(Unknown) = Unknowns(FittestIndividual, Unknown) NEXT Unknown END SUB ' SUB FindFitness(BYVAL PopulationSize AS LONG, BYREF Fitness() AS SINGLE, BYREF Unknowns() AS SINGLE) LOCAL Individual AS LONG 'The problem at hand is used to assign a positive (or zero) fitness to each individual in turn. 'The problem is f = x^2 + sin(y). FOR Individual = 1 TO PopulationSize Fitness(Individual) = Unknowns(Individual, 1) ^ 2 + SIN(Unknowns(Individual, 2)) IF Fitness(Individual) < 0 THEN Fitness(Individual) = 0 NEXT Individual END SUB ' SUB FindIntegers(BYVAL PopulationSize AS LONG, BYVAL TotalStringLength AS LONG, BYVAL NumberOfUnknowns AS LONG, _ BYREF Integers() AS LONG, BYVAL SubstringLength AS LONG, BYREF Strings() AS LONG) 'Decode the strings to sets of decimal integers. DIM BitB AS LOCAL LONG LOCAL Individual AS LONG, Unknown AS LONG, StringBit AS LONG FOR Individual = 1 TO PopulationSize BitB = TotalStringLength + 1 FOR Unknown = NumberOfUnknowns TO 1 STEP -1 Integers(Individual, Unknown) = 0 FOR StringBit = 1 TO SubstringLength BitB = BitB - 1 IF Strings(Individual, BitB) = 1 THEN Integers(Individual, Unknown) = Integers(Individual, Unknown) + 2 ^ (StringBit - 1) END IF NEXT StringBit NEXT Unknown NEXT Individual END SUB ' SUB FindUnknowns(BYVAL PopulationSize AS LONG, BYVAL TotalStringLength AS LONG, BYVAL NumberOfUnknowns AS LONG, _ BYREF Integers() AS LONG, BYVAL SubstringLength AS LONG, BYREF Strings() AS LONG, _ BYREF Unknowns() AS SINGLE, BYREF Range() AS SINGLE) LOCAL Individual AS LONG, Unknown AS LONG 'Decode the strings to real numbers. 'First decode the strings to sets of decimal integers. CALL FindIntegers(PopulationSize, TotalStringLength, NumberOfUnknowns, Integers(), SubstringLength, Strings()) 'Now convert these integers to reals. FOR Individual = 1 TO PopulationSize FOR Unknown = 1 TO NumberOfUnknowns Unknowns(Individual, Unknown) = Range(1, Unknown) + Integers(Individual, Unknown) * (Range(2, Unknown) - Range(1, Unknown)) / (2 ^ SubstringLength - 1) NEXT Unknown NEXT Individual END SUB ' SUB InitialPopulation(BYVAL PopulationSize AS LONG, BYVAL TotalStringLength AS LONG, BYVAL NumberOfUnknowns AS LONG, _ BYREF Integers() AS LONG, BYVAL SubstringLength AS LONG, BYREF Strings() AS LONG, _ BYREF Unknowns() AS SINGLE, BYREF Range() AS SINGLE) 'Create the initial random population. LOCAL Individual AS LONG, BitB AS LONG FOR Individual = 1 TO PopulationSize FOR BitB = 1 TO TotalStringLength IF RND > .5 THEN Strings(Individual, BitB) = 1 ELSE Strings(Individual, BitB) = 0 END IF NEXT BitB NEXT Individual 'Decode strings to real numbers. CALL FindUnknowns(PopulationSize, TotalStringLength, NumberOfUnknowns, Integers(), SubstringLength, Strings(), Unknowns(), Range()) END SUB ' SUB Mutate(BYVAL PopulationSize AS LONG, BYVAL TotalStringLength AS LONG, BYREF NewStrings() AS LONG, _ BYVAL MutationProbability AS SINGLE) 'Visit each bit of each string very occasionally flipping a "1" to a "0" or vice versa. LOCAL Individual AS LONG, BitB AS LONG FOR Individual = 1 TO PopulationSize FOR BitB = 1 TO TotalStringLength 'Throw a random number and see if it is less than or equal to the mutation probability. IF RND <= MutationProbability THEN 'Mutate. IF NewStrings(Individual, BitB) = 1 THEN NewStrings(Individual, BitB) = 0 ELSE NewStrings(Individual, BitB) = 1 END IF END IF NEXT BitB NEXT Individual END SUB ' SUB NoCrossover (BYREF Mate1 AS LONG, BYREF Mate2 AS LONG, BYREF NewIndividual AS LONG, _ BYVAL TotalStringLength AS LONG, BYREF NewStrings() AS LONG, BYREF Strings() AS LONG) 'Pass the selected strings to the temporary population without applying crossover. LOCAL BitB AS LONG FOR BitB = 1 TO TotalStringLength NewStrings(NewIndividual, BitB) = Strings(Mate1, BitB) NewStrings(NewIndividual + 1, BitB) = Strings(Mate2, BitB) NEXT BitB END SUB ' SUB DisplayGeneration (BYVAL Generation AS LONG, BYVAL MeanFitness AS SINGLE, BYVAL FittestIndividual AS LONG, _ BYREF Fitness() AS SINGLE, BYVAL NumberOfUnknowns AS LONG, BYREF Unknowns() AS SINGLE, _ BYVAL PopulationSize AS LONG, BYREF Strings() AS LONG, BYVAL hCtl AS LONG) 'Display results on the screen. LOCAL s AS STRING, t AS STRING, Unknown AS LONG, N AS LONG s = LTRIM$(STR$(Generation))+$TAB+$TAB+LTRIM$(STR$(Fitness(FittestIndividual)))+$TAB+$TAB+LTRIM$(STR$(MeanFitness)) ' PRINT Generation; Fitness(FittestIndividual); MeanFitness; 'Screen. ' PRINT #1, Generation; ","; Fitness(FittestIndividual); ","; MeanFitness; 'File LGADOS.RES. FOR Unknown = 1 TO NumberOfUnknowns 'PRINT Unknowns(FittestIndividual, Unknown); 'Screen. 'PRINT #1, ","; Unknowns(FittestIndividual, Unknown); ","; 'File LGADOS.RES t = t + $TAB + $TAB + LTRIM$(STR$(Unknowns(FittestIndividual, Unknown))) NEXT Unknown LISTBOX ADD hCtl, %IDC_LISTBOX1, s + t ' scroll to display last results CONTROL SEND hCtl,%IDC_LISTBOX1, %LB_GETCOUNT, 0, 0 TO N CONTROL SEND hCtl, %IDC_LISTBOX1, %LB_SETTOPINDEX, N-1, 0 ' If you wish you can obtain the full information by adapting the following code: ' ' FOR Individual = 1 TO PopulationSize ' ' PRINT #2, Generation; ","; Fitness(Individual); ","; 'File LGADOS.ALL ' ' FOR Unknown = 1 TO NumberOfUnknowns ' PRINT #2, Unknowns(Individual, Unknown); ","; 'File LGADOS.ALL ' NEXT Unknown ' ' FOR BitB = 1 TO TotalStringLength ' PRINT #2, RIGHT$(STR$(Strings(Individual, BitB)), 1); ","; 'File LGADOS.ALL ' NEXT BitB ' ' PRINT #2, 'Carriage return ' ' NEXT Individual END SUB ' SUB ReplaceR(BYREF Strings() AS LONG, NewStrings() AS LONG) 'Replace the old population with the new one. 'FOR Individual = 1 TO PopulationSize ' FOR BitB = 1 TO TotalStringLength ' Strings(Individual, BitB) = NewStrings(Individual, BitB) ' NEXT BitB 'NEXT Individual 'ERASE NewStrings 'Clear the old array of strings. MAT Strings() = NewStrings() MAT NewStrings() = ZER END SUB ' SUB Scaling (BYVAL ScalingConstant AS SINGLE, BYVAL FittestIndividual AS LONG, BYREF SumFitness AS SINGLE, _ BYREF MeanFitness AS SINGLE, BYREF Fitness() AS SINGLE, BYVAL PopulationSize AS LONG) LOCAL a AS SINGLE, b AS SINGLE, Individual AS LONG 'Apply Linear Fitness Scaling, ' scaledfitness = a * fitness + b. 'Subject to, ' meanscaledfitness = meanfitness 'and ' bestscaledfitness = c * meanfitness, 'where c, the scaling constant, is set by the user. 'If the scaling constant is set to zero, or all individuals have the same 'fitness, scaling is not applied. IF ScalingConstant <> 0 AND Fitness(FittestIndividual) - MeanFitness > 0 THEN 'Find a and b. a = (ScalingConstant - 1) * MeanFitness / (Fitness(FittestIndividual) - MeanFitness) b = (1 - a) * MeanFitness 'Adjust the fitness of all members of the population. SumFitness = 0 FOR Individual = 1 TO PopulationSize Fitness(Individual) = a * Fitness(Individual) + b IF Fitness(Individual) < 0 THEN Fitness(Individual) = 0 'Avoid negative values near the end of a run. SumFitness = SumFitness + Fitness(Individual) 'Adjust the sum of all the fitnesses. NEXT Individual 'Adjust the mean of all the fitnesses. MeanFitness = SumFitness / PopulationSize END IF END SUB ' SUB Selection (BYREF mate AS LONG, BYREF SumFitness AS SINGLE, BYREF MeanFitness AS SINGLE, _ BYREF Fitness() AS SINGLE, PopulationSize AS LONG) 'Select a single individual by fitness proportional selection. LOCAL Sum AS SINGLE, Individual AS LONG, RouletteWheel AS SINGLE Sum = 0 Individual = 0 RouletteWheel = RND * SumFitness DO Individual = Individual + 1 Sum = Sum + Fitness(Individual) LOOP UNTIL Sum >= RouletteWheel OR Individual = PopulationSize mate = Individual END SUB ' SUB Statistics (BYREF MeanFitness AS SINGLE, BYREF SumFitness AS SINGLE, BYREF FittestIndividual AS LONG, BYVAL Generation AS LONG, _ BYREF Fitness() AS SINGLE, BYREF EliteFitness AS SINGLE, BYREF EliteString() AS LONG, BYREF EliteIntegers() AS LONG, _ BYREF EliteUnknowns() AS SINGLE, BYREF Strings() AS LONG, BYREF Integers() AS LONG, _ BYREF Unknowns() AS SINGLE, BYVAL TotalStringLength AS LONG, BYVAL NumberOfUnknowns AS LONG, BYVAL PopulationSize AS LONG, BYVAL Elitism AS STRING) 'Calculate the sum of fitness across the population and find the best individual, 'then apply elitism if required. LOCAL Individual AS LONG, MaxFitness AS LONG FittestIndividual = 0 MaxFitness = 0 FOR Individual = 1 TO PopulationSize IF Fitness(Individual) > MaxFitness THEN MaxFitness = Fitness(Individual) FittestIndividual = Individual END IF NEXT Individual IF Elitism = "on" THEN 'Apply elitism. CALL Elite(SumFitness, FittestIndividual, Fitness(), EliteFitness, EliteString(), _ EliteIntegers(), EliteUnknowns(), Strings(), Integers(), Unknowns(), _ TotalStringLength, NumberOfUnknowns, PopulationSize) END IF SumFitness = 0 'Sum the fitness. FOR Individual = 1 TO PopulationSize SumFitness = SumFitness + Fitness(Individual) NEXT Individual 'Find the average fitness of the population. MeanFitness = SumFitness / PopulationSize END SUB ' CALLBACK FUNCTION ShowDIALOG1Proc() SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG ' Initialization handler STATIC PopulationSize AS LONG, NumberOfUnknowns AS LONG, SubstringLength AS LONG, TotalStringLength AS LONG STATIC MaxGeneration AS LONG, CrossOverProbability AS SINGLE, MutationProbability AS SINGLE STATIC Elitism AS STRING, ScalingConstant AS SINGLE, NewIndividual AS LONG STATIC Generation AS LONG, MeanFitness AS SINGLE, SumFitness AS SINGLE, FittestIndividual AS LONG STATIC Mate1 AS LONG, Mate2 AS LONG '------- SET ALL THE IMPORTANT FIXED PARAMETERS. ------- 'These should be set by the user. PopulationSize = 20 'Must be even. NumberOfUnknowns = 2 SubstringLength = 12 'All sub-strings have the same length. TotalStringLength = NumberOfUnknowns * SubstringLength MaxGeneration = 400 'G. CrossOverProbability = .6 'Pc. >=0 and <=1. MutationProbability = 1 / TotalStringLength 'Pm, >=0 and <1. Elitism = "on" '"on" or "off". ScalingConstant = 1.2 'A value of 0 implies no scaling. '------DECLARE ALL STATIC ARRAY-VARIABLES---------- 'The arrays that hold the individuals within the current population. DIM Unknowns(PopulationSize, NumberOfUnknowns) AS STATIC SINGLE DIM Integers(PopulationSize, NumberOfUnknowns) AS STATIC LONG DIM Strings(PopulationSize, TotalStringLength) AS STATIC LONG DIM Fitness(PopulationSize) AS STATIC SINGLE 'The new population. DIM NewStrings(PopulationSize, TotalStringLength) AS STATIC LONG 'The array that defines the range of the unknowns. DIM Range(2, NumberOfUnknowns) AS STATIC SINGLE 'The best individual in the past generation. Used if elitism is on. DIM EliteString(TotalStringLength) AS STATIC LONG DIM EliteIntegers(NumberOfUnknowns) AS STATIC LONG DIM EliteFitness AS STATIC SINGLE DIM EliteUnknowns(NumberOfUnknowns) AS STATIC SINGLE CALL DefineRange(Range()) 'Define the range of each unknown. These should also be set by the user. 'Set the random number generator so it produces a different set of numbers 'each time the program is run. RANDOMIZE TIMER CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN ' Save control focus hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN ' Restore control focus SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_COMMAND ' Process control notifications SELECT CASE AS LONG CBCTL CASE %IDC_BUTTON1 ' run program IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN MAT EliteString() = ZER MAT EliteIntegers() = ZER EliteFitness = 0.0! MAT EliteUnknowns() = ZER LISTBOX RESET CBHNDL, %IDC_LISTBOX1 '------- START OF THE GENETIC ALGORITHM ------- '------- CREATE AN INITIAL POPULATION, GENERATION 1 ------ Generation = 1 'Build a population of strings at random. CALL InitialPopulation(PopulationSize, TotalStringLength, NumberOfUnknowns, Integers(), SubstringLength, Strings(), Unknowns(), Range()) 'Find the fitness of each member of the population. CALL FindFitness(PopulationSize, Fitness(), Unknowns()) 'Find the mean fitness and the fittest individual. CALL Statistics(MeanFitness, SumFitness, FittestIndividual, Generation, _ Fitness(), EliteFitness, EliteString(), EliteIntegers(), _ EliteUnknowns(), Strings(), Integers(), _ Unknowns(), TotalStringLength, NumberOfUnknowns, PopulationSize, Elitism) 'Display generation. CALL DisplayGeneration(Generation, MeanFitness, FittestIndividual, _ Fitness(), NumberOfUnknowns, Unknowns(), PopulationSize, _ Strings(), CBHNDL) 'If linear fitness scaling is "on" then scale population prior to selection. CALL Scaling(ScalingConstant, FittestIndividual, SumFitness, MeanFitness, _ Fitness(), PopulationSize) '------- LOOP OVER ALL THE GENERATIONS ------- FOR Generation = 2 TO MaxGeneration FOR NewIndividual = 1 TO PopulationSize STEP 2 'Loop over the population choosing pairs of mates. CALL Selection(Mate1, SumFitness, MeanFitness, Fitness(), PopulationSize) 'Choose first mate. CALL Selection(Mate2, SumFitness, MeanFitness, Fitness(), PopulationSize) 'Choose second mate. 'Pass individuals to the temporary population either with or without performing crossover. IF RND <= CrossOverProbability THEN 'Perform crossover. CALL CrossOver(Mate1, Mate2, NewIndividual, TotalStringLength, NewStrings(), Strings()) ELSE 'Don't perform crossover. CALL NoCrossover(Mate1, Mate2, NewIndividual, TotalStringLength, NewStrings(), Strings()) END IF NEXT NewIndividual 'Mutate the temporary population. CALL Mutate(PopulationSize, TotalStringLength, NewStrings(), MutationProbability) 'Replace the old population completely by the new one. CALL ReplaceR(Strings(), NewStrings()) 'De-code the new population to integers then real numbers. CALL FindUnknowns(PopulationSize, TotalStringLength, NumberOfUnknowns, Integers(), SubstringLength, Strings(), Unknowns(), Range()) 'Find the fitness of each member of the population. CALL FindFitness(PopulationSize, Fitness(), Unknowns()) 'Find the mean fitness and the fittest individual. CALL Statistics(MeanFitness, SumFitness, FittestIndividual, Generation, _ Fitness(), EliteFitness, EliteString(), EliteIntegers(), _ EliteUnknowns(), Strings(), Integers(), _ Unknowns(), TotalStringLength, NumberOfUnknowns, PopulationSize, Elitism) 'Display generation. CALL DisplayGeneration(Generation, MeanFitness, FittestIndividual, _ Fitness(), NumberOfUnknowns, Unknowns(), PopulationSize, _ Strings(), CBHNDL) 'If linear fitness scaling is "on" then scale population prior to selection. CALL Scaling(ScalingConstant, FittestIndividual, SumFitness, MeanFitness, _ Fitness(), PopulationSize) NEXT Generation 'Process the next generation. END IF CASE %IDC_BUTTON2 ' exit IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN DIALOG END CBHNDL END SELECT END SELECT END FUNCTION
Comment