frmmain.frm

基于VB开发的遗传算法源程序

VERSION 5.00
Begin VB.Form frmMain 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Neural Network Optimizer"
   ClientHeight    =   8655
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6750
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   8655
   ScaleWidth      =   6750
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdRun 
      Caption         =   "&Run"
      Default         =   -1  'True
      Height          =   375
      Left            =   4560
      TabIndex        =   4
      Top             =   2640
      Width           =   975
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "&Quit"
      Height          =   375
      Left            =   5640
      TabIndex        =   3
      Top             =   2640
      Width           =   975
   End
   Begin VB.TextBox txtChromosomes 
      BackColor       =   &H80000004&
      ForeColor       =   &H00FF0000&
      Height          =   3975
      Left            =   120
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   4560
      Width           =   6495
   End
   Begin VB.PictureBox picRMS 
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000004&
      Height          =   1440
      Left            =   120
      ScaleHeight     =   1380
      ScaleWidth      =   6435
      TabIndex        =   0
      Top             =   3120
      Width           =   6495
   End
   Begin VB.Label lblCaption 
      AutoSize        =   -1  'True
      Caption         =   "RMS Error:"
      Height          =   195
      Index           =   0
      Left            =   120
      TabIndex        =   1
      Top             =   2880
      Width           =   780
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private NetworkArray() As Double 'Holds data for the neural network

Private Neurons As Integer
Private Epochs As Long
Private Learning_Rate As Double
Private Momentum As Double

Dim WithEvents GA As GeneticAlgorithm
Attribute GA.VB_VarHelpID = -1

Private Target_Value As Double
Private lngWhere As Long
Private dblLastValue As Double
Private dblFitness As Double
Dim dblLFitness As Double

Private Sub LoadData(FileName As String)

    Dim TextLine
    Dim intCols As Integer
    Dim Found As Integer
    Dim intLoop As Integer
    Dim lngRows As Long

    MousePointer = vbHourglass

    'Get column count
    On Error GoTo ErrHndl

    Open FileName For Input As #1
    Line Input #1, TextLine
    Close #1

    Do
        Found = InStr(TextLine, ",")
        If Found = 0 Then Exit Do
        intCols = intCols + 1
        TextLine = Trim(Mid(TextLine, Found + 1))
        DoEvents
    Loop

    intCols = intCols + 1
    Neurons = intCols

    'Get row count
    Open FileName For Input As #1
    Do While Not EOF(1)
        lngRows = lngRows + 1
        Line Input #1, TextLine
    Loop
    Close #1

    ReDim NetworkArray(1 To intCols + 1, 1 To lngRows) As Double

    'Read file
    lngRows = 0
    Open FileName For Input As #1
    Do While Not EOF(1)
        Line Input #1, TextLine
        lngRows = lngRows + 1
        For intLoop = 1 To intCols
            Found = InStr(TextLine, ",")
            If Found = 0 Then
                NetworkArray(intLoop, lngRows) = Trim(TextLine)
            Else
                NetworkArray(intLoop, lngRows) = Trim(Mid(TextLine, 1, Found - 1))
                TextLine = Trim(Mid(TextLine, Found + 1))
            End If
            DoEvents
        Next intLoop
    Loop
    Close #1

    MousePointer = vbNormal
    Exit Sub

ErrHndl:

    MousePointer = vbNormal
    MsgBox Err.Description, vbExclamation, "Error: " & Err.Number

End Sub

Private Sub TrainNetwork()

    RetVal = Train(NetworkArray(), Epochs, 1, Learning_Rate, Momentum, _
            CDbl(Neurons), AddressOf CallBackEpoch, AddressOf CallBackRMSError)

    If RetVal = -1 Then MsgBox "Error training network", vbExclamation, "Error:"

End Sub

Private Function Fitness()

    Dim lngCol As Long
    Dim strResults As String
    Dim Errors As Double

    RetVal = Train(NetworkArray(), 1, 0, 0.001, 0.001, _
            CDbl(Neurons), AddressOf CallBackEpoch, AddressOf CallBackRMSError)

    If RetVal = -1 Then MsgBox "Error training network", vbExclamation, "Error:"

    For lngCol = 1 To UBound(NetworkArray, 2)
        Errors = Errors + Abs(NetworkArray(UBound(NetworkArray) - 1, lngCol) - _
                NetworkArray(UBound(NetworkArray), lngCol))
    Next lngCol

    Errors = Errors / UBound(NetworkArray, 2)

    On Error Resume Next
    Fitness = CCur(Val(Errors))

End Function

Private Function Evaluate(Values)

    LoadData App.Path & "\TRAIN.TXT"

    Learning_Rate = Values(1) / 2
    Momentum = Values(2) / 8
    Neurons = Values(3) + Values(4)
    Epochs = (Values(5) + Values(6) + Values(7) + Values(8)) * 100

    TrainNetwork
    LoadData App.Path & "\TRAIN.TXT"
    Evaluate = Fitness

End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Unload Me
    End
End Sub

Private Sub cmdQuit_Click()
    On Error Resume Next
    GA.Quit
End Sub

Private Sub cmdRun_Click()

    Set GA = New GeneticAlgorithm

    'Reset for graphics
    Target_Value = 0.05
    txtChromosomes = ""
    lngWhere = 0
    dblLastValue = 0
    dblFitness = 0
    dblLFitness = 0
    Cls

    GA.Target = Target_Value
    GA.Run
    Set GA = Nothing

End Sub

Private Sub GA_BestSolution(Chromosome As String, Fitness As Double, Values As Variant)

    Dim strValues As String
    Dim i As Integer
    Dim dblFit As Double
    Dim Errors As Double

    Static ClearText As Integer

    ClearText = ClearText + 1
    If ClearText = 2 Then
        ClearText = 0
        txtChromosomes = ""
    End If

    For i = 1 To UBound(Values)
        strValues = strValues & Values(i) & vbTab
    Next i

    Fitness = Target_Value - Fitness

    Learning_Rate = Values(1) / 2
    Momentum = Values(2) / 8
    Neurons = Values(3) + Values(4)
    Epochs = (Values(5) + Values(6) + Values(7) + Values(8)) * 100
    strValues = "Learning Rate: " & Learning_Rate & vbCrLf & _
            "Momentum: " & Momentum & vbCrLf & _
            "Neurons: " & Neurons & vbCrLf & _
            "Epochs: " & Epochs

    txtChromosomes = txtchromosome & vbCrLf & "Chromosome: " & Chromosome & vbCrLf & "Error: " & _
            Evaluate(Values) & vbCrLf & vbCrLf & strValues

    lngWhere = lngWhere + 50
    Line (lngWhere - 50, (dblLastValue * 10) + 1000)-(lngWhere, (Fitness * 10) + 1000), vbBlue

    dblFit = Abs(Fitness - dblLastValue)
    If dblFit > dblFitness Then dblFitness = dblFit
    dblLastValue = Fitness

    Line (lngWhere - 50, 150 - (dblLFitness * 10) + 1500)-(lngWhere, 150 - (dblFitness * 10) + 1500), vbRed

    dblLFitness = dblFitness

    If lngWhere > 7000 Then
        Cls
        lngWhere = 0
    End If

End Sub

Private Sub GA_Evaluate(Values As Variant)
    GA.Fitness = Evaluate(Values)
End Sub

Private Sub GA_Solved(Chromosome As String, Fitness As Double, Values As Variant)

    Dim strValues As String
    Dim i As Integer

    Learning_Rate = Values(1) / 2
    Momentum = Values(2) / 8
    Neurons = Values(3) + Values(4)
    Epochs = (Values(5) + Values(6) + Values(7) + Values(8)) * 100
    strValues = "Learning Rate: " & Learning_Rate & vbCrLf & _
            "Momentum: " & Momentum & vbCrLf & _
            "Neurons: " & Neurons & vbCrLf & _
            "Epochs: " & Epochs

    txtChromosomes = "Best Neural Network" & vbCrLf & vbCrLf & "Chromosome: " & _
            Chromosome & vbCrLf & "Fitness: " & Fitness & vbCrLf & vbCrLf & strValues

    MsgBox "Fittest Neural Network Found!", vbInformation

End Sub