8数码问题

04年写的8数码问题的代码：

 

Dim OpenNode() As Node
Dim CloseNode() As Node
Dim favorNode As Node
Dim tempNode As Node
Dim showNode As Node

Dim openTop As Integer
Dim closeTop As Integer

Dim startStr(2, 2) As Integer
Dim targetStr(2, 2) As Integer

Dim getIt As Boolean

Dim Step As Integer

Public Function getAnswer(tempG() As Integer) As Boolean
'若找到答案返回true 否则返回false
    Dim equalNum As Integer
   
    For i = 0 To 2
        For j = 0 To 2
            If tempG(i, j) = targetStr(i, j) Then
                equalNum = equalNum + 1
            End If
        Next
    Next
   
    If equalNum = 9 Then
        getAnswer = True
    Else
        getAnswer = False
    End If
           
End Function

Public Function inClose(tempC() As Integer)
'返回 tempA 在open表中的位置，若不在返回-1
    Dim equalNum As Integer
    Dim returnNum As Integer
   
    returnNum = -1
   
    For i = 0 To closeTop
        equalNum = 0
        For m = 0 To 2
            For n = 0 To 2
                If tempC(m, n) = CloseNode(i).eightNum(m, n) Then
                    equalNum = equalNum + 1
                End If
            Next
        Next
       
        If equalNum = 9 Then
            returnNum = i
            Exit For
        End If
    Next
   
    inClose = returnNum
End Function

Public Function inOpen(tempC() As Integer)
'返回 tempA 在open表中的位置，若不在返回-1
    Dim equalNum As Integer
    Dim returnNum As Integer
   
  
    returnNum = -1
   
    For i = 0 To openTop
        equalNum = 0
        For m = 0 To 2
            For n = 0 To 2
                If tempC(m, n) = OpenNode(i).eightNum(m, n) Then
                    equalNum = equalNum + 1
                End If
            Next
        Next
       
        If equalNum = 9 Then
            returnNum = i
            Exit For
        End If
    Next
   
    inOpen = returnNum
End Function

Public Function getFee(aArr() As Integer, bArr() As Integer) As Integer
'函数－－－计算费用
    Dim k As Integer
   
    For i = 0 To 2
        For j = 0 To 2
            If aArr(i, j) <> bArr(i, j) Then
                k = k + 1
            End If
        Next
    Next
   
    getFee = k
End Function

Sub iniProblem()
'过程－－－初始化
    ReDim OpenNode(10000)
    ReDim CloseNode(10000)
   
    startStr(0, 0) = TxtStart(0).Text
    startStr(0, 1) = TxtStart(1).Text
    startStr(0, 2) = TxtStart(2).Text
    startStr(1, 0) = TxtStart(3).Text
    startStr(1, 1) = TxtStart(4).Text
    startStr(1, 2) = TxtStart(5).Text
    startStr(2, 0) = TxtStart(6).Text
    startStr(2, 1) = TxtStart(7).Text
    startStr(2, 2) = TxtStart(8).Text
   
    targetStr(0, 0) = TxtTarget(0).Text
    targetStr(0, 1) = TxtTarget(1).Text
    targetStr(0, 2) = TxtTarget(2).Text
    targetStr(1, 0) = TxtTarget(3).Text
    targetStr(1, 1) = TxtTarget(4).Text
    targetStr(1, 2) = TxtTarget(5).Text
    targetStr(2, 0) = TxtTarget(6).Text
    targetStr(2, 1) = TxtTarget(7).Text
    targetStr(2, 2) = TxtTarget(8).Text

'初始化open表,它有序，安g从大到小排
    For i = 0 To 2
        For j = 0 To 2
            OpenNode(0).eightNum(i, j) = startStr(i, j)
            If startStr(i, j) = 0 Then
                OpenNode(0).x = i
                OpenNode(0).y = j
            End If
        Next
    Next

    OpenNode(0).parent = -1
    OpenNode(0).h = 0
    OpenNode(0).g = getFee(OpenNode(0).eightNum, targetStr)
   
    openTop = 1
   
'close表为空
    closeTop = 0

'还没得到答案
    getIt = False

'显示步骤初始化为0
    Step = 0
   

End Sub

Public Function insertP(newFee As Integer)
'返回插入open表的位置

    For i = 0 To openTop - 1
        If OpenNode(i).g < newFee Then
            Exit For
        End If
    Next
   
    insertP = i
End Function

Public Sub inOpenOrClose()
        '生成新临时节点
        tempNode.h = favorNode.h + 1
        tempNode.g = getFee(tempNode.eightNum, targetStr) + tempNode.h
        tempNode.parent = closeTop - 1
  
        inopeni = inOpen(tempNode.eightNum)
       
        If inopeni <> -1 Then  'already exist in open table
            If OpenNode(inopeni).h > tempNode.h Then
            'open 表中的费用较高,修改
                OpenNode(inopeni).h = tempNode.h
                OpenNode(inopeni).g = tempNode.g
                OpenNode(inopeni).parent = tempNode.parent
            End If
        End If
       
        If inopeni = -1 Then
        '不在open表中看是否在close表中
            inclosei = inClose(tempNode.eightNum)
            If inclosei <> -1 Then
                If CloseNode(inclosei).h > tempNode.h Then
                    CloseNode(inclosei).h = tempNode.h
                    CloseNode(inclosei).g = tempNode.g
                    CloseNode(inclosei).parent = tempNode.parent
                End If
            Else
            'also not in close table,so add it to open table
           
                insertI = insertP(tempNode.g)   '得到要插入open表的位置
               
                For i = openTop To insertI + 1 Step -1
                    OpenNode(i) = OpenNode(i - 1)
                Next
               
                OpenNode(insertI) = tempNode
                openTop = openTop + 1
                If openTop > 10000 Then
                    '重新分配空间
                    MsgBox "重新分配空间，open表已满"
                    Exit Sub '暂时退出
                    ReDim Preserve OpenNode(openTop + 500)
                End If
               
               
            End If
        End If

End Sub

Sub clearTxtColor()
    For i = 0 To 8
        TxtTarget(i).BackColor = &H80000005
        TxtStart(i).BackColor = &H80000005
    Next
End Sub
Public Sub showStep()
    If Step = -1 Or getIt = False Then
   
        tShowStep.Enabled = False
       
    Else
        m = 0
        For i = 0 To 2
            For j = 0 To 2
                'MsgBox CloseNode(step).eightNum(i, j)
                TxtTarget(m).Text = CloseNode(Step).eightNum(i, j)
                If TxtTarget(m).Text = 0 Then
                    clearTxtColor
                    TxtTarget(m).BackColor = &H80000000
                End If
                m = m + 1
            Next
        Next
        showNode = CloseNode(Step)
        Step = showNode.parent
    End If

End Sub

Private Sub CmdRestart_Click()
    For i = 0 To 8
        TxtStart(i).Text = ""
        TxtTarget(i).Text = ""
        TxtTarget(i).BackColor = &H80000005
    Next
End Sub

 

Private Sub tshowStep_Timer()
   
    If getIt = True Then
        showStep
  '      MsgBox "step value is:" & Step
    End If

End Sub

Public Function checkPass() As Boolean
    '输入的数在[0,8]上返回true，否则返回false
   
    Dim returnV As Boolean
    Dim MyStr As String
   
    MyStr = "0,1,2,3,4,5,6,7,8"
    returnV = True
   
    clearTxtColor
   
    For i = 0 To 8
        If InStr(MyStr, TxtStart(i).Text) = 0 Then
            returnV = False
            TxtStart(i).BackColor = &H8080FF
        End If
       
        If InStr(MyStr, TxtTarget(i).Text) = 0 Then
            returnV = False
            TxtTarget(i).BackColor = &H8080FF
        End If
    Next
   
    checkPass = returnV
End Function

Public Function checkRepeat() As Boolean
    '输入的数没有重复返回false，否则返回true
   
    Dim returnV As Boolean
    Dim MyStr As String
   
    MyStr = "0,1,2,3,4,5,6,7,8"
    MsgBox InStr(MyStr, "0") & "<>" & InStrB(MyStr, "0")
    returnV = False
   
    clearTxtColor
   
    For i = 0 To 8
        If InStr(MyStr, TxtStart(i).Text) <> InStrB(MyStr, TxtStart(i).Text) Then
            '初始状态有重复
            returnV = True
            For j = 0 To 8
                If TxtStart(j).Text = TxtStart(i) Then
                    '改变重复数字背景
                    TxtStart(j).BackColor = &H80000003
                End If
            Next
        End If
       
        If InStr(MyStr, TxtTarget(i).Text) <> InStrB(MyStr, TxtTarget(i).Text) Then
            returnV = True
            '目标状态有重复
            For j = 0 To 8
                If TxtTarget(j) = TxtTarget(j) Then
                    '改变重复数字背景
                    TxtTarget(j).BackColor = &H80000003
                End If
            Next
        End If
    Next
    checkRepeat = returnV
End Function
Private Sub StartCompute_Click()
 
 
 If checkPass = False Then
    MsgBox "红色背景筐内输入有错误!请检查", vbInformation, "-_-!"
    Exit Sub
 End If

' If checkRepeat = True Then
'    MsgBox "蓝色背景筐内数字有重复！", vbInformation, "@_@"
'    Exit Sub
' End If

Label1.Caption = "处理中,请稍候...."

a = MsgBox("系统处理可能要花几分钟，你要处理么？", vbYesNo + vbInformation, "^_^")

If a = vbNo Then
    Exit Sub
End If

'MsgBox Label1.Caption
StartCompute.Enabled = False
CmdRestart.Enabled = False
 

 
 
 iniProblem
 
 While openTop > 0 And Not getIt
    favorNode = OpenNode(openTop - 1)
    openTop = openTop - 1             'delete form open table
    'add it to closeTable
    CloseNode(closeTop) = favorNode
    closeTop = closeTop + 1
    If closeTop > 10000 Then
    '重新分配空间
        a = MsgBox("close表已满,退出", vbInformation + vbYesNo)
        Exit Sub '暂时推出
        ReDim Preserve CloseNode(closeTop + 500)
    End If
    getIt = getAnswer(favorNode.eightNum)
   
       
   
    '－－－－－－展开favorNode－－－－－－－－
   
    '''''''''''''''''''''''''''
    '        零上移           '
    '''''''''''''''''''''''''''
    tempNode = favorNode
    If favorNode.x > 0 Then ' zero move  up
       
        tempNode.eightNum(tempNode.x, tempNode.y) = tempNode.eightNum(tempNode.x - 1, tempNode.y)
        tempNode.eightNum(tempNode.x - 1, tempNode.y) = 0
       
        tempNode.x = tempNode.x - 1
        tempNode.y = tempNode.y
       
        inOpenOrClose
       
    End If
   
    '''''''''''''''''''''''''''
    '       零 下 移          '
    '''''''''''''''''''''''''''
    tempNode = favorNode
    If favorNode.x < 2 Then   'zero move down
       
        tempNode.eightNum(tempNode.x, tempNode.y) = tempNode.eightNum(tempNode.x + 1, tempNode.y)
        tempNode.eightNum(tempNode.x + 1, tempNode.y) = 0
       
        tempNode.x = tempNode.x + 1
        tempNode.y = tempNode.y
       
        inOpenOrClose
       
    End If

    '''''''''''''''''''''''''''
    '       零 左 移          '
    '''''''''''''''''''''''''''
    tempNode = favorNode
    If favorNode.y > 0 Then   'zero move down
       
        tempNode.eightNum(tempNode.x, tempNode.y) = tempNode.eightNum(tempNode.x, tempNode.y - 1)
        tempNode.eightNum(tempNode.x, tempNode.y - 1) = 0
       
        tempNode.x = tempNode.x
        tempNode.y = tempNode.y - 1
       
        inOpenOrClose
       
    End If

    '''''''''''''''''''''''''''
    '       零 右 移          '
    '''''''''''''''''''''''''''
    tempNode = favorNode
    If favorNode.y < 2 Then   'zero move down
       
        tempNode.eightNum(tempNode.x, tempNode.y) = tempNode.eightNum(tempNode.x, tempNode.y + 1)
        tempNode.eightNum(tempNode.x, tempNode.y + 1) = 0

        tempNode.x = tempNode.x
        tempNode.y = tempNode.y + 1
       
        inOpenOrClose
       
    End If
 
 Wend
 
 If getIt = True Then
    MsgBox "得到答案！"
   '' MsgBox "step value is:" & favorNode.parent
    showNode = favorNode
   
    Step = favorNode.parent
    'MsgBox "next step is:" & step
    tShowStep.Enabled = True
 Else
    MsgBox "no success"
 End If
 StartCompute.Enabled = True
 CmdRestart.Enabled = True
 Label1.Caption = ""

End Sub