Genetic algorithm demonstration

Erik Christensen replied

28 Feb 2008, 03:53 PM

' 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, 04:12 PM.

' 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, 09:16 AM. Reason: More explanation and slight simplification of code

Tags: None

Previous template Next

Announcement

Forum Guidelines

Genetic algorithm demonstration

Leave a comment:

Genetic algorithm demonstration