module6.bas

用XML做专家系统的一个编译器,有说明书,使用简单,有模板

Attribute VB_Name = "Module6"
'样本学习模块
'//////////////////////////////////////////////////yr 04-1-11
Public W() As Single
Public Xi() As Integer
Public x() As Integer '样本输入
Public d() As Integer '样本输出
Public NodeNum As Integer '节点数
Public SampleNum As Integer '样本数
Public pow As Integer
Public work() As Integer '工作区
Public rebuf() As Integer '缓冲区
Public WorkNum As Integer '工作区长度
Public RebufNum As Integer '缓冲区长度
Public change As Boolean
Public flg() As Boolean

Public Sub SampleLearn()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim wij As Single
Dim deta As Single

Dim rest As Integer
Dim temp As Integer

On Error GoTo errorhand

NodeNum = frmLearning.MSFlexGrid1.Cols - 2 '节点数，变量数
SampleNum = frmLearning.MSFlexGrid1.Rows - 1 '样本数

pow = 1
For i = 1 To NodeNum
    pow = pow * 2
Next

'样本预处理
'-------------------------------------------------------------------------

'-------------------------------------------------------------------------
'获得完备样本集
'-------------------------------------------------------------------------
'输入量
ReDim x(SampleNum - 1, NodeNum)
ReDim d(SampleNum - 1)
For i = 0 To SampleNum - 1
    x(i, 0) = 1
Next

'读入样本记录
For i = 1 To frmLearning.MSFlexGrid1.Rows - 1
'    Debug.Print "第" + CStr(i) + "个样本："
    For j = 1 To frmLearning.MSFlexGrid1.Cols - 2
        x(i - 1, j) = frmLearning.MSFlexGrid1.TextMatrix(i, j)
    Next
    d(i - 1) = frmLearning.MSFlexGrid1.TextMatrix(i, j)
'    Debug.Print d(i - 1)
Next


'网络训练
ReDim W(NodeNum, NodeNum)

For i = 0 To NodeNum
    For j = 0 To i
        wij = Rnd(Timer)
        Do While wij = 0
        wij = Rnd(Timer)
        Loop
        W(i, j) = wij
        W(j, i) = W(i, j)
    Next
Next

'调整权值矩阵
For i = 0 To SampleNum - 1
    If Sigmod(i) <> d(i) Then
       deta = CSng(d(i) - Sigmod(i))
       Call Revise(i, deta)
       i = -1
    End If
Next

ReDim x(pow - 1, NodeNum)
ReDim d(pow - 1)

For j = 0 To pow - 1
    temp = j
    x(j, 0) = 1
    For i = 1 To NodeNum
        rest = temp Mod 2
        x(j, i) = rest
        temp = (temp - rest) / 2
    Next
Next

For i = 0 To pow - 1
    d(i) = Sigmod(i)
Next

'---------------------------------------------------------------------------
'逻辑式化简
ReDim work(NodeNum - 1, pow - 1)
ReDim rebuf(NodeNum - 1, pow - 1)

Dim time As Integer

change = True

WorkNum = 0
RebufNum = 0

For i = 0 To pow - 1
    If d(i) Then
       For j = 0 To NodeNum - 1
           work(j, WorkNum) = x(i, j + 1)
       Next
       WorkNum = WorkNum + 1
    End If
Next

time = 0

Do While change = True
   ReDim flg(WorkNum - 1)
   change = False
   For i = 0 To WorkNum - 1
       flg(i) = True
   Next
   
   For k = 0 To WorkNum - 2
       For l = k + 1 To WorkNum - 1
         Call Merge(k, l)
       Next
   Next
            
   For i = 0 To WorkNum - 1
       If flg(i) = True Then
          For j = 0 To NodeNum - 1
              rebuf(j, RebufNum) = work(j, i)
          Next
          RebufNum = RebufNum + 1
       End If
   Next
   
   time = time + 1
'   MsgBox "第" + CStr(time) + "次"
   
   If change = True Then
      '将缓冲区的合取式拷入工作区，并删除重复的合取式
      ReDim work(NodeNum - 1, RebufNum - 1)
      For i = 0 To RebufNum - 1
          For j = 0 To NodeNum - 1
              work(j, i) = rebuf(j, i)
          Next
      Next
      Call DelRepeat
   End If
   RebufNum = 0
   
Loop
'化简完毕
'--------------------------------------------------------------------
'MsgBox "化简完毕！"

For i = 0 To WorkNum - 1
'    MsgBox "第" + CStr(i) + "列"
    For j = 0 To NodeNum - 1
'        MsgBox CStr(work(j, i))
    Next
Next

'显示学习后的结果
frmLearning.MSFlexGrid2.Rows = WorkNum + 1
frmLearning.MSFlexGrid2.Cols = NodeNum + 2
For i = 0 To frmLearning.MSFlexGrid2.Cols - 1
        frmLearning.MSFlexGrid2.ColWidth(i) = frmLearning.MSFlexGrid2.Width / 5
        frmLearning.MSFlexGrid2.TextMatrix(0, i) = frmLearning.MSFlexGrid1.TextMatrix(0, i)
Next
For i = 0 To NodeNum
    For j = 1 To WorkNum
        If i = 0 Then
            frmLearning.MSFlexGrid2.TextMatrix(j, 0) = frmLearning.MSFlexGrid1.TextMatrix(j, 0)
        Else
            frmLearning.MSFlexGrid2.TextMatrix(j, i) = work(i - 1, j - 1)
        End If
    Next
Next
For j = 0 To WorkNum
    If j = 0 Then
        frmLearning.MSFlexGrid2.TextMatrix(j, NodeNum + 1) = frmLearning.MSFlexGrid1.TextMatrix(j, NodeNum + 1)
    Else
        frmLearning.MSFlexGrid2.TextMatrix(j, NodeNum + 1) = "1"
    End If
Next
frmLearning.MSFlexGrid2.TextMatrix(0, 0) = "规则号"

errorhand: Exit Sub

End Sub

Function Sigmod(ii As Integer) As Integer
Dim S As Single

S = W(0, 0) * x(ii, 0) * x(ii, 0) + W(1, 0) * x(ii, 1) * x(ii, 0) + W(2, 0) * x(ii, 0) * x(ii, 2) + W(3, 0) * x(ii, 0) * x(ii, 3) _
  + W(0, 1) * x(ii, 1) * x(ii, 0) + W(1, 1) * x(ii, 1) * x(ii, 1) + W(2, 1) * x(ii, 1) * x(ii, 2) + W(3, 1) * x(ii, 1) * x(ii, 3) _
  + W(0, 2) * x(ii, 2) * x(ii, 0) + W(1, 2) * x(ii, 1) * x(ii, 2) + W(2, 2) * x(ii, 2) * x(ii, 2) + W(3, 2) * x(ii, 2) * x(ii, 3) _
  + W(0, 3) * x(ii, 3) * x(ii, 0) + W(1, 3) * x(ii, 1) * x(ii, 3) + W(2, 3) * x(ii, 3) * x(ii, 2) + W(3, 3) * x(ii, 3) * x(ii, 3)

If S >= 0 Then
   Sigmod = 1
Else
   Sigmod = 0
End If
End Function



Sub Revise(ii As Integer, deta As Single)
Dim i As Integer
Dim j As Integer
Dim Yita As Single

Yita = 0.5

For i = 0 To NodeNum
    For j = 0 To NodeNum
        W(i, j) = W(i, j) + Yita * deta * x(ii, i) * x(ii, j)
    Next
Next

End Sub

Sub Merge(KK As Integer, LL As Integer)
Dim i As Integer
Dim j As Integer
Dim jj As Integer
Dim k As Integer
Dim l As Integer
Dim mark As Boolean
Dim r As Integer

For j = 0 To NodeNum - 1
    If work(j, KK) = -1 Or work(j, LL) = -1 Then '-1意味着逻辑式与该变量无关
       mark = True
       For jj = 0 To NodeNum - 1
          If jj <> j And work(jj, KK) <> work(jj, LL) Then
             mark = False
          End If
       Next
       If mark Then
          For jj = 0 To NodeNum - 1
              If jj = j Then
                 rebuf(jj, RebufNum) = -1
              Else
                 rebuf(jj, RebufNum) = work(jj, KK)
              End If
              RebufNum = RebufNum + 1
          Next
          RebufNum = RebufNum + 1
          GoTo Bottom
       End If
    Else
       If (work(j, KK) = 0 And work(j, LL) = 1) Or (work(j, KK) = 1 And work(j, LL) = 0) Then
          mark = True
          For jj = 0 To NodeNum - 1
              If jj <> j And work(jj, KK) <> work(jj, LL) Then
                 mark = False
              End If
          Next
          If mark Then
             For jj = 0 To NodeNum - 1
                 If jj = j Then
                    rebuf(jj, RebufNum) = -1
                 Else
                    rebuf(jj, RebufNum) = work(jj, KK)
                 End If
             Next
             RebufNum = RebufNum + 1
             GoTo Bottom
          End If
        End If
     End If
Next
Exit Sub

Bottom:
         change = True
         flg(KK) = False
         flg(LL) = False

End Sub

Sub DelRepeat()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim mark As Boolean

WorkNum = 0
For j = 0 To NodeNum - 1
    work(j, WorkNum) = rebuf(j, WorkNum)
Next

For i = 1 To RebufNum - 1
    mark = False
    For j = 0 To NodeNum - 1
        If work(j, WorkNum) <> rebuf(j, i) Then
           mark = True
        End If
    Next
    If mark Then
       WorkNum = WorkNum + 1
       For j = 0 To NodeNum - 1
           work(j, WorkNum) = rebuf(j, i)
       Next
    End If
Next
WorkNum = WorkNum + 1

'MsgBox "new"
For i = 0 To WorkNum - 1
    For j = 0 To NodeNum - 1
'        MsgBox CStr(work(j, i))
    Next
Next

End Sub