Option Explicit
Const Nulo = 0    '' Posicion NO Valida de la Lista
Dim L       As New Listas
Dim P       As New Pilas
Dim C       As New Colas
Dim G       As New Grafos
 
Private Sub cmd_apilar_Click()
 
    Dim X       As Variant
 
    Randomize
 
    While Not P.EstaLlena
        X = Int(Rnd(100) * 100)
        P.Apilar X
    Wend
 
End Sub
 
Private Sub cmd_eliminar_Click()
 
    Dim Q       As Long
    Dim X       As Variant
 
    X = CLng(InputBox("Ingresar Dato a Eliminar", "Ingresar Datos", ""))
 
    Q = L.Buscar(X)
 
    If Q <> Nulo Then
        L.Eliminar (Q)
    Else
        MsgBox "Elemento No Encontrado"
    End If
 
End Sub
 
Private Sub cmd_encolar_Click()
 
    Dim X       As Variant
 
    Randomize
 
    While Not C.EstaLlena
        X = Int(Rnd(100) * 100)
        C.Encolar X
    Wend
 
End Sub
 
Private Sub cmd_listar_Click()
 
    Dim Q       As Long
    Dim X       As Variant
 
    List1.Clear
    Q = L.Inicio
 
    While Q <> Nulo
        X = L.Recuperar(Q)
        List1.AddItem X
        Q = L.Siguiente(Q)
    Wend
 
End Sub
 
Private Sub cmd_mostrar_cola_Click()
 
    Dim X       As Variant
    Dim li      As Integer
 
    li = 0
    List1.Clear
    While Not C.EstaVacia
        X = C.Recuperar
        li = li + 1
        List1.AddItem "Pos(" & li & ") = " & X
        C.DesEncolar
    Wend
 
End Sub
 
Private Sub cmd_mostrar_pila_Click()
 
    Dim X       As Variant
 
    List1.Clear
    While Not P.EstaVacia
        X = P.Recuperar
        List1.AddItem X
        P.DesApilar
    Wend
 
End Sub
 
Private Sub cmd_test_Click()
 
    Dim X       As Variant
 
    Randomize
    X = Int(Rnd(100) * 100)
    If L.Agregar(X) = False Then
        MsgBox "Error al Agregar en la Lista"
    End If
 
End Sub
 
Private Sub cmdcreargrafo_Click()
    Dim V As Variant
    Dim V2 As Variant
    Dim Varco As Variant
 
    V = "A"
    G.AgregarVertice (V)
    V = "B"
    G.AgregarVertice (V)
    V = "C"
    G.AgregarVertice (V)
    V = "D"
    G.AgregarVertice (V)
 
    Varco = 1
    V = "A"
    V2 = "B"
    If G.AgregarArco(V, V2, Varco) = False Then
    End If
 
    V = "B"
    V2 = "D"
    If G.AgregarArco(V, V2, Varco) = False Then
    End If
 
    V = "D"
    V2 = "C"
    If G.AgregarArco(V, V2, Varco) = False Then
    End If
 
    List1.Clear
    List1.AddItem G.RetornarVertices
    List1.AddItem G.RetornarArcos
 
End Sub
 
Private Sub cmdrecorridoanchura_Click()
 
    List1.AddItem G.RecorridoAnchura("A")
 
End Sub
 
Private Sub cmdrecorridoprof_Click()
 
    List1.AddItem G.RecorridoProfundidad("A")
 
End Sub
 
Private Sub Form_Load()
 
    L.CrearVacia
    P.CrearVacia
    C.CrearVacia
    G.CrearVacio
 
End Sub

Option Explicit   '' Obliga a definir todos las variables
Option Base 1     '' Para obligar a que los array funcionen de 1-N
 
Const MIN = 1     '' Elemento Minimo del Array
Const MAX = 100   '' Elemento Maximo del Array
Const Nulo = 0    '' Posicion NO Valida de la Lista
 
Dim Vertices(MAX) As Variant  '' Array donde se guardan los elementos
Dim Arcos(MAX, MAX) As Integer
 
Public NroVertices  As Integer  '' Maneja la Cantidad de Vertices que hay al momento en el grafo. maximo MAX = 100
 
Public Sub CrearVacio()
    Dim i, j As Integer
 
 
    NroVertices = 0  '' Indica que NO hay vertices
 
    '' Instancio cada casillero de la Matriz en Vacio
    For i = 1 To MAX
        For j = 1 To MAX
            Arcos(i, j) = vbEmpty
        Next
    Next
End Sub
 
Public Function EsVacio() As Boolean
    EsVacio = IIf(NroVertices = 0, True, False)
End Function
 
Public Function EsLleno() As Boolean
    EsLleno = IIf(NroVertices = MAX, True, False)
End Function
 
Public Function BuscarVertice(V As Variant) As Integer
    Dim i As Integer
 
    BuscarVertice = Nulo
    For i = 1 To NroVertices
        If Vertices(i) = V Then
            BuscarVertice = i
            Exit For
        End If
    Next
End Function
 
Public Function AgregarVertice(V As Variant) As Boolean
 
    If BuscarVertice(V) <> Nulo Then
        AgregarVertice = False
    Else
        NroVertices = NroVertices + 1
        Vertices(NroVertices) = V
        AgregarVertice = True
    End If
 
End Function
 
Public Function AgregarArco(V1, V2 As Variant, Varco As Variant, Optional ArcoBidireccional As Boolean = True) As Boolean
    Dim i, j As Integer
 
    AgregarArco = False
    If V1 <> V2 Then
        i = BuscarVertice(V1)
        j = BuscarVertice(V2)
        If (i <> Nulo) And (j <> Nulo) Then
            Arcos(i, j) = Varco
            If ArcoBidireccional = True Then
                Arcos(j, i) = Varco
            End If
            AgregarArco = True
        End If
    End If
End Function
 
Public Function EliminarArco(V1, V2 As Variant, Optional ArcoBidireccional As Boolean = True) As Boolean
    Dim i, j As Integer
 
    EliminarArco = False
    If V1 <> V2 Then
        i = BuscarVertice(V1)
        j = BuscarVertice(V2)
        If (i <> Nulo) And (j <> Nulo) Then
            Arcos(i, j) = vbEmpty
            If ArcoBidireccional = True Then
                Arcos(j, i) = vbEmpty
            End If
            EliminarArco = True
        End If
    End If
End Function
 
Public Function EliminarVertice(V As Variant) As Boolean
    Dim i, j, k As Integer
 
    EliminarVertice = False
    i = BuscarVertice(V)
    If V <> Nulo Then
        '' Primero Saco la Columna de la Matriz
        For j = 1 To NroVertices
            For k = i To NroVertices - 1
                Arcos(j, k) = Arcos(j, k + 1)
            Next
        Next
        '' Segundo saco la Fila de la matriz
        For j = i To NroVertices - 1
            For k = 1 To NroVertices - 1
                Arcos(j, k) = Arcos(j + 1, k)
            Next
        Next
        '' Saco el Vertice del vector de vertices
        For j = i To NroVertices - 1
            Vertices(j) = Vertices(j + 1)
        Next
        '' Por ultimo descuento 1 en la variable nrovertices
        NroVertices = NroVertices - 1
 
        EliminarVertice = True
    End If
End Function
 
Public Function RetornarVertices() As String
    Dim ll_i As Integer
    Dim S As String
 
    RetornarVertices = ""
    For ll_i = 1 To NroVertices
        S = S & Vertices(ll_i) & ", "
    Next
    RetornarVertices = S
End Function
 
Public Function RetornarArcos() As String
    Dim ll_i As Integer
    Dim ll_j As Integer
    Dim S As String
 
    RetornarArcos = ""
    For ll_i = 1 To NroVertices
        For ll_j = 1 To NroVertices
            S = S & Arcos(ll_i, ll_j) & ", "
        Next
        S = S & " | "
    Next
    RetornarArcos = S
End Function
 
Public Function RecorridoProfundidad(V As Variant) As String
 
    Dim ll_i As Integer
    Dim ll_j As Integer
    Dim P As New Pilas
    Dim L As New Listas
    Dim S As String
 
    ll_i = BuscarVertice(V)
    If ll_i = Nulo Then
        RecorridoProfundidad = ""
        Exit Function
    End If
 
    '' Si esta el Vertice se comienza el recorrido en profundidad
    P.CrearVacia
    P.Apilar (ll_i)
    L.CrearVacia
    While Not P.EstaVacia
        ll_i = P.Recuperar
        L.Agregar (ll_i)
        S = S & Vertices(ll_i)
        P.DesApilar
        For ll_j = 1 To NroVertices
            If Arcos(ll_i, ll_j) <> vbEmpty Then
                If L.Buscar(ll_j) = Nulo Then
                    P.Apilar (ll_j)
                End If
            End If
        Next
    Wend
 
    RecorridoProfundidad = S
End Function
 
Public Function RecorridoAnchura(V As Variant) As String
 
    Dim ll_i As Integer
    Dim ll_j As Integer
    Dim C As New Colas
    Dim L As New Listas
    Dim S As String
 
    ll_i = BuscarVertice(V)
    If ll_i = Nulo Then
        RecorridoAnchura = ""
        Exit Function
    End If
 
    '' Si esta el Vertice se comienza el recorrido en profundidad
    C.CrearVacia
    C.Encolar (ll_i)
    L.CrearVacia
    While Not C.EstaVacia
        ll_i = C.Recuperar
        L.Agregar (ll_i)
        S = S & Vertices(ll_i)
        C.DesEncolar
        For ll_j = 1 To NroVertices
            If Arcos(ll_i, ll_j) <> vbEmpty Then
                If L.Buscar(ll_j) = Nulo Then
                    C.Encolar (ll_j)
                End If
            End If
        Next
    Wend
 
    RecorridoAnchura = S
End Function