🧠💾 The data structure is seamlessly integrated within the host string & requires no additional memory management—simply use the string as is. 🚫🗑�
🔗 Its integrity is maintained throughout the string's lifetime, whether stored or transferred. To remain up-to-date, it must be passed by reference. 🔄
📊 The array functions like a buffered stack, complete with array procedures, handling up to 100,000 strings efficiently. However, it slows down with a million. 🐢
🔍 The hash table excels at fast retrieval for 100,000 items but is slower when adding new ones due to its binary insert method. It can manage approximately 25,000 items without a predefined 'capacity' and maintains key order. 🔑
🛠� Utilizing PureBasic's versatile functions (ChrToUtf8$()/Utf8ToChr$, MK.../CV...), these containers can accommodate any standard variable types. The hash table keys can even include nulls. 🚀
🎛� Since these containers are essentially strings, they can be crafted into various structures: arrays of arrays, arrays of hash tables, and even hash tables of arrays. 🧩
📊 With PowerBasic's functions, you can create complex data structures like a table with columns and rows—a sample is provided for reference. 📝
🔄 If a container is nested within another, it must be extracted to access or modify its contents, then stored again if any changes are made. 📦
#DataStructures #Programming #PowerBasic #Coding #Tech #SoftwareDevelopment #ComputerScience #Arrays #HashTables #MemoryManagement #Efficiency #Developers 🖥�🔧📈🧮📊🔍📚👨�💻👩�💻🚀🧠💾
'Sarr.bas
'String Array Sample
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\Sarr.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Macro SS = SBdrAddLine stringBuilder,
%TestCount = 10000
%LongString = 100
Sub SampleCode()
Register i As Long
Local stringBuilder As String
Local arr As String
Local value As String
Local a() As String
Local d As Double
Randomize
SS ""
SS "Sub SarrSetMetadata((ByRef container As String, ByVal value As String)"
SS " there is SarrMetadataSpace in each container for metadata"
SS " set metadata"
SarrSetMetadata arr, "metadata ..............................................................."
SS ""
SS "Function SarrGetMetadata(ByRef container As String) As String"
SS " there is SarrMetadataSpace in each container for metadata"
SS " get metadata"
SS "metadata = " + $Dq + SarrGetMetadata(arr) + $Dq
SS ""
SS "SarrAdd(ByRef container As String, ByVal value As String)"
SS " append value and payload : pass null string to ignore payload"
SS " append few values"
For i = 1 To 5
value = "value " + Format$(i)
SarrAdd arr, value
Next i
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "SSub SarrSet(ByRef container As String, ByVal index As Long, ByVal value As String)"
SS " set value at one-based index"
SS " change value at index 5"
SarrSet arr, 5, "last value in array"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrInsert(ByRef container As String, ByVal index As Long, ByVal value As String)"
SS " insert value at one-based index "
SS " insert value at index 2"
SarrInsert arr, 2, "inserted at index 2"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrDelete(ByRef container As String, ByVal index As Long)"
SS " delete value at one-based index"
SS " delete value at index 2"
SarrDelete arr, 2
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrFastDelete(container$, ByVal index As Long)"
SS " fast delete value at one-based index"
SS " ffast on massive array but destroys array order"
SS " traverse back to front to use"
SS " fast delete value at index 1"
SarrFastDelete arr, 1
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrReverse(ByRef container As String)"
SS " reverse array"
SarrReverse arr
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrSort(ByRef container As String)"
SS " non-recursive quick sort"
SS " clear array and add some values"
SarrClear arr
SarrAdd arr, "G"
SarrAdd arr, "C"
SarrAdd arr, "A"
SarrAdd arr, "D"
SarrAdd arr, "B"
SarrAdd arr, "X"
SarrAdd arr, "A"
SarrAdd arr, "C"
SarrAdd arr, "B"
SarrAdd arr, "D"
SarrAdd arr, "C"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS " sort array"
SarrSort arr
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Function SarrSortSearch(ByRef container As String, ByVal value As String, Opt ByVal findFirst As Long, Opt ByVal findLast As Long) As Long"
SS " binary search for value : return index : zero if not found : array must be sorted"
SS "sort search for 'A' = " + Format$(SarrSortSearch(arr, "A"))
SS "sort search for 'B' = " + Format$(SarrSortSearch(arr, "B"))
SS "sort search for 'C' = " + Format$(SarrSortSearch(arr, "C"))
SS "sort search for 'D' = " + Format$(SarrSortSearch(arr, "D"))
SS "sort search for 'E' = " + Format$(SarrSortSearch(arr, "E"))
SS "sort search for 'F' = " + Format$(SarrSortSearch(arr, "F"))
SS "sort search for 'G' = " + Format$(SarrSortSearch(arr, "G"))
SS ""
SS " if IsTrue findFirst then first instance found"
SS " if IsTrue findLast then last instance found"
SS "first instance of 'A' = " + Format$(SarrSortSearch(arr, "A", 1, 0))
SS "last instance of 'A' = " + Format$(SarrSortSearch(arr, "A", 0, 1))
SS "first instance of 'B' = " + Format$(SarrSortSearch(arr, "B", 1, 0))
SS "last instance of 'B' = " + Format$(SarrSortSearch(arr, "B", 0, 1))
SS "first instance of 'C' = " + Format$(SarrSortSearch(arr, "C", 1, 0))
SS "last instance of 'C' = " + Format$(SarrSortSearch(arr, "C", 0, 1))
SS "first instance of 'D' = " + Format$(SarrSortSearch(arr, "D", 1, 0))
SS "last instance of 'D' = " + Format$(SarrSortSearch(arr, "D", 0, 1))
SS ""
SS "Function SarrSortCount(ByRef container As String, ByVal value As String) As Long"
SS " get value's instance count : array must be sorted"
SS "instances of 'A' = " + Format$(SarrSortCount(arr, "A"))
SS "instances of 'B' = " + Format$(SarrSortCount(arr, "B"))
SS "instances of 'C' = " + Format$(SarrSortCount(arr, "C"))
SS ""
SS "Sub SarrSortInsert(ByRef container As String, ByVal value As String, Opt ByVal unique As Long)"
SS " insert value at sort position : added if empty : array must be sorted or empty"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS " sort insert A, B, C"
SarrSortInsert arr, "A"
SarrSortInsert arr, "B"
SarrSortInsert arr, "C"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS " if IsTrue unique then duplicates ignored"
SS " sort insert A, B, C, R, Z"
SarrSortInsert arr, "A", 1
SarrSortInsert arr, "B", 1
SarrSortInsert arr, "C", 1
SarrSortInsert arr, "R", 1
SarrSortInsert arr, "Z", 1
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Sub SarrSortDelete(ByRef container As String, ByVal value As String)"
SS " delete one instance of value if in array maintaining sort order : array must be sorted"
SS " sort delete R"
SarrSortDelete arr, "R"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS ""
SS "Sub SarrPushFirst(ByRef container As String, ByVal value As String)"
SS " insert value at front"
SS "Sub SarrPushLast(ByRef container As String, ByVal value As String)"
SS " append value to end of array"
SS "Function SarrPopFirst(ByRef container As String) As String"
SS " get and remove first value in array"
SS "Function SarrPopLast(ByRef container As String) As String"
SS " get and remove first value in array"
SS ""
SS "Stack: SarrPushLast(), SarrPopLast()"
SS " push A, B, C on stack"
SarrClear arr
SarrPushLast arr, "A"
SarrPushLast arr, "B"
SarrPushLast arr, "C"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS " pop stack"
While SarrCount(arr)
SS "pop = " + $Dq + SarrPopLast(arr) + $Dq
Wend
SS ""
SS "Queue: SarrPushLast(), SarrPopFirst()"
SS " add A, B, C to queue"
SarrClear arr
SarrPushLast arr, "A"
SarrPushLast arr, "B"
SarrPushLast arr, "C"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS " pop queue"
While SarrCount(arr)
SS "pop = " + $Dq + SarrPopFirst(arr) + $Dq
Wend
SS ""
SS ""
SS "SarrSplit(ByRef container As String, ByVal delimitedString As String, ByVal delimiter As String)"
SS " split array on delimited strin"
SS " split array on '1,two,3.33,Four,5.5555' "
SarrSplit arr, "1,two,3.33,Four,5.5555", ","
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS "Function SarrJoin(ByRef container As String, ByVal delimiter As String) As String"
SS " join array to delimited string"
SS "join = " + $Dq + SarrJoin(arr, ",") + $Dq
SS ""
SS ""
SS "Sub SarrToTextFile(ByRef container As String, ByVal file As WString)"
SS " store array as text file"
SS " clear array and add text linex"
SarrClear arr
SarrAdd arr, "This is line one."
SarrAdd arr, "The is line two."
SarrAdd arr, "This is line three."
SarrAdd arr, "This is the last line."
SS " store as text file"
SarrToTextFile arr, "Text.txt"
SS ""
SS "Sub SarrFromTextFile(ByRef container As String, ByVal file As WString)"
SS " load text file"
SarrFromTextFile arr, "Text.txt"
Kill "Text.txt"
SS "--- Display Array ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + SarrGet(arr, i) + $Dq
Next i
SS ""
SS ""
SS "File and Folder List"
SS ""
SS "Sub SarrFolders(ByRef container As String, ByVal specifiedFolder As WString)"
SS " get all folders in specified folder matching mask"
SS " items stored UTF8"
SS " load all folders in 'C:\Windows\IME'"
SarrFolders arr, "C:\Windows\IME"
SS "--- Display Array Converted From UTF8 ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + Utf8ToChr$(SarrGet(arr, i)) + $Dq
Next i
SS ""
SS "Sub SarrFiles(ByRef container As String, ByVal specifiedFolder As WString, ByVal mask As WString)"
SS " get all files in folder matching mask"
SS " items stored UTF8 "
SS " get all files in 'C:\Windows\IME' matching '*.dll' "
SarrFiles arr, "C:\Windows\IME", "*.dll"
SS "--- Display Array Converted From UTF8 ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + Utf8ToChr$(SarrGet(arr, i)) + $Dq
Next i
SS ""
SS "Sub SarrAllFolders(ByRef container As String, ByVal specifiedFolder As WString)"
SS " get all folders in specified folder and sub-folders"
SS " items stored UTF8"
SS " get folders in 'C:\Windows\IME' "
SarrAllFolders arr, "C:\Windows\IME"
SS "--- Display Array Converted From UTF8 ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + Utf8ToChr$(SarrGet(arr, i)) + $Dq
Next i
SS ""
SS "Sub SarrAllFiles(ByRef container As String, ByVal specifiedFolder As WString, ByVal mask As WString)"
SS " get all files in specified folder, and sub-folders, matching mask"
SS " items stored UTF8"
SS " get all files in 'C:\Windows\IME' matching '*.dll' "
SarrAllFiles arr, "C:\Windows\IME", "*.dll"
SS "--- Display Array Converted From UTF8 ---"
For i = 1 To SarrCount(arr)
SS "at "+Format$(i)+" value = " + $Dq + Utf8ToChr$(SarrGet(arr, i)) + $Dq
Next i
ReDim a(1 To %TestCount)
For i = 1 To %TestCount
a(i) = Format$(Rnd(-222222222, 2222222222))
Next i
SS ""
SS ""
SS ""
SS "add "+Format$(%TestCount, "#,")+" values to empty array"
arr = ""
d = Timer
For i = 1 To %TestCount
SarrAdd arr, a(i)
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS "get "+Format$(%TestCount, "#,")+" values"
d = Timer
For i = 1 To %TestCount
If SarrGet(arr, i) <> a(i) Then
? "array fail" : Exit For
End If
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS ""
SS ""
SS "Sub SarrPack(ByRef container As String)"
SS " get rid of dead space"
SS "container size = " + Format$(Len(arr), "#,") + " bytes"
SS "pack container"
d = Timer
SarrPack arr
SS "Time = " + Format$(Timer - d, "000.000")
SS "container size = " + Format$(Len(arr), "#,") + " bytes"
SS ""
SS ""
SS ""
SS "sort array of "+Format$(%TestCount, "#,")+" random values"
d = Timer
SarrSort arr
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS "binary search array for "+Format$(%TestCount, "#,")+" values"
d = Timer
For i = 1 To %TestCount
If SarrSortSearch(arr, a(i)) = 0 Then
? "sort search fail" : Exit For
End If
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS ""
SS "Sub SarrFastDelete(ByRef container As String, ByVal index As Long)"
SS " fast delete value at one-based index "
SS " fast on massive array but destroys array order"
SS " traverse back to front to use"
SS " fast delete "+Format$(SarrCount(arr), "#,")+" values"
For i = SarrCount(arr) To 1 Step -1
SarrFastDelete arr, i
Next i
SS "Time = " + Format$(Timer - d, "000.000")
d = Timer
For i = 1 To %TestCount
a(i) = Repeat$(%LongString, "X")
Next i
SS ""
SS ""
SS "add "+Format$(%TestCount, "#,")+" strings "+Format$(%LongString, "#,")+" characters long"
SarrClear arr
d = Timer
For i = 1 To %TestCount
SarrAdd arr, a(i)
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS "container size = " + Format$(Len(arr), "#,") + " bytes"
SS "pack container"
d = Timer
SarrPack arr
SS "Time = " + Format$(Timer - d, "000.000")
SS "container size = " + Format$(Len(arr), "#,") + " bytes"
SS ""
SS "--- The End ---"
SS ""
Control Set Text gDlg, %TextBox, SBdrGet(stringBuilder)
End Sub
Function PBMain()
Dialog Default Font "consolas", 12, 0, 0
Dialog New 0, "Sample Code", 0, 0, 0, 0, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame, %WS_Ex_AppWindow To gDlg
Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
Control Add Button, gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
Dialog Show Modal gDlg, Call DlgCB
End Function
CallBack Function DlgCB()
Select Case As Long Cb.Msg
Case %WM_InitDialog
WM_InitDialog()
Case %WM_Size
WM_Size()
Case %WM_Command
Select Case As Long Cb.Ctl
Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
End Select
End Select
End Function
Sub WM_InitDialog()
Local clientW, clientH As Long
Desktop Get Client To clientW, clientH
clientW /= 6
clientH /= 5
Dialog Set Loc gDlg, clientW / 2, clientH / 2
Dialog Set Size gDlg, clientW, clientH
End Sub
Sub WM_Size()
Local clientW, clientH As Long
Local marg As Long
Local buttonW, buttonH As Long
Local txtWidth, txtHeight As Long
Local fromLeft, fromBottom As Long
Dialog Get Client gDlg To clientW, clientH
marg = 2 : buttonW = 25 : buttonH = 10
fromLeft = clientW - marg - buttonW
fromBottom = clientH - marg - buttonH
Control Set Size gDlg, %BtnID, buttonW, buttonH
Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
txtWidth = clientW - marg - marg
txtHeight = clientH - marg - buttonH - marg - marg
Control Set Size gDlg, %TextBox, txtWidth, txtHeight
Control Set Loc gDlg, %TextBox, marg, marg
End Sub
#If Not %Def(%SBdr230824)
%SBdr230824 = 1
'String Builder Container
%SBdrBufferMin = 1000
%SBdrBufferMax = 5000000
%SBdrExtra = 20
Sub SBdrAdd(container$, value$)
'append string
Local lenValue&, lenContainer&, usedChars&, unusedChars&, buffer&
lenValue& = Len(value$)
lenContainer& = Len(container$)
If lenValue& Then
If lenContainer& = 0 Then
usedChars& = lenValue&
buffer& = %SBdrBufferMin
container$ = Mkl$(usedChars&) + value$ + Nul$(buffer&)
Else
usedChars& = Cvl(container$)
unusedChars& = lenContainer& - (usedChars&) - 4
If lenValue& > unusedChars& - usedChars& Then
buffer& = usedChars& * %SBdrExtra
If buffer& < %SBdrBufferMin Then buffer& = %SBdrBufferMin
If buffer& > %SBdrBufferMax Then buffer& = %SBdrBufferMax
container$ += Nul$(buffer&)
End If
Poke$ StrPtr(container$) + 4 + usedChars&, value$
Poke Long, StrPtr(container$), usedChars& + lenValue&
End If
End If
End Sub
Sub SBdrAddLine(container$, value$)
'append string + $CrLf
SBdrAdd container$, value$ + $CrLf
End Sub
Function SBdrGet(container$) As String
'get complete string
If Len(container$) > 4 Then Function = Peek$(StrPtr(container$) + 4, Cvl(container$))
End Function
#EndIf '%SBdr230824�
'Sash.bas
'Hash Table Sample
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\Sarr.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Macro SS = SBdrAddLine stringBuilder,
Macro TestCount = 10000
Sub SampleCode()
Register x As Long
Local stringBuilder As String
Local hash As String
Local a() As String
Local d As Double
Randomize
ReDim a(1 To TestCount)
For x = 1 To TestCount
a(x) = Format$(Rnd(-22222222, 222222222))
Next x
SS ""
SS "Sub SashSetMetadata((ByRef container As String, ByVal value As String)"
SS " there is SarrMetadataSpace in each container for metadata"
SS " set metadata"
SashSetMetadata hash, "My hash table ..........................................."
SS ""
SS "Function SashGetMetadata(ByRef container As String) As String"
SS " there is SarrMetadataSpace in each container for metadata"
SS " get metadata"
SS "metadata = " + $Dq + SashGetMetadata(hash) + $Dq
SS ""
SS "Sub SashSet(ByRef container As String, ByVal key As String, ByVal value As String)"
SS " add key and associated value : value replaced if key exist"
SS " add few items"
SashSet hash, "Key A", "Value A"
SashSet hash, "Key B", "Value B"
SashSet hash, "Key C", "Value C"
SashSet hash, "Key D", "Value D"
SashSet hash, "Key E", "Value E"
SS "--- Display Hash Table ---"
For x = 1 To SashCount(hash)
SS "key = " + $Dq + SashGetKey(hash, x) + $Dq + ", value = " + $Dq + SashGetValue(hash, x) + $Dq
Next x
SS ""
SS "change value for key 'Key C' "
SashSet hash, "Key C", "Value for 'Key C' changed."
SS "--- Display Hash Table ---"
For x = 1 To SashCount(hash)
SS "key = " + $Dq + SashGetKey(hash, x) + $Dq + ", value = " + $Dq + SashGetValue(hash, x) + $Dq
Next x
SS ""
SS "Function SashGet(ByRef container As String, ByVal key As String) As String"
SS " get key's associated value"
SS "value for 'Key C' = " + $Dq + SashGet(hash, "Key C") + $Dq
SS "value for 'Key E' = " + $Dq + SashGet(hash, "Key E") + $Dq
SS "value for 'Key ZZZ' = " + $Dq + SashGet(hash, "Key ZZZ") + $Dq
SS ""
SS "Function SashContains(ByRef container As String, ByVal key As String) As Long"
SS " return zero if key not in table"
SS "hash contains 'Key B' = " + Format$(SashContains(hash, "Key B"))
SS "hash contains 'Key D' = " + Format$(SashContains(hash, "Key D"))
SS "hash contains 'Key ZZZ' = " + Format$(SashContains(hash, "Key ZZZ"))
SS ""
SS "Sub SashDelete(ByRef container As String, ByVal key As String)"
SS " delete key and associated value"
SS " delete key 'Key C' "
SashDelete hash, "Key C"
For x = 1 To SashCount(hash)
SS "key = " + $Dq + SashGetKey(hash, x) + $Dq + ", value = " + $Dq + SashGetValue(hash, x) + $Dq
Next x
SS ""
SS ""
SashClear hash
SS "add "+Format$(TestCount, "#,")+" random key/values to hash table"
d = Timer
For x = 1 To TestCount
SashSet hash, a(x), a(x)
Next x
SS "Time = " + Format$(Timer - d, "000.000")
SS "Hash Count = " + Format$(SashCount(hash), "#,") + " ... duplicate keys not allowed "
SS ""
SS "find "+Format$(TestCount, "#,")+" keys "
d = Timer
For x = 1 To TestCount
If IsFalse SashContains(hash, a(x)) Then
? "SashContains() fail" : Exit For
End If
Next x
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS "Sub SashPack(ByRef container As String)"
SS " get rid of dead space"
SS "size of container = " + Format$(Len(hash), "#,")
SS "pack"
d = Timer
SashPack hash
SS "size of container = " + Format$(Len(hash), "#,")
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS "get "+Format$(TestCount, "#,")+" values using key "
d = Timer
For x = 1 To TestCount
If SashGet(hash, a(x)) <> a(x) Then
? "SashGet() fail" : Exit For
End If
Next x
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS ""
Control Set Text gDlg, %TextBox, SBdrGet(stringBuilder)
stringBuilder = ""
End Sub
Function PBMain()
Dialog Default Font "consolas", 12, 0, 0
Dialog New 0, "Sample Code", 0, 0, 0, 0, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame, %WS_Ex_AppWindow To gDlg
Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
Control Add Button, gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
Dialog Show Modal gDlg, Call DlgCB
End Function
CallBack Function DlgCB()
Select Case As Long Cb.Msg
Case %WM_InitDialog
WM_InitDialog()
Case %WM_Size
WM_Size()
Case %WM_Command
Select Case As Long Cb.Ctl
Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
End Select
End Select
End Function
Sub WM_InitDialog()
Local clientW, clientH As Long
Desktop Get Client To clientW, clientH
clientW /= 6
clientH /= 5
Dialog Set Loc gDlg, clientW / 2, clientH / 2
Dialog Set Size gDlg, clientW, clientH
End Sub
Sub WM_Size()
Local clientW, clientH As Long
Local marg As Long
Local buttonW, buttonH As Long
Local txtWidth, txtHeight As Long
Local fromLeft, fromBottom As Long
Dialog Get Client gDlg To clientW, clientH
marg = 2 : buttonW = 25 : buttonH = 10
fromLeft = clientW - marg - buttonW
fromBottom = clientH - marg - buttonH
Control Set Size gDlg, %BtnID, buttonW, buttonH
Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
txtWidth = clientW - marg - marg
txtHeight = clientH - marg - buttonH - marg - marg
Control Set Size gDlg, %TextBox, txtWidth, txtHeight
Control Set Loc gDlg, %TextBox, marg, marg
End Sub
#If Not %Def(%SBdr230824)
%SBdr230824 = 1
'String Builder Container
%SBdrBufferMin = 1000
%SBdrBufferMax = 5000000
%SBdrExtra = 20
Sub SBdrAdd(container$, value$)
'append string
Local lenValue&, lenContainer&, usedChars&, unusedChars&, buffer&
lenValue& = Len(value$)
lenContainer& = Len(container$)
If lenValue& Then
If lenContainer& = 0 Then
usedChars& = lenValue&
buffer& = %SBdrBufferMin
container$ = Mkl$(usedChars&) + value$ + Nul$(buffer&)
Else
usedChars& = Cvl(container$)
unusedChars& = lenContainer& - (usedChars&) - 4
If lenValue& > unusedChars& - usedChars& Then
buffer& = usedChars& * %SBdrExtra
If buffer& < %SBdrBufferMin Then buffer& = %SBdrBufferMin
If buffer& > %SBdrBufferMax Then buffer& = %SBdrBufferMax
container$ += Nul$(buffer&)
End If
Poke$ StrPtr(container$) + 4 + usedChars&, value$
Poke Long, StrPtr(container$), usedChars& + lenValue&
End If
End If
End Sub
Sub SBdrAddLine(container$, value$)
'append string + $CrLf
SBdrAdd container$, value$ + $CrLf
End Sub
Function SBdrGet(container$) As String
'get complete string
If Len(container$) > 4 Then Function = Peek$(StrPtr(container$) + 4, Cvl(container$))
End Function
#EndIf '%SBdr230824�
'Table.bas
'Table Sample
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\Sarr.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Macro SS = SBdrAddLine stringBuilder,
Function CompareColumn1(ByRef RowA As String, ByRef RowB As String) As Long
Local ColA, ColB As String
ColA = UCase$(SarrGet(RowA, 1))
ColB = UCase$(SarrGet(RowB, 1))
Function = Switch&(ColA < ColB, -1, ColA > ColB, 1) 'else match
End Function
Function CompareColumn2(ByRef RowA As String, ByRef RowB As String) As Long
Local ColA, ColB As Long
ColA = Cvl(SarrGet(RowA, 2))
ColB = Cvl(SarrGet(RowB, 2))
Function = Switch&(ColA < ColB, -1, ColA > ColB, 1) 'else match
End Function
Function CompareColumn3(ByRef RowA As String, ByRef RowB As String) As Long
Local ColA, ColB As Ext
ColA = Cve(SarrGet(RowA, 3))
ColB = Cve(SarrGet(RowB, 3))
Function = Switch&(ColA < ColB, -1, ColA > ColB, 1) 'else match
End Function
Sub SampleCode()
Register x As Long
Local stringBuilder As String
Local Table, TableRow As String
Local c2, c3 As Long
'column 1 = String
'column 2 = Long
'column 3 = Extended
Randomize
SS ""
SS "add rows"
For x = 5 To 1 Step -1
SarrReDim TableRow, 3
SarrSet TableRow, 1, "Column" + Format$(x)
SarrSet TableRow, 2, Mkl$(Rnd(-1000, 1000))
SarrSet TableRow, 3, Mke$(Rnd(-1000, 1000) / 3)
SarrAdd Table, TableRow
Next x
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "sort on column 1"
SS " set compare callback"
SarrComparison Table, CodePtr(CompareColumn1)
SarrSort Table
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "sort on column 2"
SS " set compare callback"
SarrComparison Table, CodePtr(CompareColumn2)
SarrSort Table
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "sort on column 3"
SS " set compare callback"
SarrComparison Table, CodePtr(CompareColumn3)
SarrSort Table
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "set column 2 = 1111 where column 1 = 'Column3' "
SS " array must be sorted on column searched"
SS " change compare callback"
SarrComparison Table, CodePtr(CompareColumn1)
SS " sort"
SarrSort Table
SarrReDim TableRow, 3
SarrSet TableRow, 1, "Column3"
x = SarrSortSearch(Table, TableRow)
If x Then
TableRow = SarrGet(Table, x)
SarrSet TableRow, 2, Mkl$(1111)
SarrSet Table, x, TableRow
End If
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "SarrSortInsert() "
SS " may be used to insert new row at sort position, based on current callback"
SarrReDim TableRow, 3
SarrSet TableRow, 1, "Column333"
SarrSet TableRow, 2, Mkl$(Rnd(-1000, 1000))
SarrSet TableRow, 3, Mke$(Rnd(-1000, 1000) / 3)
SarrSortInsert Table, TableRow
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "SarrSortDelete() "
SS " may be used to delete item maintaining sort order, based on current callback"
SS " delete where column 1 = 'Column333' "
SarrReDim TableRow, 3
SarrSet TableRow, 1, "Column333"
SarrSortDelete Table, TableRow
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS "you can move through table using index to Get/Set values"
SS " multiply column 2 by 100"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
c2 = Cvl(SarrGet(TableRow, 2))
c2 *= 100
SarrSet TableRow, 2, Mkl$(c2)
SarrSet Table, x, TableRow
Next x
SS "--- Display Table ---"
For x = 1 To SarrCount(Table)
TableRow = SarrGet(Table, x)
SS SarrGet(TableRow, 1) +", "+ Format$(Cvl(SarrGet(TableRow, 2))) +", "+ Format$(Cve(SarrGet(TableRow, 3)))
Next x
SS ""
SS ""
Control Set Text gDlg, %TextBox, SBdrGet(stringBuilder)
stringBuilder = ""
End Sub
Function PBMain()
Dialog Default Font "consolas", 12, 0, 0
Dialog New 0, "Sample Code", 0, 0, 0, 0, %WS_Caption Or %WS_ClipSiblings Or %WS_MinimizeBox Or %WS_SysMenu Or %WS_ThickFrame, %WS_Ex_AppWindow To gDlg
Control Add TextBox, gDlg, %TextBox, "", 0, 0, 0, 0, %ES_AutoHScroll Or %ES_AutoVScroll Or %ES_MultiLine Or %ES_NoHideSel Or %ES_WantReturn Or %WS_HScroll Or %WS_VScroll Or %WS_Border, 0
Control Add Button, gDlg, %BtnID, "Run", 275, 220, 60, 15, %BS_Flat, 0
Dialog Show Modal gDlg, Call DlgCB
End Function
CallBack Function DlgCB()
Select Case As Long Cb.Msg
Case %WM_InitDialog
WM_InitDialog()
Case %WM_Size
WM_Size()
Case %WM_Command
Select Case As Long Cb.Ctl
Case %BtnID : If Cb.CtlMsg = %BN_Clicked Then SampleCode()
End Select
End Select
End Function
Sub WM_InitDialog()
Local clientW, clientH As Long
Desktop Get Client To clientW, clientH
clientW /= 6
clientH /= 5
Dialog Set Loc gDlg, clientW / 2, clientH / 2
Dialog Set Size gDlg, clientW, clientH
End Sub
Sub WM_Size()
Local clientW, clientH As Long
Local marg As Long
Local buttonW, buttonH As Long
Local txtWidth, txtHeight As Long
Local fromLeft, fromBottom As Long
Dialog Get Client gDlg To clientW, clientH
marg = 2 : buttonW = 25 : buttonH = 10
fromLeft = clientW - marg - buttonW
fromBottom = clientH - marg - buttonH
Control Set Size gDlg, %BtnID, buttonW, buttonH
Control Set Loc gDlg, %BtnID, fromLeft, fromBottom
txtWidth = clientW - marg - marg
txtHeight = clientH - marg - buttonH - marg - marg
Control Set Size gDlg, %TextBox, txtWidth, txtHeight
Control Set Loc gDlg, %TextBox, marg, marg
End Sub
#If Not %Def(%SBdr230824)
%SBdr230824 = 1
'String Builder Container
%SBdrBufferMin = 1000
%SBdrBufferMax = 5000000
%SBdrExtra = 20
Sub SBdrAdd(container$, value$)
'append string
Local lenValue&, lenContainer&, usedChars&, unusedChars&, buffer&
lenValue& = Len(value$)
lenContainer& = Len(container$)
If lenValue& Then
If lenContainer& = 0 Then
usedChars& = lenValue&
buffer& = %SBdrBufferMin
container$ = Mkl$(usedChars&) + value$ + Nul$(buffer&)
Else
usedChars& = Cvl(container$)
unusedChars& = lenContainer& - (usedChars&) - 4
If lenValue& > unusedChars& - usedChars& Then
buffer& = usedChars& * %SBdrExtra
If buffer& < %SBdrBufferMin Then buffer& = %SBdrBufferMin
If buffer& > %SBdrBufferMax Then buffer& = %SBdrBufferMax
container$ += Nul$(buffer&)
End If
Poke$ StrPtr(container$) + 4 + usedChars&, value$
Poke Long, StrPtr(container$), usedChars& + lenValue&
End If
End If
End Sub
Sub SBdrAddLine(container$, value$)
'append string + $CrLf
SBdrAdd container$, value$ + $CrLf
End Sub
Function SBdrGet(container$) As String
'get complete string
If Len(container$) > 4 Then Function = Peek$(StrPtr(container$) + 4, Cvl(container$))
End Function
#EndIf '%SBdr230824�
'Sarr.inc
'Public domain, use at own risk. SDurham
'In-String: String Array, String Hash Table, Unique Ordered String Set
'In-String String Array
'SarrComparison() set or change compare callback : default case sensitive
'SarrSetMetadata() set metadata : each container can have a metadata string
'SarrGetMetadata() get metadata
'SarrCount() get item count
'SarrClear() empty container
'SarrReDim() only needed to set a specified number of items : space management automatic
'SarrPack() get rid of dead space
'SarrAdd() append value
'SarrGet() get value at one-based index
'SarrSet() set value at one-based index
'SarrInsert() insert value at one-based index
'SarrDelete() delete value at one-based index
'SarrFastDelete() fast on massive array but destroys array order
'SarrSort() quick sort
'SarrSortSearch() binary search : optionally first or last
'SarrSortInsert() binary insert : optionally ignore duplicates
'SarrSortDelete() binary search and delete if found
'SarrSortCount() get item count in sorted array
'SarrReverse() reverse array
'SarrPushFirst() insert value at front
'SarrPushLast() append value to end
'SarrPopFirst() get and remove first value
'SarrPopLast() get and remove last value
'SarrSplit() split array on delimited string
'SarrJoin() join array to delimited string
'SarrToTextFile() store array as text file
'SarrFromTextFile() load text file
'SarrFolders() get all folders in specified folder
'SarrFiles() get all files in folder matching mask
'SarrAllFolders() get all folders in specified folder and sub-folders
'SarrAllFiles() get all files in specified folder, and sub-folders, matching mask
'In-String Hash Table
'SashComparison() set compare callback : default case sensitive
'SashSetMetadata() set metadata : each container can have a metadata string
'SashGetMetadata() get metadata
'SashCount() get item count
'SashClear() empty container
'SashPack() get rid of dead space
'SashSet() add key and associated value : value replaced if key exist
'SashGet() get key's associated value
'SashContains() return zero if key not in table
'SashDelete() delete key and associated value
'SashGetKey() get key at one-based index
'SashGetValue() get value at one-based index
'Unique Ordered String Set
'SSetSetMetadata()set metadata : each container can have a metadata string
'SSetGetMetadata() get metadata
'SSetCount() get Set count
'SSetClear() empty Set
'SSetPack() get rid of dead space
'SSetGet() get value in Set at one-based index
'SSetAdd() add value to Set : duplicates ignored
'SSetSubtract() remove value from set
'SSetContains() true/false if value in Set
'SSetAddSet() add one Set to other : duplicates ignored
'SSetSubtractSet() subtract one Set from other
'SSetContainsSet() true/false if one Set is a subset of other
'SSetContained() get number of items in one Set that are in other
'SSetNotContained() get number of items in one Set that aren't in other
'SSetEqual() true if Sets equal
'SSetSum() get unique Set of values in two other Sets
'SSetDifference() get the difference between two Sets
'SSetCommon() get Set of values common to two Sets
'SSetUncommon() get Set of values uncommon to two Sets
'SSetCommonCount() get number of items common to two Sets
'SSetUncommonCount() get number of items uncommon to two Sets
'In-String String Array Performance
'add 10,000 values to empty array = 0.000 seconds
'get 10,000 values = 0.016 seconds
'binary search array for 10,000 values = 0.031 seconds
'add 10,000 strings 500 characters long = 0.141 seconds
'add 10,000 strings 1,000 characters long = 0.486 seconds
'fast delete 10,000 values = 0.031 seconds
'add 100,000 values to empty array = 0.047 seconds
'get 100,000 values = 0.015 seconds
'sort array of 100,000 random values = 0.490 seconds
'binary search array for 100,000 values = 0.352 seconds
'add 100,000 strings 100 characters long = 0.360 seconds
'add 100,000 strings 500 characters long = 9.780 seconds
'fast delete 100,000 values = 0.409 seconds
'add 1,000,000 values to empty array = 1.489
'get 1,000,000 values = 0.189
'sort array of 1,000,000 random values = 6.442 seconds
'binary search array for 1,000,000 values = 5.315 seconds
'add 1,000,000 strings 100 characters long = 50.119 seconds
'fast delete 1,000,000 values = 5.470 seconds
'add 100 strings 1,000,000 characters long = 1.883 seconds
'In-String Hash Table Performance
'add 10,000 random key/values to hash table = 0.267 seconds
'find 10,000 keys = 0.078 seconds
'get 10,000 values using key = 0.078 seconds
'add 20,000 random key/values to hash table = 0.723 seconds
'find 20,000 keys = 0.159
'get 20,000 values using key = 0.174 seconds
'add 30,000 random key/values to hash table = 1.271 seconds
'find 30,000 keys = 0.251 seconds
'get 30,000 values using key = 0.266 seconds
'add 40,000 random key/values to hash table = 1.888 seconds
'find 40,000 keys = 0.345 seconds
'get 40,000 values using key = 0.377 seconds
'add 50,000 random key/values to hash table = 2.676 seconds
'find 50,000 keys = 0.447 seconds
'get 50,000 values using key = 0.475 seconds
'add 60,000 random key/values to hash table = 3.531 seconds
'find 60,000 keys = 0.615 seconds
'get 60,000 values using key = 0.612
'add 70,000 random key/values to hash table = 4.673 seconds
'find 70,000 keys = 0.659 seconds
'get 70,000 values using key = 0.675 seconds
'add 80,000 random key/values to hash table = 5.690 seconds
'find 80,000 keys = 0.786 seconds
'get 80,000 values using key = 0.800
'add 90,000 random key/values to hash table = 6.893 seconds
'find 90,000 keys = 0.899 seconds
'get 90,000 values using key = 0.942 seconds
'add 100,000 random key/values to hash table = 8.224 seconds
'find 100,000 keys = 1.020 seconds
'get 100,000 values using key = 0.991 seconds
#IF NOT %DEF(%Sarr230829)
%Sarr230829 = 1
'InString String Array
'Container protected with hash tag.
DECLARE FUNCTION SarrCompare(BYREF a AS STRING, BYREF b AS STRING) AS LONG
'compare callback template
'a < b : return < 0
'a = b : return = 0
'a > b : return > 0
MACRO SarrTag = 1783209428
MACRO SarrMetadataSpace = 20
MACRO SarrHeaderSize = (5 * 4) + SarrMetadataSpace + 1
MACRO SarrRecordSize = 8
MACRO SarrRecordBufferMax = 10000
MACRO SarrRecordBufferMin = 4
MACRO SarrCharacterBufferMax = 40000
MACRO SarrCharacterBufferMin = 40
MACRO SarrRecordMultiplier = 2
MACRO SarrCharacterMultiplier = 5
' 12345678901234567890123456789012345678901234567890 string position
' 1234567890123456789012345678901234567 position in string space
' :header:array:used string space:free string space:
' 56789012345678901234567890123456789012345678901234 string pointer position
' : left side : right side :
' : metadata : character space :
TYPE SarrHeaderT
tag AS LONG
count AS LONG
max AS LONG
used AS LONG
compare AS LONG
metadata AS STRING * SarrMetadataSpace
END TYPE
TYPE SarrRecordT
charSpaceOffset AS LONG
bytes AS LONG
END TYPE
#IF NOT %DEF(%Unicode)
%Unicode = 1
#ENDIF '%Unicode
'-------------------------------------
'-------------------------------------
' String Array
'-------------------------------------
'-------------------------------------
SUB SarrComparison(BYREF container AS STRING, BYVAL compareCB AS LONG)
'change compare callback which changes sort and binary search order
'default = case sensitive : CodePtr(SarrCompare)
'CodePtr(SarrCompare) = case sensitive
'CodePtr(SarrCompareUCase) = ignore case
'CodePtr(procedure) for custom comparison
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
IF compareCB THEN SarrSetCompare container, compareCB
END SUB
'-------------------------------------
SUB SarrSetMetadata((BYREF container AS STRING, BYVAL value AS STRING)
LOCAL p AS SarrHeaderT PTR
'there is SarrMetadataSpace in each container for metadata
'set metadata
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
p = STRPTR(container)
@p.metadata = value
END SUB
'-------------------------------------
FUNCTION SarrGetMetadata(BYREF container AS STRING) AS STRING
LOCAL p AS SarrHeaderT PTR
'there is SarrMetadataSpace in each container for metadata
'get metadata
IF CVL(container) <> SarrTag THEN EXIT FUNCTION
p = STRPTR(container)
FUNCTION = TRIM$(@p.metadata)
END FUNCTION
'-------------------------------------
FUNCTION SarrCount(BYREF container AS STRING) AS LONG
'get item count
IF LEN(container) AND CVL(container) = SarrTag THEN FUNCTION = SarrGetCount(container)
END FUNCTION
'-------------------------------------
SUB SarrClear(BYREF container AS STRING)
'empty container
LOCAL compareCB AS LONG
LOCAL metadata AS STRING
IF LEN(container) THEN
IF CVL(container) <> SarrTag THEN EXIT SUB
compareCB = SarrGetCompare(container)
metadata = SarrGetMetadata(container)
container = ""
SarrInitialize(container)
SarrSetCompare container, compareCB
SarrSetMetadata container, metadata
END IF
END SUB
'-------------------------------------
SUB SarrReDim(BYREF container AS STRING, BYVAL items AS LONG)
'redimension array : data preserved
'doesn't need be called, array is buffered
'use to set a specified number of items
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
IF items >= 0 THEN
WHILE SarrGetCount(container) < items
SarrPushLast container, ""
WEND
WHILE SarrGetCount(container) > items
SarrPopLast(container)
WEND
END IF
END SUB
'-------------------------------------
SUB SarrPack(BYREF container AS STRING)
'get rid of dead space
REGISTER i AS LONG
LOCAL items, usedCharacters AS LONG
LOCAL leftSide, rightSide AS STRING
LOCAL a() AS STRING
IF CVL(container) <> SarrTag THEN EXIT SUB
items = SarrGetCount(container)
usedCharacters = SarrGetUsed(container)
IF items = 0 THEN
SarrClear(container)
ELSE
REDIM a(1 TO items)
FOR i = 1 TO items
a(i) = SarrGet(container, i)
NEXT x
SarrClear container
FOR i = 1 TO items
SarrAdd container, a(i)
NEXT x
ERASE a()
leftSide = LEFT$(container, SarrHeaderSize + (items * SarrRecordSize))
rightSide = RIGHT$(container, SarrRight(container))
rightSide = LEFT$(rightSide, usedCharacters)
container = leftSide + rightSide
SarrSetMax container, items
END IF
END SUB
'-------------------------------------
SUB SarrAdd(BYREF container AS STRING, BYVAL value AS STRING)
'append value
LOCAL bytes, charSpaceOffset, mem AS LONG
LOCAL rec() AS SarrRecordT
'get needed character space
bytes = LEN(value)
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
'add more records if needed
IF SarrGetCount(container) = SarrGetMax(container) THEN SarrMoreRecords(container)
'add more character space if needed
IF SarrUnusedCharacters(container) < bytes THEN SarrMoreCharacters(container, bytes)
'store value
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = STRPTR(container) + SarrLeft(container) + charSpaceOffset
MEMORY COPY STRPTR(value), mem, bytes
SarrSetCount container, SarrGetCount(container) + 1
REDIM rec(1 TO SarrGetMax(container)) AT SarrArrMem(container)
rec(SarrGetCount(container)).charSpaceOffset = charSpaceOffset
rec(SarrGetCount(container)).bytes = bytes
END SUB
'-------------------------------------
FUNCTION SarrGet(BYREF container AS STRING, BYVAL index AS LONG) AS STRING
'get value at one-based index
LOCAL mem, charSpaceOffset, bytes AS LONG
LOCAL rec() AS SarrRecordT
IF CVL(container) <> SarrTag THEN EXIT FUNCTION
IF index < 1 OR index > SarrGetCount(container) THEN EXIT FUNCTION
REDIM rec(1 TO SarrGetMax(container)) AT SarrArrMem(container)
charSpaceOffset = rec(index).charSpaceOffset
bytes = rec(index).bytes
mem = STRPTR(container) + SarrLeft(container) + charSpaceOffset
FUNCTION = PEEK$(mem, bytes)
END FUNCTION
'-------------------------------------
SUB SarrSet(BYREF container AS STRING, BYVAL index AS LONG, BYVAL value AS STRING)
'set value at one-based index
LOCAL mem, charSpaceOffset, bytes AS LONG
LOCAL rec() AS SarrRecordT
IF CVL(container) <> SarrTag THEN EXIT SUB
IF index < 1 OR index > SarrGetCount(container) THEN EXIT SUB
'get needed character space
bytes = LEN(value)
'replace string
REDIM rec(1 TO SarrGetMax(container)) AT SarrArrMem(container)
IF bytes > rec(index).bytes THEN
'abandon old string space
'add more character space if needed
IF SarrUnusedCharacters(container) < bytes THEN SarrMoreCharacters(container, bytes)
'store value in new space
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = STRPTR(container) + SarrLeft(container) + charSpaceOffset
MEMORY COPY STRPTR(value), mem, bytes
REDIM rec(1 TO SarrGetMax(container)) AT SarrArrMem(container)
rec(index).charSpaceOffset = charSpaceOffset
rec(index).bytes = bytes
ELSE
'we have enough space
rec(index).bytes = bytes
charSpaceOffset = rec(index).charSpaceOffset
mem = STRPTR(container) + SarrLeft(container) + charSpaceOffset
MEMORY COPY STRPTR(value), mem, bytes
END IF
END SUB
'-------------------------------------
SUB SarrInsert(BYREF container AS STRING, BYVAL index AS LONG, BYVAL value AS STRING)
'insert value at one-based index
LOCAL charSpaceOffset, mem, bytes AS LONG
LOCAL qud() AS QUAD
LOCAL rec() AS SarrRecordT
IF CVL(container) <> SarrTag THEN EXIT SUB
IF index < 1 OR index > SarrGetCount(container) THEN EXIT SUB
'get needed character space
bytes = LEN(value)
'add more records if needed : we need two more
IF SarrGetMax(container) = SarrGetCount(container) THEN SarrMoreRecords(container)
'add more character space if needed
IF SarrUnusedCharacters(container) < bytes THEN SarrMoreCharacters(container, bytes)
'insert record space
REDIM qud(1 TO SarrGetMax(container)) AT SarrArrMem(container)
ARRAY INSERT qud(index), 0
SarrSetCount container, SarrGetCount(container) + 1
'store value
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = STRPTR(container) + SarrLeft(container) + charSpaceOffset
MEMORY COPY STRPTR(value), mem, bytes
REDIM rec(1 TO SarrGetMax(container)) AT SarrArrMem(container)
rec(index).charSpaceOffset = charSpaceOffset
rec(index).bytes = bytes
END SUB
'-------------------------------------
SUB SarrDelete(BYREF container AS STRING, BYVAL index AS LONG)
'delete value at one-based index
LOCAL qud() AS QUAD
IF CVL(container) <> SarrTag THEN EXIT SUB
IF index < 1 OR index > SarrGetCount(container) THEN EXIT SUB
REDIM qud(1 TO SarrGetCount(container)) AT SarrArrMem(container)
ARRAY DELETE qud(index)
SarrSetCount container, SarrGetCount(container) - 1
END SUB
'-------------------------------------
SUB SarrFastDelete(BYREF container AS STRING, BYVAL index AS LONG)
'fast delete value at one-based index
'fast on massive array but destroys array order
'traverse back to front to use
LOCAL qud() AS QUAD
IF CVL(container) <> SarrTag THEN EXIT SUB
IF index < 1 OR index > SarrGetCount(container) THEN EXIT SUB
REDIM qud(1 TO SarrGetCount(container)) AT SarrArrMem(container)
IF index < SarrGetCount(container) THEN SWAP qud(index), qud(SarrGetCount(container))
SarrSetCount container, SarrGetCount(container) - 1
END SUB
'-------------------------------------
'-------------------------------------
' Sort Order
'-------------------------------------
'-------------------------------------
SUB SarrSort(BYREF container AS STRING)
'non-recursive quick sort
REGISTER i AS LONG
REGISTER j AS LONG
LOCAL k, leftIndex, rightIndex, counter, compareCB, compare AS LONG
LOCAL value AS STRING
LOCAL qud() AS QUAD
IF CVL(container) <> SarrTag THEN EXIT SUB
compareCB = SarrGetCompare(container)
leftIndex = 1
rightIndex = SarrGetCount(container)
IF rightIndex > 1 THEN
REDIM qud(1 TO rightIndex) AT SarrArrMem(container)
counter = 1
!PUSH leftIndex
!PUSH rightIndex
WHILE counter
DECR counter
!POP rightIndex
!POP leftIndex
i = leftIndex
j = rightIndex
k = i + j
SHIFT RIGHT k, 1
value = SarrGet(container, k)
WHILE i <= j
CALL DWORD compareCB USING SarrCompare(SarrGet(container, i), value) TO compare
WHILE compare < 0
INCR i
CALL DWORD compareCB USING SarrCompare(SarrGet(container, i), value) TO compare
WEND
CALL DWORD compareCB USING SarrCompare(SarrGet(container, j), value) TO compare
WHILE compare > 0
DECR j
CALL DWORD compareCB USING SarrCompare(SarrGet(container, j), value) TO compare
WEND
IF i <= j THEN
SWAP qud(i), qud(j) : INCR i : DECR j
END IF
WEND
IF leftIndex < j THEN
!PUSH leftIndex
!PUSH j
INCR counter
END IF
IF i < rightIndex THEN
!PUSH i
!PUSH rightIndex
INCR counter
END IF
WEND
END IF
END SUB
'-------------------------------------
FUNCTION SarrSortSearch(BYREF container AS STRING, BYVAL value AS STRING, OPT BYVAL findFirst AS LONG, OPT BYVAL findLast AS LONG) AS LONG
'binary search for value : return index : zero if not found : array must be sorted
'if IsTrue findFirst then first instance found
'if IsTrue findLast then last instance found
REGISTER i AS LONG
REGISTER j AS LONG
LOCAL bot, top, result, compareCB, compare AS LONG
IF CVL(container) <> SarrTag THEN EXIT FUNCTION
compareCB = SarrGetCompare(container)
bot = 1
top = SarrGetCount(container)
IF top THEN
WHILE top >= bot
i = bot + top
SHIFT RIGHT i, 1 'divide by 2
CALL DWORD compareCB USING SarrCompare(value, SarrGet(container, i)) TO compare
IF compare > 0 THEN
bot = i + 1
ELSEIF compare < 0 THEN
top = i - 1
ELSE
result = i
IF ISTRUE findFirst THEN
FOR j = i - 1 TO 1 STEP -1
CALL DWORD compareCB USING SarrCompare(value, SarrGet(container, j)) TO compare
IF compare = 0 THEN
result = j
ELSE
EXIT FOR
END IF
NEXT j
ELSEIF ISTRUE findLast THEN
FOR j = i + 1 TO SarrGetCount(container)
CALL DWORD compareCB USING SarrCompare(value, SarrGet(container, j)) TO compare
IF compare = 0 THEN
result = j
ELSE
EXIT FOR
END IF
NEXT j
END IF
FUNCTION = result
EXIT FUNCTION
END IF
WEND
END IF
END FUNCTION
'-------------------------------------
SUB SarrSortInsert(BYREF container AS STRING, BYVAL value AS STRING, OPT BYVAL unique AS LONG)
'insert value at sort position : added if empty : array must be sorted or empty
'if IsTrue unique then duplicates ignored
REGISTER i AS LONG
LOCAL bot, top, compareCB, compare AS LONG
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
compareCB = SarrGetCompare(container)
bot = 1
top = SarrGetCount(container)
IF top THEN
WHILE top >= bot
i = bot + top
SHIFT RIGHT i, 1 'divide by 2
CALL DWORD compareCB USING SarrCompare(value, SarrGet(container, i)) TO compare
IF compare > 0 THEN
bot = i + 1
ELSEIF compare < 0 THEN
top = i - 1
ELSE
IF ISFALSE unique THEN SarrInsert(container, i, value)
EXIT SUB
END IF
WEND
IF compare < 0 THEN
SarrInsert(container, i, value)
ELSEIF i < SarrGetCount(container) THEN
SarrInsert(container, i + 1, value)
ELSE
SarrAdd(container, value)
END IF
ELSE
SarrAdd(container, value)
END IF
END SUB
'-------------------------------------
SUB SarrSortDelete(BYREF container AS STRING, BYVAL value AS STRING)
'delete one instance of value if in array maintaining sort order : array must be sorted
LOCAL x AS LONG
x = SarrSortSearch(container, value)
IF x THEN SarrDelete container, x
END SUB
'-------------------------------------
FUNCTION SarrSortCount(BYREF container AS STRING, BYVAL value AS STRING) AS LONG
'get value's instance count : array must be sorted
LOCAL first, last AS LONG
first = SarrSortSearch(container, value, 1, 0)
last = SarrSortSearch(container, value, 0, 1)
FUNCTION = last - first + 1
END FUNCTION
'-------------------------------------
SUB SarrReverse(BYREF container AS STRING)
'reverse array
REGISTER i AS LONG
REGISTER j AS LONG
LOCAL qud() AS QUAD
IF CVL(container) <> SarrTag THEN EXIT SUB
i = 1
j = SarrGetCount(container)
IF j > 1 THEN
REDIM qud(1 TO SarrGetMax(container)) AT SarrArrMem(container)
WHILE i < j
SWAP qud(i), qud(j)
INCR i
DECR j
WEND
END IF
END SUB
'-------------------------------------
'-------------------------------------
' Stack and Queue
'-------------------------------------
'-------------------------------------
SUB SarrPushFirst(BYREF container AS STRING, BYVAL value AS STRING)
'insert value at front
IF SarrCount(container) THEN SarrInsert(container, 1, value) ELSE SarrAdd(container, value)
END SUB
'-------------------------------------
SUB SarrPushLast(BYREF container AS STRING, BYVAL value AS STRING)
'append value to end of array
SarrAdd container, value
END SUB
'-------------------------------------
FUNCTION SarrPopFirst(BYREF container AS STRING) AS STRING
'get and remove first value in array
IF SarrCount(container) THEN
FUNCTION = SarrGet(container, 1)
SarrDelete container, 1
END IF
END FUNCTION
'-------------------------------------
FUNCTION SarrPopLast(BYREF container AS STRING) AS STRING
'get and remove first value in array
LOCAL items AS LONG
items = SarrCount(container)
IF items THEN
FUNCTION = SarrGet(container, items)
SarrDelete container, items
END IF
END FUNCTION
'-------------------------------------
'-------------------------------------
' Split and Join
'-------------------------------------
'-------------------------------------
SUB SarrSplit(BYREF container AS STRING, BYVAL delimitedString AS STRING, BYVAL delimiter AS STRING)
'split array on delimited string
REGISTER i AS LONG
LOCAL items AS LONG
LOCAL a() AS STRING
IF CVL(container) <> SarrTag THEN EXIT SUB
SarrClear container
IF LEN(delimitedString) THEN
items = PARSECOUNT(delimitedString, delimiter)
IF items THEN
REDIM a(1 TO items)
PARSE delimitedString, a(), delimiter
FOR i = 1 TO items
SarrAdd container, a(i)
NEXT x
END IF
END IF
END SUB
'-------------------------------------
FUNCTION SarrJoin(BYREF container AS STRING, BYVAL delimiter AS STRING) AS STRING
'join array to delimited string
REGISTER i AS LONG
LOCAL items AS LONG
LOCAL a() AS WSTRING
IF CVL(container) <> SarrTag THEN EXIT FUNCTION
items = SarrCount(container)
IF items THEN
REDIM a(1 TO items)
FOR i = 1 TO items
a(i) = UTF8TOCHR$(SarrGet(container, i))
NEXT x
FUNCTION = JOIN$(a(), delimiter)
END IF
END FUNCTION
'-------------------------------------
'-------------------------------------
' To/From Text File
'-------------------------------------
'-------------------------------------
SUB SarrToTextFile(BYREF container AS STRING, BYVAL file AS WSTRING)
'store array as text file
StrToFile file, TRIM$(SarrJoin(container, $CRLF), $CRLF) + $CRLF
END SUB
'-------------------------------------
SUB SarrFromTextFile(BYREF container AS STRING, BYVAL file AS WSTRING)
'load text file
SarrSplit container, TRIM$(StrFromFile(file), $CRLF), $CRLF
END SUB
'-------------------------------------
'-------------------------------------
' File and Folder List
'-------------------------------------
'-------------------------------------
SUB SarrFolders(BYREF container AS STRING, BYVAL specifiedFolder AS WSTRING)
'get all folders in specified folder
'items stored UTF8
LOCAL folder, folderMask, specifiedPath AS WSTRING
LOCAL DrD AS DIRDATA
SarrClear container
IF ISFALSE ISFOLDER(specifiedFolder) THEN EXIT SUB
specifiedPath = RTRIM$(specifiedFolder, "\") + "\"
folderMask = specifiedPath
folder = DIR$(folderMask, ONLY %SUBDIR TO DrD)
WHILE LEN(folder)
SarrAdd container, CHRTOUTF8$(specifiedPath + folder)
folder = DIR$
WEND
END SUB
'-------------------------------------
SUB SarrFiles(BYREF container AS STRING, BYVAL specifiedFolder AS WSTRING, BYVAL mask AS WSTRING)
'get all files in folder matching mask
'items stored UTF8
LOCAL file, fileMask AS WSTRING
SarrClear container
IF ISFALSE ISFOLDER(specifiedFolder) THEN EXIT SUB
specifiedFolder = RTRIM$(specifiedFolder, "\") + "\"
fileMask = specifiedFolder + mask
file = DIR$(fileMask)
WHILE LEN(file)
SarrAdd container, CHRTOUTF8$(specifiedFolder + file)
file = DIR$
WEND
END SUB
'-------------------------------------
SUB SarrAllFolders(BYREF container AS STRING, BYVAL specifiedFolder AS WSTRING)
'get all folders in specified folder and sub-folders
'items stored UTF8
LOCAL foldersArr, subFoldersArr AS STRING
LOCAL currentFolder AS WSTRING
SarrClear container
IF ISFALSE ISFOLDER(specifiedFolder) THEN EXIT SUB
SarrPushLast foldersArr, specifiedFolder
WHILE SarrCount(foldersArr)
currentFolder = SarrPopLast(foldersArr)
SarrAdd container, currentFolder
SarrFolders subFoldersArr, currentFolder
WHILE SarrCount(subFoldersArr)
SarrPushLast foldersArr, SarrPopLast(subFoldersArr)
WEND
WEND
END SUB
'-------------------------------------
SUB SarrAllFiles(BYREF container AS STRING, BYVAL specifiedFolder AS WSTRING, BYVAL mask AS WSTRING)
'get all files in specified folder, and sub-folders, matching mask
'items stored UTF8
LOCAL allFoldersArr, folderFilesArr AS STRING
SarrClear container
IF ISFALSE ISFOLDER(specifiedFolder) THEN EXIT SUB
SarrAllFolders allFoldersArr, specifiedFolder
WHILE SarrCount(allFoldersArr)
SarrFiles folderFilesArr, SarrPopLast(allFoldersArr), mask
WHILE SarrCount(folderFilesArr)
SarrAdd container, SarrPopLast(folderFilesArr)
WEND
WEND
END SUB
'-------------------------------------
'-------------------------------------
' PRIVATE
'-------------------------------------
'-------------------------------------
SUB SarrSetTag(BYREF container AS STRING, BYVAL value AS LONG) PRIVATE
'set container header tag parameter
IF LEN(container) THEN POKE LONG, STRPTR(container), value
END SUB
'-------------------------------------
FUNCTION SarrGetCount(BYREF container AS STRING) PRIVATE AS LONG
'get container header count parameter
IF LEN(container) THEN FUNCTION = PEEK(LONG, STRPTR(container) + 4)
END FUNCTION
'-------------------------------------
SUB SarrSetCount(BYREF container AS STRING, BYVAL value AS LONG) PRIVATE
'set container header count parameter
IF LEN(container) THEN POKE LONG, STRPTR(container) + 4, value
END SUB
'-------------------------------------
FUNCTION SarrGetMax(BYREF container AS STRING) PRIVATE AS LONG
'get container header max parameter
IF LEN(container) THEN FUNCTION = PEEK(LONG, STRPTR(container) + 8)
END FUNCTION
'-------------------------------------
SUB SarrSetMax(BYREF container AS STRING, BYVAL value AS LONG) PRIVATE
'set container header max parameter
IF LEN(container) THEN POKE LONG, STRPTR(container) + 8, value
END SUB
'-------------------------------------
FUNCTION SarrGetUsed(BYREF container AS STRING) PRIVATE AS LONG
'get container header used parameter
IF LEN(container) THEN FUNCTION = PEEK(LONG, STRPTR(container) + 12)
END FUNCTION
'-------------------------------------
SUB SarrSetUsed(BYREF container AS STRING, BYVAL value AS LONG) PRIVATE
'set container header used parameter
IF LEN(container) THEN POKE LONG, STRPTR(container) + 12, value
END SUB
'-------------------------------------
FUNCTION SarrGetCompare(BYREF container AS STRING) PRIVATE AS LONG
'get container header compare parameter
IF LEN(container) THEN FUNCTION = PEEK(LONG, STRPTR(container) + 16)
END FUNCTION
'-------------------------------------
SUB SarrSetCompare(BYREF container AS STRING, BYVAL value AS LONG) PRIVATE
'set container header compare parameter
IF LEN(container) THEN POKE LONG, STRPTR(container) + 16, value
END SUB
'-------------------------------------
SUB SarrInitialize(BYREF container AS STRING) PRIVATE
'initialize container : not necessary to call : automatic
container = NUL$(SarrHeaderSize + (SarrRecordBufferMin * SarrRecordSize) + SarrCharacterBufferMin)
SarrSetTag container, SarrTag
SarrSetMax container, SarrRecordBufferMin
SarrSetCompare container, CODEPTR(SarrCompare)
END SUB
'-------------------------------------
FUNCTION SarrArrSize(BYREF container AS STRING) PRIVATE AS LONG
'get size of record array
FUNCTION = SarrGetMax(container) * SarrRecordSize
END FUNCTION
'-------------------------------------
FUNCTION SarrArrMem(BYREF container AS STRING) PRIVATE AS LONG
'get record array memory address
FUNCTION = STRPTR(container) + SarrHeaderSize
END FUNCTION
'-------------------------------------
FUNCTION SarrLeft(BYREF container AS STRING) PRIVATE AS LONG
'get length of left side
FUNCTION = SarrHeaderSize + SarrArrSize(container)
END FUNCTION
'-------------------------------------
FUNCTION SarrRight(BYREF container AS STRING) PRIVATE AS LONG
'get length of right side
FUNCTION = LEN(container) - SarrLeft(container)
END FUNCTION
'-------------------------------------
SUB SarrMoreRecords(BYREF container AS STRING) PRIVATE
'add more record space
LOCAL buffer AS LONG
LOCAL leftSide, rightSide AS STRING
buffer = SarrGetCount(container) * SarrRecordMultiplier
IF buffer < SarrRecordBufferMin THEN buffer = SarrRecordBufferMin
IF buffer > SarrRecordBufferMax THEN buffer = SarrRecordBufferMax
rightSide = RIGHT$(container, SarrRight(container))
leftSide = LEFT$(container, SarrLeft(container))
leftSide += NUL$(buffer * SarrRecordSize)
container = leftSide + rightSide
SarrSetMax container, SarrGetMax(container) + buffer
END SUB
'-------------------------------------
SUB SarrMoreCharacters(BYREF container AS STRING, BYVAL bytes AS LONG) PRIVATE
'add more character space
LOCAL buffer AS LONG
LOCAL p AS SarrHeaderT PTR
p = STRPTR(container)
buffer = SarrGetCount(container) * SarrCharacterMultiplier
IF buffer < SarrCharacterBufferMin THEN buffer = SarrCharacterBufferMin
IF buffer > SarrCharacterBufferMax THEN buffer = SarrCharacterBufferMax
container += NUL$(buffer + bytes)
END SUB
'-------------------------------------
FUNCTION SarrUnusedCharacters(BYREF container AS STRING) PRIVATE AS LONG
'get unused character space
FUNCTION = LEN(container) - SarrLeft(container) - SarrGetUsed(container)
END FUNCTION
'-------------------------------------
'-------------------------------------
' Callback Functions
'-------------------------------------
'-------------------------------------
FUNCTION SarrCompare(BYREF a AS STRING, BYREF b AS STRING) PRIVATE AS LONG
'case sensitive compare callback
FUNCTION = SWITCH&(a < b, -1, a > b, 1) 'else match
END FUNCTION
'-------------------------------------
FUNCTION SarrCompareUCase(BYREF a AS STRING, BYREF b AS STRING) PRIVATE AS LONG
'upper case compare callback
LOCAL ua AS STRING : ua = UCASE$(a)
LOCAL ub AS STRING : ub = UCASE$(b)
FUNCTION = SWITCH&(ua < ub, -1, ua > ub, 1) 'else match
END FUNCTION
'-------------------------------------
#ENDIF '%Sarr230829
#IF NOT %DEF(%Sash230903)
%Sash230903 = 1
'InString Hash Table
'Value stored and retrieved using unique lookup key.
'Keys are case sensitive.
'Key and value can be any kind of binary data, nulls, MK_$, ChrToUtf8$(), ...
'Uses string array and binary search and insert.
'Stays in key ordr.
'-------------------------------------
'-------------------------------------
' Hash Table
'-------------------------------------
'-------------------------------------
'-------------------------------------
SUB SashComparison(BYREF container AS STRING, BYVAL compareCB AS LONG)
'this implementation stays in key order
'!!! must be changed before use, will erase all data !!!
'default is case sensitive : CodePtr(SashCompare)
'set CodePtr(SashCompareUCase) to ignore case
'set CodePtr(procedure) for custom comparison
' modify provided callbacks
' keep in mind that only unique keys are allowed
IF LEN(container) = 0 THEN SarrInitialize(container)
IF CVL(container) <> SarrTag THEN EXIT SUB
SashClear container
IF compareCB THEN SarrSetCompare container, compareCB
END SUB
'-------------------------------------
SUB SashSetMetadata((BYREF container AS STRING, BYVAL value AS STRING)
'there is SarrMetadataSpace in each container for metadata
'set metadata
SarrSetMetadata container, value
END SUB
'-------------------------------------
FUNCTION SashGetMetadata(BYREF container AS STRING) AS STRING
'there is SarrMetadataSpace in each container for metadata
'get metadata
FUNCTION = SarrGetMetadata(container)
END FUNCTION
'-------------------------------------
FUNCTION SashCount(BYREF container AS STRING) AS LONG
'get item count
IF LEN(container) AND CVL(container) = SarrTag THEN FUNCTION = SarrGetCount(container)
END FUNCTION
'-------------------------------------
SUB SashClear(BYREF container AS STRING)
'empty container
SarrClear container
END SUB
'-------------------------------------
SUB SashPack(BYREF container AS STRING)
'get rid of dead space
LOCAL x AS LONG
LOCAL KeyValArr AS STRING
IF CVL(container) <> SarrTag THEN EXIT SUB
FOR x = 1 TO SarrCount(container)
KeyValArr = SarrGet(container, x)
SarrPack KeyValArr
SarrSet container, x, KeyValArr
NEXT x
SarrPack container
END SUB
'-------------------------------------
SUB SashSet(BYREF container AS STRING, BYVAL key AS STRING, BYVAL value AS STRING)
'add key and associated value : value replaced if key exist
LOCAL x AS LONG
LOCAL KeyValArr AS STRING
SarrComparison container, CODEPTR(SashCompare)
IF CVL(container) <> SarrTag THEN EXIT SUB
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
SarrSet KeyValArr, 2, value
x = SarrSortSearch(container, KeyValArr)
IF x THEN
SarrSet container, x, KeyValArr
ELSE
SarrSortInsert container, KeyValArr
END IF
END SUB
'-------------------------------------
FUNCTION SashGet(BYREF container AS STRING, BYVAL key AS STRING) AS STRING
'get key's associated value
LOCAL x AS LONG
LOCAL KeyValArr AS STRING
x = SashContains(container, key)
IF x THEN
KeyValArr = SarrGet(container, x)
FUNCTION = SarrGet(KeyValArr, 2)
END IF
END FUNCTION
'-------------------------------------
FUNCTION SashContains(BYREF container AS STRING, BYVAL key AS STRING) AS LONG
'return zero if key not in table
LOCAL x AS LONG
LOCAL KeyValArr AS STRING
IF CVL(container) <> SarrTag THEN EXIT FUNCTION
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
FUNCTION = SarrSortSearch(container, KeyValArr)
END FUNCTION
'-------------------------------------
SUB SashDelete(BYREF container AS STRING, BYVAL key AS STRING)
'delete key and associated value
LOCAL KeyValArr AS STRING
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
SarrSortDelete container, KeyValArr
END SUB
'-------------------------------------
FUNCTION SashGetKey(BYREF container AS STRING, BYVAL index AS LONG) AS STRING
'get key at one-based index
LOCAL KeyValArr AS STRING
KeyValArr = SarrGet(container, index)
IF LEN(KeyValArr) THEN FUNCTION = SarrGet(KeyValArr, 1)
END FUNCTION
'-------------------------------------
FUNCTION SashGetValue(BYREF container AS STRING, BYVAL index AS LONG) AS STRING
'get value at one-based index
LOCAL KeyValArr AS STRING
KeyValArr = SarrGet(container, index)
IF LEN(KeyValArr) THEN FUNCTION = SarrGet(KeyValArr, 2)
END FUNCTION
'-------------------------------------
'-------------------------------------
' PRIVATE
'-------------------------------------
'-------------------------------------
FUNCTION SashCompare(BYREF a AS STRING, BYREF b AS STRING) PRIVATE AS LONG
'case sensitive compare callback
LOCAL keyA AS STRING : keyA = SarrGet(a, 1)
LOCAL keyB AS STRING : keyB = SarrGet(b, 1)
FUNCTION = SWITCH&(keyA < keyB, -1, keyA > keyB, 1) 'else match
END FUNCTION
FUNCTION SashCompareUCase(BYREF a AS STRING, BYREF b AS STRING) PRIVATE AS LONG
'case sensitive compare callback
LOCAL keyA AS STRING : keyA = UCASE$(SarrGet(a, 1))
LOCAL keyB AS STRING : keyB = UCASE$(SarrGet(b, 1))
FUNCTION = SWITCH&(keyA < keyB, -1, keyA > keyB, 1) 'else match
END FUNCTION
#ENDIF '%Sash230903
#IF NOT %DEF(%SSet230905)
%SSet230905 = 1
'Each Set is a group of unique values.
'Comparison is case sensitive.
'-------------------------------------
'-------------------------------------
' Unique Ordered String Set
'-------------------------------------
'-------------------------------------
SUB SSetSetMetadata(BYREF ThisSet AS STRING, BYVAL value AS STRING)
'there is SarrMetadataSpace in each container for metadata
'set metadata
SarrSetMetadata ThisSet, value
END SUB
'-------------------------------------
FUNCTION SSetGetMetadata(BYREF ThisSet AS STRING) AS STRING
'there is SarrMetadataSpace in each container for metadata
'get metadata
FUNCTION = SarrGetMetadata(ThisSet)
END FUNCTION
'-------------------------------------
FUNCTION SSetCount(BYREF ThisSet AS STRING) AS LONG
'get unique items in ThisSet
FUNCTION = SarrCount(ThisSet)
END FUNCTION
'-------------------------------------
SUB SSetClear(BYREF ThisSet AS STRING)
'empty ThisSet
SarrClear ThisSet
END SUB
'-------------------------------------
SUB SSetPack(BYREF ThisSet AS STRING)
'get rid of dead space
SarrPack ThisSet
END SUB
'-------------------------------------
FUNCTION SSetGet(BYREF ThisSet AS STRING, BYVAL index AS LONG) AS STRING
'get value in ThisSet at one-based index
FUNCTION = SarrGet(ThisSet, index)
END FUNCTION
'-------------------------------------
SUB SSetAdd(BYREF ThisSet AS STRING, BYVAL value AS STRING)
'add value to ThisSet : ignored if duplicate
SarrSortInsert ThisSet, value, 1
END SUB
'-------------------------------------
SUB SSetSubtract(BYREF ThisSet AS STRING, BYVAL value AS STRING)
'remove value if in ThisSet
SarrSortDelete ThisSet, value
END SUB
'-------------------------------------
FUNCTION SSetContains(BYREF ThisSet AS STRING, BYVAL value AS STRING) AS BYTE
'true/false if value in ThisSet
IF SarrSortSearch(ThisSet, value) THEN FUNCTION = 1
END FUNCTION
'-------------------------------------
SUB SSetAddSet(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING)
'add OtherSet to ThisSet : duplicates ignored
REGISTER x AS LONG
FOR x = 1 TO SSetCount(OtherSet)
SSetAdd ThisSet, SSetGet(OtherSet, x)
NEXT x
END SUB
'-------------------------------------
SUB SSetSubtractSet(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING)
'remove all values from ThisSet that are in OtherSet
REGISTER x AS LONG
FOR x = 1 TO SSetCount(OtherSet)
SSetSubtract ThisSet, SSetGet(OtherSet, x)
NEXT x
END SUB
'-------------------------------------
FUNCTION SSetContainsSet(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS BYTE
'true if neither Set empty and all values in OtherSet are in ThisSet
REGISTER x AS LONG
IF SSetCount(ThisSet) AND SSetCount(OtherSet) THEN
FOR x = 1 TO SSetCount(OtherSet)
IF ISFALSE SSetContains(ThisSet, SSetGet(OtherSet, x)) THEN EXIT FUNCTION
NEXT x
FUNCTION = 1
END IF
END FUNCTION
'-------------------------------------
FUNCTION SSetContained(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS LONG
'get number of items in OtherSet that are in ThisSet
REGISTER x AS LONG
LOCAL items AS LONG
FOR x = 1 TO SSetCount(OtherSet)
IF ISTRUE SSetContains(ThisSet, SSetGet(OtherSet, x)) THEN INCR items
NEXT x
FUNCTION = items
END FUNCTION
'-------------------------------------
FUNCTION SSetNotContained(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS LONG
'get number of items in OtherSet that aren't in ThisSet
REGISTER x AS LONG
LOCAL items AS LONG
FOR x = 1 TO SSetCount(OtherSet)
IF ISFALSE SSetContains(ThisSet, SSetGet(OtherSet, x)) THEN INCR items
NEXT x
FUNCTION = items
END FUNCTION
'-------------------------------------
FUNCTION SSetEqual(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS BYTE
'true if both Sets empty or both same size and contain same values
IF SSetCount(ThisSet) = 0 AND SSetCount(OtherSet) = 0 THEN
FUNCTION = 1
ELSEIF SSetCount(ThisSet) = SSetCount(OtherSet) AND SSetContained(ThisSet, OtherSet) = SSetCount(ThisSet) THEN
FUNCTION = 1
END IF
END FUNCTION
'-------------------------------------
FUNCTION SSetSum(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS STRING
'return unique Set of values that are in either Set
LOCAL result AS STRING
SSetAddSet result, ThisSet
SSetAddSet result, OtherSet
FUNCTION = result
END FUNCTION
'-------------------------------------
FUNCTION SSetDifference(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS STRING
'return values that are in ThisSet but not in OtherSet
LOCAL result AS STRING
SSetAddSet result, ThisSet
SSetSubtractSet result, OtherSet
FUNCTION = result
END FUNCTION
'-------------------------------------
FUNCTION SSetCommon(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS STRING
'return unique Set of values that are common to both Sets
REGISTER x AS LONG
LOCAL result AS STRING
FOR x = 1 TO SSetCount(ThisSet)
IF ISTRUE SSetContains(OtherSet, SSetGet(ThisSet, x)) THEN SSetAdd result, SSetGet(ThisSet, x)
NEXT x
FOR x = 1 TO SSetCount(OtherSet)
IF ISTRUE SSetContains(ThisSet, SSetGet(OtherSet, x)) THEN SSetAdd result, SSetGet(OtherSet, x)
NEXT x
FUNCTION = result
END FUNCTION
'-------------------------------------
FUNCTION SSetUncommon(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS STRING
'return unique Set of values that are uncommon to both Sets
REGISTER x AS LONG
LOCAL result AS STRING
FOR x = 1 TO SSetCount(ThisSet)
IF ISFALSE SSetContains(OtherSet, SSetGet(ThisSet, x)) THEN SSetAdd result, SSetGet(ThisSet, x)
NEXT x
FOR x = 1 TO SSetCount(OtherSet)
IF ISFALSE SSetContains(ThisSet, SSetGet(OtherSet, x)) THEN SSetAdd result, SSetGet(OtherSet, x)
NEXT x
FUNCTION = result
END FUNCTION
'-------------------------------------
FUNCTION SSetCommonCount(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS LONG
'get number of values common to both Sets
LOCAL temp AS STRING
temp = SSetCommon(ThisSet, OtherSet)
FUNCTION = SSetCount(temp)
END FUNCTION
'-------------------------------------
FUNCTION SSetUncommonCount(BYREF ThisSet AS STRING, BYREF OtherSet AS STRING) AS LONG
'get number of values uncommon to both Sets
LOCAL temp AS STRING
temp = SSetUncommon(ThisSet, OtherSet)
FUNCTION = SSetCount(temp)
END FUNCTION
'-------------------------------------
#ENDIF '%SSet230905
#IF NOT %DEF(%FileUtilities230424)
%FileUtilities230424 = 1
' File Utilities
' public domain, use at own risk
' SDurham
SUB StrToFile(BYVAL file AS WSTRING, BYVAL s AS STRING) THREADSAFE
' store string to File
LOCAL f AS LONG
IF LEN(file) = 0 THEN EXIT SUB
f = FREEFILE
OPEN file FOR BINARY AS f
SETEOF f
PUT$ f, s
CLOSE f
END SUB
FUNCTION StrFromFile(BYVAL file AS WSTRING) THREADSAFE AS STRING
' get file contents as string
LOCAL f AS LONG
LOCAL s AS STRING
IF ISFALSE ISFILE(file) THEN EXIT FUNCTION
f = FREEFILE
OPEN file FOR BINARY AS f
GET$ f, LOF(f), s
FUNCTION = s
CLOSE f
END FUNCTION
SUB WStrToFile(BYVAL file AS WSTRING, BYVAL s AS WSTRING) THREADSAFE
' store string to File
LOCAL f AS LONG
IF LEN(file) = 0 THEN EXIT SUB
f = FREEFILE
OPEN file FOR BINARY AS f
SETEOF f
PUT$$ f, s
CLOSE f
END SUB
FUNCTION WStrFromFile(BYVAL file AS WSTRING) THREADSAFE AS WSTRING
' get file contents as string
LOCAL f AS LONG
LOCAL s AS WSTRING
IF ISFALSE ISFILE(file) THEN EXIT FUNCTION
f = FREEFILE
OPEN file FOR BINARY AS f
GET$$ f, LOF(f), s
FUNCTION = s
CLOSE f
END FUNCTION
SUB WStrToTextFile(BYVAL file AS WSTRING, BYVAL s AS WSTRING) THREADSAFE
' store string converted to UTF8 to File
StrToFile file, CHRTOUTF8$(s)
END SUB
FUNCTION WStrFromTextFile(BYVAL file AS WSTRING) AS WSTRING
' get file contents converted from UTF8
FUNCTION = UTF8TOCHR$(StrFromFile(file))
END FUNCTION
FUNCTION WStrFromTextFileFixed(BYVAL file AS WSTRING) THREADSAFE AS WSTRING
' get file contents converted from UTF8 fixing Unix line endings if any
LOCAL s AS WSTRING
s = UTF8TOCHR$(StrFromFile(file))
REPLACE $CRLF WITH $LF IN s
REPLACE $CRLF WITH $LF IN s
REPLACE $CR WITH $LF IN s
REPLACE $CR WITH $LF IN s
REPLACE $LF WITH $CRLF IN s
FUNCTION = s
END FUNCTION
#ENDIF '%FileUtilities230424�
'Sarr.inc
'Public domain, use at own risk. SDurham
'In-String: String Array, String Lookup Table, Unique Ordered String Set
'In-String String Array
'SarrComparison() set or change compare callback : default case sensitive
'SarrSetMetadata() set metadata : each container can have a metadata string
'SarrGetMetadata() get metadata
'SarrCount() get item count
'SarrClear() empty container
'SarrReDim() only needed to set a specified number of items : space management automatic
'SarrPack() get rid of dead space
'SarrAdd() append value
'SarrGet() get value at one-based index
'SarrSet() set value at one-based index
'SarrInsert() insert value at one-based index
'SarrDelete() delete value at one-based index
'SarrFastDelete() fast on massive array but destroys array order
'SarrSort() quick sort
'SarrSortSearch() binary search : optionally first or last
'SarrSortInsert() binary insert : optionally ignore duplicates
'SarrSortDelete() binary search and delete if found
'SarrSortCount() get item count in sorted array
'SarrReverse() reverse array
'SarrPushFirst() insert value at front
'SarrPushLast() append value to end
'SarrPopFirst() get and remove first value
'SarrPopLast() get and remove last value
'SarrSplit() split array on delimited string
'SarrJoin() join array to delimited string
'SarrToTextFile() store array as text file
'SarrFromTextFile() load text file
'SarrFolders() get all folders in specified folder
'SarrFiles() get all files in folder matching mask
'SarrAllFolders() get all folders in specified folder and sub-folders
'SarrAllFiles() get all files in specified folder, and sub-folders, matching mask
'In-String Lookup Table
'SashComparison() set compare callback : default case sensitive
'SashSetMetadata() set metadata : each container can have a metadata string
'SashGetMetadata() get metadata
'SashCount() get item count
'SashClear() empty container
'SashPack() get rid of dead space
'SashSet() add key and associated value : value replaced if key exist
'SashGet() get key's associated value
'SashContains() return zero if key not in table
'SashDelete() delete key and associated value
'SashGetKey() get key at one-based index
'SashGetValue() get value at one-based index
'Unique Ordered String Set
'SSetSetMetadata()set metadata : each container can have a metadata string
'SSetGetMetadata() get metadata
'SSetCount() get Set count
'SSetClear() empty Set
'SSetPack() get rid of dead space
'SSetGet() get value in Set at one-based index
'SSetAdd() add value to Set : duplicates ignored
'SSetSubtract() remove value from set
'SSetContains() true/false if value in Set
'SSetAddSet() add one Set to other : duplicates ignored
'SSetSubtractSet() subtract one Set from other
'SSetContainsSet() true/false if one Set is a subset of other
'SSetContained() get number of items in one Set that are in other
'SSetNotContained() get number of items in one Set that aren't in other
'SSetEqual() true if Sets equal
'SSetSum() get unique Set of values in two other Sets
'SSetDifference() get the difference between two Sets
'SSetCommon() get Set of values common to two Sets
'SSetUncommon() get Set of values uncommon to two Sets
'SSetCommonCount() get number of items common to two Sets
'SSetUncommonCount() get number of items uncommon to two Sets
'In-String String Array Performance
'add 10,000 values to empty array = 0.000 seconds
'get 10,000 values = 0.016 seconds
'binary search array for 10,000 values = 0.031 seconds
'add 10,000 strings 500 characters long = 0.141 seconds
'add 10,000 strings 1,000 characters long = 0.486 seconds
'fast delete 10,000 values = 0.031 seconds
'add 100,000 values to empty array = 0.047 seconds
'get 100,000 values = 0.015 seconds
'sort array of 100,000 random values = 0.490 seconds
'binary search array for 100,000 values = 0.352 seconds
'add 100,000 strings 100 characters long = 0.360 seconds
'add 100,000 strings 500 characters long = 9.780 seconds
'fast delete 100,000 values = 0.409 seconds
'add 1,000,000 values to empty array = 1.489
'get 1,000,000 values = 0.189
'sort array of 1,000,000 random values = 6.442 seconds
'binary search array for 1,000,000 values = 5.315 seconds
'add 1,000,000 strings 100 characters long = 50.119 seconds
'fast delete 1,000,000 values = 5.470 seconds
'add 100 strings 1,000,000 characters long = 1.883 seconds
'In-String Lookup Table Performance
'add 10,000 random key/values to hash table = 0.267 seconds
'find 10,000 keys = 0.078 seconds
'get 10,000 values using key = 0.078 seconds
'add 20,000 random key/values to hash table = 0.723 seconds
'find 20,000 keys = 0.159
'get 20,000 values using key = 0.174 seconds
'add 30,000 random key/values to hash table = 1.271 seconds
'find 30,000 keys = 0.251 seconds
'get 30,000 values using key = 0.266 seconds
'add 40,000 random key/values to hash table = 1.888 seconds
'find 40,000 keys = 0.345 seconds
'get 40,000 values using key = 0.377 seconds
'add 50,000 random key/values to hash table = 2.676 seconds
'find 50,000 keys = 0.447 seconds
'get 50,000 values using key = 0.475 seconds
'add 60,000 random key/values to hash table = 3.531 seconds
'find 60,000 keys = 0.615 seconds
'get 60,000 values using key = 0.612
'add 70,000 random key/values to hash table = 4.673 seconds
'find 70,000 keys = 0.659 seconds
'get 70,000 values using key = 0.675 seconds
'add 80,000 random key/values to hash table = 5.690 seconds
'find 80,000 keys = 0.786 seconds
'get 80,000 values using key = 0.800
'add 90,000 random key/values to hash table = 6.893 seconds
'find 90,000 keys = 0.899 seconds
'get 90,000 values using key = 0.942 seconds
'add 100,000 random key/values to hash table = 8.224 seconds
'find 100,000 keys = 1.020 seconds
'get 100,000 values using key = 0.991 seconds
#If Not %Def(%Sarr230829)
%Sarr230829 = 1
'InString String Array
'Container protected with hash tag.
Declare Function SarrCompare(ByRef a As String, ByRef b As String) As Long
'compare callback template
'a < b : return < 0
'a = b : return = 0
'a > b : return > 0
Macro SarrTag = 1783209428
Macro SarrMetadataSpace = 20
Macro SarrHeaderSize = (5 * 4) + SarrMetadataSpace + 1
Macro SarrRecordSize = 8
Macro SarrRecordBufferMax = 10000
Macro SarrRecordBufferMin = 4
Macro SarrCharacterBufferMax = 40000
Macro SarrCharacterBufferMin = 40
Macro SarrRecordMultiplier = 2
Macro SarrCharacterMultiplier = 5
' 12345678901234567890123456789012345678901234567890 string position
' 1234567890123456789012345678901234567 position in string space
' :header:array:used string space:free string space:
' 56789012345678901234567890123456789012345678901234 string pointer position
' : left side : right side :
' : metadata : character space :
Type SarrHeaderT
tag As Long
count As Long
max As Long
used As Long
compare As Long
metadata As String * SarrMetadataSpace
End Type
Type SarrRecordT
charSpaceOffset As Long
bytes As Long
End Type
#If Not %Def(%Unicode)
%Unicode = 1
#EndIf '%Unicode
'-------------------------------------
'-------------------------------------
' String Array
'-------------------------------------
'-------------------------------------
Sub SarrComparison(ByRef container As String, ByVal compareCB As Long)
'change compare callback which changes sort and binary search order
'default = case sensitive : CodePtr(SarrCompare)
'CodePtr(SarrCompare) = case sensitive
'CodePtr(SarrCompareUCase) = ignore case
'CodePtr(procedure) for custom comparison
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
If compareCB Then SarrSetCompare container, compareCB
End Sub
'-------------------------------------
Sub SarrSetMetadata((ByRef container As String, ByVal value As String)
Local p As SarrHeaderT Ptr
'there is SarrMetadataSpace in each container for metadata
'set metadata
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
p = StrPtr(container)
@p.metadata = value
End Sub
'-------------------------------------
Function SarrGetMetadata(ByRef container As String) As String
Local p As SarrHeaderT Ptr
'there is SarrMetadataSpace in each container for metadata
'get metadata
If Cvl(container) <> SarrTag Then Exit Function
p = StrPtr(container)
Function = Trim$(@p.metadata)
End Function
'-------------------------------------
Function SarrCount(ByRef container As String) As Long
'get item count
If Len(container) And Cvl(container) = SarrTag Then Function = SarrGetCount(container)
End Function
'-------------------------------------
Sub SarrClear(ByRef container As String)
'empty container
Local compareCB As Long
Local metadata As String
If Len(container) Then
If Cvl(container) <> SarrTag Then Exit Sub
compareCB = SarrGetCompare(container)
metadata = SarrGetMetadata(container)
container = ""
SarrInitialize(container)
SarrSetCompare container, compareCB
SarrSetMetadata container, metadata
End If
End Sub
'-------------------------------------
Sub SarrReDim(ByRef container As String, ByVal items As Long)
'redimension array : data preserved
'doesn't need be called, array is buffered
'use to set a specified number of items
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
If items >= 0 Then
While SarrGetCount(container) < items
SarrPushLast container, ""
Wend
While SarrGetCount(container) > items
SarrPopLast(container)
Wend
End If
End Sub
'-------------------------------------
Sub SarrPack(ByRef container As String)
'get rid of dead space
Register i As Long
Local items, usedCharacters As Long
Local leftSide, rightSide As String
Local a() As String
If Cvl(container) <> SarrTag Then Exit Sub
items = SarrGetCount(container)
usedCharacters = SarrGetUsed(container)
If items = 0 Then
SarrClear(container)
Else
ReDim a(1 To items)
For i = 1 To items
a(i) = SarrGet(container, i)
Next x
SarrClear container
For i = 1 To items
SarrAdd container, a(i)
Next x
Erase a()
leftSide = Left$(container, SarrHeaderSize + (items * SarrRecordSize))
rightSide = Right$(container, SarrRight(container))
rightSide = Left$(rightSide, usedCharacters)
container = leftSide + rightSide
SarrSetMax container, items
End If
End Sub
'-------------------------------------
Sub SarrAdd(ByRef container As String, ByVal value As String)
'append value
Local bytes, charSpaceOffset, mem As Long
Local rec() As SarrRecordT
'get needed character space
bytes = Len(value)
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
'add more records if needed
If SarrGetCount(container) = SarrGetMax(container) Then SarrMoreRecords(container)
'add more character space if needed
If SarrUnusedCharacters(container) < bytes Then SarrMoreCharacters(container, bytes)
'store value
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = StrPtr(container) + SarrLeft(container) + charSpaceOffset
Memory Copy StrPtr(value), mem, bytes
SarrSetCount container, SarrGetCount(container) + 1
ReDim rec(1 To SarrGetMax(container)) At SarrArrMem(container)
rec(SarrGetCount(container)).charSpaceOffset = charSpaceOffset
rec(SarrGetCount(container)).bytes = bytes
End Sub
'-------------------------------------
Function SarrGet(ByRef container As String, ByVal index As Long) As String
'get value at one-based index
Local mem, charSpaceOffset, bytes As Long
Local rec() As SarrRecordT
If Cvl(container) <> SarrTag Then Exit Function
If index < 1 Or index > SarrGetCount(container) Then Exit Function
ReDim rec(1 To SarrGetMax(container)) At SarrArrMem(container)
charSpaceOffset = rec(index).charSpaceOffset
bytes = rec(index).bytes
mem = StrPtr(container) + SarrLeft(container) + charSpaceOffset
Function = Peek$(mem, bytes)
End Function
'-------------------------------------
Sub SarrSet(ByRef container As String, ByVal index As Long, ByVal value As String)
'set value at one-based index
Local mem, charSpaceOffset, bytes As Long
Local rec() As SarrRecordT
If Cvl(container) <> SarrTag Then Exit Sub
If index < 1 Or index > SarrGetCount(container) Then Exit Sub
'get needed character space
bytes = Len(value)
'replace string
ReDim rec(1 To SarrGetMax(container)) At SarrArrMem(container)
If bytes > rec(index).bytes Then
'abandon old string space
'add more character space if needed
If SarrUnusedCharacters(container) < bytes Then SarrMoreCharacters(container, bytes)
'store value in new space
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = StrPtr(container) + SarrLeft(container) + charSpaceOffset
Memory Copy StrPtr(value), mem, bytes
ReDim rec(1 To SarrGetMax(container)) At SarrArrMem(container)
rec(index).charSpaceOffset = charSpaceOffset
rec(index).bytes = bytes
Else
'we have enough space
rec(index).bytes = bytes
charSpaceOffset = rec(index).charSpaceOffset
mem = StrPtr(container) + SarrLeft(container) + charSpaceOffset
Memory Copy StrPtr(value), mem, bytes
End If
End Sub
'-------------------------------------
Sub SarrInsert(ByRef container As String, ByVal index As Long, ByVal value As String)
'insert value at one-based index
Local charSpaceOffset, mem, bytes As Long
Local qud() As Quad
Local rec() As SarrRecordT
If Cvl(container) <> SarrTag Then Exit Sub
If index < 1 Or index > SarrGetCount(container) Then Exit Sub
'get needed character space
bytes = Len(value)
'add more records if needed : we need two more
If SarrGetMax(container) = SarrGetCount(container) Then SarrMoreRecords(container)
'add more character space if needed
If SarrUnusedCharacters(container) < bytes Then SarrMoreCharacters(container, bytes)
'insert record space
ReDim qud(1 To SarrGetMax(container)) At SarrArrMem(container)
Array Insert qud(index), 0
SarrSetCount container, SarrGetCount(container) + 1
'store value
charSpaceOffset = SarrGetUsed(container)
SarrSetUsed container, charSpaceOffset + bytes
mem = StrPtr(container) + SarrLeft(container) + charSpaceOffset
Memory Copy StrPtr(value), mem, bytes
ReDim rec(1 To SarrGetMax(container)) At SarrArrMem(container)
rec(index).charSpaceOffset = charSpaceOffset
rec(index).bytes = bytes
End Sub
'-------------------------------------
Sub SarrDelete(ByRef container As String, ByVal index As Long)
'delete value at one-based index
Local qud() As Quad
If Cvl(container) <> SarrTag Then Exit Sub
If index < 1 Or index > SarrGetCount(container) Then Exit Sub
ReDim qud(1 To SarrGetCount(container)) At SarrArrMem(container)
Array Delete qud(index)
SarrSetCount container, SarrGetCount(container) - 1
End Sub
'-------------------------------------
Sub SarrFastDelete(ByRef container As String, ByVal index As Long)
'fast delete value at one-based index
'fast on massive array but destroys array order
'traverse back to front to use
Local qud() As Quad
If Cvl(container) <> SarrTag Then Exit Sub
If index < 1 Or index > SarrGetCount(container) Then Exit Sub
ReDim qud(1 To SarrGetCount(container)) At SarrArrMem(container)
If index < SarrGetCount(container) Then Swap qud(index), qud(SarrGetCount(container))
SarrSetCount container, SarrGetCount(container) - 1
End Sub
'-------------------------------------
'-------------------------------------
' Sort Order
'-------------------------------------
'-------------------------------------
Sub SarrSort(ByRef container As String)
'non-recursive quick sort
Register i As Long
Register j As Long
Local k, leftIndex, rightIndex, counter, compareCB, compare As Long
Local value As String
Local qud() As Quad
If Cvl(container) <> SarrTag Then Exit Sub
compareCB = SarrGetCompare(container)
leftIndex = 1
rightIndex = SarrGetCount(container)
If rightIndex > 1 Then
ReDim qud(1 To rightIndex) At SarrArrMem(container)
counter = 1
!PUSH leftIndex
!PUSH rightIndex
While counter
Decr counter
!POP rightIndex
!POP leftIndex
i = leftIndex
j = rightIndex
k = i + j
Shift Right k, 1
value = SarrGet(container, k)
While i <= j
Call Dword compareCB Using SarrCompare(SarrGet(container, i), value) To compare
While compare < 0
Incr i
Call Dword compareCB Using SarrCompare(SarrGet(container, i), value) To compare
Wend
Call Dword compareCB Using SarrCompare(SarrGet(container, j), value) To compare
While compare > 0
Decr j
Call Dword compareCB Using SarrCompare(SarrGet(container, j), value) To compare
Wend
If i <= j Then
Swap qud(i), qud(j) : Incr i : Decr j
End If
Wend
If leftIndex < j Then
!PUSH leftIndex
!PUSH j
Incr counter
End If
If i < rightIndex Then
!PUSH i
!PUSH rightIndex
Incr counter
End If
Wend
End If
End Sub
'-------------------------------------
Function SarrSortSearch(ByRef container As String, ByVal value As String, Opt ByVal findFirst As Long, Opt ByVal findLast As Long) As Long
'binary search for value : return index : zero if not found : array must be sorted
'if IsTrue findFirst then first instance found
'if IsTrue findLast then last instance found
Register i As Long
Register j As Long
Local bot, top, result, compareCB, compare As Long
If Cvl(container) <> SarrTag Then Exit Function
compareCB = SarrGetCompare(container)
bot = 1
top = SarrGetCount(container)
If top Then
While top >= bot
i = bot + top
Shift Right i, 1 'divide by 2
Call Dword compareCB Using SarrCompare(value, SarrGet(container, i)) To compare
If compare > 0 Then
bot = i + 1
ElseIf compare < 0 Then
top = i - 1
Else
result = i
If IsTrue findFirst Then
For j = i - 1 To 1 Step -1
Call Dword compareCB Using SarrCompare(value, SarrGet(container, j)) To compare
If compare = 0 Then
result = j
Else
Exit For
End If
Next j
ElseIf IsTrue findLast Then
For j = i + 1 To SarrGetCount(container)
Call Dword compareCB Using SarrCompare(value, SarrGet(container, j)) To compare
If compare = 0 Then
result = j
Else
Exit For
End If
Next j
End If
Function = result
Exit Function
End If
Wend
End If
End Function
'-------------------------------------
Sub SarrSortInsert(ByRef container As String, ByVal value As String, Opt ByVal unique As Long)
'insert value at sort position : added if empty : array must be sorted or empty
'if IsTrue unique then duplicates ignored
Register i As Long
Local bot, top, compareCB, compare As Long
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
compareCB = SarrGetCompare(container)
bot = 1
top = SarrGetCount(container)
If top Then
While top >= bot
i = bot + top
Shift Right i, 1 'divide by 2
Call Dword compareCB Using SarrCompare(value, SarrGet(container, i)) To compare
If compare > 0 Then
bot = i + 1
ElseIf compare < 0 Then
top = i - 1
Else
If IsFalse unique Then SarrInsert(container, i, value)
Exit Sub
End If
Wend
If compare < 0 Then
SarrInsert(container, i, value)
ElseIf i < SarrGetCount(container) Then
SarrInsert(container, i + 1, value)
Else
SarrAdd(container, value)
End If
Else
SarrAdd(container, value)
End If
End Sub
'-------------------------------------
Sub SarrSortDelete(ByRef container As String, ByVal value As String)
'delete one instance of value if in array maintaining sort order : array must be sorted
Local x As Long
x = SarrSortSearch(container, value)
If x Then SarrDelete container, x
End Sub
'-------------------------------------
Function SarrSortCount(ByRef container As String, ByVal value As String) As Long
'get value's instance count : array must be sorted
Local first, last As Long
first = SarrSortSearch(container, value, 1, 0)
last = SarrSortSearch(container, value, 0, 1)
Function = last - first + 1
End Function
'-------------------------------------
Sub SarrReverse(ByRef container As String)
'reverse array
Register i As Long
Register j As Long
Local qud() As Quad
If Cvl(container) <> SarrTag Then Exit Sub
i = 1
j = SarrGetCount(container)
If j > 1 Then
ReDim qud(1 To SarrGetMax(container)) At SarrArrMem(container)
While i < j
Swap qud(i), qud(j)
Incr i
Decr j
Wend
End If
End Sub
'-------------------------------------
'-------------------------------------
' Stack and Queue
'-------------------------------------
'-------------------------------------
Sub SarrPushFirst(ByRef container As String, ByVal value As String)
'insert value at front
If SarrCount(container) Then SarrInsert(container, 1, value) Else SarrAdd(container, value)
End Sub
'-------------------------------------
Sub SarrPushLast(ByRef container As String, ByVal value As String)
'append value to end of array
SarrAdd container, value
End Sub
'-------------------------------------
Function SarrPopFirst(ByRef container As String) As String
'get and remove first value in array
If SarrCount(container) Then
Function = SarrGet(container, 1)
SarrDelete container, 1
End If
End Function
'-------------------------------------
Function SarrPopLast(ByRef container As String) As String
'get and remove first value in array
Local items As Long
items = SarrCount(container)
If items Then
Function = SarrGet(container, items)
SarrDelete container, items
End If
End Function
'-------------------------------------
'-------------------------------------
' Split and Join
'-------------------------------------
'-------------------------------------
Sub SarrSplit(ByRef container As String, ByVal delimitedString As String, ByVal delimiter As String)
'split array on delimited string
Register i As Long
Local items As Long
Local a() As String
SarrClear container
If Len(delimitedString) Then
items = ParseCount(delimitedString, delimiter)
If items Then
ReDim a(1 To items)
Parse delimitedString, a(), delimiter
For i = 1 To items
SarrAdd container, a(i)
Next x
End If
End If
End Sub
'-------------------------------------
Function SarrJoin(ByRef container As String, ByVal delimiter As String) As String
'join array to delimited string
Register i As Long
Local items As Long
Local a() As WString
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Function
items = SarrCount(container)
If items Then
ReDim a(1 To items)
For i = 1 To items
a(i) = Utf8ToChr$(SarrGet(container, i))
Next x
Function = Join$(a(), delimiter)
End If
End Function
'-------------------------------------
'-------------------------------------
' To/From Text File
'-------------------------------------
'-------------------------------------
Sub SarrToTextFile(ByRef container As String, ByVal file As WString)
'store array as text file
StrToFile file, Trim$(SarrJoin(container, $CrLf), $CrLf) + $CrLf
End Sub
'-------------------------------------
Sub SarrFromTextFile(ByRef container As String, ByVal file As WString)
'load text file
If Len(container) = 0 Then SarrInitialize(container)
SarrSplit container, Trim$(StrFromFile(file), $CrLf), $CrLf
End Sub
'-------------------------------------
'-------------------------------------
' File and Folder List
'-------------------------------------
'-------------------------------------
Sub SarrFolders(ByRef container As String, ByVal specifiedFolder As WString)
'get all folders in specified folder
'items stored UTF8
Local folder, folderMask, specifiedPath As WString
Local DrD As DirData
If Len(container) = 0 Then SarrInitialize(container)
SarrClear container
If IsFalse IsFolder(specifiedFolder) Then Exit Sub
specifiedPath = RTrim$(specifiedFolder, "\") + "\"
folderMask = specifiedPath
folder = Dir$(folderMask, Only %SubDir To DrD)
While Len(folder)
SarrAdd container, ChrToUtf8$(specifiedPath + folder)
folder = Dir$
Wend
End Sub
'-------------------------------------
Sub SarrFiles(ByRef container As String, ByVal specifiedFolder As WString, ByVal mask As WString)
'get all files in folder matching mask
'items stored UTF8
Local file, fileMask As WString
If Len(container) = 0 Then SarrInitialize(container)
SarrClear container
If IsFalse IsFolder(specifiedFolder) Then Exit Sub
specifiedFolder = RTrim$(specifiedFolder, "\") + "\"
fileMask = specifiedFolder + mask
file = Dir$(fileMask)
While Len(file)
SarrAdd container, ChrToUtf8$(specifiedFolder + file)
file = Dir$
Wend
End Sub
'-------------------------------------
Sub SarrAllFolders(ByRef container As String, ByVal specifiedFolder As WString)
'get all folders in specified folder and sub-folders
'items stored UTF8
Local foldersArr, subFoldersArr As String
Local currentFolder As WString
If Len(container) = 0 Then SarrInitialize(container)
SarrClear container
If IsFalse IsFolder(specifiedFolder) Then Exit Sub
SarrPushLast foldersArr, specifiedFolder
While SarrCount(foldersArr)
currentFolder = SarrPopLast(foldersArr)
SarrAdd container, currentFolder
SarrFolders subFoldersArr, currentFolder
While SarrCount(subFoldersArr)
SarrPushLast foldersArr, SarrPopLast(subFoldersArr)
Wend
Wend
End Sub
'-------------------------------------
Sub SarrAllFiles(ByRef container As String, ByVal specifiedFolder As WString, ByVal mask As WString)
'get all files in specified folder, and sub-folders, matching mask
'items stored UTF8
Local allFoldersArr, folderFilesArr As String
If Len(container) = 0 Then SarrInitialize(container)
SarrClear container
If IsFalse IsFolder(specifiedFolder) Then Exit Sub
SarrAllFolders allFoldersArr, specifiedFolder
While SarrCount(allFoldersArr)
SarrFiles folderFilesArr, SarrPopLast(allFoldersArr), mask
While SarrCount(folderFilesArr)
SarrAdd container, SarrPopLast(folderFilesArr)
Wend
Wend
End Sub
'-------------------------------------
'-------------------------------------
' PRIVATE
'-------------------------------------
'-------------------------------------
Sub SarrSetTag(ByRef container As String, ByVal value As Long) Private
'set container header tag parameter
If Len(container) Then Poke Long, StrPtr(container), value
End Sub
'-------------------------------------
Function SarrGetCount(ByRef container As String) Private As Long
'get container header count parameter
If Len(container) Then Function = Peek(Long, StrPtr(container) + 4)
End Function
'-------------------------------------
Sub SarrSetCount(ByRef container As String, ByVal value As Long) Private
'set container header count parameter
If Len(container) Then Poke Long, StrPtr(container) + 4, value
End Sub
'-------------------------------------
Function SarrGetMax(ByRef container As String) Private As Long
'get container header max parameter
If Len(container) Then Function = Peek(Long, StrPtr(container) + 8)
End Function
'-------------------------------------
Sub SarrSetMax(ByRef container As String, ByVal value As Long) Private
'set container header max parameter
If Len(container) Then Poke Long, StrPtr(container) + 8, value
End Sub
'-------------------------------------
Function SarrGetUsed(ByRef container As String) Private As Long
'get container header used parameter
If Len(container) Then Function = Peek(Long, StrPtr(container) + 12)
End Function
'-------------------------------------
Sub SarrSetUsed(ByRef container As String, ByVal value As Long) Private
'set container header used parameter
If Len(container) Then Poke Long, StrPtr(container) + 12, value
End Sub
'-------------------------------------
Function SarrGetCompare(ByRef container As String) Private As Long
'get container header compare parameter
If Len(container) Then Function = Peek(Long, StrPtr(container) + 16)
End Function
'-------------------------------------
Sub SarrSetCompare(ByRef container As String, ByVal value As Long) Private
'set container header compare parameter
If Len(container) Then Poke Long, StrPtr(container) + 16, value
End Sub
'-------------------------------------
Sub SarrInitialize(ByRef container As String) Private
'initialize container : not necessary to call : automatic
container = Nul$(SarrHeaderSize + (SarrRecordBufferMin * SarrRecordSize) + SarrCharacterBufferMin)
SarrSetTag container, SarrTag
SarrSetMax container, SarrRecordBufferMin
SarrSetCompare container, CodePtr(SarrCompare)
End Sub
'-------------------------------------
Function SarrArrSize(ByRef container As String) Private As Long
'get size of record array
Function = SarrGetMax(container) * SarrRecordSize
End Function
'-------------------------------------
Function SarrArrMem(ByRef container As String) Private As Long
'get record array memory address
Function = StrPtr(container) + SarrHeaderSize
End Function
'-------------------------------------
Function SarrLeft(ByRef container As String) Private As Long
'get length of left side
Function = SarrHeaderSize + SarrArrSize(container)
End Function
'-------------------------------------
Function SarrRight(ByRef container As String) Private As Long
'get length of right side
Function = Len(container) - SarrLeft(container)
End Function
'-------------------------------------
Sub SarrMoreRecords(ByRef container As String) Private
'add more record space
Local buffer As Long
Local leftSide, rightSide As String
buffer = SarrGetCount(container) * SarrRecordMultiplier
If buffer < SarrRecordBufferMin Then buffer = SarrRecordBufferMin
If buffer > SarrRecordBufferMax Then buffer = SarrRecordBufferMax
rightSide = Right$(container, SarrRight(container))
leftSide = Left$(container, SarrLeft(container))
leftSide += Nul$(buffer * SarrRecordSize)
container = leftSide + rightSide
SarrSetMax container, SarrGetMax(container) + buffer
End Sub
'-------------------------------------
Sub SarrMoreCharacters(ByRef container As String, ByVal bytes As Long) Private
'add more character space
Local buffer As Long
Local p As SarrHeaderT Ptr
p = StrPtr(container)
buffer = SarrGetCount(container) * SarrCharacterMultiplier
If buffer < SarrCharacterBufferMin Then buffer = SarrCharacterBufferMin
If buffer > SarrCharacterBufferMax Then buffer = SarrCharacterBufferMax
container += Nul$(buffer + bytes)
End Sub
'-------------------------------------
Function SarrUnusedCharacters(ByRef container As String) Private As Long
'get unused character space
Function = Len(container) - SarrLeft(container) - SarrGetUsed(container)
End Function
'-------------------------------------
'-------------------------------------
' Callback Functions
'-------------------------------------
'-------------------------------------
Function SarrCompare(ByRef a As String, ByRef b As String) Private As Long
'case sensitive compare callback
Function = Switch&(a < b, -1, a > b, 1) 'else match
End Function
'-------------------------------------
Function SarrCompareUCase(ByRef a As String, ByRef b As String) Private As Long
'upper case compare callback
Local ua As String : ua = UCase$(a)
Local ub As String : ub = UCase$(b)
Function = Switch&(ua < ub, -1, ua > ub, 1) 'else match
End Function
'-------------------------------------
#EndIf '%Sarr230829
#If Not %Def(%Sash230903)
%Sash230903 = 1
'InString Hash Table
'Value stored and retrieved using unique lookup key.
'Keys are case sensitive.
'Key and value can be any kind of binary data, nulls, MK_$, ChrToUtf8$(), ...
'Uses string array and binary search and insert.
'Stays in key ordr.
'-------------------------------------
'-------------------------------------
' Hash Table
'-------------------------------------
'-------------------------------------
'-------------------------------------
Sub SashComparison(ByRef container As String, ByVal compareCB As Long)
'this implementation stays in key order
'!!! must be changed before use, will erase all data !!!
'default is case sensitive : CodePtr(SashCompare)
'set CodePtr(SashCompareUCase) to ignore case
'set CodePtr(procedure) for custom comparison
' modify provided callbacks
' keep in mind that only unique keys are allowed
If Len(container) = 0 Then SarrInitialize(container)
If Cvl(container) <> SarrTag Then Exit Sub
SashClear container
If compareCB Then SarrSetCompare container, compareCB
End Sub
'-------------------------------------
Sub SashSetMetadata((ByRef container As String, ByVal value As String)
'there is SarrMetadataSpace in each container for metadata
'set metadata
SarrSetMetadata container, value
End Sub
'-------------------------------------
Function SashGetMetadata(ByRef container As String) As String
'there is SarrMetadataSpace in each container for metadata
'get metadata
Function = SarrGetMetadata(container)
End Function
'-------------------------------------
Function SashCount(ByRef container As String) As Long
'get item count
If Len(container) And Cvl(container) = SarrTag Then Function = SarrGetCount(container)
End Function
'-------------------------------------
Sub SashClear(ByRef container As String)
'empty container
SarrClear container
End Sub
'-------------------------------------
Sub SashPack(ByRef container As String)
'get rid of dead space
Local x As Long
Local KeyValArr As String
If Cvl(container) <> SarrTag Then Exit Sub
For x = 1 To SarrCount(container)
KeyValArr = SarrGet(container, x)
SarrPack KeyValArr
SarrSet container, x, KeyValArr
Next x
SarrPack container
End Sub
'-------------------------------------
Sub SashSet(ByRef container As String, ByVal key As String, ByVal value As String)
'add key and associated value : value replaced if key exist
Local x As Long
Local KeyValArr As String
SarrComparison container, CodePtr(SashCompare)
If Cvl(container) <> SarrTag Then Exit Sub
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
SarrSet KeyValArr, 2, value
x = SarrSortSearch(container, KeyValArr)
If x Then
SarrSet container, x, KeyValArr
Else
SarrSortInsert container, KeyValArr
End If
End Sub
'-------------------------------------
Function SashGet(ByRef container As String, ByVal key As String) As String
'get key's associated value
Local x As Long
Local KeyValArr As String
x = SashContains(container, key)
If x Then
KeyValArr = SarrGet(container, x)
Function = SarrGet(KeyValArr, 2)
End If
End Function
'-------------------------------------
Function SashContains(ByRef container As String, ByVal key As String) As Long
'return zero if key not in table
Local x As Long
Local KeyValArr As String
If Cvl(container) <> SarrTag Then Exit Function
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
Function = SarrSortSearch(container, KeyValArr)
End Function
'-------------------------------------
Sub SashDelete(ByRef container As String, ByVal key As String)
'delete key and associated value
Local KeyValArr As String
SarrRedim KeyValArr, 2
SarrSet KeyValArr, 1, key
SarrSortDelete container, KeyValArr
End Sub
'-------------------------------------
Function SashGetKey(ByRef container As String, ByVal index As Long) As String
'get key at one-based index
Local KeyValArr As String
KeyValArr = SarrGet(container, index)
If Len(KeyValArr) Then Function = SarrGet(KeyValArr, 1)
End Function
'-------------------------------------
Function SashGetValue(ByRef container As String, ByVal index As Long) As String
'get value at one-based index
Local KeyValArr As String
KeyValArr = SarrGet(container, index)
If Len(KeyValArr) Then Function = SarrGet(KeyValArr, 2)
End Function
'-------------------------------------
'-------------------------------------
' PRIVATE
'-------------------------------------
'-------------------------------------
Function SashCompare(ByRef a As String, ByRef b As String) Private As Long
'case sensitive compare callback
Local keyA As String : keyA = SarrGet(a, 1)
Local keyB As String : keyB = SarrGet(b, 1)
Function = Switch&(keyA < keyB, -1, keyA > keyB, 1) 'else match
End Function
Function SashCompareUCase(ByRef a As String, ByRef b As String) Private As Long
'case sensitive compare callback
Local keyA As String : keyA = UCase$(SarrGet(a, 1))
Local keyB As String : keyB = UCase$(SarrGet(b, 1))
Function = Switch&(keyA < keyB, -1, keyA > keyB, 1) 'else match
End Function
#EndIf '%Sash230903
#If Not %Def(%SSet230905)
%SSet230905 = 1
'Each Set is a group of unique values.
'Comparison is case sensitive.
'-------------------------------------
'-------------------------------------
' Unique Ordered String Set
'-------------------------------------
'-------------------------------------
Sub SSetSetMetadata(ByRef ThisSet As String, ByVal value As String)
'there is SarrMetadataSpace in each container for metadata
'set metadata
SarrSetMetadata ThisSet, value
End Sub
'-------------------------------------
Function SSetGetMetadata(ByRef ThisSet As String) As String
'there is SarrMetadataSpace in each container for metadata
'get metadata
Function = SarrGetMetadata(ThisSet)
End Function
'-------------------------------------
Function SSetCount(ByRef ThisSet As String) As Long
'get unique items in ThisSet
Function = SarrCount(ThisSet)
End Function
'-------------------------------------
Sub SSetClear(ByRef ThisSet As String)
'empty ThisSet
SarrClear ThisSet
End Sub
'-------------------------------------
Sub SSetPack(ByRef ThisSet As String)
'get rid of dead space
SarrPack ThisSet
End Sub
'-------------------------------------
Function SSetGet(ByRef ThisSet As String, ByVal index As Long) As String
'get value in ThisSet at one-based index
Function = SarrGet(ThisSet, index)
End Function
'-------------------------------------
Sub SSetAdd(ByRef ThisSet As String, ByVal value As String)
'add value to ThisSet : ignored if duplicate
SarrSortInsert ThisSet, value, 1
End Sub
'-------------------------------------
Sub SSetSubtract(ByRef ThisSet As String, ByVal value As String)
'remove value if in ThisSet
SarrSortDelete ThisSet, value
End Sub
'-------------------------------------
Function SSetContains(ByRef ThisSet As String, ByVal value As String) As Byte
'true/false if value in ThisSet
If SarrSortSearch(ThisSet, value) Then Function = 1
End Function
'-------------------------------------
Sub SSetAddSet(ByRef ThisSet As String, ByRef OtherSet As String)
'add OtherSet to ThisSet : duplicates ignored
Register x As Long
For x = 1 To SSetCount(OtherSet)
SSetAdd ThisSet, SSetGet(OtherSet, x)
Next x
End Sub
'-------------------------------------
Sub SSetSubtractSet(ByRef ThisSet As String, ByRef OtherSet As String)
'remove all values from ThisSet that are in OtherSet
Register x As Long
For x = 1 To SSetCount(OtherSet)
SSetSubtract ThisSet, SSetGet(OtherSet, x)
Next x
End Sub
'-------------------------------------
Function SSetContainsSet(ByRef ThisSet As String, ByRef OtherSet As String) As Byte
'true if neither Set empty and all values in OtherSet are in ThisSet
Register x As Long
If SSetCount(ThisSet) And SSetCount(OtherSet) Then
For x = 1 To SSetCount(OtherSet)
If IsFalse SSetContains(ThisSet, SSetGet(OtherSet, x)) Then Exit Function
Next x
Function = 1
End If
End Function
'-------------------------------------
Function SSetContained(ByRef ThisSet As String, ByRef OtherSet As String) As Long
'get number of items in OtherSet that are in ThisSet
Register x As Long
Local items As Long
For x = 1 To SSetCount(OtherSet)
If IsTrue SSetContains(ThisSet, SSetGet(OtherSet, x)) Then Incr items
Next x
Function = items
End Function
'-------------------------------------
Function SSetNotContained(ByRef ThisSet As String, ByRef OtherSet As String) As Long
'get number of items in OtherSet that aren't in ThisSet
Register x As Long
Local items As Long
For x = 1 To SSetCount(OtherSet)
If IsFalse SSetContains(ThisSet, SSetGet(OtherSet, x)) Then Incr items
Next x
Function = items
End Function
'-------------------------------------
Function SSetEqual(ByRef ThisSet As String, ByRef OtherSet As String) As Byte
'true if both Sets empty or both same size and contain same values
If SSetCount(ThisSet) = 0 And SSetCount(OtherSet) = 0 Then
Function = 1
ElseIf SSetCount(ThisSet) = SSetCount(OtherSet) And SSetContained(ThisSet, OtherSet) = SSetCount(ThisSet) Then
Function = 1
End If
End Function
'-------------------------------------
Function SSetSum(ByRef ThisSet As String, ByRef OtherSet As String) As String
'return unique Set of values that are in either Set
Local result As String
SSetAddSet result, ThisSet
SSetAddSet result, OtherSet
Function = result
End Function
'-------------------------------------
Function SSetDifference(ByRef ThisSet As String, ByRef OtherSet As String) As String
'return values that are in ThisSet but not in OtherSet
Local result As String
SSetAddSet result, ThisSet
SSetSubtractSet result, OtherSet
Function = result
End Function
'-------------------------------------
Function SSetCommon(ByRef ThisSet As String, ByRef OtherSet As String) As String
'return unique Set of values that are common to both Sets
Register x As Long
Local result As String
For x = 1 To SSetCount(ThisSet)
If IsTrue SSetContains(OtherSet, SSetGet(ThisSet, x)) Then SSetAdd result, SSetGet(ThisSet, x)
Next x
For x = 1 To SSetCount(OtherSet)
If IsTrue SSetContains(ThisSet, SSetGet(OtherSet, x)) Then SSetAdd result, SSetGet(OtherSet, x)
Next x
Function = result
End Function
'-------------------------------------
Function SSetUncommon(ByRef ThisSet As String, ByRef OtherSet As String) As String
'return unique Set of values that are uncommon to both Sets
Register x As Long
Local result As String
For x = 1 To SSetCount(ThisSet)
If IsFalse SSetContains(OtherSet, SSetGet(ThisSet, x)) Then SSetAdd result, SSetGet(ThisSet, x)
Next x
For x = 1 To SSetCount(OtherSet)
If IsFalse SSetContains(ThisSet, SSetGet(OtherSet, x)) Then SSetAdd result, SSetGet(OtherSet, x)
Next x
Function = result
End Function
'-------------------------------------
Function SSetCommonCount(ByRef ThisSet As String, ByRef OtherSet As String) As Long
'get number of values common to both Sets
Local temp As String
temp = SSetCommon(ThisSet, OtherSet)
Function = SSetCount(temp)
End Function
'-------------------------------------
Function SSetUncommonCount(ByRef ThisSet As String, ByRef OtherSet As String) As Long
'get number of values uncommon to both Sets
Local temp As String
temp = SSetUncommon(ThisSet, OtherSet)
Function = SSetCount(temp)
End Function
'-------------------------------------
#EndIf '%SSet230905
#If Not %Def(%FileUtilities230424)
%FileUtilities230424 = 1
' File Utilities
Sub StrToFile(ByRef file As WString, ByRef value As String)
'store string to File
Local f As Long
If Len(file) = 0 Then Exit Sub
f = FreeFile
Open file For Binary As f
SetEof f
Put$ f, value
Close f
End Sub
Function StrFromFile(ByRef file As WString) As String
'get file contents as string
Local f As Long
Local value As String
If IsFalse IsFile(file) Then Exit Function
f = FreeFile
Open file For Binary As f
Get$ f, Lof(f), value
Function = value
Close f
End Function
Function StrFromFileFixed(ByRef file As WString) As String
'get file contents converted from Unix line endings if any
Local value As String
value = StrFromFile(file)
Replace $CrLf With $Lf In value
Replace $CrLf With $Lf In value
Replace $Cr With $Lf In value
Replace $Cr With $Lf In value
Replace $Lf With $CrLf In value
Function = value
End Function
Sub WStrToFile(ByRef file As WString, ByRef value As WString)
'store string to File
Local f As Long
If Len(file) = 0 Then Exit Sub
f = FreeFile
Open file For Binary As f
SetEof f
Put$$ f, value
Close f
End Sub
Function WStrFromFile(ByRef file As WString) As WString
'get file contents as string
Local f As Long
Local value As WString
If IsFalse IsFile(file) Then Exit Function
f = FreeFile
Open file For Binary As f
Get$$ f, Lof(f), value
Function = value
Close f
End Function
Sub WStrToTextFile(ByRef file As WString, ByRef value As WString)
'store string converted to UTF8 to File
StrToFile file, ChrToUtf8$(value)
End Sub
Function WStrFromTextFile(ByRef file As WString) As WString
'get file contents converted from UTF8
Function = Utf8ToChr$(StrFromFile(file))
End Function
Function WStrFromTextFileFixed(ByRef file As WString) As WString
'get file contents converted from UTF8 fixing Unix line endings if any
Local value As WString
value = Utf8ToChr$(StrFromFile(file))
Replace $CrLf With $Lf In value
Replace $CrLf With $Lf In value
Replace $Cr With $Lf In value
Replace $Cr With $Lf In value
Replace $Lf With $CrLf In value
Function = value
End Function
#EndIf '%FileUtilities230424�
Source:Powerbasic Forum (https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/826311-in-string-string-array-and-hash-table)