In-String String & WString Hash Table

[Theo Gottwald]

Code Select Expand

' In-String String & WString Hash Table.
    ' Store and retrieve a Value using a unique Key.
    ' Key and Value may contain nulls.
    ' Not for heavy use.

    ' ((( The hash table exist entirely inside host string. )))
    ' May be passed are stored anywhere, remains intact; store in file, database, another string container, ...

    ' To delete or reset hash table, set string null; container$ = "".
    ' Doesn't need to be freed. Set host string null or let it go out of scope.

    ' Capacity can't be changed.
    ' Because of string manipulation overhead, a small capacity works best even on a few thousand items.

    ' The host string needs to be passed ByRef to stay current.
    ' A copy of the hash table string becomes a different instance.
    ' The original can be updated, original = copy.

    ' limited to a few thousand Key/Value items.

    ' add 1,000 key/values = 0.015seconds
    ' test existence of 1,000 keys = 0.015 seconds
    ' get 1,000 values = 0.016 seconds

    ' add 5,000 key/values = 0.248 seconds
    ' test existence of 5,000 keys = 0.295 seconds
    ' get 5,000 values = 0.047 seconds

#If Not %Def(%HostedStringHash230304)
    %HostedStringHash230304 = 1
    %SashCapacity = 150
    ' In-String String Hash Table
    ' Memory allocation is just a string.
    ' public domain, use at own risk
    ' SDurham
    Function SashCount(container$) ThreadSafe As Long
        ' get key count
        If SarrCount(container$) Then Function = Cvl(SarrGet(container$, 1))
    End Function
    Sub SashSet(container$, ByVal key As String, ByVal value As String) ThreadSafe
        ' add key and value to hash, value replaced if key exist
        ' key case sensitive
        ' key and value can contain nulls
        Register i As Long
        Local HashIndexArr$, hashIndex&, KeyArr$, KeyValArr$, KeyCount&
        If IsFalse SarrCount(container$) Then SashBuild(container$)
        HashIndexArr$ = SarrGet(container$, 2)
        hashIndex& = SashIndex(key)
        KeyArr$ = SarrGet(HashIndexArr$, hashIndex&)
        For i = 1 To SarrCount(KeyArr$)
            KeyValArr$ = SarrGet(KeyArr$, i)
            If key = SarrGet(KeyValArr$, 1) Then
                'key in hash : set value
                SarrSet KeyValArr$, 2, value
                SarrSet KeyArr$, i, KeyValArr$
                SarrSet HashIndexArr$, hashIndex&, KeyArr$
                SarrSet container$, 2, HashIndexArr$
                Exit Sub
            End If
        Next i
        'key not in hash
        KeyValArr$ = ""
        SarrAdd KeyValArr$, key
        SarrAdd KeyValArr$, value
        SarrAdd KeyArr$, KeyValArr$
        SarrSet HashIndexArr$, hashIndex&, KeyArr$
        KeyCount& = Cvl(SarrGet(container$, 1))
        Incr KeyCount&
        SarrSet container$, 1, Mkl$(KeyCount&)
        SarrSet container$, 2, HashIndexArr$
    End Sub
    Function SashGet(container$, ByVal key As String) ThreadSafe As String
        ' get Key's Value : null key if not in hash
        Register i As Long
        Local HashIndexArr$, hashIndex&, KeyArr$, KeyValArr$
        If SashCount(container$) Then
            HashIndexArr$ = SarrGet(container$, 2)
            hashIndex& = SashIndex(key)
            KeyArr$ = SarrGet(HashIndexArr$, hashIndex&)
            For i = 1 To SarrCount(KeyArr$)
                KeyValArr$ = SarrGet(KeyArr$, i)
                If key = SarrGet(KeyValArr$, 1) Then
                    Function = SarrGet(KeyValArr$, 2)
                    Exit Function
                End If
            Next i
        End If
    End Function
    Function SashHas(container$, ByVal key As String) ThreadSafe As Byte
        ' True/False if Key in hash
        Register i As Long
        Local HashIndexArr$, hashIndex&, KeyArr$, KeyValArr$
        If SashCount(container$) Then
            HashIndexArr$ = SarrGet(container$, 2)
            hashIndex& = SashIndex(key)
            KeyArr$ = SarrGet(HashIndexArr$, hashIndex&)
            For i = 1 To SarrCount(KeyArr$)
                KeyValArr$ = SarrGet(KeyArr$, i)
                If key = SarrGet(KeyValArr$, 1) Then
                    Function = 1
                    Exit Function
                End If
            Next i
        End If
    End Function
    Sub SashAx(container$, ByVal key As String) ThreadSafe
        ' delete Key and associated Value
        Register i As Long
        Local HashIndexArr$, hashIndex&, KeyArr$, KeyValArr$, KeyCount&
        If SashCount(container$) Then
            HashIndexArr$ = SarrGet(container$, 2)
            hashIndex& = SashIndex(key)
            KeyArr$ = SarrGet(HashIndexArr$, hashIndex&)
            For i = 1 To SarrCount(KeyArr$)
                KeyValArr$ = SarrGet(KeyArr$, i)
                If key = SarrGet(KeyValArr$, 1) Then
                    SarrDelete KeyArr$, i
                    SarrSet HashIndexArr$, hashIndex&, KeyArr$
                    SarrSet container$, 2, HashIndexArr$
                    KeyCount& = Cvl(SarrGet(container$, 1))
                    Decr KeyCount&
                    SarrSet container$, 1, Mkl$(KeyCount&)
                    Exit Sub
                End If
            Next i
        End If
    End Sub
    Sub SashBuild(container$) Private ThreadSafe
        ' PRIVATE: build hash tabel
        Register i As Long
        Local HashIndexArr$
        For i = 1 To %SashCapacity
            SarrAdd HashIndexArr$, ""
        Next i
        container$ = ""
        SarrAdd container$, Mkl$(0)
        SarrAdd container$, HashIndexArr$
    End Sub
    Function SashIndex(ByRef key As String) Private ThreadSafe As Long
        ' PRIVATE: get hash index from key
        Register i As Long
        Register total As Long
        Local result As Long
        Local p As Byte Ptr
        p = StrPtr(key)
        total = 123456
        For i = 0 To Len(key) - 1
            result = @p
            result += total
            Shift Left total, 4
            total += result
            Incr p
        Next i
        Function = Abs(total Mod (%SashCapacity - 1)) + 1
    End Function
#EndIf '%HostedStringHash230304

#If Not %Def(%HostedWStringHash230304)
    %HostedWStringHash230304 = 1
    ' In-String WString Hash Table
    ' Memory allocation is just a string.
    ' public domain, use at own risk
    ' SDurham
    Function WashCount(container$) ThreadSafe As Long
        'get key count
        Function = SashCount(container$)
    End Function
    Sub WashSet(container$, ByVal key As WString, ByVal value As WString) ThreadSafe
        ' add key and value to hash, value replaced if key exist
        ' key case sensitive
        ' key and value can contain nulls
        SashSet(container$, ChrToUtf8$(key), ChrToUtf8$(value))
    End Sub
    Function WashGet(container$, ByVal key As WString) ThreadSafe As WString
        ' get Key's Value : null key if not in hash
        Function = Utf8ToChr$(SashGet(container$, ChrToUtf8$(key)))
    End Function
    Function WashHas(container$, ByVal key As WString) ThreadSafe As Byte
        ' True/False if Key in hash
        Function = SashHas(container$, ChrToUtf8$(key))
    End Function
    Sub WashAx(container$, ByVal key As WString) ThreadSafe
        ' delete Key and associated Value
        SashAx(container$, ChrToUtf8$(key))
    End Sub
    Sub WashSetStr(container$, ByVal key As WString, ByVal value As String) ThreadSafe
        ' may be used to store another hash table or string array as the associated value
        SashSet(container$, ChrToUtf8$(key), value)
    End Sub
    Function WashGetStr(container$, ByVal key As WString) ThreadSafe As String
        ' may be used to get another hash table or string array stored as the associated value
        Function = SashGet(container$, ChrToUtf8$(key))
    End Function
#EndIf '%HostedWStringHash230304

#If Not %Def(%HostedStringArray230304)
    %HostedStringArray230304 = 1
    %HostedStringArrayTag = -1622479746
    ' String Array Stored in String
    ' Memory allocation is just a string.
    ' public domain, use at own risk
    ' SDurham
    Function SarrCount(container$) ThreadSafe As Long
        ' get item count
        If Len(container$) And Peek(Long, StrPtr(container$)) = %HostedStringArrayTag Then Function = Peek(Long, StrPtr(container$) + 4)
    End Function
    Sub SarrAdd(container$, ByVal value As String) ThreadSafe
        ' append value to end of array
        Local itemCount&
        itemCount& = SarrCount(container$)
        If itemCount& = 0 Then
            container$ = Mkl$(%HostedStringArrayTag) + Mkl$(1) + Mkl$(Len(value)) + value
        Else
            container$ += Mkl$(Len(value)) + value
            Poke Long, StrPtr(container$) + 4, itemCount& + 1
        End If
    End Sub
    Function SarrGet(container$, ByVal index As Long) ThreadSafe As String
        ' get value at one-based index
        Local itemCount&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                p += 4 + @p
            Wend
            Function = Peek$(p + 4, @p)
        End If
    End Function
    Sub SarrSet(container$, ByVal index As Long, ByVal value As String) ThreadSafe
        ' set value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1 + 4 + @p)
        End If
    End Sub
    Sub SarrInsert(container$, ByVal index As Long, ByVal value As String) ThreadSafe
        ' insert value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mkl$(Len(value)) + value + Mid$(container$, bytes& + 1)
            Poke Long, StrPtr(container$) + 4, itemCount& + 1
        End If
    End Sub
    Sub SarrDelete(container$, ByVal index As Long) ThreadSafe
        ' delete value at one-based index
        Local itemCount&, bytes&, itemCounter&
        Local p As Long Ptr
        itemCount& = SarrCount(container$)
        If Len(container$) And index > 0 And index <= itemCount& Then
            itemCounter& = 0
            bytes& = 8
            p = StrPtr(container$) + 8
            While itemCounter& < index - 1
                Incr itemCounter&
                bytes& += 4 + @p
                p += 4 + @p
            Wend
            container$ = Left$(container$, bytes&) + Mid$(container$, bytes& + 1 + 4 + @p)
            Poke Long, StrPtr(container$) + 4, itemCount& - 1
        End If
    End Sub
#EndIf '%HostedStringArray230304�

Test-Code:

Code Select Expand

#Option LargeMem32
#Compile Exe
#Dim All

#Include Once "..\Hosted String Hash.inc"

Function PBMain() As Long
    Local h&, outFile$, hprocess&
    h& = FreeFile
    outFile$ = Exe.Path$ + Exe.Name$ + ".txt"
    Kill outFile$
    Open outFile$ For Append As h&

    Local hash$

    Print# h&, "Sub SashSet(container$, ByVal key As String, ByVal value As String) ThreadSafe"
    Print# h&, "    add key and value to hash, value replaced if key exist"
    Print# h&, "    key case sensitive"
    Print# h&, "    key and value can contain nulls"
    Print# h&, "        add 'A', 'aaa'"
    SashSet hash$, "A", "aaa"
    Print# h&, "        add 'B', 'bbb'"
    SashSet hash$, "B", "bbb"
    Print# h&, "        add 'C', 'aaa'"
    SashSet hash$, "C", "ccc"

    Print# h&, ""
    Print# h&, "Function SashGet(container$, ByVal key As String) ThreadSafe As String"
    Print# h&, "    get Key's Value : null string if not in hash"
    Print# h&, "value for 'A' = " + $Dq + SashGet(hash$, "A") + $Dq
    Print# h&, "value for 'B' = " + $Dq + SashGet(hash$, "B") + $Dq
    Print# h&, "value for 'C' = " + $Dq + SashGet(hash$, "C") + $Dq
    Print# h&, "value for 'ZZZ' = " + $Dq + SashGet(hash$, "ZZZ") + $Dq

    Print# h&, ""
    Print# h&, "Function SashHas(container$, ByVal key As String) ThreadSafe As Byte"
    Print# h&, "    True/False if Key in hash"
    Print# h&, "hash has 'A' = "  Format$(SashHas(hash$, "A"))
    Print# h&, "hash has 'B' = "  Format$(SashHas(hash$, "B"))
    Print# h&, "hash has 'C' = "  Format$(SashHas(hash$, "C"))
    Print# h&, "hash has 'ZZZ' = "  Format$(SashHas(hash$, "ZZZ"))

    Print# h&, ""
    Print# h&, "Sub SashAx(container$, ByVal key As String) ThreadSafe "
    Print# h&, "    delete Key and associated Value"
    Print# h&, "        delete key 'B' "
    SashAx hash$, "B"
    Print# h&, "hash has 'A' = "  Format$(SashHas(hash$, "A"))
    Print# h&, "hash has 'B' = "  Format$(SashHas(hash$, "B"))
    Print# h&, "hash has 'C' = "  Format$(SashHas(hash$, "C"))
    Print# h&, "hash has 'ZZZ' = "  Format$(SashHas(hash$, "ZZZ"))

    Print# h&, ""
    Print# h&, ""

    Close h&
    Sleep 1
    hprocess& = Shell("notepad.exe " + outFile$, 1)
End Function�