ab.com コミュニティ

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    For i=S To E
        Work=AscMid(KeyTable)
        If i>0 Then
           j=i
           While (j>=S+1) And _
                 (Work[Index[j]]<Work[Index[j-1]])
                 Swap(Index[j],Index[j-1])
                 j=j-1
           Wend
        EndIf
    Next i
End Sub
' 
Function AscMid(buf As String) As QWord
    AscMid=       buf[00]*1000000000
    AscMid=AscMid+buf[01]*100000000
    AscMid=AscMid+buf[02]*10000000
    AscMid=AscMid+buf[03]*1000000
    AscMid=AscMid+buf[04]*100000
    AscMid=AscMid+buf[06]*10000
    AscMid=AscMid+buf[07]*1000
    AscMid=AscMid+buf[08]*100
    AscMid=AscMid+buf[09]*10
    AscMid=AscMid+buf[10]*1
End Function

コード: 全て選択

Declare Function timeGetTime Lib "winmm.dll" () As Long
'#Strict
'===============================================================================
' 0.01 標準関数のみで処理を作成
' 0.04 関数の展開を行う
' 0.05 ロジックの役割を変える
' 0.06 分割処理の書込み方法を変更
' 0.07 書込みバッファーの採用
'===============================================================================
'Const WriteLine=2048
Const WriteLine=4096
'Const xReSort=10240			'
'Const xReSort=20480			'256MB
'Const xReSort=51200			'
'Const xReSort=102400			'
'Const xReSort=153600			'
'Const xReSort=204800			'512MB
'Const xReSort=256000			'
Const xReSort=307200			'

Const LineLength  = 158		'一行のバイト数
Const MarBuffer   = xReSort   * LineLength	'4KB倍数にする事
Const WriteBurrer = WriteLine * LineLength	'4KB倍数になる最小値

'Dim Dummy(72) As byte
Dim rBuffer(MarBuffer -1)	As Byte			'Read Buffer's
Dim wBuffer(255 * WriteBurrer -1) As Byte	'WriteBuffer's '0.07
'LineLengthが255を超えると追加のワークを作成する必要がある
'Dim wBufferAdd(MarBuffer-(255 * WriteBurrer))	As Byte
Dim wBufAdr(255)			As Long			'0.07
Dim xFile  (255)			As Byte			'0.06対象の有無
Dim xKeys  (xReSort)		As Byte			'0.06対象キー
Dim MasterKey(LineLength)	As Byte
Dim SortIndex(xReSort)		As BytePtr

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 hFileLoad  As  HFILE
Dim hFileSave  As  HFILE
Dim nLoad      As  Long
Dim nSave      As  Long
'   ---------------------------------------------
'     初期値を設定
'   ---------------------------------------------
	MkDir "c:\tmp"
	  xInFile = "c:\infile50000000.csv"
'	  xInFile = "d:\csv\infile8000000.csv"
'	  xInFile = "d:\csv\infile1000000.csv"
'	  xInFile = "d:\csv\infile1000.csv"
'	  xInFile = "d:\csv\infile100.csv"
'	  xInFile = "d:\csv\infile10.csv"
	 xOutFile = "OutPut.csv"
	xWorkFile = "c:\tmp\sort"
'   ---------------------------------------------
'     ソート＆ファイル書込み
'   ---------------------------------------------
    StartTime = timeGetTime()
'	hFileSave = CreateFile(xOutFile,GENERIC_WRITE,0,ByVal NULL,CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL,NULL)	'Write
	hFileSave = CreateFile(xOutFile,GENERIC_WRITE,0,ByVal NULL,CREATE_ALWAYS,FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN,NULL)	'Write
		GigaSort( 0, xInFile )
	CloseHandle( hFileSave )
    EndTime = timeGetTime()
	MsgBox 0, Str$( EndTime - StartTime )&"ms"
	End
'===============================================================================
' ファイルを用いたソート方法
'===============================================================================
Function GigaSort(xNo As Integer, xFileName As String)As Integer
	Dim i As Long
	Dim x As Long
	Dim z As Long		'分割用アドレス
	Dim r As BytePtr	'Read
	Dim w As BytePtr	'Write
'	Dim p As BytePtr	'pointer
'
	Dim Index As Integer
	Dim wFile As String		'ワークファイル名
'	Dim nSize As Long
	Dim nSize As Int64, nSizeLow As DWord
	Dim nRead As Long
	Dim hFile(255) As HFILE	'書込みファイルハンドル
	'-------------------------------------------------------
	' ファイル処理（読込みファイルの作成作業）
	'-------------------------------------------------------
	If(xNo)Then wFile = xFileName Else wFile = xWorkFile
	'
	hFileLoad = CreateFile( xFileName, _
							GENERIC_READ , _
							0, _
							ByVal NULL, _
							OPEN_EXISTING, _
							FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN, _
							NULL)		'Read
'	nSize = GetFileSize( hFileLoad, NULL )
	nSizeLow = GetFileSize( hFileLoad, VarPtr(nSize)+4 )
	nSize = nSize + nSizeLow
	'-------------------------------------------------------
	' ソート条件確認
	'-------------------------------------------------------
	Index=SortKey[xNo]-1
	If(Index < 0)Then			'ソート不能、全て書き込む
		SortOut( nSize )
		If(xNo)Then DeleteFile(xFileName)
		Exit Function
	End If
	If(nSize <= MarBuffer)Then	'メモリー内でソートが出来る場合
		QuickSortSetup( xNo, nSize )
		If(xNo)Then DeleteFile(xFileName)
		Exit Function
	End If
	'-------------------------------------------------------
	' 中間ファイルを用いて分割を行う処理
	'-------------------------------------------------------
	For i=0 To 255: wBufAdr=0: Next
	'----------------------------------------
	' 中間ファイル作成！
	'----------------------------------------
	While( nSize > 0 )
		If( nSize > MarBuffer )Then  nRead=MarBuffer  Else  nRead=nSize
		ReadFile( hFileLoad, rBuffer As BytePtr, nRead, VarPtr(nLoad), ByVal 0)
		'--------------------------------------------------
		'インデックス作成
		'--------------------------------------------------
		r=rBuffer As BytePtr
		For i=0 To ( nRead \ LineLength ) - 1
			x=r[Index]: xKeys=x: xFile[x]=1: r=r+LineLength
		Next
		'--------------------------------------------------
		'ファイル処理
		'--------------------------------------------------
		w = wBuffer As BytePtr
		For x=0 To 255
			If( xFile[x] )Then
				If(hFile[x] = 0)Then
				   hFile[x] = CreateFile( wFile + Chr$(x), _
									GENERIC_WRITE, 0, ByVal NULL, CREATE_ALWAYS, _
									FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN, _
									NULL)	'Write
				End If
				'
				r=rBuffer As BytePtr
				z=wBufAdr[x]
				For i=0 To ( nRead \ LineLength ) - 1
					If( xKeys = x )Then
						memcpy((w+z), r, LineLength) '基準ｋ
						z = z + LineLength
						If(z >= WriteBurrer)Then
							WriteFile(hFile[x], w, z, VarPtr(nSave), ByVal 0)
							z=0
						End If
					End If
					r=r+LineLength
				Next i
				wBufAdr[x]=z
			End If
			w = w + WriteBurrer
		Next
		nSize = nSize - nRead
	Wend
	'----------------------------------------
	' 中間ファイルは閉じると完成する！
	'----------------------------------------
	w = wBuffer As BytePtr
	For x=0 To 255
		If(hFile[x])Then
			z=wBufAdr[x]
			If(z>0)Then
				WriteFile(hFile[x], w, z, VarPtr(nSave), ByVal 0)
			End If
			CloseHandle( hFile[x] )
		End If
		w = w + WriteBurrer
	Next
	CloseHandle( hFileLoad )
	'----------------------------------------
	' 再度ソートを行う処理を呼び出す
	'----------------------------------------
	If(xNo)Then DeleteFile(xFileName)
	For i=0 To 255
		If(hFile)Then GigaSort(xNo+1, wFile + Chr$(i))	'再帰処理
	Next
End Function
'-----------------------------------------------------------
' ソート結果の書込み(最後まで絞り切れない場合に実行)
'-----------------------------------------------------------
Sub SortOut(nSize As DWord)
	While( nSize > MarBuffer )
		ReadFile( hFileLoad, rBuffer As BytePtr, MarBuffer, VarPtr(nLoad), ByVal 0)
		WriteFile(hFileSave, rBuffer As BytePtr, MarBuffer, VarPtr(nSave), ByVal 0)
		nSize = nSize - MarBuffer
	Wend
	ReadFile( hFileLoad, rBuffer As BytePtr, nSize, VarPtr(nLoad), ByVal 0)
	WriteFile(hFileSave, rBuffer As BytePtr, nSize, VarPtr(nSave), ByVal 0)
	CloseHandle( hFileLoad )
End Sub
'===============================================================================
' メモリーを用いたソート
'===============================================================================
Sub QuickSortSetup( xNo As Integer, nSize As DWord )
	Dim i As Long
	Dim p As BytePtr
	Dim nCount As Long
	'
	ReadFile( hFileLoad, rBuffer As BytePtr, nSize, VarPtr(nLoad), ByVal 0)
	CloseHandle( hFileLoad )
	nCount = ( nSize \ LineLength ) - 1
'	If(nCount<=0)Then Debug:exit function
'	If(nCount>=0)Then
		p=rBuffer As BytePtr
		For i=0 To nCount
			SortIndex = p: p=p+LineLength
		Next
		'
		QuickSort(xNo, 0, nCount )		'ソート処理
		'
		p=wBuffer As BytePtr
		For i=0 To nCount
			memcpy(p, SortIndex, LineLength) '基準ｋ
			p=p+LineLength
		Next
		WriteFile(hFileSave, wBuffer, nSize, VarPtr(nSave), ByVal 0)
'	End If
End Sub
'----------------------------------------------------------
' クイックソート
'----------------------------------------------------------
Sub QuickSort( xNo As Integer, Kara As Long, Made As Long)
	Dim i As Long
	Dim j As Long
	Dim w As BytePtr
	Dim k As BytePtr
	'
	memcpy(MasterKey As BytePtr, SortIndex[(Kara+Made)\2], LineLength) '基準ｋ
	i=Kara : j=Made: k=MasterKey As BytePtr
	Do
		While KeyCheck( xNo, SortIndex , k ): i=i+1: Wend
		While KeyCheck( xNo, k , SortIndex[j] ): j=j-1: Wend
		If (i <= j) Then
			w = SortIndex: SortIndex = 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( xNo As Integer, L As BytePtr, R As BytePtr ) As Long
	Dim x As Long
	Do
		x=SortKey[xNo]-1: If( x<0 )Then Exit Function
		If( L[x] < R[x] )Then Exit Do
		If( L[x] > R[x] )Then Exit Function
		xNo = xNo + 1
	Loop
	KeyCheck = -1
End Function
'===============================================================================
' コード終了
'===============================================================================

コード: 全て選択

'quicksort	ソートロジック大会の実行速度比較環境風
Const THRESHOLD = 10            '挿入ソートに切り替える境界値
Const STACKSIZE = 32            'たかだか Long のビット数程度(>log2Nの数であること)

Sub Sort(S As Long, E As Long)
	Dim i As Long, j As Long, k As Long
	Dim left As Long, right As Long, middle As Long
	Dim leftstack[STACKSIZE] As Long
	Dim rightstack[STACKSIZE] As Long
	Dim x As Long, tmp As Long

	left = S
	right = E
	While 1
		If right - left <= THRESHOLD Then
			If k = 0 Then Exit While
			k = k - 1
			left = leftstack[k]
			right = rightstack[k]
		End If
		 '基準値の作成（投稿された中央値のもの）
		middle = (left + right) \ 2
		If lstrcmp(KeyTable[Index[left]],KeyTable[Index[middle]])>0 Then
			Swap(Index[left],Index[middle])
		EndIf
		If lstrcmp(KeyTable[Index[middle]],KeyTable[Index[right]])>0 Then
			Swap(Index[middle],Index[right])
			If lstrcmp(KeyTable[Index[left]],KeyTable[Index[middle]])>0 Then
				Swap(Index[left],Index[middle])
			EndIf
		EndIf
		x = Index[middle]				'比較値の保存
		i = left
		j = right
		While 1
			While lstrcmp(KeyTable[Index], KeyTable[x]) < 0
				i = i + 1
			Wend
			While lstrcmp(KeyTable[x], KeyTable[Index[j]]) < 0
				j = j - 1
			Wend
			If i >= j Then Exit While
			Swap(Index, Index[j])
			i = i + 1
			j = j - 1
		Wend
		If i - left > right - j Then
			If i - left > THRESHOLD Then
				leftstack[k] = left
				rightstack[k] = i - 1
				k = k + 1
			End If
			left = j + 1
		Else
			If right - j > THRESHOLD Then
				leftstack[k] = j + 1
				rightstack[k] = right
				k = k + 1
			End If
			right = i - 1
		End If
	Wend
	InsertionSort(S, E) 
End Sub

Sub InsertionSort(S As Long, E As Long)
	For i = S + 1 To E
		j = i
		While j >= S + 1 And lstrcmp(KeyTable[Index[j]],KeyTable[Index[j-1]])<0
			Swap(Index[j], Index[j - 1])
			j = j - 1
		Wend
	Next i
End Sub

コード: 全て選択

'******************************************************************************** 
'* ＣＳＶファイル　ソートプログラム 
'******************************************************************************** 
' 
#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$="infile1000.csv" '        入力ファイル名定義（フルパス指定、省略時はカレント） 
Const outfile$="outfile.csv" '            入力ファイル名定義（フルパス指定、省略時はカレント） 
Const TableSize=110000 '                データ最大件数定義 
' 
' グローバル領域変数定義 
' 
Dim hHeap As HANDLE 
Dim KeyTable[TableSize] As BytePtr,DataTable[TableSize] As BytePtr,Index[TableSize] As Long,DataSize As Long 
Dim Work[TableSize] 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 
StartTime1=timeGetTime() 
Print "ソートファイル名：",infile$ 
Print 
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 
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 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
' 
' 行単位に分解・キーテーブルストック・データテーブルストック 
' 
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=1 
    While Bunkatu<E 
          Bunkatu=Bunkatu*2 
          For i=S To E Step Bunkatu 
              For j=i To i+(Bunkatu\2)-1 
                  Work[j-i]=Index[j] 
              Next j 
              k=0 
              l=i 
              While (k<Bunkatu\2) And (j<=i+Bunkatu-1) And (j<=E) 
                    If lstrcmp(KeyTable[Work[k]],KeyTable[Index[j]])>0 Then 
                       Index[l]=Index[j] 
                       j=j+1 
                    Else 
                       Index[l]=Work[k] 
                       k=k+1 
                    End If 
                    l=l+1 
              Wend 
              For j=k To Bunkatu\2-1 
                  Index[l+(j-k)]=Work[j] 
              Next j 
          Next i 
    Wend 
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

コード: 全て選択

'-----------------------------------------------------------
' ヒープソート（０ベース）
'-----------------------------------------------------------
Sub Sort( S As Long, E As Long)
    Dim i As Long
    Dim j As Long
	If(S<>0)Then If(MessageBox(0,"処理できません","",MB_OK)=MB_OK)Then Exit Sub
    'ヒープ作成（最初の処理）
    For i = (E \ 2) To 0 Step -1    '０基準
        MakeHeap(i, E)
    Next
    '並べ替え
    For i = E To 2 Step -1
		Swap(Index[0],Index)
        MakeHeap(0, i-1)
    Next
	Swap(Index[0],Index[1])
End Sub

'実際に、ヒープを編集する処理です。 
Sub MakeHeap(s As Long, n As Long)
	Dim i As Long
	i = s * 2 + 1		'０基準
	Do
		If (i < n) Then If (lstrcmp(KeyTable[Index],KeyTable[Index[i+1]])<0) Then i=i+1	'子の大を選択
		If (lstrcmp(KeyTable[Index[s]],KeyTable[Index])>0) Then Exit Do                '親が大ならHeap完成
        '親と子を交換後、処理を繰り返す
		Swap(Index[s],Index)
		s = i
		i = s * 2 + 1		'０基準
    Loop Until(i > n)
End Sub

コード: 全て選択

Sub MakeHeap(s As Long, n As Long)
	Dim A$,B$
	Dim i As Long
	i = s * 2 + 1		'０基準
	Do
		If (i < n) Then If (lstrcmp(KeyTable[Index],KeyTable[Index[i+1]])<0) Then i=i+1	'子の大を選択
		'キーデータを確認する
		A$=KeyTable[Index[s]]
		B$=KeyTable[Index]
		If (lstrcmp(KeyTable[Index[s]],KeyTable[Index])>0) Then Exit Do                '親が大ならHeap完成
        '親と子を交換後、処理を繰り返す
		Swap(Index[s],Index)
		s = i
		i = s * 2 + 1		'０基準
    Loop Until(i > n)
End Sub

コード: 全て選択

'********************************************************************************
'* ＣＳＶファイル　ソートプログラム
'********************************************************************************
'
#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$="infile1000.csv" '		入力ファイル名定義（フルパス指定、省略時はカレント）
Const outfile$="outfile.csv" '			入力ファイル名定義（フルパス指定、省略時はカレント）
Const TableSize=110000 '				データ最大件数定義
'
' グローバル領域変数定義
'
Dim hHeap As HANDLE
Dim KeyTable[TableSize] As BytePtr,DataTable[TableSize] As BytePtr,Index[TableSize] As Long,DataSize As Long
Dim Work[TableSize] 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
StartTime1=timeGetTime()
Print "ソートファイル名：",infile$
Print
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
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=1
    While Bunkatu<E
          Bunkatu=Bunkatu*2
          For i=S To E Step Bunkatu
              For j=i To i+(Bunkatu\2)-1
                  Work[j-i]=Index[j]
              Next j
              k=0
              l=i
              While (k<Bunkatu\2) And (j<=i+Bunkatu-1) And (j<=E)
                    If lstrcmp(KeyTable[Work[k]],KeyTable[Index[j]])>0 Then
                       Index[l]=Index[j]
                       j=j+1
                    Else
                       Index[l]=Work[k]
                       k=k+1
                    End If
                    l=l+1
              Wend
              For j=k To Bunkatu\2-1
                  Index[l+(j-k)]=Work[j]
              Next j
          Next i
    Wend
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

コード: 全て選択

'-----------------------------------------------------------
' ヒープソート（０ベース）
'-----------------------------------------------------------
Sub HeapSort( S As Long, E As Long)
    Dim i As Long
    Dim j As Long
    Dim w As xCd
	If(S<>0)Then MessageBox(0,"処理できません","",BM_OK):End Sub
    'ヒープ作成（最初の処理）
    For i = (E \ 2) To 0 Step -1    '０基準
        MakeHeap(i, E)
    Next
    '並べ替え
    For i = E To 2 Step -1
		Swap(Index[0],Index)
        MakeHeap(0, i-1)
    Next
	Swap(Index[0],Index[1])
End Sub

'実際に、ヒープを編集する処理です。 
Sub MakeHeap(s As Long, n As Long)
	Dim i As Long
	i = s * 2 + 1		'０基準
	Do
		If (i < n) Then If (lstrcmp(KeyTable[Index],KeyTable[i+1])<0) Then i=i+1	'子の大を選択
		If (lstrcmp(KeyTable[Index[s]],KeyTable)>0)) Then Exit Do                '親が大ならHeap完成
        '親と子を交換後、処理を繰り返す
		Swap(Index[s],Index)
		s = i
		i = i * 2 + 1	'０基準
    Loop Until(i > n)
End Sub

コード: 全て選択

'-----------------------------------------------------------
' ヒープソート（１ベース）
'-----------------------------------------------------------
Sub HeapSort( S As Long, E As Long)
    Dim i As Long
    Dim j As Long
    Dim w As xCd
	If(S<>1)Then MessageBox(0,"処理できません","",BM_OK):End Sub
    'ヒープ作成（最初の処理）
    For i = (E \ 2 + 1) To 1 Step -1    '１基準
        MakeHeap(i, E)
    Next
    '並べ替え
    For i = E To 3 Step -1
		Swap(Index[1],Index)
        MakeHeap(1, i-1)
    Next
	Swap(Index[1],Index[2])
End Sub

'実際に、ヒープを編集する処理です。 
Sub MakeHeap(s As Long, n As Long)
	Dim i As Long
	i = s * 2			'１基準
	Do
		If (i < n) Then If (lstrcmp(KeyTable[Index],KeyTable[i+1])<0) Then i=i+1	'子の大を選択
		If (lstrcmp(KeyTable[Index[s]],KeyTable)>0)) Then Exit Do                '親が大ならHeap完成
        '親と子を交換後、処理を繰り返す
		Swap(Index[s],Index)
		s = i
		i = i * 2		'１基準
    Loop Until(i > n)
End Sub

コード: 全て選択

Dim Work[TableSize] As Long

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    Dim Bunkatu As Long
    Bunkatu=1
    While Bunkatu<E
          Bunkatu=Bunkatu*2
          For i=S To E Step Bunkatu
              For j=i To i+(Bunkatu\2)-1
                  Work[j-i]=Index[j]
              Next j
              k=0
              l=i
              While (k<Bunkatu\2) And (j<=i+Bunkatu-1) And (j<=E)
                    If lstrcmp(KeyTable[Work[k]],KeyTable[Index[j]])>0 Then
                       Index[l]=Index[j]
                       j=j+1
                    Else
                       Index[l]=Work[k]
                       k=k+1
                    End If
                    l=l+1
              Wend
              For j=k To Bunkatu\2-1
                  Index[l+(j-k)]=Work[j]
              Next j
          Next i
    Wend
End Sub

コード: 全て選択

Sub Sort(ByVal S As Long,ByVal E As Long)
    l=(E\2)+1
    k=E
    While l>0'1
          l=l-1
          Furuiotoshi() ' SHIFT
    Wend
    While k>0'1
          Swap(Index[1],Index[k])
          k=k-1'1
          Furuiotoshi() ' SHIFT
    Wend
'
'   ヒープソート（河川屋さん原本）
'      L=(N\2)+1 : R=N
'      WHILE L>1
'        L=L-1 : GOSUB 3500'SHIFT
'      WEND
'      WHILE R>1
'        SWAP DAT(1),DAT(R)
'        R=R-1 : GOSUB 3500'SHIFT
'      WEND
'      RETURN
End Sub
'
'　篩い落とし
'
Sub Furuiotoshi()
    Dim X As Long
    i=l
    j=2*l
    X=Index[l]
    IF (j<k) And (lstrcmp(KeyTable[Index[j]],KeyTable[Index[j+1]])<0) THEN
       j=j+1
    EndIf
    WHILE (j<=k) And (lstrcmp(KeyTable[Index[X]],KeyTable[Index[j]])<0)
          Index=Index[j]
          i=j
          j=2*j
          IF (j<k) And (lstrcmp(KeyTable[Index[j]],KeyTable[Index[j+1]])<0) THEN
             j=j+1
          EndIf
    WEND
    Index=X
'
'3500 '篩い落とし　（河川屋さん原本）
'      I=L : J=2*L : X=DAT(L)
'      IF J<R AND DAT(J)<DAT(J+1) THEN J=J+1
'      WHILE J<=R AND X<DAT(J)
'        DAT(I)=DAT(J) : I=J : J=2*J
'        IF J<R AND DAT(J)<DAT(J+1) THEN J=J+1
'      WEND
'      DAT(I)=X
'      RETURN
End Sub