airline.frm

航空最短路径探测

VERSION 5.00
Begin VB.Form frmPlane 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Airline "
   ClientHeight    =   6705
   ClientLeft      =   4860
   ClientTop       =   3675
   ClientWidth     =   6090
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   447
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   406
   Begin VB.CommandButton CmdReset 
      Caption         =   "重置"
      Height          =   495
      Left            =   2400
      TabIndex        =   2
      Top             =   0
      Width           =   1335
   End
   Begin VB.CommandButton CmdEnd 
      Caption         =   "结束"
      Height          =   495
      Left            =   4680
      TabIndex        =   1
      Top             =   0
      Width           =   1335
   End
   Begin VB.CommandButton CmdStart 
      Caption         =   "开始"
      Height          =   495
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   1335
   End
End
Attribute VB_Name = "frmPlane"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const DEAD = 1
Const ALIVE = 0
Const CELLWIDTH = 12
Const CELLHEIGHT = 12
Const MAXCOL = 30
Const MAXROW = 30
Const XOFFSET = 20
Const YOFFSET = 56
Const MAXX = MAXCOL * CELLWIDTH + XOFFSET
Const MAXY = MAXROW * CELLHEIGHT + YOFFSET
Const CIRCLERADIUS = 5
'Const MAXGENERATIONS = 10000
Const ORINGINEX = 20
Const ORINGINEY = 56
'Const XMOVEMENT = 100


Dim Drawing As Boolean
Dim World(MAXCOL - 1, MAXROW - 1) As Integer
Dim Neighbor() As PointItem
Dim Arccost()  As Integer
Dim StopLife As Boolean
Dim OpenList As New PointList
Dim CloseList As New PointList
Dim Points(MAXROW - 1, MAXCOL - 1)  As PointItem   '当前区域内的所有的状态点

Dim start_point As PointItem
Dim destination_point As PointItem


Public Enum Distance
 XDISTANCE = 5
 XYDISTANCE = 8
 XDISTANCE_WITHBLOCK = 50
 XYDISTANCE_WITHBLOCK = 80
End Enum

'Public Enum PointStatus
'STATUSNEW = 0
' STATUSOPEN = 1
' STATUSCLOASE = 2
'End Enum

Private Sub CmdEnd_Click()
End
End Sub

Private Sub CmdReset_Click()
frmPlane.Cls
Call InitGame
Call DrawScreen
CmdStart.Enabled = True
End Sub

Private Sub CmdStart_Click()
 Call RunForLine
 CmdStart.Enabled = False
End Sub

Private Sub Form_Load()
Call InitGame
Call DrawScreen
End Sub

Sub InitGame()
Dim row As Integer
Dim column As Integer
For row = 0 To MAXROW - 1
 For column = 0 To MAXCOL - 1
  World(row, column) = ALIVE
Set Points(row, column) = New PointItem
  With Points(row, column)
    .X = row
    .Y = column
    .Status = PointItemStatus.STATUSNEW
    Set .BackPoint = Nothing
  End With
Next column
Next row
 ' Generations = 10000
  'StopLife = False
  Set OpenList = Nothing
  Set CloseList = Nothing
  Set start_point = Points(0, 0)
  Set destination_point = Points(29, 29)
End Sub

Sub DrawScreen()
 Dim x0 As Integer
 Dim y0 As Integer
 frmPlane.ForeColor = vbBlue
 For y0 = YOFFSET To MAXY Step CELLHEIGHT
    frmPlane.Line (XOFFSET, y0)-(MAXX + 1, y0)
 Next y0
 For x0 = XOFFSET To MAXX Step CELLWIDTH
  frmPlane.Line (x0, YOFFSET)-(x0, MAXY + 1)
 Next x0
 'LblGenerations.Caption = "Generation#1000"
 frmPlane.CurrentX = 15
 frmPlane.CurrentY = 40
 Print "A"
 
    frmPlane.ForeColor = vbBlack
    frmPlane.FillStyle = vbSolid
    frmPlane.FillColor = vbRed
    frmPlane.Circle (ORINGINEX + 5, ORINGINEY + 5), 6
    frmPlane.Circle (MAXCOL * CELLWIDTH + XOFFSET - 6, MAXROW * CELLHEIGHT + YOFFSET - 6), 6
   
 frmPlane.CurrentX = MAXCOL * CELLWIDTH + XOFFSET + 5
 frmPlane.CurrentY = MAXROW * CELLHEIGHT + YOFFSET + 5
 Print "B"
End Sub
''设置障碍物
Sub AddCell(X As Single, Y As Single)
 Dim column As Integer
 Dim row As Integer
 If Drawing Then
 If X > XOFFSET And X < MAXX And Y > YOFFSET And Y < MAXY Then
  column = (X - XOFFSET) \ CELLWIDTH
  row = (Y - YOFFSET) \ CELLHEIGHT
  If (column = 0 And row = 0) Or (column = 29 And row = 29) Then Exit Sub
 If Not World(column, row) Then
    frmPlane.ForeColor = vbBlack
    frmPlane.FillStyle = vbSolid
    frmPlane.FillColor = vbGreen
    frmPlane.Circle (column * CELLWIDTH + XOFFSET + CELLWIDTH / 2, row * CELLHEIGHT + YOFFSET + CELLHEIGHT / 2), CIRCLERADIUS
    World(column, row) = DEAD
 End If
 End If
End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Drawing = True
AddCell X, Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Drawing Then AddCell X, Y
End Sub
Sub SetCellColor(Generation As Integer)
 Dim ColorNum
  ColorNum = Generation Mod 6
  Select Case ColorNum
  Case 0
   Form1.FillColor = vbBlue
 Case 1
   Form1.FillColor = vbRed
 Case 2
   Form1.FillColor = vbGreen
 Case 3
   Form1.FillColor = vbYellow
 Case 4
   Form1.FillColor = vbMagenta
  Case 5
   Form1.FillColor = vbCyan
End Select
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Drawing = False
End Sub

Private Sub RunForLine()

Call OpenList.InsertPoint(destination_point, 0)
'While (start_point.Status <> STATUSCLOSE And OpenList.HasNodes)
' Call ProcessState
'Wend

' Dim Current_point As PointItem
' Dim X As PointItem
' Dim MinK As Integer
'If start_point.Status = STATUSCLOSE Then
' Current_point = start_point
' While (Not Current_point Is destination_point)
  
'        If Difference(Current_point) Then
'         Set X = OpenList.GetMinPoint()
'         MinK = X.K
  '          While (MinK <= Current_point.h And OpenList.HasNodes)
 '
   '            MinK = ProcessState()
  '           Wend
 '       End If
  '  Set Current_point = Current_point.BackPoint
' Wend
'End If
'Call OpenList.DisplayList

End Sub

Private Sub Form_Unload(Cancel As Integer)
Call OpenList.ClearList
Call CloseList.ClearList
End Sub
Function ProcessState() As Integer
Dim X  As PointItem
Dim MinK As Integer
Set X = OpenList.GetMinPoint()
If X Is Nothing Then
ProcessState = -1
End If
MinK = X.K
Call OpenList.RemovePoint(X)

Dim i As Integer
If MinK < X.h Then
Call GetPointNeighbors(X)

For i = 1 To UBound(Neighbor)
 If Neighbor(i).Y <= MinK And X.h > Neighbor(i).h + Arccost(i) Then
 Set X.BackPoint = Neighbor(i)
 '注意此处赋值对OpenList的影响
 X.h = Neighbor(i).h + Arccost(i)
 End If
Next i


ElseIf MinK = X.h Then
 
 Call GetPointNeighbors(X)
 For i = 1 To UBound(Neighbor)
   If Neighbor(i).Status = PointItemStatus.STATUSNEW Or (Neighbor(i).BackPoint Is X And Neighbor(i).h <> X.h + Arccost(i)) Or (Not Neighbor(i).BackPoint Is X And Neighbor(i).h > X.h + Arccost(i)) Then
    Set Neighbor(i).BackPoint = X
    '注意此处赋值对OpenList的影响
   Call OpenList.InsertPoint(Neighbor(i), X.h + Arccost(i))
   End If
 Next i
Else

 Call GetPointNeighbors(X)
 For i = 1 To UBound(Neighbor)
   If Neighbor(i).Status = PointItemStatus.STATUSNEW Or (Neighbor(i).BackPoint Is X And Neighbor(i).h <> X.h + Arccost(i)) Then
    Set Neighbor(i).BackPoint = X
    '注意此处赋值对OpenList的影响
    Call OpenList.InsertPoint(Neighbor(i), X.h + Arccost(i))
  ElseIf (Not Neighbor(i).BackPoint Is X And Neighbor(i).h > X.h + Arccost(i)) Then
    Call OpenList.InsertPoint(X, X.h)
  ElseIf (Not Neighbor(i).BackPoint Is X) And X.h > Neighbor(i).h + Arccost(i) And Neighbor(i).Status = PointItemStatus.STATUSCLOSE And Neighbor(i).Y > MinK Then
   Call OpenList.InsertPoint(Neighbor(i), Neighbor(i).Y)
End If
 Next i

End If
ProcessState = MinK
End Function

Private Sub GetPointNeighbors(pt As PointItem)
  ReDim Neighbor(0)
  ReDim Arccost(0)
 
  Set Neighbor(0) = pt
   Arccost(0) = 0
  Dim i As Integer
  Dim j As Integer
  For i = IIf(pt.X = 0, 0, pt.X - 1) To IIf(pt.X = MAXROW - 1, MAXROW - 1, pt.X + 1)
  For j = IIf(pt.Y = 0, 0, pt.Y - 1) To IIf(pt.Y = MAXCOL - 1, MAXCOL - 1, pt.Y + 1)
    If Not (i = pt.X And j = pt.Y) Then
     ReDim Preserve Neighbor(UBound(Neighbor) + 1)
     Set Neighbor(UBound(Neighbor)) = Points(i, j)
    ReDim Preserve Arccost(UBound(Neighbor))
    Arccost(UBound(Arccost)) = GetArccost(i, j, pt)
   End If
  Next
Next
End Sub


Private Function GetArccost(x0 As Integer, y0 As Integer, p As PointItem) As Integer
 If World(x0, y0) = DEAD Then
        If x0 = p.X And y0 = p.Y - 1 Then
           GetArccost = Distance.XDISTANCE_WITHBLOCK
         ElseIf x0 = p.X And y0 = p.Y + 1 Then
           GetArccost = Distance.XDISTANCE_WITHBLOCK
         ElseIf x0 = p.X - 1 And y0 = p.Y Then
           GetArccost = Distance.XDISTANCE_WITHBLOCK
         ElseIf x0 = p.X + 1 And y0 = p.Y Then
         GetArccost = Distance.XDISTANCE_WITHBLOCK
         Else
         GetArccost = Distance.XYDISTANCE_WITHBLOCK
        End If
  
 Else
 
         If x0 = p.X And y0 = p.Y - 1 Then
           GetArccost = Distance.XDISTANCE
         ElseIf x0 = p.X And y0 = p.Y + 1 Then
           GetArccost = Distance.XDISTANCE
         ElseIf x0 = p.X - 1 And y0 = p.Y Then
          GetArccost = Distance.XDISTANCE
         ElseIf x0 = p.X + 1 And y0 = p.Y Then
         GetArccost = Distance.XDISTANCE
         Else
         GetArccost = Distance.XYDISTANCE
        End If
End If
End Function

Private Function Difference(pt As PointItem) As Boolean
Difference = False
End Function