classganet.cls

遗传算法和神经网络的结合应用

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassGAnet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'Neural network

Public ID As Integer
Public max_ID As Integer
Public selected As Boolean
Public fitness_calculated As Boolean
Public fitness As Single
Public noOfInputUnits As Integer
Public noOfHiddenUnits As Integer
Public noOfOutputUnits As Integer
Public noOfConnections As Integer

Const MaxNeurons = 1000

Dim InputUnits(MaxNeurons) As ClassGAneuron
Dim HiddenUnits(MaxNeurons) As ClassGAneuron
Dim OutputUnits(MaxNeurons) As ClassGAneuron

Const NEURON_INPUT = 0
Const NEURON_HIDDEN = 1
Const NEURON_OUTPUT = 2


Public Sub Init(ID_no As Integer, no_of_inputs As Integer, no_of_hiddens As Integer, no_of_outputs As Integer)
'creates an initial network
  Dim i As Integer
  Dim NewNeuron As ClassGAneuron
  
  ID = ID_no
  max_ID = 0
  
  noOfInputUnits = 0
  For i = 0 To no_of_inputs - 1
    Set NewNeuron = New ClassGAneuron
    NewNeuron.NeuronType = NEURON_INPUT
    Call addNeuron(NewNeuron, False)
  Next
  
  noOfHiddenUnits = 0
  For i = 0 To no_of_hiddens - 1
    Set NewNeuron = New ClassGAneuron
    NewNeuron.NeuronType = NEURON_HIDDEN
    Call addNeuron(NewNeuron, False)
  Next
  
  noOfOutputUnits = 0
  For i = 0 To no_of_outputs - 1
    Set NewNeuron = New ClassGAneuron
    NewNeuron.NeuronType = NEURON_OUTPUT
    Call addNeuron(NewNeuron, False)
  Next
  
  For i = 0 To no_of_hiddens - 1
    Call HiddenUnits(i).RandomNeuron(Me)
  Next
  
  For i = 0 To no_of_outputs - 1
    Call OutputUnits(i).RandomNeuron(Me)
  Next
  
  noOfConnections = getNoOfConnections
End Sub


Public Function getNoOfConnections() As Integer
'returns the number of connections in the network
  Dim i As Integer
  Dim c As Integer
  
  c = 0
  For i = 0 To noOfHiddenUnits - 1
    c = c + HiddenUnits(i).noOfConnections
  Next
  For i = 0 To noOfOutputUnits - 1
    c = c + OutputUnits(i).noOfConnections
  Next
  getNoOfConnections = c
End Function


Public Function getRandomNeuron() As ClassGAneuron
'returns a random neuron
  Dim i As Integer
  
  i = CInt(Rnd * (noOfInputUnits + noOfHiddenUnits + noOfOutputUnits - 1))
  If (i < noOfInputUnits) Then
    Set getRandomNeuron = InputUnits(i)
    Else
    If (i < noOfInputUnits + noOfHiddenUnits) Then
      Set getRandomNeuron = HiddenUnits(i - noOfInputUnits)
      Else
      Set getRandomNeuron = OutputUnits(i - (noOfInputUnits + noOfHiddenUnits))
    End If
  End If
End Function


Public Function temp() As Single
'returns the instantaneous temperature of the network
  temp = 1# - fitness
End Function
    
    
Public Sub addNeuron(NewNeuron As ClassGAneuron, KeepID As Boolean)
'adds the given neuron to the network

  If (Not KeepID) Then
    max_ID = max_ID + 1
    NewNeuron.ID = max_ID
  End If
  
  Select Case NewNeuron.NeuronType
    Case NEURON_INPUT
      Set InputUnits(noOfInputUnits) = NewNeuron
      noOfInputUnits = noOfInputUnits + 1
    Case NEURON_HIDDEN
      Set HiddenUnits(noOfHiddenUnits) = NewNeuron
      noOfHiddenUnits = noOfHiddenUnits + 1
    Case NEURON_OUTPUT
      Set OutputUnits(noOfOutputUnits) = NewNeuron
      noOfOutputUnits = noOfOutputUnits + 1
  End Select
  noOfConnections = noOfConnections + NewNeuron.noOfConnections
End Sub


Public Sub Mutate(alpha As Single, temperature As Single, _
  minUnits As Integer, MaxUnits As Integer, _
  minConnections As Integer, MaxConnections As Integer, _
  connectionMutations As Integer, NeuronMutations As Integer, _
  weightSaturation As Single)
'mutates the network

  Dim fromUnit As ClassGAneuron
  Dim toUnit As ClassGAneuron
  Dim newunit As ClassGAneuron
  Dim fromID As Integer
  Dim toID As Integer
  Dim i As Integer
  Dim weight As Single
  Dim insttemp As Single
  Dim j As Integer
  Dim k As Integer

  For i = 0 To NeuronMutations - 1
    insttemp = temperature * Rnd
    'structural mutate units
    If (Rnd < insttemp) Then
      'Note: this ensures that there is an equal probability of addition/deletion
      'delete a hidden unit
      If (Rnd < 0.5) Then
        'add unit
        If (noOfHiddenUnits < MaxUnits) Then
          Set newunit = New ClassGAneuron
          newunit.ID = max_ID + 1
          newunit.NeuronType = NEURON_HIDDEN
          newunit.timeconst = (Rnd * 10#) + 1#
          newunit.noise = Abs(N(5#))
          newunit.threshold = N(1#)
          Call addNeuron(newunit, False)
          If (max_ID > 30000) Then
            Call RenumberUnits
          End If
        End If
          
        Else
                     
        'delete unit
        If (noOfHiddenUnits > minUnits) Then
          j = CInt(Rnd * (noOfHiddenUnits - 1))
          If (j > 0) Then
            'remove connections to this unit
            For k = 0 To noOfHiddenUnits - 1
              Call HiddenUnits(k).removeConnectionsToNeuron(HiddenUnits(j).ID)
            Next
            For k = 0 To noOfOutputUnits - 1
              Call OutputUnits(k).removeConnectionsToNeuron(HiddenUnits(j).ID)
            Next
          
            'remove the unit itself
            For k = j + 1 To noOfHiddenUnits - 1
              Set HiddenUnits(k - 1) = HiddenUnits(k)
            Next
            noOfHiddenUnits = noOfHiddenUnits - 1
          End If
        End If
      End If
    End If
  Next
    
  For i = 0 To connectionMutations - 1
    insttemp = temperature * Rnd
    'mutate connections/params
    If (Rnd < insttemp) Then
      'structural mutation
      toID = CInt(Rnd * (noOfOutputUnits + noOfHiddenUnits - 1))
        
      If (toID < noOfHiddenUnits) Then
        Set toUnit = HiddenUnits(toID)
        Else
        Set toUnit = OutputUnits(toID - noOfHiddenUnits)
      End If
        
      If (Rnd < 0.5) And (toUnit.noOfConnections > 0) Then
        'delete connection
        If (noOfConnections > minConnections) Then
          Call toUnit.DeleteRandomConnection
          noOfConnections = noOfConnections - 1
        End If
          
        Else
          
        'add connection
        If (noOfConnections < MaxConnections) Then
          fromID = toID
          While (fromID = toID)
            fromID = CInt(Rnd * (noOfInputUnits + noOfHiddenUnits + noOfOutputUnits - 1))
          Wend
            
          If (fromID < noOfInputUnits) Then
            Set fromUnit = InputUnits(fromID)
            Else
            If (fromID < noOfInputUnits + noOfHiddenUnits) Then
              Set fromUnit = HiddenUnits(fromID - noOfInputUnits)
              Else
              Set fromUnit = OutputUnits(fromID - (noOfInputUnits + noOfHiddenUnits))
            End If
          End If
            
          weight = ((Rnd * 2) - 1#) * weightSaturation * temperature
          Call toUnit.addConnection(fromUnit, weight, fromUnit.ID)
          noOfConnections = noOfConnections + 1
        End If
      End If
    End If
  Next
    
    
  For i = 0 To noOfHiddenUnits - 1
    insttemp = temperature * Rnd
    Call HiddenUnits(i).Mutate(alpha * insttemp, weightSaturation)
  Next
  
  For i = 0 To noOfOutputUnits - 1
    insttemp = temperature * Rnd
    Call OutputUnits(i).Mutate(alpha * insttemp, weightSaturation)
  Next
            
End Sub
    

Public Sub RenumberUnits()
'creates new IDs for each neuron
  Dim i As Integer
  
  For i = 0 To noOfHiddenUnits - 1
    HiddenUnits(i).ID = noOfInputUnits + 1 + i
  Next
  
  For i = 0 To noOfOutputUnits - 1
    OutputUnits(i).ID = noOfInputUnits + noOfHiddenUnits + 1 + i
  Next
  
  For i = 0 To noOfHiddenUnits - 1
    Call HiddenUnits(i).renumberConnections
  Next
  
  For i = 0 To noOfOutputUnits - 1
    Call OutputUnits(i).renumberConnections
  Next
  
End Sub


Public Function getNeuron(nID As Integer) As ClassGAneuron
'returns the neuron with the given ID
  Dim i As Integer
  Dim found As Boolean
  Dim GAneuron As ClassGAneuron
  
  found = False
  i = 0
  While (i < noOfInputUnits) And (Not found)
    If (InputUnits(i).ID = nID) Then
      found = True
      Set GAneuron = InputUnits(i)
    End If
    i = i + 1
  Wend
  
  i = 0
  While (i < noOfHiddenUnits) And (Not found)
    If (HiddenUnits(i).ID = nID) Then
      found = True
      Set GAneuron = HiddenUnits(i)
    End If
    i = i + 1
  Wend
  
  i = 0
  While (i < noOfOutputUnits) And (Not found)
    If (OutputUnits(i).ID = nID) Then
      found = True
      Set GAneuron = OutputUnits(i)
    End If
    i = i + 1
  Wend
  
  If (found) Then
    Set getNeuron = GAneuron
    Else
    Set getNeuron = Nothing
  End If
  
End Function



Public Sub Copy(Dest As ClassGAnet)
'copies the network
  Dim i As Integer
  Dim NewNeuron As ClassGAneuron
  
  Dest.ID = ID
  Dest.noOfConnections = 0
  Dest.noOfHiddenUnits = 0
  Dest.noOfInputUnits = 0
  Dest.noOfOutputUnits = 0
  Dest.max_ID = max_ID
  
  For i = 0 To noOfInputUnits - 1
    Set NewNeuron = New ClassGAneuron
    Call InputUnits(i).Copy(NewNeuron)
    NewNeuron.NeuronType = NEURON_INPUT
    Call Dest.addNeuron(NewNeuron, True)
  Next
  
  For i = 0 To noOfHiddenUnits - 1
    Set NewNeuron = New ClassGAneuron
    Call HiddenUnits(i).Copy(NewNeuron)
    NewNeuron.NeuronType = NEURON_HIDDEN
    Call Dest.addNeuron(NewNeuron, True)
  Next
  
  For i = 0 To noOfOutputUnits - 1
    Set NewNeuron = New ClassGAneuron
    Call OutputUnits(i).Copy(NewNeuron)
    NewNeuron.NeuronType = NEURON_OUTPUT
    Call Dest.addNeuron(NewNeuron, True)
  Next
  
  Call Dest.Reconnect
  
End Sub


Public Sub Reconnect()
'reconnects the units based on their ID numbers
  Dim i As Integer

  For i = 0 To noOfHiddenUnits - 1
    Call HiddenUnits(i).Reconnect(Me)
  Next
  
  For i = 0 To noOfOutputUnits - 1
    Call OutputUnits(i).Reconnect(Me)
  Next
End Sub


Public Sub Update()
'updates the network
  Dim i As Integer
  
  For i = 0 To noOfHiddenUnits - 1
    HiddenUnits(i).Update
  Next
  For i = 0 To noOfOutputUnits - 1
    OutputUnits(i).Update
  Next
End Sub


Public Sub setInput(index As Integer, value As Single)
  InputUnits(index).State = value
End Sub

Public Function getOutput(index As Integer) As Single
  getOutput = OutputUnits(index).State
End Function


Public Sub Save(fileNumber As Integer)
  Dim i As Integer
  
  Print #fileNumber, ID
  Print #fileNumber, max_ID
  Print #fileNumber, fitness
  Print #fileNumber, noOfInputUnits
  Print #fileNumber, noOfHiddenUnits
  Print #fileNumber, noOfOutputUnits
  Print #fileNumber, noOfConnections

  For i = 0 To noOfInputUnits - 1
    Call InputUnits(i).Save(fileNumber)
  Next
  For i = 0 To noOfHiddenUnits - 1
    Call HiddenUnits(i).Save(fileNumber)
  Next
  For i = 0 To noOfOutputUnits - 1
    Call OutputUnits(i).Save(fileNumber)
  Next

End Sub


Public Sub Load(fileNumber As Integer)
  Dim i As Integer
  
  'delete previous settings
  If (noOfHiddenUnits > 0) Then
    Call Free
  End If
  
  Input #fileNumber, ID
  Input #fileNumber, max_ID
  Input #fileNumber, fitness
  Input #fileNumber, noOfInputUnits
  Input #fileNumber, noOfHiddenUnits
  Input #fileNumber, noOfOutputUnits
  Input #fileNumber, noOfConnections

  For i = 0 To noOfInputUnits - 1
    Set InputUnits(i) = New ClassGAneuron
    Call InputUnits(i).Load(fileNumber)
  Next
  For i = 0 To noOfHiddenUnits - 1
    Set HiddenUnits(i) = New ClassGAneuron
    Call HiddenUnits(i).Load(fileNumber)
  Next
  For i = 0 To noOfOutputUnits - 1
    Set OutputUnits(i) = New ClassGAneuron
    Call OutputUnits(i).Load(fileNumber)
  Next
  Call Reconnect

End Sub



Public Sub Free()
  Dim i As Integer
  
  For i = 0 To noOfInputUnits - 1
    Call InputUnits(i).Free
    Set InputUnits(i) = Nothing
  Next
  For i = 0 To noOfHiddenUnits - 1
    Call HiddenUnits(i).Free
    Set HiddenUnits(i) = Nothing
  Next
  For i = 0 To noOfOutputUnits - 1
    Call OutputUnits(i).Free
    Set OutputUnits(i) = Nothing
  Next
End Sub