Tri alphabetique rapide sur liste liee - radixsort on linklist

Télécharger le projet
Commenter

Description

Test d'un algorithme de Tri Alphabétique sur "liste liée". "RadixSort LINKEDLIST" en Anglais puis à partir d'un seuil, passage à un algorithme de tri par Insertion.
L'utilisation de liste Liée permet de supprimer une longue par itération du tri alphabétique "classique"

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
Explications sur Liste Liée "LinkList" : http://faq.vb.free.fr/index.php?question=160

Nota :
1 Commentaires en anglais pour que mes copains anglophones puissent comprendre
2 Je suis intéressé par les améliorations à faire. Please suggest further improvement.

Source / Exemple : 


Attribute VB_Name = "Module1"
'---------------------------------------------------------------------------------------
' Module     : Module1    Version 10
' 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 = 256        ' set by trial&error for 65530 string Stack_size needs is 82
 Private Const Threshold = 16                  ' 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
    Content As String           ' To store string
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 STACK(0 To Stack_Size) As PILE
Private StackPtr As Integer
Private Array_F() As Record

'---------------------------------------------------------------------------------------
 Public Sub Test_Radix()
 Dim Dictionary As Variant, Sorted_Dictionary As Variant
 Dim Grp_Array(0 To Loop_Count)
 Dim i As Long,This_Ptr As Long, Nb_Words_In_Array As Long
        
    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
    
    ' store all words in array
     ReDim Array_F(0 To Nb_Words_In_Array + 1)        ' Could avoid by using : Dim Grp_Array(0 To Large-Constant)

     For i = 1 To Nb_Words_In_Array                   ' read in all words
          Array_F(i).Content = Dictionary(i)           ' save all string in an array for speed
          Array_F(i).Next = i + 1                     ' save inital position of each string in the array
          Array_F(i).Prev = i - 1                      ' This is the initial link list
     Next i
    
     StackPtr = 1
     With STACK(StackPtr)                              ' initial sort : all array, letter 1
          .Head = 1                                     ' from 1
          .Tail = 0                                     ' flag it for initial call
          .Cnt = Nb_Words_In_Array                      ' to last string
          .Rk = 1                                       ' letter 1 (from left)
     End With
    
    Do
        If STACK(StackPtr).Cnt > Threshold Then
            RadixSort STACK(StackPtr).Head, STACK(StackPtr).Tail, STACK(StackPtr).Cnt, STACK(StackPtr).Rk
        Else
            InsertionSort STACK(StackPtr).Head, STACK(StackPtr).Cnt
        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_In_Array
        Sorted_Dictionary(i) = Array_F(This_Ptr).Content    ' write the result
        This_Ptr = Array_F(This_Ptr).Next                   ' Following the sorted trail
    Next i
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic

 End Sub
'---------------------------------------------------------------------------------------
' Procedure : Radix
' 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, ByRef Count As Long, ByRef Rank As Byte)
Dim i As Long, Last_i As Long, Index As Byte
Dim Ptr_Cur As Long, Ptr_End As Long
Dim Grp_Array(0 To Loop_Count) As Group
    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)
            Index = Radix_String(.Content, Rank)
            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"
'
     If Tail = 0 Then                                                       ' Flag initial call 
          Array_F(Grp_Array(Last_i).Last).Next = Grp_Array(Last_i).Last     ' set last record of the linklist
     Else
          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 If
    
End Sub
'---------------------------------------------------------------------------------------
' Procedure : InsertionSort (Byval Ptr,Byval Cnt)
' 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)
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 Array_F(Ptr_Next).Content >= .Content 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

'---------------------------------------------------------------------------------------
' Function  : Radix_String
' Author     : Jean-Louis Barre
' Date        : 05/10/2008
' Purpose    : Give  index of the nth letter of the string
'---------------------------------------------------------------------------------------
Private Function Radix_String(Content, nth) As Byte
Dim i As Byte
    If Len(Content) < nth Then
        Radix_String = 1
    Exit Function
    End If
  '--- ( Asc( )=32 Asc(A)=65 Asc(Z)=90 Asc(a)=97 Asc(z)=122)---
    i = Asc(Mid(Content, nth, 1))
    Select Case i
        Case Is < 32 '--- before Space
            Radix_String = 1
            Exit Function
        Case 97 To 122 '--- a To z ---
            Radix_String = i - 63 ' a=34
            Exit Function
        Case Is > 90
            Radix_String = 60
            Exit Function
    End Select
    Radix_String = i - 31 ' A=34
End Function
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)