The second version of the Methinks program is listed below. A few notes may be in order…

First, I’ve switched from a string based system to an array based system to speed things up a bit. This speeds up the performance by a factor of three.

Second, the mutate function has been changed to give a true mutation rather than just a 26/27 possibility that the value will mutate. (This method will not allow the result to be the same as the original value.) This should give results which are truer to the definition.

Third, I’ve used a slightly more deterministic selector than previously. The current selector simply counts the number of positions that are not equal to those in the corresponding target string. This increases the speed in which the target is reached (which makes it more of a best-case scenario), and makes for a simpler analysis.

Fourth, I’ve cut down the output by only outputting on every 10^nth value, and the final value. This just makes for a more summarized result.

SOURCE CODE (VB6):

Option Explicit

Public Const TARGET_STRING As String = _
    "METHINKS@IT@IS@LIKE@A@WEASEL"
Public Const OFFSPRING_PER_GENERATION = 100

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

Public Sub Main()

    Dim lngDisplay As Long

    Randomize Timer

    Call StringToLong(TARGET_STRING, mlngTarget)

    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

End Sub

Private Sub GenerateInitial()

    Dim lngIndex As Long

    mlngLength = Len(TARGET_STRING)
    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 Mutate(lngBest(Int(Rnd * mlngLength) + 1))

    For lngIndex = 2 To OFFSPRING_PER_GENERATION
        lngNext = mlngParent
        Call Mutate(lngNext(Int(Rnd * mlngLength) + 1))

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

    mlngParent = lngBest
    mlngGeneration = mlngGeneration + 1

End Sub

Private Sub Mutate(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

OUTPUT:

Generation 1: XFLOOOWJIW X KEFZBWO XXGVBUP [28]
Generation 10: XELHWOWJII S FIBWO XWGVBUP [20]
Generation 45: METHINKS IT IS LIKE A WEASEL [0]
Advertisements