Simple Genetic Algorithm

This code has been declared by its author to be Public Domain code.

Simple Genetic Algorithm by GW

2007

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

Retimer

2007

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