module2.bas

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

             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
             If CInt(savequeue(i, 3)) > CInt(ifNode.childNodes(j).attributes(3).nodeValue) Then
                k = k + 1
             End If
          End If
       '-------------------------------------------------------
          If ifNode.childNodes(j).attributes(2).nodeValue = "小于" Then
             If CInt(savequeue(i, 3)) < CInt(ifNode.childNodes(j).attributes(3).nodeValue) Then
                k = k + 1
             End If
          End If
       '---------------------------------------------------------
       End If
     Next
Next

If k = ifNode.childNodes.length Then
   PreconditionMatch = True
Else
   PreconditionMatch = False
End If
End Function


'****************************************************
'  '删去
'*************************************************
Private Sub SelectAndSend(ByRef m_node As IXMLDOMNode)
Dim m_string As String
Dim objnode As IXMLDOMNode
Dim objChildnode As IXMLDOMNode
Dim objFathernode As IXMLDOMNode
Dim i As Integer
Dim k As Integer
Dim j As Integer
Dim recordChild(10) As Integer
Dim m_ChildIDstring() As String
Dim myform As New FormSelectAndSend
m_string = m_node.attributes(0).nodeValue
myform.Caption = "Dest"
myform.Label2.Caption = "选择" & m_string
savequeue(RecordIndex, 0) = m_string
resultqueue(clk, res, 0) = m_string

For i = 0 To oDoc.documentElement.childNodes.length - 1
    Set objnode = oDoc.documentElement.childNodes(i)
    For j = 0 To objnode.attributes.length - 1
        If (objnode.attributes(j).nodeValue = m_string) Then Set objFathernode = objnode
    Next
Next

m_string = objFathernode.attributes(1).nodeValue
m_ChildIDstring() = Split(m_string)

For k = 1 To UBound(m_ChildIDstring) + 1
    For i = 0 To oDoc.documentElement.childNodes.length - 1
        If m_ChildIDstring(k - 1) = oDoc.documentElement.childNodes(i).attributes(0).nodeValue Then
        recordChild(k - 1) = i
        Exit For
        End If
    Next
        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
        
        For j = 0 To oDoc.documentElement.childNodes(i).attributes.length - 1
            If oDoc.documentElement.childNodes(i).attributes(j).nodeName = "name" Then
            myform.Label1(k).Caption = oDoc.documentElement.childNodes(i).attributes(j).nodeValue
            End If
        Next
Next

myform.NextButton.Top = myform.Label1(UBound(m_ChildIDstring) + 1).Top + 900
myform.PrevButton.Top = myform.Label1(UBound(m_ChildIDstring) + 1).Top + 900
myform.Height = myform.PrevButton.Top - myform.Top + 1200
myform.Show vbModal

For k = 0 To UBound(m_ChildIDstring)
If (flag = k + 1) Then
SendProcess oDoc.documentElement.childNodes(recordChild(k))
Exit For
End If
Next

End Sub

Public Sub MyWrite(ByRef m_node As IXMLDOMNode)
MsgBox m_node.Text + "              " + vbCrLf + vbCrLf + vbCrLf, , "提示信息"
End Sub

'****************************************************
'  '删去
'*************************************************
Private Sub SendProcess(ByRef m_node As IXMLDOMNode)
Dim i As Integer
For i = 0 To m_node.childNodes.length - 1
    If m_node.childNodes(i).nodeName = "METHOD" Then
    Method (m_node.childNodes(i).attributes(0).nodeValue)
    End If
Next
End Sub

Function NotInFacts(ByRef ifNode As IXMLDOMNode) As Boolean
Dim i As Integer
Dim flag As Boolean

flag = True
For i = 0 To RecordIndex - 1
    If (ifNode.attributes(0).nodeValue = savequeue(i, 0)) And _
        (ifNode.attributes(1).nodeValue = savequeue(i, 1)) Then
       flag = False
       Exit For
    End If
Next

NotInFacts = flag

End Function

Function MathXml(ByRef mathnode As IXMLDOMNode) As Double
Dim i, j As Integer
Dim str As String
str = ""
For i = 0 To mathnode.childNodes.length - 1
Select Case mathnode.childNodes(i).nodeName
Case "NUM"
   str = str + mathnode.childNodes(i).nodeTypedValue
Case "DIV"
    str = str + "/"
Case "MUL"
    str = str + "*"
Case "VARIABLE"
    For j = 0 To oDoc.nodeFromID(mathnode.childNodes(i).nodeTypedValue).attributes.length - 1
        If (oDoc.nodeFromID(mathnode.childNodes(i).nodeTypedValue).attributes(j).nodeName = "value") Then
              str = str + oDoc.nodeFromID(mathnode.childNodes(i).nodeTypedValue).attributes(j).nodeValue
              Exit For
        End If
    Next
Case "ADD"
    str = str + "+"
Case "SUB"
    str = str + "-"
End Select
Next
MsgBox str + vbCrLf + CStr(calc_Kuohao(str))
End Function

Function SelectNum(ByRef onode As IXMLDOMNode)
Dim myform As New FormSelectAndSend
Dim m_string() As String
Dim k As Integer
Set myform.pnode = oDoc.nodeFromID(onode.attributes(0).nodeValue)
m_string = Split(onode.attributes(1).nodeValue)
myform.Caption = "Dest"
myform.Label2.Caption = "请选择"
'savequeue(RecordIndex, 0) =
'resultqueue(clk, res, 0) =
For k = 1 To UBound(m_string) + 1
    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).Caption = m_string(k - 1)
    myform.Label1(k).Visible = True
Next
myform.NextButton.Top = myform.Label1(UBound(m_string) + 1).Top + 900
myform.PrevButton.Top = myform.Label1(UBound(m_string) + 1).Top + 900
myform.Height = myform.PrevButton.Top - myform.Top + 1200
myform.Show vbModal
End Function

Function IfMethod(ByRef onode As IXMLDOMNode)
If JudgeIf(onode) = True Then
    DoThen onode.nextSibling
End If
End Function

Function DoThen(ByRef onode As IXMLDOMNode)
    Method_1 onode
End Function

Function Method_1(ByRef onode As IXMLDOMNode)
Dim k As Integer
For k = 0 To onode.childNodes.length - 1
Select Case onode.childNodes(k).nodeName
    Case "SELECT"
        If NotInFacts(onode.childNodes(k)) Then
        savequeue(RecordIndex, 0) = onode.childNodes(k).attributes(0).nodeValue
        savequeue(RecordIndex, 1) = onode.childNodes(k).attributes(1).nodeValue
        MySelect onode.childNodes(k)
        End If
     '-------------------------------------------------------
    
    Case "REASON"
        Reason onode.childNodes(k).attributes(0).nodeValue

    '------------------------------------------------------------
    Case "SEND"
        Method onode.childNodes(k).attributes(0).nodeValue
    '------------------------------------------------------------
    Case "WRITE"
        MyWrite onode.childNodes(k)
    '-------------------------------------------------------------
    Case "MATH"
        MathXml onode.childNodes(k)
    Case "SELECTNUM"
        SelectNum onode.childNodes(k)
    Case "IF"
        IfMethod onode.childNodes(k)
End Select
Next
End Function

Private Sub UpdateFacts(ByRef onode As IXMLDOMNode)
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, 3) = onode.attributes(0).nodeValue + onode.attributes(1).nodeValue + onode.attributes(2).nodeValue + onode.attributes(3).nodeValue
    Exit Sub
End If
Next
End Sub


'****************************************************
'  '判断IF语句中的条件表达式成立与否,返回True表示成立
'****************************************************
Private Function JudgeIf(ByRef onode As IXMLDOMNode) As Boolean
Dim i, j As Integer
Dim pnode, qnode As IXMLDOMNode

Dim flag As Boolean
For j = 0 To onode.childNodes.length - 1
Set qnode = onode.childNodes(j)
Select Case qnode.attributes(0).nodeName
Case "object":
    flag = False
    For i = 0 To RecordIndex - 1
        If savequeue(i, 0) = qnode.attributes(0).nodeValue And _
        savequeue(i, 1) = qnode.attributes(1).nodeValue And _
        savequeue(i, 2) = qnode.attributes(2).nodeValue And _
        savequeue(i, 3) = qnode.attributes(3).nodeValue Then
        flag = True
        Exit For
        End If
    Next
Case "varname":
    Set pnode = oDoc.nodeFromID(qnode.attributes(0).nodeValue)
    flag = False
    For i = 0 To pnode.attributes.length - 1
        If pnode.attributes(i).nodeName = "value" And _
        pnode.attributes(i).nodeValue = qnode.attributes(2).nodeValue Then
        flag = True
        Exit For
        End If
    Next
End Select
Next
JudgeIf = flag
End Function

Public Sub SchemeManager()
'MsgBox "待添加方案管理模块", vbApplicationModal, "Dest3.0"

End Sub

Public Sub CollisionDetect()
'MsgBox "待添加冲突检测模块", vbApplicationModal, "Dest3.0"
End Sub