Understanding the Advanced Key-Ordered Data Storage System
Payload Storage and Retrieval: This system allows users to store data (referred to as a 'payload') and later retrieve it using a distinct identifier known as a 'unique key'.
Speed Considerations: While this method offers reliable data storage and retrieval, it doesn't achieve the same speed as data structures like hash tables or trie trees.
Key Order Maintenance: One of its distinguishing features is that it maintains the order of the keys. This means that when you iterate over the keys, they will be presented in the order in which they were added. Additionally, the system can be configured to treat keys as case-sensitive or case-insensitive, depending on the user's requirements.
Capacity and Hashing: Unlike traditional hash tables, there's no need to predetermine a capacity for this system. This eliminates the need for resizing and rehashing, which can be computationally expensive.
Custom Comparison: The system is flexible and supports custom comparison callbacks. This means users can define their own logic for comparing keys, allowing for more tailored data retrieval.
Data Persistence: It offers the capability to store its data structure into a string or a file, and similarly, it can restore its state from these sources. This ensures data persistence across sessions.
Balanced Structure: The system boasts an impressively balanced structure. For instance, when using the Long version of this system to store 10,000,000 items, the depth of the longest branch was found to be just 28 nodes. This balance ensures efficient access times even as the data grows.
'Public domain, use at own risk. SDurham
'AVL Tree
'https://en.wikipedia.org/wiki/AVL_tree
'tree stays in key order
'add 100,000 random key/payload items to empty tree = 0.297seconds
'search for 100,000 keys in tree of 100,000 items = 0.235 seconds
'add 1,000,000 random key/payload items to empty tree = 5.160 seconds
'search for 1,000,000 keys in tree of 1,000,000 items = 4.183 seconds
#If Not %Def(%WStrTree230816)
%WStrTree230816 = 1
'WString/WString Key/Payload AVL Tree
'payload stored and retrieved using unique key
'accessed with handle : handle protected with hash tag
'self-balancing binary search tree : https://en.wikipedia.org/wiki/AVL_tree
%WStrTreeTag = -2028489247
Type WStrT 'forward reference
tag As Long
count As Long
mem As Long
instances As Long
End Type
Type WStrTreeNodeT
parent As WStrTreeNodeT Ptr
left As WStrTreeNodeT Ptr
right As WStrTreeNodeT Ptr
heightLeft As Word
heightRight As Word
key As WStrT Ptr
payload As WStrT Ptr
End Type
Type WStrTreeT
tag As Long
count As Long
root As WStrTreeNodeT Ptr
cursor As WStrTreeNodeT Ptr
instances As Long
compareCB As Long
End Type
Declare Function WStrCompare(ByRef a As WString, ByRef b As WString) As Long
'compare callback template
'a < b : return < 0
'a = b : return = 0
'a > b : return > 0
'-----------------------------------
' Tree
'-----------------------------------
Function WStrTreeNew() As Long
'allocate new container : return handle
Local p As WStrTreeT Ptr
p = MemAllocate(SizeOf(@p))
If p Then
@p.tag = %WStrTreeTag
@p.compareCB = CodePtr(WStrCompare)
@p.instances = 1
Function = p
End If
End Function
Function WStrTreeFree(ByVal h As Long) As Long
'must free handle before it goes out of scope : return null
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
Decr @p.instances
If @p.instances = 0 Then
WStrTreeClear p
MemFree(h)
End If
End If
End Function
Function WStrTreeIncr(ByVal h As Long) As Long
''increment instance count : return handle to same instance
'different handles to same instance modify same data
'all instances must be freed
'use or ignore
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
Incr @p.instances
Function = p
End If
End Function
Sub WStrTreeCompare(ByVal h As Long, ByVal compareCB As Long)
'set compare callback : tree must be empty
'default = case sensitive
'set CodePtr(WStrCompareUCase) to ignore case
'set CodePtr(procedure) for custom comparison
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
If @p.count = 0 And compareCB Then @p.compareCB = compareCB
End If
End Sub
Sub WStrTreeClear(ByVal h As Long)
'delete all data
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
@p.root = WStrTreeFreeAllNodes(@p.root)
@p.count = 0
@p.cursor = 0
End If
End Sub
Function WStrTreeCount(ByVal h As Long) As Long
'get item count
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then Function = @p.count
End Function
Sub WStrTreeAdd(ByVal h As Long, ByRef key As WString, ByRef payload As WString, Opt ByVal update As Byte)
'add key and associated payload to tree : ignored if key already in tree
'if IsTure update then payload replaced if key exist
Register compare As Long
Local node As WStrTreeNodeT Ptr
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
@p.cursor = 0
If @p.count Then
node = @p.root
While node
Call Dword @p.compareCB Using WStrCompare(key, Peek$$(@node.@key.mem, @node.@key.count)) To compare
If compare > 0 Then
If @node.right Then
node = @node.right
Else
@node.right = WStrTreeAllocNode()
If @node.right Then
@node.@right.parent = node
WStrSet @node.@right.key, key
WStrSet @node.@right.payload, payload
Incr @p.count
WStrTreeCalcHeight(node)
WStrTreeBalanceBranch(p, node)
End If
Exit Sub
End If
ElseIf compare < 0 Then
If @node.left Then
node = @node.left
Else
@node.left = WStrTreeAllocNode()
If @node.left Then
@node.@left.parent = node
WStrSet @node.@left.key, key
WStrSet @node.@left.payload, payload
Incr @p.count
WStrTreeCalcHeight(node)
WStrTreeBalanceBranch(p, node)
End If
Exit Sub
End If
Else
'key already in tree
If IsTrue update Then WStrSet @node.payload, payload
Exit Sub
End If
Wend
Else
@p.root = WStrTreeAllocNode()
If @p.root Then
WStrSet @p.@root.key, key
WStrSet @p.@root.payload, payload
@p.count = 1
End If
End If
End If
End Sub
Function WStrTreeGet(ByVal h As Long, ByRef key As WString) As WString
'get key's associated payload if key in tree
Local node As WStrTreeNodeT Ptr
node = WStrTreeContains(h, key)
If node Then Function = WStrGet(@node.payload)
End Function
Sub WStrTreeSet(ByVal h As Long, ByRef key As WString, ByRef payload As WString)
'replace key's associated payload if key in tree
Local node As WStrTreeNodeT Ptr
node = WStrTreeContains(h, key)
If node Then WStrSet @node.payload, payload
End Sub
Function WStrTreeContains(ByVal h As Long, ByRef key As WString) As Long
'return zero if key not in tree
Register compare As Long
Local node As WStrTreeNodeT Ptr
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
@p.cursor = 0
node = @p.root
While node
Call Dword @p.compareCB Using WStrCompare(key, Peek$$(@node.@key.mem, @node.@key.count)) To compare
If compare > 0 Then
node = @node.right
ElseIf compare < 0 Then
node = @node.left
Else
Function = node
Exit Loop
End If
Wend
End If
End Function
Sub WStrTreeRemove(ByVal h As Long, ByRef key As WString)
'remove key/payload
Local node As WStrTreeNodeT Ptr
node = WStrTreeContains(h, key)
If node Then WStrTreeRemoveNode(h, node)
End Sub
'-----------------------------------
' Cursor
'-----------------------------------
Function WStrTreeFirst(ByVal h As Long) As Long
'move cursor to first key in tree : zero if fail
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
@p.cursor = @p.root
If @p.cursor Then
While @p.@cursor.left
@p.cursor = @p.@cursor.left
Wend
End If
Function = @p.cursor
End If
End Function
Function WStrTreeNext(ByVal h As Long) As Long
'move cursor to next key in tree : zero if fail
Local minRight As WStrTreeNodeT Ptr
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
If @p.cursor Then
minRight = WStrTreeMinRight(@p.cursor)
If @p.cursor <> minRight Then @p.cursor = minRight Else @p.cursor = WStrTreeParentGreater(@p.cursor)
Function = @p.cursor
End If
End If
End Function
Function WStrTreeLast(ByVal h As Long) As Long
'move cursor to last key in tree : zero if fail
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
@p.cursor = @p.root
If @p.cursor Then
While @p.@cursor.right
@p.cursor = @p.@cursor.right
Wend
End If
Function = @p.cursor
End If
End Function
Function WStrTreePrevious(ByVal h As Long) As Long
'move cursor to previous key in tree : zero if fail
Local maxLeft As WStrTreeNodeT Ptr
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
If @p.cursor Then
maxLeft = WStrTreeMaxLeft(@p.cursor)
If @p.cursor <> maxLeft Then @p.cursor = maxLeft Else @p.cursor = WStrTreeParentLesser(@p.cursor)
Function = @p.cursor
End If
End If
End Function
Function WStrTreeKey(ByVal h As Long) As WString
'get key at cursor position
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag And @p.cursor Then Function = WStrGet(@p.@cursor.key)
End Function
Function WStrTreePayload(ByVal h As Long) As WString
'get payload at cursor position
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag And @p.cursor Then Function = WStrGet(@p.@cursor.payload)
End Function
'-----------------------------------
' Store/Restore To/From String/File
'-----------------------------------
Function WStrTreeStore(ByVal h As Long) As String
'store tree to string
Local more As Long
Local key, payload As String
Local sb As Long : sb = StrBuildNew()
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
If @p.count And sb Then
StrBuildAdd sb, Mkl$(@p.count)
more = WStrTreeFirst(p)
While more
key = ChrToUtf8$(WStrTreeKey(p))
payload = ChrToUtf8$(WStrTreePayload(p))
StrBuildAdd sb, Mkl$(Len(key))
StrBuildAdd sb, key
StrBuildAdd sb, Mkl$(Len(payload))
StrBuildAdd sb, payload
more = WStrTreeNext(p)
Wend
Function = StrBuildGet(sb)
End If
End If
sb = StrBuildFree(sb)
End Function
Sub WStrTreeRestore(ByVal h As Long, ByVal stored As String)
'restore tree from string
Register i As Long
Local items, bytes As Long
Local key, payload As String
Local pl As Long Ptr
Local p As WStrTreeT Ptr : p = h
If p And @p.tag = %WStrTreeTag Then
WStrTreeClear(p)
If Len(stored) Then
pl = StrPtr(stored)
items = @pl : Incr pl
For i = 1 To items
bytes = @pl : Incr pl
key = Peek$(pl, bytes) : pl += bytes
bytes = @pl : Incr pl
payload = Peek$(pl, bytes) : pl += bytes
WStrTreeAdd p, Utf8ToChr$(key), Utf8ToChr$(payload)
Next i
End If
End If
End Sub
Sub WStrTreeFileStore(ByVal h As Long, ByVal file As WString)
'store tree to file
StrToFile file, WStrTreeStore(h)
End Sub
Sub WStrTreeFileRestore(ByVal h As Long, ByVal file As WString)
'restore tree from file
WStrTreeRestore h, StrFromFile(file)
End Sub
'-----------------------------------
' PRIVATE
'-----------------------------------
Function WStrTreeAllocNode() Private As Long
Local node As WStrTreeNodeT Ptr
node = MemAllocate(SizeOf(WStrTreeNodeT))
If node Then
@node.heightLeft = 1
@node.heightRight = 1
@node.key = WStrNew()
If @node.key = 0 Then Exit Function
@node.payload = WStrNew()
If @node.payload = 0 Then Exit Function
Function = node
End If
End Function
Function WStrTreeFreeNode(ByVal node As WStrTreeNodeT Ptr) Private As Long
If node Then
WStrFree(@node.key)
WStrFree(@node.payload)
MemFree(node)
End If
End Function
Function WStrTreeFreeAllNodes(ByVal node As WStrTreeNodeT Ptr) As Long 'don't make threadsafe
'free all nodes : return null
If node Then
WStrTreeFreeAllNodes(@node.left)
WStrTreeFreeAllNodes(@node.right)
WStrTreeFreeNode(node)
End If
End Function
Sub WStrTreeRemoveNode(ByVal p As WStrTreeT Ptr, ByVal node As WStrTreeNodeT Ptr) Private
Local nodeParent, swapNode As WStrTreeNodeT Ptr
If p And node Then
Decr @p.count
While @node.left Or @node.right
swapNode = IIf&(@node.heightLeft >= @node.heightRight, WStrTreeMaxLeft(node), WStrTreeMinRight(node))
If @p.root = swapNode Then @p.root = node
Swap @node.key, @swapNode.key
Swap @node.payload, @swapNode.payload
node = swapNode
Wend
If node = @p.root Then
WStrTreeClear(p)
Else
nodeParent = @node.parent
If nodeParent Then
If @nodeParent.left = node Then
@nodeParent.left = %null
Else
@nodeParent.right = %null
End If
'free node
node = WStrTreeFreeNode(node)
'balance tree
WStrTreeCalcHeight(nodeParent)
WStrTreeBalanceBranch(p, nodeParent)
End If
End If
End If
End Sub
Sub WStrTreeBalanceBranch(ByVal p As WStrTreeT Ptr, ByVal node As WStrTreeNodeT Ptr) Private
Register balance As Long
While node
balance = @node.heightRight - @node.heightLeft
If balance < -1 Then
node = WStrTreeRotateRight(p, node)
ElseIf balance > 1 Then
node = WStrTreeRotateLeft(p, node)
Else
node = @node.parent 'move up tree
End If
Wend
End Sub
Sub WStrTreeCalcHeight(ByVal node As WStrTreeNodeT Ptr) Private
While node
If @node.left Then
If @node.@left.heightLeft > @node.@left.heightRight Then
@node.heightLeft = @node.@left.heightLeft + 1
Else
@node.heightLeft = @node.@left.heightRight + 1
End If
Else
@node.heightLeft = 1
End If
If @node.right Then
If @node.@right.heightLeft > @node.@right.heightRight Then
@node.heightRight = @node.@right.heightLeft + 1
Else
@node.heightRight = @node.@right.heightRight + 1
End If
Else
@node.heightRight = 1
End If
node = @node.parent 'move up tree
Wend
End Sub
Function WStrTreeMaxLeft(ByVal node As WStrTreeNodeT Ptr) Private As Long
If node Then
If @node.left Then
node = @node.left
While @node.right
node = @node.right
Wend
End If
End If
Function = node
End Function
Function WStrTreeMinRight(ByVal node As WStrTreeNodeT Ptr) Private As Long
If node Then
If @node.right Then
node = @node.right
While @node.left
node = @node.left
Wend
End If
End If
Function = node
End Function
Function WStrTreeParentGreater(ByVal node As WStrTreeNodeT Ptr) Private As Long
If node Then
While @node.parent
If @node.@parent.left = node Then
'test node is hooked on parent's left
Function = @node.parent
Exit Function
Else
node = @node.parent 'move up branch
End If
Wend
End If
End Function
Function WStrTreeParentLesser(ByVal node As WStrTreeNodeT Ptr) Private As Long
If node Then
While @node.parent
If @node.@parent.right = node Then
'test node is hooked to parent's right
Function = @node.parent
Exit Function
Else
node = @node.parent 'move up branch
End If
Wend
End If
End Function
Function WStrTreeRotateLeft(ByVal p As WStrTreeT Ptr, ByVal node As WStrTreeNodeT Ptr) Private As Long
Local nodeParent, nodeRight, nodeRightLeft As WStrTreeNodeT Ptr
Local hookedLeft As Long
If p And node Then
nodeParent = @node.parent
If nodeParent And @nodeParent.left = node Then hookedLeft = %true
nodeRight = @node.right
If nodeRight Then
'see if promo node is heavy on hook side - fix
If @nodeRight.heightLeft > @nodeRight.heightRight Then
WStrTreeRotateRight(p, nodeRight)
nodeRight = @node.right
End If
nodeRightLeft = @nodeRight.left
'promote heavy side
@nodeRight.parent = nodeParent
If nodeParent = 0 Then
@p.root = nodeRight
Else
If hookedLeft Then
@nodeParent.left = nodeRight
Else
@nodeParent.right = nodeRight
End If
End If
'promote node's child on affected side
If nodeRightLeft = 0 Then
@node.right = 0
Else
@node.right = nodeRightLeft
@nodeRightLeft.parent = node
End If
'hook node
@node.parent = nodeRight
@nodeRight.left = node
WStrTreeCalcHeight(node)
Function = node
End If
End If
End Function
Function WStrTreeRotateRight(ByVal p As WStrTreeT Ptr, ByVal node As WStrTreeNodeT Ptr) Private As Long
Local nodeParent, pLeft, nodeLeftRight As WStrTreeNodeT Ptr
Local hookedLeft As Long
If p And node Then
nodeParent = @node.parent
If nodeParent And @nodeParent.left = node Then hookedLeft = %true
pLeft = @node.left
If pLeft Then
'see if promo node is heavy on hook side - fix
If @pLeft.heightRight > @pLeft.heightLeft Then
WStrTreeRotateLeft(p, pLeft)
pLeft = @node.left
End If
nodeLeftRight = @pLeft.right
'promote heavy side
@pLeft.parent = nodeParent
If nodeParent = 0 Then
@p.root = pLeft
Else
If hookedLeft Then
@nodeParent.left = pLeft
Else
@nodeParent.right = pLeft
End If
End If
'promote node's child on affected side
If nodeLeftRight = 0 Then
@node.left = 0
Else
@node.left = nodeLeftRight
@nodeLeftRight.parent = node
End If
'hook node
@node.parent = pLeft
@pLeft.right = node
WStrTreeCalcHeight(node)
Function = node
End If
End If
End Function
#EndIf '%WStrTree230816
#If Not %Def(%WStr230815)
%WStr230815 = 1
'WString Container
'accessed with long handle
'handle protected with hash tag
'may be in UDT as a Long
%WStrTag = -1731001151
%WStrItemSize = 2
Declare Function WStrCompare(ByRef a As WString, ByRef b As WString) As Long
'compare callback template
'a < b : return < 0
'a = b : return = 0
'a > b : return > 0
Type WStrT
tag As Long
count As Long
mem As Long
instances As Long
End Type
Function WStrNew() As Long
'allocate new instance : return handle
Local p As WStrT Ptr
p = MemAllocate(SizeOf(@p))
If p Then
@p.tag = %WStrTag
@p.instances = 1
Function = p
End If
End Function
Function WStrFree(ByVal h As Long) As Long
'must free handle before it goes out of scope : return null
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag Then
Decr @p.instances
If @p.instances = 0 Then
WStrClear p
MemFree(p)
End If
End If
End Function
Function WStrFreeIncr(ByVal h As Long) As Long
'increment instance count : return handle to same instance
'different handles to same instance modify same data
'all instances must be freed
'use or ignore
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag Then
Incr @p.instances
Function = p
End If
End Function
Function WStrCount(ByVal h As Long) As Long
'get character count
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag Then Function = @p.count
End Function
Sub WStrClear(ByVal h As Long)
'empty container
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag Then
@p.mem = MemFree(@p.mem)
@p.count = 0
End If
End Sub
Function WStrGet(ByVal h As Long) As WString
'get string
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag And @p.count Then Function = Peek$$(@p.mem, @p.count)
End Function
Sub WStrSet(ByVal h As Long, ByRef value As WString)
'set string
Local lenValue As Long : lenValue = Len(value)
Local p As WStrT Ptr : p = h
If p And @p.tag = %WStrTag Then
@p.count = 0
If @p.mem Then @p.mem = MemFree(@p.mem)
If lenValue Then
@p.mem = MemAllocate(lenValue * %WStrItemSize)
If @p.mem Then
@p.count = lenValue
Memory Copy StrPtr(value), @p.mem, lenValue * %WStrItemSize
End If
End If
End If
End Sub
Function WStrSetNew(ByRef value As WString) As Long
'allocate new instance : store string : return handle
Local h As Long
h = WStrNew()
WStrSet h, value
Function = h
End Function
Function WStrCompare(ByRef a As WString, ByRef b As WString) As Long
'string case sensitive compare callback
Function = Switch&(a < b, -1, a > b, 1) 'else zero, match
End Function
Function WStrCompareUCase(ByRef a As WString, ByRef b As WString) As Long
'string ignore calse compare callback
Local sa As WString : sa = UCase$(a)
Local sb As WString : sb = UCase$(b)
Function = Switch&(sa < sb, -1, sa > sb, 1) 'else zero, match
End Function
#EndIf '%WStr230815
#If Not %Def(%StrBuild230816)
%StrBuild230816 = 1
'String Builder
'any kind of binary data
'container accessed with handle
'handle protected with hash tag
%StrBuildTag = 2125516570
%StrBuildDefaultBuffer = 100000
%StrBuildItemSize = 1
Type StrBuildT
tag As Long
mem As Long
count As Long
max As Long
buffer As Long
instances As Long
End Type
Function StrBuildNew() As Long
'allocate new instance : return handle
Local p As StrBuildT Ptr
p = MemAllocate(SizeOf(@p))
If p Then
@p.tag = %StrBuildTag
@p.buffer = %StrBuildDefaultBuffer
@p.instances = 1
Function = p
End If
End Function
Function StrBuildFree(ByVal h As Long) As Long
'must free handle before it goes out of scope : return null
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag Then
Decr @p.instances
If @p.instances = 0 Then
StrBuildClear p
MemFree(p)
End If
End If
End Function
Sub StrBuildBuffer(ByVal h As Long, ByVal buffer As Long)
'change buffer size : default = 100,000 characters : about 1/10th expected
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag And buffer > 0 Then @p.buffer = buffer
End Sub
Sub StrBuildIncr(ByVal h As Long)
'increment instance count
'different handles to same instance modify same data
'all instances must be freed
'use or ignore
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag Then Incr @p.instances
End Sub
Function StrBuildCount(ByVal h As Long) As Long
'get character count
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag Then Function = @p.count
End Function
Sub StrBuildClear(ByVal h As Long)
'empty container
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag Then
@p.mem = MemFree(@p.mem)
@p.count = 0
@p.max = 0
End If
End Sub
Sub StrBuildAdd(ByVal h As Long, ByRef value As String)
'append string
Local currentCount, currentMax, newMax As Long
Local lenValue As Long : lenValue = Len(value)
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag Then
If lenValue Then
If lenValue > @p.max - @p.count Then
currentCount = @p.count
currentMax = @p.max
@p.count = 0
@p.max = 0
newMax = currentCount + lenValue + @p.buffer
@p.mem = MemReAllocate(@p.mem, newMax * %StrBuildItemSize)
If @p.mem = 0 Then Exit Sub
@p.count = currentCount
@p.max = newMax
End If
Memory Copy StrPtr(value), @p.mem + (@p.count * %StrBuildItemSize), lenValue * %StrBuildItemSize
@p.count += lenValue
End If
End If
End Sub
Function StrBuildGet(ByVal h As Long) As String
'get stored string
Local p As StrBuildT Ptr : p = h
If p And @p.tag = %StrBuildTag And @p.count Then Function = Peek$(@p.mem, @p.count)
End Function
#EndIf '%StrBuild230816
#If Not %Def(%FileUtilities230817)
%FileUtilities230817 = 1
' File Utilities
' public domain, use at own risk
' SDurham
Sub StrToFile(ByVal file As WString, ByVal s 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, s
Close f
End Sub
Function StrFromFile(ByVal file As WString) 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)
' 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) 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)
' 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) 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 '%FileUtilities230817
#If Not %Def(%Memory230815)
%Memory230815 = 1
Declare Function GlobalAlloc Lib "Kernel32.dll" Alias "GlobalAlloc" (ByVal uFlags As Dword, ByVal dwBytes As Dword) As Dword
Declare Function GlobalReAlloc Lib "Kernel32.dll" Alias "GlobalReAlloc" (ByVal hMem As Dword, ByVal dwBytes As Dword, ByVal uFlags As Dword) As Dword
Declare Function GlobalFree Lib "Kernel32.dll" Alias "GlobalFree" (ByVal hMem As Dword) As Dword
%GMEM_FIXED_ = &H0000
%GMEM_MOVEABLE_ = &H0002
%GMEM_ZEROINIT_ = &H0040
%GPTR_ = (%GMEM_ZEROINIT_ Or %GMEM_FIXED_)
Function MemAllocate(ByVal bytes As Long) As Long
If bytes Then Function = GlobalAlloc(ByVal %GPTR_, ByVal bytes)
End Function
Function MemReAllocate(ByVal h As Long, ByVal bytes As Long) As Long
If h And bytes Then
Function = GlobalReAlloc(ByVal h, ByVal bytes, ByVal %GMEM_MOVEABLE_ Or %GMEM_ZEROINIT_)
ElseIf bytes Then
Function = GlobalAlloc(ByVal %GPTR_, ByVal bytes)
ElseIf h Then
Function = GlobalFree(ByVal h)
End If
End Function
Function MemFree(ByVal h As Long) As Long
If h Then GlobalFree(ByVal h)
End Function
#EndIf '%Memory230815�
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\WString WString Tree.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Global gStringBuilder As IStringBuilderW
Sub AddLine(ByVal value As WString)
gStringBuilder.Add(value + $CrLf)
End Sub
%TestCount = 100000
Sub SampleCode()
Register i As Long
Local tree As Long
Local more As Long
Local stored As String
Local a() As WString
Local t As Double
Randomize
AddLine ""
AddLine "Function WStrTreeNew() As Long"
AddLine " allocate new container : return handle"
tree = WStrTreeNew()
AddLine ""
AddLine "Sub WStrTreeAdd(ByVal h As Long, ByRef key As WString, ByRef payload As WString, Opt ByVal update As Byte)"
AddLine " add key and associated payload to tree : ignored if key already in tree"
AddLine " if IsTure update then payload replaced if key exist"
AddLine " add few key/payload items"
WStrTreeAdd tree, "C", "ccc"
WStrTreeAdd tree, "B", "bbb"
WStrTreeAdd tree, "E", "eee"
WStrTreeAdd tree, "R", "rrr"
WStrTreeAdd tree, "Z", "zzz"
AddLine "--- Display Tree ---"
more = WStrTreeFirst(tree)
While more
AddLine "key = " + $Dq + WStrTreeKey(tree) + $Dq + " : payload = " + $Dq + WStrTreePayload(tree) + $Dq
more = WStrTreeNext(tree)
Wend
AddLine ""
AddLine "--- Traverse Tree in Reverse Order ---"
more = WStrTreeLast(tree)
While more
AddLine "key = " + $Dq + WStrTreeKey(tree) + $Dq + " : payload = " + $Dq + WStrTreePayload(tree) + $Dq
more = WStrTreePrevious(tree)
Wend
AddLine ""
AddLine "Function WStrTreeGet(ByVal h As Long, ByRef key As WString) As WString"
AddLine " get key's associated payload if key in tree"
AddLine "payload for 'E' = " + $Dq + WStrTreeGet(tree, "E") + $Dq
AddLine "payload for 'R' = " + $Dq + WStrTreeGet(tree, "R") + $Dq
AddLine "payload for 'X' = " + $Dq + WStrTreeGet(tree, "X") + $Dq
AddLine ""
AddLine "Sub WStrTreeSet(ByVal h As Long, ByRef key As WString, ByRef payload As WString)"
AddLine " replace key's associated payload if key in tree"
AddLine " replace payload for 'E' "
WStrTreeSet tree, "E", "eeeeeeeeeeeeeeeeeeeeeeee"
AddLine "--- Display Tree ---"
more = WStrTreeFirst(tree)
While more
AddLine "key = " + $Dq + WStrTreeKey(tree) + $Dq + " : payload = " + $Dq + WStrTreePayload(tree) + $Dq
more = WStrTreeNext(tree)
Wend
AddLine ""
AddLine "Function WStrTreeContains(ByVal h As Long, ByRef key As WString) As Long"
AddLine " return zero if key not in tree"
AddLine "tree contains 'A' = " + Format$(WStrTreeContains(tree, "A"))
AddLine "tree contains 'B' = " + Format$(WStrTreeContains(tree, "B"))
AddLine "tree contains 'C' = " + Format$(WStrTreeContains(tree, "C"))
AddLine "tree contains 'D' = " + Format$(WStrTreeContains(tree, "D"))
AddLine "tree contains 'E' = " + Format$(WStrTreeContains(tree, "E"))
AddLine ""
AddLine "Sub WStrTreeRemove(ByVal h As Long, ByRef key As WString)"
AddLine " remove key/payload"
AddLine " remove 'E'"
WStrTreeRemove tree, "E"
AddLine "--- Display Tree ---"
more = WStrTreeFirst(tree)
While more
AddLine "key = " + $Dq + WStrTreeKey(tree) + $Dq + " : payload = " + $Dq + WStrTreePayload(tree) + $Dq
more = WStrTreeNext(tree)
Wend
AddLine ""
AddLine "Function WStrTreeStore(ByVal h As Long) As String"
AddLine " store tree to string"
AddLine "Sub WStrTreeRestore(ByVal h As Long, ByVal stored As String)"
AddLine " restore tree from string"
AddLine "Sub WStrTreeFileStore(ByVal h As Long, ByVal file As WString)"
AddLine " store tree to file"
AddLine "Sub WStrTreeFileRestore(ByVal h As Long, ByVal file As WString)"
AddLine " restore tree from file"
AddLine " store tree to String"
stored = WStrTreeStore(tree)
AddLine " restore tree from String"
WStrTreeRestore tree, stored
stored = ""
AddLine " store tree to File"
WStrTreeFileStore tree, "Stored.tree"
AddLine " restore tree from File"
WStrTreeFileRestore tree, "Stored.tree"
Kill "Stored.tree"
AddLine "--- Display Tree After: Store/Restore To/From String/File ---"
more = WStrTreeFirst(tree)
While more
AddLine "key = " + $Dq + WStrTreeKey(tree) + $Dq + " : payload = " + $Dq + WStrTreePayload(tree) + $Dq
more = WStrTreeNext(tree)
Wend
WStrTreeClear tree
ReDim a(1 To %TestCount)
For i = 1 To %TestCount
a(i) = Format$(Rnd(-222222222, 222222222))
Next i
AddLine ""
AddLine "add "+Format$(%TestCount, "#,")+" random key/payload items to empty tree"
AddLine " may be some duplicates"
t = Timer
For i = 1 To %TestCount
WStrTreeAdd tree, a(i), a(i)
Next i
AddLine "Time = " + Format$(Timer - t, "000.000")
AddLine "Count = " + Format$(WStrTreeCount(tree), "#,")
AddLine ""
AddLine "search for "+Format$(%TestCount, "#,")+" keys in tree of " + Format$(WStrTreeCount(tree), "#,") + " items"
t = Timer
For i = 1 To %TestCount
If WStrTreeContains(tree, a(i)) = 0 Then
? "tree fail" : Exit For
End If
Next i
AddLine "Time = " + Format$(Timer - t, "000.000")
AddLine ""
AddLine "Function WStrTreeFree(ByVal h As Long) As Long"
AddLine " must free handle before it goes out of scope : return null"
tree = WStrTreeFree(tree)
AddLine ""
AddLine ""
Control Set Text gDlg, %TextBox, gStringBuilder.String
End Sub
Function PBMain()
gStringBuilder = Class "StringBuilderW"
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, %TextB
Source: PowerBasic Forum (https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/825803-wstring-avl-balanced-binary-search-tree)