FreeBASIC クイック・ソート・ルーチン

目次→フォーラム→FreeBASIC→補足→Quick Sort Routine←オリジナル・サイト

クイック・ソート・ルーチン　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

　これは主に、既存の関数を使わずに、クイック・ソート・ルーチンを実装しようとする人向けです。

　まず初めに紹介するのは、私(渡辺)が、大きなサイズのテキスト・ファイルをソートするために、公開されているコードをかき集めて編集したものです。

　私の、メモリ 1GB のパソコンで、1千3百万行、1GB のテキスト・ファイルを、1時間でソートしました。(ファイル・サイズが 1GB だと、I/O にも、それなりの時間がかかります。)

　ソートするファイルを選択するために、「ファイルを開くダイアログ」を使っています。
「ファイルを開くダイアログ」に、GUI ライブラリ Window9 を使ったバージョンと、Win32 API をそのまま使ったバージョンの 2 つを掲示します。
　GUI ライブラリ Window9 が、いかに優れているかよく分かりますね。

「ファイルを開くダイアログ」に、GUI ライブラリ Window9 を使用


'ユーザ・インタフェース・ライブラリ Window9 を使ったバージョン
'SortByLineWindow9.bas
'************************************************
#include "vbcompat.bi"
   
'************ ファイルを開くダイアログ部分 *******************
#Include "window9.bi"


Declare Sub QuickSort( DataArray() As String ,  LowLimit  As Long,  UpLimit  As Long)

'   ファイルを行ソート

Dim Filehandle As Integer
Dim FileName As String
Dim SortedFileName As String
Dim StartTime As Double
Dim EndTime As Double
Const MaxLines As Long =15000000    '最大入力行数
'Const MaxLines As Long =300    '最大入力行数
Dim Shared InData(MaxLines) As String
Dim Lines As Long     '入力行数
Dim LineCounter As Long
Dim text As String


Dim fName As String     '★拡張子無しのファイル名
Dim extension As String '★拡張子部分(例：.txt)
Dim e As Integer        'エラー№
Dim FullPass As String  '対象ファイルのフルパス  



'********************* ファイルを開くダイアログを使う *********************
 
 Dim buff As ZString*260
 Dim ofnFlags As Integer

   ''FileOpen
   FullPass = OpenFileRequester("ソートするファイルを指定","C:\test\","テキストファイル(*.txt;*.csv;*.htm*)"_
+Chr(0)+"*.txt;*.csv;*.htm*"+Chr(0)+"全てのファイル(*.*)"+Chr(0)+"*.*"+Chr(0))

   fName = Left(FullPass,InStrRev(FullPass,".") -1)  '対象のテキストファイルのフルパスの、拡張子無し部分
   extension = Right(FullPass,Len(FullPass) - InStrRev(FullPass,".") +1) '対象テキストファイルのドット付き拡張子部分


   StartTime = Now

   ' テキストファイルの内容読み込み処理
   FileName=FullPass
   Lines = 0

   Filehandle = FreeFile
   Open FileName For Input As #Filehandle ' テキストファイルのオープン

   If LOF(Filehandle) > 0 Then
      Do Until EOF(Filehandle )     
         'ReDim Preserve InData(Lines)
         Line Input #Filehandle, text     ' 1行読み込み
         InData(Lines)=text
         Lines = Lines + 1
         If Lines>MaxLines-100 Then 
            Print LINES ;"行読み込みました。配列の設定の上限に達したので、終了します。"
            Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。
            Sleep
            End
         EndIf
         If LINES Mod 500000 = 0 Then
            Print LINES ;"行読み込みました。"
         EndIf
      Loop     
   Else
           Goto HandleErrors
   End If
   
   Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。

   ' ソートします
   Print "行数：" ; Lines ; " のファイルをソートします。"
     QuickSort( InData(), 0, Lines - 1)        ' FreeBASIC では、Call が使えない
   Print "ソートを終了しました。結果を出力します。"
   
   ' 結果を名前を変えて出力します。
   SortedFileName = fName    & "Sorted" & extension
   
     Filehandle = FreeFile
   
   Open SortedFileName  For Output As #Filehandle

   For LineCounter = 0 To Lines - 1
       Print #Filehandle, InData(LineCounter)
       
      If (LineCounter+1) Mod 500000 = 0 Then
         Print LineCounter+1 ;"行、書き出しました。"
      EndIf
       
   Next

   Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。

    EndTime = Now
    
    Print StartTime , "開始時刻" , Format (StartTime, "yyyy/mm/dd hh:mm:ss")
    Print EndTime   , "終了時刻" , Format (EndTime, "yyyy/mm/dd hh:mm:ss")
    
    Print "ソートを終わりました。" & vbNewLine _
    & "処理時間は、" _
    & Format(EndTime - StartTime, "hh 時間 mm 分 ss 秒") & " でした。"
   Sleep
   End
   
   HandleErrors:
   Print "ファイルが見つかりません"
   Sleep
   

'************************************************
'★★★数値ソート★★★
Sub QuickSort( DataArray() As String ,  LowLimit  As Long,  UpLimit  As Long)

'Sub QuickSort(ByRef DataArray() As String , ByVal LowLimit  As Long, ByVal UpLimit  As Long)

'よねさんのWordとExcelの小部屋
'http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_array2.html
'をそのまま使わせていただいています。

   Dim i As Long
   Dim j As Long
   Dim MidNumber  As String  'As Variant '中央の要素行の内容
   Dim Temp  As String '一時待避
 
   MidNumber = DataArray(Int((LowLimit + UpLimit) / 2))
   i = LowLimit
   j = UpLimit
   Do
      Do While DataArray(i) < MidNumber
         i = i + 1
      Loop
      Do While DataArray(j) > MidNumber
         j = j - 1
      Loop
      If i >= j Then Exit Do
      Temp = DataArray(i)
      DataArray(i) = DataArray(j)
      DataArray(j) = Temp
      i = i + 1
      j = j - 1
   Loop
   If (LowLimit < i - 1) Then QuickSort( DataArray(), LowLimit, i - 1)
   If (UpLimit > j + 1) Then QuickSort( DataArray(), j + 1, UpLimit)
End Sub

ページの頭に戻る

「ファイルを開くダイアログ」に、Win32 API をそのまま使用


'Win32 API をそのまま使ったバージョン
'SortByLine.bas
'************************************************
#include "vbcompat.bi"
   
'************ ファイルを開くダイアログ部分 *******************
#Include Once "crt.bi"
#Include Once "windows.bi"
#Include Once "win/commdlg.bi"
#include Once "win/shlobj.bi"
#Ifndef _FILE_HELPERS_WIN32
#Define _FILE_HELPERS_WIN32

#Define FileOpenDialog(a,b,c,d,e) FileOpenSaveDialog(0,(a),(b),(c),(d),(e))

Dim Shared as Integer OFS_FILE_OPEN_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS

Declare Sub QuickSort( DataArray() As String ,  LowLimit  As Long,  UpLimit  As Long)

Declare Function FileOpenSaveDialog(iMode As Integer,ByVal szTitle As ZString Ptr , ByVal szInitialDir As ZString Ptr, ByVal _szFilter As ZString Ptr, ByVal iFlags As Dword, ByVal szName As ZString Ptr) as String

Type FOLDER_PROPS
   Dim lpszTitle As ZString Ptr
   Dim lpszInitialFolder As ZString Ptr
   Dim As UInteger ulFlags
End Type 

Function FileOpenSaveDialog(iMode as Integer, ByVal szTitle As ZString Ptr , ByVal szInitialDir As ZString Ptr, ByVal _szFilter As ZString Ptr, ByVal iFlags As Dword, ByVal szName As ZString Ptr) as String
   Dim ofn As OPENFILENAME
   Dim buff As ZString*260
   Dim sz_Filter as ZString Ptr
   Dim iIndex As UInteger
   ofn.lStructSize=SizeOf(OPENFILENAME)
   ofn.hwndOwner=NULL
   ofn.hInstance=GetModuleHandle(NULL)
   ofn.lpstrInitialDir= szInitialDir
   buff=String(260,0)
   If szName Then
       StrCpy(buff,szName)
   EndIf
   ofn.lpstrFile=@buff
   ofn.nMaxFile=260
   sz_Filter = malloc(StrLen(_szFilter)+2)
   StrCpy(sz_Filter,_szFilter)
   sz_Filter[StrLen(sz_Filter)+1] = 0
   For iIndex = 0 To StrLen(sz_Filter) - 1
      If sz_Filter[iIndex] = Asc("|") Then sz_Filter[iIndex] = 0
   Next iIndex
   ofn.lpstrFilter = sz_Filter
   ofn.lpstrTitle = szTitle
    If iFlags = 0 Then 
       ofn.Flags = iFlags
    EndIf
    If iMode = 0 Then
       If GetOpenFileName(@ofn) Then Function =  buff
    Else
       If GetSaveFileName(@ofn) Then Function =  buff
    EndIf
    free(sz_Filter)
End Function

#EndIf


'   ファイルを行ソート

Dim Filehandle As Integer
Dim FileName As String
Dim SortedFileName As String
Dim StartTime As Double
Dim EndTime As Double
Const MaxLines As Long =15000000    '最大入力行数
'Const MaxLines As Long =300    '最大入力行数
Dim Shared InData(MaxLines) As String
Dim Lines As Long     '入力行数
Dim LineCounter As Long
Dim text As String


Dim fName As String     '★拡張子無しのファイル名
Dim extension As String '★拡張子部分(例：.txt)
Dim e As Integer        'エラー№
Dim FullPass As String  '対象ファイルのフルパス  


   
'********************* ファイルを開くダイアログを使う *********************
 
 Dim buff As ZString*260
 Dim ofnFlags As Integer

   ''FileOpen
   
   ofnFlags = OFN_EXPLORER Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_EXPLORER
   buff = FileOpenDialog("Open","C:\test","テキストファイル(*.txt;*.csv;*.htm*)|*.txt;*.csv;*.htm*|全てのファイル(*.*)|*.*",ofnFlags,"")
   FullPass = RTrim(buff)

   fName = Left(FullPass,InStrRev(FullPass,".") -1)  '対象のテキストファイルのフルパスの、拡張子無し部分
   extension = Right(FullPass,Len(FullPass) - InStrRev(FullPass,".") +1) '対象テキストファイルのドット付き拡張子部分


   StartTime = Now

   ' テキストファイルの内容読み込み処理
   FileName=FullPass
   Lines = 0

   Filehandle = FreeFile
   Open FileName For Input As #Filehandle ' テキストファイルのオープン

   If LOF(Filehandle) > 0 Then
      Do Until EOF(Filehandle )     
         'ReDim Preserve InData(Lines)
         Line Input #Filehandle, text     ' 1行読み込み
         InData(Lines)=text
         Lines = Lines + 1
         If Lines>MaxLines-100 Then 
            Print LINES ;"行読み込みました。配列の設定の上限に達したので、終了します。"
            Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。
            Sleep
            End
         EndIf
         If LINES Mod 500000 = 0 Then
            Print LINES ;"行読み込みました。"
         EndIf
      Loop     
   Else
           Goto HandleErrors
   End If
   
   Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。

   ' ソートします
   Print "行数：" ; Lines ; " のファイルをソートします。"
     QuickSort( InData(), 0, Lines - 1)        ' FreeBASIC では、Call が使えない
   Print "ソートを終了しました。結果を出力します。"
   
   ' 結果を名前を変えて出力します。
   SortedFileName = fName    & "Sorted" & extension
   
     Filehandle = FreeFile
   
   Open SortedFileName  For Output As #Filehandle

   For LineCounter = 0 To Lines - 1
       Print #Filehandle, InData(LineCounter)
       
      If (LineCounter+1) Mod 500000 = 0 Then
         Print LineCounter+1 ;"行、書き出しました。"
      EndIf
       
   Next

   Close #Filehandle                        '' ファイル番号を通したファイルを閉じます。

    EndTime = Now
    
    Print StartTime , "開始時刻" , Format (StartTime, "yyyy/mm/dd hh:mm:ss")
    Print EndTime   , "終了時刻" , Format (EndTime, "yyyy/mm/dd hh:mm:ss")
    
    Print "ソートを終わりました。" & vbNewLine _
    & "処理時間は、" _
    & Format(EndTime - StartTime, "hh 時間 mm 分 ss 秒") & " でした。"
   Sleep
   End
   
   HandleErrors:
   Print "ファイルが見つかりません"
   Sleep
   

'************************************************
'★★★数値ソート★★★
Sub QuickSort( DataArray() As String ,  LowLimit  As Long,  UpLimit  As Long)

'Sub QuickSort(ByRef DataArray() As String , ByVal LowLimit  As Long, ByVal UpLimit  As Long)

'よねさんのWordとExcelの小部屋
'http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_array2.html
'をそのまま使わせていただいています。

   Dim i As Long
   Dim j As Long
   Dim MidNumber  As String  'As Variant '中央の要素行の内容
   Dim Temp  As String '一時待避
 
   MidNumber = DataArray(Int((LowLimit + UpLimit) / 2))
   i = LowLimit
   j = UpLimit
   Do
      Do While DataArray(i) < MidNumber
         i = i + 1
      Loop
      Do While DataArray(j) > MidNumber
         j = j - 1
      Loop
      If i >= j Then Exit Do
      Temp = DataArray(i)
      DataArray(i) = DataArray(j)
      DataArray(j) = Temp
      i = i + 1
      j = j - 1
   Loop
   If (LowLimit < i - 1) Then QuickSort( DataArray(), LowLimit, i - 1)
   If (UpLimit > j + 1) Then QuickSort( DataArray(), j + 1, UpLimit)
End Sub

ページの頭に戻る

　次は、dabooda さんが、Cの短いコードを FBに翻訳したもので、既存の関数を使わずにクイックソート・ルーチンを実装できます。

　必要な部分は、最後の二つのサブルーティンで、これは素晴らしく短いコードです。
　このプログラムを作ってくれた、見知らぬ人に感謝します。

dabooda ≫ Aug 28, 2008 16:54

'Quick Sort Routine
'by dabooda ≫ Aug 28, 2008 16:54 
'https://www.freebasic.net/forum/viewtopic.php?p=105602

'簡単なソート・ルーチン

'宣言(内容は、後ろで定義されます)
Declare Sub QUICKSORT(As Integer Ptr, As Integer)
Declare Sub Q_SORT(As Integer Ptr, As Integer, As Integer)

'この数字を昇順に並べます
Const DATA_COUNT = 10   '!!NEVER SET BELOW 2!!

'乱数を設定
Randomize Timer

'我々の配列
Dim As Integer MY_DATA(0 To DATA_COUNT-1)

'索引に使う変数
Dim As Integer COUNT, INDEX, COMPARE

'配列に乱数を格納します
COUNT = 0
Do
   MY_DATA(COUNT) = (Rnd*900) + 100
   COUNT+=1
Loop Until COUNT = DATA_COUNT

'#### ソート・ルーチンを開始 ####  -  速くするためです
'実際のソート・ルーチンは、このコードの最後にあります。
'C++ のコードから移植したものです。

'ここでは呼び出すだけです!!
QUICKSORT @MY_DATA(0), DATA_COUNT

'#### ソート・ルーチンを終了 ####

'結果を表示
Print "昇順で並び替えた MY_DATA:"
COUNT = 0
Do
   Print "VALUE (" + Str$(COUNT) + ") = " + Str$(MY_DATA(COUNT))
   COUNT+=1
Loop Until COUNT = DATA_COUNT
Print 
Print "なにかキー入力すると、終了します..."

Sleep

End

'#### これがクイック・ソートのサブルーチンです ####
Sub QUICKSORT(NUMBERS As Integer Ptr, ARRAY_SIZE As Integer)
   Q_SORT NUMBERS, 0, ARRAY_SIZE - 1
End Sub

Sub Q_SORT(NUMBERS As Integer Ptr, ILEFT As Integer, IRIGHT As Integer)
   Dim As Integer PIVOT, L_HOLD, R_HOLD
   
   L_HOLD = ILEFT
   R_HOLD = IRIGHT
   PIVOT = NUMBERS[ILEFT]
   
   While (ILEFT < IRIGHT)
      While ((NUMBERS[IRIGHT] >= PIVOT) And (ILEFT < IRIGHT))
         IRIGHT-=1
      Wend
      If (ILEFT <> IRIGHT) Then
         NUMBERS[ILEFT] = NUMBERS[IRIGHT]
         ILEFT+=1
      EndIf
      While ((NUMBERS[ILEFT] <= PIVOT) And (ILEFT < IRIGHT))
         ILEFT+=1
      Wend
      If (ILEFT <> IRIGHT) Then
         NUMBERS[IRIGHT] = NUMBERS[ILEFT]
         IRIGHT -= 1
      EndIf
   Wend
   
   NUMBERS[ILEFT] = PIVOT
   PIVOT = ILEFT
   ILEFT = L_HOLD
   IRIGHT = R_HOLD
   If (ILEFT < PIVOT) Then Q_SORT NUMBERS, ILEFT, PIVOT - 1
   If (IRIGHT > PIVOT) Then Q_SORT NUMBERS, PIVOT+1, IRIGHT
   
End Sub

ページの頭に戻る

h4tt3n ≫ Aug 29, 2008 14:11

'Quick Sort Routine
'by h4tt3n ≫ Aug 29, 2008 14:11 
'https://www.freebasic.net/forum/viewtopic.php?p=105602

''   再帰クイック・ソートの実装
''   ソース・コードは、下記によりました: 
''   http://www.java2s.com/Code/C/Data-Structure-Algorithm/TheQuicksort.htm

Randomize Timer

Const num_elements    = 49
Const min_value         = 1
Const max_value         = 1000

#Define QSORT_DATA_TYPE Uinteger

Declare sub qsort OverLoad (A() As QSORT_DATA_TYPE)
Declare sub qsort (A() As QSORT_DATA_TYPE, L As Integer, R As Integer)

Dim As QSORT_DATA_TYPE myarray(num_elements)

''   乱数を割り当てます
For i As Integer = 0 To num_elements
   myarray(i) = min_value + Rnd*(max_value-min_value)
Next

''   ソート前の状態を表示
Print "ソート前の配列:"
For i As Integer = 0 To num_elements
   Print myarray(i),
Next

''   ソート
qsort myarray()

Print

''   結果を表示
Print "並び替えた配列:"
For i As Integer = 0 To num_elements
   Print myarray(i),
Next

Sleep

End

sub qsort(A() As QSORT_DATA_TYPE)
   qsort(A(), LBound(A), UBound(A))
End Sub


sub qsort(A() As QSORT_DATA_TYPE, L As Integer, R As Integer)
   
   If L < R Then
      Dim As Integer i = L, j = R
      Dim As QSORT_DATA_TYPE Pivot = A((L+R)*0.5)
      Do
         While A(i) < Pivot And i < R: i += 1: Wend
         While A(j) > Pivot And j > L: j -= 1: Wend
         If i <= j Then swap A(i), A(j): i += 1: j -= 1
      Loop While i <= j
      If L < j Then qsort(A(), L, j)
      If R > i Then qsort(A(), i, R)
   End If
    
End Sub

ページの頭に戻る

補足に戻る

←リンク元に戻る　プログラム開発関連に戻る

ページ歴史:2008-08-29 14:11
日本語翻訳：WATANABE Makoto、原文著作者：dabooda、h4tt3n

FreeBASIC クイック・ソート・ルーチン

クイック・ソート・ルーチン 左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

クイック・ソート・ルーチン　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい