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

General FreeBASIC programming questions.
badidea
Posts: 2149
Joined: May 24, 2007 22:10
Location: The Netherlands

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

Postby badidea » Dec 15, 2019 21:54

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
Posts: 88
Joined: Oct 10, 2017 6:41

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

Postby ppf » Dec 15, 2019 22:01

@ 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 !
Last edited by ppf on Dec 15, 2019 22:09, edited 1 time in total.
badidea
Posts: 2149
Joined: May 24, 2007 22:10
Location: The Netherlands

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

Postby badidea » Dec 15, 2019 22:06

ppf wrote: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
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

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

Postby dodicat » Dec 16, 2019 19:41

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
Posts: 194
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

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

Postby Makoto WATANABE » Jun 25, 2020 1:50

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.
https://www.freebasic.net/forum/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
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

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

Postby fxm » Jun 25, 2020 6:49

Makoto WATANABE wrote: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
Posts: 194
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

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

Postby Makoto WATANABE » Jun 25, 2020 9:37

Dear fxm;

Thanks for your quick reply.
The program displayed the results I expected without crashing.
Thank you very much.
Lost Zergling
Posts: 333
Joined: Dec 02, 2011 22:51
Location: France

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

Postby Lost Zergling » Jun 25, 2020 9:40

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+array+features&start=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
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

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

Postby dodicat » Jun 25, 2020 12:23

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
Posts: 194
Joined: Apr 10, 2010 11:41
Location: Japan
Contact:

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

Postby Makoto WATANABE » Jun 26, 2020 1:54

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
Posts: 333
Joined: Dec 02, 2011 22:51
Location: France

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

Postby Lost Zergling » Jun 26, 2020 15:36

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.

Return to “General”

Who is online

Users browsing this forum: No registered users and 10 guests