FreeBasic

Пример сортировки массивов со строковыми данными.
Платформы: Windows , Linux.
Автор: dodicat, создано в 2009 году

Sub arrayinsertstring( a() As String,index As Integer,insert As String )
If index>=lbound(a) And index<=ubound(a)+1 Then
    index=index-lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    Dim x As Integer
    For x= Ubound(a) To Lbound(a)+index+1 Step -1
      Swap a(x),a(x-1)
    Next x
   a(Lbound(a)+index)=insert
   End If
End Sub

Sub arrayinsertinteger( a() As Long,index As Integer,insert As Long )
If index>=lbound(a) And index<=ubound(a)+1 Then
    index=index-lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    Dim x As Integer
    For x= Ubound(a) To Lbound(a)+index+1 Step -1
      Swap a(x),a(x-1)
    Next x
   a(Lbound(a)+index)=insert
   End If
End Sub

Sub arrayinsertsingle( a() As Single,index As Integer,insert As Single )
If index>=lbound(a) And index<=ubound(a)+1 Then
    index=index-lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    Dim x As Integer
    For x= Ubound(a) To Lbound(a)+index+1 Step -1
      Swap a(x),a(x-1)
    Next x
   a(Lbound(a)+index)=insert
   End If
End Sub

Sub arrayinsertdouble( a() As Double,index As Integer,insert As Double )
If index>=lbound(a) And index<=ubound(a)+1 Then
    index=index-lbound(a)
    Redim Preserve a(Lbound(a) To  Ubound(a)+1)
    Dim x As Integer
    For x= Ubound(a) To Lbound(a)+index+1 Step -1
      Swap a(x),a(x-1)
    Next x
   a(Lbound(a)+index)=insert
   End If
End Sub

Sub arraydeletestring(a() As String,index As Integer)
    If index>=lbound(a) And index<=ubound(a) Then
    Dim x As Integer
    For x=index To Ubound(a)-1
         a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
    Endif
End Sub

Sub arraydeleteinteger(a() As Long,index As Integer)
    If index>=lbound(a) And index<=ubound(a) Then
    Dim x As Integer
    For x=index To Ubound(a)-1
         a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
    Endif
End Sub

Sub arraydeletesingle(a() As Single,index As Integer)
    If index>=lbound(a) And index<=ubound(a) Then
    Dim x As Integer
    For x=index To Ubound(a)-1
         a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
    Endif
End Sub

Sub arraydeletedouble(a() As Double,index As Integer)
    If index>=lbound(a) And index<=ubound(a) Then
    Dim x As Integer
    For x=index To Ubound(a)-1
         a(x)=a(x+1)
    Next x
    Redim Preserve a(Lbound(a) To Ubound(a)-1)
    Endif
End Sub

'SINGLE DIMENSION ARRAY QUICKSORTS
Sub MF(g As Long,d As Long,a()As Single)
Dim As Single v,t:Dim As Byte o:Dim As Long i,j
  If g<d Then:v=a(d):i=g-1:j=d:Do:Do:i=i+1:Loop Until a(i)>=v:o=0
     Do:If j>Lbound(a) Then:j=j-1:Else:o=1:Endif:If a(j)<=v Then o=1
     Loop Until o<>0:Swap a(i),a(j):Loop Until j<=i
    t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t:MF(g,i-1,a()):MF(i+1,d,a()):Endif:End Sub
Sub MD(g As Long,d As Long,a()As Double)
Dim As Double v,t:Dim As Byte o:Dim As Long i,j
  If g<d Then:v=a(d):i=g-1:j=d:Do:Do:i=i+1:Loop Until a(i)>=v:o=0
     Do:If j>Lbound(a) Then:j=j-1:Else:o=1:Endif:If a(j)<=v Then o=1
     Loop Until o<>0:Swap a(i),a(j):Loop Until j<=i
    t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t:MD(g,i-1,a()):MD(i+1,d,a()):Endif:End Sub
Sub MS(g As Long,d As Long,a()As String)
Dim As String v,t:Dim As Byte o:Dim As Long i,j
   If g<d Then:v=a(d):i=g-1:j=d:Do:Do:i=i+1:Loop Until a(i)>=v:o=0
     Do:If j>Lbound(a) Then:j=j-1:Else:o=1:Endif: If a(j)<=v Then o=1
     Loop Until o<>0:Swap a(i),a(j):Loop Until j<=i
    t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t:MS(g,i-1,a()):MS(i+1,d,a()):Endif:End Sub
Sub MI(g As Long,d As Long,a()As Long)
Dim As Long v,t:Dim As Byte o:Dim As Long i,j
  If g<d Then:v=a(d):i=g-1:j=d:Do:Do:i=i+1:Loop Until a(i)>=v:o=0
     Do:If j>Lbound(a) Then:j=j-1:Else:o=1:Endif:If a(j)<=v Then o=1
     Loop Until o<>0:Swap a(i),a(j):Loop Until j <= i
    t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t:MI(g,i-1,a()):MI(i+1,d,a()):Endif:End Sub
Sub sortsingle(arr() As Single,D As String)
    D=Lcase$(D):MF(Lbound(arr),Ubound(arr),arr()):Select Case D
    Case "up":Case "down":Dim As Long lb,ub:lb=Lbound(arr):ub=Ubound(arr)
    For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next:End Select:End Sub
Sub sortdouble(arr() As Double,D As String)
    D=Lcase$(D):MD(Lbound(arr),Ubound(arr),arr()):Select Case D
    Case "up":Case "down":Dim As Long lb,ub:lb=Lbound(arr):ub=Ubound(arr)
    For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next:End Select:End Sub
Sub sortstring(arr() As String,D As String)
    D=Lcase$(D):MS(Lbound(arr),Ubound(arr),arr()):Select Case D
    Case "up":Case "down":Dim As Long lb,ub:lb=Lbound(arr):ub=Ubound(arr)
    For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next:End Select:End Sub
Sub sortinteger(arr() As Long,D As String)
    D=Lcase$(D):MI(Lbound(arr),Ubound(arr),arr()):Select Case D
    Case "up":Case "down":Dim As Long lb,ub:lb=Lbound(arr):ub=Ubound(arr)
    For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next:End Select:End Sub
  'END QUICKSORTS 
  
Screen 9
'XXXXXX     USAGE EXAMPLES (strings)     XXXXXX
Redim b(2 To 8) As String

Dim n As Integer
'make the array 
b(2)="Smith"
b(3)="Harry Worth"
b(4)="MacPhail"
b(5)="MacPherson"
b(6)="Mr.Bean"
b(7)="Miss Marple"
b(8)="Mr.Pastry"
'set up the screen
Locate 1
Print"original -->"
Locate 1,18
Print"Nelson added -->"
Locate 1,40
Print"Bean removed -->"
Locate 1,60
Print"b(7) taken out."
Print
'original array printed
For n=lbound(b) To Ubound(b):Print"b(";n;") = ";b(n):Next n
    
    'Add a name
arrayinsertstring (b(),3,"Lord Nelson")
    'print
For n=lbound(b) To Ubound(b)
    Locate n+1,20
    Print"b(";n;") = ";b(n)
Next n
'delete b(7)
arraydeletestring(b(),7)
  'print
For n=lbound(b) To Ubound(b)
    Locate n+1,40
    Print"b(";n;") = ";b(n)
Next n
'delete b(7)
arraydeletestring(b(),7)
   'print
For n=lbound(b) To Ubound(b)
    Locate n+1,60
     Print"b(";n;") = ";b(n)
Next n
  'Add a few names
arrayinsertstring b(),3,"Freda Jago"
arrayinsertstring b(),3,"Paddy"
arrayinsertstring b(),3,"Jim Davis"
  'set up the lower screen
Locate 12
For n=1 To 79:Print "_";:Next
    Print
    Print "Add a few names -->"
    Print
    For n=lbound(b) To Ubound(b)
    'locate n+1,60
     Print"b(";n;") = ";b(n)
Next n
'Using the sort
Locate 13,30
Print "Sort them up -->"
sortstring(b(),"up")
For n=lbound(b) To Ubound(b)
    Locate n+13,30
     Print"b(";n;") = ";b(n)
Next n
Locate 13,50
Print "Sort them down"
sortstring(b(),"down")
For n=lbound(b) To Ubound(b)
    Locate n+13,50
     Print"b(";n;") = ";b(n)
Next n
Sleep
Cls
Print "USER DEFINED TYPE SORT (string * 3)" 'OPTIONAL
'USER DEFINED TYPE SORT EXAMPLE ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ
'in sub OTHER, below 
'dim the array as CHAR, dim v and t as char in line 1
'change a(d) to a(d).c, a(i) to a(i).c in line 2
'change a(j) to a(j).c in line 3
'in sub sortother, dim the array as char 
Type CHAR
    c As string*3
    End Type
Sub OTHER(g As Long,d As Long,a()As CHAR):Dim As Byte o:Dim As Long i,j:Dim As CHAR v,t
  If g<d Then:Var v=A(D).C:i=g-1:j=d:Do:Do:i=i+1:Loop Until A(I).C>=v:o=0
     Do:If j>Lbound(a) Then:j=j-1:Else:o=1:Endif:If A(J).C<=v Then o=1
     Loop Until o<>0:Swap a(i),a(j):Loop Until j <= i
     Var t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t:OTHER(g,i-1,a()):OTHER(i+1,d,a()):Endif:End Sub
Sub sortOTHER(arr() As CHAR,D As String)
    D=Lcase$(D):OTHER(Lbound(arr),Ubound(arr),arr()):Select Case D
    Case "up":Case "down":Dim As Long lb,ub:lb=Lbound(arr):ub=Ubound(arr)
    For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next:End Select:End Sub
'END USER DEFINED TYPE ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ
'EXAMPLE USER DEFINED TYPE
Dim a(3 To 20) As char
'set up the array of char
For n=lbound(a) To Ubound(a)
            Randomize timer*20000
            a(n).c=left$(str$(rnd*10),3)
        Next
        sortOTHER(a(),"down") 
        For n=lbound(a) To Ubound(a): Print a(n).c:Next
Sleep