Оптимизация алгоритма сортировки Шелла. , Visual Basic v.6.0.

[Сергей85]

Практика показала на частном массиве с хаотичными числами (65000 значений) увеличение скорости сортировки в 100-200 раз,в сравнении с пузырьковой. Пусть, это частный случай - но перспектива имеет место быть.

Можно ли оптимизировать данный код-реализацию сортировки Шелла на VB6?

Нужен ли вообше Doevents? Перефразируя: если метод Шелла настолько быстр - нужна ли вообще индикация? В моем случае я даже отмену нажать не успеваю - сортировка пролетает в миг. Причем дважды: сначала от меньшего к большему сортирую, а потом результат сортирую в обратную сторону.

Нужно ли дублирование кода при такой бешеной скорости (разбиение на направления сортировки). Может, просто в цикле If поставить, каждый раз проверяющий bDirection?

Private Function vSort_Array(ByRef dArray() As Double, bDirection As Boolean, sMessage As String)
1 On Error GoTo ErrorHandler
 
2 Dim iStep As Integer 'Текущий шаг для сортировки вставкой.
3 Dim dTemp As Double 'Временная переменная для хранения значения вставки.
4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
 
'Избыток кода - для увеличения быстродействия.
5 If bDirection = True Then 'Сортировка от меньшего к большему.
    iStep = Int((UBound(dArray)) / 2) 'Работает и в случае нечетной размерности массива.
    
    While iStep >= 1
        If g_bCancel = True Then Exit Function 'Прерывание сортировки.
        
        DoEvents
        Label_Process.Caption = "Расчет параллельных соединений (в омах): " & UBound(dArray) - iStep & " / " & UBound(dArray)
        
        For i = 0 To iStep
            For j = i + iStep To UBound(dArray) Step iStep
                dTemp = dArray(j)
                
                For k = j - iStep To 0 Step -iStep
                    If dTemp >= dArray(k) Then GoTo insert1
                    dArray(k + iStep) = dArray(k)
                Next k
 
insert1:         dArray(k + iStep) = dTemp
            Next j
        Next i
        
        iStep = Int(iStep / 2)
    Wend
17 ElseIf bDirection = False Then 'Сортировка от большего к меньшему.
    iStep = Int((UBound(dArray)) / 2) 'Работает и в случае нечетной размерности массива.
    
    While iStep >= 1
        If g_bCancel = True Then Exit Function 'Прерывание сортировки.
        
        DoEvents
        Label_Process.Caption = "Расчет параллельных соединений (в омах): " & UBound(dArray) - iStep & " / " & UBound(dArray)
 
        For i = 0 To iStep
            For j = i + iStep To UBound(dArray) Step iStep
                dTemp = dArray(j)
                
                For k = j - iStep To 0 Step -iStep
                    If dTemp < dArray(k) Then GoTo insert2
                    dArray(k + iStep) = dArray(k)
                Next k
 
insert2:         dArray(k + iStep) = dTemp
            Next j
        Next i
        
        iStep = Int(iStep / 2)
    Wend
32 End If
    
1000000 Exit Function
ErrorHandler:
1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции vSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
End Function

Добавлено 20.01.17, 11:13
Конструкция "If (dTemp >= dArray(k) And bDirection = True) Or (dTemp < dArray(k) And bDirection = False) Then GoTo insert1" не привела к уменьшению быстродействия. Вероятно уменьшение на 10% - но заметить такое сложно.

Сообщение отредактировано: Сергей85 - 20.01.17, 11:28

[Akina]

Цитата Сергей85 @ 20.01.17, 11:08

В моем случае я даже отмену нажать не успеваю - сортировка пролетает в миг.

Увеличьте массив в 100 раз.

[Сергей85]

Итак, пока 3 изменения:
- "If dTemp >= dArray(k) Then GoTo insert1" заменить на "If dTemp >= dArray(k) Then Exit For";
- iStep сменить на тип double, чтобы не было переполнения в массивах с размерностью >50млн значений;
- вместо задвоения кода использовать конструкцию "If (dTemp >= dArray(k) And bDirection = True) Or (dTemp < dArray(k) And bDirection = False) Then".

Сообщение отредактировано: Сергей85 - 20.01.17, 14:43

[VisualProg]

Цитата

'Избыток кода - для увеличения быстродействия.

Всё это легко можно было бы убрать, если бы в VB можно было передавать указатели на функции:

Function PositiveDirection(ByRef Value1 as Double, ByRef Value2 as Double) as Boolean
 PositiveDirection = Value1 >= Value2
End Function
 
Function NegativeDirection(ByRef Value1 as Double, ByRef Value2 as Double) as Boolean
 NegativeDirection = Value1 < Value2
End Function

соответственно, код уменьшается в 2 раза:

    Private Function PositiveDirection(ByRef Value1 as Double, ByRef Value2 as Double) as Boolean
     PositiveDirection = Value1 >= Value2
    End Function
 
    Private Function NegativeDirection(ByRef Value1 as Double, ByRef Value2 as Double) as Boolean
     NegativeDirection = Value1 < Value2
    End Function
 
    Private Function vSort_Array(ByRef dArray() As Double, ByRef bDirection As Function, sMessage As String)
    1 On Error GoTo ErrorHandler
    
    2 Dim iStep As Integer 'Текущий шаг для сортировки вставкой.
    3 Dim dTemp As Double 'Временная переменная для хранения значения вставки.
    4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
    
        iStep = Int((UBound(dArray)) / 2) 'Работает и в случае нечетной размерности массива.
    
        While iStep >= 1
            If g_bCancel = True Then Exit Function 'Прерывание сортировки.
    
            DoEvents
            Label_Process.Caption = "Расчет параллельных соединений (в омах): " & UBound(dArray) - iStep & " / " & UBound(dArray)
    
            For i = 0 To iStep
                For j = i + iStep To UBound(dArray) Step iStep
                    dTemp = dArray(j)
    
                    For k = j - iStep To 0 Step -iStep
                        If bDirection(dTemp,dArray(k)) Then GoTo insert1
                        dArray(k + iStep) = dArray(k)
                    Next k
    
    insert1:         dArray(k + iStep) = dTemp
                Next j
            Next i
    
            iStep = Int(iStep / 2)
        Wend
    
    1000000 Exit Function
    ErrorHandler:
    1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции vSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
    End Function

Сейчас VB6.0 не помню, и не уверен что подобное в нём когда нибудь было...

Во всяком случае, от злосчастного GoTo вы в силах избавиться, не понимаю зачем вы его тут таскаете...

[Akina]

Цитата VisualProg @ 20.01.17, 13:30

Всё это легко можно было бы убрать, если бы в VB можно было передавать указатели на функции:

Да не вопрос - оформи их как методы класса и CallByName.

[Сергей85]

Результаты после оптимизации:

Для 65536 чисел. Пузырьковая: упорядочить рэндомный массив - 92с, инвертировать упорядоченный массив - 127с. Шелла: упорядочить рэндомный массив - менее 1с, инвертировать упорядоченный массив - менее 1с.

Для 262114 чисел. Пузырьковая: упорядочить рэндомный массив - 1460c, инвертировать упорядоченный массив - 2046c. Шелла: упорядочить рэндомный массив - 3с, инвертировать упорядоченный массив - менее 1с. Сто-тысячекратное увеличение скорости. Можно использовать метод Шелла для инверсии больших массивов без циклического перебора элементов.

Добавлено 20.01.17, 16:00
Сортируемый массив:
- одномерный;
- double;
- дробные числа с 14 знаками после запятой;
- рэндомные номиналы;
- 2:16 чисел (65536) и для подтверждения 2^18 чисел (262144).

Условия тестирования: без дебаггера (отдельный EXE-файл), процессу полностью отдано свободное ядро процессора, программная индикация времени запуска и окончания сортировки, отключен DoEvents, приоритет реального времени.

Добавлено 20.01.17, 16:01
Стократные увеличения скорости, по сравнению с пузырьковой, подтвердились повторно.

Добавлено 20.01.17, 16:02
Да тут уже речь о тысячекратных идет...

Добавлено 20.01.17, 16:12
Кажется, еще оптимизировать можно (НЕ УВЕРЕН, ПОСМОТРИТЕ):

"If dTemp >= dArray(k) Then GoTo insert1" - здесь равно, вроде, не нужно.

Сообщение отредактировано: Сергей85 - 20.01.17, 17:43

[Сергей85]

Равно не нужно.

Добавлено 20.01.17, 17:39
Итоговый вариант:

Private Function vSort_Array(ByRef dArray() As Double, bDirection As Boolean, sMessage As String) 'Сортировка методом Шелла - самая быстрая из сортировок рэндома.
1 On Error GoTo ErrorHandler
 
2 Dim dStep As Double 'Текущий шаг для сортировки вставкой.
3 Dim dTemp As Double 'Временная переменная для хранения значения вставки.
4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
 
dStep = Int((UBound(dArray)) / 2) 'Работает и в случае нечетной размерности массива.
    
While dStep >= 1
    If g_bCancel = True Then Exit Function 'Прерывание сортировки.
        
    DoEvents
    Label_Process.Caption = "Расчет параллельных соединений (в омах): " & UBound(dArray) - dStep & " / " & UBound(dArray)
        
    For i = 0 To dStep
        For j = i + dStep To UBound(dArray) Step dStep
            dTemp = dArray(j)
                
            For k = j - dStep To 0 Step -dStep
                If (dTemp > dArray(k) And bDirection = True) Or (dTemp < dArray(k) And bDirection = False) Then Exit For
                dArray(k + dStep) = dArray(k)
            Next k
 
            dArray(k + dStep) = dTemp
        Next j
    Next i
      
    dStep = Int(dStep / 2)
Wend
    
1000000 Exit Function
ErrorHandler:
1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции vSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
End Function

Добавлено 20.01.17, 17:55
Кажется, этот алгоритм можно дальше оптимизировать. Ввести, к примеру, начальный элемент массива и конечный - и чтобы сортировка шла только в этом диапазоне.

[Akina]

Жутик...

1) Модификатор ByRef в параметрах избыточен, массивы в принципе не передаются по значению.
2) В обработчике ошибок фактически игнорируется runtime error 364 (object was unloaded). Можно полюбопытствовать, в каком месте ожидается эта ошибка, причём так, что она считается сравнительно легитимной? во всяком случае достаточно легитимной для прерывания процедуры без какого-либо уведомления...
3) Вам не кажется, что самыми-самыми требующими точной идентификации места ошибками считать крайне маловероятные ошибки определения переменных не совсем правильно? Это я о метках-номерах строк, ежели что.
4) Обработчик ошибок следует завершать оператором Resume [label].
5) Переменные типа Double, используемые только как целочисленные итераторы циклов - более чем странно...
6) DoEvents на КАЖДОМ витке цикла? мы сортируем или очередь сообщений чистим?

[leo]

Цитата Сергей85 @ 20.01.17, 13:14

- вместо задвоения кода использовать конструкцию "If (dTemp >= dArray(k) And bDirection = True) Or (dTemp < dArray(k) And bDirection = False) Then".

Это условие эквивалентно If bDirection Xor (dTemp < dArray(k)) Then

[Сергей85]

Цитата Akina @ 20.01.17, 20:47

1. Вы это знаете; остальные это не увидели. Можно считать это дополнительным комментарием к входящим переменным.
2. Обработчик ошибок - унифицированный, с учетом возникающих ошибок прошлого. Я его тупо копипастю из функции в функцию без изменений.
3. Мне не проблема пронумеровать всё.
4. Что за Resume [label]? Зачем это нужно? И так все работает.
5. dStep, если Int, переполняется при 262000 размере массива. Максимальная размерность массива (сумма по всем направлениям) - 50102267;
6. Сообщений будет немного: степень двойки. Зато отчетливо видно его работу на больших размерностях.

Добавлено 21.01.17, 07:53
Ааа. Я в этой версии не пронумеровал до конца еще. Ну, это мелочи.

Сообщение отредактировано: Сергей85 - 21.01.17, 07:53

[Сергей85]

Цитата leo @ 21.01.17, 06:51

Уже нет. Я равно убрал. Правда, сейчас обсуждаем вопрос скорости вашего предложения. Может, можно пожертвовать операциями с "=", если XOR много быстрее.

[Сергей85]

Вот блин. Xor быстрее. Для 3 массивов с 16 миллионами значений получены результаты:
- без Xor: 9:56, 1:05, 1:07;
- с Xor (несмотря на возвращение ">=" в строку сравнения): 6:49, 48, 49.

[Сергей85]

Еще допилил.

Стандартная сортировка Шелла была доработана так, что реализует:
- быструю сортировку по Шеллу;
- возможность ускоряться или работать без зависания ПО и возвращая время сортировки;
- сортировать любую часть массива, а не только массив целиком;
- сортировать синхронно два массива сразу.

Private Function lSort_Array(ByRef dArray() As Double, bDirection As Boolean, ByRef dWith_Array() As Double, Optional sMessage As String, Optional bReturn_Time As Boolean, Optional bWith_Array As Boolean, Optional lBegin_Element As Long, Optional lEnd_Element As Double) As Long
'Сортировка методом Шелла - самая быстрая из сортировок рэндома. Возвращает затраченное время сортировки массива в секундах.
'dArray() - Основной массив (указатель), bDirection - направление соритровки (True - по возрастанию), dWith_Array() - дополнительный массив (указатель, сортируется вместе с основным),
'sMessage - сообщение пользователю (индикатор независания ПО), bReturn_Time - ускорение сортировки или вывод sMessage и возврат времени выполнения в секундах,
'bWith_Array - так как массив нельзя указать Optional, флаг используется как наличие dWith_Array() (заглушка - dArray, False),
'lBegin_Element - начальный элемент для сортировки части массива (с нуля), lEnd_Element - конечный элемент для сортировки части массива (с нуля).
1 On Error GoTo ErrorHandler
 
2 Dim dStep As Double 'Текущий шаг для сортировки вставкой.
3 Dim dTemp As Double, dTemp2 As Double 'Временные переменные для хранения значения вставки.
4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
5 Dim dateBegin_Time As Date 'Для вычисления времени работы в секундах.
 
6 If bReturn_Time Then dateBegin_Time = Time 'Если важна скорость - не тратить ресурсы на вычисление времени и индикацию выполнения.
7 If lEnd_Element = 0 And lBegin_Element >= 0 Then lEnd_Element = UBound(dArray) 'Коррекция входных параметров Optional.
 
8 dStep = Int((lEnd_Element - lBegin_Element) / 2) 'Работает и в случае нечетной размерности массива.
 
9  If bWith_Array Then 'Задвоение кода из-за нескольких строк приводит к увеличению скорости на 30%.
10     While dStep >= 1
11         If g_bCancel Then Exit Function 'Прерывание сортировки.
      
12         If bReturn_Time Then
13             DoEvents
14             If sMessage <> "" Then Label_Process.Caption = sMessage & UBound(dArray) - dStep & " / " & UBound(dArray) + 1
15         End If
        
16         For i = lBegin_Element To dStep + lBegin_Element
17             For j = i + dStep To lEnd_Element Step dStep
18                 dTemp = dArray(j)
19                 dTemp2 = dWith_Array(j)
                
20                 For k = j - dStep To lBegin_Element Step -dStep
21                     If bDirection Xor (dTemp < dArray(k)) Then Exit For
22                     dArray(k + dStep) = dArray(k)
23                     dWith_Array(k + dStep) = dWith_Array(k)
24                 Next k
 
25                 dArray(k + dStep) = dTemp
26                 dWith_Array(k + dStep) = dTemp2
27             Next j
28         Next i
      
29         dStep = Int(dStep / 2)
30     Wend
31 Else
32     While dStep >= 1
33         If g_bCancel Then Exit Function 'Прерывание сортировки.
      
34         If bReturn_Time Then
35             DoEvents
36             If sMessage <> "" Then Label_Process.Caption = sMessage & UBound(dArray) - dStep & " / " & UBound(dArray) + 1
37         End If
        
38         For i = lBegin_Element To dStep + lBegin_Element
39            For j = i + dStep To lEnd_Element Step dStep
40                dTemp = dArray(j)
                
41                For k = j - dStep To lBegin_Element Step -dStep
42                    If bDirection Xor (dTemp < dArray(k)) Then Exit For
43                    dArray(k + dStep) = dArray(k)
44                Next k
 
45                dArray(k + dStep) = dTemp
46            Next j
47        Next i
      
48        dStep = Int(dStep / 2)
49    Wend
50 End If
 
51 If bReturn_Time Then lSort_Array = DateDiff("s", dateBegin_Time, Time)
    
1000000 Exit Function
ErrorHandler:
1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции lSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
End Function