ab.com コミュニティ

コード: 全て選択

'-----------------------------------------------------------------------------
'  イベント プロシージャ
'-----------------------------------------------------------------------------
' このファイルには、ウィンドウ [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

コード: 全て選択

#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 Sub

コード: 全て選択

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