1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
'API pour calcul temps
Private Declare Function GetTickCount Lib "kernel32" () As Long
Public Function RunKthTests()
On Error GoTo catch
Const cLenArr As Long = 10 ^ 6 'Nombre d'éléments
Const cKth As Long = 10 ^ 3 'position de l'élément à récupérer : doit être >= 1 et <= cLenArr
Const cMaxVal As Double = 10 ^ 5 'Valeur maxi des éléments
Dim arr() As Double, arrsave() As Double, Res As Double
Dim i As Long, t0 As Long, t1 As Long
Randomize
ReDim arr(1 To cLenArr)
ReDim arrsave(1 To cLenArr)
For i = 1 To cLenArr
arr(i) = Rnd * cMaxVal
arrsave(i) = arr(i)
Next i
Debug.Print "go!"
t0 = GetTickCount
Res = QuickSelect(arr, cLenArr, cKth)
t1 = GetTickCount
Debug.Print "QuickSelect ", (t1 - t0) & " ms", Res
'tableau non modifié par QuickSelect
t0 = GetTickCount
Res = SelectSmallest(cKth, cLenArr, arr)
t1 = GetTickCount
Debug.Print "SelectSmallest", (t1 - t0) & " ms", Res
arr = arrsave 'restaure le tableau d'origine
t0 = GetTickCount
Res = findElementAtRank(arr, 1, cLenArr, cKth)
t1 = GetTickCount
Debug.Print "findElemAtRank", (t1 - t0) & " ms", Res
Exit Function
catch:
Debug.Print Err.Number, Err.Description
End Function
'Numerical Recipes In C - second edition - page 342
'Algo non récursif, tableau modifié
Private Function SelectSmallest(ByVal k As Long, ByVal n As Long, ByRef arr() As Double) As Double
Dim i As Long, ir As Long, j As Long, l As Long, mid As Long, l1 As Long
Dim a As Double, temp As Double
l = 1: l1 = 2: ir = n
While True
If ir <= l1 Then
If ir = l1 And arr(ir) < arr(l) Then temp = arr(l): arr(l) = arr(ir): arr(ir) = temp
SelectSmallest = arr(k): Exit Function
Else
mid = (l + ir) \ 2
temp = arr(l1): arr(l1) = arr(mid): arr(mid) = temp
If arr(l1) > arr(ir) Then temp = arr(l1): arr(l1) = arr(ir): arr(ir) = temp
If arr(l) > arr(ir) Then temp = arr(l): arr(l) = arr(ir): arr(ir) = temp
If arr(l1) > arr(l) Then temp = arr(l1): arr(l1) = arr(l): arr(l) = temp
i = l1: j = ir: a = arr(l)
Do While True
Do: i = i + 1: Loop While arr(i) < a
Do: j = j - 1: Loop While arr(j) > a
If j < i Then Exit Do
temp = arr(i): arr(i) = arr(j): arr(j) = temp
Loop
arr(l) = arr(j)
arr(j) = a
If j >= k Then ir = j - 1
If j <= k Then l = i: l1 = i + 1
End If
Wend
End Function
'http://www.rawkam.com/?p=870
'Algo récursif, tableau modifié
Public Function findElementAtRank(ByRef arr() As Double, ByVal low As Long, ByVal high As Long, ByVal rank As Long) As Double
Dim pivot As Long, l As Long, h As Long, temp As Double, valPivot As Double
pivot = low: l = low: h = high
If l <= h Then
valPivot = arr(pivot)
While l < h
While arr(l) <= valPivot: l = l + 1: Wend
While arr(h) > valPivot: h = h - 1: Wend
If l < h Then temp = arr(l): arr(l) = arr(h): arr(h) = temp
Wend
arr(pivot) = arr(h): arr(h) = valPivot
End If
If rank < h Then
findElementAtRank = findElementAtRank(arr, low, h - 1, rank)
ElseIf rank > h Then
findElementAtRank = findElementAtRank(arr, h + 1, high, rank)
Else: findElementAtRank = arr(h): End If
End Function
'http://pine.cs.yale.edu/pinewiki/QuickSelect
'Algo récursif, consomme mémoire, tableau non modifié
Public Function QuickSelect(ByRef arr() As Double, ByVal n As Long, ByVal k As Long) As Double
Dim se As Long, le As Long, i As Long
Dim pivot As Double, ase() As Double, ale() As Double
pivot = arr(Int(Rnd * n) + 1) 'Autre pivot ? pivot = arr((n + 1) \ 2)
ReDim ase(1 To n)
ReDim ale(1 To n)
For i = 1 To n
If arr(i) < pivot Then
se = se + 1
ase(se) = arr(i)
ElseIf arr(i) > pivot Then
le = le + 1
ale(le) = arr(i)
End If
Next i
If k <= se Then
Erase ale 'free mem
QuickSelect = QuickSelect(ase, se, k)
ElseIf k > n - le Then
Erase ase 'free mem
QuickSelect = QuickSelect(ale, le, k - n + le)
Else: QuickSelect = pivot: End If
End Function |
