The following code demonstrates a basic Genetic Algorithm that I had created whilst working on my thesis program. The programming language used is Microsoft's VBScript implemented in Rhinoceros 4. It has been further enhanced and modified as my thesis develops. Working drafts and snippets of the final code will be posted in turn.
Option Explicit
'Script written by Walid nazih | MSC10'11 | 2011
'(c) Walid Nazih. All rights reserved
Call GA()
Sub GA()
Randomize
Dim generation,Maxgens, pop
Dim Chromosome(),gene_length , words, word_length
Dim objects(),values
Dim Mom,Dad,DNAMOM,DNADAD
Dim mutationRate, successCount
Dim FitnessObj()
Dim Populationfitness ,GenerationFitness,Offspring1,Offspring2
Dim i,j
Dim FP,LP
Dim ALL
' -------- Get Integers ----------------------------
Maxgens = Rhino.Integerbox("How Many Generations", 6)
pop = Rhino.integerbox("How Many populations" , 6)
mutationRate = Rhino.Integerbox("Mutation Rate - Percentage %", 10 )
gene_length = 30 ' words * word_length
words = 6 ' give 6 integers between 0 and 31
word_length = 5
FP = 1 ' First population
LP = pop ' last population
'---------- build DNA population---------------------
For i = 1 To pop
ReDim Preserve Chromosome(pop)
Chromosome(i) = BuildDNA(gene_length)
Next
'---------loop through number of generations----------
For generation = 1 To Maxgens
ReDim Preserve objects(Maxgens,pop)
For i = 1 To pop
'--------- Decode genes ------------------------------
Values = Decode(Chromosome,words,word_length,i)
'---------- build objects / Get each population Fitness --------------
objects(generation,i) = build(Values, generation,i ,pop, FitnessObj)
Next
'----------- Fitness Population -------------------------------
Populationfitness = 0
For i = 1 To pop
Populationfitness = Populationfitness + FitnessObj(i)
Next
' --------------------Selection ---------------------
If generation <> Maxgens Then
mom = NaturalSelection(FitnessObj, pop)
dad = NaturalSelection(FitnessObj, pop)
DNADAD = chromosome(Dad)
DNAMOM = chromosome(mom)
'-------------------- Crossover -----------------------
For j = 1 To pop - 1 Step 2
Offspring1 = D_crossover ( DNADAD , DNAMOM , gene_length)
Offspring2 = M_crossover ( DNADAD , DNAMOM , gene_length)
'---------------- Mutation ------------------------
If Rnd() > mutationRate Then
chromosome (j) = Mutate (offspring1,gene_length)
chromosome (j+1) = Mutate (offspring2,gene_length)
Else
chromosome (j) = offspring1
chromosome (j+1) = offspring2
End If
Next
End If
Next
End Sub
'------------------------------------------------- MAKE DNA -----------------------------
Function BuildDNA(gene_length)
Dim gene , j
gene = ""
For j = 1 To gene_length
If Rnd < 0.5 Then
gene = gene + "1"
Else
gene = gene + "0"
End If
Next
'---------- build objects / Get each population Fitness --------------
objects(generation,i) = build(Values, generation,i ,pop, FitnessObj)
Next
'----------- Fitness Population -------------------------------
Populationfitness = 0
For i = 1 To pop
Populationfitness = Populationfitness + FitnessObj(i)
Next
' --------------------Selection ---------------------
If generation <> Maxgens Then
mom = NaturalSelection(FitnessObj, pop)
dad = NaturalSelection(FitnessObj, pop)
DNADAD = chromosome(Dad)
DNAMOM = chromosome(mom)
'-------------------- Crossover -----------------------
For j = 1 To pop - 1 Step 2
Offspring1 = D_crossover ( DNADAD , DNAMOM , gene_length)
Offspring2 = M_crossover ( DNADAD , DNAMOM , gene_length)
'---------------- Mutation ------------------------
If Rnd() > mutationRate Then
chromosome (j) = Mutate (offspring1,gene_length)
chromosome (j+1) = Mutate (offspring2,gene_length)
Else
chromosome (j) = offspring1
chromosome (j+1) = offspring2
End If
Next
End If
Next
End Sub
'------------------------------------------------- MAKE DNA -----------------------------
Function BuildDNA(gene_length)
Dim gene , j
gene = ""
For j = 1 To gene_length
If Rnd < 0.5 Then
gene = gene + "1"
Else
gene = gene + "0"
End If
Next
buildDNA = gene
End Function
'-----------------------------------------------Dcode Chromosome -------------------------
Function Decode(Chromosome,words,word_length,i)
Dim values()
Dim temp , pos , endpos
Dim j , k
For j = 1 To words
ReDim Preserve values(j)
temp = 0
endpos = j * word_length
'work backwards through string
For k = 0 To word_length - 1
pos = endpos - k
If Mid(Chromosome(i), pos, 1) = "1" Then temp = temp + 2 ^ k
Next
If temp = 0 Then temp = 1
values(j) = temp
Next
Decode = values
End Function
'-----------------------------------------------Dcode Chromosome -------------------------
Function Decode(Chromosome,words,word_length,i)
Dim values()
Dim temp , pos , endpos
Dim j , k
For j = 1 To words
ReDim Preserve values(j)
temp = 0
endpos = j * word_length
'work backwards through string
For k = 0 To word_length - 1
pos = endpos - k
If Mid(Chromosome(i), pos, 1) = "1" Then temp = temp + 2 ^ k
Next
If temp = 0 Then temp = 1
values(j) = temp
Next
Decode = values
End Function
'---------------------------------------------Build populations ---------------------------
Function build(Values, generation,i,pop,ByRef FitnessObj)
Dim object
Dim Array01
Dim objFit
Dim c
ReDim Preserve FitnessObj(i)
Array01 = Array (Array(0,0,0), Array(values(1),0,0),Array(values(1),values(2),0),Array(0,values(2),0),Array(0,0,values(3)),Array(values(1),0,values(4)),Array(values(1),values(2),values(5)),Array(0,values(2),values(6)))
object = Rhino.AddBox(Array01)
Rhino.MoveObject object, Array(0,0,0), Array (100*i, 100*generation , 0)
objFit = Rhino.SurfaceVolume(object)
FitnessObj(i) = objFit(0) 'the bigger the fittest
build = object
End Function
'------------------------------------------------------- roulette--------------------------------
Function roulette (FP,LP)
Dim Random
Random = Int((LP - FP + 1) * Rnd + FP)
roulette = Random
End Function
'--------------------------------------------------------- Crossover -------------------------------
Function D_crossover ( DNADAD , DNAMOM , gene_length)
Dim start , newdad, NLow,NHigh
NLow = 1
NHigh = gene_length
Randomize
start= Int((NHigh - NLow + 1) * Rnd + NLow)
newdad = left(DNADAD, start) + Mid(DNAMOM, start + 1)
D_crossover = newdad
End Function
'---------------------------------------------Build populations ---------------------------
Function build(Values, generation,i,pop,ByRef FitnessObj)
Dim object
Dim Array01
Dim objFit
Dim c
ReDim Preserve FitnessObj(i)
Array01 = Array (Array(0,0,0), Array(values(1),0,0),Array(values(1),values(2),0),Array(0,values(2),0),Array(0,0,values(3)),Array(values(1),0,values(4)),Array(values(1),values(2),values(5)),Array(0,values(2),values(6)))
object = Rhino.AddBox(Array01)
Rhino.MoveObject object, Array(0,0,0), Array (100*i, 100*generation , 0)
objFit = Rhino.SurfaceVolume(object)
FitnessObj(i) = objFit(0) 'the bigger the fittest
build = object
End Function
'------------------------------------------------------- roulette--------------------------------
Function roulette (FP,LP)
Dim Random
Random = Int((LP - FP + 1) * Rnd + FP)
roulette = Random
End Function
'--------------------------------------------------------- Crossover -------------------------------
Function D_crossover ( DNADAD , DNAMOM , gene_length)
Dim start , newdad, NLow,NHigh
NLow = 1
NHigh = gene_length
Randomize
start= Int((NHigh - NLow + 1) * Rnd + NLow)
newdad = left(DNADAD, start) + Mid(DNAMOM, start + 1)
D_crossover = newdad
End Function
Function M_crossover ( DNADAD , DNAMOM , gene_length)
Dim start,newmom , NLow,NHigh
NLow = 1
NHigh = gene_length
Randomize
start= Int((NHigh - NLow + 1) * Rnd + NLow)
newmom = left(DNAMOM, start) + Mid(DNADAD, start + 1)
M_crossover = newmom
End Function
'--------------------------------------------------- Mutation ---------------------------------------
Function Mutate (offspring,gene_length)
Dim pos , NLow , NHigh
NLow = 1
NHigh = gene_length
Randomize
pos= Int((NHigh - NLow + 1) * Rnd + NLow)
If Mid(offspring1, pos, 1) = "0" Then
Mid(offspring1, pos, 1) = "1"
Else
Mid(offspring1, pos, 1) = "0"
End If
mutate1= offspring1
End Function
'--------------------------------------------- Natural Selection ------------------------------------
Function NaturalSelection(FitnessObj, pop)
' select a single individual via weighted roulette wheel selection
Dim slice , counter , j
counter = 0
j = 0
slice = FitnessObj ( Int(Rnd()* (pop-1)) )
Do
j = j + 1
counter = counter + FitnessObj(j)
Loop Until ((counter > slice) Or (j = pop-1))
NaturalSelection = j
End Function