Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Genetic algorithm at work

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • 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/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
    Last edited by Erik Christensen; 22 Mar 2008, 06:46 PM. Reason: Minor inconsistencies corrected

  • #2
    At this link there you can obtain a source code in C and an EXE-file to demonstrate the traveling salesman problem being solved using a genetic algorithm:

    http://www.generation5.org/content/2001/tspapp.asp

    Interesting to see the operation of the program.

    Comment


    • #3
      Genetic Algorithms in PB-DOS

      FYI, I did my PhD a few years back on the use of Genetic Algorithms in aircraft design, and did all my work in PB-DOS. My thesis is at http://www.aircraftdesign.com/Raymer...lRevLowRes.pdf

      Cheers!

      Dan Raymer
      www.aircraftdesign.com

      Comment

      Working...
      X