An hash array dictonary step by step

[bplus]

OK you guys made me look at what I did with Dictionary, no hash but I did get multiple values for a given key:

Code: (Select All)

Option _Explicit ' Dictionary 2 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

Type Dictionary
    K As String
    V As String
End Type

ReDim MyDict(1 To 1) As Dictionary ' use ubound of array to tell how many values we have

' 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()


' 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$)
    ReDim ub As Long, i As Long, 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
            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
            '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
            Dict(ub + 1).K = ky$: Dict(ub + 1).V = V$ ' fill it with key and value
        End If
    End If
End Sub

' fixed for
Function GetValue$ (Dict() As Dictionary, K$)
    Dim i As Long
    For i = 1 To UBound(Dict)
        If Dict(i).K = UCase$(_Trim$(K$)) Then
            GetValue$ = Dict(i).V: Exit Function
        End If
    Next
End Function

'modified for quick look
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

'========================== new stuff 2021-04-07

Sub RemoveKV (Dict() As Dictionary, K$)
    Dim As Long i, j
    For i = 1 To UBound(Dict)
        If Dict(i).K = UCase$(_Trim$(K$)) Then
            If i <> UBound(Dict) Then
                For j = i + 1 To UBound(Dict)
                    Swap Dict(j - 1), Dict(j)
                Next
            End If
            ReDim _Preserve Dict(1 To UBound(Dict) - 1) As Dictionary
            Exit Sub
        End If
    Next
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$)
    ReDim ub As Long, i As Long, 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
            For i = 1 To ub ' see if we have that name yet
                If ky$ = Dict(i).K Then Dict(i).V = Dict(i).V + "," + V$: Exit Sub ' yes name is registered so change value
            Next
            '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
            Dict(ub + 1).K = ky$: Dict(ub + 1).V = V$ ' fill it with key and value
        End If
    End If
End Sub

Sub RemoveValue (Dict() As Dictionary, K$, RemoveV$)
    ReDim As Long ub, i, j
    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
            For i = 1 To ub ' see if we have that name yet
                If ky$ = Dict(i).K Then
                    If InStr(Dict(i).V, ",") > 0 Then
                        ReDim t$(1 To 1)
                        Split Dict(i).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(i).V = b$
                    ElseIf Dict(i).V = RemoveV$ Then
                        Dict(i).V = ""
                    End If
                    Exit Sub
                End If
            Next
        End If
    End If
End Sub

' 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)
    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 Sub

I did use Split but for removing or modifying multiple items under a key. K stands for key and V stands for value(s).