'===========================================================================
' Subject: EMS QUICK SORTING PROCEDURE       Date: 06-23-99 (15:06)       
' Author:  Alexander Podkolzin               Code: PB                     
' Origin:  APP@nw.sbank.e-burg.su          Packet: PB.ABC
'===========================================================================
'---------------------------------------------------------------------------
' EMS quick sorting procedure with demo.
' Quick sorting (non recursive) algorithm is from
' Ethan Winer's book "BASIC Techniques and Utilities".
' Thank you Ethan from all of us!
' Hope this program will be usefull for PB-programmers.
' Copyright status - PUBLIC DOMAIN.
'---------------------------------------------------------------------------
 $DIM ALL
 $COMPILE MEMORY
 %Ss = 512                         ' Max length of a string
 %Ascending  =  1
 %Descending = -1
'---------------------------------------------------------------------------
 Declare Sub VirtualSortString( _
         Txt() As String * %Ss, _
         Byval FirstElement As Integer, _
         Byval NumberOfElements As Integer, _
         Byval StartPosition As Integer, _
         Byval NumberOfPositions As Integer, _
         Byval Order As Integer _
         )
'---------------------------------------------------------------------------
 If Fre(-11) = 0 Then
   Print "EMS unavailable!"
   End
 End If

 Dim i As Integer
 Dim n As Integer
 Dim q As Integer
 Dim s As string

 Cls
 n = 1000

 Dim Virtual x(1:n) As String * %Ss

 ? "Filling array of" + Str$(n) + " random virtual strings...";
 ? "Done!"
 For i = 1 To n
   s = Using$("#####", Rnd(1, n))
   x(i) = Left$(s + String$( %Ss - 5, "A"), 80)
 Next i

 ? "Before sorting (first and last elements):"
 ? Left$(x(1), 80);
 ? Left$(x(n), 80);

 ? "Sorting...";
 VirtualSortString x(), 1, n, 1, 5, %Ascending

 ? "Done!"
 ? "After sorting (first and last elements):"
 ? Left$(x(1), 80);
 ? Left$(x(n), 80);
 ? "----------------------"
 ? "Thanks to Ethan Winer!"
 End

'---------------------------------------------------------------------------
 Sub VirtualSortString(Txt() As String * %Ss, _
                       Byval FirstElement As Integer, _
                       Byval NumberOfElements As Integer, _
                       Byval StartPosition As Integer, _
                       Byval NumberOfPositions As Integer, _
                       Byval Order As Integer)

   Dim Temp As String
   Dim TempForSwap As String * %Ss
   Dim StackPtr As Integer
   Dim I As Integer
   Dim J As Integer
   Dim QStack(0) As Integer
   Dim LastElement As Integer

   If NumberOfElements < 2 Then Exit Sub    'Nothing to sort
   LastElement = FirstElement + NumberOfElements - 1

   Redim QStack(LastElement \ 5 + 10)
   StackPtr = 0
   Do
     Do
       Temp = Mid$(Txt((LastElement \ 2) + (FirstElement \ 2)), _
              StartPosition, NumberOfPositions)

       I = FirstElement: J = LastElement
       Do
         If Order = 1 Then             'Ascending
           Do While Mid$(Txt(I), StartPosition, NumberOfPositions) < Temp
             Incr I
           Loop
           Do While Mid$(Txt(J), StartPosition, NumberOfPositions) > Temp
             Decr J
           Loop
         Else                          'Descending
           Do While Mid$(Txt(I), StartPosition, NumberOfPositions) > Temp
             Incr I
           Loop
           Do While Mid$(Txt(J), StartPosition, NumberOfPositions) < Temp
             Decr J
           Loop
         End If
         If I > J Then Exit Do
         If I < J Then
           TempForSwap = Txt(J)
           Txt(J) = Txt(I)
           Txt(I) = TempForSwap
         End If
         Incr I
         Decr J
       Loop While I <= J
       If I < LastElement Then
         QStack(StackPtr) = I
         QStack(StackPtr + 1) = LastElement
         Incr StackPtr, 2
       End If
       LastElement = J
     Loop While FirstElement < LastElement
     If StackPtr = 0 Then Exit Do
     Decr StackPtr, 2
     FirstElement = QStack(StackPtr)
     LastElement = QStack(StackPtr + 1)
   Loop
   Erase QStack
 End Sub
'---------------------------------------------------------------------------