ソートロジック大会

メッセージ

omasu

お世話になります。

イグトランスさんのコードを実用化（利用・借用・横領？）(~O~)したいと思います。

ＣＳＶファイルのキーを１列目と２列目とする前提条件を
　もし、仮に２列目、１列目、４列目、３列目をキーとする
　　条件にした場合、どのようなコーディングをすればよいかを教えてください。

エクセルでのソートキーは３列までしか対応していません
　もし、可能であればソートキー列を前段の定義で指定できれば
　　SortKey(2,1,4,3)とか
　　非常に実用的なプログラムが作成可能です。

コード: 全て選択

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
        End If
    End If
    GetKeyPart$ = str
End Function

淡幻星

≫omasuさん
不完全なプログラムを投稿したまま放置した形になってしまい、すいません。
あの後、私事でちょっとテンパッテまして、
ここ半月くらいABにさっぱり触れていないもので、
Ver3.x以降への移植も、テストも、レスも何も出来ませんでした。
この後のもう１週間以上は触れられそうに無いです･･･。

さて、本題なのですが
> ごめんなさい、もう少し、お待ちください　m(_ _)m
のヒトコトに、もう大変恐縮している次第でございます。
や、もう本当にスイマセンｍ(_　_)ｍ
私のクイックソートのコードは、１年以上前に
「とりあえず動くからこれでいいや」の気持ちで、
初めて組んだソート関数なので、
クイックソート初構築の際に参考になればと思い投稿しただけで、
速度計測大会に参加できるような立派な品物ではありません。

そんなわけで、他の皆様方のコードに比べて、
速度はそんなに期待できないと思いますので、
Ver4.xへの移植＆テストは大変ですから、
わざわざしてくださらなくても結構ですよ（苦笑）。
私自身さっぱりしていないのに、そこまで手を煩わすのは気が引けます。

Ｃのサンプルを基にとりあえず移植して、
デバックしながらどうにかクイックのアルゴリズムを理解した、
そんなレベルです。そのまま放置中のコードです（汗）。

そのうえ、Ver2.xの曖昧性を利用＆小規模データ（4096件くらいまで）ソートを
前提にしていますので、厳密になったVer3.x以降＆
大規模データソートへの移植はあちこち書き換える必要が
あるので、面倒だと思いますし。
実際問題としては、そのうち移植を行おうと思っているのですが、
今現在そこまで必要性がないことと、これだけ他の方の優秀な
コードが出揃ってしまったいるので、そのまま利用させていただこうかと
思うこともあり、延ばし延ばしになっていますｆ（＾＾；）

≫河川屋さん
ずいぶん前の投稿へのレスになりますが。
> クイックが不当な評価を
どうも不快感を与えてしまったようです、すいません。
私自身はクイックを批判するどころか、むしろ一番好んでますよ？
だから「王道」と言ったのですからｗ

マティ

自分の方法でよければ・・・複数行に対応したコードをホームページに乗せてあります。

ちなみに、例題で出ていた２列目、１列目、４列目、３列目をキーとするソートをエクセルで、実行するなら
３列目をソート後、（２，１，４）列目をソートします。
この方法なら何列でもソート可能です。

私の環境では、データ数が２７万件もあるので、エクセルでは処理不能なのでプログラム化しています。

大変お待たせいたしました。これでどうでしょうか。
全体的に修正しているので、ほぼ全てのコードを載せてあります。長々としていて申し訳ありません。

[ここをクリックすると内容が表示されます]

コード: 全て選択

#strict
#prompt

'前回のtime～関数とCharNextのDeclareをここに
'前回のOwnerWnd関数をここに

Const INFILE = "z:\infile.csv"
Const OUTFILE = "z:\outfile.csv"

TypeDef PPCHAR = *BytePtr

Dim hHeap As HANDLE

Sub GetKeyRows(pp As PPCHAR, str As String, StrPos As DWord, Rows As *DWord, RowsIndex As *DWord, ArrayNum As Long)(CurrentRow As DWord)
	If Len(str) = 0 Or ArrayNum < 0 Then
		Exit Function
 	End If
	Dim NextRow As DWord
	NextRow = InStr(StrPos, str, ",")
	If NextRow = 0 Then
		NextRow = Len(str) + 1
	End If
	If Rows[RowsIndex[0]] = CurrentRow Then
		pp[0] = StrDupS(Mid$(str, StrPos, NextRow - StrPos)) As DWord
		ArrayNum = ArrayNum - 1
		RowsIndex = VarPtr(RowsIndex[1])
		pp = VarPtr(pp[1])
	End If
	GetKeyRows(pp, str, NextRow + 1, Rows, RowsIndex, ArrayNum, CurrentRow + 1)
End Sub

Function CreateKey(str As String, KeyRows As *DWord, KeyRowsIndex As *DWord, Num As DWord) As *Byte
	Dim SortKeys As PPCHAR, Size As DWord, i As DWord
	Size = (Num + 1) * SizeOf (DWord)

	SortKeys = HeapAlloc(hHeap, 0, Size)
	GetKeyRows(SortKeys, str, 1, KeyRows, KeyRowsIndex, Num)
	Dim Buffer As StrApending, FreeBufferSize = 1024 As DWord
	For i = 0 To Num
		Buffer.PushBack(SortKeys)
		Buffer.PushBack(",")
	Next
	CreateKey = Buffer.Ptr()
	CreateKey[Buffer.Size() - 1] = 0
End Function

Function CreateKeyIndex(KeyRows As *DWord, Num As DWord) As *DWord
	Dim KeyRowsIndex As *DWord
	Dim Size As DWord, i As DWord
	Size = (Num + 1) * SizeOf (DWord)
	KeyRowsIndex = HeapAlloc(hHeap, 0, Size)
	For i = 0 To Num
		KeyRowsIndex = i
	Next
	SortIndex(KeyRowsIndex, KeyRows, Num)
	CreateKeyIndex = KeyRowsIndex
End Function

Sub SortIndex(KeyRowsIndex As *DWord, KeyRows As *DWord, Num As DWord)
	Dim i As DWord, j As DWord
	For i = 1 To Num
		For j = i To 0 Step -1
			If KeyRows < KeyRows[j - 1] Then
				Swap_dw(KeyRowsIndex[j], KeyRowsIndex[j - 1])
			End If
		Next
	Next
End Sub

'前回のGetLine関数をここに

Function StrDupS(str As String) As BytePtr
	Dim Size As DWord
	Size = Len(str) + 1
	StrDupS = HeapAlloc(hHeap, 0, 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 = HeapAlloc(hHeap, 0, FileSize + 1)
	FileRead[FileSize] = 0
	ReadFile(hInputFile, FileRead, FileSize, VarPtr(dwReadSize), ByVal 0)
	CloseHandle(hInputFile)
End Function

Class StrApending
Public
	Sub StrApending()(InitSize As DWord)
		If InitSize = 0 Then
			InitSize = 1024
		End If
		FreeSize = InitSize
		UsedSize = 0
		ptr = HeapAlloc(hHeap, 0, InitSize)
	End Sub

	Sub PushBack(psz As *Byte)
		If psz = 0 Then Exit Sub
		PushBackMem(psz, lstrlen(psz))
	End Sub

	Sub PushBackStr(str As String)
		PushBackMem(StrPtr(str), Len(str))
	End Sub

	Function Ptr() As *Byte
		ptr[UsedSize] = 0
		Ptr = ptr
	End Function

	Function Size() As DWord
		Size = UsedSize
	End Function

	Function ToString() As String
		ToString = ZeroString(UsedSize)
		memcpy(StrPtr(ToString), ptr, UsedSize)
	End Function
Private
	Sub PushBackMem(p As *Byte, Size As DWord)
		If FreeSize <= Size Then
			FreeSize = FreeSize + Size
			ptr = HeapReAlloc(hHeap, 0, ptr, UsedSize + FreeSize)
		End If
		memcpy(ptr + UsedSize, p, Size)
		UsedSize = UsedSize + Size
	End Sub

	ptr As *Byte
	UsedSize As DWord
	FreeSize As DWord
End Class

コード: 全て選択

'-----------------------------------------------------------------------------------------------------------------------
'	ここからプログラム開始
Const ArraySize = ELM(2)
Randomize

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, 1048576, 0)
If hHeap = 0 Then
	End
End If

' ファイル読み込み
Dim pInputBuffer As BytePtr
pInputBuffer = FileRead(INFILE)
If pInputBuffer = 0 Then
	Goto *ProgramEnd
End If

Const RowsNum = 3
Dim KeyRows[RowsNum] = [2, 1, 4, 3] As DWord

timeBeginPeriod(1)
' 行単位へ分解

Dim strCurrentLine As String, KeyIndex As *DWord
Dim dwStartTime As DWord, dwEndTime As DWord
dwStartTime = timeGetTime()
KeyIndex = CreateKeyIndex(KeyRows, RowsNum)
For i = 0 To TableSize
	strCurrentLine = GetLine(pInputBuffer)
	KeyTable = StrDupS(CreateKey(strCurrentLine, KeyRows, KeyIndex, RowsNum))'GetKeyPart$(strCurrentLine))
	DataTable = StrDupS(Str$(i) + "," + strCurrentLine)
	Index = i
	If pInputBuffer = 0 Then
		Exit For
	End If
Next
DataSize = i
dwEndTime = timeGetTime()
Print "stock start", dwStartTime
Print "stock end", dwEndTime
Print "stock time", dwEndTime - dwStartTime
' ソート
'ここからは元のコードのまま
'Sort関数とQuickSort4Main関数も前回と変わらずここに。

キー列の指定はKeyRowsの配列で行っています。

入力文字列を順に走査していけるよう、それをCreateKeyIndexに渡し、ソートされたインデックスを作っています。
そして各行毎にCreateKey関数でKeyを生成しています。CreateKeyの中で呼んでいるGetKeyRows関数がカンマ毎に文字列を走査してキー列なら取り出すという操作をしています。

問題は肝心のソート処理より時間がかかってしまうことです。別アプローチをとるべきなのかもしれません。

更にクイックソートも私のより河川屋さんやマティさんがより速いコードを載せていたのも気になります。

H17.11.26
コードが長いのでhideを使用するように修正いたしました。

マティ

自分も、パラメータ指定によるソートを作成しましたので、報告します！
全機能で２７６ラインありますので、ソースの公開はホームページで行いたいと思います。

呼び出し例（パラメータの渡し方はイグトランスさんを参考にしました）
列番号に正の数を指定すると、数値（整数）としてソート、負の数を指定すると、文字列としてソート

コード: 全て選択


Dim KeyRows[2]=[-4,2] As Char
SortKeys( 2, KeyRows )                            'キー指定
CSVSort("c:\csv\infile.csv","c:\csv\outfile.txt") 'ソート実行

列指定方法は逆がよかったかな？
ここまでは、実装しましたが・・・
昇順／降順の対応はどうしようかな・・・パラメータ指定方法の問題もあるし・・・

Zgock

今回のテストデータのように、「桁数固定」の場合、
ラディックスソートも有効な気がしますね。
ちょっとコード起こしてみます。
（ActiveBasic触ったことないので、これから触って見ますね（汗

マティ

ヒープソートとクイックソートの動作状況を解説してみましたが、あっているでしょうか？
ヒープ
クイック
アドバイスお願いします。

omasu

イグトランスさん、マティさん、早速の対応ありがとうございます。

＜ＣＳＶファイルのキーを１列目と２列目とする前提条件を
＜　もし、仮に２列目、１列目、４列目、３列目をキーとする
＜　　条件にした場合、どのようなコーディングをすればよいかを教えてください。

使用状況のご報告は今しばらく、お待ちください。

フォーラムのテーマについて

　①．マティさんのヒープとクイックの動作状況ですが、これから本格的に勉強していきたいと思います。
　②．Ｚｇｏｃｋさんのラディックスソートに大変興味があります。
　③．淡幻星さん、もし時間が出来ましたら、最速ロジックの提供をお願いします。
　④．マティさんのホームページに載っていた、ソートロジックをすべて実行をしてみたいです。（でもまだ実力不足です）

中間結果報告Ⅱについて
前回、報告したアクティブベーシックが最新版と思っていたら、もう４．１０が
出ていました。早速ダウンロード、しかし、実行速度に違いがあるような？。

自分も試行錯誤により、いろいろなロジックを組んでいました。

ここをクリックすると実行速度比較が表示されます。 [ここをクリックすると内容が表示されます]

コード: 全て選択

実行環境　　　　　　　Ｃｐｕ　Ｐｅｎｔｉｕｍ４　周波数２．６６ＧＨｚ　メモリ２５６ＭＢ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

Ｖｅｒ．４．１０　最新版　　　　　　　　　　　　　　データ件数／秒
作成者　　　　　　　　ソート名称　　　　　　　　　　　１，０００　　　５，０００　　　１０，０００　　　５０，０００　　　１００，０００　　　５００，０００　　　記事

河川屋さん　　　　　　（ＰＪ）クイック（改２）　　　　０．０８０　　　０．１４０　　　　０．２７１　　　　０．８０１　　　　　１．１４２　　　　　６．２４９　　　クイック最速（順位不定）
河川屋さん　　　　　　（ＰＪ）クイック（改１）　　　　０．０２０　　　０．１３０　　　　０．１７０　　　　０．７３２　　　　　１．１５１　　　　　６．４５９　　　クイック最速（順位不定）
河川屋さん　　　　　　（ＰＪ）クイック（ノーマル版）　０．１３０　　　０．１６０　　　　０．２１０　　　　０．８３１　　　　　１．１９２　　　　　７．０６０　　　クイック最速（順位不定）
マティさん　　　　　　（ＰＪ）コーム　　　　　　　　　０．０１０　　　０．０６０　　　　０．１２０　　　　０．５８１　　　　　１．６４３　　　　　８．５０２　　　コーム最速
イグトランスさん　　　クイック　　　　　　　　　　　　０．０４０　　　０．２４１　　　　０．５２１　　　　３．２３５　　　　　６．７０９　　　　４２．０８１
ｏｍａｓｕ　　　　　　シェル（挿入法＋クヌース先生）　０．０４０　　　０．３２０　　　　０．７０１　　　　４．８４７　　　　１２．７３８　　　　４３．７７３　　　シェル最速
河川屋さん　　　　　　シェル（クヌース先生改）　　　　０．１７０　　　０．８２１　　　　２．００３　　　１３．０７９　　　　３０．９６４　　　２３３．６３６
ｏｍａｓｕ　　　　　　単純挿入法（バイナリサーチ）　　０．０８０　　　０．８１１　　　　２．８９５　　　６５．５９５　　　２６１．５７６　　　―――――――　　　単純挿入法最速
ｏｍａｓｕ　　　　　　シェル（選択法）　　　　　　　　０．３８１　　　４．７４７　　　１３．７７０　　１７７．３０５　　　―――――――　　　―――――――
ｏｍａｓｕ　　　　　　単純挿入法　　　　　　　　　　　０．８６２　　１８．７７８　　　７７．０３１　　　――――――　　　―――――――　　　―――――――
ｏｍａｓｕ　　　　　　シェーカー（バブル）　　　　　　１．１９１　　２７．８８０　　１１６．２３７　　　――――――　　　―――――――　　　―――――――　　　シェーカー最速
ｏｍａｓｕ　　　　　　単純選択法　　　　　　　　　　　１．４３２　　３６．６０３　　１４３．６３２　　　――――――　　　―――――――　　　―――――――　　　単純選択法最速
ｏｍａｓｕ　　　　　　バブル　　　　　　　　　　　　　１．４８２　　３８．２１５　　１５０．５６７　　　――――――　　　―――――――　　　―――――――　　　バブル最速
Ｚｇｏｃｋさん　　　　ラディックス　　　　　　　　　　＼（＾ｏ＾）／　期待しております。
　　　　　　　　　　　マージ　　　　　　　　　　　　　安定性を求める場合はマージ？（キーが同一の場合、最初のデータが先にくる？　ｆｉｆｏ）
　　　　　　　　　　　ヒープ　　　　　　　　　　　　　難しいのかな？

　　　　　イグトランスさんの５０万件ソートがもっと早い事を確認、訂正済み、他順次更新の都度変更していきます。

追伸１：
　①．一番遅いはずの、バブルの進化がクイックソート？。
　②．シェルソートは、選択法で作ると遅い、挿入法だとなぜか早い。
　③．単純挿入法はバイナリサーチで挿入ポイントを決めると早い。
　④．５０万件のソートは毎回、ＰＣがフリーズする（メモリ不足）

追伸２：
　①．基本的なソートやシェルソート（挿入法）の作成で夢中になっていました。
　　　１０００件ソートテストで４０ｍＳが出たときは、また失敗しちゃったと思いました。
　　　テスト結果をみて、また、びっくり、ソートできてる。

　ギャップのとり方は河川屋さんのを「ぱくり」ました。（ギャップの決め方で速度がかなり違う）
　本体はイグトランスさんのを「ぱくり」ました。
　ごめんなさい。m(_ _)m

ホンとかどうかコードを見てください。

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim Bunkatu As Long
    Bunkatu=4
    While Bunkatu<=E
          Bunkatu=3*Bunkatu+1
    Wend
    Do
        Bunkatu=(Bunkatu-1)\3
        For i=0 To Bunkatu-1
            For j=i+Bunkatu To E Step Bunkatu
                For k=j to i+Bunkatu Step -Bunkatu
                    If lstrcmp(KeyTable[Index[k]],KeyTable[Index[k-Bunkatu]])<0 Then ' 指定した２つの文字列を比較(大文字、小文字を区別)→２倍以上早い
                       Swap(Index[k],Index[k-Bunkatu])
                    Else
                       Exit For
                    EndIf
                Next k
            Next j
        Next i
    Loop Until Bunkatu=1
End Sub

他の方もいろんなロジックを教えてください。(~o~)
　　　「バブルがこんなに遅いはずはない」でも結構です。

マティ

omasuさん確認したいことがあります。
ＡＢで、文字列配列を作成すると1000から2000程度で実行不能になりますが、どのように対応しているのでしょうか？
私は、このコミュニティで正常動作するクイックソートの実装方法がわかってからは、クイック派になっています。
あと、バブルソートの進化系はコームソートですよ！

コード: 全て選択


#include "CsvSort3.sbp"          '最新の（ファイル書込を含む）ソートロジック
Dim KeyRows[3]=[-4,2,-3] As char 'ソートキーの指定(列を指定します。＋数値列、－文字列)
SortKeys( 2, KeyRows )           '使用するキーの数と、パラメータの配列を渡します。
CSVSort("c:\csv\infile.csv","c:\csv\outfile.txt")  'ソートの実行

ファイルはホームページのＣＳＶソートのLevel3(.sbp)をcsvsort3.sbpとしてご使用ください。

omasu

お世話になります。

> ＡＢで、文字列配列を作成すると1000から2000程度で実行不能になりますが、どのように対応しているのでしょうか？

　私は、数万件の文字列定義が可能だったａｂ２．６２世代（正確にはＮ８８Ｂａｓｉｃ）ですので、
　ａｂ４．ｘｘになってから、たった１０００件の定義で実行不能になるのは解せないと、
アクティブベーシックのバグ報告にも掲載しましたが、今だ解決に至っておりません。

　今回のソートロジック大会で、マティさんやイグトランスさんのソートロジックと同時に、
　ファイル取得方法や、配列へのセット方法も吸収しているところです。

　プロジェクトのテストはマティさんの母体を利用
　ソースレベルでのテストはイグトランスさんの母体を利用させてもらっています。
（了承なしですが）

　各種のソートや、シェルソートでのテストで使った母体はイグトランスさんのものです。
　自分が一番最初に提示した、イントネーション・ディテールを忠実に再現してくれたのもイグトランスさんです。
　いろいろなロジックを組めるのもマティさんや、イグトランスさんのおかげです。

　自分なりに解るように全体のコードを整理した、プログラム全体を提示します。ソートのブロックのみの加工で作成可能です。
（イグトランスさんには了承なしですが）

[ここをクリックすると内容が表示されます]

コード: 全て選択

'********************************************************************************
'* ＣＳＶファイル　ソートプログラム
'********************************************************************************
'
#strict ' コンパイルの際に型チェックが厳密に行われるようになります。
#prompt ' #include <basic\prompt.sbp> , #N88BASIC でも可
'
Declare Function timeGetTime Lib "winmm.dll" () As DWord
Declare Function CharNext Lib "User32" Alias "CharNextA" (psz As BytePtr) As BytePtr
'
Const SubWndTitle$="ソート" '			メッセージタイトル
Const infile$="infile500000.csv" '		入力ファイル名定義（フルパス指定、省略時はカレント）
Const outfile$="outfile.csv" '			出力ファイル名定義（フルパス指定、省略時はカレント）
Const TableSize=510000 '				データ最大件数定義
'
' グローバル領域変数定義
'
Dim hHeap As HANDLE
Dim KeyTable[TableSize] As BytePtr,DataTable[TableSize] As BytePtr,Index[TableSize] As Long,DataSize As Long
Dim StartTime1 As DWord,EndTime1 As DWord,StartTime2 As DWord,EndTime2 As DWord
Dim hInputFile As HANDLE
Dim FileSize As DWord,dwReadSize As DWord
Dim pInputBuffer As BytePtr
Dim strCurrentLine As String
Dim i As Long,j As Long,k As Long,l As Long
'
'********************************************************************************
'* プログラム開始
'********************************************************************************
'
Function OwnerWnd() As HWND
         OwnerWnd=_PromptSys_hWnd
End Function
If MessageBox(OwnerWnd(),"ソート処理を実行します。よろしいですか？",SubWndTitle$,MB_YESNO or MB_ICONINFORMATION)=IDNO Then
   Goto *ProgramEnd
End If
hHeap=HeapCreate(HEAP_NO_SERIALIZE,131072,0)
If hHeap=0 Then
   End
End If
StartTime1=timeGetTime()
Print "program start",StartTime1-StartTime1
Print
'
'********************************************************************************
'* ファイルリード
'********************************************************************************
'
StartTime2=timeGetTime()
Print "read start",StartTime2-StartTime1
'
' ファイルリード（プロシージャ）
'
Function FileRead(FileName As BytePtr) As BytePtr
         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
         FileSize=GetFileSize(hInputFile,0)
         FileRead=malloc(FileSize+1)
         FileRead[FileSize]=0
         ReadFile(hInputFile,FileRead,FileSize,VarPtr(dwReadSize),ByVal 0)
         CloseHandle(hInputFile)
End Function
'
' ファイルリード
'
pInputBuffer=FileRead(infile$)
If pInputBuffer=0 Then
   Goto *ProgramEnd
End If
'
' ファイルリード終了
'
EndTime2=timeGetTime()
Print "read end",EndTime2-StartTime1,"ファイルリード時間:",(EndTime2-StartTime2)/1000;"秒"
Print
'
'********************************************************************************
'* データストック
'********************************************************************************
'
StartTime2=timeGetTime()
Print "stock start",StartTime2-StartTime1
'
' 行単位に分解抽出（プロシージャ）
'
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 GetKeyPart$(ByVal str As String) As String
         Dim PartA As Long,PartB As Long
         PartA=InStr(1,str,",")
         If PartA>0 Then
            PartB=InStr(PartA+1,str,",")
         End If
         GetKeyPart$=str
End Function
'
' 行単位に分解・キーテーブルストック・データテーブルストック
'
For i=0 To TableSize
    strCurrentLine=GetLine(pInputBuffer)
    KeyTable=StrDupS(GetKeyPart$(strCurrentLine))   ' KeyTableにキーストック
    DataTable=StrDupS(Str$(i+1)+","+strCurrentLine) ' DataTableにデータストック
    Index=i
    If pInputBuffer=0 Then
       Exit For
    End If
Next
free(pInputBuffer)
DataSize=i-1
'
' データストック終了
'
EndTime2=timeGetTime()
Print "stock end",EndTime2-StartTime1,"データストック時間:",(EndTime2-StartTime2)/1000;"秒"
Print
'
'********************************************************************************
'* ソート
'********************************************************************************
'
StartTime2=timeGetTime()
Print "sort start",StartTime2-StartTime1
'
' ソート
'
Sort(0,DataSize)
'
EndTime2=timeGetTime()
Print "sort end",EndTime2-StartTime1,"　　　　ソート時間:",(EndTime2-StartTime2)/1000;"秒"
Print
'
' ソートプロシージャ
'
Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim Bunkatu As Long
    Bunkatu=4
    While Bunkatu<=E
          Bunkatu=3*Bunkatu+1
    Wend
    Do
        Bunkatu=(Bunkatu-1)\3
        For i=0 To Bunkatu-1
            For j=i+Bunkatu To E Step Bunkatu
                For k=j to i+Bunkatu Step -Bunkatu
                    If lstrcmp(KeyTable[Index[k]],KeyTable[Index[k-Bunkatu]])<0 Then ' 指定した２つの文字列を比較(大文字、小文字を区別)→２倍以上早い
                       Swap(Index[k],Index[k-Bunkatu])
                    Else
                       Exit For
                    EndIf
                Next k
            Next j
        Next i
    Loop Until Bunkatu=1
End Sub
'
' スワッププロシージャ
'
Sub Swap(ByRef x As Long,ByRef y As Long)
    Dim temp As Long
    temp=x
    x=y
    y=temp
End Sub
'
'********************************************************************************
'* ソートしたテーブルをファイルに出力
'********************************************************************************
'
StartTime2=timeGetTime()
Print "file out start",StartTime2-StartTime1
'
Open outfile$ For Output As #2
For i=0 To DataSize
    Print #2,MakeStr(DataTable(Index))
Next i
Close
'
EndTime2=timeGetTime()
Print "file out end",EndTime2-StartTime1,"ファイルアウト時間:",(EndTime2-StartTime2)/1000;"秒"
Print
'
'********************************************************************************
'* プログラム終了確認
'********************************************************************************
'
EndTime1=timeGetTime()
Print "program end",EndTime1-StartTime1,"プログラム実行時間:",(EndTime1-StartTime1)/1000;"秒"
Print
HeapDestroy(hHeap)
'
*ProgramEnd
MessageBox(OwnerWnd(),"ソート処理が終了しました。",SubWndTitle$,MB_OK or MB_ICONINFORMATION)
End

2005/10/29記述にバグ発見修正しました。AB4.10.02以降
2005/12/17致命的なバグがあります。、利用される方はこちらを
http://www.discoversoft.net/forum/viewt ... =2509#2509

omasu

お世話になります。

　前回、テストデータの掲示に失敗したため、テストデータ作成プログラムを起こしました。

　６５５３６件まではエクセルでテストデータを作っていたのですが、
高度なロジックの投稿から１０万件、５０万件・・・のテストデータが必要となりました。

　愛機の環境では、５０万件のソートが限界です、１００万件のテストはできません。
　まだ、実行件数や、実行速度に余裕のあるロジックがあることに驚かされます。

ノンメッセージのため、実行中か、終わったのかどうかわかりませんが・・

[ここをクリックすると内容が表示されます]

コード: 全て選択

'**************************************************************************
'*　テストデータ作成　ＣＳＶファイル出力
'**************************************************************************
'
'　変数定義
'
Dim TestData$ As String
Dim i As Long
Const DataCount=1000 ' 件数指定のみで”ｉｎｆｉｌｅｘｘｘｘ．ｃｓｖ”ファイル作成（カレント）
'
'　ファイルオープン
'
Open "infile"+Str$(DataCount)+".csv" For Output As #1
'
'　テストファイル作成
'
For i=1 To DataCount
    TestData$=Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","+Str$(Int(Rnd()*90000)+10000)+","
    Print #1,TestData$
Next i
'
'　ファイルクローズ
'
Close #1
End

追伸：注意事項
　　　５０万件のソートは、常駐プログラムを全て終了させ、メモリをクリーニングした後、実行しないと簡単にフリーズします。
　　　メモリ増設の必要性を感じます。

omasu

お世話になります。

自分が試行錯誤により、作成したロジックを提示します。（Ｓｗａｐプロシージャは含みません。）
実行については「2005年09月25日(日)」の「マティさんに返信」のソート部を入替えてください。
もっと早い記述法があるのかもしれません。
コームソートやクイックソートもこれから手がけます

①．バブルソート

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim P As Long
    Do
       P=0
       For i=E To S+1 Step -1
           If lstrcmp(KeyTable[Index],KeyTable[Index[i-1]])<0 Then
              Swap(Index,Index[i-1])
              P=i ' ソートが完了していることを見つける番人をおいています。
           EndIf
       Next i
       S=S+1
   Loop Until P=0
End Sub

②．単純選択法ソート

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim P As Long
    For i=S To E-1
        P=i
        For j=i+1 To E
            If lstrcmp(KeyTable[Index[P]],KeyTable[Index[j]])>0 Then
               P=j
            EndIf
        Next j
        If P<>i Then
           Swap(Index,Index[P])
        EndIf
    Next i
End Sub

③．シェーカーソート（バブル）

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim P As Long
    Do
       P=0
       For i=S To E-1
           If lstrcmp(KeyTable[Index],KeyTable[Index[i+1]])>0 Then
              Swap(Index,Index[i+1])
              P=i
           EndIf
       Next i
       If P=0 Then
          Exit Do
       EndIf
       E=E-1
       P=0
       For i=E To S+1 Step -1
           If lstrcmp(KeyTable[Index],KeyTable[Index[i-1]])<0 Then
              Swap(Index,Index[i-1])
              P=i
           EndIf
       Next i
       If P=0 Then
          Exit Do
       EndIf
       S=S+1
   Loop
End Sub

④．単純挿入法ソート

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    For i=S+1 To E
        For j=i To S+1 Step -1
            If lstrcmp(KeyTable[Index[j]],KeyTable[Index[j-1]])<0 Then
               Swap(Index[j],Index[j-1])
            Else
               Exit For
            EndIf
        Next j
    Next i
End Sub

⑤．単純挿入法ソート（バイナリサーチ）

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim Left As Long,Mid As Long,Right As Long
    Dim Hikaku As Long
    For i=S+1 To E
        Left=0:Right=i-1
        Do
           Mid=(Left+Right)\2
           Hikaku=lstrcmp(KeyTable[Index[Mid]],KeyTable[Index])
           If Hikaku<=0 Then
              Left=Mid+1:Mid=Left
           Else
              If Hikaku>0 Then
                 Right=Mid
              EndIf
           EndIf
        Loop Until Left>=Right
        If i-1<>Mid Then ' 一件目対策
           For j=i To Mid+1 Step -1
               Swap(Index[j],Index[j-1])
           Next j
        EndIf
    Next i
End Sub

⑥．シェルソート（挿入法）

[ここをクリックすると内容が表示されます]

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim Bunkatu As Long
    Bunkatu=4
    While Bunkatu<=E
          Bunkatu=3*Bunkatu+1
    Wend
    Do
        Bunkatu=(Bunkatu-1)\3
        For i=0 To Bunkatu-1
            For j=i+Bunkatu To E Step Bunkatu
                For k=j to i+Bunkatu Step -Bunkatu
                    If lstrcmp(KeyTable[Index[k]],KeyTable[Index[k-Bunkatu]])<0 Then
                       Swap(Index[k],Index[k-Bunkatu])
                    Else
                       Exit For
                    EndIf
                Next k
            Next j
        Next i
    Loop Until Bunkatu=1
End Sub

マティ

9/29：クイックソート部分にバグがあります！修正版は次に投稿します。

性能はたいした事はないのですが、８００万件のテストデータ（1.17GB）をソート出来たので報告します。
前提条件
テストデータと同様に、固定長で固定ピッチである事！
ホストコンピュータ又はCOBOLで作成したデータをソートする用途向きの簡略版です。？
教えて
このソートのアルゴリズム名は何って言います？自分で適当に作ったので・・・
マージソートでは無いのは分かるのですが・・・

ここをクリックするとコードが表示されます [ここをクリックすると内容が表示されます]

コード: 全て選択


Declare Function timeGetTime Lib "winmm.dll" () As Long
'#Strict
Const LineLength = 158		'一行のバイト数
Const xReSort=1000			'まとめてソートする行数
Dim SortIndex[xReSort] As Integer
Dim SortText[xReSort]  As String

Dim SortKey[100]=[1,2,3,4,5,7,8,9,10,11,-1] As Char	'列位置指定(-1で終了) 

Dim StartTime  As  Long
Dim   EndTime  As  Long
Dim   xInFile  As  String
Dim  xOutFile  As  String
Dim xWorkFile  As  String
Dim StrBuf     As  String
Dim i          As  Integer
'   ---------------------------------------------
'     バッファーの初期化
'   ---------------------------------------------
	StrBuf = ZeroString(LineLength)
	For i=0 To xReSort
		SortText = ZeroString(LineLength)
	Next
'   ---------------------------------------------
'     初期値を設定
'   ---------------------------------------------
	  xInFile = "..\infile8000000.csv"
	 xOutFile = "OutPut.csv"
	xWorkFile = "c:\tmp\marg"
	kill xOutFile		'旧ファイルを消す.
'   ---------------------------------------------
'     ソート＆ファイル書込み
'   ---------------------------------------------
    StartTime = timeGetTime()
	Open xOutFile For Append As #2
		Field #2, LineLength		'バイト数
		GigaSort( 0, xInFile )
	Close #2
    EndTime = timeGetTime()
    MsgBox 0, Str$( EndTime - StartTime )&"ms"
	End
'===============================================================================
' ファイルを用いたソート方法
'===============================================================================
Function GigaSort(xNo As Integer, xFileName As String)As Integer
	Dim j As Integer
	Dim Wk As String		'ワークファイル名
	Dim FN As String		'実行用ファイル名
	Dim xCnt(9) As Integer	'振り分け件数
	j=SortKey[xNo]-1: If(xNo)Then Wk=xFileName Else Wk=xWorkFile
	if(j>=0)Then						'ソート
		Open xFileName For Input As #1:   Field   #1, LineLength
		Open Wk + "0"  For Output As #10: Field  #10, LineLength
		Open Wk + "1"  For Output As #11: Field  #11, LineLength
		Open Wk + "2"  For Output As #12: Field  #12, LineLength
		Open Wk + "3"  For Output As #13: Field  #13, LineLength
		Open Wk + "4"  For Output As #14: Field  #14, LineLength
		Open Wk + "5"  For Output As #15: Field  #15, LineLength
		Open Wk + "6"  For Output As #16: Field  #16, LineLength
		Open Wk + "7"  For Output As #17: Field  #17, LineLength
		Open Wk + "8"  For Output As #18: Field  #18, LineLength
		Open Wk + "9"  For Output As #19: Field  #19, LineLength
		'
		While (Eof(1)=0)
			Get #1, -1, StrBuf
			Select Case StrBuf[j]
				case &h30: Put #10,-1,StrBuf: If(xCnt(0)<=xReSort)Then xCnt(0)=xCnt(0)+1
				case &h31: Put #11,-1,StrBuf: If(xCnt(1)<=xReSort)Then xCnt(1)=xCnt(1)+1
				case &h32: Put #12,-1,StrBuf: If(xCnt(2)<=xReSort)Then xCnt(2)=xCnt(2)+1
				case &h33: Put #13,-1,StrBuf: If(xCnt(3)<=xReSort)Then xCnt(3)=xCnt(3)+1
				case &h34: Put #14,-1,StrBuf: If(xCnt(4)<=xReSort)Then xCnt(4)=xCnt(4)+1
				case &h35: Put #15,-1,StrBuf: If(xCnt(5)<=xReSort)Then xCnt(5)=xCnt(5)+1
				case &h36: Put #16,-1,StrBuf: If(xCnt(6)<=xReSort)Then xCnt(6)=xCnt(6)+1
				case &h37: Put #17,-1,StrBuf: If(xCnt(7)<=xReSort)Then xCnt(7)=xCnt(7)+1
				case &h38: Put #18,-1,StrBuf: If(xCnt(8)<=xReSort)Then xCnt(8)=xCnt(8)+1
				case &h39: Put #19,-1,StrBuf: If(xCnt(9)<=xReSort)Then xCnt(9)=xCnt(9)+1
			End Select
		Wend
		Close #19
		Close #18
		Close #17
		Close #16
		Close #15
		Close #14
		Close #13
		Close #12
		Close #11
		Close #10
		Close #1

		If(xNo)Then Kill(xFileName)
		For j=0 To 9
			FN=Wk + Str$(j)
			If(xCnt(j))Then
				If( xCnt(j)=1)Then
					SortOut(FN)			'ソート必要なし
				Else
					If( xCnt(j)>xReSort)Then
						GigaSort(xNo+1, FN)	'再度分割
					Else
						MegaSort(xNo+1, FN, xCnt(j))
					End If
				Endif
			End If
			Kill(FN)
		Next
	Else
		SortOut(xFileName)
	End If
End Function
'-----------------------------------------------------------
' ソート結果の書込み
'-----------------------------------------------------------
Sub SortOut(xFileName As String)
	Open xFileName For Input  As #1: Field  #1, LineLength
	Field #1, LineLength		'バイト数
	While (Eof(1)=0)
		Get #1, -1, StrBuf
		Put #2, -1, StrBuf
	Wend
	Close #1
End Sub
'===============================================================================
' 小規模ソート
'===============================================================================
Sub MegaSort(xNo As Integer, xFileName As String, nMax As Integer)
	Dim i As Integer
	Dim j As Integer
	Dim k As Integer
    Dim e As Byte
    Dim w As Integer
	'読込み
	Open xFileName For Input As #1: Field #1, LineLength
	For i=1 to nMax
		Get #1, -1, SortText(i) As StrPtr: SortIndex=i
	Next
	Close #1
	'
	If(nMax>1)Then QuickSort( xNo, 1, nMax )
	'書込み
	For i=1 To nMax
		Put #2, -1, SortText[SortIndex]
	Next
End Sub
'----------------------------------------------------------
' クイックソート
'----------------------------------------------------------
Sub QuickSort( xNo As Integer, ByVal Kara As Long, ByVal Made As Long)
	Dim i As Long
	Dim j As Long
	Dim w As Integer
	Dim k As Integer
	'
	i=Kara : j=Made : k = SortIndex((i+j)\2)	'基準ｋ
	Do
		While KeyCheck( xNo, SortIndex(i) , k ): i=i+1: Wend
		While KeyCheck( xNo, k , SortIndex(j) ): j=j-1: Wend
		If (i <= j) Then
			w = SortIndex(i): SortIndex(i) = SortIndex(j): SortIndex(j) = w
			i=i+1 : j=j-1
		End If
	Loop Until (i > j)
	If (Kara < j) Then QuickSort(xNo, Kara, j)
	If (i < Made) Then QuickSort(xNo, i, Made)
End Sub
'----------------------------------------------------------
' 比較処理( L<R なら -1 )
'----------------------------------------------------------
Function KeyCheck( k As Integer, L As Integer, R As Integer ) As Long
	Dim x  As Long
	Dim p1 As BytePtr
	Dim p2 As BytePtr

	p1=StrPtr(SortText(L))
	p2=StrPtr(SortText(R))
	Do
		x=SortKey[k]-1: If( x<0 )Then Exit Function
		If( p1[x] < p2[x] )Then Exit Do
		If( p1[x] > p2[x] )Then Exit Function
		k = k + 1
	Loop
	KeyCheck = -1
End Function

omasu

お世話になります。

またまた、新しいロジックの出現に「感謝・感激・雨あられ？」早速実行してみました。（マティさんもお酒がすきなんですか？・）

　マティさんに質問なんですが

　　Ｑ１．今回の入力テストデータはｏｍａｓｕの作った、テストデータ作成プログラムで８００万件を作成したのでしょうか？。

　　Ｑ２．とりあえず、ｉｎｆｉｌｅ１０００．ｃｓｖとｉｎｆｉｌｅ５０００００．ｃｓｖをテストしてみましたが、どうもうまく機能しません。

　　Ｑ３．何か、プログラム内に変更するべき、項目があるのでしょうか。

追伸：
　私も大型汎用（パラレル）コンピューターを使用していました。
　使っていたランゲージはコボルです。
　汎用ホストではプログラムでロジックを組まなくても、数百万件のソートは、ＪＣＬの￥ＳＯＲＴ機能でソート可能です。
　ＪＣＬとは（ジョブコントロールランゲージ、ＤＯＳでいうパッチ、機能は比較にならず言語クラスですが）
　ユーティリティーだけで高度なソートが可能です。
　しかも、本体スピードが驚異的なものなので、ロジックで組んだとしてもその良し悪しは数秒の差であまり気にしていませんでした。
　しかし、ＰＣではそうもいきません、このような８００万件数をソート可能としたロジックに感銘を受けます。

追伸その２：
　①．汎用ホストでは大容量（数百万件）の入力ファイルを索引編成（ＩＮＤＥＸ）ファイルにデータを追加して行き、
　　　使用する際、順読み出し（ソート済み）または乱読み出しを行う手段があります。
　　　（これは、ＰＣでも使用できると思います。ＤＩＳＫ容量の限界あり）
　②．ＶＳＡＳというとんでもないファイルを使用する方法もあります。

Zgock

すいません、ちょっと時間とれずにサンプル作れなくて申し訳ないです。

なので、ラディックス（基数）ソートの概念だけ説明しますね。
いわゆるバケツソートの変形になります。

バケツソートは、高速ですが、大量のワークを必要とするのが難点です。
たとえばデータ範囲が０～９９９９であるなら１００００のワークが必要ですよね？

ここで、
「データの下２桁と上２桁に着目して、まず下２桁でバケツソート、
続いて上２桁でバケツソートすればワークは１００で済むよね？」
という発想が基本です。
２回に分割する場合、バケツソートに比べて速度は２倍、ワークは１００分の１になるわけです。

↓こちらのページが参考になるかと思います。
（ヒープソートの説明あたり、かなりわかりやすい部類だと思います）
http://www.ics.kagoshima-u.ac.jp/~fuchi ... m/top.html

クイックソートは速いアルゴリズムで非常に美しいですが、
安定じゃないのだけが欠点ですね。
そういう理由からヒープソートをよく使います。

ab.com コミュニティ

ソートロジック大会

イグトランスさんへ質問(難問)です

Re: 中間結果のご報告について

ありがとうございます。

マティさんに返信

テストデータの掲示についてⅡ

作成したロジックの掲示について

マティさんに感激

ラディックスソート（と言い訳）