formknowledge.frm

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

  Exit Do
 End If
 Loop
End If
End Sub

Private Sub CommandExit_Click()
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer
If (sPrj = "") Then
    Check1.Enabled = False
Else
    Check1.Enabled = True
End If
Me.TextShowXML.Visible = False
Me.SSTab1.Tab = 0
newobject = 0
newrule = 0
countx = 0
county = 0
countrule = 0
countif = 0
countthen = 0
ObjectIni = True
RuleSel = False
ObjSel = False
AttSel = False
IfSel = False
ThenSel = False
For i = 0 To 20
 HasRule(i) = False
Next
ObjectList.Clear
AttributeList.Clear
ObjectCombo.Clear
Check1.value = 0
Call LoadData
End Sub

Private Sub Command1_Click()
Dim i As Integer
Dim j As Integer
If (newobject = 1) Then
countx = ObjectList.ListCount
ObjectArray(countx) = ObjectCombo.Text
ObjectCombo.AddItem ObjectCombo.Text
county = 0
newobject = 0
countrule = 0
countif = 0
countthen = 0
RuleList.Clear
If ObjectIni = True Then
 ObjectIni = False
Else
 ObjectIndex = countx - 1
End If
End If

If AttributeText.Text <> "" Then
    county = 0
    Do While AttributeArray(countx, county) <> ""
    county = county + 1
    Loop
 AttributeArray(countx, county) = AttributeText.Text
 county = county + 1
Else
 MsgBox "必须输入属性", vbOKOnly, "注意！"
End If

ObjectList.Clear
i = 0
Do While ObjectArray(i) <> ""
    ObjectList.AddItem ObjectArray(i)
    i = i + 1
Loop

AttributeList.Clear

j = 0
Do While AttributeArray(ObjectIndex, j) <> ""
 AttributeList.AddItem AttributeArray(ObjectIndex, j)
 j = j + 1
Loop

IfList.Clear
ThenList.Clear

i = 0
Do
If (Not RuleArray(ObjectIndex, RuleIndex, 0, i, 0) = "") Then
IfList.AddItem RuleArray(ObjectIndex, RuleIndex, 0, i, 0) & "." & RuleArray(ObjectIndex, RuleIndex, 0, i, 1) & RuleArray(ObjectIndex, RuleIndex, 0, i, 2) & RuleArray(ObjectIndex, RuleIndex, 0, i, 3)
i = i + 1
Else
Exit Do
End If
Loop

i = 0
Do
If (Not RuleArray(ObjectIndex, RuleIndex, 1, i, 0) = "") Then
ThenList.AddItem RuleArray(ObjectIndex, RuleIndex, 1, i, 0) & "." & RuleArray(ObjectIndex, RuleIndex, 1, i, 1) & RuleArray(ObjectIndex, RuleIndex, 1, i, 2) & RuleArray(ObjectIndex, RuleIndex, 1, i, 3)
i = i + 1
Else
Exit Do
End If
Loop

countx = countx + 1
End Sub

Private Sub IfList_Click()
IfSel = True
IfIndex = IfList.ListIndex

End Sub

Private Sub ObjectCombo_Change()
newobject = 1
RuleSel = False
End Sub

Private Sub ObjectCombo_Click()
ObjectIndex = ObjectCombo.ListIndex
AttributeList.Clear
RuleList.Clear
IfList.Clear
ThenList.Clear
IfSel = False
ThenSel = False
Dim j As Integer
county = 0
countrule = 0
RuleSel = False

Do
If (Not AttributeArray(ObjectCombo.ListIndex, county) = "") Then
 AttributeList.AddItem AttributeArray(ObjectCombo.ListIndex, county)
 county = county + 1
Else
 Exit Do
End If
Loop

Do
If (Not RuleArray(ObjectCombo.ListIndex, countrule, 0, 0, 0) = "") Then
RuleList.AddItem RuleNameArray(ObjectCombo.ListIndex, countrule)
countrule = countrule + 1
Else
Exit Do
End If
Loop

RuleIndex = 0

'将选定对象的第1条规则添加到列表框中
countif = 0
Do
If (Not RuleArray(ObjectCombo.ListIndex, 0, 0, countif, 0) = "") Then
IfList.AddItem RuleArray(ObjectCombo.ListIndex, 0, 0, countif, 0) & "." & RuleArray(ObjectCombo.ListIndex, 0, 0, countif, 1) & RuleArray(ObjectCombo.ListIndex, 0, 0, countif, 2) & RuleArray(ObjectCombo.ListIndex, 0, 0, countif, 3)
countif = countif + 1
Else
Exit Do
End If
Loop

countthen = 0
Do
If (Not RuleArray(ObjectCombo.ListIndex, 0, 1, countthen, 0) = "") Then
ThenList.AddItem RuleArray(ObjectCombo.ListIndex, 0, 1, countthen, 0) & "." & RuleArray(ObjectCombo.ListIndex, 0, 1, countthen, 1) & RuleArray(ObjectCombo.ListIndex, 0, 1, countthen, 2) & RuleArray(ObjectCombo.ListIndex, 0, 1, countthen, 3)
countthen = countthen + 1
Else
Exit Do
End If
Loop

End Sub

Private Sub RuleCombo_Change()
newrule = 1
End Sub

Private Sub ObjectList_Click()
ObjectRIndex = ObjectList.ListIndex
ObjSel = True
Dim i As Integer
i = 0
RuleObjText.Text = ObjectArray(ObjectRIndex)
RuleAttText.Text = AttributeArray(ObjectRIndex, 0)
AttributeList.Clear
Do
If (Not AttributeArray(ObjectList.ListIndex, i) = "") Then
 AttributeList.AddItem AttributeArray(ObjectList.ListIndex, i)
 i = i + 1
Else
 Exit Do
End If
Loop
End Sub

Private Sub RRelationText_Change()
RuleText.Text = RuleObjText.Text & "." & RuleAttText.Text & RRelationText.Text & RValueText.Text
End Sub

Private Sub RuleAttText_Change()
RuleText.Text = RuleObjText.Text & "." & RuleAttText.Text & RRelationText.Text & RValueText.Text
End Sub

Private Sub RuleList_Click()
RuleSel = True
IfList.Clear
ThenList.Clear
RuleAttText.Text = AttributeArray(ObjectRIndex, RuleList.ListIndex)
Dim i As Integer
i = 0
Do
If (Not RuleArray(ObjectIndex, RuleList.ListIndex, 0, i, 0) = "") Then
IfList.AddItem RuleArray(ObjectIndex, RuleList.ListIndex, 0, i, 0) & "." & RuleArray(ObjectIndex, RuleList.ListIndex, 0, i, 1) & RuleArray(ObjectIndex, RuleList.ListIndex, 0, i, 2) & RuleArray(ObjectIndex, RuleList.ListIndex, 0, i, 3)
i = i + 1
Else
Exit Do
End If
Loop

i = 0
Do
If (Not RuleArray(ObjectIndex, RuleList.ListIndex, 1, i, 0) = "") Then
ThenList.AddItem RuleArray(ObjectIndex, RuleList.ListIndex, 1, i, 0) & "." & RuleArray(ObjectIndex, RuleList.ListIndex, 1, i, 1) & RuleArray(ObjectIndex, RuleList.ListIndex, 1, i, 2) & RuleArray(ObjectIndex, RuleList.ListIndex, 1, i, 3)
i = i + 1
Else
Exit Do
End If
Loop

RuleIndex = RuleList.ListIndex

IfSel = False
ThenSel = False
End Sub



Private Sub RuleObjText_Change()
RuleText.Text = RuleObjText.Text & "." & RuleAttText.Text & RRelationText.Text & RValueText.Text
End Sub

Private Sub RValueText_Change()
RuleText.Text = RuleObjText.Text & "." & RuleAttText.Text & RRelationText.Text & RValueText.Text
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
    If (PreviousTab = 0) Then
        TextShowXML = buildXML
        TextShowXML.Visible = True
    Else
        TextShowXML.Visible = False
    End If
End Sub

Private Sub ThenList_Click()
ThenSel = True
ThenIndex = ThenList.ListIndex
End Sub

Public Sub BuildCommand_Click()
Unload FormCG
fMainForm.LoadNewDoc
fMainForm.ActiveForm.rtfText.Text = buildXML
If Check1.value = 1 Then
    AddtoProject
End If
Unload Me
fMainForm.mnuFileSave.Enabled = True
End Sub

Private Function buildXML() As String
Dim i As Integer
Dim j As Integer
Dim K As Integer
Dim m As Integer
Dim sXML, childstring As String

sXML = sXML & "<?xml version='1.0' encoding='GB2312'?>" & vbCrLf
sXML = sXML & "<!DOCTYPE PROJECT SYSTEM 'template.dtd'>" & vbCrLf
sXML = sXML & "<PROJECT>" & vbCrLf

For i = 0 To ObjectList.ListCount - 1
childstring = ""
For K = 0 To NodeList(i + 1).ChildCount - 1
    childstring = childstring + "B" + CStr(NodeList(i + 1).Children(K) - 1)
    If (K < NodeList(i + 1).ChildCount - 1) Then
    childstring = childstring + " "
    End If
Next
If (NodeList(i + 1).ChildCount > 0) Then childstring = " parent_of='" + childstring + "'"
sXML = sXML + " <OBJECT object_id='" + "B" + CStr(i) + "'" + childstring + " name='" + ObjectArray(i) + "'>" + vbCrLf

'----------------------------------------------------添属性
j = 0
Do
If Not AttributeArray(i, j) = "" Then
sXML = sXML & "  <ATTRIBUTE name='" & AttributeArray(i, j) & "'/>" & vbCrLf
Else
Exit Do
End If
j = j + 1
Loop
'----------------------------------------------------

K = 0
m = 0
Do While (RuleArray(i, K, 0, m, 0) <> "")
sXML = sXML + "  <RULE>" & vbCrLf
'----------------------------------------------------添规则前提

sXML = sXML + "   <IF>" & vbCrLf
Do While (RuleArray(i, K, 0, m, 0) <> "")
If (RuleArray(i, K, 0, m, 0) <> "") Then sXML = sXML + "    <STATEMENT object='" + RuleArray(i, K, 0, m, 0) + "'"
If (RuleArray(i, K, 0, m, 1) <> "") Then sXML = sXML + " attribute='" + RuleArray(i, K, 0, m, 1) + "'"
If (RuleArray(i, K, 0, m, 2) <> "") Then sXML = sXML + " relation='" + RuleArray(i, K, 0, m, 2) + "'"
If (RuleArray(i, K, 0, m, 3) <> "") Then sXML = sXML + " value='" + RuleArray(i, K, 0, m, 3) + "'"
sXML = sXML + "/>" + vbCrLf
m = m + 1
Loop
sXML = sXML + "   </IF>" & vbCrLf

'----------------------------------------------------添规则结论
sXML = sXML + "   <THEN>" & vbCrLf
j = 0
Do While (RuleArray(i, K, 1, j, 0) <> "")
If (RuleArray(i, K, 1, j, 0) <> "") Then sXML = sXML + "    <STATEMENT object='" + RuleArray(i, K, 1, j, 0) + "'"
If (RuleArray(i, K, 1, j, 1) <> "") Then sXML = sXML + " attribute='" + RuleArray(i, K, 1, j, 1) + "'"
If (RuleArray(i, K, 1, j, 2) <> "") Then sXML = sXML + " relation='" + RuleArray(i, K, 1, j, 2) + "'"
If (RuleArray(i, K, 1, j, 3) <> "") Then sXML = sXML + " value='" + RuleArray(i, K, 1, j, 3) + "'"
sXML = sXML + "/>" + vbCrLf
j = j + 1
Loop
sXML = sXML + "   </THEN>" & vbCrLf
'----------------------------------------------------
sXML = sXML + "  </RULE>" & vbCrLf
K = K + 1
Loop

sXML = sXML & " </OBJECT>" & vbCrLf
Next

sXML = sXML & "</PROJECT>"

buildXML = sXML
End Function

Public Sub LoadData()
Dim i, j As Integer
i = 0
Do While (ObjectArray(i) <> "")
    ObjectCombo.AddItem ObjectArray(i)
    ObjectList.AddItem ObjectArray(i)
    j = 0
    Do While (AttributeArray(i, j) <> "")
        AttributeList.AddItem AttributeArray(i, j)
        j = j + 1
    Loop
i = i + 1
Loop
End Sub

Private Sub AddtoProject()
Dim str As String
With fMainForm
    FileNum = FileNum + 1
    str = .ActiveForm.Caption
    .ActiveForm.Caption = Prj_Location + str
    .ActiveForm.SetModified (False)
    .SaveXMLFile Prj_Location + str                     '保存添加的知识文件
    End With
    sPrj = Prj_Location + Prj_Name
    Open sPrj For Output As #1                           '重写工程文件
    For i = 2 To frmtree.prjTreeView.Nodes.count
        Write #1, frmtree.prjTreeView.Nodes(i).Text
    Next
    Write #1, str
    Close #1   ' Close file
    Set root = frmtree.prjTreeView.Nodes(1)              '重画工程树型目录
    Set tnode = frmtree.prjTreeView.Nodes.Add(root, tvwChild, , str, 3, 3)
    tnode.Tag = Prj_Location + str
    frmtree.prjTreeView.Refresh
End Sub