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 demonstration

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

  • Genetic algorithm demonstration

    ' This very simple code demonstrates genetic algorithms, which are inspired by the principles
    ' operating in evolution: random mutation and selection of the fittest individuals in the
    ' population. This program uses only these principles and shows that randomness (cross-over, mutation)
    ' combined with selection can increase order in a system
    '
    ' The following link provides an overview:
    ' http://en.wikipedia.org/wiki/Genetic_algorithm
    '
    '
    ' Genetic algorithms are implemented as a computer simulation in which a population of abstract
    ' representations (called chromosomes or the genotype or the genome) of candidate solutions (called
    ' individuals, creatures, or phenotypes) to an optimization problem evolves toward better solutions.
    ' Traditionally, solutions are represented in binary as strings of 0s and 1s, but other encodings are
    ' also possible. The evolution usually starts from a population of randomly generated individuals and
    ' happens in generations. In each generation, the fitness of every individual in the population is
    ' evaluated, multiple individuals are stochastically selected from the current population (based on
    ' their fitness), and modified (recombined and possibly randomly mutated) to form a new population.
    ' The new population is then used in the next iteration of the algorithm. Commonly, the algorithm
    ' terminates when either a maximum number of generations has been produced, or a satisfactory
    ' fitness level has been reached for the population. If the algorithm has terminated due to a maximum
    ' number of generations, a satisfactory solution may or may not have been reached.
    '
    ' Genetic algorithms find application in bioinformatics, phylogenetics, computer science,
    ' engineering, economics, chemistry, manufacturing, mathematics, physics and other fields."
    '
    Pseudo-code algorithm
    Code:
    Choose initial population 
    Evaluate the fitness of each individual in the population 
    Repeat 
            Select best-ranking individuals to reproduce 
    	Breed new generation through crossover and mutation (genetic operations) and give birth to offspring 
    	Evaluate the individual fitnesses of the offspring 
    	Replace worst ranked part of population with offspring 
    Until termination
    ' Demo Genetic Algorithm Code
    ' PROGRAM Genetic
    ' Originally coded in Fortran 90 by Philip Brierley
    ' http://www.philbrierley.com/code.html
    '
    ' The following code is included as a demonstration of a genetic algorithm optimisation procedure. The subroutine
    ' CALCSUITABILITY determines the 'performance' of each candidate solution on which the tournament selection
    ' procedure is based in the subroutine BREED. In this particular example the more identical adjacent bits in
    ' the string the better the suitability. Each bit can have values of 0,1,2 or 3
    '
    ' Try to experiment with number of generations, contestants, cross-over probability and mutation probability.
    '
    ' Translated to Powerbasic Win8X by
    '
    ' Erik Christensen -------- February 26, 2008
    Code:
    ' This very simple code demonstrates genetic algorithms, which are inspired by the principles
    ' operating in evolution: random mutation and selection of the fittest individuals in the
    ' population. This program uses only these principles and shows that randomization combined with
    ' selection can increase order in a system
    '
    ' The following link provides an overview:
    ' http://en.wikipedia.org/wiki/Genetic_algorithm
    '
    ' quote:
    ' "Genetic algorithms are implemented as a computer simulation in which a population of abstract
    ' representations (called chromosomes or the genotype or the genome) of candidate solutions (called
    ' individuals, creatures, or phenotypes) to an optimization problem evolves toward better solutions.
    ' Traditionally, solutions are represented in binary as strings of 0s and 1s, but other encodings are
    ' also possible. The evolution usually starts from a population of randomly generated individuals and
    ' happens in generations. In each generation, the fitness of every individual in the population is
    ' evaluated, multiple individuals are stochastically selected from the current population (based on
    ' their fitness), and modified (recombined and possibly randomly mutated) to form a new population.
    ' The new population is then used in the next iteration of the algorithm. Commonly, the algorithm
    ' terminates when either a maximum number of generations has been produced, or a satisfactory
    ' fitness level has been reached for the population. If the algorithm has terminated due to a maximum
    ' number of generations, a satisfactory solution may or may not have been reached.
    '
    ' Genetic algorithms find application in bioinformatics, phylogenetics, computer science,
    ' engineering, economics, chemistry, manufacturing, mathematics, physics and other fields."
    '
    ' Demo Genetic Algorithm Code
    ' PROGRAM Genetic
    ' Originally coded in Fortran 90 by Philip Brierley
    ' http://www.philbrierley.com/code.html
    '
    ' The following code is included as a demonstration of a genetic algorithm optimisation procedure. The subroutine
    ' CALCSUITABILITY determines the 'performance' of each candidate solution on which the tournament selection
    ' procedure is based in the subroutine BREED. In this particular example the more identical adjacent bits in
    ' the string the better the suitability. Each bit can have values of 0,1,2 or 3
    '
    ' Translated to Powerbasic Win8X by
    '
    ' Erik Christensen -------- February 26, 2008
    '
    #COMPILE EXE
    #DIM ALL
    
    #INCLUDE "WIN32API.INC"
    
    %IDC_BUTTON1  = 1004
    %IDC_BUTTON2  = 1005
    %IDC_LABEL1   = 1002
    %IDC_LABEL2   = 1003
    %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  Worst      Best     " + _
            "Average     String with most identical adjacent bits", 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
        CONTROL ADD LABEL,   hDlg, %IDC_LABEL2, "Latest string with most identical adjacent bits: ", 12, 192, 404, 12
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
        FUNCTION = lRslt
    END FUNCTION
    '
    SUB CALCSUITABILITY(BYREF PARENT() AS LONG, BYREF SUITABILITY() AS LONG, BYVAL POPSIZE AS LONG, BYVAL STRINGSIZE AS LONG)
        LOCAL I AS LONG, J AS LONG
        MAT SUITABILITY() = ZER
        FOR I=1 TO POPSIZE
            FOR J=1 TO STRINGSIZE-1
                IF (PARENT(I,J)=PARENT(I,J+1)) THEN INCR SUITABILITY(I) 'based on adjacent bits being the same
            NEXT J
        NEXT I
    END SUB
    '
    SUB BREED(BYREF SUITABILITY() AS LONG, BYREF PARENT() AS LONG, BYVAL ProbCross AS SINGLE, BYVAL ProbMut AS SINGLE, BYVAL CONTESTANTS AS LONG, BYVAL POPSIZE AS LONG, BYVAL STRINGSIZE AS LONG)
    
        DIM SON(POPSIZE,STRINGSIZE) AS LOCAL LONG     'next generation
        DIM POTENTIAL_DAD(CONTESTANTS) AS LOCAL LONG  'potential parents
        DIM DAD(2,STRINGSIZE) AS LOCAL LONG           'array for 2 chosen parents
        LOCAL I AS LONG, J AS LONG, K AS LONG, M AS LONG, N AS LONG, IWINNER AS LONG, ICROSSPOS AS LONG, W AS LONG
    
        FOR I=1 TO POPSIZE      'each mating results in only 1 offspring
    
            '' choose two parents ''
            FOR J=1 TO 2
                '
                FOR K=1 TO CONTESTANTS          'randomly select contestants
                    POTENTIAL_DAD(K)=RND(1, POPSIZE)
                NEXT K
                '
                FOR K = 1 TO STRINGSIZE
                    DAD(J, K)=PARENT(POTENTIAL_DAD(1), K)     'first assumes the throne
                NEXT K
                IWINNER=SUITABILITY(POTENTIAL_DAD(1))
    
                FOR M=2 TO CONTESTANTS          'tournament begins
                    W = SUITABILITY(POTENTIAL_DAD(M))
                    IF (W > IWINNER) THEN
                        IWINNER = W
                        FOR K = 1 TO STRINGSIZE
                            DAD(J, K)=PARENT(POTENTIAL_DAD(M), K)
                        NEXT K
                    END IF
                NEXT M
    
            NEXT J                   'two parents chosen
    
            '' create an offspring ''
            IF (RND()<ProbCross) THEN           'probability of crossover
                ICROSSPOS=RND(1, STRINGSIZE-1)
                FOR K = 1 TO ICROSSPOS
                    SON(I, K)=DAD(1, K)
                NEXT K
                FOR K = ICROSSPOS+1 TO STRINGSIZE
                    SON(I, K)=DAD(2,K)
                NEXT K
            ELSE
                FOR K = 1 TO STRINGSIZE
                    SON(I, K)=DAD(1, K)       'one parent replicates into next generation
                NEXT K
            END IF
    
            ''mutate the offspring ''
            FOR N=1 TO STRINGSIZE
                IF (RND()<ProbMut) THEN     'probability of mutation
                   SON(I,N)=RND(0, 3)
                END IF
            NEXT N
    
        NEXT I
        '
        MAT PARENT() = SON()                  'the offspring become the next generation
    
    END SUB
    '
    CALLBACK FUNCTION ShowDIALOG1Proc()
    
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
                ' Initialization handler
                '' set up some user defined parameters ''
                STATIC STRINGSIZE AS LONG, POPSIZE AS LONG, GENERATIONS AS LONG, CONTESTANTS AS LONG
                STATIC ProbMut AS SINGLE, ProbCross AS SINGLE
                STATIC I AS LONG, J AS LONG, K AS LONG, M AS LONG, N AS LONG
                STATIC s AS STRING, t AS STRING
                STATIC MINVAL AS LONG, MAXVAL AS LONG, SUM AS LONG
    
                GENERATIONS=1000    'number of generations before stopping
                POPSIZE=20          'number of strings in each generation
                STRINGSIZE=31       'number of bits in each string
                CONTESTANTS=3       'no of contestants in tournament selection
                ProbMut=0.01        'mutation probability
                ProbCross=0.8       'crossover probability
    
                '' declare arrays ''
                DIM PARENT(POPSIZE,STRINGSIZE) AS STATIC LONG
                DIM SUITABILITY(1 TO POPSIZE) AS STATIC LONG      ''fitness' of each parent
                DIM Indx(1 TO POPSIZE) AS STATIC LONG  ' the lower bound for SUITABILITY() and Indx() should be sxplicitly set to 1
                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
                            LISTBOX RESET CBHNDL, %IDC_LISTBOX1
    
                            '' generate an initial population ''
                            FOR I=1 TO POPSIZE
                                FOR J=1 TO STRINGSIZE
                                    PARENT(I,J)=RND(0, 3) 'create a string of 0's, 1's, 2's and 3's
                                NEXT
                            NEXT
                            ' generate an index for computational use
                            FOR K = 1 TO POPSIZE
                                Indx(K) = K
                            NEXT
    
                            '' start the process ''
                            FOR I=1 TO GENERATIONS
                                '
                                '' suitability of each individual string ''
                                CALL CALCSUITABILITY(PARENT(), SUITABILITY(), POPSIZE, STRINGSIZE)
                                '
                                ' get current results for output to textbox and label
                                ARRAY SORT SUITABILITY(), TAGARRAY Indx() ' easy way to obtain MAX and MIN values
                                MINVAL = SUITABILITY(1) : MAXVAL = SUITABILITY(POPSIZE) : SUM = 0
                                FOR K = 1 TO POPSIZE
                                    SUM = SUM + SUITABILITY(K)
                                NEXT
                                t = ""
                                FOR K = 1 TO STRINGSIZE
                                    t = t + TRIM$(STR$(PARENT(Indx(POPSIZE),K))) ' Get best string. Position is at Indx(POPSIZE)
                                NEXT
                                ' Establish original sequence of SUITABILITY() and Indx() arrays
                                ' This is important in SUB BREED and subsequent calculations
                                ARRAY SORT Indx(), TAGARRAY SUITABILITY() ' recreates original sequence of SUITABILITY() and Indx() arrays
                                '
                                s = STR$(I)+$TAB+STR$(MINVAL)+$TAB+STR$(MAXVAL)+$TAB+STR$(SUM/POPSIZE)+$TAB+t
                                LISTBOX ADD CBHNDL, %IDC_LISTBOX1, s
                                ' scroll to display last results
                                CONTROL SEND CBHNDL,%IDC_LISTBOX1, %LB_GETCOUNT, 0, 0 TO N
                                CONTROL SEND CBHNDL, %IDC_LISTBOX1, %LB_SETTOPINDEX, N-1, 0
                                CONTROL SET TEXT CBHNDL, %IDC_LABEL2, "Latest string with most identical adjacent bits: " + t
                                '
                                '' create new generation ''
                                CALL BREED(SUITABILITY(),PARENT(),ProbCross,ProbMut,CONTESTANTS,POPSIZE, STRINGSIZE)
                            NEXT I
                        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; 27 Feb 2008, 10:16 AM. Reason: More explanation and slight simplification of code

  • #2
    ' Genetic algorithm demonstration version 2. This version has an improved
    ' suitability evaluation: In addition to counting the number of identical
    ' adjacent bits in the string, it also gives the string with the longest
    ' uniform sequence at any one time an extra bonus point. This improves
    ' optimisation. Even with as few as 500 generations you may obtain a
    ' completely uniform string.
    '
    ' You are still using the same randomness as before, but the suitability
    ' function is improved. This leads to an improved selection of the best
    ' individuals and this is the reason for the faster change in the population.
    '
    ' If you increase the number of contestants you may see even faster changes
    ' in the population.
    '
    ' Best regards,
    '
    ' Erik Christensen -------- February 28, 2008
    Code:
    ' Genetic algorithm demonstration version 2. This version has an improved
    ' suitability evaluation: In addition to counting the number of identical
    ' adjacent bits in the string, it also gives the string with the longest
    ' uniform sequence at any one time an extra bonus point. This improves
    ' optimisation. Even with as few as 500 generations you may obtain a
    ' completely uniform string.
    '
    ' You are still using the same randomness as before, but the suitability
    ' function is improved. This leads to an improved selection of the best
    ' individuals and this is the reason for the faster change in the population.
    '
    ' If you increase the number of contestants you may see even faster changes
    ' in the population.
    '
    ' Best regards, :)
    '
    ' Erik Christensen  -------- February 28, 2008
    '
    #COMPILE EXE
    #DIM ALL
    
    #INCLUDE "WIN32API.INC"
    
    %IDC_BUTTON1  = 1004
    %IDC_BUTTON2  = 1005
    %IDC_LABEL1   = 1002
    %IDC_LABEL2   = 1003
    %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  Worst      Best     " + _
            "Average     String with most identical adjacent bits", 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
        CONTROL ADD LABEL,   hDlg, %IDC_LABEL2, "Latest string with most identical adjacent bits: ", 12, 192, 404, 12
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
        FUNCTION = lRslt
    END FUNCTION
    '
    FUNCTION MaxUniformSequenceLength(BYREF PARENT() AS LONG, BYVAL I AS LONG, BYVAL STRINGSIZE AS LONG) AS LONG
        LOCAL J AS LONG, K AS LONG, LE AS LONG, MAXL AS LONG
        K = PARENT(I,1) : LE = 1 : J = 2
        DO
            IF PARENT(I,J) = K THEN
                INCR LE
            ELSE
                K = PARENT(I,J) : LE = 1
            END IF
            MAXL = MAX(MAXL, LE) : INCR J
        LOOP UNTIL J > STRINGSIZE
        FUNCTION = MAXL
    END FUNCTION
    '
    SUB CALCSUITABILITY(BYREF PARENT() AS LONG, BYREF SUITABILITY() AS LONG, BYVAL POPSIZE AS LONG, BYVAL STRINGSIZE AS LONG)
        LOCAL I AS LONG, J AS LONG, MAXS AS LONG, K AS LONG, MAXLMAX AS LONG, MAXL AS LONG
        MAT SUITABILITY() = ZER
        FOR I=1 TO POPSIZE
            FOR J=1 TO STRINGSIZE-1
                IF (PARENT(I,J)=PARENT(I,J+1)) THEN INCR SUITABILITY(I) 'based on adjacent bits being the same
            NEXT J
            MAXS = MAX(MAXS, SUITABILITY(I))
        NEXT I
        ' Among strings with most adjacent bits being the same, perform an extra suitability evaluation:
        ' Find the string with the longest uniform sequence length.
        J = 0
        FOR I=1 TO POPSIZE
            IF SUITABILITY(I) = MAXS THEN
                MAXL = MaxUniformSequenceLength(PARENT(), I, STRINGSIZE)
                IF MAXL > MAXLMAX THEN MAXLMAX = MAXL : K = I
            END IF
        NEXT
        INCR SUITABILITY(K) ' The suitability of the string with the highest uniform sequence length is increased by one
    END SUB
    '
    SUB BREED(BYREF SUITABILITY() AS LONG, BYREF PARENT() AS LONG, BYVAL ProbCross AS SINGLE, BYVAL ProbMut AS SINGLE, BYVAL CONTESTANTS AS LONG, BYVAL POPSIZE AS LONG, BYVAL STRINGSIZE AS LONG)
    
        DIM SON(POPSIZE,STRINGSIZE) AS LOCAL LONG     'next generation
        DIM POTENTIAL_DAD(CONTESTANTS) AS LOCAL LONG  'potential parents
        DIM DAD(2,STRINGSIZE) AS LOCAL LONG           'array for 2 chosen parents
        LOCAL I AS LONG, J AS LONG, K AS LONG, M AS LONG, N AS LONG, IWINNER AS LONG, ICROSSPOS AS LONG, W AS LONG
    
        FOR I=1 TO POPSIZE      'each mating results in only 1 offspring
    
            '' choose two parents ''
            FOR J=1 TO 2
                '
                FOR K=1 TO CONTESTANTS          'randomly select contestants
                    POTENTIAL_DAD(K)=RND(1, POPSIZE)
                NEXT K
                '
                FOR K = 1 TO STRINGSIZE
                    DAD(J, K)=PARENT(POTENTIAL_DAD(1), K)     'first assumes the throne
                NEXT K
                IWINNER=SUITABILITY(POTENTIAL_DAD(1))
    
                FOR M=2 TO CONTESTANTS          'tournament begins
                    W = SUITABILITY(POTENTIAL_DAD(M))
                    IF (W > IWINNER) THEN
                        IWINNER = W
                        FOR K = 1 TO STRINGSIZE
                            DAD(J, K)=PARENT(POTENTIAL_DAD(M), K)
                        NEXT K
                    END IF
                NEXT M
    
            NEXT J                   'two parents chosen
    
            '' create an offspring ''
            IF (RND()<ProbCross) THEN           'probability of crossover
                ICROSSPOS=RND(1, STRINGSIZE-1)
                FOR K = 1 TO ICROSSPOS
                    SON(I, K)=DAD(1, K)
                NEXT K
                FOR K = ICROSSPOS+1 TO STRINGSIZE
                    SON(I, K)=DAD(2,K)
                NEXT K
            ELSE
                FOR K = 1 TO STRINGSIZE
                    SON(I, K)=DAD(1, K)       'one parent replicates into next generation
                NEXT K
            END IF
    
            ''mutate the offspring ''
            FOR N=1 TO STRINGSIZE
                IF (RND()<ProbMut) THEN     'probability of mutation
                   SON(I,N)=RND(0, 3)
                END IF
            NEXT N
    
        NEXT I
        '
        MAT PARENT() = SON()                  'the offspring become the next generation
    
    END SUB
    '
    CALLBACK FUNCTION ShowDIALOG1Proc()
    
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
                ' Initialization handler
                '' set up some user defined parameters ''
                STATIC STRINGSIZE AS LONG, POPSIZE AS LONG, GENERATIONS AS LONG, CONTESTANTS AS LONG
                STATIC ProbMut AS SINGLE, ProbCross AS SINGLE
                STATIC I AS LONG, J AS LONG, K AS LONG, M AS LONG, N AS LONG
                STATIC s AS STRING, t AS STRING
                STATIC MINVAL AS LONG, MAXVAL AS LONG, SUM AS LONG
    
                GENERATIONS=500     'number of generations before stopping
                POPSIZE=20          'number of strings in each generation (size of the population)
                STRINGSIZE=31       'number of bits in each string (no. of "genes" in each individual)
                CONTESTANTS=3       'no of contestants in tournament selection for mating
                ProbMut=0.01        'mutation probability
                ProbCross=0.8       'crossover probability
    
                '' declare arrays ''
                DIM PARENT(POPSIZE,STRINGSIZE) AS STATIC LONG
                DIM SUITABILITY(1 TO POPSIZE) AS STATIC LONG      ''fitness' of each parent
                DIM Indx(1 TO POPSIZE) AS STATIC LONG  ' the lower bound for SUITABILITY() and Indx() should be sxplicitly set to 1
                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
                            LISTBOX RESET CBHNDL, %IDC_LISTBOX1
    
                            '' generate an initial population ''
                            FOR I=1 TO POPSIZE
                                FOR J=1 TO STRINGSIZE
                                    PARENT(I,J)=RND(0, 3) 'create a string of 0's, 1's, 2's and 3's
                                NEXT
                            NEXT
                            ' generate an index for computational use
                            FOR K = 1 TO POPSIZE
                                Indx(K) = K
                            NEXT
    
                            '' start the process ''
                            FOR I=1 TO GENERATIONS
                                '
                                '' suitability of each individual string ''
                                CALL CALCSUITABILITY(PARENT(), SUITABILITY(), POPSIZE, STRINGSIZE)
                                '
                                ' get current results for output to listbox and label
                                ARRAY SORT SUITABILITY(), TAGARRAY Indx() ' easy way to obtain MAX and MIN values
                                MINVAL = SUITABILITY(1) : SUM = 0
                                MAXVAL = SUITABILITY(POPSIZE) - 1 ' MAXVAL is decreased by one to adjust for the addition by one
                                                                  ' in SUB CALCSUITABILITY to the string with the best suitability
                                
                                FOR K = 1 TO POPSIZE
                                    SUM = SUM + SUITABILITY(K)
                                NEXT
                                t = "" : DECR SUM                 ' SUM is decreased by one for the same reason as above
                                FOR K = 1 TO STRINGSIZE
                                    t = t + TRIM$(STR$(PARENT(Indx(POPSIZE),K))) ' Get best string. Position is at Indx(POPSIZE)
                                NEXT
                                ' Recreate original sequence of SUITABILITY() and Indx() arrays
                                ' This is important in SUB BREED and for subsequent calculations
                                ARRAY SORT Indx(), TAGARRAY SUITABILITY()
                                '
                                s = STR$(I)+$TAB+STR$(MINVAL)+$TAB+STR$(MAXVAL)+$TAB+STR$(SUM/POPSIZE)+$TAB+t
                                LISTBOX ADD CBHNDL, %IDC_LISTBOX1, s
                                ' scroll to display last results
                                CONTROL SEND CBHNDL,%IDC_LISTBOX1, %LB_GETCOUNT, 0, 0 TO N
                                CONTROL SEND CBHNDL, %IDC_LISTBOX1, %LB_SETTOPINDEX, N-1, 0
                                CONTROL SET TEXT CBHNDL, %IDC_LABEL2, "Latest string with most identical adjacent bits: " + t
                                '
                                '' create new generation ''
                                CALL BREED(SUITABILITY(),PARENT(),ProbCross,ProbMut,CONTESTANTS,POPSIZE, STRINGSIZE)
                            NEXT I
                        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; 28 Feb 2008, 05:12 PM.

    Comment

    Working...
    X