たびたび、申し訳ありません。
どうも添付したｃｓｖファイルが思惑どおりのイメージになりません。
修正方法や、添付ファイルとしての投稿方法を教えてください。
（フォーラムの方向性は変えたくありません・・・）
また、ｃｓｖデータのイメージはお解りいただけると思いますので、
テストデータとしては、ソート済み、逆ソート済みでなければ、
実行時間は変わらないと思います。
ソートロジック大会
-
河川屋
＞私の使っているクイックソートのコード（Ver2.59）
＞正順or逆順に非常に弱いのが欠点
＞クイック スタック不足で強制終了
なんだか、クイックが不当な評価を受けていますが、コードが悪いのでは？
普通にクイックを組んだとしても、クイックというのは正順or逆順に対して
相当強いし、スタックについても、５０回再帰までｏｋとすると100兆個の
データでもイケます。クイックは、そんなにヤワではないです。
＞シェル法が最強
そういうこと書かれると困るんですよねえ。
NlogNとn^1.25（≒N(logN)^2）の差は、データ数が大きくなると
ちょっとやそっとではひっくり返せなくなるだけの差があります。
だから、数千個までなら、シェル法はクイックやヒープとかなりいい勝負を
しますが、数十万個になると、シェル法は脱落する筈です。
クイックやヒープを実験しないうちに最強を決め手はダメだってば。
＞ ａｂのバージョンがわからず、コンパイルエラーの嵐
私も悩まされています。
で、N88BASICまで遡っても使える命令だけで書いています。
(Do～Loop UntilはIf～gotoに修正する必要があるのと、
行番号を適当にくっつける必要があるが。)
よって、
・メインルーチンの中で、gosubで飛ばす
という使い方なら、abのVerにかかわらず問題ないはずです。
abは、N88BASIC互換と書いてあるから、
N88BASICで動いてabで動かないというプログラムがあれば、
それはabのバグのせいであり、abのVerを言っても仕方ありません。
※でも、実際問題、コケるため、サブルーチンとして書くことを放棄しました。
だから、昔の方法（gosubで飛ばし、変数は全てメインと共用）で使ってください。
クイックソート（昔流の書き方で、再帰や構造体は用いていない。）
dim Key(xxx),X,W as ○○○
dim SL(xx),SR(xx) as long
dim i,j,S,L,R,N as long
dim nn as long
'N:データ数
'Key():キーデータの配列
'SL(),SR() スタック配列
'SL()とSR()の配列サイズは以下のとおり。
'nn=log(N)/log(2)+2
'dim SL(nn),SR(nn) as long
' ただし、ノーマル版はこれより大きい配列が必要。
'Quicksortノーマル版（非再帰）
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
Do
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
IF i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
IF i<R Then S=S+1 : SL(S)=i : SR(S)=R
R=j
Loop Until L>=R
Loop Until S=0
Return
'Quicksort改１ スタックオーバーを起こさないよう変更
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
If i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
' 左右のうちデータ数の少ないほうを先に砕く
If (R-i) > (j-L) Then
If i<R Then S=S+1 : SL(S)=i : SR(S)=R
If j>L Then S=S+1 : SL(S)=L : SR(S)=j
Else
If j>L Then S=S+1 : SL(S)=L : SR(S)=j
If i<R Then S=S+1 : SL(S)=i : SR(S)=R
End If
Loop Until S=0
Return
'Quicksort改２ ある程度小さく砕いたら、あとは単純挿入法にまかせる
nn=20 'ここまで砕いた時点で停止する（この値で適当かどうかは不明）
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
If i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
' 左右のうちデータ数の少ないほうを先に砕く
If (R-i) > (j-L) Then
If i+nn<R Then S=S+1 : SL(S)=i : SR(S)=R
If j>L+nn Then S=S+1 : SL(S)=L : SR(S)=j
Else
If j>L+nn Then S=S+1 : SL(S)=L : SR(S)=j
If i+nn<R Then S=S+1 : SL(S)=i : SR(S)=R
End If
Loop Until S=0
'
For i=2 to N
X=Key(i) : Key(0)=X
j=i-1
While X<Key(j)
Key(j+1)=Key(j): j=j-1
Wend
Key(j+1)=X
Next
RETURN
'Quicksort改３ 最悪計算量に陥る可能性を減らす。
X=Key((L+R)\2)の部分を、
・XはKey(L)とKey((L+R)\2)とKey(R)のうちの中央値を選ぶ
・XはKey(L)、Key(L+1)、とKey(L+2)、...Key(R)のうちからランダムに１つ選ぶ
のいずれかに変更する。
'Quicksort改４ キーが文字列で、データ数が非常に多い場合専用。
１．まず、キーの１文字目を使って、度数ソートで区間分けする。
２．各々の区間に対してQuicksort。
＞正順or逆順に非常に弱いのが欠点
＞クイック スタック不足で強制終了
なんだか、クイックが不当な評価を受けていますが、コードが悪いのでは？
普通にクイックを組んだとしても、クイックというのは正順or逆順に対して
相当強いし、スタックについても、５０回再帰までｏｋとすると100兆個の
データでもイケます。クイックは、そんなにヤワではないです。
＞シェル法が最強
そういうこと書かれると困るんですよねえ。
NlogNとn^1.25（≒N(logN)^2）の差は、データ数が大きくなると
ちょっとやそっとではひっくり返せなくなるだけの差があります。
だから、数千個までなら、シェル法はクイックやヒープとかなりいい勝負を
しますが、数十万個になると、シェル法は脱落する筈です。
クイックやヒープを実験しないうちに最強を決め手はダメだってば。
＞ ａｂのバージョンがわからず、コンパイルエラーの嵐
私も悩まされています。
で、N88BASICまで遡っても使える命令だけで書いています。
(Do～Loop UntilはIf～gotoに修正する必要があるのと、
行番号を適当にくっつける必要があるが。)
よって、
・メインルーチンの中で、gosubで飛ばす
という使い方なら、abのVerにかかわらず問題ないはずです。
abは、N88BASIC互換と書いてあるから、
N88BASICで動いてabで動かないというプログラムがあれば、
それはabのバグのせいであり、abのVerを言っても仕方ありません。
※でも、実際問題、コケるため、サブルーチンとして書くことを放棄しました。
だから、昔の方法（gosubで飛ばし、変数は全てメインと共用）で使ってください。
クイックソート（昔流の書き方で、再帰や構造体は用いていない。）
dim Key(xxx),X,W as ○○○
dim SL(xx),SR(xx) as long
dim i,j,S,L,R,N as long
dim nn as long
'N:データ数
'Key():キーデータの配列
'SL(),SR() スタック配列
'SL()とSR()の配列サイズは以下のとおり。
'nn=log(N)/log(2)+2
'dim SL(nn),SR(nn) as long
' ただし、ノーマル版はこれより大きい配列が必要。
'Quicksortノーマル版（非再帰）
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
Do
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
IF i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
IF i<R Then S=S+1 : SL(S)=i : SR(S)=R
R=j
Loop Until L>=R
Loop Until S=0
Return
'Quicksort改１ スタックオーバーを起こさないよう変更
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
If i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
' 左右のうちデータ数の少ないほうを先に砕く
If (R-i) > (j-L) Then
If i<R Then S=S+1 : SL(S)=i : SR(S)=R
If j>L Then S=S+1 : SL(S)=L : SR(S)=j
Else
If j>L Then S=S+1 : SL(S)=L : SR(S)=j
If i<R Then S=S+1 : SL(S)=i : SR(S)=R
End If
Loop Until S=0
Return
'Quicksort改２ ある程度小さく砕いたら、あとは単純挿入法にまかせる
nn=20 'ここまで砕いた時点で停止する（この値で適当かどうかは不明）
S=1 : SL(1)=1 : SR(1)=N
Do
L=SL(S) : R=SR(S) : S=S-1
i=L : j=R : X=Key((L+R)\2)
Do
While Key(i)<X : i=i+1 : WEND
While X<Key(j) : j=j-1 : WEND
If i<=j Then
W= Key(i) :Key(i)=Key(j) : Key(j)=W
i=i+1 : j=j-1
End If
Loop Until i>j
' 左右のうちデータ数の少ないほうを先に砕く
If (R-i) > (j-L) Then
If i+nn<R Then S=S+1 : SL(S)=i : SR(S)=R
If j>L+nn Then S=S+1 : SL(S)=L : SR(S)=j
Else
If j>L+nn Then S=S+1 : SL(S)=L : SR(S)=j
If i+nn<R Then S=S+1 : SL(S)=i : SR(S)=R
End If
Loop Until S=0
'
For i=2 to N
X=Key(i) : Key(0)=X
j=i-1
While X<Key(j)
Key(j+1)=Key(j): j=j-1
Wend
Key(j+1)=X
Next
RETURN
'Quicksort改３ 最悪計算量に陥る可能性を減らす。
X=Key((L+R)\2)の部分を、
・XはKey(L)とKey((L+R)\2)とKey(R)のうちの中央値を選ぶ
・XはKey(L)、Key(L+1)、とKey(L+2)、...Key(R)のうちからランダムに１つ選ぶ
のいずれかに変更する。
'Quicksort改４ キーが文字列で、データ数が非常に多い場合専用。
１．まず、キーの１文字目を使って、度数ソートで区間分けする。
２．各々の区間に対してQuicksort。
-
高信期
投稿した記事の編集方法はhttp://www.discoversoft.net/forum/faq.php#15にあるようですが、ID登録した人以外は出来ないようですね。
CSVファイル自体はどこかのアップローダーにアップロードしてそのURLを投稿するか、
もしくはCSVファイルを圧縮し、BASE64や昔懐かしいISHでエンコードしたものを投稿してみてはいかがでしょうか。
さて最速のソート法は、安定である必要があるならマージソート、
そうでなければクイックソートですかね。
CSVファイル自体はどこかのアップローダーにアップロードしてそのURLを投稿するか、
もしくはCSVファイルを圧縮し、BASE64や昔懐かしいISHでエンコードしたものを投稿してみてはいかがでしょうか。
さて最速のソート法は、安定である必要があるならマージソート、
そうでなければクイックソートですかね。
今回、抜き出しがうまくいったと思われる６１６件分のデータをソートした結果、ファイルの入出力を含めて、60ms前後で処理できました。
ActiveBasic4.x
投稿ロジックにバグが多くて申し訳ありません。
元プログラムが（第１列＝自治体ＣＤ（０１固定）、第２列＝住民ＣＤ）のCSVファイルを第２列でソートする仕様でした。
今回、投稿用に第１列をソート対象に改造し、出力結果をチェックしましたが、結果的に第１列に関する処理にバグを大量に作り込みました。
以後投稿時は、十分にチェックを行います。m(_^_)m
ＰＳ
実は、自分もＣＳＶの高速ソートが必要になったのでActiveBasic(Ver4.x)を使ってみようと思ったのです。
（趣味で開発を行っているので、有償の開発ツールを買うお金が無いのです）
でも、ActiveBasicに出会えて非常によかったと思うので、自分のノウハウは全て公開しようと思っています。
これからもよろしくお願いします。
必要ないと思いますが、訂正後のコードも乗せておきます。
（本当は、以前に乗せたコードは全て消したいのですが・・・）
条件
[AB4]プロジェクト・EXE - ノーマルウィンドウベース
コマンドを実行する為に、CommandButton1が必要です。
fLoad（処理対象のCSVファイルを指定する）
ActiveBasic4.x
投稿ロジックにバグが多くて申し訳ありません。
元プログラムが（第１列＝自治体ＣＤ（０１固定）、第２列＝住民ＣＤ）のCSVファイルを第２列でソートする仕様でした。
今回、投稿用に第１列をソート対象に改造し、出力結果をチェックしましたが、結果的に第１列に関する処理にバグを大量に作り込みました。
以後投稿時は、十分にチェックを行います。m(_^_)m
ＰＳ
実は、自分もＣＳＶの高速ソートが必要になったのでActiveBasic(Ver4.x)を使ってみようと思ったのです。
（趣味で開発を行っているので、有償の開発ツールを買うお金が無いのです）
でも、ActiveBasicに出会えて非常によかったと思うので、自分のノウハウは全て公開しようと思っています。
これからもよろしくお願いします。
必要ないと思いますが、訂正後のコードも乗せておきます。
（本当は、以前に乗せたコードは全て消したいのですが・・・）
条件
[AB4]プロジェクト・EXE - ノーマルウィンドウベース
コマンドを実行する為に、CommandButton1が必要です。
fLoad（処理対象のCSVファイルを指定する）
ここをクリックするとコードが表示されます [ここをクリックすると内容が表示されます]
コード: 全て選択
'-----------------------------------------------------------------------------
' イベント プロシージャ
'-----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd
' TODO: この位置にグローバルな変数、構造体、定数、関数を定義します。
Const xMax = 300000
Type xCd
xPtr As BytePtr '参照位置
xKey1 As DWord '並替キー１
xKey2 As DWord '並替キー２
End Type
Dim tblcnt As DWord '読込数
Dim Cd(xMax) As xCd 'データ格納件数
'-----------------------------------------------------------------------------
' ウィンドウメッセージを処理するためのコールバック関数
Function MainWndProc(hWnd As DWord, dwMsg As DWord, wParam As DWord, lParam As DWord) As DWord
' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
' イベントプロシージャの呼び出しを行います。
MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function
'-----------------------------------------------------------------------------
' ここから下は、イベントプロシージャを記述するための領域になります。
Sub MainWnd_Destroy()
TextSort_DestroyObjects()
PostQuitMessage(0)
End Sub
Sub MainWnd_CommandButton1_Click()
Dim i As Dword
Dim text As String
Dim pFileBuffer As BytePtr 'ファイルポインター
Dim StartTime As DWord
Dim EndTime As DWord
StartTime = GetTickCount()
pFileBuffer = fLoad ("C:\Test.CSV") 'ファイル名をフルパスで指定します。
' BubbleSort()
' CormSort()
' ShellSort()
' ShellSort2()
Open "C:\Work.Txt" For Output As #1 'ファイル名を相対パスで指定します。
For i=0 To tblcnt
Print #1, MakeStr(Cd.xPtr)
Next
Close #1
fClose(pFileBuffer)
EndTime = GetTickCount()
MsgBox hMainWnd, Str$(EndTime - StartTime )&"ms"
End Sub
'=============================================================================
' ファイル制御
'=============================================================================
Function fLoad (ByVal lpstrFileName As BytePtr) As BytePtr
Dim hFile As HANDLE
Dim nRead As DWord
Dim nSize As DWord
Dim pLoad As BytePtr
'ファイル読込み
pLoad = NULL
hFile = CreateFile( lpstrFileName, GENERIC_READ, 0,ByVal 0,OPEN_EXISTING,FILE_FLAG_SEQUENTIAL_SCAN,0)
If hFile <> INVALID_HANDLE_VALUE Then
nSize = GetFileSize( hFile, NULL )
pLoad = HeapAlloc( GetProcessHeap(), HEAP_ZERO_MEMORY, nSize + 2 )
ReadFile( hFile, pLoad, nSize, VarPtr(nRead), ByVal 0 )
CloseHandle( hFile )
'文字列へ分解する処理
if (pLoad[nSize] = &h00) then pLoad[nSize]=0: nSize=nSize-1
if (pLoad[nSize] = &h1A) then pLoad[nSize]=0: nSize=nSize-1 'Eof
if (pLoad[nSize] <> &h0A) then pLoad[nSize]=&h0D: pLoad[nSize+1]=&h0A
MakeLines( pLoad , nSize )
End If
fLoad = pLoad
End Function
'■バッファを開放する
Function fClose ( ByVal lpstrBuffer As BytePtr) As Long
fClose = HeapFree( GetProcessHeap(), 0, lpstrBuffer)
End Function
'=============================================================================
'
'=============================================================================
Sub MakeLines(byVal p as BytePtr,ByVal cMax as DWord)
Dim i = 0 As DWord
Dim n = 0 As DWord
Dim w As DWord
'文字列切り出し
Do
Cd[n].xPtr = p + i
w=0: While p<>&h2C: w=(w*10)+p-&h30: i=i+1: Wend: Cd[n].xKey1=w: i=i+1
w=0: While p<>&h2C: w=(w*10)+p-&h30: i=i+1: Wend: Cd[n].xKey2=w
Do: i=i+1: Loop Until (p=&h0D)
p=0 'CR &h0D
p[i+1]=0 'LF &h0A
i=i+2
n=n+1
Loop While ( i < cMax )
tblcnt = n - 1
End Sub
'----------------------------------------------------------
' 並べ替えの例
'----------------------------------------------------------
Sub ShellSort2() 'クヌースによる改シェル法
Dim i As DWord
Dim j As DWord
Dim k As DWord
Dim g As DWord 'gap
Dim w As xCd
g = 4
While g <= tblcnt
g = 3 * g + 1
Wend
'
While ( g > 1 )
g = ( g - 1 ) \ 3
For i = g To tblcnt
j = i - g
k = i
w = Cd(i)
Do
'条件誤り If w.xKey1 >= Cd(j).xKey1 Then If w.xKey2 >= Cd(j).xKey2 Then Exit Do
If w.xKey1 > Cd(j).xKey1 Then Exit Do
If w.xKey1 = Cd(j).xKey1 Then If w.xKey2 >= Cd(j).xKey2 Then Exit Do
Cd(k) = Cd(j)
k = j
j = j - g
Loop While ( j > 0 )
If ( i <> k ) Then Cd(k) = w
Next
Wend
End Sub
Sub ShellSort()
Dim i As DWord
Dim j As DWord
Dim k As DWord
Dim g As DWord 'gap
Dim w As xCd
g = tblcnt
While ( g > 1 )
' g = g \ 2
g = g >> 1
' For i = g + 1 To tblcnt
For i = g To tblcnt
j = i - g
k = i
w = Cd(i)
Do
'条件誤り If w.xKey1 >= Cd(j).xKey1 Then If w.xKey2 >= Cd(j).xKey2 Then Exit Do
If w.xKey1 > Cd(j).xKey1 Then Exit Do
If w.xKey1 = Cd(j).xKey1 Then If w.xKey2 >= Cd(j).xKey2 Then Exit Do
Cd(k) = Cd(j)
k = j
j = j - g
Loop While ( j > 0 )
If ( i <> k ) Then Cd(k) = w
Next
Wend
End Sub
Sub CormSort() 'コームソート
Dim i As DWord
Dim j As DWord
Dim s As DWord
Dim w As xCd
s = tblcnt \ 2
Do
j = s
For i = 0 To (tblcnt - s)
If Cd(i).xKey1 = Cd(j).xKey1 Then
If Cd(i).xKey2 > Cd(j).xKey2 Then
w = Cd(i): Cd(i) = Cd(j): Cd(j) = w
End If
Else
If Cd(i).xKey1 > Cd(j).xKey1 Then
w = Cd(i): Cd(i) = Cd(j): Cd(j) = w
End If
End If
j = j + 1
Next
s = (s * 10) \ 13
Loop Until (s < 1)
BubbleSort()
End Sub
Sub BubbleSort() 'バブルソート
Dim i As DWord
Dim j As DWord
Dim w As xCd
Dim e As Byte
Do
j = 0: e = 0
For i = 1 To tblcnt
If Cd(j).xKey1 = Cd(i).xKey1 Then
If Cd(j).xKey2 > Cd(i).xKey2 Then
w = Cd(i): Cd(i) = Cd(j): Cd(j) = w: e=1
End If
Else
If Cd(j).xKey1 > Cd(i).xKey1 Then
w = Cd(i): Cd(i) = Cd(j): Cd(j) = w: e=1
End If
End If
j = j + 1
Next
Loop Until (e=0)
End Sub
最後に編集したユーザー マティ [ 2005年12月15日(木) 23:22 ], 累計 1 回
前回のコードはAB 2.62用でしたが、omasuさんのcsvはなぜかエラー。
デバッガもないのでAB 4.1β1用に移植しました。
コンパイルして実行するとソートは20ミリ秒になりました。
クイックソートですが、まだ他の種類を試していないので直接的な比較はまだできませんが、少なくともAB2よりは相当速くなっています。
H17.11.26
コードが長いのでhideを使用するように修正いたしました。
デバッガもないのでAB 4.1β1用に移植しました。
コンパイルして実行するとソートは20ミリ秒になりました。
クイックソートですが、まだ他の種類を試していないので直接的な比較はまだできませんが、少なくともAB2よりは相当速くなっています。
[ここをクリックすると内容が表示されます]
コード: 全て選択
#strict
#prompt
Declare Function timeGetTime Lib "winmm.dll" () As DWord
Declare Function timeBeginPeriod Lib "winmm" (ByVal uPeriod As DWord) As Long
Declare Function timeEndPeriod Lib "winmm" (ByVal uPeriod As DWord) As Long
Declare Function CharNext Lib "User32" Alias "CharNextA" (psz As BytePtr) As BytePtr
Dim hHeap As HANDLE
Function OwnerWnd() As HWND
OwnerWnd = _PromptSys_hWnd
End Function
Function GetKeyPart$(ByVal str As String) As String
Dim Length As Long, PartA As Long, PartB As Long
PartA = InStr(1, str, ",")
If PartA > 0 Then
PartB = InStr(PartA + 1, str, ",")
If PartB > 0 Then
GetKeyPart$ = Left$(str, PartB - 1)
Exit Function
End If
End If
GetKeyPart$ = str
End Function
Function GetLine(ByRef rpsz As BytePtr) As BytePtr
GetLine = rpsz
While GetWord(rpsz) <> &h0a0d ' GetWord(Ex"\r\n")
If GetByte(rpsz) = 0 Then
rpsz = 0
Exit Function
End If
rpsz = CharNext(rpsz)
Wend
SetByte(rpsz, 0)
rpsz = rpsz + 2
End Function
Function StrDupS(str As String) As BytePtr
Dim Size As DWord
Size = Len(str) + 1
StrDupS = malloc(Size)
memcpy(StrDupS, StrPtr(str), Size)
End Function
Function FileRead(FileName As BytePtr) As BytePtr
Dim hInputFile As HANDLE
hInputFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0) As HANDLE
If hInputFile = INVALID_HANDLE_VALUE Then
Exit Function
End If
Dim FileSize As DWord, dwReadSize As DWord
FileSize = GetFileSize(hInputFile, 0)
FileRead = malloc(FileSize + 1)
FileRead[FileSize] = 0
ReadFile(hInputFile, FileRead, FileSize, VarPtr(dwReadSize), ByVal 0)
CloseHandle(hInputFile)
End Function
Const TableSize = 2000
Dim KeyTable[TableSize] As BytePtr, DataTable[TableSize] As BytePtr,Index[TableCount] As Long, DataSize As Long
Dim i As Long
Dim StartTime As DWord, EndTime As DWord
Const SubWndTitle$ = "ソート"
' 処理開始確認
If MessageBox(OwnerWnd(), "ソート処理を実行します。よろしいですか？", SubWndTitle$, MB_YESNO or MB_ICONINFORMATION) = IDNO Then
Goto *ProgramEnd
End If
Print "program start", timeGetTime()
hHeap = HeapCreate(HEAP_NO_SERIALIZE, 131072, 0)
If hHeap = 0 Then
End
End If
' ファイル読み込み
Dim pInputBuffer As BytePtr
pInputBuffer = FileRead("z:\infile.csv")
If pInputBuffer = 0 Then
Goto *ProgramEnd
End If
timeBeginPeriod(1)
' 行単位へ分解
Dim strCurrentLine As String
Print "stock start", timeGetTime()
For i = 0 To TableSize
strCurrentLine = GetLine(pInputBuffer)
KeyTable = StrDupS(GetKeyPart$(strCurrentLine))
DataTable = StrDupS(Str$(i) + "," + strCurrentLine)
Index = i
If pInputBuffer = 0 Then
Exit For
End If
Next
free(pInputBuffer)
DataSize = i
Print "stock end", timeGetTime()
' ソート
StartTime = timeGetTime()
Print "sort start", StartTime
Sort(KeyTable, Index, DataSize)
EndTime = timeGetTime()
Print "sort end", EndTime
' ソートしたテーブルをファイルに出力
Open "z:\outfile.csv" For Output As #2
Print "file out start", timeGetTime()
For i = 0 To DataSize
Print #2, MakeStr(DataTable(Index))
Next i
Print "file out end", timeGetTime()
Close
' 処理終了確認
Print "program end", timeGetTime()
timeEndPeriod(1)
Print "ソート時間:"; EndTime - StartTime; "ミリ秒"
HeapDestroy(hHeap)
*ProgramEnd
MessageBox(OwnerWnd(), "ソート処理が終了しました。", SubWndTitle$, MB_OK or MB_ICONINFORMATION)
End
Sub Sort(KeyTable() As BytePtr, Index() As Long, ByVal Num As Long)
QuickSort3Main(KeyTable, Index, 0, Num)
End Sub
Sub QuickSort3Main(KeyTable() As BytePtr, Index() As Long, ByVal First As Long, ByVal Last As Long)
Dim j As Long, Center As Long
If First < Last Then
Swap(Index[First], Index[(First + Last) / 2])
Center = First
For j = First + 1 To Last
If lstrcmp(KeyTable[Index[First]], KeyTable[Index[j]]) > 0 Then
Center = Center + 1
Swap(Index[Center], Index[j])
End If
Next
Swap(Index[Center], Index[First])
QuickSort3Main(KeyTable, Index, First, Center - 1)
QuickSort3Main(KeyTable, Index, Center + 1, Last)
End If
End Sub
Sub Swap(ByRef x As Long, ByRef y As Long)
Dim temp As Long
temp = x
x = y
y = temp
End SubH17.11.26
コードが長いのでhideを使用するように修正いたしました。
最後に編集したユーザー イグトランス [ 2005年11月26日(土) 14:31 ], 累計 2 回
-
omasu
近況報告について
いつもお世話になっております。
イグトランスさんのメッセージでＡＢ（４．１β１）を早速ダウンロードしました。
入出力のファイル名の変更だけで実行ができました。
入力データ件数は「Const TableSize = 2000」の変更で実行できました。
あまりにもソート時間が短く、愛機の環境でも、数十ミリセカンドの世界で実行可能です。（一瞬、実行結果を疑ったほどです。）
今、結果の１行目が空白になってしまう原因を追求中です。
自作のプログラムでは１０００件の配列変数（テーブル）セットが２秒もかかるのに「なーぜー」？、
それより早い時間でソートができるのかが雲の上の世界と感じます。
ＡＢ２．６２は数千件のデータを配列変数に取り込めるのに、「実行プログラムが６４ＫＢ以上になる」
ＡＢ４．ｘｘ以降ではエラーとなるかが不明です。「ｅｘｅでありながら、ｃｏｍモデル？」
(~↓~)フォーラムの方向性は変えたくありません。
勝手ながらテストデータを
数値４桁を文字列として扱い１００００件を実行した結果を以下に示します。
ソート時間 デバック １．６０４秒 ｅｘｅ ０．４２６秒
残念ながら配列変数（テーブル）にためこむロジックはエラーとなります。
イグトランスさんのメッセージでＡＢ（４．１β１）を早速ダウンロードしました。
入出力のファイル名の変更だけで実行ができました。
入力データ件数は「Const TableSize = 2000」の変更で実行できました。
あまりにもソート時間が短く、愛機の環境でも、数十ミリセカンドの世界で実行可能です。（一瞬、実行結果を疑ったほどです。）
今、結果の１行目が空白になってしまう原因を追求中です。
自作のプログラムでは１０００件の配列変数（テーブル）セットが２秒もかかるのに「なーぜー」？、
それより早い時間でソートができるのかが雲の上の世界と感じます。
ＡＢ２．６２は数千件のデータを配列変数に取り込めるのに、「実行プログラムが６４ＫＢ以上になる」
ＡＢ４．ｘｘ以降ではエラーとなるかが不明です。「ｅｘｅでありながら、ｃｏｍモデル？」
(~↓~)フォーラムの方向性は変えたくありません。
勝手ながらテストデータを
数値４桁を文字列として扱い１００００件を実行した結果を以下に示します。
ソート時間 デバック １．６０４秒 ｅｘｅ ０．４２６秒
残念ながら配列変数（テーブル）にためこむロジックはエラーとなります。
omasuさん、自分のコードは実行してくれないのですね（泣）
しかたがないので、イグトランスさんのソートが早い理由を説明すると、
omasuさんのコードは、
ここで重要なのは、最初に指摘した通り
omasuさんのプログラムは、文字列をSwap
イグトランスさんは、文字列を指定するIndexをSwap
omasuさんのが最初に出したアルゴリズムでも、IndexをSwapする方法に変更すると劇的に性能が改善します。
今後性能を改善しようと思うと、CSVファイルの読込みから書込みまでの
全工程を見直す必要が出てくると思います。
ちなみに、最終提示したプログラムの処理性能は、
BubbleSort以外は処理時間（10ms未満）でしたのでファイルの入出力を含めたシステム性能(60ms前後)として計測しました。
P.S
配列の０からデータを設定しましたか？
配列の１からデータを設定していませんか？
[/quote]
しかたがないので、イグトランスさんのソートが早い理由を説明すると、
コード: 全て選択
If lstrcmp(KeyTable[Index[First]], KeyTable[Index[j]]) > 0 Then
(中略)
Swap(Index[Center], Index[First])
コード: 全て選択
If keytbl$(p1)>keytbl$(j) Then
(中略)
Swap keytbl$(i),keytbl$(p1)
Swap datatbl$(i),datatbl$(p1)
omasuさんのプログラムは、文字列をSwap
イグトランスさんは、文字列を指定するIndexをSwap
omasuさんのが最初に出したアルゴリズムでも、IndexをSwapする方法に変更すると劇的に性能が改善します。
コード: 全て選択
Dim Index(tblcnt)
For i=0 To tblcnt
Index(i)=i
Next
(中略)
If keytbl$(Index(p1))>keytbl$(Index(j)) Then
(中略)
Swap(Index, Index[p1])
今後性能を改善しようと思うと、CSVファイルの読込みから書込みまでの
全工程を見直す必要が出てくると思います。
ちなみに、最終提示したプログラムの処理性能は、
BubbleSort以外は処理時間（10ms未満）でしたのでファイルの入出力を含めたシステム性能(60ms前後)として計測しました。
P.S
今、結果の１行目が空白になってしまう原因を追求中です。
配列の０からデータを設定しましたか？
配列の１からデータを設定していませんか？
[/quote]
-
omasu
実行管理委員会の能力不足について
申し訳ありません。
マティさんへ
「実行してくれない」のではなく実行能力がないのが現状です。
条件
[AB4]プロジェクト・EXE - ノーマルウィンドウベース
コマンドを実行する為に、CommandButton1が必要です。
fLoad（処理対象のCSVファイルを指定する）
アクティブベーシック４．０のプロジェクトにボタンを作成、
イベントコードのイベントプロシージャにマティさんのコードを埋め込みました。
デバックを実行するも
MainWnd.sbp(31) - "TextSort_DestroyObjects" 無効な識別子です
かねてからソースレベルでの作成はしてきましたが、プロジェクトの概念がなく
ただいま勉強中でありますm(_ _)m
現在 自分が吸収、実行可能なロジックはソースのみとなっています。
申し訳ありません。
マティさんへ
「実行してくれない」のではなく実行能力がないのが現状です。
条件
[AB4]プロジェクト・EXE - ノーマルウィンドウベース
コマンドを実行する為に、CommandButton1が必要です。
fLoad（処理対象のCSVファイルを指定する）
アクティブベーシック４．０のプロジェクトにボタンを作成、
イベントコードのイベントプロシージャにマティさんのコードを埋め込みました。
デバックを実行するも
MainWnd.sbp(31) - "TextSort_DestroyObjects" 無効な識別子です
かねてからソースレベルでの作成はしてきましたが、プロジェクトの概念がなく
ただいま勉強中でありますm(_ _)m
現在 自分が吸収、実行可能なロジックはソースのみとなっています。
申し訳ありません。
Re: 実行管理委員会の能力不足について
> MainWnd.sbp(31) - "TextSort_DestroyObjects" 無効な識別子です
これは「プロジェクト名_DestroyObjects」と命名されます。
なのでプロジェクト名をTextSortにしていないとうまくいきません。
プロジェクト名が違う場合、自分で「プロジェクト名_DestroyObjects」に書き換えれば動くと思います。
ちなみに私が実行するとシェルソート1, 2もコムソートも50ミリ秒台、バブルソートは100ミリ秒台になりました。
（timeGetTimeを使うように修正してあります）
これは「プロジェクト名_DestroyObjects」と命名されます。
なのでプロジェクト名をTextSortにしていないとうまくいきません。
プロジェクト名が違う場合、自分で「プロジェクト名_DestroyObjects」に書き換えれば動くと思います。
ちなみに私が実行するとシェルソート1, 2もコムソートも50ミリ秒台、バブルソートは100ミリ秒台になりました。
（timeGetTimeを使うように修正してあります）
-
河川屋
イグトランスさんのクイックソートですが、やや効率が悪いです。
データ数１０００個の場合の比較回数、入替え回数を計測、数値は概数。
Keytable,Indexに関係するもののみをカウントし、単なる添字の比較はカウントせず）
イグトランスさんのクイックソート
比較回数 交換回数
ランダムデータ １１５００ ６９００
昇順データ ８０００ ５０００
降順データ ８６００ ５７００
私のクイックソート（ノーマル版）
比較回数 交換回数
ランダムデータ ７２００ ２６００
昇順データ ８０００ ５００
降順データ ７０００ １０００
参考１：シェル法（クヌース改）
比較回数 交換回数
ランダムデータ １４０００ １４０００
昇順データ ５５００ ５５００
降順データ ９４００ ９４００
参考２：単純挿入法
比較回数 交換回数
ランダムデータ ２５００００ ２５００００
昇順データ １０００ １０００
降順データ ５０００００ ５０００００
イグトランスさんのクイックソートのデータ交換回数が必要以上に多いため、
明らかに私のもの（＝解説本の標準版）より遅いです。
それでもシェル法よりはわずかに勝っていますが。
データ数１０００個の場合の比較回数、入替え回数を計測、数値は概数。
Keytable,Indexに関係するもののみをカウントし、単なる添字の比較はカウントせず）
イグトランスさんのクイックソート
比較回数 交換回数
ランダムデータ １１５００ ６９００
昇順データ ８０００ ５０００
降順データ ８６００ ５７００
私のクイックソート（ノーマル版）
比較回数 交換回数
ランダムデータ ７２００ ２６００
昇順データ ８０００ ５００
降順データ ７０００ １０００
参考１：シェル法（クヌース改）
比較回数 交換回数
ランダムデータ １４０００ １４０００
昇順データ ５５００ ５５００
降順データ ９４００ ９４００
参考２：単純挿入法
比較回数 交換回数
ランダムデータ ２５００００ ２５００００
昇順データ １０００ １０００
降順データ ５０００００ ５０００００
イグトランスさんのクイックソートのデータ交換回数が必要以上に多いため、
明らかに私のもの（＝解説本の標準版）より遅いです。
それでもシェル法よりはわずかに勝っていますが。
河川屋さんのコードを正しくインプリメントするとクイックの性能が計測できました。
自分が参考にしたコードが駄目だったようです。
再帰なし 880ms
再帰あり 1280ms（河川屋さんのコードを再帰ありに戻す）
再帰あり 1150ms（最適化２のみ適用）
と言うわけで、クイックの圧勝でした。
今回は非常に勉強になりました。ありがとうございます。
言い訳
googleでクイックソートを検索すると、他の方が投稿したような片側から詰める処理がほとんどでした。
両側から詰める方法も存在は知っていましたが、ネットで調べればすぐにコードも得られるだろうと思っていました。
なかなか落ちていないですね！
目標
日曜日からＤＢに書き込む処理を勉強しています。
まさか、ＯＤＢＣドライバの制御から勉強する必要があったなんて・・・。
コードを作成した記念にＵＰします。
自分が参考にしたコードが駄目だったようです。
再帰なし 880ms
再帰あり 1280ms（河川屋さんのコードを再帰ありに戻す）
再帰あり 1150ms（最適化２のみ適用）
と言うわけで、クイックの圧勝でした。
今回は非常に勉強になりました。ありがとうございます。
言い訳
googleでクイックソートを検索すると、他の方が投稿したような片側から詰める処理がほとんどでした。
両側から詰める方法も存在は知っていましたが、ネットで調べればすぐにコードも得られるだろうと思っていました。
なかなか落ちていないですね！
目標
日曜日からＤＢに書き込む処理を勉強しています。
まさか、ＯＤＢＣドライバの制御から勉強する必要があったなんて・・・。
コードを作成した記念にＵＰします。
ここをクリックするとコードが表示されます [ここをクリックすると内容が表示されます]
コード: 全て選択
Dim SL(100) As DWord 'Stack 計算上は19？
Dim SR(100) As DWord 'Stack 計算上は19？
'----------------------------------------------------------
'Quicksortノーマル版（非再帰）:河川屋さんベース
'----------------------------------------------------------
Sub QuickSort2(ByVal First As Long, ByVal Last As Long)
Dim i As long, j As long, S As long, L As long, R As long
Dim k As xCd, w As xCd
S=1 : SL(1)=First : SR(1)=Last
Do
L=SL(S) : R=SR(S) : S=S-1
Do
i=L : j=R : k = Cd((i+j)\2)
Do
While ((Cd(i).xKey1 < k.xKey1)) Or _
((Cd(i).xKey1 = k.xKey1) And (Cd(i).xKey2 < k.xKey2))
i=i+1
Wend
While ((k.xKey1 < Cd(j).xKey1)) Or _
((k.xKey1 = Cd(j).xKey1) And (k.xKey2 < Cd(j).xKey2))
j=j-1
Wend
IF i<=j Then
w= Cd(i) :Cd(i)=Cd(j) : Cd(j)=w
i=i+1 : j=j-1
End If
Loop Until i>j
IF i<R Then S=S+1 : SL(S)=i : SR(S)=R
R=j
Loop Until L>=R
Loop Until S=0
End Sub
コード: 全て選択
'----------------------------------------------------------
'Quicksortノーマル版（再帰版）:河川屋さんベース
'----------------------------------------------------------
Sub QuickSort(ByVal First As Long, ByVal Last As Long)
Dim i As Long
Dim j As Long
Dim k As xCd
Dim w As xCd
i=First : j=Last : k = Cd((i+j)\2)
Do
While ((Cd(i).xKey1 < k.xKey1)) Or _
((Cd(i).xKey1 = k.xKey1) And (Cd(i).xKey2 < k.xKey2))
i=i+1
Wend
While ((k.xKey1 < Cd(j).xKey1)) Or _
((k.xKey1 = Cd(j).xKey1) And (k.xKey2 < Cd(j).xKey2))
j=j-1
Wend
IF i<=j Then
w= Cd(i) :Cd(i)=Cd(j) : Cd(j)=w
i=i+1 : j=j-1
End If
Loop Until i>j
If (First < j) Then QuickSort(First, j)
If (i < Last) Then QuickSort(i, Last)
End Sub
コード: 全て選択
'----------------------------------------------------------
'Quicksortノーマル版（再帰版）:河川屋さんベース最適化２のみ
'----------------------------------------------------------
Sub QuickSort(ByVal First As Long, ByVal Last As Long)
Dim i As Long
Dim j As Long
Dim k As xCd
Dim w As xCd
i=First : j=Last : k = Cd((i+j)\2)
Do
While ((Cd(i).xKey1 < k.xKey1)) Or _
((Cd(i).xKey1 = k.xKey1) And (Cd(i).xKey2 < k.xKey2))
i=i+1
Wend
While ((k.xKey1 < Cd(j).xKey1)) Or _
((k.xKey1 = Cd(j).xKey1) And (k.xKey2 < Cd(j).xKey2))
j=j-1
Wend
IF i<=j Then
w= Cd(i) :Cd(i)=Cd(j) : Cd(j)=w
i=i+1 : j=j-1
End If
Loop Until i>j
If(First<j)Then If(j-First>10)Then QuickSort(First,j) Else InsertionSort(First,j)
If(i< Last)Then If(Last- i>10)Then QuickSort(i, Last) Else InsertionSort(i, Last)
End Sub
Sub InsertionSort(ByVal First,ByVal Last)
Dim i As Long
Dim j As Long
Dim k As xCd
For i=First+1 to Last
k=Cd(i)
For j=i-1 to First Step -1
If ((Cd(j).xKey1 < k.xKey1)) Or _
((Cd(j).xKey1 = k.xKey1) And (Cd(j).xKey2) <= k.xKey1) Then Exit For
Cd(j+1)=Cd(j)
Next
j=j+1:if(j<i)Then Cd(j)=k
Next
End Sub
最後に編集したユーザー マティ [ 2005年12月15日(木) 23:23 ], 累計 1 回
-
omasu
ありがとうございました。
実行テストもままならない「ソートロジック大会」なるテーマを掲げてしまい。
高度なロジックの投稿の数々、皆様には大変お世話になりました。
イグトランスさん、河川屋さん、マティさん、淡幻星さん、高信期さん
本当にありがとうございました。（搭乗者順）
また、１０００名以上の方々のフォーラム参照に満足しています。
（これで、最後にはしたくありません）
ＰｅｒｔⅡ主催者募集・・・＼（~O~）／
今回の「大会」なるものの、「実行管理委員会」を主催可能な実力者を募集します。
※そんな実力者は一番早い？
いつの日か、「私より早い・・・集合」で、・・・あくまで希望ですが・・・
高度なロジックの投稿の数々、皆様には大変お世話になりました。
イグトランスさん、河川屋さん、マティさん、淡幻星さん、高信期さん
本当にありがとうございました。（搭乗者順）
また、１０００名以上の方々のフォーラム参照に満足しています。
（これで、最後にはしたくありません）
ＰｅｒｔⅡ主催者募集・・・＼（~O~）／
今回の「大会」なるものの、「実行管理委員会」を主催可能な実力者を募集します。
※そんな実力者は一番早い？
いつの日か、「私より早い・・・集合」で、・・・あくまで希望ですが・・・
中間結果のご報告について
お世話になります。
あれから、ほとんどのロジックを実行できなかった心残りで、
試行錯誤を繰り返してきました。
中間結果報告という形で、ご報告申し上げます。
実行環境
Ｃｐｕ Ｐｅｎｔｉｕｍ４ 周波数２．６６ＧＨｚ メモリ２５６ＭＢyte
テストｃｓｖファイル
５桁のランダム数字を文字列として使用
テストデータイメージ
キー列 １列目と２列目を連結
データ列数 ２６列
実行アクティブベーシック Ｖｅｒ．４．１．β２ 最新版
作成者 ソート名称 1000件/秒 5000件/秒 10,000件/秒 65,536件/秒
河川屋さん クイックﾉｰﾏﾙ版 0.080 0.220 0.311 1.482
河川屋さん クイック改１ 0.080 0.190 0.331 1.492
河川屋さん クイック改２ 0.092 0.200 0.350 1.502
マティさん コーム 0.080 0.210 0.320 1.863
イグトランスさん クイック 0.040 0.240 0.551 4.440
河川屋さん 改シェル法 0.150 0.831 2.002 17.956
omasu 単純選択法 1.402 36.633 145.559 6313.448
淡幻星さん クイック ごめんなさい、もう少し、お待ちください m(_ _)m
自分も数万件のソートが可能となりました。
しかし、まちくたびれました・・・
あれから、ほとんどのロジックを実行できなかった心残りで、
試行錯誤を繰り返してきました。
中間結果報告という形で、ご報告申し上げます。
実行環境
Ｃｐｕ Ｐｅｎｔｉｕｍ４ 周波数２．６６ＧＨｚ メモリ２５６ＭＢyte
テストｃｓｖファイル
５桁のランダム数字を文字列として使用
テストデータイメージ
コード: 全て選択
26859,31003,37839,74441,25822,29003,54011,19579,72420,27675,25111,12762,55130,49720,97371,20405,52912,64265,80288,55299,39913,14589,75082,44182,45705,92357
60841,91092,77067,79925,28514,36197,16786,89574,31012,26270,75320,78494,32872,23085,43516,55354,12531,60530,20124,15771,77757,75784,54270,40216,15173,10227
67670,74412,73156,20065,84922,31690,98540,90588,57296,60254,21653,52591,41306,16425,19665,29547,56820,36166,93903,82901,64051,12796,67288,69641,34454,34565
21540,27936,87912,73621,10468,95213,88320,64498,86489,76019,17807,19912,74595,66107,80508,37801,97051,81810,96331,41196,92766,11529,56718,37673,13557,19144
データ列数 ２６列
実行アクティブベーシック Ｖｅｒ．４．１．β２ 最新版
作成者 ソート名称 1000件/秒 5000件/秒 10,000件/秒 65,536件/秒
河川屋さん クイックﾉｰﾏﾙ版 0.080 0.220 0.311 1.482
河川屋さん クイック改１ 0.080 0.190 0.331 1.492
河川屋さん クイック改２ 0.092 0.200 0.350 1.502
マティさん コーム 0.080 0.210 0.320 1.863
イグトランスさん クイック 0.040 0.240 0.551 4.440
河川屋さん 改シェル法 0.150 0.831 2.002 17.956
omasu 単純選択法 1.402 36.633 145.559 6313.448
淡幻星さん クイック ごめんなさい、もう少し、お待ちください m(_ _)m
自分も数万件のソートが可能となりました。
しかし、まちくたびれました・・・