Sort Array

[dodicat]

The simple combsort is fast and versatile.
Example:

Code: Select all

 

#macro combsort(array,begin,finish,dot)
Scope
    Var size=(finish),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.3: If void<1 Then void=1
        switch=0
        For i As Integer =(begin) To size-void
            j=i+void
            If array(i)dot>array(j)dot Then 
                Swap array(i),array(j): switch=1
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro
'========================================================

'example

#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))

type anytype
    as integer field1
    as double field2
    as string field3
end type

'set up some values
dim as integer number=200000
dim as anytype x(1 to number)
for n as integer=1 to number
    with x(n)
        .field1=IntRange(0,20000000)
        .field2=rnd*1000-rnd*1000
        .field3=chr(IntRange(65,90))+chr(IntRange(65,90))+chr(IntRange(65,90))
    end with
next n

'just to print out the start and end of the array
sub printbits(k() as anytype)
    for n as integer=1 to 10
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print
    print " ..."
    print
    for n as integer=ubound(k)-10 to ubound(k) 
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print
    print "_____________________________"
    print
    print
end sub

print
print "  field1","  field2","            field3"
print

printbits(x())

combsort(x,lbound(x),ubound(x),.field1)

printbits(x())

combsort(x,lbound(x),ubound(x),.field2)

printbits(x())

combsort(x,lbound(x),ubound(x),.field3)

printbits(x())
sleep

 

[MichaelW]

I am impressed with these sorts. maybe you can help me on multiple key sort.
I need to sort my sort index by date and time and then alphabetically.
I do not know how to do this in one hit.

I cannot see any way to do it in one sort. And as you may already know, for doing it with two sorts the second sort must be stable so it can preserve the order of equal keys from the first sort. A Comb sort is unfortunately not stable. Insertion sort, like a Bubble sort, is stable and has an N^2 run time, but since the first sort will have nearly sorted the array, the actual run time for Insertion sort will be much lower than it would be for Bubble sort.

[dafhi]

It might be possible to sort in one pass. I understand that Date keys would likely contain duplicates. Sorting the sub-keys would thus go quicker for non O(N) sorts.

[Roe5685]

to dodicat!!
now this is brilliant multikey sort code and I thank you. I see your example of 3 could be 10 or 20.
I tested it with 250,000 real world entries. seems as fast as quick sort just on the large date number even though it is going on to sort the name too out to 14 letters. ( there are lots of files created the same minute ). I see that while I only sorted on 2 keys it could have been say 10. Thanks again!
As so you know your code does each field on its own. I adjusted it to multiple keys.
Also I needed to sort the index to use on the very large number being dates from years down to minutes.
I do not understand the macro. I do not understand why I not need to declare. and how to I get away with not using ()?
the code:

Code: Select all

#macro combsort(array,begin,finish,dot,dot2,SortIndex )
Scope
    Var size=(finish),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.2: If void<1 Then void=1
        switch=0
        For i As Integer =(begin) To size-void
            j=i+void
            If array(i)dot>array(j)dot Then 
                Swap array(i),array(j): switch=1
                Swap SortIndex(i),SortIndex(j)
            elseif array(i)dot=array(j)dot then
            if array(i)dot2>array(j)dot2 then
                Swap array(i),array(j):switch=1
                Swap SortIndex(i),SortIndex(j)
            end if    
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro
I called the code with :
dim as anytype x(0 to harry -1)
for n as integer=0 to harry -1
    with x(n)
        .field1=GT(n)
        .field2=lcase$(left$(viv(n).restofit,16))
    end with
next n
dim nnn as integer
combsort(x,lbound(x),ubound(x),.field1,.field2,SortIndex )

ANY IDEAS TO SPEED IT UP?

[dafhi]

this comb is a little faster. many thanks to dodicat for his brilliant macro work.

I have a string compare that's much faster than the built-in .. it's 600+ lines though.

Code: Select all

#Macro combsort(array,begin,finish,dot)
Scope
    Var size=(finish),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.3: If void<1 Then void=1
        switch=0
        For i As Integer =(begin) To size-void
            j=i+void
            If array(i)dot>array(j)dot Then 
                Swap array(i),array(j): switch=1
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro

#Macro combsort4(array,begin,finish,dot)
Scope

    dim as integer  gap = finish - begin
    Do While gap > 1
      For i As integer = begin To finish - gap
        Dim As Integer  j = i+gap
        If array(i)dot>array(i+gap)dot Then
            Swap array(i),array(j)
        EndIf
      Next
      gap *= 10
      gap \= 13
    Loop
    
    '' insertion sort
    Dim As TypeOf(array(begin)dot) swap_var
  	Dim As Integer i = begin, K=Any
  	For j As integer = i + 1 To finish
  		If array(i)dot > array(j)dot Then
  			swap_var = array(j)dot
  			Dim As Integer k = i
  			array(j)dot = array(i)dot
  			For i = k - 1 To begin Step -1
  				If array(i)dot <= swap_var Then Exit For
  				array(k)dot = array(i)dot
  				k = i
  			Next
  			array(k)dot = swap_var
  		End If
  		i = j
  	Next
  	
End Scope
#EndMacro

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

'example

#define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))

type anytype
    as integer field1
    as double field2
    as string field3
end type

'set up some values
dim as integer number=200000
dim as anytype x(1 to number)
for n as integer=1 to number
    with x(n)
        .field1=IntRange(0,20000000)
        .field2=rnd*1000-rnd*1000
        .field3=chr(IntRange(65,90))+chr(IntRange(65,90))+chr(IntRange(65,90))
    end with
next n

'just to print out the start and end of the array
sub printbits(k() as anytype)
    for n as integer=1 to 10
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print
    print " ..."
    print
    for n as integer=ubound(k)-10 to ubound(k) 
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print
    print "_____________________________"
    print
    print
end sub

print
print "  field1","  field2","            field3"
print

printbits(x())

combsort4(x,lbound(x),ubound(x),.field1)

printbits(x())

combsort4(x,lbound(x),ubound(x),.field2)

printbits(x())

combsort4(x,lbound(x),ubound(x),.field3)

printbits(x())
sleep

[Roe5685]

to dafhi.
I will give this a try too if I can figure out how to multiple key it.
thanks

[dodicat]

Hi Roe5685

Macros put the contained code inline.
If you compile either mine or Dafhi's with compiler switch pp, then you will get a pp.bas file.
e.g.
fbc -pp Mytest.bas
will give
Mytestpp.bas.

You will see then how the macro parameters pan out.
Just a caution when using macros:
Send off your parameters in brackets if they are more complex than a single variable.
e.g.
combsort(array,(lbound(array)+10),(ubound(array)-10),.something)

The quicksort cannot be done by macro because it is recursive.
The insertionsort can be done ok though slightly differently.
The insertionsort is desperately slow for large arrays.

I've played about a bit with a large array here, so the final insertion sort operates on a reduced size array.
The dates are between 2005 and 2012.
Any names within any hour of a date are caught.
Please note, it's only messing about.
Oops, forgot the scope block in the macro.
ok.

Code: Select all

 

#macro insertionsort(array,field)
scope
    dim as integer j
   FOR row as integer= 1 TO ubound(array)
     var temp = array(row)
   j = row
    while j>=1 andalso array(j-1).field>temp.field
        array(j) = array(j - 1)
        j=j-1
    wend
    array(j)=temp
   next row
end scope
   #endmacro




type record
    as string date
    as string time
    as string name
end type



sub SetArtificialData(a() as record)
    #define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))
    dim as string d,m,y
   dim as string hr,min
    for n as integer=1 to ubound(a)
        var _Y=IntRange(2005,2012)
        y=str(_Y)
        var _M=IntRange(1,12)
        m=str(_M)
        select case  _M
        case 1,3,5,7,8,10,12
          d=str(IntRange(1,31))
      case 2
          if _Y mod 4=0 then d=str(IntRange(1,29)) else d=str(IntRange(1,28))
          case else
        d=str(IntRange(1,30))
    end select
    if len(d)=1 then d="0"+d
    if len(m)=1 then m="0"+m
      a(n).date=d+":"+m+":"+y
      hr=str(IntRange(0,23))
      min=str(IntRange(0,59))
      if len(hr)=1 then hr="0"+hr
      if len(min)=1 then min="0"+min
      
      a(n).time=hr+":"+min
      a(n).name=chr(IntRange(65,90),IntRange(65,90),IntRange(65,90),IntRange(65,90))
        
        next n
    end sub
   
   function search(a() as record,find() as record,_date as string,_time as string) as integer
       for n as integer=lbound(a) to ubound(a)
           if a(n).date=_date and left(a(n).time,2)=left(_time,2) then 'to hour only
               redim preserve find(ubound(find)+1)
               find(ubound(find))=a(n)
               end if
           next n
           return ubound(find)
       end function
 '===============================================================
 dim as integer number=500000
 dim as record People(1 to number)
 
 
 
 print "please wait"
 print "Creating ";number; "  dates and times"
 
SetArtificialData(People())

print "Data now set"

redim as record found()
print
if search(People(),found(),"06:08:2011","12:15") then
    print "Within the hour, these people signed on"

    for n as integer=lbound(found) to ubound(found)
        print found(n).date,found(n).time,found(n).name
    next n
    print
    print ubound(found) & "  found"
    insertionsort(found,name)
    print
    print "sorted by name"
    print
    for n as integer=lbound(found) to ubound(found)
        print found(n).date,found(n).time,found(n).name
        next n
else
    print "No matches"
    end if

sleep
 

[MichaelW]

The insertionsort is desperately slow for large arrays.

Insertion sort is fast for almost sorted arrays. But thinking more about it, I’m not sure how “almost sorted” the array would be after the first sort.

[dafhi]

@Roe5685 - actually, my string compare is not showing speed improvement over the combsort4 I posted. What I've done is create a natural sort, ie. "2" is not greater than "10"

Code: Select all

' sort macro v0.99 (2014 March 28)  by dafhi

' Usage:

' 1. sort(arr,.field3)  ' member
' 2. sort(arr,)         ' plain

' -------- SORT CODE BEGINS AFTER LINE 610 --------

' ----------------------------------------------- '
'  Less / More string compare functions by dafhi  '
'                                                 '
'  Ver 0.11 - 2012 July 14                        '
' ----------------------------------------------- '

/' Basics:

1. dir sort - recognizes symbols \ and /
2. "Junk" sorts to end
  A. empty strings
  B. Robert < R.
'/

Const                 CHUNKTYPE_NUMBER = 0
Const                 CHUNKTYPE_LETTER = 1
Const                 CHUNKTYPE_OTHER = 2

#Ifndef FALSE
Const FALSE = 0
Const TRUE = not FALSE
#endif

#Macro DimVars(FT_1,FT_2)

  dim as any ptr      _any = @A
  Dim As UInteger Ptr lpStr = _any
  Dim As UInteger     lena = lpStr[1]
  _any = @B: lpStr = _any
  Dim As UInteger     lenb = lpStr[1]
  
  if lena = 0 then
    if lenb > 0 then return FT_2
    Return FALSE
  elseif lenb = 0 then
    Return FT_1
  end if

  Dim As Integer      posa
  Dim As Integer      posb
  dim as uinteger     lena_M = lena - 1
  dim as uinteger     lenb_M = lenb - 1
  Dim As Integer      posa_st
  Dim As Integer      posb_st
  dim as integer      delt_a
  dim as integer      delt_b
  dim as integer      asc_A
  dim as integer      asc_B
  dim as integer      typ_A
  dim as integer      typ_B
  dim as integer      lrh_A
  dim as integer      lrh_B
#EndMacro

#Macro BreakCommon(FT_1,FT_2)
  If posa > lena_M Then
    If posb > lenb_M Then
      If lena_M > lenb_M Then
        Return FT_2
      ElseIf lenb_M > lena_M Then
        Return FT_1
      Else
        Return FALSE
      EndIf
    Else
      Return FT_1
    EndIf
  ElseIf posb > lenb_M Then
    Return FT_2
  EndIf
#EndMacro
#Macro EarlyBreak(FT_1,FT_2)
  If posa > lena_M Then
    If posb > lenb_M Then
      If lena_M > lenb_M Then
        Return FT_2
      ElseIf lenb_M > lena_M Then
        Return FT_1
      Else
        Return FALSE
      EndIf
    else
      Return FT_2
    EndIf
  ElseIf posb > lenb_M Then  
    Return FT_1
  EndIf
#EndMacro

'' ---------
'  Common
' ----------

#Macro AscRemap_Common(str_,pos_,lenm,asc_)
  asc_ = str_[pos_]
  if asc_ = 46 Then
    if pos_ < lenm then
      If NumFollows(@str_[pos_]) Then
      else
        asc_ = 255
      end if
    else
      asc_ = 255
    end If
#EndMacro

#Macro SelCase(pVar)
  Select Case pVar: Case
#EndMacro
#Macro Handle_Common()
  delt_a = lena_M - posa
  delt_b = lenb_M - posb
  if delt_a < delt_b then
#EndMacro
#Macro Handle_Common_PosSt()
  posa_st = posa
  posb_st = posb
  Handle_Common()
#EndMacro

#Macro Space_VS(FT_1,FT_2, str_1,pos_1, str_2,pos_2, lenm_1,lenm_2)
  SelCase( str_1[pos_1] ) 32,92 ''space, backslash (for dir sort)
    SelCase( str_2[pos_2] ) 32,92
    Case Else
      If pos_2 <= lenm_2 Then Return FT_1
    End Select  
  Case Else
    SelCase( str_2[pos_2] ) 32,92
      If pos_1 <= lenm_1 Then Return FT_2
    End Select  
  End Select
  
  /' equivalent, w/o backslash
  
  If str_1[pos_1] = 32 Then
    If str_2[pos_2] <> 32 Then
      If pos_2 <= lenm_2 Then Return FT_1
    EndIf
  ElseIf str_2[pos_2] = 32 Then
    If pos_1 <= lenm_1 Then Return FT_2
  EndIf
  
  '/
#EndMacro
#Macro SkipChar(str_,pos_,lenm,charval)
  For pos_ = pos_ to lenm
    if str_[pos_] <> charval then
      exit for
    end if
  next
#EndMacro
#Macro Skip_Space_BackSlash(str_,pos_,lenm)
  For pos_ = pos_ to lenm
    SelCase( str_[pos_] ) 32, 92
    Case Else
      exit for
    End Select
  next
#EndMacro


'' ----------
'  Asc Other
' -----------

Function asc_other(ByVal pAsc as integer) as integer
  select case pAsc
  case 48 to 57, 65 to 90, 97 to 122,32,92''space,backslash
    Return FALSE
  end select
  Return TRUE
end function
#Macro AscRemapOther(str_,pos_,lenm,asc_)
  AscRemap_Common(str_,pos_,lenm,asc_)
  elseif asc_other(asc_) then
    asc_ = 255
  end if
#EndMacro
#Macro Other_Loop(FT_1,FT_2,dlt_1,str_1,pos_1,lenm_1,asc_1,str_2,pos_2,lenm_2,asc_2)

  for pos_1 = pos_1 to pos_1 + dlt_1
    AscRemapOther(str_1,pos_1,lenm_1,asc_1)
    AscRemapOther(str_2,pos_2,lenm_2,asc_2)
    
    if asc_1 = 255 then
      if asc_2 <> 255 then
        Return FT_2
      end if
    elseif asc_2 = 255 then
      Return FT_1
    Else
      Exit for      
    end if
    pos_2 += 1
  next
  
#EndMacro

#Macro Other_Chunk(FT_1,FT_2)
  Handle_Common_PosSt()
  
    '' posa closest to end
    Other_Loop( FT_1,FT_2, delt_a, A,posa,lena_M,asc_A,B,posb,lenb_M,asc_B )
      
    ''posa went past end pos, A is smaller
    if posa = lena then Return FT_1

  elseif delt_b < delt_a then
    
    '' posb closest to end
    Other_Loop( FT_2,FT_1, delt_b, B,posb,lenb_M,asc_B, A,posa,lena_M,asc_A)

    ''posb went past end pos, B is smaller
    if posb = lenb then Return FT_2

  else
    
    '' posa and posb equidistant to end pos
    Other_Loop( FT_1,FT_2, delt_a, A,posa,lena_M,asc_A, B,posb,lenb_M,asc_B )

  end if
#EndMacro

'' ------------------
'  Asc Numeric
' -------------------

function NumFollows(ByVal lpUByt as ubyte ptr) as integer
  lpUByt += 1
  if *lpUByt > 57 then return false
  if *lpUByt < 48 then return false
  return TRUE
end Function
Function asc_non_numeric(ByVal pAsc As UInteger) As Integer
  If pAsc > 57 Then Return TRUE ''57 is "9"
  If pAsc < 48 Then Return TRUE ''48 is "0"
  Return FALSE
End Function
Function asc_numeric(ByVal pAsc As UInteger) As Integer
  If pAsc > 57 Then Return FALSE ''57 is "9"
  If pAsc < 48 Then Return FALSE ''48 is "0"
  Return TRUE
End Function
Function asc_1_To_9(ByVal pAsc As UInteger) As Integer
  If pAsc > 57 Then Return FALSE ''57 is "9"
  If pAsc < 49 Then Return FALSE ''48 is "0"
  Return TRUE
End Function
#Macro SeekNonNumeric(str_,pos_st,pos_,delt_,lenm)
  pos_st = pos_
  for pos_ = pos_ to lenm
    if str_[pos_] < 48 then exit for
    if str_[pos_] > 57 then exit for
  next
  delt_ = pos_ - pos_st
#EndMacro


'' ---------
'  Alphabet
' ----------

Function UCase_is_a_letter(ByRef pAsc As Integer) As Integer

  If pAsc > 96 Then '' 97 a
    If pAsc < 123 Then '' 122 z
      pAsc -= 32
    EndIf
  EndIf
  
  If pAsc < 65 Then Return FALSE '' A 65
  If pAsc > 90 Then Return FALSE '' Z 90
  
  Return TRUE
End Function
#Macro Make_UCase(str_,pos_,asc_)
  asc_=str_[pos_]
  If asc_ > 96 Then
    If asc_ < 123 Then
      asc_ -= 32
    EndIf
  EndIf
#EndMacro

#Macro Letters_Loop(FT_1,FT_2,dlt_1,asc_1,str_1,pos_1,len_1,asc_2,str_2,pos_2,len_2)
  Make_UCase(str_1,pos_1,asc_1)
  Make_UCase(str_2,pos_2,asc_2)
  
  If asc_1 < asc_2 Then
    Return FT_1
  ElseIf asc_2 < asc_1 Then
    Return FT_2
  EndIf
  
  pos_1 += 1
  pos_2 += 1
  
  for pos_1 = pos_1 to pos_1 + dlt_1 - 1
  
    Make_UCase(str_1,pos_1,asc_1)
    Make_UCase(str_2,pos_2,asc_2)
    
    SelCase( asc_1 ) 65 to 90
      SelCase( asc_2 ) 65 to 90
        If asc_1 < asc_2 Then
          Return FT_1
        ElseIf asc_2 < asc_1 Then
          Return FT_2
        EndIf
      Case 48 To 57, 32, 92 ''space, backslash (dir sorting)
          Return FT_2
      Case 46
        Exit For
      Case Else
        Return FT_1
      End Select
      
    case 48 To 57
      SelCase( asc_2 ) 48 To 57, 46
        Exit For
      Case 32, 92 ''space, backslash (dir sort)
        Return FT_2
      Case Else
        Return FT_1
      End Select
      
    Case 32, 92 ''space, backslash (dir sort)
      SelCase( asc_2 ) 65 to 90, 48 To 57, 46
        Return FT_1
      Case Else
        Exit For
      End Select
    
    Case 46
      Exit For
      
    Case Else
      SelCase( asc_2 ) 65 to 90, 48 To 57, 32, 92 ''space,backslash
        Return FT_2
      Case Else
        Exit For
      End Select
      
    End Select
    
    pos_2 += 1
    
  Next
  
  If asc_1 = 46 Then
    SelCase( asc_2 ) 32, 92 ''space,backslash
      If NumFollows( @str_1[pos_1] ) Then
      Else
        Return FT_2
      EndIf
    End Select
    /' equivalent, w/o backslash
    If asc_2 = 32 Then
      If NumFollows( @str_1[pos_1] ) Then
      Else
        Return FT_2
      EndIf
    EndIf
    '/
  ElseIf asc_2 = 46 Then
    SelCase( asc_1 ) 32, 92 ''space,backslash
      If NumFollows( @str_2[pos_2] ) Then
      Else
        Return FT_1
      EndIf
    End Select
    /' equivalent, w/o backslash
    If asc_1 = 32 Then
      If NumFollows( @str_2[pos_2] ) Then
      Else
        Return FT_1
      EndIf
    EndIf
    '/
  EndIf
  
#EndMacro

#Macro Letters_Chunk(FT_1,FT_2)

  Handle_Common_PosSt()
  
    '' posa closest to end
    Letters_Loop(FT_1,FT_2, delt_a, _
      asc_A,A,posa,lena, asc_B,B,posb,lenb)
      
    ''posa went past end pos, A is smaller
    if posa = lena then Return FT_1

  elseif delt_b < delt_a then
    
    '' posb closest to end
    Letters_Loop(FT_2,FT_1, delt_b, _
      asc_B,B,posb,lenb, asc_A,A,posa,lena)

    ''posb went past end pos, B is smaller
    if posb = lenb then Return FT_2

  else
    
    '' posa and posb equidistant to end pos
    Letters_Loop(FT_1,FT_2, delt_a, _
      asc_A,A,posa,lena, asc_B,B,posb,lenb)

  end If
  
#EndMacro



#Macro LHS_(FT_1,FT_2)

  SkipChar( A, posa, lena_m, 48 )
  SkipChar( B, posb, lenb_m, 48 )
  SeekNonNumeric(A,posa_st,posa,delt_a,lena_M)
  SeekNonNumeric(B,posb_st,posb,delt_b,lenb_M)
      
  if delt_a < delt_b then
    return FT_1
  elseif delt_b < delt_a then
    return FT_2
  End If

  delt_A -= 1
  DigitLoop(FT_1,FT_2, A,posa_st,posa,delt_A, B,posb_st,posb)
#EndMacro

#Macro RHS_Inscription(str_,pos_st,pos_,lenm_,lrh_)
  lrh_ = 1
  If str_[pos_] = 46 Then
    Pos_ += 1
    pos_st = pos_
    SkipChar( str_, pos_, lenm_, 48 )
    If asc_numeric( str_[pos_] ) Then
      lrh_ = 1
    Else
      lrh_ = 0
    EndIf
    pos_ = pos_st
  Else
    lrh_ = 0
  EndIf
#EndMacro
#Macro DigitLoop(FT_1,FT_2, str_1,pos_st1,pos_1,delt_1, str_2,pos_st2,pos_2)
  pos_2 = pos_st2
  for pos_1 = pos_st1 to pos_st1 + delt_1
    if str_1[pos_1] < str_2[pos_2] then
      return FT_1
    elseif str_2[pos_2] < str_1[pos_1] then
      return FT_2
    end if
    pos_2 += 1
  Next
#EndMacro

#Macro RHS_Digits(FT_1,FT_2, str_1,pos_st1,pos_1,lenm_1,delt_1, str_2,pos_st2,pos_2,lenm_2,delt_2)
  delt_1 -= 1
  delt_2 += pos_st2 - 1
  DigitLoop(FT_1,FT_2, str_1,pos_st1,pos_1,delt_1, str_2,pos_st2,pos_2)
  For pos_2 = pos_2 To delt_2
    If asc_1_To_9( str_2[pos_2] ) Then Return FT_1
  Next
  Space_VS(FT_1,FT_2, str_1,pos_1, str_2,pos_2, lenm_1,lenm_2)

#EndMacro
#Macro RHS_(FT_1,FT_2)

  RHS_Inscription(A,posa_st,posa,lena_M,lrh_A)
  RHS_Inscription(B,posb_st,posb,lenb_M,lrh_B)
  
  If lrh_A < lrh_B Then
    Return FT_1
  ElseIf lrh_B < lrh_A Then
    Return FT_2
  EndIf
  
  SeekNonNumeric(A,posa_st,posa,delt_a,lena_M)
  SeekNonNumeric(B,posb_st,posb,delt_b,lenb_M)
  
  If delt_A < delt_B Then
    RHS_Digits(FT_1,FT_2, A,posa_st,posa,lena_m,delt_A, B,posb_st,posb,lenb_M,delt_B)
  ElseIf delt_B < delt_A Then
    RHS_Digits(FT_2,FT_1, B,posb_st,posb,lenb_m,delt_B, A,posa_st,posa,lena_M,delt_A)
  Else
    delt_A -= 1
    DigitLoop(FT_1,FT_2, A,posa_st,posa,delt_A, B,posb_st,posb)
    Space_VS(FT_1,FT_2, A,posa, B,posb, lenA_m,lenb_m)
  EndIf
  
#EndMacro
#Macro CompareNums(FT_1,FT_2)

  LHS_(FT_1,FT_2)
  RHS_(FT_1,FT_2)
  
#EndMacro


#Macro ChunkType(str_,pos_st,pos_,lenm_,asc_,typ_)

  pos_st = pos_
  SkipChar(str_,pos_,lenm_,48)
  
  if pos_ > pos_st Then
    If asc_non_numeric( str_[Pos_] ) Then
      asc_ = pos_ - 1
      If str_[asc_] = 48 Then
        pos_ = asc_
      EndIf
    End If
  end if
  
  asc_ = str_[pos_]
  If pos_ > lenm_ Then
    typ_ = -1
  elseIf UCase_is_a_letter(asc_) Then
    typ_ = CHUNKTYPE_LETTER
  elseif asc_numeric(asc_) Then
  
    typ_ = CHUNKTYPE_NUMBER
    
    If str_[pos_] = 48 Then
      If pos_ < lenm_ Then
        asc_ = pos_ + 1
        If str_[asc_] = 46 Then
          pos_ = asc_
        EndIf
      EndIf
    End If
    
  Else
  
    typ_ = CHUNKTYPE_OTHER
    
    if asc_ = 46 then '' decimal point
      If pos_ < lenm_ Then
        if NumFollows(@str_[pos_]) Then typ_ = CHUNKTYPE_NUMBER
      ElseIf Pos_ > 0 Then
        If asc_numeric(str_[pos_-1]) Then typ_ = CHUNKTYPE_NUMBER
      End If
    end if
  end if
#EndMacro

#Macro CompareChunks(FT_1,FT_2)

  if typ_A < typ_B then
    Return FT_1
  elseif typ_B < typ_A then
    Return FT_2
  Else
    If typ_A = CHUNKTYPE_NUMBER Then
      CompareNums(FT_1,FT_2)
    ElseIf typ_A = CHUNKTYPE_LETTER then
      Letters_Chunk(FT_1,FT_2)
    else
      Other_Chunk(FT_1,FT_2)
    end if
  end If

  BreakCommon(FT_1,FT_2)  
#EndMacro

#Macro LessMore(FALS_TRU_1,FALS_TRU_2)

  DimVars(FALS_TRU_1,FALS_TRU_2)
  
  SkipChar(A,posa,lena_M,32)
  SkipChar(B,posb,lenb_M,32)
  EarlyBreak(FALS_TRU_1,FALS_TRU_2)
  ChunkType(A,posa_st,posa,lena_M,asc_A,typ_A)
  ChunkType(B,posb_st,posb,lenb_M,asc_B,typ_B)
  CompareChunks(FALS_TRU_1,FALS_TRU_2)
  
  Do
    Skip_Space_BackSlash(A,posa,lena_M)
    Skip_Space_BackSlash(B,posb,lenb_M)
    ChunkType(A,posa_st,posa,lena_M,asc_A,typ_A)
    ChunkType(B,posb_st,posb,lenb_M,asc_B,typ_B)
    CompareChunks(FALS_TRU_1,FALS_TRU_2)
  Loop
  
  Return FALSE
#EndMacro

Function Less(ByRef A As String, ByRef B As String) As Integer
  LessMore(TRUE,FALSE)
End Function
Function More(ByRef A As String, ByRef B As String) As Integer
  LessMore(FALSE,TRUE)
End Function

'                      '
'     Less / More      '
' -------------------- '


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

'     S O R T S

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

#Macro zInsertionSortString(A,lSt,lEnd,dot)
  I = lSt
  For J = I + 1 To lEnd
    if more( a(i)dot, a(j)dot ) then
      SwapV = A(J)
      SwapVcomp = A(J)dot
      dim as integer K = I
      A(J) = A(K)
      For I = I - 1 To lSt Step -1
        'If A(I)dot <= SwapVcomp Then Exit For
        if not more( a(i)dot, SwapVcomp ) then exit for
        A(K) = A(I)
        K = I
      Next
      A(K) = SwapV
    End If
    I = J
  Next
#EndMacro

#Macro zQuickCommonString(A,pSt,pEnd,dot)
        Exit Do
      Else
        I = pSt
        J = pEnd
        SwapVcomp = A((I + J) \ 2)dot
        Do
          While Less(A(I)dot, SwapVcomp)
            I = I + 1
          Wend
          While Less(SwapVcomp, A(J)dot)
            J = J - 1
          Wend
          If I > J Then Exit Do
          If More(A(I)dot, A(J)dot) Then Swap A(I), A(J)
          I = I + 1
          J = J - 1
        Loop While I <= J
        If I < pEnd Then
          lStack(StackPtr) = I
          lStack(StackPtr + 1) = pEnd
          StackPtr = StackPtr + 2
        End If
        pEnd = J
      End If
    Loop While pSt < pEnd
    If StackPtr = 0 Then Exit Do
    StackPtr = StackPtr - 2
    pSt = lStack(StackPtr)
    pEnd = lStack(StackPtr + 1)
  Loop
#EndMacro


' ======== numeric --------

#Macro zInsertionSort(A,lSt,lEnd,dot)
  I = lSt
  For J = I + 1 To lEnd
    If A(I)dot > A(J)dot Then
      SwapV = A(J)
      SwapVcomp = A(J)dot
      dim as integer K = I
      A(J) = A(K)
      For I = I - 1 To lSt Step -1
        If A(I)dot <= SwapVcomp Then Exit For
        A(K) = A(I)
        K = I
      Next
      A(K) = SwapV
    End If
    I = J
  Next
#EndMacro
#Macro zQuickCommon(A,pSt,pEnd,dot)
        Exit Do
      Else
        I = pSt
        J = pEnd
        SwapVcomp = A((I + J) \ 2)dot
        Do
          While A(I)dot < SwapVcomp
            I = I + 1
          Wend
          While SwapVcomp < A(J)dot
            J = J - 1
          Wend
          If I > J Then Exit Do
          If A(I)dot > A(J)dot Then Swap A(I), A(J)
          I = I + 1
          J = J - 1
        Loop While I <= J
        If I < pEnd Then
          lStack(StackPtr) = I
          lStack(StackPtr + 1) = pEnd
          StackPtr = StackPtr + 2
        End If
        pEnd = J
      End If
    Loop While pSt < pEnd
    If StackPtr = 0 Then Exit Do
    StackPtr = StackPtr - 2
    pSt = lStack(StackPtr)
    pEnd = lStack(StackPtr + 1)
  Loop
#EndMacro

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

#Macro QS_StrNum_Common(a)
  Dim As Integer UB = ubound(a)
  If UB > 0 Then
    Dim As Integer I,J,lSt,StackPtr,lStack(UB \ 2 + 10)
    Const       QS_INSERTSORT_THRESHOLD = 13
    'Standard QuickSort Routine
    'http://www.freebasic-portal.de/porticula/sort-testbas-schnellste-routinen-513.html
    Do
      Do
        If UB - lSt < QS_INSERTSORT_THRESHOLD Then ''Tests show 13 optimal for many cases
#EndMacro

#Macro sort(a,dot)
  Scope
    dim as TypeOf(a)        SwapV
    dim as TypeOf(a(0)dot)  SwapVcomp
    #if typeof(SwapVcomp) = typeof(string)
      QS_StrNum_Common(a)
        zInsertionSortString(A, lSt, UB,dot)
        zQuickCommonString(A,lSt,UB,dot)
      end if
    #else
      QS_StrNum_Common(A)
        zInsertionSort(A, lSt, UB, dot)
        zQuickCommon(A,lSt,UB,dot)
      end if
    #EndIf
  End Scope
#EndMacro

'=== End of  SORT ===

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

type anytype
    as integer  field1
    as double   field2
    as string   field3
end type

' ======= Print Result =======

function MinBound(a as double, b as double) as integer
  if a < b then return a
  return b
end function
function MaxBound(a as double, b as double) as integer
  if a > b then return a
  return b
end function

sub printbits(k() as anytype)
    for n as integer=0 to MinBound( 4, ubound(k) )
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print " ..."
    for n as integer= MaxBound(0, ubound(k)-4) to ubound(k)
        print k(n).field1,k(n).field2,k(n).field3
    next n
    print
    print "_____________________________"
    print
    print
end sub


Sub Main

  dim as integer  array_size = 20

  dim as integer  ub = array_size - 1
  dim as anytype  x(0 to ub)

  #define Intrange(f,l) Int(Rnd*((l+1)-(f))+(f))

  for n as integer=0 to ub
      with x(n)
          .field1=rnd*1000
          .field2=rnd*1000-rnd*1000
          .field3=chr(IntRange(65,90))+chr(IntRange(65,90))
      end with
  next n

  print
  print "  field1","  field2","            field3"
  print

  sort(x,.field1)
  printbits x()

  sort(x,.field2)
  printbits x()

  sort(x,.field3)
  printbits x()

  sleep

End Sub

Main

[dodicat]

The insertionsort is desperately slow for large arrays.

Insertion sort is fast for almost sorted arrays. But thinking more about it, I’m not sure how “almost sorted” the array would be after the first sort.

Well, say the first 14 out of 100000 are unsorted then it's not too bad.
But to sort 100000 raw by insertionsort takes about a minute.
SORTS are for integers here, I've skipped out of UDT's.

Code: Select all

 
#macro insertionsort(array)
scope
    dim as integer j
   FOR row as integer= 1 TO ubound(array)
     var temp = array(row)
   j = row
    while j>=1 andalso array(j-1)>temp
        array(j) = array(j - 1)
        j=j-1
    wend
    array(j)=temp
   next row
   end scope
   #endmacro
   
   #macro combsort(array,begin,finish)
Scope
    Var size=(finish),switch=0,j=0
    Dim As Single void=size
    Do
        void=void/1.3: If void<1 Then void=1
        switch=0
        For i As Integer =(begin) To size-void
            j=i+void
            If array(i)>array(j) Then 
                Swap array(i),array(j): switch=1
            End If
        Next
    Loop Until  switch =0 And void=1
End Scope
#endmacro

#macro reverse(s)
For n As Integer=Lbound(s) To Int((Lbound(s)+Ubound(s))/2):Swap s(n),s(Ubound(s)+Lbound(s)-n):Next
    #endmacro
    
dim as double t1,t2
dim as integer number=100000
dim as integer a( number)
for n as integer=0 to number
    a(n)=int(rnd*1000-rnd*1000)
next n
t1=timer
combsort(a,15,ubound(a))
t2=timer
for n as integer=0 to 30
    print n,a(n)
    if n=14 then print "sorted from here by combsort "
next n
print "Bla"
print "Bla"
print "Bla to ";number;"  elements"
print "Time taken ";t2-t1
print
print "Now insertion sort on nearly sorted array" '(quite fast)
t1=timer
insertionsort(a)
t2=timer
for n as integer=0 to 60
    print n,a(n)
next n
Print "Bla"
print "Bla"
print "time taken ";t2-t1
'???????????????????????????????????????????????????????????????????
'If you comment out goto, you'll have to wait over one minute for insertionsort!!
goto finish
reverse(a)
print "please wait, the array has been reversed"
print "Now insertionsort on ";number; "  integers"
print
t1=timer
insertionsort(a)

'combsort(a,0,ubound(a))
t2=timer
for n as integer=0 to 60
    print n,a(n)
next n
print "done Time was ";t2-t1
finish:
sleep



 

[Roe5685]

what do you do with the pp file? it is very large!
I had trouble making a second macro although I made it EXACTLY like the first. I had to revert and do "normal".
I also lost on the second macro the neat handling of the "type". what only one macro at a time?

It would seem that if you want to sort the date and the time on files spanning 20 years then:
quick sort is fine you add up the date and time components and do some multiplication and sort the large number.
250,000 files to 1,000,000 you are talking a few seconds at the most. and that includes a sort on the first letter of the name.
you use the asc code and add it in.
it you do a second pass to then sort alpha (keeping the date sort of course ) the very long names and many names are similar using bubble or insertion as is commonly done in business - I used the ms code - you are talking about 90 seconds but it is rock solid and you can let it do its thing when convenient. it just plods along continually improving the second sort.
I used your sort but as explained without a macro and without the type aspect working to sort alpha on the 250k of files as the first sort. speedy and snappy. I will try the other sort like yours tomorrow. thanks everyone.
Roe5685.

( alpha as the first sort ). It was very speedy.
My quick sort on the file size was not that quick as I had to take out the commas.

[dodicat]

The pp file is of no importance.
It is convenient for de-bugging sometimes, and it shows you things like #macro, #define and #include in your code.
You can (sometimes) use a macro instead of a sub but with care.
If you dim a variable inside a macro then you should put the macro code within a scope and end scope.
If you are not used to using macros then you should have a play around with some of your own to get the feel of them.
Perhaps try and convert some of your previous (SUBS) to macros to find out the pitfalls.

You can send instructions as macro parameters which sometimes makes them useful.
e.g.

Code: Select all

#macro dothis(range,instruction,datatype)
for n as datatype=range
instruction
next n
#endmacro

screen 19

dothis(1 to 5,print "Hello",integer)
dothis(1 to 2,print "Goodbye",single)
sleep
  

[Zippy]

I'm late but want to add array sorts using fb-BASIC - no CRT or ASM.

These are conversions of Ethan Winer's 22yo QB code. I've split integer and string sorting (Winer only did the integer sort code, IIRC). They could be combined for a generic sort but the code would be messy. The integer sort is very fast, on the order of 4 million sorts per second. The string sort is MUCH slower, some 300 thousand sorts per second. Note that I'm sorting 5 million elements...

Integer array sort:

Code: Select all

'sort integer array
' fb-updated conversion of Ethan Winer's Quick Sort, ca 1992
'
' sortdir=1 for ascending sort, any other val for descending
declare sub Qsort (myarray() as integer,startEl as integer,numEls as integer,sortdir as integer =1)
'
dim as integer i=5000000
dim as integer myarray(i-1)
dim as integer c
dim as double bt,et
'
randomize timer
print "Building array.. ";
for c = 0 to i-1 
    myarray(c)=(int(rnd * i))
next
'
print "done"
print
print "Integer sort, descending, started"
'
bt=timer
Qsort(myarray(),0,i,0) 
et=timer
print using "Elapsed         : ###.######## seconds";et-bt
print "Elements sorted :";ubound(myarray)-lbound(myarray)+1
print "Sorts per second:";int((1/(et-bt))*(ubound(myarray)-lbound(myarray)+1))
print
for c= 0 to 8
    print "Index: ";c;tab(20);"IntValue: ";myarray(c)
next
'
for c=i-1 to i-8 step -1
    print "Index: ";c;tab(20);"IntValue: ";myarray(c)
next
'
print
print "Done, Sleeping to Exit.."
sleep
'end
'
sub Qsort(myarray() as integer,startEl as integer,numEls as integer,sortdir as integer =1)
'
    dim as integer qstack(NumEls\5+10)
    dim as integer i,j,first,last,stackptr
    dim as integer temp
    '
    first = startEl
    last  = StartEl + NumEls - 1
    '
    do
        do
            temp=myarray((last + first)\2)
            i=first:j=last
            do
                if sortdir=1 then 'ascending
                    while myarray(i)<temp:i+=1:wend
                    while myarray(j)>temp:j-=1:wend
                else              'decending
                    while myarray(i)>temp:i+=1:wend
                    while myarray(j)<temp:j-=1:wend                
                end if    
                if i>j then exit do
                if i<j then swap myarray(i),myarray(j)
                i+=1:j-=1
            loop until i > j
            if i < last then
                qstack(stackptr)=i
                qstack(stackptr+1)=last
                stackptr+=2
            end if
            last=j
        loop until first>=last
        if stackptr=0 then
            exit do
        end if
        stackptr-=2
        first=qstack(stackptr)
        last=qstack(stackptr+1)
    loop
'
end sub

String array sort (MUCH slower - you've been warned...):

Code: Select all

'sort string array
' fb-updated conversion of Ethan Winer's Quick Sort, ca 1992
'
declare sub Qsort overload (myStrArray() as string,startEl as integer,numEls as integer,sortdir as integer =1)
'
dim as integer i=5000000
dim as string myStrArray(i-1)
dim as integer c
dim as double bt,et
'
'randomize timer
print "Building array.. ";
for c = 0 to i-1 
    myStrArray(c)=str((int(rnd * i)))
next
'
print "done"

print
print "String sort, descending, started (this is MUCH slower than integer sort)"
bt=timer
Qsort(myStrArray(),0,i,0)
et=timer
print using "Elapsed         : ###.######## seconds";et-bt
print "Elements sorted :";ubound(myStrArray)-lbound(myStrArray)+1
print "Sorts per second:";int((1/(et-bt))*(ubound(myStrArray)-lbound(myStrArray)+1))
print
'
for c= 0 to 8
    print "Index: ";c;tab(20);"StrValue: ";myStrArray(c)
next
'
for c=i-1 to i-8 step -1
    print "Index: ";c;tab(20);"StrValue: ";myStrArray(c)
next
'
print
print "Done, Sleeping to Exit.."
sleep
'end
'
sub Qsort(myStrArray() as string,startEl as integer,numEls as integer,sortdir as integer =1)
'
    dim as integer qstack(NumEls\5+10)
    dim as integer i,j,first,last,stackptr
    dim as string temp
    '
    first = startEl
    last  = StartEl + NumEls - 1
    '
    do
        do
            temp=myStrArray((last + first)\2)
            i=first:j=last
            do
                if sortdir=1 then 'ascending
                    while myStrArray(i)<temp:i+=1:wend
                    while myStrArray(j)>temp:j-=1:wend
                else              'decending
                    while myStrArray(i)>temp:i+=1:wend
                    while myStrArray(j)<temp:j-=1:wend                
                end if    
                if i>j then exit do
                if i<j then swap myStrArray(i),myStrArray(j)
                i+=1:j-=1
            loop until i > j
            if i < last then
                qstack(stackptr)=i
                qstack(stackptr+1)=last
                stackptr+=2
            end if
            last=j
        loop until first>=last
        if stackptr=0 then
            exit do
        end if
        stackptr-=2
        first=qstack(stackptr)
        last=qstack(stackptr+1)
    loop
'
end sub

Z.

[dodicat]

Thanks Zippy.

STRINGS

Here is the qsort sort using the crt method.
I also tested a bog standard quicksort (with recursion), it's about the same speed as yours, and didn't stack out even with 5 million pieces.
I tested my macro combsort, -- about half the speed of yours.

With the crt sort, it is of course easy to be generic, you would only need to write another compare function using the data type after *cptr( ---), four lines of code.
I suppose this is the reason for having a compare function anyway.

With the combsort macro, it is generic as it stands.

I reckon that there are as many sorts around as there are things to be sorted.

CRT qsort:

Code: Select all

#include "crt.bi"
Function compareS Cdecl(n1 As Any Ptr,n2 As Any Ptr) As Integer
    If *Cptr(string Ptr,n1) > *Cptr(string Ptr,n2) Then Return -1
    If *Cptr(string Ptr,n1) < *Cptr(string Ptr,n2) Then Return 1
End Function

dim as integer i=5000000
dim as string myStrArray(i-1)
dim as integer c
dim as double bt,et
'randomize timer
print "Building array.. ";
for c = 0 to i-1 
    myStrArray(c)=str((int(rnd * i)))
next
'
print "done"

print
print "String sort, descending, started (this is MUCH slower than integer sort)"
bt=timer
qsort(@myStrArray(Lbound(myStrArray)),(Ubound(myStrArray)-Lbound(myStrArray)+1),Sizeof(myStrArray),@compareS)
et=timer
print using "Elapsed         : ###.######## seconds";et-bt
print "Elements sorted :";ubound(myStrArray)-lbound(myStrArray)+1
print "Sorts per second:";int((1/(et-bt))*(ubound(myStrArray)-lbound(myStrArray)+1))
print
'
for c= 0 to 8
    print "Index: ";c;tab(20);"StrValue: ";myStrArray(c)
next
'
for c=i-1 to i-8 step -1
    print "Index: ";c;tab(20);"StrValue: ";myStrArray(c)
next
'
print
print "Done, Sleeping to Exit.."
sleep
 

[Zippy]

@dodicat

Changing your compareS() function slightly cuts the sort time in half:

Code: Select all

Function compareS Cdecl(n1 As Any Ptr,n2 As Any Ptr) As Integer
'    If *Cptr(string Ptr,n1) > *Cptr(string Ptr,n2) Then Return -1
'    If *Cptr(string Ptr,n1) < *Cptr(string Ptr,n2) Then Return 1
return strcmp(*Cptr(string Ptr,n2),*Cptr(string Ptr,n1))
End Function

strcmp() is fast...

Z.