Code archives/Algorithms/Simple Genetic Algorithm
This code has been declared by its author to be Public Domain code.
Download source code
| |||||
This version works with mutation only. Breeding is not really needed. Compile as a console program. | |||||
rem small Genetic algorithm example by GW [jojo_dfb at Yahoo.com] 10.19.07 endrem Strict Framework brl.basic SeedRnd(MilliSecs()) Const MAXPOP = 300 '# of individuals in each generation Const MUTATECHANCE = 2'[percent] ' smaller is better [1 to 5]ish Const ASCII1 = 30 ' start of ascii range as chromosomes Const ASCII2 = 140 ' end of ascii range Global Population$[] Global INputSTRING$ INputSTRING = "A Genetic Algo example in BLITZMAX!! bigger strings take longer!!!!" Population = New String[MAXPOP] 'INputSTRING = Input("Give some text to evolve:") '------------------------------------------------------------------ Function GENPOP() '// Generate first random population // Local S$ Local i,j For I = 0 To MAXPOP-1 For j = 1 To INputSTRING.Length Local C$ = Chr(Rand(ASCII1,ASCII2)) S :+ C Next Population[i] = S S="" Next End Function '------------------------------------------------------------------ Function Fitness(instring$) '// this fitness func works but is non-optimal // Local i, val=0 For i = 0 To instring.length-1 val :+ Abs(instring[i] - INputSTRING[i]) Next Return Val End Function '------------------------------------------------------------------ Function Fitness2(Instring$) '// a better fitness function // Local i, val=0 For i = 0 To instring.length-1 If instring[i] <> INputSTRING[i] Then val :+ 1 Next Return Val End Function '------------------------------------------------------------------ Function EvalPOP() '// Evaluate the population and flag the 2 fittest individuals '// we're only using 1 with mutation, but if you wanted to breed the '// 2 best fit, there are flagged. For Local I = 0 To MAXPOP-1 Local Val = Fitness2(Population[i]) If Val <= Oldval1 Then Best2 = Best1 Best1 = I Oldval2 = oldval1 oldval1 = val End If Next End Function '------------------------------------------------------------------ Function BreedPOP() '// not really Breed, just mutate, but here is where a breeding func would go Local S$ Local tPop$[MAXPOP] tpop[0] = Population[Best1] For Local I = 1 To MAXPOP-1 tpop[I] = Mutate() Next Population = tpop End Function '------------------------------------------------------------------ Function Mutate$() Local Str$ For Local I = 0 To Population[Best1].Length-1 If Rand(1,100) <= MUTATECHANCE Then str :+ Chr(Rand(ASCII1,ASCII2)) Else str :+ Chr(Population[Best1][I]) End If Next Return Str End Function '------------------------------------------------------------------ '------------------------------------------------------------------ GENPOP Global Best1 = 999999 Global Best2 = 999999 Global Oldval1 = 999999 Global oldval2= 999999 Local loop1 For loop1 = 1 To 1000000 Oldval1 = 999999 oldval2= 999999 EvalPOP If Population[Best1].Contains(INputSTRING) Then Print "~nWINNER!!~n"; Exit BreedPOP If loop1 Mod 10 = 0 Then Print Population[0] End If Next Print Print Population[Best1] Print (Loop1 * MAXPOP) + " individuals tested in " + Loop1 + " generations" |
Comments
| ||
I became interested in this for implimenting a language skill into my game. Where text from other races would show results like that depending on your skill with them (much like everquest). so I came up with a faster, less professional method. It has a few constants you can alter to get different results. Since I didn't even understand your code, this is my newbie version of it: SuperStrict SeedRnd(MilliSecs()) Const GeniousID:Int = 20 Const AnyChar:Byte = 0 'Allow any characters in text. 0 if numbers and letters only. Const MethodID:Byte = 0 '1 if you want growing string Local I:Int = 0 Local II:Int = 0 Local E:Int = 0 Local LastCount:Int = 0 Global Corrected:Byte[0] Global Mistake:String[0] Global TestString:String = "I see a red door and I want it painted black" Corrected = Corrected[..Len(teststring)] Mistake = Mistake[..Len(teststring)] Lastcount = Len(teststring) For ii = 1 To GeniousID Local NewString:String Local TOer:Int = (LastCount - (Len(teststring) - Int((Len(teststring)*ii) / GeniousID))) LastCount = LastCount - ToEr If TOEr > 0 For e = 1 To TOer Local a:Int = FindToChange() Corrected[a] = 1 Next End If For i = 1 To Len(TestString) If MethodID = 0 If Corrected[i-1] = 1 NewString = NewString + Mid(TestString$,i,1) ElseIf corrected[i-1]=2 NewString = NewString + Mistake[i-1] Else If AnyChar Select Rand(1,3) Case 1 'Upper Chars Mistake[i-1] = Chr(Rand(65,90)) Case 2 'Lower Chars Mistake[i-1] = Chr(Rand(97,122)) Case 3 'Numbers Mistake[i-1] = Chr(Rand(48,57)) Case 4 'space Mistake[i-1] = Chr(32) End Select Else Mistake[i-1] = Chr(Rand(1,255)) End If corrected[i-1]=2 NewString = NewString + Mistake[i-1] End If Else 'Alternate Method of Slowly Stretching the string to perfection 'Could be used for scrambling games if you start at 50% in steps. If Corrected[i-1] = 1 NewString = NewString + Mid(TestString$,i,1) End If End If Next Print ii + ". " + NewString Next Function FindToChange:Int() Repeat Local III:Int = Rand(0,Len(TestString)-1) If Corrected[iii] <> 1 Return iii End If Forever End Function |
Code Archives Forum