To turbo charge the speed of my Dictionary code, I am maintaining the Dictionary with a sorted and uppercase Key property. Now we only have to use a Binary search to lookup values to see if a Key already exists or not. This should save loads of time! Also added file Load and Save Dictionary abilities.
Would like to compare with @TempodiBasic and @madscijr but what data set are you testing?
Code: (Select All)
Option _Explicit ' Dictionary 3
' b+ remake of TempodiBasic post 2021-04-06
' ref: https://www.qb64.org/forum/index.php?topic=3786.msg131448#msg131448
' 2021-04-07 add some bells and whistles
' 2023-04-11 add Find for faster actions, add load and save to file
Type Dictionary
K As String ' keys all caps for faster searches
V As String
End Type
ReDim MyDict(1 To 1) As Dictionary ' use ubound of array to tell how many values we have
' This code checks all the stuff Dictionary 2 did
' make some new pairs
Print "Show empty MyDict at start of this demo:"
ShowDict MyDict()
Print "Add a KV pair:"
AddModDictionary MyDict(), "mammals", "Cats"
ShowDict MyDict()
Print "Add a KV pair:"
AddModDictionary MyDict(), "trees", "Oak"
ShowDict MyDict()
Print "Add a KV pair:"
AddModDictionary MyDict(), "fish", "Bass"
ShowDict MyDict()
Print "Swap Dogs for Cats in mammals:"
AddModDictionary MyDict(), "mammals", "Dogs"
ShowDict MyDict()
Print "Check current mammals:"
Print "What is current mammal ? answer: "; GetValue$(MyDict(), "mammals")
Print "Remove mammals:"
RemoveKV MyDict(), "mammals"
ShowDict MyDict()
Print "Bring mammals back with Horses AND Dogs,Cats:"
AddAppendDictionary MyDict(), "Mammals", "Horses"
AddAppendDictionary MyDict(), "mammals", "Cats,Dogs"
ShowDict MyDict()
Print "Remove Cats from mammals:"
RemoveValue MyDict(), "mammals", "Cats"
ShowDict MyDict()
Print "Remove Horses from mammals:"
RemoveValue MyDict(), "mammals", "Horses"
ShowDict MyDict()
Print "Remove Unicorns from mammals:"
RemoveValue MyDict(), "mammals", "Unicorns"
ShowDict MyDict()
Print "And finally wipe out mammals again by removing dogs:"
RemoveValue MyDict(), "mammals", "Dogs"
ShowDict MyDict()
' all above seems to work how bout new subs?
Print "Test Save and Load of the Dictionary:"
SaveDictionary MyDict(), "My Dictionary.txt"
_Delay .25
LoadDictionary MyDict(), "My Dictionary.txt"
ShowDict MyDict()
' good
Sub SaveDictionary (Dict() As Dictionary, pathedFileName$)
Dim As Long i
Open pathedFileName$ For Output As #1 ' 2 line format key then value list
For i = 1 To UBound(Dict)
Print #1, Dict(i).K
If _Trim$(Dict(i).V) = "" Then Print #1, " " Else Print #1, _Trim$(Dict(i).V)
Next
Close #1
End Sub
Sub LoadDictionary (Dict() As Dictionary, pathedFileName$)
Dim As Long ub ' will track actual amout of items
ReDim Dict(1 To 1) As Dictionary
Dict(1).K = "": Dict(1).V = "" ' sometimes var string UDT's have to be zero'd
If _FileExists(pathedFileName$) Then
Open pathedFileName$ For Input As #1
While Not EOF(1)
ub = ub + 1
If ub > UBound(Dict) Then ReDim _Preserve Dict(1 To ub + 1000) As Dictionary
Line Input #1, Dict(ub).K
Line Input #1, Dict(ub).V
Wend
ReDim _Preserve Dict(1 To ub) As Dictionary
End If
End Sub
' replace 2 TempodiBasic Functions with 1 Sub, to handle both new and modified values for keys and dynamic Dict() dbl string array.
' Now just take ubound of dict() and have number of pairs it contains
Sub AddModDictionary (Dict() As Dictionary, K$, V$) ' mod with mod Find
ReDim ub As Long, i As Long, ky$, f As Long, ip As Long
ub = UBound(Dict)
ky$ = UCase$(_Trim$(K$)) 'don't change k$ but make case insensitive?
If ky$ <> "" Then ' bullet proof sub routine K$ must not be empty!
If ub = 1 And Dict(1).K = "" Then 'our very first pair!
Dict(1).K = ky$: Dict(1).V = V$: Exit Sub
Else
'For i = 1 To ub ' see if we have that name yet
' If ky$ = Dict(i).K Then Dict(i).V = V$: Exit Sub ' yes name is registered so change value
'Next
f = Find&(Dict(), ky$, ip)
If f Then
Dict(f).V = V$
Else
'still here? add var name and value to dictionary
ReDim _Preserve Dict(1 To ub + 1) As Dictionary ' create one slot at a time such that ubound = number or pairs
For i = ub To ip Step -1
Dict(i + 1) = Dict(i)
Next
Dict(ip).K = ky$: Dict(ip).V = V$ ' fill it with key and value
End If
End If
End If
End Sub
Function GetValue$ (Dict() As Dictionary, K$) 'mod
Dim f As Long, ip As Long
f = Find&(Dict(), K$, ip)
If f Then GetValue$ = Dict(f).V
End Function
Sub ShowDict (Dict() As Dictionary)
Dim i As Long
Print "Dictionary has "; _Trim$(Str$(UBound(Dict))); " items."
For i = 1 To UBound(Dict)
Print i, Dict(i).K, Dict(i).V
Next
Print
Print "zzz... press any to continue"
Sleep
Print
End Sub
Sub RemoveKV (Dict() As Dictionary, K$) ' mod
Dim As Long j, f, ip
f = Find&(Dict(), K$, ip)
If f Then
If f <> UBound(Dict) Then
For j = f + 1 To UBound(Dict)
Swap Dict(j - 1), Dict(j)
Next
End If
ReDim _Preserve Dict(1 To UBound(Dict) - 1) As Dictionary
End If
End Sub
' instead or replacing a value with another we will add the new value delimited by a comma
Sub AddAppendDictionary (Dict() As Dictionary, K$, V$) ' mod
Dim As Long ub, i, f, ip
Dim ky$
ub = UBound(Dict)
ky$ = UCase$(_Trim$(K$)) 'don't change k$ but make case insensitive?
If ky$ <> "" Then ' bullet proof sub routine K$ must not be empty!
If ub = 1 And Dict(1).K = "" Then 'our very first pair!
Dict(1).K = ky$: Dict(1).V = V$: Exit Sub
Else
f = Find&(Dict(), ky$, ip)
If f Then
Dict(f).V = Dict(f).V + "," + V$
Else
ReDim _Preserve Dict(1 To ub + 1) As Dictionary ' create one slot at a time such that ubound = number or pairs
For i = ub To ip Step -1
Dict(i + 1) = Dict(i)
Next
Dict(ip).K = ky$: Dict(ip).V = V$ ' fill it with key and value
End If
End If
End If
End Sub
Sub RemoveValue (Dict() As Dictionary, K$, RemoveV$) ' mod
ReDim As Long ub, j, f, ip
ReDim ky$, b$
ub = UBound(Dict)
ky$ = UCase$(_Trim$(K$)) 'don't change k$ but make case insensitive?
If ky$ <> "" Then ' bullet proof sub routine K$ must not be empty!
If ub = 1 And Dict(1).K = "" Then 'our very first pair!
Exit Sub
Else
f = Find&(Dict(), ky$, ip)
If f Then
If InStr(Dict(f).V, ",") > 0 Then
ReDim t$(1 To 1)
Split Dict(f).V, ",", t$()
For j = 1 To UBound(t$)
If t$(j) <> RemoveV$ Then
If b$ = "" Then
b$ = t$(j)
Else
b$ = b$ + "," + t$(j)
End If
End If
Next
Dict(f).V = b$
ElseIf Dict(f).V = RemoveV$ Then
Dict(f).V = ""
End If
End If
End If
End If
End Sub
' 2023-04-11 mod for Dictionary Type and inserting new words
Function Find& (SortedArr() As Dictionary, x$, insertPlace&)
Dim As Long low, hi, test
Dim xcap$
xcap$ = UCase$(x$)
low = LBound(SortedArr): hi = UBound(SortedArr)
While low <= hi
test = Int((low + hi) / 2)
If SortedArr(hi).K < xcap$ Then insertPlace& = hi + 1 Else insertPlace& = low
If SortedArr(test).K = xcap$ Then
Find& = test: Exit Function
Else
If SortedArr(test).K <= xcap$ Then low = test + 1 Else hi = test - 1
End If
Wend
End Function
' note: I buggered this twice now, FOR base 1 array REDIM MyArray (1 to 1) AS ... the (1 to 1) is not same as (1) which was the Blunder!!!
'notes: REDIM the array(0) to be loaded before calling Split '<<<< IMPORTANT dynamic array and empty, can use any lbound though
'This SUB will take a given N delimited string, and delimiter$ and create an array of N+1 strings using the LBOUND of the given dynamic array to load.
'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given. rev 2019-08-27
Sub Split (SplitMeString As String, delim As String, loadMeArray() As String) ' from Handy library
Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
dpos = InStr(curpos, SplitMeString, delim)
Do Until dpos = 0
loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
arrpos = arrpos + 1
If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
curpos = dpos + LD
dpos = InStr(curpos, SplitMeString, delim)
Loop
loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
End SubWould like to compare with @TempodiBasic and @madscijr but what data set are you testing?
b = b + ...