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
| ' Сортирует методом бинарных деревьев по колонке (строке) номер nSort
' многомерный массив: A(0..N-1) вектор или A(0..N-1,0..M-1) матрицу
' byRow - для матрицы важен - сортировать по столбцу ( строке ) номер nSort
' Возврат в функции False - если не массив; True - иначе
Public Function BTreeSort(ByRef A As Variant, _
Optional ByVal nSort As Long = 0, _
Optional ByVal byRow As Boolean = False) As Boolean
'< aDims(),TranspositionElement() >
Dim aDimsA As Long
Dim i As Long, t As Long, k As Long, n As Long, u As Variant, cmp As Boolean
aDimsA = aDims(A) ' число размерностей массива
If aDimsA = -1 Or aDimsA = 0 Then Exit Function ' -->>
If aDimsA = 1 Then byRow = False
n = UBound(A, IIf(Not byRow, 1, 2)) + 1 ' число строк или столбцов
For i = 2 To n
t = i
2:
If t <> 1 Then
k = Int(t / 2)
If aDimsA = 1 Then
cmp = A(k - 1) >= A(t - 1)
Else
If Not byRow Then
cmp = A(k - 1, nSort) >= A(t - 1, nSort)
Else
cmp = A(nSort, k - 1) >= A(nSort, t - 1) ' перестановка столбцов
End If
End If
If cmp Then
t = 1
Else
TranspositionElement A, k - 1, t - 1, aDimsA, byRow ' перестановка
t = k
End If
GoTo 2
End If
Next i
i = n - 1
3:
TranspositionElement A, i, 0, aDimsA, byRow ' перестановка
t = 1
4:
If t = 0 Then GoTo 5
k = 2 * t
If k > i Then
t = 0: GoTo 4
End If
If k < i Then
If aDimsA = 1 Then
If A(k) > A(k - 1) Then k = k + 1
Else
If Not byRow Then
If A(k, nSort) > A(k - 1, nSort) Then k = k + 1
Else
If A(nSort, k) > A(nSort, k - 1) Then k = k + 1 ' перестановка столбцов
End If
End If
End If
If aDimsA = 1 Then
cmp = A(t - 1) >= A(k - 1) ' перестановка
Else
If Not byRow Then
cmp = A(t - 1, nSort) >= A(k - 1, nSort) ' перестановка строк
Else
cmp = A(nSort, t - 1) >= A(nSort, k - 1) ' перестановка столбцов
End If
End If
If cmp Then
t = 0
Else
TranspositionElement A, k - 1, t - 1, aDimsA, byRow ' перестановка
End If
GoTo 4
5:
i = i - 1
If i >= 1 Then GoTo 3
BTreeSort = True
End Function ' BTreeSort -->>
' Переставляет элементы ( или строки или - forCol - столбцы ) I и J местами
' в непустом массиве A(0...,0...) размерности aDims=1 (или 2)
Public Function TranspositionElement(ByRef A As Variant, _
ByVal i As Long, ByVal j As Long, _
Optional ByVal aDims As Long = 1, _
Optional ByVal forCol As Boolean = False)
Dim u As Variant, z As Variant, k As Long
If aDims = 1 Then
u = A(i): A(i) = A(j): A(j) = u
Else
If Not forCol Then ' для строк
For k = 0 To UBound(A, 2)
u = A(i, k): A(i, k) = A(j, k): A(j, k) = u
Next k
Else ' для колонок
For k = 0 To UBound(A, 1)
u = A(k, i): A(k, i) = A(k, j): A(k, j) = u
Next k
End If
End If
End Function ' TranspositionElement -->>
' Возвращает число размерностей массива A
' 0 - массив не содержит элементов ; -1 - если A - не массив
Public Function aDims(ByRef A As Variant) As Long
Dim i As Long, j As Long
On Error GoTo OverFlow
aDims = -1
If Not IsArray(A) Then Exit Function
i = 1
Do While True
j = UBound(A, i)
i = i + 1
Loop
OverFlow: |
(
