' 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

## Leave a comment: