エクセルVBAでシェーカーソート - 午後わてんのブログ

前回のバブルソートからの続き

gogowaten.hatenablog.com

エクセルVBAでバブルソート ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14787146.html

シェーカーソート

ja.wikipedia.org

基本はバブルソートと同じで左右の数値を比較して左が大きければ数値を交換

違いは

バブルソートでは左から右へを繰り返していたのを左右交互
1ループごとに比較範囲を1個づつ狭くしていくだけだったのを効率化

っていう改良を加えたものらしい

比較範囲の効率化

バブルソートで2,1,4,3,2,5,6,7を小さい順に並べ替えるときの1ループ目

2ループ目の比較範囲は1つ狭くして1,2,3,2,4,5,6だった

でも最後の右端から見て連続3回交換が発生していない4,5,6の部分、これはもう順番通りに並んでいるってことなので省くことができる

なので2ループ目は3つ狭くした1,2,3,2の範囲だけ比較していけばいいことになる

前回のバブルソートのtestBubbleを元にしてシェーカーソート(仮)に書き直したのが

testShaker1

'testBubble2を改変してシェーカーソート
Public Function testShaker1(v As Variant) As Variant
    Dim i As Long, j As Long
    Dim c As Long: c = 0 '連続非交換回数記録用、カウント
    Dim r As Long: r = UBound(v) - 1 '探索範囲右端、right
    Dim tmp As Variant
    For i = 0 To UBound(v) - 1
        c = 0
        For j = 0 To r  '探索範囲
           '左(j)＞右(j+1)なら数値を交換する
            If v(j) > v(j + 1) Then
               '入れ替え
                tmp = v(j)
                v(j) = v(j + 1)
                v(j + 1) = tmp
                c = 0 'リセット
            Else
                c = c + 1 '連続非交換回数カウント
            End If
        Next
       '次のループの探索範囲変更、狭くする
        r = r - c - 1
       'もし探索範囲が0以下なら完了なのでループを抜ける
        If r <= 0 Then Exit For
    Next
    testShaker1 = v
End Function

交換が発生しなかったら回数を変数ｃにカウントして、交換が発生したらその時点でカウントをリセット、これで最後から見ての連続非交換回数がわかるのでループの最後に探索範囲右端の変数ｒから引き算

r = r - c - 1

-1しているのは通常の毎ループから1狭くできるからその分

f:id:gogowaten:20191031095049p:plain

1ループ目が終わったところカウントは3

次の探索範囲の右端はｒ－ｃ－１＝6-3-1＝2になる

2になった

探索範囲が0以下なら並べ替え完了なのでループを抜ける

1,2,3,4なら1ループ目で探索範囲がマイナスになる

ループ回数は並べ替え要素の個数-1だけどその前に並べ替えが終わることもある

その時は探索範囲がマイナスになるのが目安

これで探索範囲の効率化はできたのであとは左から右への探索を付け足せばシェーカーソートになるはず

'シェーカーソート、逆順からも探索
Public Function testShaker2(v As Variant) As Variant
    Dim i As Long, j As Long
    Dim c As Long: c = 0 '連続非交換回数記録用、カウント
    Dim r As Long: r = UBound(v) - 1 '探索範囲右端、right
    Dim l As Long: l = LBound(v)  '探索範囲の左端、left
    Dim tmp As Variant
   '順方向探索
    For i = 0 To UBound(v) - 1
        c = 0
        For j = l To r  '探索範囲
           '左(j)＞右(j+1)なら数値を交換する
            If v(j) > v(j + 1) Then
               '入れ替え
                tmp = v(j)
                v(j) = v(j + 1)
                v(j + 1) = tmp
                c = 0 'リセット
            Else
                c = c + 1 '連続非交換回数カウント
            End If
        Next
        r = r - c - 1 '次のループの探索範囲変更、狭くする
        
       '逆方向探索
        c = 0
        For j = r To l Step -1
           '左(j)＞右(j+1)なら数値を交換する
            If v(j) > v(j + 1) Then
                tmp = v(j)
                v(j) = v(j + 1)
                v(j + 1) = tmp
                c = 0
            Else
                c = c + 1
            End If
        Next
        l = l + c + 1 '次のループの探索範囲変更、狭くする
       '探索範囲の左右が交差したら完了なのでループを抜ける
        If l >= r Then Exit For
    Next
    
    testShaker2 = v
End Function

左から右へっていう逆方向を単純に付け足しただけだから2倍の行数になったｗ

逆方向からも探索して、範囲も狭くしていって探索範囲が交差(0以下)になったら並べ替え完了なので外側のループのFor i ～ NextはDo ～ Loopにした方がいいかも

これtestShaker2でタイム計測

計測方法は前回と同じ1万件のランダム数値の並べ替え

Sub sortTestBubble2()
    Dim c As Long: c = 10000
    Dim v() As Variant
    ReDim v(c - 1)
    For i = 0 To c - 1
        v(i) = CInt(c * Rnd)
    Next
    Dim st As Single
    st = Timer
'  v = testBubble1(v) '18.90234秒
'  v = testBubble2(v) '12.27734
   'v = testBubble3(v)  '10.16406
    v = testShaker2(v)
    MsgBox Timer - st & "秒"
End Sub

testShaker2

testBubble2の改変だから2秒近く速くなった

testBubble3をシェーカーソートにした場合はどうかな

'シェーカーソート、testBubble3から改変
Public Function testShaker3(v As Variant) As Variant
    Dim i As Long, j As Long
    Dim c As Long: c = 0 '連続非交換回数記録用、カウント
    Dim r As Long: r = UBound(v) - 1 '探索範囲右端、right
    Dim l As Long: l = LBound(v)  '探索範囲の左端、left
    Dim tmp As Variant
   '順方向探索
    For i = 0 To UBound(v) - 1
        c = 0
        tmp = v(l) '最初に比較する数値をtmpに入れる
        For j = l To r  '探索範囲
           'tmp＞右(j+1)なら右を左へ上書き、違うならtmpの数値と交換
            If tmp > v(j + 1) Then
                v(j) = v(j + 1)
                c = 0 'カウンターリセット
            Else
                v(j) = tmp 'tmpの値を配列に戻す
                tmp = v(j + 1) '次に比較する数値(今の右)をtmpに入れる
                c = c + 1 '連続非交換回数カウント
            End If
        Next
        v(j) = tmp 'tmpの値を探索範囲の右端に戻す
        r = r - c - 1 '次のループの探索範囲変更、狭くする
       '探索範囲の左右が交差したら完了なのでループを抜ける
        If r <= l Then Exit For
        
       '逆方向探索
        c = 0
        tmp = v(r + 1) '最初に比較する数値をtmpに入れる
        For j = r To l Step -1
           'tmp<左の数値なら左を右に上書き、違うならtmpの数値と交換
            If tmp < v(j) Then
                v(j + 1) = v(j) '左を右に上書き
                c = 0
            Else
                v(j + 1) = tmp 'tmpの値を配列に戻す
                tmp = v(j)
                c = c + 1
            End If
        Next
        v(j + 1) = tmp 'tmpの値を探索範囲の左端に戻す
        l = l + c + 1 '次のループの探索範囲変更、狭くする
        
       '探索範囲の左右が交差したら完了なのでループを抜ける
        If l >= r Then Exit For
    Next
    
    testShaker3 = v
End Function