prodsys.cls

人工智能课程 产生式部分的一个实验设计：用产生式解决“过河问题”

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ProdSys"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                                           '
' ＂过河问题产生式系统＂类定义                              '
' 　　　　　　　　　　　　　　　（人工智能（AI）作业）      '
'　制　　作：姜睐                                           '
'　完成时间：2007-5-13                                      '
'                                                           '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


'保持属性值的局部变量
Private mvarBlackBoard As String    '局部复制　黑板,总数据库
Private mvarStateB As String        '局部复制：初始事实状态，用于启动产生式系统
Private mvarStateE As String        '局部复制：结束状态，用于结束产生式系统
Private mvarStepCount As Integer    '局部复制：产生式系统的工作步数 ，外部只读
Private mvarMonCount As Integer     '局部复制：产生式规则库使用：传教士人数，初始
Private mvarVayCount As Variant     '局部复制：产生式规则库使用：野蛮人人数，初始
Private mvarShipSize As Variant     '局部复制：产生式规则库使用：每船可载人数，初始
Private mvarShipState As Variant    '局部复制：产生式规则库使用：船的状态，初始，只能为１左岸

'其他　内部属性
Private Rule_BasesB() As String     '规则库（左）
Private Rule_BasesE() As String     '规则库（右）
Private RuleCount As Integer        '规则库长度（数字由１开始使用）

'控制策略搜索算法使用：递归的深的优先搜索
Private NodeVisited() As Boolean    '节点已访问标记
Private StackSeaWay() As Integer     '经过路径纪录，使用堆栈纪录
Private StackTop As Integer         '路径纪录堆栈栈定指针
'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent Go1Step[(arg1, arg2, ... , argn)]
Public Event Go1Step()


Public Property Get SS() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ShipState
    ShipState = StackSeaWay
End Property


Public Property Let ShipState(ByVal vData As Variant)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.ShipState = 5
    mvarShipState = vData
End Property

Public Property Set ShipState(ByVal vData As Variant)
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.ShipState = Form1
    Set mvarShipState = vData
End Property


Public Property Get ShipState() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ShipState
    If IsObject(mvarShipState) Then
        Set ShipState = mvarShipState
    Else
        ShipState = mvarShipState
    End If
End Property



Public Property Let ShipSize(ByVal vData As Variant)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.ShipSize = 5
    mvarShipSize = vData
End Property


Public Property Set ShipSize(ByVal vData As Variant)
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.ShipSize = Form1
    Set mvarShipSize = vData
End Property


Public Property Get ShipSize() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ShipSize
    If IsObject(mvarShipSize) Then
        Set ShipSize = mvarShipSize
    Else
        ShipSize = mvarShipSize
    End If
End Property



Public Property Let VayCount(ByVal vData As Variant)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.VayCount = 5
    mvarVayCount = vData
End Property


Public Property Set VayCount(ByVal vData As Variant)
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.VayCount = Form1
    Set mvarVayCount = vData
End Property


Public Property Get VayCount() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.VayCount
    If IsObject(mvarVayCount) Then
        Set VayCount = mvarVayCount
    Else
        VayCount = mvarVayCount
    End If
End Property



Public Property Let MonCount(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.MonCount = 5
    mvarMonCount = vData
End Property


Public Property Get MonCount() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.MonCount
    MonCount = mvarMonCount
End Property





'局部复制：产生式系统的工作步数
Public Property Get StepCount() As Integer
    StepCount = mvarStepCount
End Property

'局部复制：初始事实状态，用于启动产生式系统
Public Property Let StateB(ByVal vData As String)
    mvarStateB = vData
End Property
Public Property Get StateB() As String
    StateB = mvarStateB
End Property

'局部复制：结束状态，用于结束产生式系统
Public Property Let StateE(ByVal vData As String)
    mvarStateE = vData
End Property
Public Property Get StateE() As String
    StateE = mvarStateE
End Property

'局部复制　黑板
Public Property Let blackboard(ByVal vData As String)
Attribute blackboard.VB_Description = "总数据库（黑板）"
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.blackboard = 5
    mvarBlackBoard = vData
End Property
Public Property Get blackboard() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.blackboard
    blackboard = mvarBlackBoard
End Property


Public Sub go()     '应用控制策略进行求解
    'Private NodeVisited() As Boolean    '节点已访问标记
    'Private StackSeaWay() As integer     '经过路径纪录，使用堆栈纪录
    'Private StackTop As Integer         '路径纪录堆栈栈定指针
    ReDim NodeVisited(RuleCount) As Boolean
    ReDim StackSeaWay(RuleCount) As Integer
    Dim i, j As Integer
    Dim flag As Boolean
            
    For i = 1 To RuleCount
        NodeVisited(i) = False
    Next
    
    StackTop = 0    '空栈，栈底由１开始纪录
    '应用深度优先搜索算法
    i = 1
    mvarStepCount = 0
    Do While True
        NodeVisited(i) = True           '加已访问标记
        mvarBlackBoard = Rule_BasesB(i) '写黑板
        mvarStepCount = mvarStepCount + 1       '步数纪录器加１
    '入站
        StackTop = StackTop + 1
        StackSeaWay(StackTop) = i
        If Rule_BasesE(i) = "000" Then Exit Do '产生式自动生成，已经知道一定会有结果
    '找相邻节点
        flag = False
        j = 1
        Do While j <= RuleCount
            If Rule_BasesE(i) = Rule_BasesB(j) And Not NodeVisited(j) Then
                flag = True
                Exit Do
            End If
            j = j + 1
        Loop
    '根据查找情况判断
        If flag Then
            i = j   '找到了一个可用规则
        Else  '退回出栈一个
            StackTop = StackTop - 1
            If StackTop = 0 Then
                i = i + 1 '空栈：用的第一次推理就失败
            Else
                i = StackSeaWay(StackTop)
            End If
        End If
        
        RaiseEvent Go1Step
        
        
    Loop
    
    Dim temp As String
    For i = 1 To StackTop
        temp = temp & Rule_BasesB(StackSeaWay(i)) & "-" & Rule_BasesE(StackSeaWay(i)) & Chr(13)
    Next
    MsgBox temp, vbOKOnly, "产生式规则数量：" & Str(RuleCount)

End Sub

Private Sub Class_Initialize()
    
       
    '初始化标志位
    
    '步数纪录器初始化
    mvarStepCount = 0
    
    
    
End Sub

'方法：自动生成规则库 参数说明：传教士人数／野人人数／渡船容量／船的位置：１｜０左右岸
Public Sub CreatRuleBase(Mon As Integer, Vay As Integer, ShipC As Integer, ShipState As Integer)

'某些属性获得值：
mvarMonCount = Mon          '产生式中传教士人数
mvarVayCount = Vay          '产生式中野蛮人数
mvarShipSize = ShipC        '产生式中船的容量
mvarShipState = ShipState   '起始船状态
mvarStateB = Mon & Vay & ShipState  '产生式启动规则左端，如"331"
mvarStateE = "000"                  '产生式结束态

'初始事实状态   mvarStateB as string    '直接使用属性纪录，不再另外开辟变量空间
'结束状态       mvarStateE as string
'规则库（左）   Rule_BasesB() As String
'规则库（右）   Rule_BasesE() As String
'规则库长度（数字由１开始使用）RuleCount As Integer
Dim Queue(100) As String   '队列：存放按层次遍历过程中产生的新状态
Dim QueueHead, QueueTail As Integer  '队头，队尾指针
Dim TempM, TempV, TempM1, TempV1, TempM2, TempV2, TempS As Integer '当前规则\测试左端情况＼测试右岸情况＼船只位置
Dim strRuleB, TempRuleB As String
Dim i, j, k As Integer
Dim flag As Boolean     '规则有效标记
    '参数合法性验证：
    
    'c初始化队列，循环队列
    QueueHead = 0   '开始队首指针位于队内第一个元素之前．
    QueueTail = 1
    Queue(QueueTail) = Mon & Vay & ShipState    '生成启动规则的左侧
    RuleCount = 0
    
    '开始生成　　基本思想：树的按层次遍历算法：
    Do While QueueHead < QueueTail  '队不空
        QueueHead = QueueHead + 1
        strRuleB = Queue(QueueHead)
        TempM = Val(Left(strRuleB, 1))
        TempV = Val(Mid(strRuleB, 2, 1))
        If Val(Right(strRuleB, 1)) Then TempS = -1 Else TempS = 1   '船在左岸减人，右岸加人
        For i = 0 To ShipC          '传教士i人过河
            For j = 0 To ShipC - i  '野人1人过河
            
                TempM1 = TempM + i * TempS         '左岸传教士变化后
                TempM2 = Mon - TempM - i * TempS    '右岸传教士变化后
                TempV1 = TempV + j * TempS          '左岸野蛮人变化后
                TempV2 = Vay - TempV - j * TempS    '右岸传教士变化后
                TempRuleB = TempM1 & TempV1 & IIf(TempS = -1, 0, 1)  'c本次产生的规则
                
                flag = True '产生有效标记,以下为规则有效判断
                If i + j <= 0 Then  '乘船人数不为零
                    flag = False
                ElseIf TempM1 < 0 Or TempM2 < 0 Or TempV1 < 0 Or TempV2 < 0 Then
                    flag = False    '任意时刻两岸人数不能为负数
                ElseIf (TempV1 > TempM1 And TempM1 <> 0) Then   '两岸人数比例合法
                    flag = False    '左岸：野蛮人人数小于或等于传教士，或没有传教士全是野蛮人；
                ElseIf (TempV2 > TempM2 And TempM2 <> 0) Then
                    flag = False    '右岸：同理；
                ElseIf strRuleB = "000" Then
                    flag = False   '以000为起点的规则
                Else
                    If RuleCount > 0 Then
                        k = 1
                        Do While k <= RuleCount
                            If Rule_BasesB(k) = TempRuleB Then
                                flag = False '已经完成以当前右端为起点推测的规则
                                Exit Do
                            End If
                            If Rule_BasesB(k) = strRuleB And Rule_BasesE(k) = TempRuleB Then
                                flag = False '判断是否是已经存在的规则
                                Exit Do
                            End If
                            k = k + 1
                        Loop
                    End If
                End If
                    
                If flag Then    '对有效规则的处理：
                    '加入队尾
                    QueueTail = QueueTail + 1
                    Queue(QueueTail) = TempRuleB
                    '加入规则库中
                    RuleCount = RuleCount + 1
                    ReDim Preserve Rule_BasesB(RuleCount)
                    ReDim Preserve Rule_BasesE(RuleCount)
                    Rule_BasesB(RuleCount) = strRuleB
                    Rule_BasesE(RuleCount) = TempRuleB
                    'MsgBox strRuleB & " - " & TempRuleB
                End If
                
            Next 'j
        Next 'i
    Loop
    
    
    
    Dim temp As String
    temp = ""
    flag = False '标志：判断根据用户给定的传教士数量、野蛮人数量、船容量参数最后能否实现过河，即规则库中有无右侧为“000”的
    For k = 1 To RuleCount
        temp = temp & Rule_BasesB(k) & "-" & Rule_BasesE(k) & Chr(13)
        If Rule_BasesB(k) = "000" Then flag = True   '已经找到右侧为"000" 的规则
    Next
    MsgBox temp, vbOKOnly, "产生式规则数量：" & Str(RuleCount)
    If flag Then MsgBox "指定参数的产生式系统无解！"
    
End Sub