I took the liberty to "optimise" dodicat's code of Aug 11, 2019 15:31 (three posts above) by adding a switch that loads the string array from disk. The creation part is very slow, therefore it is convenient to create it once, then recall it from disk to speed up the testing:
Code: Select all
#include "Recall.bi"
#define fromdisk 1 ' 1=create, 2=load
Sub create(L() As String)
#if fromdisk=1
Dim As Long fText=Freefile
Open "SortTemp.txt" For Binary Access Write As #fText
#define range(f,l) Int(Rnd*(((l)+1)-(f))+(f))
#define q range(97,122)-Iif(Rnd>.5,32,0)
Randomize 1
For n As Long=Lbound(L) To Ubound(L)
Dim As String g1=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
Dim As String g2=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
Dim As String g3=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
L(n)=Left(g1+g2+g3,60+Rnd*30)
Print #fText, L(n)
Next
Close #fText
Print Ubound(L); " strings created"
#else
Print "Loading array - ";
Print Recall("SortTemp.txt", L());" strings loaded from SortTemp.txt"
#endif
End Sub
Here is the required Recall.bi - copy & save to disk in the same folder as the main source:
Code: Select all
' Recall.bi, 12 August 2019, jj2007
#include once "crt.bi" ' needed for memcpy
#ifndef maxCell
#Define maxCell 100 ' whatever you consider enough for a single cell
#endif
Dim shared retstr As string * maxCell+1
Function Recall(fname As String, locArray() As String) As Integer
Dim As Integer ct=0, cursize=1000 ' locArray is a local representation of a dynamic array
Dim As Long f=Freefile, sBytes
If Open(fname For Binary Access Read As #f) = 0 Then
Dim as ubyte ptr pContent = Allocate(Lof(f)), CurPos=pContent, CrPos
Dim as long flen=Lof(f)
Get #f, 1, *pContent, Lof(f)
Close #f
Do
if ct=0 or ct>cursize then
cursize+=cursize shr 1
ReDim Preserve locArray(cursize)
endif
CrPos=strstr(CurPos, Chr(10))
if CrPos=0 Then CrPos=pContent+flen:flen=0
sBytes=CrPos-CurPos-1
if sBytes>0 then
locArray(ct)=Space(sBytes)
memcpy(StrPtr(locArray(ct)), CurPos, sBytes)
endif
CurPos=CrPos+1
ct+=1 ' inc dword ptr [ebp-20]
Loop until flen=0
While ct>1 and len(trim(locArray(ct-1)))=0 ' get rid of trailing empty strings
ct-=1
Wend
ReDim Preserve locArray(ct-1)
DeAllocate(pContent)
Else
Print "Error opening file"
End If
Return ct
End Function
Function Cell(row As integer, col As integer, locArray() As String) As string
Dim As integer ct=0, ctTabs=0, posLeft=-1, posRight=0
Dim As ubyte ptr pString
Dim c As ubyte
pString=StrPtr(locArray(row))
if pString then
Do
c=pString[ct]
if c=0 then
if ctTabs>=col then posRight=ct+1
Exit do
endif
if c=9 then
ctTabs=ctTabs+1
if col=0 then
posLeft=0
if ctTabs>col then
posRight=ct+1
Exit do
endif
else
if posLeft=-1 and ctTabs>=col then
posLeft=ct+1
elseif ctTabs>col then
posRight=ct+1
Exit do
endif
endif
endif
ct=ct+1
Loop
endif
if posRight=0 then
retstr[0]=0
else
posRight-=posLeft
if posRight>maxCell then posRight=maxCell
memcpy(StrPtr(retstr), pString+posLeft, posRight)
retstr[posRight-1]=0
endif
return retstr
end function
And here is
Dodicat's full code with the modification. Compile & run once with #define fromdisk 1, then test the sort algos with #define fromdisk 2. I moved the limit (#strings) up, too, to make it more transparent:
Code: Select all
Dim As Long limit=1000000
#define fromdisk 1 ' 1=create, 2=load
Dim Shared As Ubyte u(255)
#define lwr(s) iif(s<91 andalso s>64,s+32,s)
For n As Long=0 To 255
u(n)=lwr(n) 'lookup
Next
Function lessthan(a As String,b As String,Lenb as long) As Long
static as long lena
lena=cast(integer ptr,@a)[1]'=Len(a)
For n as long =0 To Iif(lena<lenb,lena,lenb)-1
If u(a[n]) < u(b[n]) Then Return -1
If u(a[n]) > u(b[n]) Then Return 0
Next
Return 0
End Function
Function morethan(a As String,b As String,lenb as long) As Long
static as long lena
lena=cast(integer ptr,@a)[1]'=Len(a)
For n as long =0 To Iif(lena<lenb,lena,lenb)-1
If u(a[n]) > u(b[n]) Then Return -1
If u(a[n]) < u(b[n]) Then Return 0
Next
Return 0
End Function
Sub sortup(array() As String,begin As Long,Finish As Long)
static as string x
var i=begin,j=finish
x=(array(((I+J)\2)))
var lenx=cast(integer ptr,@x)[1]'=len(X) 'get length here instead of in the loops
While I <= J
While lessthan(array(I),X,lenx):I+=1:Wend
While morethan(array(J),X,lenx):J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J >begin Then sortup(array(),begin,J)
If I <Finish Then sortup(array(),I,Finish)
End Sub
Sub sortdown(array() As String,begin As Long,Finish As Long)
static as string x
var i=begin,j=finish
x=(array(((I+J)\2)))
var lenx=len(X)
While I <= J
While morethan(array(I),X,lenx):I+=1:Wend
While lessthan(array(J),X,lenx):J-=1:Wend
If I<=J Then Swap array(I),array(J): I+=1:J-=1
Wend
If J >begin Then sortdown(array(),begin,J)
If I <Finish Then sortdown(array(),I,Finish)
End Sub
#include "Recall.bi"
Sub create(L() As String)
#if fromdisk=1
Dim As Long fText=Freefile
Open "SortTemp.txt" For Binary Access Write As #fText
#define range(f,l) Int(Rnd*(((l)+1)-(f))+(f))
#define q range(97,122)-Iif(Rnd>.5,32,0)
Randomize 1
For n As Long=Lbound(L) To Ubound(L)
Dim As String g1=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
Dim As String g2=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
Dim As String g3=Chr(q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q,q)
L(n)=Left(g1+g2+g3,60+Rnd*30)
Print #fText, L(n)
Next
Close #fText
Print Ubound(L); " strings created"
#else
Print "Loading array - ";
Print Recall("SortTemp.txt", L());" strings loaded from SortTemp.txt"
#endif
End Sub
Sub show(L() As String)
For n As Long=Lbound(L) To 10
Print L(n)
Next
For n As Long=1 To 4
Print "..."
Next
For n As Long=Ubound(L)-10 To Ubound(L)
Print L(n)
Next
End Sub
Dim As Double t1,t2
Dim As String L(1 To limit)
Print "Creating string"
create(L())
Print "Commence sort (crt)"
t1=Timer
sortup(L(),Lbound(L),Ubound(L))
t2=Timer
show(L())
Print t2-t1;" Seconds quicksort"
Sleep
See here for an assembly equivalent, showing that the case-insensitive algo is roughly a factor 2.5 slower