module2.bas

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

Attribute VB_Name = "Module2"
'正向推理模块
Option Explicit
Public bValidate As Boolean '有效性
Public Const max = 10
Public oDoc As MSXML.DOMDocument   '定义全局DOM文档
Dim dw As WroxXml.CDomFunctions    '定义全局DOM函数库
Public savequeue(100, 4) As String '存推理中间结果
Public resultqueue(100, 100, 5) As String
Public RecordIndex As Integer
Public outputflag As Integer            '是否推理出结果标志
Public user_information_code As Integer '输出信息编号
Public FileNum As Integer '记录打开的文件
Public iDoc As Integer      '文档数
Public frmD(max) As frmDocument '知识库文档
Public bAutoAdd As Boolean  '标志是否自动添加信息
Public bAutoSave As Boolean '自动存盘
Public m_saveinteval As Integer
Public sPrj As String '记录工程文件名
Public Prj_Location As String '记录工程路径
Public Prj_Name As String '记录工程名
Public Reverse_Reason_flag As Integer '正反向推理标志
Public sXML(max) As String
Public Rmax, Cmax As String '记录结果所占用的行和列数
Public clk As Integer '记录推理次数
Public res As Integer '记录结论
Public centernode As IXMLDOMNode
Public flag As Integer
Public currentXml As String '当前XML文档名


Public Sub Method(ByRef KeyWord As String)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim oelem As IXMLDOMNode
Dim tempnode As IXMLDOMNode
Dim item As ListItem

For i = 0 To oDoc.documentElement.childNodes.length - 1
Set oelem = oDoc.documentElement.childNodes(i)
For j = 0 To oelem.childNodes.length - 1
Set tempnode = oelem.childNodes(j)
'-------------------------------------------------------
If (tempnode.nodeName = "METHOD") Then
    If (tempnode.attributes(0).nodeValue = KeyWord) Then
    
    For k = 0 To tempnode.childNodes.length - 1
 '----------------------------------------------------------
    Select Case tempnode.childNodes(k).nodeName
    Case "SELECT"
        If NotInFacts(tempnode.childNodes(k)) Then
            MySelect tempnode.childNodes(k)
        Else
            UpdateFacts tempnode.childNodes(k)
        End If
 '-------------------------------------------------------
    
    Case "REASON"
        Reason tempnode.childNodes(k).attributes(0).nodeValue

 '------------------------------------------------------------
    Case "SEND"
        Method tempnode.childNodes(k).attributes(0).nodeValue
 '------------------------------------------------------------
    Case "WRITE"
        MyWrite tempnode.childNodes(k)
 '-------------------------------------------------------------
    Case "STATEMENT"
        statement tempnode.childNodes(k)
    
    Case "MATH"
        MathXml tempnode.childNodes(k)
    Case "SELECTNUM"
        SelectNum tempnode.childNodes(k)
    Case "IF"
        IfMethod tempnode.childNodes(k)
    End Select
    Next
    End If
End If
Next
Next
If outputflag = 0 Then
    'MsgBox "没有推出结论", , "提示信息"
    Set item = frmOutput.LVoutput.ListItems.Add(, , "用户信息")
    item.SubItems(1) = "没有推出结论"
End If
End Sub

'*************************************
'     功能：选择语句及界面实现
'*************************************
Public Sub MySelect(ByRef selectnode As IXMLDOMNode)
Dim k As Integer
Dim j As Integer
Dim i As Integer
Dim tempnodelist As IXMLDOMNodeList
Dim tempnode As IXMLDOMNode
Dim myform As New FormSelect
Dim InputForm As New FormInput

savequeue(RecordIndex, 0) = selectnode.attributes(0).nodeValue
savequeue(RecordIndex, 1) = selectnode.attributes(1).nodeValue
myform.Label2.Caption = "选择_" + selectnode.attributes(0).nodeValue + "_" + selectnode.attributes(1).nodeValue
InputForm.Label1.Caption = "请输入_" + selectnode.attributes(0).nodeValue + "_" + selectnode.attributes(1).nodeValue
        
myform.lblExplain.Caption = AddLabel(selectnode.attributes(0).nodeValue, selectnode.attributes(1).nodeValue)
If selectnode.hasChildNodes Then

   For k = 1 To selectnode.childNodes.length
       Load myform.Option1(k)
       Load myform.Label1(k)
       myform.Option1(k).Top = myform.Option1(k - 1).Top + 600
       myform.Option1(k).Visible = True
       myform.Label1(k).Top = myform.Label1(k - 1).Top + 600
       myform.Label1(k).Visible = True
       myform.Label1(k).Caption = selectnode.childNodes(k - 1).Text
   Next
   myform.Caption = "Dest"
   myform.Combo1.Visible = True
   myform.NextButton.Top = myform.Label1(selectnode.childNodes.length).Top + 600
   myform.PrevButton.Top = myform.Label1(selectnode.childNodes.length).Top + 600
   
   With myform.Line1
    .BorderColor = &H808080
    .x1 = 0
    .y1 = myform.NextButton.Top + myform.NextButton.Height + 100
    .x2 = myform.ScaleWidth
    .y2 = .y1
   End With
   With myform.Line2
    .BorderColor = vbWhite
    .x1 = myform.Line1.x1
    .y1 = myform.Line1.y1 + 20
    .x2 = myform.Line1.x2
    .y2 = .y1
   End With
   
   myform.Frame1.Top = myform.PrevButton.Top + myform.PrevButton.Height + 200
   myform.Height = myform.NextButton.Top + myform.Top + myform.Frame1.Height + 900
   myform.Show vbModal
Else
   Set centernode = selectnode
   InputForm.Label1.Visible = True
   InputForm.Show vbModal
End If
End Sub

'*************************************
'     功能：给对象属性添加说明性文字
'*************************************
Private Function AddLabel(ByRef obj As String, ByRef Att As String) As String
Dim i, j, k, m, N As Integer
Dim Object As IXMLDOMNode
Dim AttNode As IXMLDOMNode
For i = 0 To oDoc.documentElement.childNodes.length - 1
    Set Object = oDoc.documentElement.childNodes(i)
    For m = 0 To Object.attributes.length - 1
    If Object.attributes(m).nodeValue = obj And Object.attributes(m).nodeName = "name" Then
        For j = 0 To Object.childNodes.length - 1
            If Object.childNodes(j).nodeName = "ATTRIBUTE" Then
                Set AttNode = Object.childNodes(j)
                For k = 0 To AttNode.attributes.length - 1
                    If AttNode.attributes(k).nodeValue = Att And AttNode.attributes(k).nodeName = "name" Then
                        For N = 0 To AttNode.attributes.length - 1
                            If AttNode.attributes(N).nodeName = "explain" Then
                                AddLabel = AttNode.attributes(N).nodeValue
                                Exit Function
                            End If
                        Next N
                    End If
                Next k
            End If
        Next j
        AddLabel = "无相关说明"
        Exit Function
    End If
    Next m
Next i
End Function

Private Sub statement(ByRef onode As IXMLDOMNode)
Dim item As ListItem
Dim i As Integer
For i = 0 To RecordIndex - 1
If savequeue(i, 0) = onode.attributes(0).nodeValue And _
    savequeue(i, 1) = onode.attributes(1).nodeValue And _
    savequeue(i, 2) = onode.attributes(2).nodeValue Then
    
    savequeue(i, 0) = onode.attributes(0).nodeValue
    savequeue(i, 1) = onode.attributes(1).nodeValue
    savequeue(i, 2) = onode.attributes(2).nodeValue
    savequeue(i, 3) = onode.attributes(3).nodeValue
    savequeue(i, 4) = savequeue(i, 0) + savequeue(i, 1) + savequeue(i, 2) + savequeue(i, 3)
    Set item = frmOutput.LVoutput.ListItems.Add(, , "用户信息", 3, 3)
    item.SubItems(1) = savequeue(RecordIndex, 4)
    user_information_code = user_information_code + 1
    Exit Sub
End If
Next
savequeue(RecordIndex, 0) = onode.attributes(0).nodeValue
savequeue(RecordIndex, 1) = onode.attributes(1).nodeValue
savequeue(RecordIndex, 2) = onode.attributes(2).nodeValue
savequeue(RecordIndex, 3) = onode.attributes(3).nodeValue
savequeue(i, 4) = savequeue(i, 0) + savequeue(i, 1) + " " + savequeue(i, 2) + " " + savequeue(i, 3)
Set item = frmOutput.LVoutput.ListItems.Add(, , "用户信息", 3, 3)
item.SubItems(1) = savequeue(RecordIndex, 4)
user_information_code = user_information_code + 1
RecordIndex = RecordIndex + 1
End Sub

Private Sub Reason(ByRef Myobject As String)
Dim i As Integer
Dim j As Integer
Dim q As Integer
Dim l As Integer
Dim myindex As Integer
Dim oelem As IXMLDOMNode
Dim temp As IXMLDOMNode
Dim item As ListItem

For i = 0 To oDoc.documentElement.childNodes.length - 1
Set oelem = oDoc.documentElement.childNodes(i)
If Not oelem.attributes Is Nothing Then
    For l = 0 To oelem.attributes.length - 1
    If (oelem.attributes(l).nodeValue = Myobject And oelem.attributes(l).nodeName = "name") Then
    For j = 0 To oelem.childNodes.length - 1
    Set temp = oelem.childNodes(j)
    If (temp.nodeName = "RULE") Then
    If PreconditionMatch(temp.firstChild) Then
          outputflag = 1
          myindex = RecordIndex
        For q = 0 To temp.firstChild.nextSibling.childNodes.length - 1
            Set item = frmOutput.LVoutput.ListItems.Add(, , "推理结论", 2, 2)
            item.SubItems(1) = temp.firstChild.nextSibling.childNodes(q).attributes(0).nodeValue + _
            temp.firstChild.nextSibling.childNodes(q).attributes(1).nodeValue + " " + _
            temp.firstChild.nextSibling.childNodes(q).attributes(2).nodeValue + " " + _
            temp.firstChild.nextSibling.childNodes(q).attributes(3).nodeValue
            If NotInFacts(temp.firstChild.nextSibling.childNodes(q)) Then
                savequeue(RecordIndex, 0) = temp.firstChild.nextSibling.childNodes(q).attributes(0).nodeValue
                savequeue(RecordIndex, 1) = temp.firstChild.nextSibling.childNodes(q).attributes(1).nodeValue
                savequeue(RecordIndex, 2) = temp.firstChild.nextSibling.childNodes(q).attributes(2).nodeValue
                savequeue(RecordIndex, 3) = temp.firstChild.nextSibling.childNodes(q).attributes(3).nodeValue
                savequeue(RecordIndex, 4) = temp.firstChild.nextSibling.childNodes(q).Text
                resultqueue(clk, res, 0) = temp.firstChild.nextSibling.childNodes(q).attributes(0).nodeValue
                resultqueue(clk, res, 1) = temp.firstChild.nextSibling.childNodes(q).attributes(1).nodeValue
                resultqueue(clk, res, 2) = temp.firstChild.nextSibling.childNodes(q).attributes(2).nodeValue
                resultqueue(clk, res, 3) = temp.firstChild.nextSibling.childNodes(q).attributes(3).nodeValue
                resultqueue(clk, res, 4) = temp.firstChild.nextSibling.childNodes(q).Text
                If (q < temp.firstChild.nextSibling.childNodes.length - 1) Then
                    RecordIndex = RecordIndex + 1
                End If
                res = res + 1
            Else
                UpdateFacts temp.firstChild.nextSibling.childNodes(q)
            End If
        Next
        RecordIndex = RecordIndex + 1
    End If
    End If
    Next
End If
Next
End If
Next
End Sub

Function PreconditionMatch(ByRef ifNode As IXMLDOMNode) As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer '记录匹配的前提数
k = 0

For j = 0 To ifNode.childNodes.length - 1
    For i = 0 To RecordIndex
       If (ifNode.childNodes(j).attributes(0).nodeValue = savequeue(i, 0)) And _
       (ifNode.childNodes(j).attributes(1).nodeValue = savequeue(i, 1)) Then
        
       '-------------------------------------------------------
          If ifNode.childNodes(j).attributes(2).nodeValue = "等于" Then
             If ifNode.childNodes(j).attributes(3).nodeValue = savequeue(i, 3) Then
                k = k + 1
             End If
          End If
       '-------------------------------------------------------
          If ifNode.childNodes(j).attributes(2).nodeValue = "不等于" Then