Reasonably fast.
add 1,000,000 key/value items to empty hash table = 0.488 seconds
use key to get 1,000,000 values in hash table of 1,000,000 key/value items = 0.249 seconds
Can be stored/restored to/from String/File.
Added note: the key's associated value can be a UDT.
Key and value may contain nulls, any kind of binary data.
Source: Powerbasic Forum (https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/824573-string-hash-table)
'Public domain, use at own risk. SDurham
#If Not %Def(%Memory230424)
%Memory230424 = 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_NOCOMPACT_ = &H0010
%GMEM_NODISCARD_ = &H0020
%GMEM_ZEROINIT_ = &H0040
%GMEM_MODIFY_ = &H0080
%GMEM_DISCARDABLE_ = &H0100
%GMEM_NOT_BANKED_ = &H1000
%GMEM_SHARE_ = &H2000
%GMEM_DDESHARE_ = &H2000
%GMEM_NOTIFY_ = &H4000
%GMEM_LOWER_ = %GMEM_NOT_BANKED_
%GMEM_VALID_FLAGS_ = &H7F72
%GMEM_INVALID_HANDLE_ = &H08000
%GHND_ = (%GMEM_ZEROINIT_ Or %GMEM_MOVEABLE_)
%GPTR_ = (%GMEM_ZEROINIT_ Or %GMEM_FIXED_)
Function MemAllocate(ByVal bytes As Long) ThreadSafe As Long
If bytes Then Function = GlobalAlloc(ByVal %GPTR_, ByVal bytes)
End Function
Function MemReAllocate(ByVal h As Long, ByVal bytes As Long) ThreadSafe 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) ThreadSafe As Long
If h Then GlobalFree(ByVal h)
End Function
#EndIf '%Memory230424
#If Not %Def(%Str230424)
%Str230424 = 1
' String container that can be stored in UDT.
' public domain, use at own risk
' SDurham
%StrItemSize = 1
Type StrT
count As Long
mem As Long
End Type
Sub StrFinal(t As StrT) ThreadSafe
' must call before variable goes out of scope
StrClear t
End Sub
Sub StrClear(t As StrT) ThreadSafe
' empty container
t.count = 0
t.mem = MemFree(t.mem)
End Sub
Function StrCount(t As StrT) ThreadSafe As Long
' get character count
Function = t.count
End Function
Sub StrSet(t As StrT, ByVal value As String) ThreadSafe
' set string
Local lenValue As Long : lenValue = Len(value)
t.count = 0
If t.mem Then t.mem = MemFree(t.mem)
If lenValue Then
t.mem = MemAllocate(lenValue * %StrItemSize)
If t.mem = 0 Then Exit Sub
t.count = lenValue
Memory Copy StrPtr(value), t.mem, lenValue * %StrItemSize
End If
End Sub
Function StrGet(t As StrT) ThreadSafe As String
' get string
If t.count Then Function = Peek$(t.mem, t.count)
End Function
Function StrCompareCallback(ByVal a As String, ByVal b As String) ThreadSafe As Long
' string container case sensitive compare callback
Function = Switch&(a < b, -1, a > b, 1) 'else zero, match
End Function
Function StrCompareUCaseCallback(ByVal a As String, ByVal b As String) ThreadSafe As Long
' string container ignore calse compare callback
Local sa As String : sa = UCase$(a)
Local sb As String : sb = UCase$(b)
Function = Switch&(sa < sb, -1, sa > sb, 1) 'else zero, match
End Function
#EndIf '%Str230424
#If Not %Def(%StrBld230424)
%StrBld230424 = 1
' String Builder : all memory freed when StrBldGet() called
' add 1,000,000 one-character Strings = 0.094 seconds
' public domain, use at own risk
' SDurham
%StrBldItemsSize = 1
%StrBldBuffer = 100000
Type StrBldT
mem As Long
count As Long
max As Long
End Type
Function StrBldCount(t As StrBldT) ThreadSafe As Long
' get character count
Function = t.count
End Function
Sub StrBldAdd(t As StrBldT, ByRef value As String) ThreadSafe
' append string
Local currentCount, currentMax, newMax As Long
Local lenValue As Long : lenValue = Len(value)
If lenValue Then
If lenValue > t.max - t.count Then
currentCount = t.count
currentMax = t.max
t.count = 0
t.max = 0
newMax = currentCount + lenValue + %StrBldBuffer
t.mem = MemReAllocate(t.mem, newMax * %StrBldItemsSize)
If t.mem = 0 Then Exit Sub
t.count = currentCount
t.max = newMax
End If
Memory Copy StrPtr(value), t.mem + (t.count * %StrBldItemsSize), lenValue * %StrBldItemsSize
t.count += lenValue
End If
End Sub
Function StrBldGet(t As StrBldT) ThreadSafe As String
' get complete string and free all memory
If t.count Then Function = Peek$(t.mem, t.count)
t.mem = MemFree(t.mem)
t.count = 0
t.max = 0
End Function
#EndIf '%StrBld230424
#If Not %Def(%FileUtilities230424)
%FileUtilities230424 = 1
' File Utilities
' public domain, use at own risk
' SDurham
Sub StrToFile(ByVal file As WString, ByVal s As String) ThreadSafe
' store string to File
Local f As Long
If Len(file) = 0 Then Exit Sub
f = FreeFile
Open file For Binary As f
SetEof f
Put$ f, s
Close f
End Sub
Function StrFromFile(ByVal file As WString) ThreadSafe As String
' get file contents as string
Local f As Long
Local s As String
If IsFalse IsFile(file) Then Exit Function
f = FreeFile
Open file For Binary As f
Get$ f, Lof(f), s
Function = s
Close f
End Function
Sub WStrToFile(ByVal file As WString, ByVal s As WString) ThreadSafe
' store string to File
Local f As Long
If Len(file) = 0 Then Exit Sub
f = FreeFile
Open file For Binary As f
SetEof f
Put$$ f, s
Close f
End Sub
Function WStrFromFile(ByVal file As WString) ThreadSafe As WString
' get file contents as string
Local f As Long
Local s As WString
If IsFalse IsFile(file) Then Exit Function
f = FreeFile
Open file For Binary As f
Get$$ f, Lof(f), s
Function = s
Close f
End Function
Sub WStrToTextFile(ByVal file As WString, ByVal s As WString) ThreadSafe
' store string converted to UTF8 to File
StrToFile file, ChrToUtf8$(s)
End Sub
Function WStrFromTextFile(ByVal file As WString) As WString
' get file contents converted from UTF8
Function = Utf8ToChr$(StrFromFile(file))
End Function
Function WStrFromTextFileFixed(ByVal file As WString) ThreadSafe As WString
' get file contents converted from UTF8 fixing Unix line endings if any
Local s As WString
s = Utf8ToChr$(StrFromFile(file))
Replace $CrLf With $Lf In s
Replace $CrLf With $Lf In s
Replace $Cr With $Lf In s
Replace $Cr With $Lf In s
Replace $Lf With $CrLf In s
Function = s
End Function
#EndIf '%FileUtilities230424
#If Not %Def(%StrHash230424)
%StrHash230424 = 1
' String/String Key/Value Hash Table
' Value stored and retrieved using unique key.
' Key case sensitive.
' Key and value may contain nulls, any kind of binary data.
'
' add 1,000,000 key/value items to empty hash table = 0.488 seconds
' use key to get 1,000,000 values in hash table of 1,000,000 key/value items = 0.249 seconds
Type StrHashRecordT
key As StrT
value As StrT
next As StrHashRecordT Ptr
End Type
Type StrHashT
count As Long
capacity As Long
arr As Long Ptr
cursorIndex As Long
cursorRecord As StrHashRecordT Ptr
End Type
Sub StrHashCapacity(t As StrHashT, ByVal capacity As Long) ThreadSafe
' capacity must be set before use : about number of expected items
If capacity < 1 Then Exit Sub
t.arr = MemAllocate(capacity * 4)
If t.arr = 0 Then Exit Sub
t.capacity = capacity
End Sub
Sub StrHashFinal(t As StrHashT) ThreadSafe
' must call before variable goes out of scope to free memory
StrHashClear t
t.arr = MemFree(t.arr)
End Sub
Sub StrHashClear(t As StrHashT) ThreadSafe
' empty container
Register i As Long
Local record As StrHashRecordT Ptr
For i = 0 To t.capacity - 1
While t.@arr[i]
record = t.@arr[i]
t.@arr[i] = @record.next
StrFinal @record.key
StrFinal @record.value
record = MemFree(record)
Wend
t.count = 0
t.cursorIndex = -1
t.cursorRecord = 0
Next
End Sub
Function StrHashCoumt(t As StrHashT) ThreadSafe As Long
' get item count
Function = t.count
End Function
Function StrHashAdd(t As StrHashT, ByRef key As String, ByVal value As String) ThreadSafe As Byte
' add key and associated value to hash table : value may be UDT : fail if key already in table
Local keyIndex As Long
Local record As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then Exit Function
record = @record.next
Wend
record = MemAllocate(SizeOf(@record))
If record = 0 Then Exit Function
StrSet @record.key, key
StrSet @record.value, value
@record.next = t.@arr[keyIndex]
t.@arr[keyIndex] = record
Incr t.count
Function = 1
End Function
Function StrHashContains(t As StrHashT, ByRef key As String) ThreadSafe As Byte
' true/false key in hash table
Local keyIndex As Long
Local record As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then
Function = 1 : Exit Function
End If
record = @record.next
Wend
End Function
Function StrHashSet(t As StrHashT, ByRef key As String, ByVal value As String) ThreadSafe As Byte
' update key's associated value : fail if key not in hash table
Local keyIndex As Long
Local record As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then
StrSet @record.value, value
Function = 1 : Exit Function
End If
record = @record.next
Wend
End Function
Function StrHashGet(t As StrHashT, ByRef key As String) ThreadSafe As String
' get key's associated value : null if key not in hash table
Local keyIndex As Long
Local record As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then
Function = Peek$(@record.value.mem, @record.value.count)
Exit Function
End If
record = @record.next
Wend
End Function
Function StrHashGetPtr(t As StrHashT, ByRef key As String) ThreadSafe As Long
' if key's value is a UDT, return UDT pointer : use pointer to modify stored UDT : fail if key not in hash table or value null
Local keyIndex As Long
Local record As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then
Function = @record.value.mem
Exit Function
End If
record = @record.next
Wend
End Function
Function StrHashDelete(t As StrHashT, ByRef key As String) ThreadSafe As Byte
' delete key and associated value : fail if key not in hash table
Local keyIndex As Long
Local record, previousRecord As StrHashRecordT Ptr
If t.capacity = 0 Then Exit Function
keyIndex = StrHashKeyIndex(key, t.capacity)
record = t.@arr[keyIndex]
While record
If Peek$(@record.key.mem, @record.key.count) = key Then
StrFinal @record.key
StrFinal @record.value
If previousRecord Then @previousRecord.next = @record.next Else t.@arr[keyIndex] = @record.next
record = MemFree(record)
Decr t.count
Function = 1
Exit Function
End If
previousRecord = record
record = @record.next
Wend
End Function
Function StrHashFirst(t As StrHashT) ThreadSafe As Byte
' move cursor to first key in hash table : true/false success
Register i As Long
t.cursorIndex = -1
t.cursorRecord = 0
For i = 0 To t.capacity - 1
If t.@arr[i] Then
t.cursorIndex = i
t.cursorRecord = t.@arr[i]
Function = 1
Exit Function
End If
Next i
End Function
Function StrHashNext(t As StrHashT) ThreadSafe As Byte
' move cursor to next key in hash table : true/false success
Register i As Long
If t.cursorIndex > -1 And t.cursorIndex < t.capacity And t.cursorRecord Then
If t.@cursorRecord.next Then
t.cursorRecord = t.@cursorRecord.next
Function = 1
Exit Function
Else
t.cursorRecord = 0
For i = t.cursorIndex + 1 To t.capacity - 1
If t.@arr[i] Then
t.cursorIndex = i
t.cursorRecord = t.@arr[i]
Function = 1
Exit Function
End If
Next i
End If
End If
End Function
Function StrHashKey(t As StrHashT) ThreadSafe As String
' get key at cursor position : null if cursor invalid
If t.cursorIndex > -1 And t.cursorIndex < t.capacity And t.cursorRecord Then
Function = StrGet(t.@cursorRecord.key)
End If
End Function
Function StrHashValue(t As StrHashT) ThreadSafe As String
' get value at cursor position : null if cursor invalid
If t.cursorIndex > -1 And t.cursorIndex < t.capacity And t.cursorRecord Then
Function = StrGet(t.@cursorRecord.value)
End If
End Function
Function StrHashValuePtr(t As StrHashT) ThreadSafe As Long
' if value is as stored UDT, get pointer to stored UDT : null if cursor invalid or value null
If t.cursorIndex > -1 And t.cursorIndex < t.capacity And t.cursorRecord Then
Function = t.@cursorRecord.value.mem
End If
End Function
Function StrHashStore(t As StrHashT) ThreadSafe As String
' store hash table to String
Local sb As StrBldT
Local more As Byte
Local key, value As String
StrBldAdd sb, Mkl$(t.capacity)
StrBldAdd sb, Mkl$(t.count)
more = StrHashFirst(t)
While IsTrue more
key = StrHashKey(t)
value = StrHashValue(t)
StrBldAdd sb, Mkl$(Len(key))
StrBldAdd sb, key
StrBldAdd sb, Mkl$(Len(value))
StrBldAdd sb, value
more = StrHashNext(t)
Wend
Function = StrBldGet(sb)
End Function
Sub StrHashRestore(t As StrHashT, ByVal stored As String) ThreadSafe
' restore hash table from String
Register i As Long
Local capacity, items, characters As Long
Local p As Long Ptr
Local key, value As String
StrHashClear t
If Len(stored) Then
p = StrPtr(stored)
capacity = @p : Incr p
items = @p : Incr p
If capacity And items Then
StrHashFinal t
StrHashCapacity t, capacity
For i = 1 To items
characters = @p : Incr p
key = Peek$(p, characters) : p += characters
characters = @p : Incr p
value = Peek$(p, characters) : p += characters
StrHashAdd(t, key, value)
Next i
End If
End If
End Sub
Sub StrHashFileStore(t As StrHashT, ByVal file As WString) ThreadSafe
' store hash table to File
StrToFile file, StrHashStore(t)
End Sub
Sub StrHashFileRestore(t As StrHashT, ByVal file As WString) ThreadSafe
' restore hash table to File
StrHashRestore t, StrFromFile(file)
End Sub
Function StrHashKeyIndex(ByRef key As String, ByVal capacity As Long) Private ThreadSafe As Long
' get key's hash code index
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 capacity)
End Function
#EndIf '%StrHash230424�