 ソート：シェルソート(VB6.0) (No.1の個別表示) [スレッド一覧へ] |
- 日時： 2011/04/05 11:36
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[文字列処理][アルゴリズム][] *
* キーワード：アルゴリズム,並べ替える,小さい順（昇順）,大きい順（降順）,並び替え *
***********************************************************************************
【開設当初の掲示板に投稿頂いていた分です】
-----------------------------------------------------------------------
ソート：シェルソート 投稿者：ゆう（U） [1998/9/14(月)15：24分]
-----------------------------------------------------------------------
'シェルソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' False：降順
Public Sub sShellSort(ByRef myArray() As Long, _
Optional Sorted As Boolean = True)
Dim i As Long, j As Long, k As Long
Dim intMyPointer As Integer
Dim lngGap As Long
Dim lngLow As Long, lngHigh As Long, lngCount As Long
Dim tmpArray As Long
intMyPointer = Screen.MousePointer
Screen.MousePointer = vbHourglass
lngLow = LBound(myArray)
lngHigh = UBound(myArray)
lngCount = lngHigh - lngLow + 1
lngGap = 1
k = Int(lngCount / 3)
Do While (lngGap < k)
lngGap = lngGap * 3 + 1
Loop
If Sorted Then
Do While (lngGap > 0)
For i = lngGap + lngLow To lngHigh
j = i
tmpArray = myArray(j)
Do While j >= lngGap + lngLow
If myArray(j - lngGap) <= tmpArray Then Exit Do
myArray(j) = myArray(j - lngGap)
j = j - lngGap
Loop
myArray(j) = tmpArray
Next i
lngGap = Int(lngGap / 3)
Loop
Else
Do While (lngGap > 0)
For i = lngGap + lngLow To lngHigh
j = i
tmpArray = myArray(j)
Do While j >= lngGap + lngLow
If myArray(j - lngGap) >= tmpArray Then Exit Do
myArray(j) = myArray(j - lngGap)
j = j - lngGap
Loop
myArray(j) = tmpArray
Next i
lngGap = Int(lngGap / 3)
Loop
End If
Screen.MousePointer = intMyPointer
End Sub
 |
| ソート：ヒープソート(VB6.0) (No.2の個別表示) [スレッド一覧へ] |
- 日時： 2011/04/05 11:36
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[文字列処理][アルゴリズム][] *
* キーワード：アルゴリズム,並べ替える,小さい順（昇順）,大きい順（降順）,並び替え *
***********************************************************************************
【開設当初の掲示板に投稿頂いていた分です】
----------------------------------------------------------------------
ソート：ヒープソート 投稿者：ゆう（U） [1998/09/14(月)15：25分]
----------------------------------------------------------------------
' ヒープソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' False：降順
Public Sub sHeapSort(ByRef myArray() As Long, _
Optional Sorted As Boolean = True)
Dim i As Long, j As Long, k As Long, l As Long, m As Long
Dim intMyPointer As Integer
Dim lngLow As Long, lngHigh As Long, lngCount As Long
Dim tmpArray As Long
intMyPointer = Screen.MousePointer
Screen.MousePointer = vbHourglass
lngLow = LBound(myArray)
lngHigh = UBound(myArray)
lngCount = lngHigh - lngLow
If Sorted Then
For i = (lngCount \ 2) To i > 0 Step (-1)
'共通化可能1
l = i: m = lngCount
k = 2 * l
Do While (k <= m)
If k < m Then
If myArray(k + 1 + lngLow) > myArray(k + lngLow) Then
k = k + 1
End If
End If
If myArray(l + lngLow) >= myArray(k + lngLow) Then Exit Do
tmpArray = myArray(l + lngLow)
myArray(l + lngLow) = myArray(k + lngLow)
myArray(k + lngLow) = tmpArray
l = k
k = 2 * l
Loop
'ここまで
Next i
j = lngCount
Do While j > 0
tmpArray = myArray(0 + lngLow)
myArray(0 + lngLow) = myArray(j + lngLow)
myArray(j + lngLow) = tmpArray
j = j - 1
'共通化可能1
l = 0: m = j
k = 2 * l
Do While (k <= m)
If k < m Then
If myArray(k + 1 + lngLow) > myArray(k + lngLow) Then
k = k + 1
End If
End If
If myArray(l + lngLow) >= myArray(k + lngLow) Then Exit Do
tmpArray = myArray(l + lngLow)
myArray(l + lngLow) = myArray(k + lngLow)
myArray(k + lngLow) = tmpArray
l = k
k = 2 * l
Loop
'ここまで
Loop
Else
For i = (lngCount \ 2) To i > 0 Step (-1)
'共通化可能2
l = i: m = lngCount
k = 2 * l
Do While (k <= m)
If k < m Then
If myArray(k + 1 + lngLow) < myArray(k + lngLow) Then
k = k + 1
End If
End If
If myArray(l + lngLow) <= myArray(k + lngLow) Then Exit Do
tmpArray = myArray(l + lngLow)
myArray(l + lngLow) = myArray(k + lngLow)
myArray(k + lngLow) = tmpArray
l = k
k = 2 * l
Loop
'ここまで
Next i
j = lngCount
Do While j > 0
tmpArray = myArray(0 + lngLow)
myArray(0 + lngLow) = myArray(j + lngLow)
myArray(j + lngLow) = tmpArray
j = j - 1
'共通化可能2
l = 0: m = j
k = 2 * l
Do While (k <= m)
If k < m Then
If myArray(k + 1 + lngLow) < myArray(k + lngLow) Then
k = k + 1
End If
End If
If myArray(l + lngLow) <= myArray(k + lngLow) Then Exit Do
tmpArray = myArray(l + lngLow)
myArray(l + lngLow) = myArray(k + lngLow)
myArray(k + lngLow) = tmpArray
l = k
k = 2 * l
Loop
'ここまで
Loop
End If
Screen.MousePointer = intMyPointer
End Sub
|
| ソート法の使用方法他(ゆうさん投稿分の)(VB6.0) (No.3の個別表示) [スレッド一覧へ] |
- 日時： 2011/04/08 12:10
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[文字列処理][アルゴリズム][] *
* キーワード：アルゴリズム,並べ替える,小さい順（昇順）,大きい順（降順）,並び替え *
***********************************************************************************
------------------------------------------------------------------
ソート（前述３つ） 投稿者：ゆう（U） [1998/09/14(月)15：26分]
------------------------------------------------------------------
使用方法はすべて同じです。
Dim i As Long
Dim lngArray() As Long
ReDim lngArray(0 To 100) '(-1000 To -1)等のソートもOK
For i = LBound(lngArray) To UBound(lngArray)
lngArray(i) = i
Next i
s????Sort lngArray [, True|, False]
速度を比較すると
低速← sBubleSort > sHeapSort > sShellSort →高速
の順です。
※しかしソートするデータによってはもっと良い（特化）したソート方法が
考えられます（一般的なデータではシェルソートが早いみたい）。
ヒープソートの添字に負を使用できるようにしている部分をなくすと
今より速度が上がると思いますが、良い考えが思い浮かばずこの様な
コードになってしまいました(+ lngLowがいっぱいで見栄えが悪い)。
なお、ソートについてはVisualBasicマガジン７月号と河西朝雄著
C言語によるはじめてのアルゴリズム入門（技術評論社）を参考に
しました。
※しかし、VBマガジン７月号に掲載されているコードではテストに
不十分な為、コードを手直ししないとあまり使えません。
或るソートでソート後別のソートを試しても配列はソート済みの為
ソート時間が公正では無くなる。
花ちゃん（さん）のヒープソートも試したのですが負の添字もOKなどの
仕様で移植しきれなかったので上記アルゴリズム入門を参考にして作成
しました。
Long型以外、ユーザー定義型の配列などは前回の投稿を参考にして
手直しして使用して下さい。
※この仕様（添字に負を許す）でこのコードより早いソート方法や
コードの修正点などをご存知の方（気づかれた方）、その方法を
教えて下さい。
|
| ソート：クイックソート(VB6.0) (No.4の個別表示) [スレッド一覧へ] |
- 日時： 2011/04/05 11:37
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[文字列処理][アルゴリズム][] *
* キーワード：アルゴリズム,並べ替える,小さい順（昇順）,大きい順（降順）,並び替え *
***********************************************************************************
【開設当初の掲示板に投稿頂いていた分です】
----------------------------------------------------------------------
ソート：クイックソート 投稿者：ゆう（U） [1998/09/19(土)21：12分]
----------------------------------------------------------------------
' クイックソート(Long版)
'Sorted(省略可能) = True ：昇順（デフォルト）
' False：降順
Public Sub sQuickSort(ByRef myArray() As Long, _
Optional Sorted As Boolean = True)
Dim i As Long, j As Long, k As Long, l As Long, m As Long
Dim intMyPointer As Integer
Dim lngLow As Long, lngHigh As Long
Dim tmpArray As Long
intMyPointer = Screen.MousePointer
Screen.MousePointer = vbHourglass
lngLow = LBound(myArray)
lngHigh = UBound(myArray)
If Sorted Then
Call sAQuick(myArray(), lngLow, lngHigh)
Else
Call sDQuick(myArray(), lngLow, lngHigh)
End If
Screen.MousePointer = intMyPointer
End Sub
'昇順用Quickソート
Private Sub sAQuick(ByRef myArray() As Long, _
ByVal lngLeft As Long, _
ByVal lngRight As Long)
Dim tmpArray As Long
Dim i As Long, j As Long
If lngLeft < lngRight Then
tmpArray = myArray((lngLeft + lngRight) \ 2)
i = lngLeft
j = lngRight
Do While (True)
Do While (myArray(i) < tmpArray)
i = i + 1
Loop
Do While (myArray(j) > tmpArray)
j = j - 1
Loop
If i >= j Then Exit Do
myArray(i) = myArray(i) Xor myArray(j)
myArray(j) = myArray(i) Xor myArray(j)
myArray(i) = myArray(i) Xor myArray(j)
i = i + 1
j = j - 1
Loop
Call sAQuick(myArray(), lngLeft, i - 1)
Call sAQuick(myArray(), j + 1, lngRight)
End If
End Sub
'降順用Quickソート
Private Sub sDQuick(ByRef myArray() As Long, _
ByVal lngLeft As Long, _
ByVal lngRight As Long)
Dim tmpArray As Long
Dim i As Long, j As Long
If lngLeft < lngRight Then
tmpArray = myArray((lngLeft + lngRight) \ 2)
i = lngLeft
j = lngRight
Do While (True)
Do While (myArray(i) > tmpArray)
i = i + 1
Loop
Do While (myArray(j) < tmpArray)
j = j - 1
Loop
If i >= j Then Exit Do
myArray(i) = myArray(i) Xor myArray(j)
myArray(j) = myArray(i) Xor myArray(j)
myArray(i) = myArray(i) Xor myArray(j)
i = i + 1
j = j - 1
Loop
Call sDQuick(myArray(), lngLeft, i - 1)
Call sDQuick(myArray(), j + 1, lngRight)
End If
End Sub
|
|
