Résolution du problème du voyageur de commerce (tsp) par l'algorithme de little

Télécharger le projet
Commenter

Description

Comme beaucoup d?étudiant on m?a demandé de programmer une petite application de résolution du problème du voyageur de commerce (TSP) par l'algorithme de LITTLE.
J?avoue avoir cherché un peu partout pour trouver des sources mais rien de satisfaisant et encore moins en VB. Donc je vous mets à disposition mon appli.
Explication :
Le but est simple, on imagine une matrice de plusieurs points de départs et d?arrivées qui nous donne les coûts engendrés par un déplacement. Le problème est d?estimer un coup minimum en passant par chaque point une fois.
L?application :
J?avoue elle n?est pas infaillible, au contraire il y a quelque problème qu?elle ne résout pas, mais elle a le mérite de fonctionner. De plus, je crois avoir lut sur le net qu?il n?existait pas d?appli qui résolvais ce problème parfaitement à tous les coups et puis le nombre de calcul devient vite astronomique. Et surtout sa me soule donc j?arrête là, je me contenterais de la moyenne :P
Bon, il se fait tard je vous mets ça à disposition et si cette appli vous dépanne d?un projet (de long heures) j?aimerais bien voir la manière dont vous l?avez présentée (pour les dossiers), mais pas de panique pour moi c déjà rendu.

Source / Exemple : 


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'           FAC de Toulouse le Mirail
'           Recherche opérationnelle
'           Formation math, info, stat
' Aider par : http://www.cs.sunysb.edu/~algorith/implement/syslo/distrib/processed/babtsp.p
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Option Base 1 'valeur par défaut des variables tableau
Dim DetectionErreur As Boolean
Dim Temps As Integer
Dim Matrice() As Integer
Dim Ville As String
Const NBValMax = 50
Dim n, nextint, inf As Integer
Dim NumMatrice As Integer
Dim avoid, c, colligneval, first, I, j, last, lowerbound, most, r, Taille, TEMP, K, MINCOLELT, minligneelt, ZEROES As Integer
Dim PasaPas As Boolean
Dim fwdptr(NBValMax), backptr(NBValMax), meilleur(NBValMax), col(NBValMax), ligne(NBValMax), lieu(NBValMax)
Dim route(NBValMax)
Dim colred(NBValMax), newcol(NBValMax), newligne(NBValMax), ligneed(NBValMax)
  
Private Sub Form_Load()
    Form1.Show
End Sub

Private Sub CmdExemple_Click()
    'Appelle de la procedure de lancement de l'EXEMPLE
    Call Code_Exemple(lieu)
End Sub

Private Sub CmdDirect_Click()
    'Action lors du click sur le bouton de résolution DIRECT
    PasaPas = False
    Call Introduction
End Sub

Private Sub CmdPAS_Click()
    'Action lors du click sur le bouton de résolution PAS A PAS
    PasaPas = True
    Call Introduction
End Sub
Private Sub Introduction()
ZoneTexte.Text = ""
    Do Until ok = True
        Ville = InputBox("Saisir un nombre de ville.", "Nombre de ville", Int(Rnd * 13))
        If IsNumeric(Ville) Then
            If Ville < 2 Then
            MsgBox "Le nombre de ville doit étre au moins de deux.", vbCritical, "Erreur de saisie"
            Else: ok = True
            End If
        ElseIf Ville = "" Then
        End
        Else: MsgBox "Saisir un nombre de ville.", vbCritical, "Erreur de saisie"
        End If
    Loop
    
        inf = 9999
        n = Int(Ville)
        ReDim Matrice(1 To n, 1 To n) As Integer
        Call Saisie_des_données
        Call recherche(n, 9999, Matrice, route, Temps)
        Call resultat(route, Temps)
        Form1.Picture1.SetFocus
        
End Sub

Private Function recherche(NbrsVille, inf, Matrice, route, Temps)
Dim I, Index As Integer
     
    For I = 1 To NbrsVille
        ligne(I) = I
        col(I) = I
        fwdptr(I) = 0
        backptr(I) = 0
    Next
    Temps = inf
    Call explore(0, 0, ligne, col, Temps, Matrice)
    Index = 1
    For I = 1 To NbrsVille
       route(I) = Index
       Index = meilleur(Index)
    Next

End Function

Private Function explore(pointes, Cout, ligne, col, Temps, Matrice)
Dim most As Integer

     Taille = n - pointes
     'Réduction de la plus petite valeur pour avoir la longeur du chemin
     Cout = Cout + reduction(ligne, col, ligneed, colred, Matrice)
     If Cout < Temps Then
        If pointes = (n - 2) Then
           
                For I = 1 To n
                    meilleur(I) = fwdptr(I)
                Next
                If Matrice(ligne(1), col(1)) = inf Then
                    avoid = 1 'éviter
                    Else
                    avoid = 2
                End If
                
                meilleur(ligne(1)) = col(3 - avoid)
                meilleur(ligne(2)) = col(avoid)
                Temps = Cout

           Else
           
                Call meilleurpointe(r, c, most, Matrice) 'recherche de la meillieur pointe

                
                lowerbound = Cout + most        'limite inférieure ou surcout d'arrivé des villes
                fwdptr(ligne(r)) = col(c)
                backptr(col(c)) = ligne(r)
                last = col(c)
                '{ PREVENT CYCLES }Le cycle précedent
                tourSecu = 0
                
                Do While fwdptr(last) <> 0
                    tourSecu = tourSecu + 1
                    If tourSecu <= n Then
                    last = fwdptr(last)
                    'En cas de blocage sur la boucle (Bricolage)
                    Else
                        For last = 1 To n
                        If fwdptr(last) = 0 Then Exit For
                        Next
                    End If
                Loop
                
                first = ligne(r)
                tourSecu = 0
                Do While backptr(first) <> 0
                    tourSecu = tourSecu + 1
                    If tourSecu <= n Then
                    first = backptr(first)
                    'En cas de blocage sur la boucle (Bricolage)
                    Else
                        For first = 1 To n
                        If backptr(first) = 0 Then Exit For
                        Next
                    End If
                Loop
            'Marque la valeur trouvée
                colligneval = Matrice(last, first)
                Matrice(last, first) = inf
            'Supresion d'une ligne dans la matrice
                For I = 1 To r - 1          'les lignes avant la valeur trouvée
                newligne(I) = ligne(I)
                Next
                For I = r To Taille - 1     'les lignes après la valeur trouvé
                    newligne(I) = ligne(I + 1)
                Next
            'Supresion d'une Colonne dans la matrice
                For I = 1 To c - 1          'les Colonne avant la valeur trouvée
                    newcol(I) = col(I)
                Next
                For I = c To Taille - 1     'les Colonne après nla valeur trouvé
                    newcol(I) = col(I + 1)
                Next
            'relance l'exploration avec la ligne suprimé
                Call explore(pointes + 1, Cout, newligne, newcol, Temps, Matrice)
                
                '{ RESTORE PREVIOUS VALUES }
                Matrice(last, first) = colligneval
                backptr(col(c)) = 0
                fwdptr(ligne(r)) = 0
                
                If lowerbound < Temps Then
                     Matrice(ligne(r), col(c)) = inf
                     Call explore(pointes, Cout, ligne, col, Temps, Matrice)
                     Matrice(ligne(r), col(c)) = 0
                     'Cout = lowerbound
                End If

            End If
    End If
            '{ UNREDUCE MATRIX }
            For I = 1 To Taille
                For j = 1 To Taille
                    If (ligneed(I) < 0 Or colred(j) < 0) Or (ligneed(I) > 999 Or colred(j) > 999) Then
                    ZoneTexte.Text = ZoneTexte.Text & "Erreur" & vbCrLf
                    If DetectionErreur <> True Then
                    DetectionErreur = True
                    MsgBox "MDR, la résolution pose des problèmes, la solution va dériver.", vbCritical, "Erreur !!!"
                    End If
                    Else
                    
                    Matrice(ligne(I), col(j)) = Matrice(ligne(I), col(j)) + ligneed(I) + colred(j)
                    End If
                Next
            Next

End Function

Function min(I, j)
'Recherche des plus petits coûts
If I <= j Then
    min = I
Else
    min = j
End If
End Function
  

Private Function meilleurpointe(r, c, most As Integer, Matrice)
Dim I, j, K, MINCOLELT, MINROWELT, ZEROES As Integer
     most = -inf
    For I = 1 To Taille
        For j = 1 To Taille
            If Matrice(ligne(I), col(j)) = 0 Then
                minligneelt = inf
                MINCOLELT = inf
                ZEROES = 0
            'recherche  des zeros pour la ligne i
                For K = 1 To Taille
                    If Matrice(ligne(I), col(K)) = 0 Then
                        ZEROES = ZEROES + 1
                    Else
                        minligneelt = min(minligneelt, Matrice(ligne(I), col(K)))
                    End If
                Next
                If ZEROES > 1 Then minligneelt = 0

                ZEROES = 0
            'recherche des zero pour la colonne j
                For K = 1 To Taille
                    If Matrice(ligne(K), col(j)) = 0 Then
                    ZEROES = ZEROES + 1
                    Else
                    MINCOLELT = min(MINCOLELT, Matrice(ligne(K), col(j)))
                    End If
                Next
                If ZEROES > 1 Then MINCOLELT = 0
                
            'Enregistre le coût mini si inférieure
                If (minligneelt + MINCOLELT) > most Then
                    most = minligneelt + MINCOLELT
                    r = I
                    c = j
                End If
            End If
        Next
    Next
End Function

Private Sub TxtVille_Change()
'Controle de la saisi des caractere dans le choix du nombre de ville
    If Not IsNumeric(TxtVille.Text) Then
        MsgBox "Doit être numérique !!!", vbCritical, "Erreur de saisie"
        'Nombrede ville négatif
        ElseIf Int(TxtVille.Text) < 0 Then
        MsgBox "Le nombre de ville ne doit pas étre négatif !!!", vbCritical, "Erreur de saisie"
            'Trop de ville
            ElseIf Int(TxtVille.Text) > 20 Then   'vérifi si la saisie est bonne
            MsgBox "Le nombre de ville doit etre inférieur à 20 !!!", vbCritical, "Erreur de saisie"
    End If
End Sub

Private Function reduction(ligne, col, ligned, colred, Matrice)
Dim I As Integer
Dim j As Integer
Dim RVALUE As Integer
Dim TEMP As Integer

'Soustraction de la plus petite valeur pour chaque ligne et pour chaque colonne
RVALUE = 0
  
    'REDUIT LES LIGNES
    For I = 1 To Taille
    TEMP = inf
        'Recherche la valeur minimun de la COLONNE
        For j = 1 To Taille
            TEMP = min(TEMP, Int(Matrice(ligne(I), col(j))))
        Next
        'Soustrait la valeur mini trouver a toute la COLONNE
        If TEMP > 0 Then
            For j = 1 To Taille
                If Matrice(ligne(I), col(j)) < inf Then
                Matrice(ligne(I), col(j)) = Matrice(ligne(I), col(j)) - TEMP
                End If
            Next
        RVALUE = RVALUE + TEMP
        End If
    ligneed(I) = TEMP
    Next
    
           
    'REDUIT LES COLONNES
    For j = 1 To Taille
    TEMP = inf
        'Recherche la valeur minimun de la LIGNE
        For I = 1 To Taille
         TEMP = min(TEMP, Matrice(ligne(I), col(j)))
        Next
        'Soustrait la valeur mini trouver a toute la LIGNE
        If TEMP > 0 Then
            For I = 1 To Taille
                If Matrice(ligne(I), col(j)) < inf Then
                Matrice(ligne(I), col(j)) = Matrice(ligne(I), col(j)) - TEMP
                End If
            Next
        RVALUE = RVALUE + TEMP
        End If
    colred(j) = TEMP
    Next

'Valeur total de la réduction qui est la longeur du chemin réduit
       reduction = RVALUE
If PasaPas = True Then ecriture (reduction)
End Function

'############################### Saisie texte ###################################
Private Sub Saisie_des_données()
Dim ligne, colonne As Integer
Dim v As String
 
For ligne = 1 To n 'Demmande le nom de ligne de chaque ville  à visiter
    lieu(ligne) = InputBox("Nom de la ville n° " & ligne, "Choix des villes", "Ville" & ligne)
Next

'Demmande les données de tps pour chaque ville à visiter
For ligne = 1 To n 'Pour chaque ville
   For colonne = 1 To n 'Pour chaque croissement en colonne
    'Si dans la matrice c'est deux villes différentes
    If ligne <> colonne Then
        'Vérifie la saisi des temps
        Do Until ok = True
            v = InputBox("Entrez le temps entre " & lieu(ligne) & " et " & lieu(colonne), "Choix des temps", Int(Rnd * 25))
            If IsNumeric(v) Then ok = True
        Loop
        ok = False
        'Chargement des valeurs
            Matrice(ligne, colonne) = v
    'si c'est les mêmes villes dans la matrice alors une valeur infinie
    Else
        Matrice(ligne, colonne) = 9999
    End If
  Next colonne
Next ligne

'Remplissage de la zone de texte
     ZoneTexte.Text = ZoneTexte.Text & vbCrLf & "L'ordre de passage dans les différentes villes est : " & vbCrLf
    For I = 1 To n - 1
     ZoneTexte.Text = ZoneTexte.Text & lieu(I) & " , "
    Next
    ZoneTexte.Text = ZoneTexte.Text & lieu(n) & vbCrLf & vbCrLf
    ZoneTexte.Text = ZoneTexte.Text & "Récapitulatif des temps : " & vbCrLf
    For ligne = 1 To n
       For colonne = 1 To n
           If ligne <> colonne Then
                ZoneTexte.Text = ZoneTexte.Text & lieu(ligne) & " à " & lieu(colonne) & " = " & Matrice(ligne, colonne) & vbCrLf
           End If
       Next colonne
    Next ligne

End Sub
Private Function resultat(route, Temps)
'Ecriture des résultats
Dim count As Integer
     ZoneTexte.Text = ZoneTexte.Text & vbCrLf & "Une solution proche de l'optimalité pour le voyageur est : " & vbCrLf
     For count = 1 To n
     ZoneTexte.Text = ZoneTexte.Text & lieu(route(count)) & " => "
     Next
     ZoneTexte.Text = ZoneTexte.Text & lieu(route(1)) & vbCrLf & vbCrLf & "La valeur optimale trouvée est : " & Temps & "."
End Function

Private Function ecriture(reduction)
'Ecriture des matrices intermédaires pour le mode PAS A PAS
Dim ligne, colonne As Integer
NumMatrice = NumMatrice + 1
ZoneTexte.Text = ZoneTexte.Text & vbCrLf & "Nouvelle matrice numéro : " & NumMatrice & vbCrLf
    For ligne = 1 To n
       For colonne = 1 To n
           If ligne <> colonne Then
            ZoneTexte.Text = ZoneTexte.Text & lieu(ligne) & " à " & lieu(colonne) & " = " & Matrice(ligne, colonne) & vbCrLf
           End If
       Next colonne
    Next ligne
ZoneTexte.Text = ZoneTexte.Text & "Réduction temporaire de : " & reduction & vbCrLf
End Function

'##################### EXEMPLE ################################
Public Sub Code_Exemple(lieu)
'Action lors du click sur le bouton de résolution d'un Exemple
Dim ligne, colonne As Integer
Dim v As String
Dim Ville_(5) As String
Dim Distance_(20) As String
Dim Matrice(1 To 5, 1 To 5) As Variant

    MsgBox "Le nombre de ville dans cette exemple est de 5.", vbOKOnly, "Introduction"
    ZoneTexte.Text = ""
    inf = 9999
    n = 5           'nombre de ville par défaut
    PasaPas = False

    'Nom des 5 Villes par défaut
    lieu(1) = "Paris"
    lieu(2) = "Toulouse"
    lieu(3) = "Rodez"
    lieu(4) = "Nimes"
    lieu(5) = "Bretz"
    'Chargement des valeurs
    Distance_(1) = 10
    Distance_(2) = 12
    Distance_(3) = 10
    Distance_(4) = 5
    Distance_(5) = 8
    Distance_(6) = 1
    Distance_(7) = 8
    Distance_(8) = 4
    Distance_(9) = 4
    Distance_(10) = 8
    Distance_(11) = 9
    Distance_(12) = 5
    Distance_(13) = 5
    Distance_(14) = 5
    Distance_(15) = 2
    Distance_(16) = 1
    Distance_(17) = 9
    Distance_(18) = 10
    Distance_(19) = 9
    Distance_(20) = 8
    v = 0
    
'Demmande les données de tps pour chaque ville à visiter
For ligne = 1 To 5          'Pour chaque ville
   For colonne = 1 To 5     'Pour chaque croissement en colonne
    'Si dans la matrice c'est deux villes différentes
    If ligne <> colonne Then
        'Chargement des valeurs
        v = v + 1
        Matrice(ligne, colonne) = Distance_(v)
    Else
    'si c'est les mêmes villes dans la matrice alors une valeur infinie
        Matrice(ligne, colonne) = 9999
    End If
  Next colonne
Next ligne

'Remplissage de la zone de texte
     ZoneTexte.Text = ZoneTexte.Text & vbCrLf & "L'ordre de passage dans les différentes villes est : " & vbCrLf
    For I = 1 To n - 1
     ZoneTexte.Text = ZoneTexte.Text & lieu(I) & " , "
    Next
    ZoneTexte.Text = ZoneTexte.Text & lieu(n) & vbCrLf & vbCrLf
    ZoneTexte.Text = ZoneTexte.Text & "Récapitulatif des temps : " & vbCrLf
    For ligne = 1 To n
       For colonne = 1 To n
           If ligne <> colonne Then
                ZoneTexte.Text = ZoneTexte.Text & lieu(ligne) & " à " & lieu(colonne) & " = " & Matrice(ligne, colonne) & vbCrLf
           End If
       Next colonne
    Next ligne

        Call recherche(n, inf, Matrice, route, Temps)
        Call resultat(route, Temps)

End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (didiwai)