Enero 24, 2018, 12:25:11 am

Autor Tema: [VB] Problema de la ruta mas corta  (Leído 3049 veces)

0 Usuarios y 1 Visitante están viendo este tema.

Desconectado Root XOR

  • Moderador
  • *****
  • Mensajes: 401
  • Sexo: Masculino
  • Exclusive Root
    • Ver Perfil
[VB] Problema de la ruta mas corta
« en: Diciembre 11, 2011, 10:34:09 pm »
Este es un Programa que realice para la clase de MATEMÁTICAS DISCRETAS en un ciclo anterior

Bien lleva consigo un archivo de clase,
Código: (vbnet) You are not allowed to view links. Register or Login
Imports System.Math

Public Class Calcs

    Function Randomizer()
        Dim num As Integer
        num = Rnd() * 400
        Return num
    End Function

    Function Distancia(ByVal a1 As Integer, ByVal a2 As Integer, ByVal b1 As Integer, ByVal b2 As Integer)
        Dim Oper As Double
        Oper = Sqrt((Pow((a2 - a1), 2)) + Pow((b2 - b1), 2))
        Return Oper
    End Function

    Function totRutas(ByVal ptscomb As Integer, ByVal ptsrec As Integer)
        Dim vals As Long = 1
        ptscomb -= 1
        For i As Integer = 0 To ptsrec - 2
            vals *= ptscomb - i
        Next
        Return vals
    End Function
End Class

Y las instrucciones del formulario Principal,

Código: (vbnet) You are not allowed to view links. Register or Login
Imports System.Math
Imports System.Threading
Imports System.Drawing
Imports System.Drawing.Drawing2D
Public Class frmPrincipal

#Region "DECLARATIVAS"

    Public Puntos As dsPos                  'Cada Tabla de Datos
    Public Linea As DataRow                 'Cada Linea de las Tablas
    Public N As Integer                     'Cantidad de Puntos
    Public XV As Long                    'Combinaciones de rutas
    Public dibujo As Graphics               'Area de Dibujo
    Public lapiz As New Pen(Color.Black)    'Declaro lapiz
    Public Fuente1 As Font                   'Fuente 1
    Public Fuente2 As Font                  'Fuente 2
    Private Calc As New Calcs               'Libreria de Calculos
    Dim otra As Byte = 0

    Dim menor As Long
    Dim indexmay As Long
    Dim mayor As Long
    Dim indexmen As Long

#End Region

    Private Sub frmPrincipal_Load(ByVal sender As System.Object, _
                                  ByVal e As System.EventArgs) Handles MyBase.Load

        nudCantidad.Maximum = My.Settings.MAXpts            'Defino El Maximo de puntos
        dibujo = PicGrafico.CreateGraphics                  'Declaro Area de Dibujo
        Fuente1 = New Font(FontFamily.GenericSerif, 10)     'Especifico la Fuente 1
        Fuente2 = New Font(FontFamily.GenericMonospace, 10) 'Especifico la Fuente 2

    End Sub

    Private Sub btnGenerar_Click(ByVal sender As System.Object, _
                                 ByVal e As System.EventArgs) Handles btnGenerar.Click

        N = nudCantidad.Value                       'Asigno a N la cantidad de puntos generados

        If nudCantidad.Value <= 1 Then              'Por si pone un valor muy pequeño
            MsgBox("Debe Generar 2 o mas puntos", _
                   MsgBoxStyle.Critical = _
                   MsgBoxStyle.OkOnly, "Erro")
        Else
            bgwGenPts.RunWorkerAsync()              'Inicio el Procesador de Generacion
            nudSalt.Minimum = 2
            nudSalt.Maximum = N                     'Maximo de Rutas que puedo pedir
            nudInitPT.Minimum = 1
            nudInitPT.Maximum = N
            btnGraf.Enabled = True
            btnCalc.Enabled = True
        End If

    End Sub

    Private Sub btnGraf_Click(ByVal sender As System.Object, _
                              ByVal e As System.EventArgs) Handles btnGraf.Click
        Graf_puntos()
    End Sub

    Private Sub btnClear_Click(ByVal sender As System.Object, _
                               ByVal e As System.EventArgs) Handles btnClear.Click
        dibujo.Clear(Color.White)                   'Limpio el Area de Dibujo
    End Sub

    Private Sub btnCalc_Click(ByVal sender As System.Object, _
                              ByVal e As System.EventArgs) Handles btnCalc.Click

        menor = 100000000
        indexmay = -1
        mayor = -1
        indexmen = -1

        Puntos.dtRoute.Clear()
        bgwGenroute.RunWorkerAsync()

    End Sub

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
        bgwGenroute.CancelAsync()
    End Sub


#Region "BG WORKER GRAF"

    Private Sub bgwGenPts_DoWork(ByVal sender As System.Object, _
                             ByVal e As System.ComponentModel.DoWorkEventArgs) _
                             Handles bgwGenPts.DoWork
        Generacion_PTS()
        Distancia_PTS()
    End Sub

    Private Sub bgwGenPts_ProgressChanged(ByVal sender As System.Object, _
                                          ByVal e As System.ComponentModel.ProgressChangedEventArgs) _
                                          Handles bgwGenPts.ProgressChanged
        pbProceso.Value = e.ProgressPercentage
    End Sub

    Private Sub bgwGenPts_ProgressEnd(ByVal sender As System.Object, _
                                      ByVal e As System.ComponentModel.AsyncCompletedEventArgs) _
                                      Handles bgwGenPts.RunWorkerCompleted
        Me.dgvRandoms.DataSource = Puntos.Tables("dtRandpos")
        Me.dgvDist.DataSource = Puntos.Tables("dtDist")
        Graf_puntos()
        pbProceso.Value = 0
    End Sub

#End Region

#Region "BG WORKER ROUTE"

    Private Sub bgwGenroute_DoWork(ByVal sender As System.Object, _
                                 ByVal e As System.ComponentModel.DoWorkEventArgs) _
                                 Handles bgwGenroute.DoWork

        XV = Calc.totRutas(nudCantidad.Value, nudSalt.Value)
        Rutas()

    End Sub

    Private Sub bgwGenroute_ProgressChanged(ByVal sender As System.Object, _
                                          ByVal e As System.ComponentModel.ProgressChangedEventArgs) _
                                          Handles bgwGenroute.ProgressChanged

        lblroutes.Text = "Se han Generado: " & e.ProgressPercentage & " Rutas"
        On Error Resume Next
        pbProceso.Value = ((e.ProgressPercentage / XV) * 100)
        On Error Resume Next

    End Sub

    Private Sub bgwGenroute_ProgressEnd(ByVal sender As System.Object, _
                                      ByVal e As System.ComponentModel.AsyncCompletedEventArgs) _
                                      Handles bgwGenroute.RunWorkerCompleted

        dgvRoutes.DataSource = Puntos.Tables("dtRoute")
        pbProceso.Value = 0
        lblRouteMenor.Text = Puntos.Tables("dtRoute").Rows(indexmen).Item("NODOS")
        lblRouteMayor.Text = Puntos.Tables("dtRoute").Rows(indexmay).Item("NODOS")
    End Sub

#End Region


#Region "SUB RUTINAS"

    Public Sub Generacion_PTS()
        Puntos = New dsPos
        Dim rep1 As Integer = 0
        For i As Integer = 0 To N - 1
            Linea = Puntos.dtRandpos.NewRow()  ' creo una linea en blanco
            Puntos.dtRandpos.Rows.Add(Linea)
            Linea.Item("ID") = i + 1
            Linea.Item("X") = Calc.Randomizer()
            Linea.Item("Y") = Calc.Randomizer()
            rep1 = ((i / (N - 1)) * 100)
            bgwGenPts.ReportProgress(rep1)
        Next
    End Sub

    Public Sub Distancia_PTS()
        Dim x1 As Short
        Dim x2 As Short
        Dim y1 As Short
        Dim y2 As Short
        Dim rep2 As Integer = 0
        For p1 As Integer = 0 To N
            For p2 As Integer = p1 + 1 To N - 1
                x1 = CType(Puntos.Tables("dtRandpos").Rows(p1).Item("X"), Integer)
                x2 = CType(Puntos.Tables("dtRandpos").Rows(p2).Item("X"), Integer)
                y1 = CType(Puntos.Tables("dtRandpos").Rows(p1).Item("Y"), Integer)
                y2 = CType(Puntos.Tables("dtRandpos").Rows(p2).Item("Y"), Integer)

                Linea = Puntos.dtDist.NewRow()
                Puntos.dtDist.Rows.Add(Linea)
                Linea.Item("ID_P1") = p1 + 1
                Linea.Item("ID_P2") = p2 + 1
                Linea.Item("DIST") = Round(Calc.Distancia(x1, x2, y1, y2), 4)
                rep2 = ((p1 / (N - 1)) * 100)
                bgwGenPts.ReportProgress(rep2)
            Next
        Next
    End Sub

    Public Sub Graf_puntos()
        For i As Integer = 0 To N - 1
            Dim x As Integer = CType(Puntos.Tables("dtRandpos").Rows(i).Item("X"), Integer)
            Dim y As Integer = CType(Puntos.Tables("dtRandpos").Rows(i).Item("Y"), Integer)
            dibujo.DrawString("*", Fuente1, Brushes.Blue, x - 5, y - 5)
            'Dim cadena As String = "(" & CType(x, String) & "," & CType(y, String) & ")"
            dibujo.DrawString(CType(i + 1, String), Fuente2, Brushes.Red, x, y)
        Next
    End Sub

    Public Sub Graf_Trace(ByVal Pts())
        Dim pt1 As Integer
        Dim pt2 As Integer
        For i As Integer = 0 To Pts.Length - 2
            pt1 = Pts(i) - 1
            pt2 = Pts(i + 1) - 1

            Dim x1 = CType(Puntos.Tables("dtRandpos").Rows(pt1).Item("X"), Integer)
            Dim x2 = CType(Puntos.Tables("dtRandpos").Rows(pt2).Item("X"), Integer)
            Dim y1 = CType(Puntos.Tables("dtRandpos").Rows(pt1).Item("Y"), Integer)
            Dim y2 = CType(Puntos.Tables("dtRandpos").Rows(pt2).Item("Y"), Integer)
            dibujo.DrawLine(lapiz, x1, y1, x2, y2)
        Next
        lapiz = Pens.Black
    End Sub

    Public Sub Rutas()

        Dim Npts, Ninit, Nsalt, c, log, cont As Integer
        cont = 0
        Npts = nudCantidad.Value
        Ninit = nudInitPT.Value
        Nsalt = nudSalt.Value
        Dim x(Nsalt - 1) As Integer
        Dim CadTemp As String = ""
        Dim DisTemp As Double = 0
        c = Nsalt - 1

        For q As Integer = 0 To Nsalt - 1
            x(q) = q
        Next

        Dim i As Integer = 0
        'x(0) = Ninit - 1

        Do
            For h As Integer = 0 To Nsalt - 1
                For j As Integer = 0 To Nsalt - 1
                    If x(h) = x(j) Then
                        log += 1
                    End If
                Next
            Next

            If log <= Nsalt Then

                For k As Integer = 0 To Nsalt - 1
                    If k < Nsalt - 1 Then
                        CadTemp = CadTemp & (x(k) + 1) & ","
                    Else
                        CadTemp = CadTemp & (x(k) + 1)
                    End If
                Next
                Dim ArrTemp() = CadTemp.Split(",")

                If ArrTemp(0) = Ninit Then
                    Dim pt1 As Integer
                    Dim pt2 As Integer
                    For tmp As Integer = 0 To ArrTemp.Length - 2
                        pt1 = ArrTemp(tmp) - 1
                        pt2 = ArrTemp(tmp + 1) - 1
                        Dim x1 = CType(Puntos.Tables("dtRandpos").Rows(pt1).Item("X"), Integer)
                        Dim x2 = CType(Puntos.Tables("dtRandpos").Rows(pt2).Item("X"), Integer)
                        Dim y1 = CType(Puntos.Tables("dtRandpos").Rows(pt1).Item("Y"), Integer)
                        Dim y2 = CType(Puntos.Tables("dtRandpos").Rows(pt2).Item("Y"), Integer)
                        DisTemp = DisTemp + Calc.Distancia(x1, x2, y1, y2)
                    Next

                    If DisTemp < menor Then
                        menor = Round(DisTemp, 4)
                        indexmen = cont
                    End If

                    If DisTemp > mayor Then
                        mayor = Round(DisTemp, 4)
                        indexmay = cont
                    End If

                    Linea = Puntos.dtRoute.NewRow()
                    Linea.Item("NODOS") = CadTemp
                    Linea.Item("DIST") = Round(DisTemp, 4)
                    Puntos.dtRoute.Rows.Add(Linea)
                    cont += 1
                    bgwGenroute.ReportProgress(cont)
                End If

                CadTemp = ""
                DisTemp = 0
                If ArrTemp(0) > Ninit Then
                    Exit Do
                End If
            End If

            x(c) += 1
            Do
                If x(c) = Npts Then
                    x(c) = 0
                    c = c - 1
                    x(c) += 1
                End If
                If Not x(c) = Npts Then
                    Exit Do
                End If
            Loop
            i += 1
            c = Nsalt - 1
            log = 0
            If x(0) >= Npts - 1 Then
                Exit Do
            End If

        Loop

    End Sub

#End Region

#Region "PICTURE BOX"

    Private Sub pbGrafico_MouseMove(ByVal sender As System.Object, _
                                    ByVal e As System.Windows.Forms.MouseEventArgs) _
                                    Handles PicGrafico.MouseMove
        Dim P As Point
        Dim Cx, Cy As Single
        Dim scalax, scalay As Single
        Cx = PicGrafico.ClientSize.Width
        Cy = PicGrafico.ClientSize.Height
        scalax = Cx : scalay = Cy
        P = e.Location
        Label1.Text = ((e.X - Cx) + scalax) & "," & ((e.Y + Cy) - scalay)
    End Sub

    Private Sub PicGrafico_Click(ByVal sender As System.Object, _
                                 ByVal e As System.EventArgs) Handles PicGrafico.Click
        Dim xy()
        xy = Label1.Text.Split(",")
        dibujo.DrawString("*", Fuente1, Brushes.Green, xy(0) - 5, xy(1) - 5)
    End Sub

#End Region


    Private Sub dgvRoutes_CellContentClick(ByVal sender As System.Object, ByVal e As System.Windows.Forms.DataGridViewCellEventArgs) Handles dgvRoutes.CellContentClick
        On Error Resume Next
        Dim numeroindex As String = Me.dgvRoutes.Item(0, e.RowIndex).Value.ToString
        On Error Resume Next
        Graf_Trace(numeroindex.Split(","))
        On Error Resume Next
    End Sub

    Private Sub btnMenor_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnMenor.Click
        lapiz = Pens.Blue
        Graf_Trace(lblRouteMenor.Text.Split(","))
    End Sub

    Private Sub btnMayor_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnMayor.Click
        lapiz = Pens.Fuchsia
        Graf_Trace(lblRouteMayor.Text.Split(","))
    End Sub
End Class

Hay un dataset.
Dejare el Link para la descarga del codigo Fuente.
You are not allowed to view links. Register or Login
Creo que habían algunos problemas referentes a la cantidad de combinaciones que se pueden realizar
pero como ya fue presentado y calificado no le di interés en corregirlo.

Saludos[/code]
« Última modificación: ſeptiembre 18, 2012, 08:57:55 am por Root XOR »

Desconectado ALEKSEI FLORES CENTENO

  • CPQUE??
  • *
  • Mensajes: 1
    • Ver Perfil
Re:[VB] Problema de la ruta mas corta
« Respuesta #1 en: Marzo 11, 2015, 07:33:39 pm »
hola hermano, sabes estoy muy interesado en este proyecto me gustaría saber si puedes re-subir el link de descarga ya que esta muerto, te lo agradecería mucho.


xx
Problema para abrir ruta.

Iniciado por ExPuMa

2 Respuestas
864 Vistas
Último mensaje Abril 17, 2009, 12:51:22 pm
por RockoX
xx
Problema al sacar ruta de un Textbox

Iniciado por Nekuroi

3 Respuestas
1256 Vistas
Último mensaje Marzo 21, 2009, 09:29:19 pm
por EddyW
question
ARP Spoofing corta internet

Iniciado por roadd

4 Respuestas
1378 Vistas
Último mensaje Febrero 27, 2013, 08:35:18 pm
por roadd
xx
Comunicación terminales corta distancia

Iniciado por PeterPeterPeter2

7 Respuestas
2528 Vistas
Último mensaje Diciembre 19, 2017, 03:37:42 pm
por DUDA!
xx
Se corta el internet (en páginas torrents)

Iniciado por slayerbleast

3 Respuestas
1624 Vistas
Último mensaje Mayo 09, 2012, 07:51:26 pm
por locvtvs
question
Un hacker me corta el internet(AYUDA SOY NOVATO)

Iniciado por firruvl

9 Respuestas
1293 Vistas
Último mensaje Abril 25, 2014, 11:19:30 pm
por seth
question
No puedo cerrar un Puerto porque se me corta la conexión :O

Iniciado por Apocalixsa

3 Respuestas
2015 Vistas
Último mensaje Febrero 03, 2008, 07:06:26 pm
por napoleon15
exclamation
Shell remota en Python (corta, simple y explicada)

Iniciado por coredump

4 Respuestas
6087 Vistas
Último mensaje Febrero 17, 2010, 03:51:00 pm
por wocarin
xx
Como desactivar el antivirus y corta fuegos de la victima????????

Iniciado por aljack12

3 Respuestas
1619 Vistas
Último mensaje Diciembre 18, 2007, 10:52:06 am
por huron74
exclamation
El Pentágono corta la WiFi de Guantánamo tras amenazas de Anonymous

Iniciado por cemasmas

2 Respuestas
894 Vistas
Último mensaje Mayo 24, 2013, 01:29:38 pm
por Royca