Comparaison des mthodes de tri : Quick, Shell, Bubble et Selection 
S'applique : VB3, VB4-16, VB4-32, VB5, VB6  

 

 Prrequis 
  
Rien. 

--------------------------------------------------------------------------------
 

Cette application se compose en 2 parties - la premire, une simple comparaison de tri avec 30 elements, et la seconde plus sur la vitesse de tri entre les 4 mthodes prsents.

J'ai ajout du code pour afficher le numro actuel de fois que la routine changait des valeurs; ce code est comment et doit tre enlev pour chaque implmentation de n'importe quel mthode de tri ici prsente.

En complment,  cause du temps exorbitant pris par les methodes Bubble et Selection, j'ai ajout des boutons "Passer" pour passer cet aspect de test de vitesse.
 

 

 Cration du formulaire de dmonstration 
  
Comme le formulaire est assez complexe, j'ai essay de disposer les controles de manire logique.   Ajouter un nouveau formulaire  votre projet et dfinisez ce qui suit: 
xStart est un nouveau projet, et ajouter les controles qui suivent dans le formulaire :

Contrle      Etat       Nom      Titre (Caption)
Command      Enabled    cmdEnd     Quitter
Frame        Enabled    Frame1     Tri de 30 elements alatoires
Frame        Enabled    Frame2     Comparaison de vitesse
Frame        Enabled    Frame3     Comparaison d'Iterations
Timer        Disabled   timSpeedTest

Dans la Frame1 placez:
Label        Enabled    Label2         non-tri:
Label        Enabled    Label3         tri:
Label        Enabled     lblOriginElements    
Label        Enabled     lblSortedElements
Command      Enabled    cmdSort(0)     Tri Bubble
Command      Enabled    cmdSort(1)     Tri Selection
Command      Enabled    cmdSort(2)     Tri Shell
Command      Enabled    cmdSort(3)     Tri Quick

Dans la Frame2 placez:
Label        Enabled    Label6                 Nombre lments alatoires:
Label        Enabled     lblSortTimeReport(0)  Le Tri Bubble a dure: xxxx
Label        Enabled     lblSortTimeReport(1)  Le Tri Selection a dure: xxxx
Label        Enabled     lblSortTimeReport(2)  Le Tri Shell a dure: xxxx
Label        Enabled     lblSortTimeReport(3)  Le Tri Quick a dure: xxxx
Label        Enabled     lblSpeedTestStatus    Prt lancer le test
Label        Enabled    lblStatus              Vitesse du Test:
Textbox      Enabled    txtNumberOfElements    1000
Command      Enabled    cmdSpeedTest           Test de vitesse
Command      Enabled    cmdSkipBubbleSort      Passer
Command      Enabled    cmdSkipSelectionSort   Passer

Dans la Frame3 placez:
Label        Enabled    lblIterations(0)     Iterations:
Label        Enabled    lblIterations(1)     Iterations:
Label        Enabled    lblIterations(2)     Iterations:
Label        Enabled    lblIterations(3)     Iterations:
Label        Enabled    lblIterations(4)     Iterations:
 

--------------------------------------------------------------------------------
 

Public Sub vbQuickSort(vArray As Variant, l As Integer, r as Integer)   
      
    Dim i As Integer
    Dim j As Integer
    Dim X
    Dim Y
  
    i = l
    j = r
    X = vArray((l + r) / 2)
  
    While (i <= j)
  
        While (vArray(i) < X And i < r)
            i = i + 1
        Wend
    
        While (X < vArray(j) And j > l)
            j = j - 1
        Wend

        If (i <= j) Then
            Y = vArray(i)
            vArray(i) = vArray(j)
            vArray(j) = Y
            i = i + 1
            j = j - 1
        End If
  
    Wend
  
    If (l < j) Then vbQuickSort vArray, l, j
    If (i < r) Then vbQuickSort vArray, i, r
  
    frmSorts.lblIterations(3) = "La procdure a t appele : " & QSCallCnt & " fois"
    frmSorts.lblIterations(4) = "Elements changs : " & QSSwaps

End Sub
'--fin de bloc--'
   

 Code du Module BAS  
  
Ajoutez les 4 routines suivantes au module BAS: 

--------------------------------------------------------------------------------
 

Option Explicit

'variables pour les itrations du tri Quick
Public QSCallCnt As Integer
Public QSSwaps As Integer

'variable pour le tri Bubble pour l'on puisse
'sortir de la procedure par abandon
Public Bcnt As Long

'variable pour le tri Selection pour l'on puisse
'sortir de la procedure par abandon
Public SScnt As Long

'utlis pour abandonner les tri trop longs
Public SkipFlag As Integer


Public Sub BubbleSortNumbers(iArray As Variant)

    Dim lLoop1 As Long
    Dim lLoop2 As Long
    Dim lTemp As Long
    
    frmSorts.lblIterations(0) = "En cours..."
    
    For lLoop1 = UBound(iArray) To LBound(iArray) Step -1
      
        For lLoop2 = LBound(iArray) + 1 To lLoop1
        
          If iArray(lLoop2 - 1) > iArray(lLoop2) Then
              lTemp = iArray(lLoop2 - 1)
              iArray(lLoop2 - 1) = iArray(lLoop2)
              iArray(lLoop2) = lTemp
              
             '-----------------------------
             'Necessaire pour le test de vitesse;
             'Met  jour le label des iterations
              Bcnt = Bcnt + 1
              DoEvents
              If SkipFlag% Then Exit Sub
             '----------------------------
              
          End If
        
        Next lLoop2
    
    Next lLoop1
            
    frmSorts.lblIterations(0) = "Elments changs : " & Bcnt
  
End Sub


Public Sub SelectionSortNumbers(vArray As Variant)
  
    Dim lLoop1 As Long
    Dim lLoop2 As Long
    Dim lMin As Long
    Dim lTemp As Long
    
    frmSorts.lblIterations(1) = "En cours..."
    
    For lLoop1 = LBound(vArray) To UBound(vArray) - 1
    
        lMin = lLoop1
        
        For lLoop2 = lLoop1 + 1 To UBound(vArray)
        
            If vArray(lLoop2) < vArray(lMin) Then
              lMin = lLoop2
            
              '---------------------------
              'Met  jour le label des iterations
                SScnt = SScnt + 1
              '----------------------------
            
            End If
            
          '-----------------------------
          'Necessaire pour le test de vitesse;
          'Met  jour le label des iterations
           If SkipFlag Then Exit Sub
          '-----------------------------
         
        Next lLoop2
        
        lTemp = vArray(lMin)
        vArray(lMin) = vArray(lLoop1)
        vArray(lLoop1) = lTemp
      
    Next lLoop1
  
    frmSorts.lblIterations(1) = "Elments changs : " & SScnt
  
End Sub


Public Sub ShellSortNumbers(vArray As Variant)
    
    Dim lLoop1 As Long
    Dim lHold As Long
    Dim lHValue As Long
    Dim lTemp As Long
        
    Dim SHcnt As Integer
        
    frmSorts.lblIterations(2) = "En cours..."
    
    lHValue = LBound(vArray)
    
    Do
        lHValue = 3 * lHValue + 1
    Loop Until lHValue > UBound(vArray)
      
    Do
        lHValue = lHValue / 3
        
        For lLoop1 = lHValue + LBound(vArray) To UBound(vArray)
        
            lTemp = vArray(lLoop1)
            lHold = lLoop1
            
            Do While vArray(lHold - lHValue) > lTemp
                vArray(lHold) = vArray(lHold - lHValue)
                lHold = lHold - lHValue
                
                 '-----------------------------
                 'Necessaire pour le test de vitesse;
		 'Met  jour le label des iterations
                  SHcnt = SHcnt + 1
                  DoEvents
                 '-----------------------------
                
                If lHold < lHValue Then Exit Do
            
            Loop
            
            vArray(lHold) = lTemp
        
        Next lLoop1
      
    Loop Until lHValue = LBound(vArray)
    
  frmSorts.lblIterations(2) = "Elments changs : " & SHcnt

End Sub


Public Sub QuickSortNumbers(iArray As Variant, l As Long, r As Long)
   'iArray()            Le iArray du tri
   'l                  Premier lment de iArray pour commencer le tri
   'r                  Dernier lment de iArray pour commencer le tri
      
   '----------------------------------------------------
   'Met  jour l'appel au label compteur
    QSCallCnt = QSCallCnt + 1
   '----------------------------------------------------
  
    Dim X As Long
    
    Dim Y As Long
    Dim i As Long
    Dim j As Long
    
    i = l
    j = r
    X = iArray((l + r) / 2)
  
    While (i <= j)
  
        While (iArray(i) < X And i < r)
            i = i + 1
        Wend
    
        While (X < iArray(j) And j > l)
            j = j - 1
        Wend

        If (i <= j) Then
            Y = iArray(i)
            iArray(i) = iArray(j)
            iArray(j) = Y
            i = i + 1
            j = j - 1
            
           '----------------------------
           'Met  jour le label compteur d'change ; 
            QSSwaps = QSSwaps + 1
           '---------------------------
        End If
  
    Wend
  
    If (l < j) Then QuickSortNumbers iArray, l, j
    If (i < r) Then QuickSortNumbers iArray, i, r
  
    frmSorts.lblIterations(3) = "La procedure a t appel : " & QSCallCnt & " fois"
    frmSorts.lblIterations(4) = "Elments changs : " & QSSwaps

End Sub
'--fin de bloc--'
   

 Code du Formulaire 
  
Ajouter ce qui suit dans le code du formulaire: 

--------------------------------------------------------------------------------
 

Option Explicit

Dim tmrCounter As Long    'Utilis comme compteur pour le test de vitesse
Dim sortMethod As Integer 'drapeau pour le timer

Private Sub cmdSort_Click(Index As Integer)

'Dans cet exemple nous faisons un tableau de 15 lments et
'on place les dispose de manire alatoire. la chaine est alors
'affiche  l'cran. Le tableau est pass  la procedure appelle
'BubbleSortNumbers dans le module du projet et il permet un tri
'Selection. Ensuite on raffiche les lments tris  l'cran.

    Dim lMyArray(0 To 30) As Long
    Dim iLoop As Integer
    Dim sBuiltString As String
    
    Randomize
    
    For iLoop = LBound(lMyArray) To UBound(lMyArray)
        lMyArray(iLoop) = Int(Rnd * 9) + 1
        sBuiltString = sBuiltString & " " & lMyArray(iLoop)
    Next iLoop
    
    lblOriginElements = sBuiltString
    sBuiltString = ""
        
    Select Case Index
        Case 0
            Bcnt = 0
            Call BubbleSortNumbers(lMyArray)
        Case 1
            Call SelectionSortNumbers(lMyArray)
        Case 2
            Call ShellSortNumbers(lMyArray)
        Case 3
            QSCallCnt = 0
            Call QuickSortNumbers(lMyArray, 0, UBound(lMyArray))
    End Select
        
    For iLoop = LBound(lMyArray) To UBound(lMyArray)
        sBuiltString = sBuiltString & " " & lMyArray(iLoop)
    Next iLoop
    
    lblSortedElements = sBuiltString
    
End Sub


Private Sub cmdEnd_Click()
    
    Unload Me
    
End Sub


Private Sub cmdSkipBubbleSort_Click()

    SkipFlag% = True

End Sub

Private Sub cmdSkipSelectionSort_Click()

  SkipFlag% = True

End Sub


Private Sub cmdSpeedTest_Click()

    Dim lMyArray() As Long
    ReDim lMyArray(0 To CLng(txtNumberOfElements - 1))
    
    Dim i As Integer
    Dim X As Integer
    
    Dim vTemp1 As Variant
    Dim vTemp2 As Variant
    Dim vTemp3 As Variant
    
    Randomize
    tmrCounter = 0
    
    lblSpeedTestStatus.Caption = "Construction d'un tableau de " & _
                                  txtNumberOfElements & " _
                                  Elments ........."
    
    For i = LBound(lMyArray) To UBound(lMyArray)
        lMyArray(i) = Int(Rnd * 100) + 1
    Next i
    
    vTemp1 = lMyArray
    vTemp2 = lMyArray
    vTemp3 = lMyArray
    
    Frame1.Enabled = False
    GoTo doshell
   '---------------------------------
    SkipFlag% = False
    cmdSkipBubbleSort.Enabled = True
    
    sortMethod = 1
    Bcnt = 0
    
    frmSorts.timSpeedTest.Enabled = True
    lblSpeedTestStatus.Caption = "Tri Bubble en cours ......"
    
    Call BubbleSortNumbers(lMyArray)
    lblSortTimeReport(0).Caption = "Le tri Bubble a dur : " & tmrCounter & " secondes"
    timSpeedTest.Enabled = False
    
    frmSorts.lblIterations(0) = "Elments changs : " & Bcnt
    
    tmrCounter = 0
    cmdSkipBubbleSort.Enabled = False
   
   '---------------------------------
    SkipFlag% = False
    cmdSkipSelectionSort.Enabled = True
    
    sortMethod = 2
    SScnt = 0
    
    frmSorts.timSpeedTest.Enabled = True
    lblSpeedTestStatus.Caption = "Tri Selection en cours ......"
    
    Call SelectionSortNumbers(vTemp1)
    lblSortTimeReport(1).Caption = "Le tri Selection a dur : " & tmrCounter & " secondes"
    timSpeedTest.Enabled = False
    
    frmSorts.lblIterations(1) = "Elments changs : " & SScnt
    
    tmrCounter = 0
    cmdSkipSelectionSort.Enabled = False
   
   '---------------------------------
doshell:
    sortMethod = 3
    frmSorts.timSpeedTest.Enabled = True
    lblSpeedTestStatus.Caption = "Tri Shell en cours ......"
    
    Call ShellSortNumbers(vTemp2)
    lblSortTimeReport(2).Caption = "Le tri Shell  dur : " & tmrCounter & " secondes"
    timSpeedTest.Enabled = False
    tmrCounter = 0
   
   '---------------------------------
    frmSorts.lblIterations(3) = "En cours..."
  
    sortMethod = 4
    frmSorts.timSpeedTest.Enabled = True
    lblSpeedTestStatus.Caption = "Tri Shell en cours......"
    
    Call QuickSortNumbers(vTemp3, 0, UBound(vTemp3))
    lblSortTimeReport(3).Caption = "Le tri Quick a dur : " & tmrCounter & " secondes"
    timSpeedTest.Enabled = False
    
    lblSpeedTestStatus.Caption = "Test de vitesse termin......"
    
   '---------------------------------
    
    Frame1.Enabled = True
    
End Sub


Private Sub Form_Unload(Cancel As Integer)

  Set Form1 = Nothing

End Sub


Private Sub timSpeedTest_Timer()

    tmrCounter = tmrCounter + 1
    
    If sortMethod = 1 Then
        lblSortTimeReport(0).Caption = _
           "Le tri Bubble a dur : " & tmrCounter & " secondes"
    End If
    
    If sortMethod = 2 Then
        lblSortTimeReport(1).Caption = _
           "Le tri Selection a dur : " & tmrCounter & " secondes"
    End If
    
    If sortMethod = 3 Then
        lblSortTimeReport(2).Caption = _
           "Le tri Shell a dur : " & tmrCounter & " secondes"
    End If

    If sortMethod = 4 Then
        lblSortTimeReport(2).Caption = _
           "Le tri Quick a dur : " & tmrCounter & " secondes"
    End If

End Sub
'--fin de bloc--'
   

 Commentaires 
  
Lancez l'application, et cliquez sur le bouton de commande. Notepad est lanc, et quand il se ferme, la boite de message s'affiche. 

--------------------------------------------------------------------------------
 
