FreeBASIC マニュアルのトップに戻る

FreeBASIC 高速ソート Sort Array

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

高速ソート Sort Array　左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

←リンク元に戻る　プログラム開発関連に戻る
Sort Array
by I3I2UI/I0 ≫ Jan 16, 2012 16:39

　Qsort、ASM_QSort、RapidSort の3種類のソート方法で、処理時間を表示します。
　'RapidSort'アルゴリズムは、変数が整数である特定の場合のために最適化されていて、整数の場合は、最速です。

'Sort Array
'by I3I2UI/I0 ≫ Jan 16, 2012 16:39
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268

Dim As UInteger MaxSize = 2000000
Dim Shared NumArray(MaxSize) As UInteger
Randomize Timer
Sub Qsort(start As Integer,Finish As UInteger)
  Dim As UInteger I=start,J=Finish,X=NumArray(Int((I+J)/2)),A
  While  I <= J
    While NumArray(I) < X
      I+=1
    Wend
    While NumArray(J) > X
      J-=1
    Wend
    If I<=J Then
      A = NumArray(I)
      NumArray(I) = NumArray(J)
      NumArray(J) = A
      I+=1
      J-=1
    EndIf
  Wend
  If J > Start Then Qsort(start,J)
  If I < Finish Then Qsort(I,Finish)
End Sub

Sub ASM_QSort(a() As Integer, l As Integer, r As Integer)
  Dim As Integer i=l, j=r, x=a((l+r)\2)
Asm
 QS_L0:              'Do
  mov ecx, [a]
  mov ecx, [ecx]
 QS_L1:
  mov ebx, [i]
  lea edi, [ecx+ebx*4]
  mov ebx, [x]
  cmp [edi], ebx     'While a(i)<x
  jge QS_L2
  inc dword ptr [i]  'i+=1
  jmp QS_L1
 QS_L2:
  mov ebx, [j]
  lea esi, [ecx+ebx*4]
  mov eax, [esi]
  cmp [x], eax       'While x<a(j)
  jge QS_L3
  dec dword ptr [j]  'j-=1
  jmp QS_L2
 QS_L3:
  cmp [i], ebx       'If i<=j Then
  jg QS_L4
  mov eax, [edi]     'Swap a(i), a(j)
  xchg eax, [esi]
  mov [edi], eax 
  inc dword ptr [i]  'i+=1
  dec dword ptr [j]  'j-=1
 QS_L4:
  cmp [i], ebx       'Loop Until i>j
  jle QS_L0
End Asm 
  If l<j Then ASM_QSort(a(), l, j)
  If i<r Then ASM_QSort(a(), i, r)
End Sub

Sub RapidSort (Item()As Integer, LoElement As Integer, HiElement As Integer)
  Dim As Integer n, wert, nptr, arr, rep, LoVal, HiVal
  LoVal=Item(LoElement)
  HiVal=Item(HiElement)
  For n=LoElement To HiElement
    If LoVal> Item(n) Then LoVal=Item(n)
    If HiVal< Item(n) Then HiVal=Item(n)
  Next
  ReDim SortArray(LoVal To HiVal) As Integer
  For n=LoElement To HiElement
    wert=Item(n)
    SortArray(wert)=SortArray(wert)+1
  Next
  nptr=LoElement-1
  For arr=LoVal To HiVal
    rep=SortArray(arr)
    For n=1 To rep
      nptr=nptr+1
      Item(nptr)=arr
    Next
  Next
  Erase SortArray
End Sub

Dim t As Double
Print "Qsort     ";
For I As Integer=1 To MaxSize
  NumArray(I) = Int(Rnd*MaxSize)
Next
t=Timer
Qsort(1,MaxSize)
?Timer-t

Print "ASM_QSort ";
For I As Integer=1 To MaxSize
  NumArray(I) = Int(Rnd*MaxSize)
Next
t=Timer
ASM_QSort(NumArray(),1,MaxSize)
?Timer-t

Print "RapidSort ";
For I As Integer=1 To MaxSize
  NumArray(I) = Int(Rnd*MaxSize)
Next
t=Timer
RapidSort(NumArray(),1,MaxSize)
?Timer-t
Sleep

ページの頭に戻る

Sort Array
by MichaelW ≫ Feb 02, 2012 3:41

　CRT qsort 関数は、コンパイラーに最適化され、非再帰的な「クイックソート-挿入ソート」ハイブリッドを実行します。
それぞれの比較で別々の関数を呼ばなければならないにもかかわらず、単純な再帰的なバージョンよりはるかに速いです。


'Sort Array
'by MichaelW ≫ Feb 02, 2012 3:41 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268

''=============================================================================
#include "crt.bi"
''=============================================================================
Dim As UInteger MaxSize = 1000000
Dim Shared NumArray(MaxSize) As UInteger
Randomize Timer
''=============================================================================

function compare naked cdecl( byval elem1 as any ptr, _
                              byval elem2 as any ptr ) as integer
  asm
      mov ecx, [esp+4]
      mov edx, [esp+8]
      mov eax, [ecx]
      sub eax, [edx]
      ret
  end asm
end function

''=============================================================================

Sub _Qsort(start As Integer,Finish As UInteger)
   Dim As UInteger I=start,J=Finish,X=NumArray(Int((I+J)/2)),A
   While  I <= J
      While NumArray(I) < X
         I+=1
      Wend
      While NumArray(J) > X
         J-=1
      Wend
      If I<=J Then
         A = NumArray(I)
         NumArray(I) = NumArray(J)
         NumArray(J) = A
         I+=1
         J-=1
      EndIf
   Wend
   If J > Start Then _Qsort(start,J)
   If I < Finish Then _Qsort(I,Finish)
End Sub

''=============================================================================

/'
Print "Unsorted Array"
For I As Integer=1 To MaxSize
   NumArray(I) = Int(Rnd*100)
   Print NumArray(I);" ";
Next
print
_Qsort(1,MaxSize)
Print "Sorted Array"
For I As Integer=1 To MaxSize
   Print NumArray(I);" ";
Next
print

Print "Unsorted Array"
For I As Integer=1 To MaxSize
   NumArray(I) = Int(Rnd*100)
   Print NumArray(I);" ";
Next
print
qsort( @NumArray(1), MaxSize, 4, @compare )
Print "Sorted Array"
For I As Integer=1 To MaxSize
   Print NumArray(I);" ";
Next
print
'/

sleep 3000

dim as double t
t = timer
_Qsort(1,MaxSize)
print using "Qsort ##.###";timer-t

t = timer
qsort( @NumArray(1), MaxSize, 4, @compare )
print using "qsort ##.###";timer-t

sleep

ページの頭に戻る

Sort Array
by dafhi ≫ Feb 02, 2012 5:31

　私のソートは、上の crt qsort より、6% ほど速いが、70k ほど大きいだけです。

'Sort Array
'by dafhi ≫ Feb 02, 2012 5:31 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268

Dim As Integer NumElements = 65000

Dim Shared As double mTimeQ,mTimeG,MinLoopTime
Dim Shared As String strNum,strDen

#include "crt.bi"

function compare naked cdecl( byval elem1 as any ptr, _
                              byval elem2 as any ptr ) as integer
  asm
      mov ecx, [esp+4]
      mov edx, [esp+8]
      mov eax, [ecx]
      sub eax, [edx]
      ret
  end asm
end function

'' LerpSort by cRex

'' also included: cRex-modified quicksort

'' Both:
'' 1. index reference array, swapping those vals (for langs w/o pointers)
'' 2. post-sort cycle swap for minimum user-data movement

Dim Shared As Integer Q, UB,LB
Dim Shared As Integer Sorted,mDelta,SwapI_
Dim Shared As Single SwapVar,mDelt

#Macro zSort3C(pLo,pMid,pHi,A) ''CycleSort version
    If A(pLo) <= A(pMid) Then
        If A(pMid) <= A(pHi) Then '123
        Else
            If A(pLo) <= A(pHi) Then '132
                SwapI_ = pMid
                pMid = pHi: pHi = SwapI_
            Else '231
                SwapI_ = pHi
                pHi = pMid
                pMid = pLo: pLo = SwapI_
            End If
        End If
    Else 'plo > pMid
        If A(pMid) <= A(pHi) Then
            If A(pLo) <= A(pHi) Then   '213
                SwapI_ = pMid
                pMid = pLo: pLo = SwapI_
            Else '312
                SwapI_ = pLo
                pLo = pMid
                pMid = pHi: pHi = SwapI_
            End If
        Else '321
            SwapI_ = pLo
            pLo = pHi: pHi = SwapI_
        End If
    End If
#EndMacro
#Macro zIfSwapC(I_,J_,A) ''CycleSort version
   If A(I_) > A(J_) Then
      Swap I_, J_
   EndIf
#EndMacro
#Macro zInsertionSortC(A,lSt,lEnd,pBtr) ''CycleSort version
   I_ = lSt
   For J_ = I_ + 1 To lEnd
      If A(pBtr(I_)) > A(pBtr(J_)) Then
         Swap_=pBtr(J_)
         SwapVar = A(Swap_)
         Copy_ = I_
         pBtr(J_) = pBtr(Copy_)
         For I_ = J_ - 2 To lSt Step -1
            If A(pBtr(I_)) <= SwapVar Then Exit For
            pBtr(Copy_) = pBtr(I_)
            Copy_ = I_
         Next
         pBtr(Copy_) = Swap_
      End If
      I_ = J_
   Next
#EndMacro

Private Sub zCycleSort(pSt As Integer, pEnd As Integer, pBtr() As Integer, A() As Single)
Dim J As Integer, K As Integer

   For pSt = pSt To pEnd
      K = pBtr(pSt)
      If K <> pSt Then
         J = pSt
         SwapVar = A(J)
         Do
            A(J) = A(K)
            J = K
            K = pBtr(K)
            pBtr(J) = J ' "Null"
            If K = pSt Then Exit Do
         Loop
         A(J) = SwapVar
         pBtr(K) = K
      End If
   Next
End Sub


#Macro zInitIndices(IndxAry)
   ReDim IndxAry(UBound(A))
   For I_ = 0 To UBound(A)
      IndxAry(I_) = I_
   Next
#EndMacro

Private sub zLerpSortC(pSt As Integer,pEnd As Integer,A() As Single,pBtr() As Integer,Final() As Integer,Lerp_() As Integer)
   Dim As Integer I_,J_,K_

'' : : About LerpSort (cyclesort version) : :

'' 1. LBound must be zero
'' 2. LerpSort creates at least 4 Integer arrays
'' 3. (2011 July 1) - discovered that LerpSort is identical
''    to FlashSort by Karl Dietrich Neubert

   I_ = pSt
   J_ = pSt    
   Sorted = -1
   For K_ = pSt + 1 To pEnd
      ''pBtr = "pointers"   
      If A(pBtr(J_)) <= A(pBtr(K_)) Then
         J_ = K_
      Else
         Sorted = 0
         If A(pBtr(I_)) > A(pBtr(K_)) Then
         I_ = K_
         End If
      End If
   Next

   If Sorted Then Exit Sub
   
   mDelta = pEnd - pSt    
   Dim lStack(mDelta) As Integer '' created here in case recursive LerpSort
   
   I_ = pBtr(I_)
   mDelt = A(pBtr(J_)) - A(I_)    
   mDelt = mDelta / mDelt
   
   For K_ = pSt To pEnd
   J_ = (A(pBtr(K_)) - A(I_)) * mDelt
   Lerp_(K_) = J_
   lStack(J_) += 1
   Next
   
   I_ = pSt + lStack(0)
   lStack(0) = pSt
   For J_ = 1 To mDelta
      If lStack(J_) > 0 Then
         K_ = lStack(J_)
         lStack(J_) = I_
         I_ = I_ + K_
      End If
   Next
   
   For I_ = pSt To pEnd
   J_ = Lerp_(I_)
   Final(lStack(J_)) = pBtr(I_)
   lStack(J_) = lStack(J_) + 1
   Next
   
   For I_ = pSt To pEnd  
      pBtr(I_) = Final(I_) ''CycleSwap after LerpSort
   Next

   Dim As Integer   Swap_, Copy_ '' InsertionSort Macro
   Dim As Integer L_

   For L_ = 0 To mDelta
      pEnd = lStack(L_)
      I_ = pEnd - pSt
      If I_ < 1 Then
      ElseIf I_ = 1 Then
         pSt = pEnd
      ElseIf I_ = 2 Then
         zIfSwapC(pBtr(pSt), pBtr(pEnd - 1), A)
         pSt = pEnd
      ElseIf I_ = 3 Then
         zSort3C(pBtr(pSt), pBtr(pSt + 1), pBtr(pEnd - 1), A)
         pSt = pEnd
      ElseIf I_ < 10 Then
         zInsertionSortC(A,pSt,pEnd - 1,pBtr)
         pSt = pEnd
      Else
         zLerpSortC pSt,pEnd - 1,A(),pBtr(),Final(),Lerp_()
         pSt = pEnd
      End If
   Next

End Sub
Sub LerpSort(A() As Single)

   mDelta = UBound(A)
   If mDelta = 0 Then Exit Sub
   
   Dim As Integer I_,J_,pBtr()
   zInitIndices(pBtr)
   
   If mDelta = 1 Then
      zIfSwapC(pBtr(0), pBtr(1), A)
   ElseIf mDelta = 2 Then
      zSort3C(pBtr(0), pBtr(1), pBtr(2), A)
   Else
      Dim As Integer lSt
   
      Dim Final() As Integer
      Dim Lerp_() As Integer
      
      ReDim Final(mDelta)
      ReDim Lerp_(mDelta)
      
      zLerpSortC lSt,mDelta,A(),pBtr(),Final(),Lerp_()
      
   End If            
   zCycleSort 0, UBound(A), pBtr(), A()
End Sub

Private Sub zTimerCompare(A() As Single,ByRef RetTotal_ As Double)

    mTimeQ = Timer - mTimeQ
    RetTotal_ = RetTotal_ + mTimeQ

Dim As Integer J, I
    For J = 1 To UB
        If A(I) > A(J) Then
            Q = Q + 1
            ? "Sort Problem!"
            Exit For
        End If
        I = J
    Next
    mDelta = UB - LB
    For J = 0 To UB
        A(J) = Rnd * UB'-J
    Next
    Sleep 1
End Sub

Private Sub Test(A() As Single,U_ As Integer)
Dim TQ_    As Double, TG_  As Double
Dim Q2 As Integer
Dim lTimer  As Double

   UB = U_
   ReDim A(U_)
   For Q = 0 To U_
      A(Q) = Rnd * U_
   Next
   
   Q = 1
   Q2 = Q   
   lTimer = Timer
      
   Do
      Q2 = Q

      strDen = "Quick"

      mTimeQ = Timer
      qsort( @A(0), UB+1, 4, @compare )
      zTimerCompare A(), TQ_
      If Q > Q2 Then
      ? "Quick " & Q2
      GoTo OHNO
      End If
      
      strNum = "Lerp"
      
      mTimeQ = Timer
      LerpSort A()
      zTimerCompare A(),TG_
      If Q > Q2 Then
      ? "Lerp " & Q2
      GoTo OHNO
      End If
      
      If MinLoopTime <= (timer - lTimer) Then Exit Do
      Q += 1
   Loop
   
   mTimeQ = TQ_
   mTimeG = TG_
   
   OHNO:
   Q = 0
End Sub
Randomize Timer
MinLoopTime = 1.5

Dim MyData() As Single
Test MyData(), NumElements

If mTimeQ <> 0 Then Print strNum & " / " & strDen & " = " & mTimeG / mTimeQ

Sleep

ページの頭に戻る
 
補足 に戻る
←リンク元に戻る　プログラム開発関連に戻る
ページ歴史:2012-02-02 05:31
日本語翻訳：WATANABE Makoto、原文著作者：I3I2UI/I0、MichaelW、dafhi

ホームページのトップに戻る

表示-非営利-継承