This latest version incorporates a fixed mutation rate, rather than a fixed number of mutations per child. This decreases the efficiency of the algorithm from an average count of 47 generations with a standard deviation of 10 generations to an average count of 77 generations with a standard deviation of 24 generations (over 200 runs each). The best rate I could find was at 1 out of every 26 – for the original 1 out of every 28, the results were an average count of 79 generations with a standard deviation of 24 generations.

I did not include the standard output, but it would be essentially the same as the previous version of the program, except that the last line will have a count of around 77 generations.

SOURCE CODE (VB6):

Option Explicit

Public Const TARGET_STRING As String = “METHINKS@IT@IS@LIKE@A@WEASEL”
Public Const OFFSPRING_PER_GENERATION = 100
Public Const MUTATION_RATE = 1 / 26

Private mlngTarget() As Long
Private mlngParent() As Long
Private mlngLength As Long
Private mlngGeneration As Long

Public Sub Main()

Call Initialize
Call Simulate

End Sub

Private Sub Initialize()

Randomize Timer

mlngLength = Len(TARGET_STRING)
Call StringToLong(TARGET_STRING, mlngTarget)

End Sub

Private Function Simulate() As Long

Dim lngDisplay As Long

Call GenerateInitial

lngDisplay = 1
Do While CalculateScore(mlngParent) > 0
If mlngGeneration = lngDisplay Then
Call ShowResult
lngDisplay = lngDisplay * 10
End If

Call GenerateOffspring
Loop

If mlngGeneration * 10 lngDisplay Then
ShowResult
End If

Simulate = mlngGeneration

End Function

Private Sub GenerateInitial()

Dim lngIndex As Long

ReDim mlngParent(1 To mlngLength)
mlngGeneration = 1
For lngIndex = 1 To mlngLength
mlngParent(lngIndex) = Int(Rnd * 27)
Next lngIndex

End Sub

Public Sub StringToLong(ByRef StringIn As String, ByRef LongOut() As Long)

Dim lngIndex As Long

ReDim LongOut(1 To Len(StringIn))
For lngIndex = 1 To Len(StringIn)
LongOut(lngIndex) = AscW(Mid$(StringIn, lngIndex, 1)) – 64
Next lngIndex

End Sub

Public Function LongToString(ByRef LongIn() As Long) As String

Dim lngIndex As Long

LongToString = vbNullString
For lngIndex = LBound(LongIn) To UBound(LongIn)
LongToString = LongToString & Chr$(LongIn(lngIndex) + 64)
Next lngIndex

End Function

Private Sub GenerateOffspring()

Dim lngIndex As Long
Dim lngBest() As Long
Dim lngNext() As Long

lngBest = mlngParent
Call MutateString(lngBest)

For lngIndex = 2 To OFFSPRING_PER_GENERATION
lngNext = mlngParent
Call MutateString(lngNext)

If CalculateScore(lngNext) < CalculateScore(lngBest) Then
lngBest = lngNext
End If
Next lngIndex

mlngParent = lngBest
mlngGeneration = mlngGeneration + 1

End Sub

Private Sub MutateString(ByRef MutateFrom() As Long)

Dim lngIndex As Long

For lngIndex = 1 To mlngLength
If Int(Rnd * (1 / MUTATION_RATE)) = 0 Then
Call MutateChar(MutateFrom(lngIndex))
End If
Next lngIndex

End Sub

Private Sub MutateChar(ByRef FromVal As Long)

FromVal = (FromVal + Int(Rnd * 26) + 1) Mod 27

End Sub

Private Function CalculateScore(ByRef CompareTo() As Long) As Long

Dim lngIndex As Long

For lngIndex = 1 To mlngLength
If mlngTarget(lngIndex) CompareTo(lngIndex) Then
CalculateScore = CalculateScore + 1
End If
Next lngIndex

End Function

Private Sub ShowResult()

Debug.Print “Generation ” & mlngGeneration & “: ” & Replace$(LongToString(mlngParent), “@”, ” “) & _
” [” & CalculateScore(mlngParent) & “]”

End Sub

Advertisements