0/5 (9 avis)
Vue 4 098 fois - Téléchargée 340 fois
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
24 mars 2009 à 09:13
http://www.vbfrance.com/code.aspx?ID=48709
j'ai pas grand chose a en dire
24 mars 2009 à 00:12
Quoi qu'il en soit je vous félicite pour ce code, et je vous envoi un fichier Excel qui permet de le comparer à quicksort, trifusion et ma procedure de tri que je nomme "Tri par vague"
Amicalement
20 mars 2009 à 08:14
lisant la description, je pensai à des pointeurs de chaine et non l'indice dans le tableau ^^
19 mars 2009 à 20:01
Effectivement " Utilisez une locution As type distincte pour chaque variable que vous déclarez."
19 mars 2009 à 19:46
Dim I, J, k as Long
seul k est de type Long (I et J sont de type Variant)
Si tu veux déclarer les trois variables en tant que Long il faut écrire :
Dim I as Long, J as Long, k as Long
++
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.