Today, 01:29 AM
(This post was last modified: Today, 02:22 AM by Stanley Durham.)
find 100,000 random keys = 0.004 seconds
find 1,000,000 random keys = 0.112 seconds
find 5,000,000 random keys = 0.900 seconds
A unique key, WString, is used to store and retrieve a payload value, Object.
Key is case sensitive.
Property Set Capacity(ByVal value As Long), about number of expected items.
Can Store/Restore To/From File. To use that you need to provide callbacks. One to pack the object into a String and another to restore the object from a String.
Declare Function ObjectStoreCallback(o As IUnknown) As String
Declare Function ObjectRestoreCallback(ByRef stored As String) As IUnknown
When you implement the callbacks, use the actual “Interface” instead of “IUnknown.”
INC has no dependencies.
comments
Very Fast WString /Object Hash Table (Comments)
find 1,000,000 random keys = 0.112 seconds
find 5,000,000 random keys = 0.900 seconds
A unique key, WString, is used to store and retrieve a payload value, Object.
Key is case sensitive.
Property Set Capacity(ByVal value As Long), about number of expected items.
Can Store/Restore To/From File. To use that you need to provide callbacks. One to pack the object into a String and another to restore the object from a String.
Declare Function ObjectStoreCallback(o As IUnknown) As String
Declare Function ObjectRestoreCallback(ByRef stored As String) As IUnknown
When you implement the callbacks, use the actual “Interface” instead of “IUnknown.”
INC has no dependencies.
Code:
'ObjectHash.inc
'Public domain, use at own risk. SDurham
#If Not %Def(%OHash250808)
%OHash250808 = 1
Declare Function ObjectStoreCallback(o As IUnknown) As String
'store object's data in a String and return the String
'when you implement the callback, replace IUnknown with the actual interface
Declare Function ObjectRestoreCallback(ByRef stored As String) As IUnknown
'restore object's data and return new instance
'when you implement the callback, replace IUnknown with the actual interface
Type WStrT
mem As Word Ptr
count As Long
End Type
Type OHashNodeT
key As WStrT
value As Long
next As OHashNodeT Ptr
End Type
Type StrBuildT
mem As Long
count As Long
max As Long
End Type
Class OHashC
'Key/Value WString/Object Hash Table
'value stored and retrieved using unique key
'key case sensitive
Instance mCapacity As Long
Instance mCount As Long
Instance mArr() As Long
Instance mIndex As Long
Instance mNode As OHashNodeT Ptr
Instance mStore As Long
Instance mRestore As Long
Class Method Create()
mCapacity = 30 'default capacity
ReDim mArr(0 To mCapacity - 1)
End Method
Class Method Destroy()
Me.ClearMe()
Erase mArr()
End Method
Interface OHashI : Inherit IUnknown
Property Set Capacity(ByVal value As Long)
'about number of expected items : hash table must be empty
If mCount = 0 And value > 0 Then
mCapacity = value
ReDim mArr(0 To mCapacity - 1)
End If
End Property
Method Storage(ByVal storeCB As Long, ByVal restoreCB As Long)
'store and restore callbacks must be set to call Stor/Restore methods
If storeCB And restoreCB Then
mStore = storeCB : mRestore = restoreCB
End If
End Method
Method Clear()
'empty container
Me.ClearMe()
End Method
Property Get Count() As Long
'get item count
Property = mCount
End Property
Method Set(ByRef key As WString, value As IUnknown)
'add key and associated value : key added if not in hash table
Local index, keymem, keylen As Long
Local node As OHashNodeT Ptr
If IsObject(value) Then
keymem = StrPtr(key)
keylen = Len(key)
index = WStrHashIndex(keymem, keylen, mCapacity)
node = mArr(index)
While node
If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then
@node.value = Me.FreeObj(@node.value)
@node.value = Me.LongFromObj(value)
Exit Method
End If
node = @node.next
Wend
'key not in hash table
node = MemAlloc(SizeOf(@node))
If node Then
WStrSet @node.key, key
@node.value = Me.LongFromObj(value)
@node.next = mArr(index)
mArr(index) = node
Incr mCount
End If
End If
End Method
Method Get(ByRef key As WString) As IUnknown
'get key's associated value : null if key not in hash table
Local o As IUnknown
Local node As OHashNodeT Ptr
node = Me.Contains(key)
If node Then
o = Me.ObjFromLong(@node.value)
Method = o
End If
End Method
Method Contains(ByRef key As WString) As Long
'true/false if key in hash table
Local keymem, keylen As Long
Local node As OHashNodeT Ptr
If mCount Then
keymem = StrPtr(key)
keylen = Len(key)
node = mArr(WStrHashIndex(keymem, keylen, mCapacity))
While node
If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then
Method = node : Exit Method
End If
node = @node.next
Wend
End If
End Method
Method Delete(ByRef key As WString)
'delete key and associated value
Local index, keymem, keylen As Long
Local node, prev As OHashNodeT Ptr
If mCount Then
keymem = StrPtr(key)
keylen = Len(key)
index = WStrHashIndex(keymem, keylen, mCapacity)
node = mArr(index)
While node
If WStrEqual(keymem, keylen, @node.key.mem, @node.key.count) Then
If prev Then
@prev.next = @node.next
Else
mArr(index) = @node.next
End If
node = Me.FreeNode(node)
Decr MCount
Exit Method
End If
node = @node.next
Wend
End If
End Method
Method Start()
'reset cursor to start
mIndex = -1 : mNode = 0
End Method
Method Each() As Long
'move cursor to next key in hash table : true/false success
Register i As Long
If mCount Then
If mNode And @mNode.next Then
mNode = @mNode.next
Method = 1 : Exit Method
Else
mNode = 0
For i = mIndex + 1 To mCapacity - 1
If mArr(i) Then
mIndex = i
mNode = mArr(i)
Method = 1 : Exit Method
End If
Next i
End If
End If
mIndex = -1 : mNode = 0
End Method
Method Key() As WString
'get key at cursor position : null if cursor invalid
If mNode Then Method = WStrGet(@mNode.key)
End Method
Method Value() As IUnknown
'get value at cursor position : null if cursor invalid
If mNode Then Method = Me.ObjFromLong(@mNode.value)
End Method
Method Store() As String
'store container as String
Local key, s As String
Local value As IUnknown
Local sb As StrBuildT
If mCount And mStore Then
StrBuildPush sb, Mkl$(mCount)
Me.Start()
While Me.Each()
key = ChrToUtf8$(Me.Key())
value = Me.Value()
If IsObject(value) Then
Call Dword mStore Using ObjectStoreCallback(value) To s
StrBuildPush sb, Mkl$(Len(key))
StrBuildPush sb, key
StrBuildPush sb, Mkl$(Len(s))
StrBuildPush sb, s
End If
Wend
Method = StrBuildPop(sb)
End If
End Method
Method Restore(ByRef stored As String)
'restore container from String
Register i As Long
Local items, bytes As Long
Local key, s As String
Local o As IUnknown
Local p As Long Ptr
Me.ClearMe()
If mRestore And Len(stored) Then
p = StrPtr(stored)
items = @p : Incr p
For i = 1 To items
bytes = @p : Incr p
key = Peek$(p, bytes) : p += bytes
bytes = @p : Incr p
s = Peek$(p, bytes) : p += bytes
Call Dword mRestore Using ObjectRestoreCallback(s) To o
Me.Set(Utf8ToChr$(key), o)
Next i
End If
End Method
Method FileStore(ByVal file As WString)
'store container to File
If Len(file) And mStore Then Me.FilePut(file, Me.Store())
End Method
Method FileRestore(ByVal file As WString)
'restore container from File
If IsFile(file) And mRestore Then Me.Restore(Me.FileGet(file))
End Method
End Interface
Class Method ClearMe()
Register i As Long
Local node As OHashNodeT Ptr
For i = 0 To mCapacity - 1
While mArr(i)
node = mArr(i)
mArr(i) = @node.next
Me.FreeNode(node)
Wend
Next i
mCount = 0
End Method
Class Method FreeNode(ByVal node As OHashNodeT Ptr) As Long
If node Then
WStrFinal @node.key
@node.value = Me.FreeObj(@node.value)
MemFree(node)
End If
End Method
Class Method LongFromObj(o As IUnknown) As Long
If IsObject(o) Then
o.AddRef()
Method = Peek(Long, VarPtr(o))
End If
End Method
Class Method ObjFromLong(ByVal h As Long) As IUnknown
Local o As IUnknown
If h Then
Poke Long, VarPtr(o), h
o.AddRef()
Method = o
End If
End Method
Class Method FreeObj(ByVal h As Long) As Long
Local o As IUnknown
If h Then
Poke Long, VarPtr(o), h
o = Nothing
End If
End Method
Class Method FilePut(ByVal file As WString, ByRef value As String)
Local f As Long
If Len(file) = 0 Then Exit Method
f = FreeFile
Open file For Binary As f
SetEof f
Put$ f, value
Close f
End Method
Class Method FileGet(ByVal file As WString) As String
Local f As Long, value As String
If IsFalse IsFile(file) Then Exit Method
f = FreeFile
Open file For Binary As f
Get$ f, Lof(f), value
Close f
Method = value
End Method
End Class
#EndIf '%OHash250808
#If Not %Def(%WStr250808)
%WStr250808 = 1
'----------------------------------------------------------------------
'WString Container = Word Array
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
%WrdSize = 2
Type WStrT
mem As Word Ptr
count As Long
End Type
'----------------------------------------------------------------------
Sub WStrFinal(t As WStrT)
'call before variable gores out of scope to free memory
WStrClear t
End Sub
'----------------------------------------------------------------------
Sub WStrClear(t As WStrT)
'empty container
t.mem = MemFree(t.mem)
t.count = 0
End Sub
'----------------------------------------------------------------------
Function WStrCount(t As WStrT) As Long
'get character count
Function = t.count
End Function
'----------------------------------------------------------------------
Function WStrGet(t As WStrT) As WString
'get value
If t.mem Then Function = Peek$$(t.mem, t.count)
End Function
'----------------------------------------------------------------------
Macro WStrGetM(t) = Peek$$(t.mem, t.count)
'----------------------------------------------------------------------
Sub WStrSet(t As WStrT, ByRef value As WString)
'set value
Local characters As Long
t.mem = MemFree(t.mem)
t.count = 0
characters = Len(value)
If characters Then
t.mem = MemAlloc(characters * %WrdSize)
If t.mem Then
Memory Copy StrPtr(value), t.mem, characters * %WrdSize
t.count = characters
End If
End If
End Sub
'----------------------------------------------------------------------
#EndIf '%WStr250808
#If Not %Def(%WStrHash250808)
%WStrHash250808 = 1
'----------------------------------------------------------------------
'WString Hash Index
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
Function WStrHashIndex(ByVal keymem As Word Ptr, ByVal keylen As Long, ByVal capacity As Long) As Long
'get key's hash index position
Register i As Long
Register total As Long
Local temp As Long
If keymem Then
For i = 0 To keylen - 1
temp += @keymem[i] + total
Shift Left total, 8
total += temp
Next i
Function = Abs(total Mod capacity)
End If
End Function
'----------------------------------------------------------------------
#EndIf '%WStrHash250808
#If Not %Def(%WStrEqual250808)
%WStrEqual250808 = 1
'----------------------------------------------------------------------
Function WStrEqual(ByVal memA As Word Ptr, ByVal lenA As Long, ByVal memB As Word Ptr, ByVal lenB As Long) As Long
'true/false if two strings equal
Register i As Long
If memA And memB And lenA = lenB Then
For i = 0 To lenA - 1
If @memA[i] <> @memB[i] Then Exit Function
Next i
Function = 1
End If
End Function
'----------------------------------------------------------------------
#EndIf '%WStrEqual250808
#If Not %Def(%StrBuild250811)
%StrBuild250811 = 1
'----------------------------------------------------------------------
'String Builder
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
%BytSize = 1
%StrBuildBufferMax = 5000000
'----------------------------------------------------------------------
Type StrBuildT
mem As Long
count As Long
max As Long
End Type
'----------------------------------------------------------------------
Sub StrBuildPush(t As StrBuildT, ByVal value As String)
'append value
Local strlen, currentcount, buffer, newmax As Long
strlen = Len(value)
If strlen Then
If strlen > t.max - t.count Then
currentcount = t.count : t.count = 0 : t.max = 0
buffer = Max&(1, 2 * currentcount)
buffer = Min&(buffer, %StrBuildBufferMax)
newmax = currentcount + buffer + strlen
t.mem = MemReAlloc(t.mem, newmax * %BytSize)
If t.mem = 0 Then Exit Sub
t.count = currentcount : t.max = newmax
End If
Memory Copy StrPtr(value), t.mem + (t.count * %BytSize), strlen * %BytSize
t.count += strlen
End If
End Sub
'----------------------------------------------------------------------
Function StrBuildPop(t As StrBuildT) As String
'get whole string : free memory
If t.mem And t.count Then Function = Peek$(t.mem, t.count)
t.mem = MemFree(t.mem)
t.count = 0
t.max = 0
End Function
'----------------------------------------------------------------------
#EndIf '%StrBuild250811
#If Not %Def(%Memory230925)
%Memory230925 = 1
'----------------------------------------------------------------------
'Memory Allocation
'Public domain, use at own risk. SDurham
'----------------------------------------------------------------------
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
%MEMFIXED = &H0000 : %MEMMOVEABLE = &H0002 : %MEMZEROINIT = &H0040 : %MEMGPTR = (%MEMZEROINIT Or %MEMFIXED)
'----------------------------------------------------------------------
Function MemAlloc(ByVal bytes As Long) As Long
'allocate memory
If bytes Then Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
End Function
'----------------------------------------------------------------------
Function MemReAlloc(ByVal hMem As Long, ByVal bytes As Long) As Long
'reallocate new size
If hMem And bytes Then
Function = GlobalReAlloc(ByVal hMem, ByVal bytes, ByVal %MEMMOVEABLE Or %MEMZEROINIT)
ElseIf bytes Then
Function = GlobalAlloc(ByVal %MEMGPTR, ByVal bytes)
ElseIf hMem Then
Function = GlobalFree(ByVal hMem)
End If
End Function
'----------------------------------------------------------------------
Function MemFree(ByVal hMem As Long) As Long
'free memory
If hMem Then GlobalFree(ByVal hMem)
End Function
'----------------------------------------------------------------------
#EndIf '%Memory230925Code:
'ObjectHash.bas
#Option LargeMem32
#Dim All
#Compile Exe
#Include Once "WIN32API.INC"
#Include Once "..\ObjectHash.inc"
%TextBox = 101
%BtnID = 102
Global gDlg As Long
Global gBuild As IStringBuilderW
Sub SS(ByVal value As WString)
gBuild.Add(value + $CrLf)
End Sub
Class TestC
Instance mX As Long
Interface TestI : Inherit IUnknown
Property Get X() As Long
Property = mX
End Property
Property Set X(ByVal value As Long)
mX = value
End Property
Property Get Str() As WString
Property = Format$(mX)
End Property
End Interface
End Class
Function TestStore(o As TestI) As String
'store callback
'store object's data in a String and return the String
'when you implement the callback, replace IUnknown with the actual interface
If IsObject(o) Then Function = Mkl$(o.X)
End Function
Function TestRestore(ByRef stored As String) As TestI
'restore callback
'restore object's data and return new instance
'when you implement the callback, replace IUnknown with the actual interface
Local o As TestI : o = Class "TestC"
o.X = Cvl(stored)
Function = o
End Function
Sub SampleCode()
Register i As Long
Local hash As OHashI : hash = Class "OHashC"
Local o As TestI : o = Class "TestC"
Local stored As String
Local a() As WString
Local d As Double
Local testcount As Long : testcount = 100000 'can change
Randomize
MousePtr 11
Control Set Text gDlg, %TextBox, ""
SS ""
SS "Property Set Capacity(ByVal value As Long)"
hash.capacity = testcount
SS ""
SS "Method Storage(ByVal storeCB As Long, ByVal restoreCB As Long)"
hash.Storage(CodePtr(TestStore), CodePtr(TestRestore))
SS ""
SS "Method Add(ByRef key As WString, value As IUnknown) As Long"
SS "add key/value items"
For i = 65 To 69
o = Class "TestC" : o.X = i
hash.Set(Chr$$(i), o)
Next i
hash.Start()
While hash.Each()
o = hash.Value()
If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str
Wend
SS ""
SS "change value for key C"
o = Class "TestC" : o.X = 4444
hash.Set("C", o)
hash.Start()
While hash.Each()
o = hash.Value()
If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str
Wend
SS ""
SS "Method Get(ByRef key As WString) As IUnknown"
SS "get object to change value for key C"
o = hash.Get("C") : If IsObject(o) Then o.X = 999999999
hash.Start()
While hash.Each()
o = hash.Value()
If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str
Wend
SS ""
SS "Method Contains(ByRef key As WString)"
SS "hash table contains key B = " + Format$(hash.Contains("B"))
SS "hash table contains key E = " + Format$(hash.Contains("E"))
SS "hash table contains key ZZZ = " + Format$(hash.Contains("ZZZ"))
SS ""
SS "Method Delete(ByRef key As WString)"
SS "delete key C"
hash.Delete("C")
hash.Start()
While hash.Each()
o = hash.Value()
If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str
Wend
SS ""
SS "Method Store() As String"
stored = hash.Store()
SS "Method Restore(ByRef stored As String)"
hash.Restore(stored)
SS "Method FileStore(ByVal file As String)"
hash.FileStore("Stored.hash")
SS "Method FileRestore(ByVal file As String)"
hash.FileRestore("Stored.hash")
Kill "Stored.hash"
hash.Start()
While hash.Each()
o = hash.Value()
If IsObject(o) Then SS "key = " + $Dq + hash.Key() + $Dq + " | value = " + o.Str
Wend
ReDim a(1 To testcount)
For i = 1 To testcount
a(i) = RandomString()
Next i
SS ""
SS "add "+Format$(testcount,"#,")+" random key/value items"
hash.Clear()
d = Timer
For i = 1 To testcount
o = Class "TestC" : o.X = i
hash.Set(a(i), o)
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS "Count = " + Format$(hash.Count, "#,") + " duplicate keys not allowed"
SS ""
SS "find "+Format$(testcount,"#,")+" random keys"
d = Timer
For i = 1 To testcount
If hash.Contains(a(i)) = 0 Then
? "hash table fail" : Exit For
End If
Next i
SS "Time = " + Format$(Timer - d, "000.000")
SS ""
SS ""
Control Set Text gDlg, %TextBox, gBuild.String
gBuild.Clear
MousePtr 1
End Sub
Function RandomString() As String
Register i As Long
Local s As String
For i = 1 To Rnd(5, 8)
Select Case As Const Rnd(1, 2)
Case 1 : s += Chr$(Rnd(65, 90))
Case 2 : s += Chr$(Rnd(97, 122))
End Select
Next i
Function = s
End Function
Function PBMain()
gBuild = Class "StringBuilderW"
Dialog Default Font "courier new", 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
SendMessageW(GetDlgItem(gDlg, %TextBox), %EM_SETLIMITTEXT, 4000000, 0)
Dialog Show Modeless gDlg, Call DlgCB
While IsWin(gDlg)
Dialog DoEvents
Wend
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 /= 7
clientH /= 4
Dialog Set Loc gDlg, clientW / 2, clientH / 7
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 = 1 : buttonW = 30 : buttonH = 10
fromLeft = clientW - marg - marg - buttonW
fromBottom = clientH - marg - 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, %TextBox, marg, marg
End Subcomments
Very Fast WString /Object Hash Table (Comments)