Home > Algorithm | Excel VBA > ヒープソート・アルゴリズムの訂正・ Correction of HeapSort Algorithm

ヒープソート・アルゴリズムの訂正・ Correction of HeapSort Algorithm

Posted by: WebMaster
2008年5月20日 13:18
Algorithm | Excel VBA

訂正：２０％効率化されたヒープソート・アルゴリズムと書いていましたが、どうにも腑に落ちなかったので、C言語で書かれた専門書を買って調べたところ、ここに書いているコード（効率化されたヒープソートと書いたコードとほぼ同じもの）が本に書かれていました。

この記事の前に書いたヒープソートのコードは、Wikipediaや海外の複数のサイトで紹介されていたC言語のアルゴリズムを参考にしたものでした。それらが間違っているとは言い切れないし、難しいところです。ただ、効率化された新しいヒープソートと紹介した部分は間違っていますので、ここで訂正します。

簡単な時間測定で、通常のヒープソートよりも時間が短縮されます。コムソート１１よりも少しだけ早くなりました。100万個の配列での相対的比較です。処理数は最低で13,815,511回となりますので単純計算で１万個の配列のソートテストを少なくとも150回して平均値を取ったのとほぼ同じになります。10,000,000*log(10,000,000)/10,000*log(10,000)=150（テストは乱数で作った配列の並び替えです）

アルゴリズム的には当然、O(N*log N) の範囲内での改善になります。コードは以下に紹介しています。

According to the HeapSort algorithm, the portion of the comparison & swap was all done in loop. I have removed the portion of compare & swap from the loop. As a result, large amounts of processings of sorting have been improved. New HeapSort is equivalent to CombSort11 or became more than it.

ソースコードは、以下のとおりです。通常のヒープソートとコムソート１１のコードも書きました。

In addition, I also wrote CombSort11 & HeapSort(normal) shown as below.

''******************************************************************************************
''------------------------------------------------------------------------------------------
''----------- HEAP_SORT PROCEDURE (HeapDown)
''------------------------------------------------------------------------------------------
''******************************************************************************************
Sub HeapDown(S_Array, ByVal FirstArray As Long, ByVal LastArray As Long)
Dim Temp As Double
Dim CurrentMax As Long
Dim Pos As Long
''***********************************
''-----------------------------------
''---HEAP_SORT Code VB
''-----------------------------------
''---20 May,2008 Samurai-Logic.com
''-----------------------------------
''***********************************

Temp = S_Array(FirstArray)

Do While (FirstArray * 2 < LastArray)

CurrentMax = FirstArray * 2 + 1

If (CurrentMax = LastArray) Then Exit Do

If (S_Array(CurrentMax) <= S_Array(CurrentMax + 1)) Then
       CurrentMax = CurrentMax + 1
      End If

If Temp < S_Array(CurrentMax) Then
        S_Array(FirstArray) = S_Array(CurrentMax)
        Pos = CurrentMax
      Else
        Exit Do
      End If
  
  FirstArray = CurrentMax
Loop

S_Array(Pos) = Temp

End Sub
''******************************************************************************************
''------------------------------------------------------------------------------------------
''----------- HEAP_SORT PROCEDURE
''------------------------------------------------------------------------------------------
''******************************************************************************************

Sub HeapSort(Ar)
''***********************************
''---20 May,2008 Samurai-Logic.com
''***********************************
Dim i As Long
Dim Temp As Double
Dim SwapLast As Boolean

For i = Int((UBound(Ar) + 0.5) / 2) - 1 To 0 Step -1
    Call HeapDown(Ar, i, UBound(Ar))
Next

SwapLast = IIf(Ar(0) < Ar(UBound(Ar)), True, False)
  
For i = UBound(Ar) To 0 Step -1
    Temp = Ar(i)
    Ar(i) = Ar(0)
    Ar(0) = Temp
    Call HeapDown(Ar, 0, i - 1)
Next
If SwapLast = True Then
 Temp = Ar(UBound(Ar))
 Ar(UBound(Ar)) = Ar(UBound(Ar) - 1)
 Ar(UBound(Ar) - 1) = Temp
End If

End Sub

''*****************************************************************************************
''----------------------------------------------------------
''------ TEST PROCEDURE
''--------------------------------------------------------
Sub HeapSort_SpeedTest()
Dim i&
Dim Ar() As Double

ReDim Ar(1000000) ''---動的配列にして最後にメモリ解放する

For i = 0 To UBound(Ar)
 Ar(i) = Round(Rnd * 12345)
Next

Call HeapSort(Ar)  ''<---New HeapSort

'Call CombSort11(Ar)  ''<---Try CombSort11

'Call HeapSort_Sub(Ar)  ''<---Try HeapSort

Erase Ar ''---Donot forget to erase memory of 1,000,000 Array
End Sub

''****************************************************************************
''-----  HEAP_SORT (swap in loop)
''-----  Down Heap
''*****************************************************************************
Sub DownHeap(S_Array, ByVal FirstArray As Long, ByVal LastArray As Long)
Dim Temp As Double
Dim CurrentMax As Long
Dim Child As Long
''----------------------------------
''---Position of Children in array
''----------------------------------
''--Parent-->  Child
''---  0  -->  1 & 2
''---  1  -->  3 & 4
''---  2  -->  5 & 6
''---  3  -->  7 & 8
''---  4  -->  9 & 10
''---
''***********************************
''---7 May,2008 Samurai-Logic.com
''***********************************

Do While (FirstArray * 2 < LastArray)
    Child = FirstArray * 2 + 1
  
    If (Child = LastArray) Then Exit Sub

If (S_Array(Child) > S_Array(Child + 1)) Then
       CurrentMax = Child
      Else
       CurrentMax = Child + 1
      End If
      If S_Array(FirstArray) < S_Array(CurrentMax) Then
        Temp = S_Array(FirstArray)
        S_Array(FirstArray) = S_Array(CurrentMax)
        S_Array(CurrentMax) = Temp
      Else
        Exit Sub
      End If
    
   FirstArray = CurrentMax

Loop

End Sub
''*****************************************************************************
''----- Sub Program of Heap Sort
''*****************************************************************************
Sub HeapSort_Sub(Ar)
''***********************************
''---7 May,2008 Samurai-Logic.com
''***********************************
Dim i As Long
Dim Temp As Double
Dim SwapLast As Boolean

For i = Int((UBound(Ar) + 0.5) / 2) - 1 To 0 Step -1
    Call DownHeap(Ar, i, UBound(Ar))
Next

SwapLast = IIf(Ar(0) < Ar(UBound(Ar)), True, False)

For i = UBound(Ar) To 0 Step -1
    Temp = Ar(i)
    Ar(i) = Ar(0)
    Ar(0) = Temp

Call DownHeap(Ar, 0, i - 1)
Next
If SwapLast = True Then
 Temp = Ar(UBound(Ar))
 Ar(UBound(Ar)) = Ar(UBound(Ar) - 1)
 Ar(UBound(Ar) - 1) = Temp
End If

End Sub

''****************************************************************************
''-----  COMBSORT11
''*****************************************************************************

Sub CombSort11(S_Array)

''*****************************************
''----9 May, 2008 Samurai-Logic.com
''******************************************

Dim Gap As Single, Temp As Double
Dim isCombed As Boolean
Dim i&

isCombed = False
Gap = UBound(S_Array) + 1

Do While (Gap >= 1 Or isCombed = False)
  
  Gap = Int(Gap / 1.3)

If Gap = 10 Or Gap = 9 Then Gap = 11

isCombed = True

For i = 0 To UBound(S_Array) - Gap
       If S_Array(i) > S_Array(i + Gap) Then
        Temp = S_Array(i)
        S_Array(i) = S_Array(i + Gap)
        S_Array(i + Gap) = Temp
        If Gap <> 1 Then isCombed = False
        iCount = iCount + 1
       End If
    Next
Loop

End Sub

Comments:0

Amazon.co.jp ウィジェット

Home > Algorithm | Excel VBA > ヒープソート・アルゴリズムの訂正・ Correction of HeapSort Algorithm

Return to page top