Private Const Target As Double = 100.0    'Number for algorithm to find.
Private Const MaxInputs As Integer = 50  'Number of chromosomes in population.
Private Const MaxEpochs As Integer = 10000  'Arbitrary number of test cycles.
Private Const mRate As Double = 0.001 'Mutation Rate.
Private Const mRate2 As Double = 0.03 'Stagnation avoidance mutation rate.

Private Const ShowVerboseResults As Boolean = False

'0000 0000 0000 0000 0000 0000 0000 0000 0000

'Four bits are required to represent the range of characters used:
'Digits:                Operators:
'   0: 0000                 +: 1010
'   1: 0001                 +: 1011
'   2: 0010                 -: 1100
'   3: 0011                 -: 1101
'   4: 0100                 *: 1110
'   5: 0101                 /: 1111
'   6: 0110
'   7: 0111
'   8: 1000
'   9: 1001

Private Const MaxSize As Integer = 36
Private Const CR As String = Chr(13) + Chr(10)

Private Digits As Integer(,) = New Integer(,) {{0, 0, 0, 0}, _
                                                {0, 0, 0, 1}, _
                                                {0, 0, 1, 0}, _
                                                {0, 0, 1, 1}, _
                                                {0, 1, 0, 0}, _
                                                {0, 1, 0, 1}, _
                                                {0, 1, 1, 0}, _
                                                {0, 1, 1, 1}, _
                                                {1, 0, 0, 0}, _
                                                {1, 0, 0, 1}}

Private Operators As Integer(,) = New Integer(,) {{1, 0, 1, 0}, _
                                                    {1, 0, 1, 1}, _
                                                    {1, 1, 0, 0}, _
                                                    {1, 1, 0, 1}, _
                                                    {1, 1, 1, 0}, _
                                                    {1, 1, 1, 1}}

Private Inputs(MaxInputs - 1, MaxSize - 1) As Integer   'Current population.
Private NextGen(MaxInputs - 1, MaxSize - 1) As Integer  'Next population.
Private Totals(MaxInputs - 1) As Double                'Decoded values.
Private Fitness(MaxInputs - 1) As Double                'Fitness as percentage.
Private Selected(MaxInputs - 1) As Boolean              'Eligible parents.
Private ChildCount As Integer = 0
Private NextMutation As Integer                         'For scheduling mutations.
Private Mutations As Integer = 0
Private NaNAvoidanceCalls As Integer = 0
Private StopTest As Boolean = False

Private Sub Button1_Click(ByVal sender As Object, ByVal e As System.EventArgs) _
                                                            Handles Button1.Click
    GeneticAlgorithm()
End Sub

Private Sub Button2_Click(ByVal sender As Object, ByVal e As System.EventArgs) _
                                                            Handles Button2.Click
    StopTest = True
End Sub

' Note that as a floating point value, I can be a little more lenient with the algorithm's solutions.
' I've arbitrarily chosen the range between 99.999 and 100.001 as acceptable solutions.

Private Sub GeneticAlgorithm()
Dim TempString, TempString2 As String
Dim i, j, epoch As Integer
Dim Done As Boolean = False

    InitializeChromosomes()
    NextMutation = getRandomNumber(0, (1 / mRate))
    epoch = 0

    Do While Not Done

        For i = 0 To MaxInputs - 1
            Totals(i) = DecodeInput(i)
            If Math.Abs(Totals(i) - Target) <= 0.001 Or epoch = MaxEpochs Then
                Done = True
            End If
        Next i

        GetFitness()

        If epoch = 0 Or ShowVerboseResults = True Or Done = True Then
            For i = 0 To MaxInputs - 1
                For j = 0 To MaxSize - 1
                    TempString += CStr(Inputs(i, j))
                Next j
                TempString += " = " + CStr(Totals(i))
                TempString += vbTab + CStr(Fitness(i)) + "%" + CR
            Next i
            TempString += CR
        End If

        Selection()

        Mating()

        PrepNextEpoch()

        epoch += 1
        'This is here simply to show the runtime status.
        Text1.Text = "Epoch: " + CStr(epoch) + CR
        Application.DoEvents()

        'Stop all testing if user clicks Button2.
        If StopTest = True Then
            Done = True
        End If

    Loop

    TempString += "Done." + CR
    If epoch <> MaxEpochs Then
        TempString += GetDecodedFunction()
    End If
    TempString += "Completed " + CStr(epoch) + " epochs." + CR
    TempString += "Encountered " + CStr(Mutations) + " mutations in " + _
                                        CStr(ChildCount) + " offspring." + CR
    TempString += "NaN avoidance routine called " + CStr(NaNAvoidanceCalls) + _
                                                                " times." + CR

    Text1.Text += TempString

End Sub

Private Sub InitializeChromosomes()
Dim getRand As Double
Dim i, j, k, l As Integer

    For i = 0 To MaxInputs - 1
        l = 0
        For j = 0 To 8
            If j Mod 2 = 0 Then
                'j is even; this is an operand
                getRand = getRandomNumber(0, 9)
                For k = 0 To 3
                    Inputs(i, l) = Digits(getRand, k)
                    l += 1
                Next k
            Else
                'j is odd; this is an operator
                getRand = getRandomNumber(0, 5)
                For k = 0 To 3
                    Inputs(i, l) = Operators(getRand, k)
                    l += 1
                Next k
            End If
        Next j
    Next i

End Sub

Private Function DecodeInput(ByVal InputIndex As Integer) As Double
'Take a chromosome, decode it, evaluate it mathematically, and return the answer.
'Ignore the usual rules of algebraic evaluation, and simple go from left to right.
Dim i, Pointer As Integer
Dim Done As Boolean = False
Dim Operator As Integer
Dim Operand As Integer
Dim Total As Double = 0.0

    '0-3:   operand
    '4-7:   operator
    '8-11:  operand
    '12-15: operator
    '16-19: operand
    '20-23: operator
    '24-27: operand
    '28-31: operator
    '32-35: operand

    Pointer = 0
    'Get first operand...
    For i = 3 To 0 Step -1
        Total += Inputs(InputIndex, Pointer) * Math.Pow(2, i) 'B2D
        Pointer += 1
    Next i

    Done = False
    Do While Not Done
        'Get next operator...
        Operator = 0
        For i = 3 To 0 Step -1
            Operator += Inputs(InputIndex, Pointer) * Math.Pow(2, i) 'B2D
            Pointer += 1
        Next i

        'Get next operand...
        Operand = 0
        For i = 3 To 0 Step -1
            Operand += Inputs(InputIndex, Pointer) * Math.Pow(2, i) 'B2D
            Pointer += 1
        Next i

        If Operator = 10 Or Operator = 11 Then
            'Addition
            Total += Operand
        ElseIf Operator = 12 Or Operator = 13 Then
            'Subtraction
            Total -= Operand
        ElseIf Operator = 14 Then
            'Multiplication
            Total *= Operand
        Else
            'Division
            If Operand <> 0 Then 'Avoid divide-by-zero errors.
                Total /= Operand
            End If
        End If

        If Pointer >= 35 Then
            Done = True
        End If

    Loop

    Return Total

End Function

Private Sub GetFitness()
'Lowest errors = 100%, Highest errors = 0%
Dim i As Integer
Dim BestScore, WorstScore As Integer
Dim NaNCount As Integer = 0 'Monitors fitness scores for non-real numbers

    'The worst score would be the one furthest from the Target.
    WorstScore = Math.Abs(Target - Totals(Maximum(Totals)))

    'The best would be the closest.
    BestScore = Math.Abs(Target - Totals(Minimum(Totals)))

    'Convert to a weighted percentage.
    BestScore = WorstScore - Math.Abs(Target - Totals(Minimum(Totals)))
    For i = 0 To MaxInputs - 1
        Fitness(i) = (WorstScore - (Math.Abs(Target - Totals(i)))) * 100 / BestScore
        If Double.IsNaN(Fitness(i)) Then
            NaNCount += 1
        End If
    Next i

    'Prepare to shake up population if all fitness scores become NaN.
    If NaNCount = MaxInputs Then
        BreakNaN()
    End If

End Sub

Private Sub Selection()
'We start out with n individuals, and will stay with n.
'To do this, pick out the most fit, mate them, then replace the least fit
'with the new offspring.  The parents will remain for the next
'population. Basically, the least fit are always being weeded out.
Dim i, j As Integer
Dim getRand As Integer

    For i = 0 To MaxInputs - 1
        getRand = getRandomNumber(0, 100)
        If Fitness(i) >= getRand Then
            Selected(i) = True
        Else
            Selected(i) = False
        End If
    Next i

End Sub

Private Sub Mating()
Dim i, j, Pointer1, Pointer2 As Integer
Dim MaxChild As Integer = 0
Dim CanMate As Integer = 0
Dim CannotMate(MaxInputs - 1) As Integer
Dim ParentA, ParentB As Integer
Dim NewChild(MaxSize - 1) As Integer
Dim PossibleMutation As Integer

    For i = 0 To MaxInputs - 1
        CannotMate(i) = -1
    Next

    'Determine total who can mate.
    Pointer1 = 0
    Pointer2 = 0
    For i = 0 To MaxInputs - 1
        If Selected(i) = True Then
            CanMate += 1
            'Copy selected individuals to next generation.
            For j = 0 To MaxSize - 1
                NextGen(Pointer1, j) = Inputs(i, j)
            Next j
            Pointer1 += 1
        Else 'Cannot mate.
            CannotMate(Pointer2) = i
            Pointer2 += 1
        End If
    Next i

    MaxChild = MaxInputs - CanMate 'Total number of offspring to be created.

    If CanMate > 1 And Pointer2 > 0 Then
        For i = 0 To MaxChild - 1
            ParentA = ChooseParent()
            ParentB = ChooseParent(ParentA)
            Crossover(ParentA, ParentB, NewChild)
            For j = 0 To MaxSize - 1
                NextGen(Pointer1, j) = NewChild(j)
            Next j

            If ChildCount = NextMutation Then
                Mutation(Pointer1)
            End If

            Pointer1 += 1
            ChildCount += 1

            'Schedule next mutation.
            If ChildCount Mod CInt(1 / mRate) = 0 Then
                NextMutation = ChildCount + getRandomNumber(0, (1 / mRate))
            End If
        Next i
    End If

End Sub

Private Function ChooseParent() As Integer
'Overloaded function, see also "ChooseParent(ByVal ParentA As Integer)".
Dim Parent As Integer
Dim Done As Boolean = False

    Do While Not Done
        'Randomly choose an eligible parent.
        Parent = getRandomNumber(0, MaxInputs - 1)
        If Selected(Parent) = True Then
            Done = True
        End If
    Loop

    Return Parent

End Function

Private Function ChooseParent(ByVal ParentA As Integer) As Integer
'Overloaded function, see also "ChooseParent()".
Dim Parent As Integer
Dim Done As Boolean = False

    Do While Not Done
        'Randomly choose an eligible parent.
        Parent = getRandomNumber(0, MaxInputs - 1)
        If Parent <> ParentA Then
            If Selected(Parent) = True Then
                Done = True
            End If
        End If
    Loop

    Return Parent

End Function

Private Sub Crossover(ByVal ChromA As Integer, ByVal ChromB As Integer, _
                                                ByRef NewChrom As Integer())
'select a random gene along the length of the
'chromosomes and swap all genes after that point.
Dim i As Integer
Dim RandomPoint As Integer

    'We want the point to be at a logical place, so that valid operands and
    'operators are kept intact.
    RandomPoint = getRandomNumber(0, 8)
    RandomPoint *= 4

    For i = 0 To MaxSize - 1
        If i < RandomPoint Then
            NewChrom(i) = Inputs(ChromA, i)
        ElseIf i >= RandomPoint Then
            NewChrom(i) = Inputs(ChromB, i)
        End If
    Next i

End Sub

Private Sub Mutation(ByVal ChildIndex As Integer)
Dim i, j As Integer
Dim RandomPoint As Integer
Dim RandomItem As Integer

    'We want the point to be at a logical place, so that valid operands and
    'operators are kept intact.
    RandomPoint = getRandomNumber(0, 8)

    If RandomPoint Mod 2 = 0 Then
        'RandomPoint is even; this is an operand
        RandomItem = getRandomNumber(0, 9)
    Else
        'RandomPoint is odd; this is an operator
        RandomItem = getRandomNumber(0, 5)
    End If

    j = 0
    For i = 0 To MaxSize - 1
        If (i > (RandomPoint * 4) - 1) And (i < (RandomPoint * 4) + 4) Then
            If RandomPoint Mod 2 = 0 Then
                NextGen(ChildIndex, i) = Digits(RandomItem, j)
            Else
                NextGen(ChildIndex, i) = Operators(RandomItem, j)
            End If
            j += 1
        Else
            NextGen(ChildIndex, i) = Inputs(ChildIndex, i)
        End If
    Next i

    Mutations += 1

End Sub

' This helps to break up the monotony a little...

Private Sub BreakNaN()
'If the entire population achieves a fitness score of NaN,
'shake up the monotony with several mutations.
Dim i, j As Integer
Dim getRand As Integer

    For i = 0 To MaxInputs - 1
        getRand = getRandomNumber(0, 100)
        If getRand <= (1 / mRate2) Then
            Mutation(i)
        End If
    Next

    NaNAvoidanceCalls += 1

End Sub

Private Sub PrepNextEpoch()
Dim i, j As Integer

    'Copy next generation into current generation input.
    For i = 0 To MaxInputs - 1
        For j = 0 To MaxSize - 1
            Inputs(i, j) = NextGen(i, j)
        Next j
    Next i

    'Reset flags for selected individuals.
    For i = 0 To MaxInputs - 1
        Selected(i) = False
    Next i

End Sub

Private Function GetDecodedFunction() As String
Dim i, j, k, Pointer, Item As Integer
Dim TempString As String

    For i = 0 To MaxInputs - 1
        Totals(i) = DecodeInput(i)
        If Math.Abs(Totals(i) - Target) <= 0.001 Then
            'Print the chromosome.
            For j = 0 To MaxSize - 1
                TempString += CStr(Inputs(i, j))
            Next j
            TempString += CR

            'Print the decoded function.
            Pointer = 0
            For j = 0 To 8
                Item = 0
                For k = 3 To 0 Step -1
                    Item += Inputs(i, Pointer) * Math.Pow(2, k) 'B2D
                    Pointer += 1
                Next k
                If Item < 10 Then
                    TempString += CStr(Item) + " "
                Else
                    If Item = 10 Or Item = 11 Then
                        'Addition
                        TempString += "+ "
                    ElseIf Item = 12 Or Item = 13 Then
                        'Subtraction
                        TempString += "- "
                    ElseIf Item = 14 Then
                        'Multiplication
                        TempString += "* "
                    Else
                        'Division
                        TempString += "/ "
                    End If
                End If
            Next j
            TempString += "= " + CStr(Totals(i)) + CR
        End If
    Next i

    Return TempString

End Function

Private Function getRandomNumber(ByVal low, ByVal high) As Integer
    Randomize()
    getRandomNumber = CInt((high - low) * Rnd() + low)
End Function

Private Function Minimum(ByRef IntArray As Double()) As Integer
'Returns an array index.
Dim i As Integer
Dim Winner As Integer
Dim FoundNewWinner As Boolean
Dim Done As Boolean = False

    Winner = 0
    Do Until Done

        FoundNewWinner = False
        For i = 0 To MaxInputs - 1
            If i <> Winner Then             'Avoid self-comparison.
                'The minimum has to be in relation to the Target.
                If Math.Abs(Target - IntArray(i)) < _
                    Math.Abs(Target - IntArray(Winner)) Then
                    Winner = i
                    FoundNewWinner = True
                End If
            End If
        Next i

        If FoundNewWinner = False Then
            Done = True
        End If

    Loop

    Return Winner

End Function

Private Function Maximum(ByRef IntArray As Double()) As Integer
'Returns an array index.
Dim i As Integer
Dim Winner As Integer
Dim FoundNewWinner As Boolean
Dim Done As Boolean = False

    Winner = 0
    Do Until Done

        FoundNewWinner = False
        For i = 0 To MaxInputs - 1
            If i <> Winner Then             'Avoid self-comparison.
                'The maximum has to be in relation to the Target.
                If Math.Abs(Target - IntArray(i)) > _
                    Math.Abs(Target - IntArray(Winner)) Then
                    Winner = i
                    FoundNewWinner = True
                End If
            End If
        Next i

        If FoundNewWinner = False Then
            Done = True
        End If

    Loop

    Return Winner

End Function