;======================================================================================================================
; Collection of Array sort algorithms including bonus tools.
; Adapted to WinBatch by Detlev Dalitz.20010720.20020718
;----------------------------------------------------------------------------------------------------------------------
; udfArrPartSort (Array) ; from slow
; udfArrBubbleSort (Array) ; I
; udfArrQuickNRSort (Array) ; I
; udfArrShellSort (Array) ; I
; udfArrQuickRSort (Array) ; I
; udfArrBinSort (Array) ; v
; udfArrItemSort (Array, Delimiter) ; to fast ?
; udfArrDistributionSort (Array, KeyCount) ; special hash sort
;----------------------------------------------------------------------------------------------------------------------
; udfIsItemInArray (Array, item) ; checks if item exists in Array; returns bool
;----------------------------------------------------------------------------------------------------------------------
; udfArrWriteFile (Array, filename) ; unload Array to diskfile; returns filesize
; udfArrReadFile (filename) ; load Array from diskfile; returns new Array
;----------------------------------------------------------------------------------------------------------------------
; udfArrDump (Array, Delimiter) ; for testing dim-1 Array; returns string
;======================================================================================================================
Gosub DefineUDFs
Gosub testsort ; test the sort functions
Gosub testload ; test write to file and read from file
Exit
;======================================================================================================================
:testsort
logo="Demo Array Sort Algorithms"
test1="udfArrPartSort (Array)"
test2="udfArrBubbleSort (Array)"
test3="udfArrQuickNRSort (Array)"
test4="udfArrShellSort (Array)"
test5="udfArrQuickRSort (Array)"
test6="udfArrBinSort (Array)"
test7="udfArrItemSort (Array, Delimiter)"
test8="udfArrDistributionSort (Array, KeyCount)"
testlist=""
For i=1 To 10
If IsDefined(test%i%) Then testlist=StrCat(testlist,test%i%,@tab)
Next
TestCount=ItemCount(testlist,@tab)
asklist=""
While (asklist=="")
asklist=testlist
asklist=AskItemlist(StrCat(logo,": Select one or more functions to test"),asklist,@tab,@unsorted,@extended)
EndWhile
testlist=asklist
Drop(asklist)
testitemsdef=30
testitems=AskLine(logo,"How many items in Array?",testitemsdef)
testitems=Max(testitems,10)
testitemlendef=20
testitemlen=AskLine(logo,"How max length of each item?",testitemlendef)
testitemlen=Max(testitemlen,1)
BoxOpen(StrCat(logo,": Processing"), "Be patient")
BoxText("creating test items ...")
; --- create list of testitems, method A ------------------------------------------------------------------------------
sortstr=""
For i=1 To testitems
item=""
For k=1 To Random(1+testitemlen)
item=StrCat(item,Num2Char(65 + Random(25)))
Next
If ((i mod (testitems/10))==0) Then BoxText(StrCat("creating test item ...",@crlf,testitems,"/",i,@crlf,item))
sortstr = ItemInsert(item,-1,sortstr," ")
Next
;----------------------------------------------------------------------------------------------------------------------
; --- create list of testitems, method B ------------------------------------------------------------------------------
;sortstr=""
;poolstr="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvw1234567890"
;poollen=StrLen(poolstr)
;For i=1 to testitems
; item=""
; For k=1 to random(1+testitemlen)
; item=StrCat(item,StrSub(poolstr,1+Random(poollen),1))
; Next
; If ((i mod (testitems/10))==0) then Boxtext(StrCat("creating test item ...",@crlf,testitems,"/",i,@crlf,item))
; sortstr = ItemInsert(item,-1,sortstr," ")
;Next
;----------------------------------------------------------------------------------------------------------------------
KeyCount=26
Delimiter=@tab
maxticks=0
testcount=ItemCount(Testlist,@tab)
For i=1 To testcount
item=ItemExtract(i,testlist,@tab)
BoxText(StrCat(item,@crlf,"sorting ..."))
Array = Arrayize(sortstr," ")
start=GetTickCount()
%item%
stop=GetTickCount()
ticks%i%=stop-start
maxticks=Max(ticks%i%,maxticks)
msgstr=StrCat(item,@crlf)
If (testitems<50) Then msgstr=StrCat(msgstr,udfArrDump(Array,@cr),@crlf)
msgstr=StrCat(msgstr,"ticks=",ticks%i%)
Display(10,item,msgstr)
Drop(Array)
Next
BoxShut()
msgstr=""
For i=1 To testcount
item=ItemExtract(i,testlist,@tab)
msgstr=StrCat(msgstr,100*ticks%i%/maxticks,"%%",@tab,ticks%i%,@tab,item,@crlf)
Next
Message(StrCat(logo,": Summary"),msgstr)
Return
;======================================================================================================================
:testload
logo = "Demo Array UnLoad Load Functions"
BoxOpen(StrCat(logo,": Processing"), "Be patient")
BoxText("creating test items ...")
d1 = 20
d2 = 3
d1count = d1-1
d2count = d2-1
A = ArrDimension(d1,d2)
ArrInitialize(A,0)
For d2=0 To d2count
For d1=0 To d1count
item = ""
For k=1 To Random(25)
item = StrCat(item,Num2Char(65 + Random(25)))
Next
A[d1,d2] = item
Next
Next
BoxShut()
TempFile = StrCat(Environment("temp"),"\arrtest.txt")
num = udfArrWriteFile(A,TempFile)
Message(StrCat("Array A ",num," byte written to diskfile ",TempFile),udfArrDump(A,@cr))
B = udfArrReadFile(TempFile)
Message(StrCat("Array B created, read from diskfile ",TempFile),udfArrDump(B,@cr))
RunZoom("notepad",TempFile)
Return
;======================================================================================================================
:DefineUDFs
;======================================================================================================================
If ItemLocate("udfarrpartsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrpartsort
#DefineFunction udfArrPartSort (Array)
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
sorted=@false
While !sorted
sorted=@true
For i=0 To arrmax-1
If (Array[i]>Array[i+1])
A=Array[i]
Array[i]=Array[i+1]
Array[i+1]=A
sorted=@false
EndIf
Next
EndWhile
Return (Array)
#EndFunction
:skip_udfarrpartsort
If ItemLocate("udfarrbubblesort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrbubblesort
#DefineFunction udfArrBubbleSort (Array)
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
For i=0 To arrmax-1
For k=i+1 To arrmax
If (Array[i]>Array[k])
A=Array[i]
Array[i]=Array[k]
Array[k]=A
EndIf
Next
Next
Return (Array)
#EndFunction
:skip_udfarrbubblesort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrshellsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrshellsort
#DefineFunction udfArrShellSort (Array);
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
start=Floor(Loge(Max(arrmax,2)-1)/Loge(2))
For i=start To 0 By -1
jump=Exp(i*Loge(2))
For k=jump To arrmax
A=Array[k]
z=k-jump
done=!(A<Array[z])
While !done
Array[z+jump]=Array[z]
z=z-jump
If (z>0)
done=!(A<Array[z])
Else
done=@true
EndIf
EndWhile
Array[z+jump]=A
Next
Next
Return (Array)
#EndFunction
:skip_udfarrshellsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrquicknrsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrquicknrsort
#DefineFunction udfArrQuickNRSort (Array); non recursive
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
left=ArrDimension(100)
right=ArrDimension(100)
left[1]=0
right[1]=arrmax
sp=1
While (sp>0)
If (left[sp]>=right[sp])
sp=sp-1
Else
i=left[sp]
k=right[sp]
pivot=Array[k]
mid=(i+k)/2
If ((k-i)>5)
If ((Array[mid]<pivot) && (Array[mid]>Array[i])) || ((Array[mid]>pivot) && (Array[mid]<Array[i]))
A=Array[mid]
Array[mid]=Array[k]
Array[k]=A
EndIf
Else
If ((Array[i]<Array[mid]) && (Array[i]>pivot)) || ((Array[i]>Array[mid]) && (Array[i]<pivot))
A=Array[i]
Array[i]=Array[k]
Array[k]=A
EndIf
EndIf
pivot=Array[k]
While (i<k)
While (Array[i]<pivot)
i=i+1
EndWhile
k=k-1
While ((i<k) && (pivot<Array[k]))
k=k-1
EndWhile
If (i<k)
A=Array[i]
Array[i]=Array[k]
Array[k]=A
EndIf
EndWhile
k=right[sp]
A=Array[i]
Array[i]=Array[k]
Array[k]=A
If ((i-left[sp])>=(right[sp]-i))
left[sp+1]=left[sp]
right[sp+1]=i-1
left[sp]=i+1
Else
left[sp+1]=i+1
right[sp+1]=right[sp]
right[sp]=i-1
EndIf
sp=sp+1
EndIf
EndWhile
Drop(left,right)
Return (Array)
#EndFunction
:skip_udfarrquicknrsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrquickrsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrquickrsort
#DefineFunction udfArrQuickRSort (Array) ; recursive
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
udfArrQRSort(Array,0,arrmax)
Return (Array)
#EndFunction
:skip_udfarrquickrsort
If ItemLocate("udfarrqrsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrqrsort
#DefineFunction udfArrQRSort (Array, left, right)
; "udfArrQRSort" should be called first only from inner "udfArrQuickRSort" or by itself!
If (left<right)
pivot=Array[(left+right)/2]
i=left
k=right
While (i<=k)
While (Array[i]<pivot)
i=i+1
EndWhile
While (pivot<Array[k])
k=k-1
EndWhile
If (i<=k)
A=Array[i]
Array[i]=Array[k]
Array[k]=A
i=i+1
k=k-1
EndIf
EndWhile
udfArrQRSort(Array,left,k)
udfArrQRSort(Array,i,right)
EndIf
Return (Array)
#EndFunction
:skip_udfarrqrsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrbinsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrbinsort
#DefineFunction udfArrBinSort (Array)
If (VarType(Array)<>256) Then Return (Array) ; is Array?
If (ArrInfo(Array,0)>1) Then Return (Array) ; only dimension 1 wanted
If (VarType(Array[0])<>2) Then Return (Array) ; only strings wanted
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
maxlen=0
For i=0 To arrmax
maxlen=Max(maxlen,StrLen(Array[i]))
Next
bb=BinaryAlloc(maxlen*ArrInfo(Array,1))
For i=0 To arrmax
BinaryPokeStr(bb,i*maxlen,Array[i])
Next
BinarySort(bb,maxlen,0,maxlen,0)
For i=0 To arrmax
Array[i]=BinaryPeekStr(bb,i*maxlen,maxlen)
Next
BinaryFree(bb)
Return (Array)
#EndFunction
:skip_udfarrbinsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarritemsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarritemsort
#DefineFunction udfArrItemSort (Array,Delimiter)
If (VarType(Array)<>256) Then Return (Array) ; is Array?
If (ArrInfo(Array,0)>1) Then Return (Array) ; only dimension 1 wanted
If (VarType(Array[0])<>2) Then Return (Array) ; only strings wanted
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
sortstr=""
For i=0 To arrmax
sortstr=ItemInsert(Array[i],-1,sortstr,Delimiter)
Next
sortstr=ItemSort(sortstr,Delimiter)
For i=0 To arrmax
Array[i]=ItemExtract(i+1,sortstr,Delimiter)
Next
Return (Array)
#EndFunction
:skip_udfarritemsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrdistributionsort",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrdistributionsort
#DefineFunction udfArrDistributionSort (Array, KeyCount)
If (VarType(Array)<>256) Then Return (Array)
If (ArrInfo(Array,0)>1) Then Return (Array)
arrmax=ArrInfo(Array,1)-1
If (arrmax<0) Then Return (Array)
; how many different keys exist? If fix number is known, then computing is not necessary
If (KeyCount==0)
itemlist=""
For i=0 To arrmax
If (ItemLocate(Array[i],itemlist,@tab)==0) Then itemlist=ItemInsert(Array[i],-1,itemlist,@tab)
Next
KeyCount=ItemCount(itemlist,@tab)
EndIf
BinsArray = ArrDimension(KeyCount)
StartArray = ArrDimension(KeyCount)
SaveArray = ArrDimension(ArrInfo(Array,1))
ArrInitialize(BinsArray,0)
ArrInitialize(StartArray,0)
For i=0 To arrmax
SaveArray[i] = Array[i] ; copy Array to save
BinsIndex = (Max(0,Char2Num(Array[i])-65)) ; hier die entsprechende Abbildungsfunktion anwenden
BinsArray[BinsIndex] = BinsArray[BinsIndex] + 1 ; count the number of each key value
Next
pos=0
For i=1 To (KeyCount-1)
pos = pos + BinsArray[i-1] ; compute the start position of each bin
StartArray[i] = pos
Next
For i=0 To arrmax ; deal the saved Array back to the original
SaveIndex = (Max(0,Char2Num(SaveArray[i])-65)) ; hier die entsprechende Abbildungsfunktion anwenden
StartIndex = StartArray[SaveIndex]
Array[StartIndex] = (Num2Char(SaveIndex+65)) ; hier die entsprechende _inverse_ Abbildungsfunktion anwenden
StartArray[SaveIndex] = StartArray[SaveIndex] + 1
Next
Drop(arrmax,BinsArray,BinsIndex,i,pos,SaveArray,SaveIndex,StartArray,StartIndex)
Return(Array)
; Is this an example for ideal hashing?
; Adopted from Pascal source published by
; James L. Allison, 1703 Neptune Lane, Houston, Texas 77062, Dec 22, 1988.
; "This is a real screamer, but it takes a lot of space,
; and is hard to package for inclusion in a library.
; It requires prior knowledge of how the Array and keys are structured.
; It is only feasible where there are a small number of possible keys.
; In this example, there are only 256 different values.
; It works well, for example, where the key is sex, department or state.
; It would be a disaster if the keys were name or phone number."
#EndFunction
:skip_udfarrdistributionsort
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfisiteminarray",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfisiteminarray
#DefineFunction udfIsItemInArray (Array, item)
; this udf needs an ascending sorted Array
If (VarType(Array)<>256) Then Return (Array) ; is Array?
If (ArrInfo(Array,0)>1) Then Return (Array) ; only dimension 1 wanted
elements=ArrInfo(Array,1)
If (elements==0) Then Return (Array)
top=elements
bot=0
pivot=top/2
done=@false
found=@false
While !(done||found)
If (Array[pivot]<item)
bot=pivot
pivot=bot+((top-bot)/2)
done=(bot==pivot)
Else
top=pivot
pivot=top-((top-bot)/2)
done=(top==pivot)
EndIf
found=(Array[pivot]==item)
EndWhile
Return (found)
#EndFunction
:skip_udfisiteminarray
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrreadfile",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrreadfile
#DefineFunction udfArrReadFile (filename)
; Create Array from txtfile
; Example: MyArray = udfFileToArray(myFile)
fsize = FileSize(filename)
If (fsize <> 0)
bbsize = fsize+1
bb = BinaryAlloc (bbsize)
BinaryPokeStr(bb,0,@lf)
BinaryReadEx(bb,1,filename,0,fsize)
; read header, must be 7 lines on top of the file, but read into line 8
headercheck=""
struct=BinaryTagInit(bb,@lf,@cr)
For i=1 To 8
struct=BinaryTagFind(struct)
If (struct=="") Then Break ; something wrong in file
line=BinaryTagExtr(struct,0)
If (ItemExtract(1,line,";")=="ArrInfo")
index=ItemExtract(2,line,";")
ai%index%=ItemExtract(3,line,";")
headercheck=ItemInsert(index,-1,headercheck,",")
EndIf
Next
headercheck=ItemSort(headercheck,",")
If (headercheck=="0,1,2,3,4,5,6")
;declare Array
Array = ArrDimension(ai1,ai2,ai3,ai4,ai5)
;read data
offset=BinaryTagIndex(struct,1)-1
BinaryEodSet(bb,0)
BinaryReadEx(bb,0,filename,offset,fsize)
struct=BinaryTagInit(bb,@lf,@cr)
While @true
struct=BinaryTagFind(struct)
If (struct=="") Then Break ; end of file
line=BinaryTagExtr(struct,0)
If (line=="") Then Break ; end of data
ArrIndex=ItemExtract(1,line,";")
ArrType=ItemExtract(2,line,";")
ArrData=ItemExtract(3,line,";")
Array[%ArrIndex%]=ArrData
EndWhile
EndIf
BinaryFree(bb)
EndIf
If !IsDefined(Array) Then Array=Arrayize(" ","")
Return (Array)
#EndFunction
:skip_udfarrreadfile
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrwritefile",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrwritefile
#DefineFunction udfArrWriteFile (aArray, sFilename)
; Create txtfile from Array
; Example: udfArrToFile(myArray,myFile)
If (VarType(aArray)<>256) Then Return (aArray) ; no Array
If (ArrInfo(aArray,6)==0) Then Return (aArray) ; no elements
ai0="ArrInfo;0;{{0}};number of dimensions in the array"
ai1="ArrInfo;1;{{1}};number of elements in dimension 1"
ai2="ArrInfo;2;{{2}};number of elements in dimension 2"
ai3="ArrInfo;3;{{3}};number of elements in dimension 3"
ai4="ArrInfo;4;{{4}};number of elements in dimension 4"
ai5="ArrInfo;5;{{5}};number of elements in dimension 5"
ai6="ArrInfo;6;{{6}};number of elements in the entire array"
iDims=ArrInfo(aArray,0)
For i=1 To 5
e%i%=Max(ArrInfo(aArray,i)-1,0)
Next
hFW=FileOpen(sFilename,"WRITE")
; write header
For i=0 To 6
FileWrite(hFW,StrReplace(ai%i%,"{{%i%}}",ArrInfo(aArray,i)))
Next
; write data
For d1=0 To e1
For d2=0 To e2
For d3=0 To e3
For d4=0 To e4
For d5=0 To e5
index=""
For i=1 To iDims
index=ItemInsert(d%i%,-1,index,",")
Next
sOut=""
sOut=ItemInsert(index,-1,sOut,";")
sOut=ItemInsert(VarType(aArray[%index%]),-1,sOut,";")
If VarType(aArray[%index%])
sOut = ItemInsert(aArray[%index%],-1,sOut,";")
Else
sOut = ItemInsert("",-1,sOut,";")
EndIf
FileWrite(hFW,sOut)
Next
Next
Next
Next
Next
; close
FileClose(hFW)
Return (FileSize(sFilename))
#EndFunction
:skip_udfarrwritefile
;----------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfarrdump",IntControl(77,103,0,0,0),@tab) Then Goto skip_udfarrdump
#DefineFunction udfArrDump (aArray, sDelimiter)
If (VarType(aArray)<>256) Then Return ("Dump not available. No Array.")
If (ArrInfo(aArray,6)==0) Then Return ("Dump not available. No Elements.")
If (ArrInfo(aArray,0)>1) Then Return ("Dump not available. Array has more than 1 Dimension.")
sItemList = ""
iArrMax = Max(ArrInfo(aArray,1)-1,0)
For i=0 To iArrMax
If VarType(aArray[i])
sItemList = ItemInsert(aArray[i],-1,sItemList,sDelimiter)
Else
sItemList = ItemInsert("",-1,sItemList,sDelimiter)
EndIf
Next
sItemList = StrCat("Elements=",iArrMax+1,@crlf,sItemList)
Return (sItemList)
#EndFunction
:skip_udfarrdump
;======================================================================================================================
Return ; from gosub DefineUDFs
;======================================================================================================================
|
