module3.bas

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

Attribute VB_Name = "Module3"
'反向推理
Option Explicit
Const max = 100
Public yes As uAttribute
Public no As uAttribute

Public Type uStatement             '规则类
    Object As String
    attribute As String
    relation As String
    value As String
End Type

Public Type uAttribute
     Attrib(0 To 9) As uStatement   '一条规则最多十个前提
     Att_number As Integer
End Type

Public Type uObject
Name As String
End Type

Private Sub query(ByRef m_string As String)
Dim oelem As IXMLDOMNode
Dim Node As IXMLDOMNode
Dim m_nodelist As IXMLDOMNodeList
Dim i As Integer
Dim p As Integer
Dim j As Integer
Dim k As Integer
Dim ap As uAttribute
'ap.Att_number = 0

For i = 0 To oDoc.documentElement.childNodes.length - 1
Set oelem = oDoc.documentElement.childNodes(i)
For p = 0 To oelem.attributes.length - 1
If (oelem.attributes(p).nodeValue = m_string) Then
Set m_nodelist = oelem.selectNodes("RULE")

For j = 0 To m_nodelist.length - 1
For k = 0 To m_nodelist(j).childNodes(1).childNodes.length - 1
If (tryob(m_nodelist(j).firstChild.childNodes, m_nodelist(j).childNodes(1).childNodes(k))) Then
If (MsgBox(add_statement(m_nodelist(j).childNodes(1).childNodes(k)) & vbCrLf & "符合当前的描述" & vbCrLf & "需要继续搜寻吗?", vbYesNoCancel) = vbNo) Then
    Exit Sub
End If
End If
Next
Next

Exit Sub
End If
Next

Next
'MsgBox "没有找到符合当前描述的新结论", vbInformation, "推测结论"
End Sub

Private Function tryob(ByRef m_nodelist As IXMLDOMNodeList, ByRef m_node As IXMLDOMNode) As Integer
Dim answer As Integer
Dim a As uAttribute
Dim i As Integer

If (Not trailno(m_nodelist, m_node)) Then
tryob = 0
Exit Function
End If
If (Not trailyes(m_nodelist, m_node)) Then
tryob = 0
Exit Function
End If

i = 0
Do While (i < m_nodelist.length)
If (ask(m_nodelist(i))) Then
answer = MsgBox("你需要推测的对象具有如下属性吗？" & vbCrLf & add_statement(m_nodelist(i)), vbYesNoCancel, "提示信息")
a.Att_number = 0

Select Case answer

Case 7 '选择否
mystrcpy a, m_nodelist(i)

 no.Attrib(no.Att_number) = a.Attrib(a.Att_number - 1)
 no.Att_number = no.Att_number + 1
 tryob = 0
 Exit Function


Case 6 '选择是
mystrcpy a, m_nodelist(i)                               'strcpy函数
 yes.Attrib(yes.Att_number) = a.Attrib(a.Att_number - 1)
 yes.Att_number = yes.Att_number + 1
 i = i + 1

Case 2
MsgBox "解释模块"
End Select

Else
    i = i + 1
End If
Loop

tryob = 1
End Function

Private Function trailyes(ByRef m_nodelist As IXMLDOMNodeList, ByRef m_node As IXMLDOMNode) As Boolean
Dim a As uAttribute
Dim i As Integer
Dim j As Integer
Dim OK As Integer

a = yes
i = 0
Do While (a.Attrib(i).Object <> "" And i < a.Att_number)
OK = 0

'If (a.Attrib(i).object <> m_nodelist(j).Attributes(0).nodeValue _
'   Or a.Attrib(i).attribute <> m_nodelist(j).Attributes(0).nodeValue) Then
'ok = 1
'End If

j = 0
Do While (j < m_nodelist.length)
If (mystrcmp(m_nodelist(j), a.Attrib(i))) Then OK = 1
j = j + 1
Loop

If (OK = 0) Then
trailyes = False
Exit Function
End If

i = i + 1
Loop
trailyes = True
End Function

Private Function trailno(ByRef m_nodelist As IXMLDOMNodeList, ByRef m_node As IXMLDOMNode) As Boolean
Dim a As uAttribute
Dim i As Integer
Dim j As Integer
Dim OK As Integer

a = no
i = 0
Do While (a.Attrib(i).Object <> "" And i < a.Att_number)

j = 0
Do While (j < m_nodelist.length)
If (mystrcmp(m_nodelist(j), a.Attrib(i))) Then
trailno = False
Exit Function
End If
j = j + 1
Loop

i = i + 1
Loop

trailno = True
End Function

Private Function ask(ByRef m_node As IXMLDOMNode) As Boolean
Dim p As uAttribute
Dim i As Integer
Dim OK As Integer
p = yes
If (p.Att_number = 0) Then
ask = True
Exit Function
End If

OK = 1
For i = 0 To p.Att_number - 1
If (mystrcmp(m_node, p.Attrib(i))) Then
OK = 0
Exit For
End If
Next

If (OK = 0) Then
ask = False
Exit Function
Else
ask = True
Exit Function
End If
End Function
'反向推理模块
Public Function free_trails()
Dim i As Integer
yes.Att_number = 0
no.Att_number = 0
For i = 0 To 9
yes.Attrib(i).attribute = ""
yes.Attrib(i).Object = ""
yes.Attrib(i).relation = ""
yes.Attrib(i).value = ""
no.Attrib(i).attribute = ""
no.Attrib(i).Object = ""
no.Attrib(i).relation = ""
no.Attrib(i).value = ""
Next
End Function

Private Function add_statement(ByRef m_node As IXMLDOMNode) As String
Dim i As Integer
Dim m_string As String
m_string = ""
If (m_node.nodeName = "STATEMENT") Then
For i = 0 To m_node.attributes.length - 1
If (Not m_node.attributes(i).nodeValue = "") Then m_string = m_string + m_node.attributes(i).nodeValue + " "
Next
End If
add_statement = m_string
End Function

Private Sub mystrcpy(ByRef a As uAttribute, ByRef m_node As IXMLDOMNode)
a.Attrib(a.Att_number).Object = m_node.attributes(0).nodeValue
a.Attrib(a.Att_number).attribute = m_node.attributes(1).nodeValue
a.Attrib(a.Att_number).relation = m_node.attributes(2).nodeValue
a.Attrib(a.Att_number).value = m_node.attributes(3).nodeValue
a.Att_number = a.Att_number + 1
End Sub

Private Function mystrcmp(ByRef m_node As IXMLDOMNode, ByRef a As uStatement) As Boolean
If (m_node.attributes(0).nodeValue = a.Object And m_node.attributes(1).nodeValue = a.attribute And _
    m_node.attributes(2).nodeValue = a.relation And m_node.attributes(3).nodeValue = a.value) Then
mystrcmp = True
Else
mystrcmp = False
End If
End Function

Public Sub Reverse_Method(ByRef KeyWord As String)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim count As Integer
Dim oelem As IXMLDOMNode
Dim tempnode As IXMLDOMNode

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"
        'savequeue(RecordIndex, 0) = tempnode.childNodes(k).Attributes(0).nodeValue
        'savequeue(RecordIndex, 1) = tempnode.childNodes(k).Attributes(1).nodeValue
        MySelect tempnode.childNodes(k)
    
 '-------------------------------------------------------
    
    Case "REASON"
   query tempnode.childNodes(k).attributes(0).nodeValue
   
 '------------------------------------------------------------
    Case "SEND"
    Reverse_Method tempnode.childNodes(k).attributes(0).nodeValue
 '------------------------------------------------------------
    Case "WRITE"
    MyWrite tempnode.childNodes(k)
 '-------------------------------------------------------------
    Case "SELECT_AND_SEND"
    SelectAndSend tempnode.childNodes(k)
    End Select
    Next
    End If
End If
Next
Next
If outputflag = 0 Then
MsgBox "没有推出结论", vbInformation, "推测结论"
frmOutput.LVoutput.ListItems.Add , , "提示信息" + "          " + "没有推出结论", 3, 3
End If
End Sub

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 p 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
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

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
    Reverse_Method (m_node.childNodes(i).attributes(0).nodeValue)
    End If
Next
End Sub