main.frm

the attached file contains artifitial neural network code

      Index           =   1
      Left            =   3495
      TabIndex        =   2
      Top             =   570
      Width           =   1095
   End
   Begin VB.Label Label 
      Alignment       =   2  'Center
      Caption         =   "Input"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   0
      Left            =   30
      TabIndex        =   1
      Top             =   570
      Width           =   1095
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private variable As Integer
Private variableCycle As Integer

Private paneStart As Point2d 'Single
Private paneRatio As Double
Private paneEnd As Point2d

Private Sub Form_Load()
    Dim Files As String, FSO As New FileSystemObject
    StatusBar.Panels(1).Text = "Gathering presets..."
    AppPath = App.Path & IIf(Right(App.Path, 1) = "\", "", "\")
    PresetPath = AppPath & "presets\"
    Files = Dir(PresetPath & "*.ini")
    If Not FSO.FolderExists(PresetPath) Then
        Call MkDir(PresetPath)
    End If
    Do While Files <> ""
        Call InitializePreset(PresetPath & Files)
        Files = Dir
    Loop
    Call UpdateToolbarPresets
    StatusBar.Panels(1).Text = "Loading..."
    StatusBar.Panels(2).Text = "Empty network"
    paneRatio = 0.5
    Call InitializeTestSet
End Sub

Private Sub Form_Resize()
    If Me.Width < 8090 Then Me.Width = 8090
    If Me.Height < 8090 Then Me.Height = 8090
    Call Redraw
End Sub

Private Sub hL_Click(Index As Integer)
    Call Pane_Click
End Sub

Private Sub hL_DblClick(Index As Integer)
    If InputValue("Insert a new threshold for " & hNodesCaption(Index) & ":", "Modify value", hNodes(Index), NewValue) Then
        hNodes(Index) = NewValue
        Call Redraw
    End If
End Sub

Private Sub iL_Click(Index As Integer)
    Call Pane_Click
End Sub

Private Sub iL_DblClick(Index As Integer)
    If InputValue("Insert a variable name for " & iNodesCaption(Index) & ":", "Modify variable name", iNodesCaption(Index), NewValue, False) Then
        iNodesCaption(Index) = NewValue
        Call Redraw
    End If
End Sub

Private Sub Label_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Index = 3 Then Call PaneResize_MouseDown(Button, Shift, X + Label(Index).Left, Y + Label(Index).Top)
End Sub

Private Sub Label_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Index = 3 Then Call PaneResize_MouseMove(Button, Shift, X + Label(Index).Left, Y + Label(Index).Top)
End Sub

Private Sub oL_Click(Index As Integer)
    Call Pane_Click
End Sub

Private Sub oL_DblClick(Index As Integer)
    If InputValue("Insert a variable name for " & oNodesCaption(Index) & ":", "Modify variable name", oNodesCaption(Index), NewValue, False) Then
        oNodesCaption(Index) = NewValue
        Call Redraw
    End If
End Sub

Private Sub Pane_Click()
    Call wT1_MouseDown(-1, 1, 0, 0, 0)
End Sub

Private Sub PaneResize_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call GetCursorPos(paneStart)
    paneStart.Y = paneStart.Y - PaneResize.Top / Screen.TwipsPerPixelY
End Sub

Private Sub PaneResize_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call GetCursorPos(paneEnd)
        FormTwips = (paneEnd.Y - paneStart.Y) * Screen.TwipsPerPixelY
        paneRatio = (FormTwips - Pane.Top) / (Pane.Height + WeightsBox.Height)
        Call Redraw
    End If
End Sub

Private Sub Toolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Index
    Case 1
        Load InputValues
        Call InputValues.Prepare(iNodes, iNodesCaption)
        InputValues.Show 1, Me
        If InputValues.Extract(iNodes) Then
            StatusBar.Panels(1).Text = "Calculating..."
            Msg = "Neural network calculated:" & vbCrLf
            Dim hNodeInput() As Double
            ReDim hNodeInput(0 To UBound(hNodes))
            For j = 0 To UBound(hNodes)
                hNodeInput(j) = 0
                For i = 0 To UBound(iNodes)
                    hNodeInput(j) = hNodeInput(j) + iWeights(i, j) * iNodes(i)
                Next i
                Msg = Msg & vbCrLf & hNodesCaption(j) & " = " & hNodeInput(j)
            Next j
            Msg = Msg & vbCrLf
            Dim oNodeInput() As Double
            ReDim oNodeInput(0 To UBound(oNodes))
            For j = 0 To UBound(oNodes)
                For i = 0 To UBound(hNodeInput)
                    Value = 0
                    If hNodeInput(i) >= hNodes(i) Then
                        Value = 1
                    End If
                    oNodeInput(j) = oNodeInput(j) + oWeights(i, j) * Value
                Next i
                Msg = Msg & vbCrLf & oNodesCaption(j) & " = " & oNodeInput(j)
            Next j
            StatusBar.Panels(1).Text = "Ready"
            MsgBox Msg, vbInformation, "Calculation results"
        End If
    Case 3
        Dim reset1 As Boolean, reset2 As Boolean, reset3 As Boolean, reset4 As Boolean
        Load Reset
        Reset.Show 1, Me
        If Reset.Extract(reset1, reset2, reset3, reset4) Then
            For j = 0 To UBound(hNodes)
                If reset1 Then hNodes(j) = 0
                For i = 0 To UBound(iNodes)
                    If reset2 Then iWeights(i, j) = 0
                Next i
            Next j
            For j = 0 To UBound(oNodes)
                For i = 0 To UBound(hNodes)
                    If reset3 Then oWeights(i, j) = 0
                Next i
            Next j
            If reset4 Then Call DefaultVariables
            Call Redraw
        End If
    Case 4
        Load Rescale
        Call Rescale.Prepare(UBound(iNodes) + 1, UBound(hNodes) + 1, UBound(oNodes) + 1)
        Rescale.Show 1, Me
        Dim inputs As Integer, hiddens As Integer, outputs As Integer
        If Rescale.Extract(inputs, hiddens, outputs) Then
            For X = 1 To iB.UBound
                Unload iB(X)
                Unload iL(X)
                Unload wL1(X)
                Unload wT1(X)
            Next X
            For X = 1 To hB.UBound
                Unload hB(X)
                Unload hL(X)
                Unload wL2(X)
                Unload wT2(X)
            Next X
            For X = 1 To oB.UBound
                Unload oB(X)
                Unload oL(X)
            Next X
            ReDim iNodes(0 To inputs - 1), hNodes(0 To hiddens - 1), oNodes(0 To outputs - 1)
            ReDim iNodesCaption(0 To inputs - 1), hNodesCaption(0 To hiddens - 1), oNodesCaption(0 To outputs - 1)
            Call DefaultVariables
            Call SetHiddenNodes
            ReDim iWeights(0 To inputs - 1, 0 To hiddens - 1), oWeights(0 To hiddens - 1, 0 To outputs - 1)
            Call Redraw
        End If
    Case 5
        Load Presets
        Call Presets.Prepare
        Presets.Show 1, Me
        Dim PresetIndex As Integer
        If Presets.Extract(PresetIndex) Then
            Call LoadPreset(PresetIndex)
        End If
    Case 7
        Load Help
        Help.Show 0, Me
    Case 8
        Load About
        About.Show 0, Me
    Case 10
        End
    End Select
End Sub

Private Sub Toolbar_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
    Select Case ButtonMenu.Parent.Index
    Case 5
        Select Case ButtonMenu.Tag
        Case "add"
            Call AddPreset(Me)
        Case ""
            Call LoadPreset(ButtonMenu.Index)
        End Select
    End Select
End Sub

Private Sub wT1_DblClick(Index As Integer)
    If InputValue("Insert a new weight between i[" & Index & "] and h[" & wT1(Index).ListIndex & "]:", "Modify weight", iWeights(Index, wT1(Index).ListIndex), NewValue) Then
        iWeights(Index, wT1(Index).ListIndex) = NewValue
        Call Redraw
    End If
End Sub

Private Sub wT1_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    Call wT1_MouseDown(Index, 1, Shift, 0, 0)
End Sub

Private Sub wT1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Me.Pane.Cls
    For X = 0 To wT1.Count - 1
        If X <> Index Then
            wT1(X).ListIndex = -1
        ElseIf wT1(X).ListIndex > -1 Then
            Call Highlight(Me.iB, Me.hB, Index, wT1(X).ListIndex)
        End If
    Next X
    For X = 0 To wT2.Count - 1
        wT2(X).ListIndex = -1
    Next X
End Sub

Private Sub wT2_DblClick(Index As Integer)
    If InputValue("Insert a new weight between i[" & Index & "] and h[" & wT2(Index).ListIndex & "]:", "Modify weight", oWeights(Index, wT2(Index).ListIndex), NewValue) Then
        oWeights(Index, wT2(Index).ListIndex) = NewValue
        Call Redraw
    End If
End Sub

Private Sub wT2_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    Call wT2_MouseDown(Index, 1, Shift, 0, 0)
End Sub

Private Sub wT2_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Me.Pane.Cls
    For X = 0 To wT1.Count - 1
        wT1(X).ListIndex = -1
    Next X
    For X = 0 To wT2.Count - 1
        If X <> Index Then
            wT2(X).ListIndex = -1
        ElseIf wT2(X).ListIndex > -1 Then
            Call Highlight(Me.hB, Me.oB, Index, wT2(X).ListIndex)
        End If
    Next X
End Sub


' ################
' Custom functions
' ################

Private Sub InitializeTestSet()
    ReDim TestSet(0, 0), TestSetResult(0)
    ReDim iNodes(0), hNodes(0), oNodes(0)
    ReDim iNodesCaption(0), oNodesCaption(0)
    ReDim iWeights(0, 0), oWeights(0, 0)

    Call DefaultVariables
    Call SetHiddenNodes
End Sub

Private Sub InitializeTestSet2()
    ReDim TestSet(0 To 1, 0 To 1), TestSetResult(0 To 1)
    ReDim iNodes(0 To 1), hNodes(0 To 2), oNodes(0)
    ReDim iNodesCaption(0 To 1), oNodesCaption(0)
    ReDim iWeights(0 To 1, 0 To 2), oWeights(0 To 2, 0)
    
    ' Perceptron thresholds
    hNodes(0) = 1
    hNodes(1) = 2
    hNodes(2) = 1
    ' Output threshold
    oNodes(0) = 1
    
    Call DefaultVariables
    Call SetHiddenNodes
    
    ' Perceptron weights
    iWeights(0, 0) = 1
    iWeights(0, 1) = 1
    iWeights(0, 2) = 0
    iWeights(1, 0) = 0
    iWeights(1, 1) = 1
    iWeights(1, 2) = 1
    ' Output weights
    oWeights(0, 0) = 1
    oWeights(1, 0) = -2
    oWeights(2, 0) = 1
    
    'Command(0).Caption = "Train #1 of " & UBound(TestSet) + 1
    
    ' Concept: XOR