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