RosettaCodeData/Task/Evolutionary-algorithm/PureBasic/evolutionary-algorithm.pure...

72 lines
1.9 KiB
Plaintext

Define population = 100, mutationRate = 6
Define.s target$ = "METHINKS IT IS LIKE A WEASEL"
Define.s charSet$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ "
Procedure.i fitness(Array aspirant.c(1), Array target.c(1))
Protected i, len, fit
len = ArraySize(aspirant())
For i = 0 To len
If aspirant(i) = target(i): fit +1: EndIf
Next
ProcedureReturn fit
EndProcedure
Procedure mutatae(Array parent.c(1), Array child.c(1), Array charSetA.c(1), rate.i)
Protected i, L, maxC
L = ArraySize(child())
maxC = ArraySize(charSetA())
For i = 0 To L
If Random(100) < rate
child(i) = charSetA(Random(maxC))
Else
child(i) = parent(i)
EndIf
Next
EndProcedure
Procedure.s cArray2string(Array A.c(1))
Protected S.s, len
len = ArraySize(A())+1 : S = Space(len)
CopyMemory(@A(0), @S, len * SizeOf(Character))
ProcedureReturn S
EndProcedure
Define mutationRate, maxChar, target_len, i, maxfit, gen, fit, bestfit
Dim targetA.c(Len(target$) - 1)
CopyMemory(@target$, @targetA(0), StringByteLength(target$))
Dim charSetA.c(Len(charSet$) - 1)
CopyMemory(@charSet$, @charSetA(0), StringByteLength(charSet$))
maxChar = Len(charSet$) - 1
maxfit = Len(target$)
target_len = Len(target$) - 1
Dim parent.c(target_len)
Dim child.c(target_len)
Dim Bestchild.c(target_len)
For i = 0 To target_len
parent(i) = charSetA(Random(maxChar))
Next
fit = fitness (parent(), targetA())
OpenConsole()
PrintN(Str(gen) + ": " + cArray2string(parent()) + ": Fitness= " + Str(fit) + "/" + Str(maxfit))
While bestfit <> maxfit
gen + 1
For i = 1 To population
mutatae(parent(),child(),charSetA(), mutationRate)
fit = fitness (child(), targetA())
If fit > bestfit
bestfit = fit: CopyArray(child(), Bestchild())
EndIf
Next
CopyArray(Bestchild(), parent())
PrintN(Str(gen) + ": " + cArray2string(parent()) + ": Fitness= " + Str(bestfit) + "/" + Str(maxfit))
Wend
PrintN("Press any key to exit"): Repeat: Until Inkey() <> ""