WString AVL Balanced Binary Search Tree

[Theo Gottwald]

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.

Code Select Expand

'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�


Code Select Expand

#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