frmfindallpaths.frm

vb实现最短路径Dijkstra算法

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmFindAllPaths 
   Caption         =   "Find All Paths"
   ClientHeight    =   4140
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6120
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   ScaleHeight     =   4140
   ScaleWidth      =   6120
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton cmdShowTest 
      Caption         =   "Test"
      Height          =   315
      Left            =   1770
      TabIndex        =   6
      Top             =   3780
      Width           =   1035
   End
   Begin VB.CommandButton cmdCLS 
      Caption         =   "cls"
      Height          =   255
      Left            =   3615
      TabIndex        =   5
      Top             =   195
      Width           =   1050
   End
   Begin VB.TextBox txtOut 
      Height          =   3030
      Left            =   3075
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Top             =   570
      Width           =   2820
   End
   Begin VB.CommandButton cmdFindAllPaths 
      Caption         =   "Find All Paths"
      Height          =   345
      Left            =   45
      TabIndex        =   2
      Top             =   3060
      Width           =   1650
   End
   Begin VB.CommandButton cmdCalcData 
      Caption         =   "Calculate Data"
      Height          =   420
      Left            =   1230
      TabIndex        =   0
      Top             =   45
      Width           =   1470
   End
   Begin MSFlexGridLib.MSFlexGrid flxMap 
      Height          =   2505
      Left            =   30
      TabIndex        =   1
      Top             =   510
      Width           =   2925
      _ExtentX        =   5159
      _ExtentY        =   4419
      _Version        =   393216
      Rows            =   1
      Cols            =   1
      FixedRows       =   0
      FixedCols       =   0
   End
   Begin VB.Label Label4 
      Caption         =   "You should click on any two objects before finding the paths"
      Height          =   420
      Left            =   3225
      TabIndex        =   7
      Top             =   3675
      Width           =   2775
   End
   Begin VB.Label lblFromTo 
      Alignment       =   2  'Center
      Caption         =   "lblFromTo"
      Height          =   195
      Left            =   495
      TabIndex        =   3
      Top             =   3510
      Width           =   1905
   End
End
Attribute VB_Name = "frmFindAllPaths"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'  ==========================================
'  Dijkstra's algorithm to find Shortest Path
'  ==========================================
'
' E.W. Dijkstra is a Dutch professor in Computer
' Science, who did a lot of research in graphs.
'
' Dijkstra's algorithm is of use when working with
' directional graphs. It constructs the shortest path
' between a starting-node and a goal-node.
' It is assumed that every link between two nodes
' has a certain cost, and this algorithm finds the
' path between the two given nodes with the lowest cost.
'
' The idea of this VB project was to show the
' work of this algorithm in a visual way.
'
'    Screen-shot: dijkstra.gif
'
'
'    Visit my Homepage:
'    http://www.geocities.com/emu8086/vb/
'
'
'    Last Update: Saturday, July 20, 2002
'
'
'    Copyright 2002 Alexander Popov Emulation Soft.
'               All rights reserved.
'        http://www.geocities.com/emu8086/

Option Explicit

Dim sFrom As String
Dim sTo As String

Const arrow = " -> "
Dim path_id As Integer

Private Sub cmdCalcData_Click()

Dim i As Integer
Dim j As Integer
Dim toIndex As Integer

flxMap.Rows = Form1.theBlockCollection.Count + 1
flxMap.Cols = Form1.theBlockCollection.Count + 1
If Form1.theBlockCollection.Count > 0 Then
    flxMap.FixedRows = 1
    flxMap.FixedCols = 1
End If

For i = 0 To flxMap.Cols - 1
    flxMap.ColWidth(i) = 300
Next i

For i = 1 To Form1.theBlockCollection.Count
    flxMap.Row = i
    flxMap.Col = 0
    flxMap.Text = Form1.theBlockCollection(i).sCaption
    flxMap.Row = 0
    flxMap.Col = i
    flxMap.Text = Form1.theBlockCollection(i).sCaption
    
     
    flxMap.Row = i
    
    For j = 1 To flxMap.Cols - 1
            flxMap.TextMatrix(i, j) = "0"
            flxMap.Row = i
            flxMap.Col = j
            flxMap.CellForeColor = vbBlack
            flxMap.CellFontBold = False
    Next j
    
    For j = 1 To Form1.theLineCollection.Count
        If Form1.theLineCollection(j).sFrom = Form1.theBlockCollection(i).TagID Then
            toIndex = Form1.theBlockCollection.getIndexFromTag(Form1.theLineCollection(j).sTo)
            flxMap.Col = toIndex
            flxMap.Text = "1"
            flxMap.CellForeColor = vbRed
            flxMap.CellFontBold = True
        End If
    Next j
    
Next i
End Sub

Private Sub cmdShowTest_Click()
    frmTest.Show
End Sub

Private Sub Form_Activate()
    If PREV_SELECTED_SHAPE = -1 Or SELECTED_SHAPE = -1 Then
        lblFromTo.Caption = "nothing selected"
        cmdFindAllPaths.Enabled = False
    Else
        cmdFindAllPaths.Enabled = True
        sFrom = Form1.theBlockCollection(Form1.shp(PREV_SELECTED_SHAPE).Tag).sCaption
        sTo = Form1.theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaption
        lblFromTo.Caption = "From: " & sFrom & "  To: " & sTo
    End If
End Sub

Private Sub findPaths(src As Integer, dest As Integer, p As String)
    Dim tc As String
    Dim i As Integer

    tc = p

    If (flxMap.TextMatrix(src, dest) = "1") Then
        If Not (0 < InStr(1, tc, flxMap.TextMatrix(0, dest))) Then
            Dim s As String
            s = tc
            s = s & arrow
            s = s & flxMap.TextMatrix(0, dest)
            path_id = path_id + 1
            txtOut.Text = txtOut.Text & path_id & ". " & s & vbNewLine
        End If
    End If

    For i = 1 To flxMap.Cols - 1
        If (flxMap.TextMatrix(src, i) = "1") Then
            If Not (0 < InStr(1, tc, flxMap.TextMatrix(0, i))) Then
                Dim s2 As String
                s2 = tc
                s2 = s2 & arrow
                s2 = s2 & flxMap.TextMatrix(0, i)
                findPaths i, dest, s2
            End If
        End If
    Next i
    
    frmTest.listPaths.AddItem p ' any possible direction.
    If (Mid(p, Len(p)) = sTo) Then
        frmTest.listGoodPaths.AddItem p ' good path.
    End If
End Sub

Private Sub printAllPaths(src As Integer, dest As Integer)
   Dim start As String

   path_id = 0
   frmTest.listPaths.Clear
   frmTest.listGoodPaths.Clear

   txtOut.Text = txtOut.Text & "Paths from " & flxMap.TextMatrix(0, src) & " to " & flxMap.TextMatrix(0, dest) & vbNewLine
   start = flxMap.TextMatrix(0, src)
   findPaths src, dest, start
   If (path_id = 0) Then
        txtOut.Text = txtOut.Text & "-- NO PATHS! --" & vbNewLine
   End If
   txtOut.Text = txtOut.Text & vbNewLine & vbNewLine
End Sub

Private Sub cmdFindAllPaths_Click()
    Dim i As Integer
    Dim isrc As Integer
    Dim idest As Integer
    
    isrc = -1
    idest = -1
    
    For i = 1 To flxMap.Cols - 1
        If (flxMap.TextMatrix(0, i) = sFrom) Then
            isrc = i
        End If
        If (flxMap.TextMatrix(0, i) = sTo) Then
            idest = i
        End If
    Next i
    
    If (isrc = -1) Or (idest = -1) Then
        MsgBox "Something wrong! (update data!)"
        Exit Sub
    End If
    
    printAllPaths isrc, idest
    
    txtOut.SetFocus
    txtOut.SelStart = Len(txtOut.Text)
    
End Sub

Private Sub cmdCLS_Click()
    txtOut.Text = ""
End Sub