Genetic Algorithm

I'm not sure if this forum is meant for this stuff but i wrote a GA today. This is the code to it. It's based around the idea of pigs looking for truffles with them having certain attributes. I had a bit of a problem but now its finally done.

Print "This is an attempt at making a genetic algroithm for truffle hunting pigs"
Print "I know nothing about pigs or truffles so it might not be too realistic"
Print ""
Print "First Generation has been randomly selected:"
Print ""
Print ""

Type pig
	Field ID%
	Field chrom
	Field strB$
	Field selectionScore%
End Type

SeedRnd(MilliSecs())

Global gen% = 1

Dim groups(3,12)
Global numID% = 1

For a = 1 To 20
	strBin$ = ""
	p.pig = New pig
	p\chrom = CreateBank(6)					;Stores "genes". Offsets: 1-touch, 2-taste, 3-smell, 4-sight, 5-hearing, 6-obedience
	p\ID% = numID%
	For b% = 0 To 5
		PokeByte p\chrom, b%, Rand(0,255)
	Next
	For c% = 0 To 5
		strBin$ = strBin$ + Right(Bin(Str(PeekByte(p\chrom,c%))),8)
	Next
	numID% = numID% + 1
	p\strB$ = strBin$
Next

selectScore()
results()

Repeat

	Print "Press G to start a new generation."
	Print "Press Q to quit."
	
	key$ = Input("What next?: ")
	If key = "G" Or key = "g"
		newGen()
		Print "New Generation Created"
		selectScore()
		results()
	Else If key = "Q" Or key = "q"
		End
	End If

Forever
		
Function newGen()

	insertionsort()
	
	pos% = 1
	count% = 0
	break% = 12
	group% = 1
	For p.pig = Each pig
		If count% = break%
	 		group% = group%+1
			pos% = 1
			If break% = 12
				break = 17
			Else
				break = 21
			End If
		End If
		count% = count+1
		groups(group%,pos%) = p\ID%
		pos% = pos% + 1
	Next
	
	SeedRnd(MilliSecs())
	
	For a = 1 To 20
		group1Chose% = Rand(1,6)
		Select group1Chose%
			Case 1
				pig1Chose% = Rand(1,12)
			Case 2,4
				group1Chose%=2
				pig1Chose% = Rand(1,5)
			Case 3,5,6
				group1Chose%=3
				pig1Chose% = Rand(1,3)
		End Select
		group2Chose% = Rand(1,6)
		Select group2Chose%
			Case 1
				pig2Chose% = Rand(1,12)
			Case 2,4
				group2Chose%=2
				pig2Chose% = Rand(1,5)
			Case 3,5,6
				group2Chose%=3
				pig2Chose% = Rand(1,3)
		End Select
		breed(groups(group1Chose%,pig1Chose%),groups(group2Chose%,pig2Chose%))
	Next
	
	For p.pig = Each pig
		If p\ID% < numID% - 20
			Delete p
		End If
	Next
	
End Function

Function binStr(bank)
	
	For a% = 0 To 5
		byteStr = byteStr + Right(Str(PeekByte(bank,a)),8)
	Next
	bytes$ = Bin(byteStr)
	Return bytes$
	
End Function

Function InsertionSort()
Local Item.pig, NextItem.pig
Local p.pig, q.pig
Local temp%	; must be same type as the sort field.

	NextItem=After First pig
	While NextItem<>Null
		Item=NextItem
		NextItem=After Item
		p=Item : temp=Item\selectionScore
		Repeat
			q=Before p
			If q=Null Then Exit
			If temp >= q\selectionScore Then Exit
			p=q
		Forever
		q=Item
		Insert q Before p
	Wend
	
End Function

Function breed(p1%,p2%)
	
	Local chromstrt$
	
	For p.pig = Each pig
		If p\ID% = p1% Then Genes1$ = p\strB$
		If p\ID% = p2% Then Genes2$ = p\strB$
	Next
	
	SeedRnd(MilliSecs())
	
	For a% = 0 To 5
		cutOff% = Rand(1,2)
		cs1$ = Mid(Genes1,8*a,8)
		cs2$ = Mid(Genes2,8*a,8)
		cs1a$ = Left(cs1,cutOff)
		cs2a$ = Right(cs2,8-cutOff)
		cs$ = Str(cs1a) + Str(cs2a)
		mutation% = Rand(0,3)
		If mutation% = 0
		Else
			For a = 1 To mutation%
				off% = Rand(0,7)
				num$ = Mid(cs$,off,1)
				If num = "1"
					num = "0"
				Else If num = "0"
					num = "1"
				End If
				cs$ = Left(cs,off) + num + Right(cs,7-off)
			Next
		End If
		chromstrt$ = Str(chromstrt$) + Str(cs$)
	Next
		
	p.pig = New pig
	p\ID% = numID%
	p\chrom = CreateBank(6)
	For a = 0 To 5
		stat = Mid(chromstrt,8*a,8)
		stat = bin2int(Str(stat))
		If stat < 100
			stat = AddZero(stat,1)
		End If
		PokeByte p\chrom, a, stat
	Next
	p\strB = chromstrt
	numID% = numID%+1

End Function

Function bin2int(b$)
    blen=Len(b)
    For f=1 To blen
        n=n Shl 1 + (Mid(b,f,1)="1")
    Next
    Return n
End Function

Function results()

	For p.pig = Each pig
		totalScore = totalScore + p\selectionScore
	Next
	tsFloat# = totalScore
	tsFloat# = tsFloat#/30600*100

	Print "Generation " + gen
	Print ""
	Print "Pigs: 20"
	Print "Percentage Perfection: " + tsFloat# + "%"
	Print "Individual Scores:"
	Print ""
	For p.pig = Each pig
		ssFloat# = p\selectionScore
		Print p\ID% + ".  Perfection: " + ssFloat#/1530*100 + "%"
	Next
	Print ""
	gen = gen+1
			
End Function

Function selectScore()

	For p.pig = Each pig
		p\selectionScore% = PeekByte(p\chrom,0)/100*30 + PeekByte(p\chrom,1)/100*50 + PeekByte(p\chrom,2) + PeekByte(p\chrom,3)/100*30 + PeekByte(p\chrom,4)/100*10 + PeekByte(p\chrom,5)
	Next
	
End Function

Function Addzero$(s$,l)
	s$=RSet$(s$,l)
	s$=Replace$(s$," ","0")
	Return s$
End Function

They don't seem to evolve that well but there are changes in the generations so thats a bonus. Just see what you think.

(It's not all by me - there are a few functions used for sorting etc which i have borrowed)

Matt

Very interesting stuff, althoug I woul'd like to see the pigs graphically searching for the truffels, or display charts of their attributes together with the success rate. There is a bug in function breed, line:

cs1$ = Mid(Genes1,8*a,8)

produces a "parameter must be greater than zero" when I press G to run it again.