Tri alphabetique rapide pour liste liee - radixsort linklist

Télécharger le projet
Commenter

Description

Test d'un algorithme de tri alphabétique pour liste liée. "RadixSort Linklist" en Anglais, puis à partir d'un seuil, passage à un algorithme de tri par Insertion.
Bonnes explication sur le principe utilisé : Le tri par base (ou tri radix) se trouve en français à l'adresse : http://fr.wikipedia.org/wiki/Tri_radix

Au lieu déplacer les chaines de caractères dans le tableau, cet algorithme ordonne les liens de la liste liée en utilisant le trie par base 'RadixSort'.
L'utilisation d'une liste liée permet de d'éliminer une boucle longue par rapport à l'algorithme classique à trois boucles. Inconvénient: Le code est plus complexe.
( Cf les deux algorithmes et le fichier de test avec 5150 mots dans le Zip joint.

Limitation : Les minuscules dont traitées comme des majuscules.
Tri respectant l'ordre ASCII. Ne respecte pas le standard ISO/CEI 14651.
Une table de correspondance 'LookUp' permet de changer l'ordre de tri.
Les caractères ASCII > 127 ne sont pas traités telles que Ö, Û etc..

Nota : Commentaires en anglais pour que mes copains anglophones puissent comprendre

Je suis intéressé par vos suggestions d'améliorations. Fill free to suggest all improvement you think of.

Source / Exemple : 


Attribute VB_Name = "Module1"
'---------------------------------------------------------------------------------------
' Module     : Module1    Version 12
' Author     : Jean-Louis Barre
' Date       : 25/03/2009
' Purpose    : This Module tests RadixSort LinkList algoritm
'            : Strings are not moved until it is all done
'            : usage of link list decreases the number of loops
'            : limit to capital letter. For all letters Loop_Count = 127
'            : http://fr.wikipedia.org/wiki/Tri_radix - tri par base
'---------------------------------------------------------------------------------------
 Option Explicit
 Option Compare Text
 Option Base 1

 Private Const Loop_Count = 60         ' only capital letter : Asc("Z") - Asc(" ")
 Private Const Stack_Size = 128        ' set by trial&error for 65530 string Stack_size needs is 82
 Private Const Threshold = 24          ' Threshold to switch from Radix to insertion sort

 Type PILE
    Head As Long                ' to point the head of same rk letter group
    Tail As Long                ' to point the tail of same rk letter group
    Cnt As Long                 ' to count string of same rk letter
    Rk As Byte                  ' to select letter position in the string
End Type

Type Record
    Prev As Long                ' to point at previous record
    Next As Long                ' to point at next record
End Type
 
Type Group
    First As Long             ' to point the first record of group of string with same letter in same position
    Last As Long              ' to point the tail of group of string with same letter in same position
    Cnt As Long               ' to count string with same letter in same position
End Type

Private LookUp As Variant
Private STACK(0 To Stack_Size) As PILE
Private StackPtr As Integer
Private Array_F() As Record
Private Grp_Array() As Group

'---------------------------------------------------------------------------------------
 Public Sub Test_RadixSort()
 Dim Dictionary As Variant, Sorted_Dictionary As Variant
 Dim Nb_Words_In_Array As Long, i As Long
 Dim List_Word() As String, Sorted_List() As String
        
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
  
    Nb_Words_In_Array = Range(Cells(1, 1), Cells(65536, 1).End(xlUp)).Rows.Count
    Set Dictionary = Range(Cells(1, 1), Cells(1 + Nb_Words_In_Array, 1))                 ' from Row 2 col 1 to last filled cells
    Set Sorted_Dictionary = Range(Cells(1, 2), Cells(1 + Nb_Words_In_Array, 2))         ' from Row 2 col 2 to last filled cells
 
    ReDim List_Word(Nb_Words_In_Array)         ' Could avoid by using : Dim Grp_Array(0 To Large-Constant)
    ReDim Sorted_List(Nb_Words_In_Array)         ' Could avoid by using : Dim Grp_Array(0 To Large-Constant)
    ReDim Grp_Array(0 To Loop_Count)
    
    For i = 1 To Nb_Words_In_Array
        List_Word(i) = Dictionary(i)                 ' read the list
    Next i
    Sort List_Word(), Sorted_List()
    For i = 1 To Nb_Words_In_Array
        Sorted_Dictionary(i) = Sorted_List(i)         ' write the result
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

 End Sub
'---------------------------------------------------------------------------------------
Sub Sort(ByRef List, ByRef Result_List)
Dim Nb_Words As Long, i As Long, Last_i As Long, This_Ptr As Long
Dim Index As Byte, Char As String
    LookUp = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 14, 60, 60, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 60, 60, 60, 60)
    Nb_Words = UBound(List)
    StackPtr = 1
     
    ReDim Array_F(0 To Nb_Words + 1)        ' Could avoid by using : Dim Grp_Array(0 To Large-Constant)
    ReDim Grp_Array(0 To Loop_Count)
 
'--------------- Initialize Link List ---------------------------
     For i = 1 To Nb_Words                   ' read in all words
        Char = Mid(List(i), 1, 1)
        If Char = "" Then Char = " "
        If Char = "-" Then Char = Mid(List(i), 2, 1)
        Index = LookUp(AscB(Char))      ' A=34, a=34
        If Grp_Array(Index).Cnt = 0 Then
            Grp_Array(Index).First = i
            Grp_Array(Index).Last = i
        Else
            Array_F(i).Prev = Grp_Array(Index).Last           'link same rank serie
            Array_F(Array_F(i).Prev).Next = i
            Grp_Array(Index).Last = i
        End If
        Grp_Array(Index).Cnt = Grp_Array(Index).Cnt + 1
    Next i
    Last_i = 0
    For i = 1 To Loop_Count
        With Grp_Array(i)
            If .Cnt > 0 Then                                    ' If sort is to be done next time
                Array_F(.First).Prev = Grp_Array(Last_i).Last    ' link both ends. Grp_Array(0).Last =0
                Array_F(Grp_Array(Last_i).Last).Next = .First    ' link both ends. initialize Array_F(Grp_Array(0).Last).Next
                Last_i = i                                        ' to take into account Cnt= 0 and cnt = 1
               If .Cnt > 1 Then
                   STACK(StackPtr).Head = .First                  ' put task on the Pile
                   STACK(StackPtr).Tail = .Last                   ' idea to explore : group is from head to tail exclusive of both ends ?
                   STACK(StackPtr).Cnt = .Cnt
                   STACK(StackPtr).Rk = 2
                  StackPtr = StackPtr + 1
               End If
            End If
       End With
    Next i
'
' link the last record to "next to tail end"
'
    Array_F(Grp_Array(Last_i).Last).Next = Grp_Array(Last_i).Last     ' set last record of the linklist

'--------------- Sort -----------------------------
    StackPtr = StackPtr - 1
    Do
        If STACK(StackPtr).Cnt > Threshold Then
            RadixSort STACK(StackPtr).Head, STACK(StackPtr).Tail, STACK(StackPtr).Cnt, STACK(StackPtr).Rk, List
        Else
            InsertionSort STACK(StackPtr).Head, STACK(StackPtr).Cnt, List
        End If
        StackPtr = StackPtr - 1                          ' Pop from the stack
    Loop Until StackPtr = 0
    
 '    Find first record
    This_Ptr = Array_F(0).Next
    For i = 1 To Nb_Words
        Result_List(i) = List(This_Ptr)                 ' write the result
        This_Ptr = Array_F(This_Ptr).Next               ' Following the sorted trail
    Next i

 End Sub
'---------------------------------------------------------------------------------------
' Procedure : RadixSort(ByVal Head As Long, ByVal Tail As Long, ByVal Count As Long, ByVal Rank As Byte, ByRef List() as string)
' Author     : Jean-Louis Barre
' Date       : 25/03/2009
' Purpose    : do a Radix sort at current rank and save on the stack Ptr and Cnt next rank sort
'---------------------------------------------------------------------------------------
Sub RadixSort(ByVal Head As Long, ByVal Tail As Long, ByVal Count As Long, ByVal Rank As Byte, List)
Dim i As Long, Last_i As Long, Index As Byte, Char As String
Dim Ptr_Cur As Long, Ptr_End As Long
    ReDim Grp_Array(0 To Loop_Count)

    Ptr_Cur = Head
    Grp_Array(0).Last = Array_F(Head).Prev              ' "previous of head"
    Ptr_End = Array_F(Tail).Next                        ' "next to tail"
'
' store Head record, last record , record count and link them all
'
    For i = 1 To Count
        With Array_F(Ptr_Cur)
        Char = Mid(List(Ptr_Cur), Rank, 1)
        If Char = "" Then Char = " "
        If Char = "-" Then Char = Mid(List(Ptr_Cur), Rank + 1, 1)
        Index = LookUp(AscB(Char))      ' A=34, a=34
            If Grp_Array(Index).Cnt = 0 Then
                Grp_Array(Index).First = Ptr_Cur
                Grp_Array(Index).Last = Ptr_Cur
            Else
                .Prev = Grp_Array(Index).Last           'link same rank serie
                Array_F(.Prev).Next = Ptr_Cur
                Grp_Array(Index).Last = Ptr_Cur
            End If
            Grp_Array(Index).Cnt = Grp_Array(Index).Cnt + 1
            Ptr_Cur = .Next                             ' follow the trail
        End With
    Next i
'
' link groups together. If needed, put task on the Pile for next turn
'
    Last_i = 0
    For i = 1 To Loop_Count
        With Grp_Array(i)
            If .Cnt > 0 Then                                    ' If sort is to be done next time
                Array_F(.First).Prev = Grp_Array(Last_i).Last    ' link both ends
                Array_F(Grp_Array(Last_i).Last).Next = .First    ' link both ends
                Last_i = i                                        ' to take into account Cnt= 0 and cnt = 1
               If .Cnt > 1 Then
                   STACK(StackPtr).Head = .First                  ' put task on the Pile
                   STACK(StackPtr).Tail = .Last                   ' idea to explore : group is from head to tail exclusive of both ends ?
                   STACK(StackPtr).Cnt = .Cnt
                   STACK(StackPtr).Rk = Rank + 1
                  StackPtr = StackPtr + 1
               End If
            End If
       End With
    Next i
'
' link the last record to "next to tail end"
'
    Array_F(Grp_Array(Last_i).Last).Next = Ptr_End                    ' link last record to "next to tail"
    Array_F(Ptr_End).Prev = Grp_Array(Last_i).Last
    
End Sub
'---------------------------------------------------------------------------------------
' Procedure : InsertionSort(ByRef First As Long, ByRef Cnt As Long,ByRef List() as string)
' Author    : Jean-Louis Barre
' Date      : 25/01/2009
' Purpose   : Sort a linklist array by insertion
'---------------------------------------------------------------------------------------
Sub InsertionSort(ByRef First As Long, ByRef Cnt As Long, List)
Dim i As Integer, j As Integer
Dim Ptr_Cur As Long, Ptr_Next As Long, Invariant As Long
Dim List_Ptr(1 To Threshold) As Long
Dim Max_Sorted As Integer

    Ptr_Cur = First
    For i = 1 To Cnt                            ' store the link List trail
        List_Ptr(i) = Ptr_Cur
        Ptr_Cur = Array_F(Ptr_Cur).Next
    Next i
    Invariant = Array_F(First).Prev             ' previous of First
    Max_Sorted = 0
    For i = 1 To Cnt
        Ptr_Cur = List_Ptr(i)
        Ptr_Next = Array_F(Invariant).Next      'always start from the linklist beginning
        With Array_F(Ptr_Cur)
            For j = 1 To Max_Sorted
                If List(Ptr_Next) >= List(Ptr_Cur) Then Exit For
                Ptr_Next = Array_F(Ptr_Next).Next      ' loop following the trail
            Next j
            If Ptr_Next <> Ptr_Cur And Ptr_Next <> Array_F(Ptr_Cur).Next Then    ' Else do nothing : it is already done !
'--------- Insert -----------------
                ' --- Cut the link
                With Array_F(Ptr_Cur)
                    Array_F(.Prev).Next = .Next
                    Array_F(.Next).Prev = .Prev
                End With
                ' --- Insert before Ptr_Next
                With Array_F(Ptr_Cur)
                    .Next = Ptr_Next
                    .Prev = Array_F(Ptr_Next).Prev
                End With
                With Array_F(Ptr_Next)
                    Array_F(.Prev).Next = Ptr_Cur
                    .Prev = Ptr_Cur
                End With
'-------------- Done ---------------
            End If
            Max_Sorted = Max_Sorted + 1
        End With
    Next i
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 (barjea17)