Tweet
' 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
'
'
Pseudo-code algorithm
' 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
' 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."
'
' 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."
'
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
' 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
Comment