VERSION 2.00
Begin Form Form1 
   Caption         =   "Matches"
   ClientHeight    =   5160
   ClientLeft      =   630
   ClientTop       =   2010
   ClientWidth     =   8640
   Height          =   5565
   Left            =   570
   LinkTopic       =   "Form1"
   ScaleHeight     =   5160
   ScaleWidth      =   8640
   Top             =   1665
   Width           =   8760
   Begin TextBox txtavefit 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   120
      TabIndex        =   28
      Top             =   4080
      Width           =   735
   End
   Begin TextBox txthits 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   120
      TabIndex        =   27
      Top             =   3720
      Width           =   735
   End
   Begin TextBox Txtstatus 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Courier"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   3720
      TabIndex        =   26
      Top             =   4560
      Width           =   2655
   End
   Begin TextBox Txtout 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Courier"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   960
      TabIndex        =   25
      Top             =   4080
      Width           =   2655
   End
   Begin CommandButton Cmdright 
      Height          =   255
      Index           =   0
      Left            =   7800
      TabIndex        =   24
      TabStop         =   0   'False
      Top             =   2880
      Width           =   255
   End
   Begin GRAPH Graavefit 
      AsciiLabel      =   "T   O       B    E       O  R      N   O  T        T  O       B  E "
      AutoInc         =   0  'Off
      GraphTitle      =   "Mean fitness"
      GridStyle       =   1  'Horizontal
      Height          =   2055
      Left            =   480
      NumPoints       =   18
      RandomData      =   0  'Off
      TabIndex        =   20
      Top             =   1200
      Width           =   3255
      YAxisStyle      =   1  'Variable Origin
   End
   Begin CommandButton Cmdpause 
      Caption         =   "Pause"
      Height          =   495
      Left            =   2280
      TabIndex        =   19
      Top             =   4560
      Width           =   735
   End
   Begin CommandButton Cmddown 
      Caption         =   "V"
      Height          =   255
      Index           =   2
      Left            =   7800
      TabIndex        =   18
      TabStop         =   0   'False
      Top             =   3120
      Width           =   255
   End
   Begin CommandButton CmdUp 
      Caption         =   "^"
      Height          =   255
      Index           =   1
      Left            =   7800
      TabIndex        =   17
      TabStop         =   0   'False
      Top             =   2640
      Width           =   255
   End
   Begin CommandButton Cmdright 
      Caption         =   ">"
      Height          =   255
      Index           =   1
      Left            =   8040
      TabIndex        =   16
      TabStop         =   0   'False
      Top             =   2880
      Width           =   255
   End
   Begin CommandButton Cmdleft 
      Caption         =   "<"
      Height          =   255
      Index           =   0
      Left            =   7560
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   2880
      Width           =   255
   End
   Begin GRAPH Grafitness 
      AutoInc         =   0  'Off
      GraphTitle      =   "Fitness"
      Height          =   2655
      IndexStyle      =   1  'Enhanced
      Left            =   6480
      NumPoints       =   19
      RandomData      =   0  'Off
      TabIndex        =   15
      Top             =   0
      Width           =   2535
   End
   Begin TextBox txtprop 
      ForeColor       =   &H000000FF&
      Height          =   285
      Left            =   4080
      TabIndex        =   6
      Text            =   "0.00"
      Top             =   1680
      Width           =   615
   End
   Begin TextBox txtmutate 
      ForeColor       =   &H000000FF&
      Height          =   285
      Left            =   4080
      TabIndex        =   5
      Text            =   "0.00"
      Top             =   1320
      Width           =   615
   End
   Begin TextBox txtmatches 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Courier"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   960
      TabIndex        =   12
      Top             =   3720
      Width           =   2655
   End
   Begin CommandButton Cmdcontinue 
      BackColor       =   &H000000FF&
      Caption         =   "Continue"
      Height          =   495
      Left            =   1080
      TabIndex        =   8
      Top             =   4560
      Width           =   975
   End
   Begin TextBox txtfilename 
      ForeColor       =   &H000000FF&
      Height          =   375
      Left            =   3120
      TabIndex        =   3
      Top             =   720
      Width           =   3135
   End
   Begin TextBox TxtGen 
      BackColor       =   &H00FFFFFF&
      ForeColor       =   &H000000FF&
      Height          =   375
      Left            =   1680
      TabIndex        =   2
      Text            =   "4"
      Top             =   720
      Width           =   975
   End
   Begin CommandButton cmdRun 
      Caption         =   "Run"
      Default         =   -1  'True
      Height          =   495
      Left            =   120
      TabIndex        =   7
      Top             =   4560
      Width           =   735
   End
   Begin TextBox txtTarget 
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Courier"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H000000FF&
      Height          =   360
      Left            =   960
      TabIndex        =   4
      Text            =   "TO BE OR NOT TO BE"
      Top             =   3360
      Width           =   2655
   End
   Begin TextBox txtPop 
      ForeColor       =   &H000000FF&
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Text            =   "50"
      Top             =   720
      Width           =   975
   End
   Begin Label Label8 
      Caption         =   "Best of generation"
      Height          =   375
      Left            =   3840
      TabIndex        =   21
      Top             =   4080
      Width           =   1815
   End
   Begin Label Label7 
      Caption         =   "Matches"
      Height          =   375
      Left            =   3840
      TabIndex        =   22
      Top             =   3720
      Width           =   1215
   End
   Begin Label Label6 
      Caption         =   "Target"
      Height          =   375
      Left            =   3840
      TabIndex        =   23
      Top             =   3360
      Width           =   1215
   End
   Begin Label Label5 
      Caption         =   "proportionate"
      Height          =   255
      Left            =   4800
      TabIndex        =   14
      Top             =   1680
      Width           =   1335
   End
   Begin Label Label4 
      Caption         =   "Mutation rate"
      Height          =   255
      Left            =   4800
      TabIndex        =   13
      Top             =   1320
      Width           =   1335
   End
   Begin Label Label3 
      Caption         =   "Output file"
      Height          =   375
      Left            =   3120
      TabIndex        =   11
      Top             =   360
      Width           =   2775
   End
   Begin Label Label2 
      Caption         =   "Generations"
      Height          =   375
      Left            =   1680
      TabIndex        =   10
      Top             =   360
      Width           =   975
   End
   Begin Label Label1 
      Caption         =   "Population size"
      Height          =   375
      Left            =   120
      TabIndex        =   9
      Top             =   360
      Width           =   975
   End
End
Option Explicit
Dim population() As String
Dim hits() As Long
Dim fitness() As Long
Dim sumfit As Long
Dim maxhits As Long
Dim maxfit As Long
Dim best As Long
Dim maxgen As Long
Dim pop As Long
Dim target As String
Dim newpop() As String
Dim gen As Long
Dim outfilenumber As Integer
Dim cumfit() As Long
Dim matches() As Integer
Rem Dim mutation As Single
Rem Dim proporationate As Single
Dim pause As Integer
Dim continue As Integer
Dim fitbusy As Integer

Sub Cmdcontinue_Click ()
    If pop = 0 Or fitbusy = True Then
        Exit Sub 'Havnt done anything to continue yet
                 'or am already running
    End If
    cmdpause.Default = True

    pause = False
    continue = True

    maxgen = Val(txtgen.Text)
    
    open_output

    do_gens
    

End Sub

Sub Cmddown_Click (Index As Integer)
    graavefit.Visible = True
    disp_graavefit

    grafitness.Visible = True
    If grafitness.GraphStyle = 0 Then
        grafitness.GraphStyle = 7
    Else
        grafitness.GraphStyle = grafitness.GraphStyle - 1
    End If
    grafitness.DrawMode = 2

End Sub

Sub Cmdleft_Click (Index As Integer)
    graavefit.Visible = True
    disp_graavefit

    grafitness.Visible = True
    If grafitness.GraphType = 0 Then
        grafitness.GraphType = 11
    Else
        grafitness.GraphType = grafitness.GraphType - 1
    End If
    grafitness.DrawMode = 2
End Sub

Sub Cmdpause_Click ()
    pause = True
    If pop = 0 Then
        cmdrun.Default = True
    Else
        cmdcontinue.Default = True
    End If
End Sub

Sub Cmdright_Click (Index As Integer)
    graavefit.Visible = True
    disp_graavefit

    grafitness.Visible = True
    grafitness.DrawMode = 2
End Sub

Sub cmdRun_Click ()
    If fitbusy Then
        Exit Sub 'am already busy - ignore command
    End If

    cmdpause.Default = True
    continue = False
    pause = False
    pop = Val(txtpop.Text)
    maxgen = Val(txtgen.Text)
    target = txtTarget.Text

    txtStatus.Text = "Generating Pop"
    ReDim population(pop)
    ReDim fitness(pop)
    ReDim hits(pop)
    ReDim cumfit(pop)
    ReDim matches(Len(target))
    If Len(target) < 2 Then
        grafitness.Visible = False
    Else
        grafitness.NumPoints = Len(target) 'fit=hits
    End If
    Dim tmpchr

    open_output

    init_pop
    
    do_gens

End Sub

Sub CmdUp_Click (Index As Integer)
    
    graavefit.Visible = True
    disp_graavefit

    grafitness.Visible = True
    grafitness.GraphStyle = (grafitness.GraphStyle + 1) Mod 8
    grafitness.DrawMode = 2
End Sub

Sub disp_graavefit ()
    If Len(target) < 2 Then
        graavefit.Visible = False
    End If

    If graavefit.Visible = False Or fitbusy = True Then
        Exit Sub
    End If
    
    Dim i, p
    ReDim totfit(Len(target)) As Long

    For i = 1 To Len(target)
        totfit(i) = 0
    Next i
    
    For p = 1 To pop
        For i = 1 To Len(target)
            If Mid(population(p), i, 1) = Mid(target, i, 1) Then
                totfit(i) = totfit(i) + fitness(p)
            End If
        Next i
    Next p
    
    graavefit.NumPoints = Len(target)
    For i = 1 To Len(target)
        graavefit.ThisPoint = i
        graavefit.LabelText = Mid(target, i, 1)
        If matches(i) = 0 Then
            graavefit.GraphData = 0
        Else
            graavefit.GraphData = (totfit(i) * pop) / (matches(i) * sumfit)
        End If
    Next i
graavefit.DrawMode = 2

End Sub

Sub do_gens ()

Dim g As Integer
Dim np As Long
Dim mum As Long
Dim dad As Long

If outfilenumber <> 0 Then Write #outfilenumber, "Mutation rate = " & txtmutate.Text & " Straight copy rate = " & txtprop.Text
For g = gen + 1 To maxgen

    txtStatus.Text = "Creating gen " & Format(g)

    ReDim newpop(pop) 'garbage collecion?
    
    Dim tstval As Single
    

    For np = 1 To pop
    
        tstval = Rnd

        mum = sel()

        If tstval < Val(txtmutate.Text) Then
            newpop(np) = mutate(population(mum))
        ElseIf tstval < Val(txtprop.Text) + Val(txtmutate.Text) Then
            newpop(np) = population(mum)
        Else
            dad = sel()
            xover mum, dad, np
        End If
        DoEvents 'let some one else use CPU
    Next np

    For np = 1 To pop
        population(np) = newpop(np)
    Next np

    gen = g
    txtStatus.Text = "Evaluating gen " & Format(gen)
    fit
    
    If hits(best) >= Len(target) Then
        txtStatus.Text = "Match on gen " & Format(gen)
        If continue = False Then
            Exit For
        End If
    End If

    If pause Then
        txtStatus.Text = "Paused at gen " & Format(gen)
        Exit For
    End If
    
Next g

cmdcontinue.Default = True

End Sub

Sub fit ()
    fitbusy = True
    sumfit = 0
    maxfit = -1
    maxhits = -1
    Dim p, i
    ReDim frequency(0 To Len(target)) As Integer

    frequency(0) = 0
    For i = 1 To Len(target)
        matches(i) = 0
        frequency(i) = 0
    Next i

    For p = 1 To pop
        hits(p) = 0
        For i = 1 To Len(target)
           If Mid(population(p), i, 1) = Mid(target, i, 1) Then
                hits(p) = hits(p) + 1
                matches(i) = matches(i) + 1
           End If
        Next i
        fitness(p) = hits(p) '* hits(p)
        frequency(fitness(p)) = frequency(fitness(p)) + 1
        
        sumfit = sumfit + fitness(p)
        cumfit(p) = sumfit
        If maxfit < fitness(p) Then
            maxfit = fitness(p)
            best = p
            maxhits = hits(p)
        End If
        DoEvents 'let some one else use CPU
    Next p
    fitbusy = False

    printgen
    Rem Debug.Print best, population(best)
    txtout.Text = population(best)
    txthits = Format(maxhits)
    txtavefit = Format(sumfit / pop)

    txtmatches = ""
    For i = 1 To Len(target)
        If matches(i) <= 9 Then
            txtmatches = txtmatches & Format(matches(i))
        Else
            txtmatches = txtmatches & "X"
        End If
    Next i
    
    If Len(target) <= 0 Then
        grafitness.Visible = False
    End If

    If grafitness.Visible Then
        grafitness.NumPoints = Len(target) + 1
        For i = 0 To Len(target)
            grafitness.ThisPoint = i + 1
            grafitness.LabelText = Format(i)
            grafitness.GraphData = frequency(i)
        Next i
        grafitness.DrawMode = 2
    End If

    disp_graavefit
End Sub

Sub Graavefit_Click ()

    graavefit.Visible = False

End Sub

Sub Grafitness_Click ()
    grafitness.Visible = False
End Sub

Sub init_pop ()
    
    Dim p, i
    For p = 1 To pop
        For i = 1 To Len(target)
            
            population(p) = population(p) & Chr(ran_chr())
           
        Next i
        Rem Debug.Print population(p)
        DoEvents 'let some one else use CPU
    Next p

    gen = 0

    fit

End Sub

Function mutate (mut As String) As String
    
    Dim i

    For i = 1 To Len(mut)
        If Rnd * Len(mut) < 1 Then
            Mid(mut, i, 1) = Chr(ran_chr())
        End If
    Next i

    mutate = mut

End Function

Sub open_output ()
    If txtfilename.Text <> "" Then
        If outfilenumber = 0 Then
            outfilenumber = 63
            Open txtfilename.Text For Output As outfilenumber
            Write #outfilenumber, "Matches " & Date$ & " Target = " & target
            Write #outfilenumber, "Pop size = " & pop
            Write #outfilenumber, "Gen = " & gen & " Max gen = " & maxgen
        End If
    Else
        outfilenumber = 0
    End If

End Sub

Sub printgen ()
    
    If outfilenumber = 0 Then
        Exit Sub
    End If

    Dim p

    Write #outfilenumber, "Gen = " & gen & " " & Time$ & " sumfit = " & sumfit & " avefit = " & sumfit / pop & " Best = " & best & " " & population(best)
    For p = 1 To pop
        Write #outfilenumber, population(p) & " " & hits(p) & " " & fitness(p)
    Next p
End Sub

Function ran_chr () As Integer
    
    Dim tmpchr As Integer

    tmpchr = Int(Rnd * 27)
    If tmpchr > 25 Then tmpchr = 32 Else tmpchr = tmpchr + 65

    ran_chr = tmpchr

End Function

Function sel ()
    Dim t, bot, top
    Dim p As Integer
    t = Rnd * sumfit

    bot = 1
    top = pop
    
    Do While (top - bot) > 1
        
        p = (bot + top) / 2
    
        If cumfit(p) < t Then
            bot = p
        Else
            top = p
        End If

    Loop

    For p = top - 1 To 1
        If cumfit(p) <= t Then
            sel = p + 1
            Exit Function
        End If
    Next p

    sel = top
    
End Function

Sub txtTarget_Change ()
    target = txtTarget.Text
End Sub

Sub xover (mum, dad, p)
    Dim x

    x = Int(Rnd * (Len(target) - 1) + 1)

    newpop(p) = Left$(population(mum), x) & Right$(population(dad), Len(target) - x)

Rem    Debug.Print mum, population(mum)
Rem    Debug.Print dad, population(dad)
Rem    Debug.Print x
Rem    Debug.Print p, newpop(p)

End Sub