(Solved) How to sort datasheet (x-dim array) by a few columns (at once in 1 loop) ?

[badidea]

Better version:

Code: Select all

#include "crt/stdlib.bi"
#include "string.bi"

'------------------------------- class: row_type -------------------------------

type row_type
	dim as ushort col(any)
	dim as string bla1, bla2 'some extra (passive) columns
	declare operator cast () as string
end type

operator row_type.cast () as string
	dim as string tempStr
	for i as integer = 0 to ubound(col)
		if i = 0 then tempStr &= col(i) else tempStr &= !"\t" & col(i) 
	next
	return tempStr & !"\t" & bla1  & !"\t" & bla2 
end operator

'------------------------------ class: sort_type -------------------------------

type sort_type
	dim as short column
	dim as short direction
	declare constructor()
	declare constructor(column as short, direction as short)
end type

'a stupid constructor
constructor sort_type()
	this.column = 0
	this.direction = 0
end constructor

'another stupid constructor
constructor sort_type(column as short, direction as short)
	this.column = column
	this.direction = direction
end constructor

'------------------------------ class: data_type -------------------------------

type data_type
	static as sort_type sortOrder(0 to 2)
	dim as integer numRows, numCols
	dim as row_type row(any)
	declare constructor(numRows as integer, numPivotMS as integer)
	declare destructor()
	declare sub initRandom()
	declare sub printSome()
	declare sub copyTo(dst as data_type)
	declare sub sort(sort1st as sort_type, sort2nd as sort_type, sort3rd as sort_type)
	declare static function qSortCallback cdecl(pRow1 as row_type ptr, pRow2 as row_type ptr) as long
end type
dim as sort_type data_type.sortOrder(0 to 2)

constructor data_type(numRows as integer, numCols as integer)
	redim row(numRows - 1)
	this.numCols = numCols
	for iRow as integer = 0 to numRows - 1
		redim (row(iRow).col)(numCols - 1) 'weird syntax, compiler wants the extra ( )
	next
end constructor

destructor data_type()
	for iRow as integer = 0 to numRows - 1
		erase row(iRow).col
	next
	erase row
end destructor

sub data_type.initRandom()
	for iRow as integer = 0 to ubound(row)
		with row(iRow)
			for iCol as integer = 0 to ubound(.col)
				.col(iCol) = int(rnd * 1000) 
			next
			.bla1 = string(int(rnd * 7) + 1, int(rnd * 26) + asc("a"))
			.bla2 = string(int(rnd * 7) + 1, int(rnd * 26) + asc("A"))
		end with
	next
end sub

sub data_type.printSome()
	print "--- First 5 items ---"
	for i as integer = 0 to 4
		print row(i)
	next
	print "--- Last 5 items ---"
	for i as integer = ubound(row) - 4 to ubound(row)
		print row(i)
	next
end sub

sub data_type.copyTo(dst as data_type)
	if ubound(row) <> ubound(dst.row) then print "Error": exit sub
	for i as integer = 0 to ubound(row)
		dst.row(i) = row(i)
	next
end sub

sub data_type.sort(sort1st as sort_type, sort2nd as sort_type, sort3rd as sort_type)
	'disable invalid sort filters
	sortOrder(0) = iif(sort1st.column < 0 or sort1st.column >= numCols, sort_type(0,0), sort1st)
	sortOrder(1) = iif(sort2nd.column < 0 or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
	sortOrder(2) = iif(sort3rd.column < 0 or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
	qsort(@row(0), ubound(row) + 1, sizeof(row_type), cptr(any ptr, @qSortCallback))
end sub

function data_type.qSortCallback cdecl(pRow1 as row_type ptr, pRow2 as row_type ptr) as long
	for i as integer = 0 to 2
		with sortOrder(i)
			select case .direction
			case +1
				if pRow1->col(.column) < pRow2->col(.column) then return -1
				if pRow1->col(.column) > pRow2->col(.column) then return +1
			case -1
				if pRow1->col(.column) > pRow2->col(.column) then return -1
				if pRow1->col(.column) < pRow2->col(.column) then return +1
			case else
				'skip, including direction = 0
			end select
		end with
	next
	return 0
end function

'-------------------------------- main program ---------------------------------

dim as integer numRows = 2000, numCols = 5

randomize timer
print "Allocate memory"
var myData = data_type(numRows, numCols), backupData = data_type(numRows, numCols)
print "Initialize with random data"
myData.initRandom()
print "Make backup"
myData.copyTo(backupData)

print "Unsorted data:"
myData.printSome()

print !"\nSort: col 0 up, col 2 down:"
myData.sort(sort_type(0, +1), sort_type(2, -1), sort_type(0, 0))
myData.printSome()

backupData.copyTo(myData)

print !"\nSort: col 1 up (only)"
myData.sort(sort_type(0, +1), sort_type(0, 0), sort_type(0, 0))
myData.printSome()

print !"\nPress any key to end"
sleep
print "End"

[ppf]

@ badidea
After studying all the thread code + FB manual I changed callback routine to this:
(even not sured how it exactly works)

Code: Select all

function qSortCallbackMS cdecl(pRow1 as row_typeMS ptr, pRow2 as row_typeMS ptr) as long
   for i as integer = 0 to 3
      select case sortOrder(i)
      case SORT_NONE
         'skip
      case SORT_YEAR_UP
         'if pRow1->year_ < pRow2->year_ then return -1
         'if pRow1->year_ > pRow2->year_ then return +1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return +1      

      case SORT_YEAR_DOWN
         'if pRow1->year_ > pRow2->year_ then return -1
         'if pRow1->year_ < pRow2->year_ then return +1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return +1               
         
      case SORT_DAY_UP
         'if pRow1->day_ < pRow2->day_ then return -1
         'if pRow1->day_ > pRow2->day_ then return +1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return +1               
      case SORT_DAY_DOWN
         'if pRow1->day_ > pRow2->day_ then return -1
         'if pRow1->day_ < pRow2->day_ then return +1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return +1         
      case SORT_HOUR_UP
         'if pRow1->hour_ < pRow2->hour_ then return -1
         'if pRow1->hour_ > pRow2->hour_ then return +1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return +1         
      case SORT_HOUR_DOWN
         'if pRow1->hour_ > pRow2->hour_ then return -1
         'if pRow1->hour_ < pRow2->hour_ then return +1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return +1
	  case SORT_PET_UP
         'if pRow1->pet_ < pRow2->pet_ then return -1
         'if pRow1->pet_ > pRow2->pet_ then return +1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return +1         
      case SORT_PET_DOWN
         'if pRow1->pet_ > pRow2->pet_ then return -1
         'if pRow1->pet_ < pRow2->pet_ then return +1         
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return +1         
      end select
   next
   return 0

end function

Because of having only one prototypes for multisort IMHO there is needed
something like this

Code: Select all

function qSortCallbackMS cdecl(pRow1 as row_typeMS ptr, pRow2 as row_typeMS ptr) as long
   for i as integer = lbound(sortOrder) to ubound(sortOrder)
      'select case sortOrder(i)
rem      case SORT_NONE
         'skip
         if sortOrder(i)=SORT_NONE then exit for
         
rem      'case SORT_YEAR_UP
rem		pivot UP
         'if pRow1->year_ < pRow2->year_ then return -1
         'if pRow1->year_ > pRow2->year_ then return +1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return +1         
   
rem		 'case SORT_YEAR_DOWN
rem		pivot DOWN
         'if pRow1->year_ > pRow2->year_ then return -1
         'if pRow1->year_ < pRow2->year_ then return +1   
         if pRow1->pivotMS(i) > pRow2->pivotMS(i) then return -1
         if pRow1->pivotMS(i) < pRow2->pivotMS(i) then return +1         
   next i         
   return 0      

end function

As you see, there is no more used name for column (year, day,hour), because this is simply shown by iterator 'i'.
Then 1D array can be used.
How much columns will be sorted and passed to 'qsort' routine will be different by USER selection - multisort
flagString is produced.It's length says, how much columns is selected and will be passed.THIS is the trick.

Which Column is used => it's derived from iterator 'i'
and remains three conditions only - column SORT_NONE,SORT_UP,SORT_DOWN.
My old app is slowly enhanced with new Multi-column-sort feature; added interface routines.
Enum/constants SORT_abcd is changed.SORT_NONE remains, the rest is dynamically created as variable.
Sum of elements=2*length_of_flagStringMultisort.Plus interface UDT table to find everything.

I'll paste my interface routines, but must be translated to some english words, you will see.
It's quite enough code to rework, be patient please.Just second shot, not ideal, but works.
Up/Down direction is not adjusted rightly yet, and I want to add small colorized arrow chars to column header
to display/see (check) sort direction.

edit: Checking your new version, thanks for it !

[badidea]

As you see, there is no more used name for column (year, day,hour), because this is simply shown by iterator 'i'.
Then 1D array can be used.

Yes, that is what I now also did.

[dodicat]

Instead of cramming the callback, create dedicated callbacks for each udt field, and use only two choices in the callback, up or down.
Example:

Code: Select all

'=========  set up c sort =========
#include "crt/stdlib.bi"
#define ArrayToSort(x,start,finish) @X((start)),((finish)-(start)+1),Sizeof(X)
#macro SetCSort(Datatype,FnName,dot)
Function FnName Cdecl(n1 As Any Ptr,n2 As Any Ptr) As Long
    If direction=down Then
        If *Cptr(Datatype Ptr,n1)dot > *Cptr(Datatype Ptr,n2)dot Then Return -1
        If *Cptr(DataType Ptr,n1)dot < *Cptr(DataType Ptr,n2)dot Then Return 1
    Else
        If *Cptr(Datatype Ptr,n1)dot < *Cptr(Datatype Ptr,n2)dot Then Return -1
        If *Cptr(DataType Ptr,n1)dot > *Cptr(DataType Ptr,n2)dot Then Return 1
    End If
    Return 0
End Function
#endmacro

Enum
    up
    down
End Enum
Dim Shared As Byte direction=up

Type udt
    As Ushort year
    As Ushort Day
    As Ushort Hour
    As String Name
    As Long a(Any)
    As String b
    'bla
End Type
'set up the field sorts.
'the a(any) is a simple long here
SetCsort(udt,yearcallback,.year)
SetCsort(udt,daycallback,.day)
SetCsort(udt,hourcallback,.hour)
SetCsort(udt,namecallback,.name)
SetCsort(Long,longcallback,)
SetCsort(udt,bcallback,.b)

Sub printout(x() As udt,msg As String="",numelements as long=20)
    Print Ucase(msg)
    Print "year(1)";Tab(10);"day(2)";Tab(20);"hour(3)";Tab(30);"name(4)";Tab(40);".b (no sort)";Tab(60);" The array"
    Print
    For n As Long=Lbound(x) To numelements
        Print x(n).year;Tab(10);x(n).day;Tab(20);x(n).hour;Tab(30);x(n).name;Tab(40);x(n).b;"     ";
        
        For m As Long=Lbound(x(n).a) To Ubound(x(n).a)
            Print x(n).a(m); 
        Next m
        Print
    Next n
    Print
    Print ". . ."
    Print
    For n As Long=Ubound(x)-numelements To Ubound(x)
        Print x(n).year;Tab(10);x(n).day;Tab(20);x(n).hour;Tab(30);x(n).name;Tab(40);x(n).b;"     ";
        
        For m As Long=Lbound(x(n).a) To Ubound(x(n).a)
            Print x(n).a(m); 
        Next m
        Print
    Next n
End Sub

'custom udt sort
#macro sort(array,min,max,dot)
Scope
    Dim f As Function Cdecl(As Any Ptr,As Any Ptr) As Long
    Dim As boolean flag
    Select Case Lcase(#dot)
    Case ".year":f=@yearcallback
    Case ".day": f=@daycallback
    Case ".hour":f=@hourcallback
    Case ".name":f=@namecallback
    Case ".b":   f=@bcallback
    Case Else:   f=@longcallback:flag=true
    End Select
    Static As udt tmp(Lbound(array) To Ubound(array))
    For n As Long=Lbound(tmp) To Ubound(tmp)
        tmp(n)=array(n)
    Next
    
    If flag Then 'sort the array field
        For n As Long=min To max
            qsort(arraytosort(tmp(n).a,Lbound(tmp(n).a),Ubound(tmp(n).a)),f)  
        Next n
    Else
        qsort(arraytosort(tmp,min,max),f) 
    End If
    
    For n As Long=Lbound(array) To Ubound(array) 'transfer the sorted field
        array(n)dot = tmp(n)dot
    Next
End Scope
#endmacro

Sub setup(x() As udt,l As Long,u As Long)
    #define range(f,l) Int(Rnd*(((l)+1)-(f))+(f))
    #define q range(97,122)
    For m As Long=Lbound(x) To Ubound(x)
        With x(m)
            .year =range(1948,2019)
            .day=range(1,7)
            .hour=range(0,24)
            .name=ucase(Chr(q,q,q,q,q,q))
            .b=Chr(q,q,q,q,q,q)
        End With
        Redim (x(m).a)(l To u)
        For n As Long=Lbound(x(m).a) To Ubound(x(m).a)
            x(m).a(n)=Rnd*100
        Next n
    Next m
End Sub

'======  demo ============
Dim Shared As udt x(100000)
width 120,150

setup(x(),1,15) ' random elements, the a(any) will be a(1 to 15)
printout(x(),"Original")
Print "press a key . . ."
Print
Print
Sleep

'sort cols 1 to 4 and the array field (missed out .b field for the demo)
var t1=timer
direction=up
sort(x,Lbound(x),Ubound(x),.year)
sort(x,Lbound(x),Ubound(x),.day)
sort(x,Lbound(x),Ubound(x),.hour)
sort(x,Lbound(x),Ubound(x),.name)
direction=down
sort(x,Lbound(x),Ubound(x),) 'the array
var t2=timer
printout(x(),"Sort cols 1 to 4 (up) + the array (down) for  "+Str(Ubound(x))+" elements")
print "Time taken ";t2-t1;"  seconds"
Sleep


 

[Makoto WATANABE]

Hi !

I am looking for a multi-dimensional array sort and found this thread.
I would like to make the following modifications to badidea's code.
viewtopic.php?f=3&t=27993&start=30#p266914

1. Targets a simple multi-dimensional string array.
2. Make the array 1 origin instead of 0 origin.

My modified code crashes on the sorting part.
Please teach me how to fix it.

Code: Select all

'How to sort datasheet (x-dim array) by a few columns (at once in 1 loop) ?
'by badidea ≫ Dec 15, 2019 21:54 
'https://www.freebasic.net/forum/viewtopic.php?f=3&t=27993&start=30#p266914


#Include "crt/stdlib.bi"
#Include "string.bi"

'------------------------------- class: row_type -------------------------------

Type row_type
   Dim As String col(Any)
   Declare Operator Cast () As String
End Type

Operator row_type.cast () As String
   Dim As String tempStr
   'For i As Integer = 0 To UBound(col)
   For i As Integer = 1 To UBound(col)
      'If i = 0 Then tempStr &= col(i) Else tempStr &= !"\t" & col(i) 
      If i = 1 Then tempStr &= col(i) Else tempStr &= !"\t" & col(i) 
   Next
   Return tempStr
End Operator

'------------------------------ class: sort_type -------------------------------

Type sort_type
   Dim As Short column
   Dim As Short direction
   Declare Constructor()
   Declare Constructor(column As Short, direction As Short)
End Type

'a stupid constructor
Constructor sort_type()
   this.column = 0
   this.direction = 0
End Constructor

'another stupid constructor
Constructor sort_type(column As Short, direction As Short)
   this.column = column
   this.direction = direction
End Constructor

'------------------------------ class: data_type -------------------------------

Type data_type
   'Static As sort_type sortOrder(0 To 2)
   Static As sort_type sortOrder(1 To 3)
   Dim As Integer numRows, numCols
   Dim As row_type row(Any)
   Declare Constructor(numRows As Integer, numPivotMS As Integer)
   Declare Destructor()
   Declare Sub initRandom()
   Declare Sub printSome()
   Declare Sub copyTo(dst As data_type)
   Declare Sub sort(sort1st As sort_type, sort2nd As sort_type, sort3rd As sort_type)
   Declare Static Function qSortCallback Cdecl(pRow1 As row_type Ptr, pRow2 As row_type Ptr) As Long
End Type

'Dim As sort_type data_type.sortOrder(0 To 2)
Dim As sort_type data_type.sortOrder(1 To 3)

Constructor data_type(numRows As Integer, numCols As Integer)
   'ReDim row(numRows - 1)
   ReDim row(numRows)
   this.numCols = numCols
   'For iRow As Integer = 0 To numRows - 1
   For iRow As Integer = 1 To numRows
      ReDim (row(iRow).col)(numCols) 'weird syntax, compiler wants the extra ( )
   Next
End Constructor

Destructor data_type()
   'For iRow As Integer = 0 To numRows - 1
   For iRow As Integer = 1 To numRows
      Erase row(iRow).col
   Next
   Erase row
End Destructor

Sub data_type.initRandom()
   'For iRow As Integer = 0 To UBound(row)
   For iRow As Integer = 1 To UBound(row)
      With row(iRow)
         'For iCol As Integer = 0 To UBound(.col)
         For iCol As Integer = 1 To UBound(.col)
            .col(iCol) = Chr(64 + Int(Rnd() * 26) + 1) '& Chr(64 + Int(Rnd() * 26) + 1)
         Next
         '.bla1 = String(Int(Rnd * 7) + 1, Int(Rnd * 26) + Asc("a"))
      End With
   Next
End Sub

Sub data_type.printSome()
   
   For  i As Integer = 1 To UBound(row)
      Print row(i)
   Next
   
   'Print "--- First 5 items ---"
   ''For i As Integer = 0 To 4
   'For i As Integer = 1 To 5
   '   Print row(i)
   'Next
   'Print "--- Last 5 items ---"
   'For i As Integer = UBound(row) - 4 To UBound(row)
   '   Print row(i)
   'Next
End Sub

Sub data_type.copyTo(dst As data_type)
   If UBound(row) <> UBound(dst.row) Then Print "Error": Exit Sub
   'For i As Integer = 0 To UBound(row)
   For i As Integer = 1 To UBound(row) + 1
      dst.row(i) = row(i)
   Next
End Sub

Sub data_type.sort(sort1st As sort_type, sort2nd As sort_type, sort3rd As sort_type)
   'disable invalid sort filters
   'sortOrder(0) = IIf(sort1st.column < 0 Or sort1st.column >= numCols, sort_type(0,0), sort1st)
   'sortOrder(1) = IIf(sort2nd.column < 0 Or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
   'sortOrder(2) = IIf(sort3rd.column < 0 Or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
   'qsort(@row(0), UBound(row) + 1, SizeOf(row_type), CPtr(Any Ptr, @qSortCallback))
   sortOrder(1) = IIf(sort1st.column < 1 Or sort1st.column >= numCols, sort_type(0,0), sort1st)
   sortOrder(2) = IIf(sort2nd.column < 1 Or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
   sortOrder(3) = IIf(sort3rd.column < 1 Or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
   qsort(@row(1), UBound(row) + 1, SizeOf(row_type), CPtr(Any Ptr, @qSortCallback))
End Sub

Function data_type.qSortCallback Cdecl(pRow1 As row_type Ptr, pRow2 As row_type Ptr) As Long
   'For i As Integer = 0 To 2
   For i As Integer = 1 To 3
      With sortOrder(i)
         Select Case .direction
         Case +1
            If pRow1->col(.column) < pRow2->col(.column) Then Return -1
            If pRow1->col(.column) > pRow2->col(.column) Then Return +1
         Case -1
            If pRow1->col(.column) > pRow2->col(.column) Then Return -1
            If pRow1->col(.column) < pRow2->col(.column) Then Return +1
         Case Else
            'skip, including direction = 0
         End Select
      End With
   Next
   Return 0
End Function

'-------------------------------- main program ---------------------------------

'Dim As Integer numRows = 2000, numCols = 5
Dim As Integer numRows = 10, numCols = 5

Randomize Timer
Print "Allocate memory"
Var myData = data_type(numRows, numCols), backupData = data_type(numRows, numCols)

Print "Initialize with random data"
myData.initRandom()

Print "Make backup"
myData.copyTo(backupData)
Print
Print "Unsorted data:"
myData.printSome()

'Print !"\nSort: col 0 up, col 1 up, col 2 up:"
'myData.sort(sort_type(0, +1), sort_type(1, +1), sort_type(2, +1))
Print !"\nSort: col 1 up, col 2 up, col 3 up:"
myData.sort(sort_type(1, +1), sort_type(2, +1), sort_type(3, +1))

myData.printSome()

Print !"\nPress any key to end"
Sleep
Print "End"

[fxm]

My modified code crashes on the sorting part.

2 Subs to modify at first glance:

Code: Select all

.....
Sub data_type.copyTo(dst As data_type)
   If UBound(row) <> UBound(dst.row) Then Print "Error": Exit Sub
   'For i As Integer = 0 To UBound(row)
   ''For i As Integer = 1 To UBound(row) + 1
   For i As Integer = 1 To UBound(row) '' <==
      dst.row(i) = row(i)
   Next
End Sub

Sub data_type.sort(sort1st As sort_type, sort2nd As sort_type, sort3rd As sort_type)
   'disable invalid sort filters
   'sortOrder(0) = IIf(sort1st.column < 0 Or sort1st.column >= numCols, sort_type(0,0), sort1st)
   'sortOrder(1) = IIf(sort2nd.column < 0 Or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
   'sortOrder(2) = IIf(sort3rd.column < 0 Or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
   'qsort(@row(0), UBound(row) + 1, SizeOf(row_type), CPtr(Any Ptr, @qSortCallback))
   sortOrder(1) = IIf(sort1st.column < 1 Or sort1st.column >= numCols, sort_type(0,0), sort1st)
   sortOrder(2) = IIf(sort2nd.column < 1 Or sort2nd.column >= numCols, sort_type(0,0), sort2nd)
   sortOrder(3) = IIf(sort3rd.column < 1 Or sort3rd.column >= numCols, sort_type(0,0), sort3rd)
   ''qsort(@row(1), UBound(row) + 1, SizeOf(row_type), CPtr(Any Ptr, @qSortCallback))
   qsort(@row(1), UBound(row), SizeOf(row_type), CPtr(Any Ptr, @qSortCallback)) '' <==
End Sub
.....

[Makoto WATANABE]

Dear fxm;

Thanks for your quick reply.
The program displayed the results I expected without crashing.
Thank you very much.

[Lost Zergling]

Hello,
Makoto WATANABE wrote:

I am looking for a multi-dimensional array sort and found this thread.

Although very imperfect, very incomplete and at the beginning of its development, lzae also offers a solution around the problem of multi-dimensional arrays: viewtopic.php?f=8&t=27695
The main advantage of this solution is the genericity of use: the ultimate goal is that the tool behaves as a real set of instructions, that is to say complementary instructions, consistent and likely to allow a precise algorithmic construction with wide alternatives.
The genesis of this idea is in this thread viewtopic.php?f=17&t=27606&hilit=new+ar ... 45#p260885

examples : (you'll need lzle.bi also because lzae.bi is using it)(viewtopic.php?f=8&t=26533)

Code: Select all

#Include Once "F:\Basic\lzae.bi"
Dim  aArray(1 to 4, 1 To 4) As Integer
Dim As String str_tmp
Dim As Integer i=0, k=0, w

For i=1 To 4
    For k= 1 To 4        
        '-------------Alternative syntax : reverse testing
        aArray(i,k)=i*4-k+1
    '    aArray(i,5-k)=i*4-k+1
        w-=1
    Next k
Next i

Print "---------------- Original values"
For i=1 To 4
    For k= 1 To 4
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Dim aext As ArrayExtension
aSet(aArray() , aext)


aext.SetCursor(aArray(1,1))
aext.StepCursor(1)
Print "---------------- Linear Parsing"
Print aext.Value
While aext.astep
    Print aext.Value
Wend
Print "-----------------------"
Sleep



aext.Sort_WriteArray(0)
aext.Sort_BuildVector(1)
aext.Sort_Persistency(0)

aext.Lcursor( aArray(1,1) )
aext.Rcursor( aArray(1,4) )
aext.StepCursor(1)
aext.Sort

aext.Lcursor( aArray(1,1) )
aext.Rcursor( aArray(4,4) )
aext.StepCursor(5)
aext.Apply
Print
Print "--------------- New values : back end sort vector line on 1 applied to diagonal"
For i=1 To 4
    For k= 1 To 4
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Print
Print "---------------+ Parsing new diagonal : StepCursor(5)=Line len+1"
aext.SetCursor( aArray(1,1) )
Print aext.Value
While aext.astep
    Print aext.Value
Wend
sleep
aext.StepCursor(4)
aext.SetCursor( aArray(1,1) )
'aext.SetCursor( aArray(1,2) )
'Print aext.Value & "?"

For k=1 to 4
    Print "---------------+ Parsing column " & k
    aext.SetCursor( aArray(1,k) )
    For i=1 to aext.NbSteps
        Print aext.Value
        aext.bstep
    Next i
    Print aext.Value    
Next k
Print "----------------"    
Sleep
System

Code: Select all

#Include Once "F:\Basic\lzae.bi"
Dim  aArray(1 to 4, 1 To 4) As Integer
Dim As String str_tmp
Dim As Integer i=0, k=0, w

For i=1 To 4
    For k= 1 To 4        
        '-------------Alternative syntax : reverse testing
        aArray(k,i)=i*4-k+1                                                  ' LINE CHANGED
    '    aArray(i,5-k)=i*4-k+1
        w-=1
    Next k
Next i

Print "---------------- Original values"
For i=1 To 4
    For k= 1 To 4
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Dim aext As ArrayExtension
aSet(aArray() , aext)


aext.SetCursor(aArray(1,1))
aext.StepCursor(1)
Print "---------------- Linear Parsing"
Print aext.Value
While aext.astep
    Print aext.Value
Wend
Print "-----------------------"
Sleep



aext.Sort_WriteArray(0)
aext.Sort_BuildVector(1)
aext.Sort_Persistency(0)

aext.Lcursor( aArray(1,2) )                                      ' LINE CHANGED
aext.Rcursor( aArray(4,2) )                                      ' LINE CHANGED
aext.StepCursor(4)                                                 ' LINE CHANGED
aext.Sort

aext.Lcursor( aArray(1,1) )                                     ' LINE CHANGED
aext.Rcursor( aArray(4,1) )                                    ' LINE CHANGED
aext.StepCursor(4)                                                 ' LINE CHANGED
aext.Apply
Print
Print "--------------- New values : back end sort vector on col 2 applied to col 1"
For i=1 To 4
    For k= 1 To 4
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Print
Print "---------------+ Parsing new diagonal : StepCursor(5)=Line len+1"
aext.SetCursor( aArray(1,1) )
Print aext.Value
While aext.astep
    Print aext.Value
Wend
sleep
aext.StepCursor(4)
aext.SetCursor( aArray(1,1) )
'aext.SetCursor( aArray(1,2) )
'Print aext.Value & "?"

For k=1 to 4
    Print "---------------+ Parsing column " & k
    aext.SetCursor( aArray(1,k) )
    For i=1 to aext.NbSteps
        Print aext.Value
        aext.bstep
    Next i
    Print aext.Value    
Next k
Print "----------------"    
Sleep
System

[dodicat]

For a straight forward string array(multi dim) sort.
note
1) The array pointer from #include "fbc-int/array.bi" is not yet concluded, the next fb will use it differently, so I have used my own pointer.
2) Memcpy from the crt.bi doesn't handle fb strings very well so I use my own memcopy.
3) The quicksort is general, but I have set it for strings. I use the standard quicksort, but the crt sort would do just as well.

The sort method is plain simple, put the multi dim array into a single dim array, sort it and put it back into the multi dim array.

Code: Select all

'#include "fbc-int/array.bi"   'not yet

#macro __Arrayptr__(array)
Iif(Ubound(array,0)=1,@array(Lbound(array)), _
Iif(Ubound(array,0)=2,@array(Lbound(array,1),Lbound(array,2)), _
Iif(Ubound(array,0)=3,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3)), _
Iif(Ubound(array,0)=4,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3),Lbound(array,4)), _
Iif(Ubound(array,0)=5,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3),Lbound(array,4),Lbound(array,5)), _
Iif(Ubound(array,0)=6,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3),Lbound(array,4),Lbound(array,5),Lbound(array,6)), _
Iif(Ubound(array,0)=7,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3),Lbound(array,4),Lbound(array,5),Lbound(array,6),Lbound(array,7)), _
Iif(Ubound(array,0)=8,@array(Lbound(array,1),Lbound(array,2),Lbound(array,3),Lbound(array,4),Lbound(array,5),Lbound(array,6),Lbound(array,7),Lbound(array,8)),0))))))))
#endmacro

'my own pointer setup
#macro setptr(datatype) 
Function arrayptr Overload(a() As datatype,Byref ret As boolean=0)  As datatype Ptr
  #macro Get_Size(array,d)
  d=Ubound(array,0)
  For n As Long=1 To d
    If n=1 Then d=1
    d=d*(Ubound(array,n)-Lbound(array,n)+1)
  Next
  d=d*Sizeof(array)
  #endmacro
  Static As datatype Ptr z
  Dim As Long size
  get_size(a,size)
  z= __arrayptr__(a)
  If  z >  @ret + size Then ret=true Else ret=false
  Return z
End Function
#endmacro

'my own quicksort setup

#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Long)
  Dim As Long i=begin,j=finish
  Dim As datatype x =array(((I+J)\2))
  While  I <= J
    While array(I)dot b1 X dot:I+=1:Wend
      While array(J)dot b2 X dot:J-=1:Wend
        If I<=J Then Swap array(I),array(J): I+=1:J-=1
      Wend
      If J > begin Then fname(array(),begin,J)
      If I < Finish Then fname(array(),I,Finish)
    End Sub
    #endmacro  
    
    setptr(String)                    'setup to get string array pointer
    setQsort(String,stringsort,up,)   'setup string quicksort
    
    
    Sub sort(k() As String)
      #macro memcopy(dest,src,size)
      For n As Long=0 To size-1
        (dest)[n]=(src)[n]
      Next
      #endmacro
      
      #macro GetNumElements(array,d)
      d=Ubound(array,0)
      For n As Integer=1 To d
        If n=1 Then d=1
        d=d*(Ubound(array,n)-Lbound(array,n)+1)
      Next
      #endmacro
      
      Dim As String Ptr sp=arrayptr(k()) 'fb_ArrayGetDesc(k())->base_ptr  'not yet
      Dim As Long sz
      GetNumelements(k,sz)
      Dim As String tmp(1 To sz)
      memcopy(@tmp(1),sp,sz)
      stringsort(tmp(),Lbound(tmp),Ubound(tmp))
      memcopy(sp,@tmp(1),sz)
    End Sub
    
    #define range(f,l) Int(Rnd*((l+1)-(f)))+(f)
    #define rl Chr(range(65,90),range(65,90),range(65,90),range(65,90),range(65,90))
    
    Redim As String k(1 To 1000,1 To 1000)
    Dim As Long ctr
    For n As Long=1 To 1000
      For m As Long=1 To 1000
        ctr+=1
        k(n,m)=rl
        If ctr=20 Then Print:Print
        If ctr<20 Or ctr>1000000-20 Then Print "k(";n;",";m;") = ";k(n,m)
      Next
    Next
    Print  "sorting one million strings please wait . . ."
    ctr=0
    
    Dim As Double t1,t2
    t1=Timer
    sort(k())
    t2=Timer
    
    For n As Long=1 To 1000
      For m As Long=1 To 1000
        ctr+=1
        If ctr=20 Then Print:Print
        If ctr<20 Or ctr>1000000-20 Then Print "k(";n;",";m;") = ";k(n,m)
      Next
    Next
    Print 
    Print "Time taken for 1000000 ";t2-t1
    Print "Example 2 press a key . . ."
    Sleep
    '======== 
    'example2
    Screen 20
    ctr=0
    Dim As String s=String(7,0)
    Redim As String g(0 To 3,1 To 2,3 To 6)
    For a As Long=0 To 3
      For b As Long=1 To 2
        For c As Long=3 To 6
          For n As Long=0 To 6
            s[n]=range(98,122)
          Next n
          g(a,b,c)=s
          Draw String (20,ctr*16),g(a,b,c)
          ctr+=1
        Next
      Next
    Next
    
    
    sort(g())
    ctr=0
    
    For a As Long=0 To 3
      For b As Long=1 To 2
        For c As Long=3 To 6
          Draw String (200,ctr*16),g(a,b,c)
          ctr+=1
        Next
      Next
    Next
    locate 40
    print "Done"
    Sleep
    
    
      

[Makoto WATANABE]

Dear Lost Zergling

Thanks for your information.
I expect not only column operations, but the ability to sort rows together based on a specified column.
I look forward to the development of your tool.

[Lost Zergling]

Dear Mr. Watanabe,

First of all, thank you for your interest.
It is indeed a little complicated, laborious and counter-intuitive, but it is nevertheless possible to order lines according to a vector:

Code: Select all

#Include Once "F:\Basic\lzae_04.bi"
Dim  aArray(1 to 4, 1 To 6) As Integer
Dim As String str_tmp
Dim As Integer i=0, k=0, w

For i=1 To 4
    For k= 1 To 6
        '-------------Alternative syntax : reverse testing
        aArray(i,7-k)=i*6-k+1
    Next k
Next i

Print "---------------- Original values"
For i=1 To 4
    For k= 1 To 6
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Dim aext As ArrayExtension
aSet(aArray() , aext)

Dim MyList As List
MyList.HashTag("1") : MyList.RwTag1("4")
MyList.HashTag("2") : MyList.RwTag1("3")
MyList.HashTag("3") : MyList.RwTag1("2")
MyList.HashTag("4") : MyList.RwTag1("1")

aext.ImportVector(MyList)
aext.StepCursor(6)

For k=1 to 6
aext.LCursor( aArray(1,k) )
aext.Apply
Next k

Print "---------------- New values (lines transpose column per column)"
For i=1 To 4
    For k= 1 To 6
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i


Sleep
System

It is also possible to obtain a transposition vector from the sorting of a column:

Code: Select all

#Include Once "F:\Basic\lzae_04.bi"
Dim  aArray(1 to 4, 1 To 6) As Integer
Dim As String str_tmp
Dim As Integer i=0, k=0, w

For i=1 To 4
    For k= 1 To 6
        '-------------Alternative syntax : reverse testing
       ' aArray(i,k)=i*6-k+1
        aArray(5-i,7-k)=i*6-k+1
    Next k
Next i

Print "---------------- Original values"
For i=1 To 4
    For k= 1 To 6
        str_tmp+=Left(Str(aArray(i,k))+"    ", 4)
    Next k
    Print str_tmp
    str_tmp=""    
Next i

Dim aext As ArrayExtension
aSet(aArray() , aext)


aext.Sort_WriteArray(0)
aext.Sort_BuildVector(1)
aext.Sort_Persistency(0)

aext.Lcursor( aArray(1,6) ) 
aext.Rcursor( aArray(4,6) )
aext.StepCursor(6) 
aext.Sort

Dim MyList As List
aext.exportVector(MyList)

MyList.Root
While MyList.HashStep
    Print MyList.HashTag & " " & MyList.Tag(1)
Wend

sleep
system

The transposition vectors can be exported, imported, passed in parameter from one aext object to another, created manually.
It is possible to program matrix manipulations on rows, columns, to sort only sub-parts of an array, to pass calculations on diagonals, dimensions or other arrays.
On the other hand, sorting is only one way, and functions that would be very useful remain to be developed, unwanted or even more exotic behaviors are to be feared.

It's more of a toy (a little gas plant despite the apparent simplicity), but with the list engine in the background, many operations will be done without having the problem of memory management, the need to use pointers or low level code.
The user can thus focus on the complexity of the dynamics of arrays rather than on pointers.