Sorted Key Dictionary

[bplus]

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.

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 Sub

Would like to compare with @TempodiBasic and @madscijr but what data set are you testing?

[madscijr]

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.
...

That sounds great - I'll give this a look when I'm back at my PC!

Would like to compare with @TempodiBasic and @madscijr but what data set are you testing?

I can plug your code into the test harness when I'm back, but if you look at the most recent test program I posted that compares my delimited string dictionary vs Tempodi vs Luke, you can see the test code that calls them all at the top.

PS Thanks for contributing to this!

[TempodiBasic]

Hi Bplus
at first time 
I used an UDT made by 2 items as String  . Declaring string array,
while in the second time I used an array of type of data of that declared by Luke, this with the aim to get a closer comparison.
But at the end  my algorithm and that of Luke used to store data in a string variable and the same for the key stored.
The difference is the way to get the hash value and how this is used to access to the data stored.

[bplus]

Ah this is way more fun when I have a practical application for Dictionary.

Dictionary 4 preps for using Dictionary Code to handle variables in a Basic program. The key will be the variable name, case insensitive. The value will be string form of number or variable length string.

I intend on using code in experiment for tracking simple variables and their values. I've added these helper procedure to aid in the process:

Code: (Select All)

Function LV& (varName$) ' handy convert to Integer
    LV& = Val(Vb$(varName$))
End Function

Function DV# (varName$) ' handy convert to Double
    DV# = Val(Vb$(varName$))
End Function

' assign or reassign a varaiiable a value
Sub Set (vName$, vValue$) ' working with special variable & values Dictionary
    AddModDictionary VD(), vName$, vValue$
End Sub

' get the value of a variable convert to number with Val() if needed
Function Vb$ (vName$)
    ' why b? 1. Can't have a single char function, b is right next door to v so typing vb is cake!
    Vb$ = GetValue$(VD(), vName$)
End Function

Sub SeeVD ' here is a debug function brought to you by bplus!
    Dim As Long ub, i
    Dim l$, b$
    ub = UBound(VD)
    l$ = Chr$(10)
    For i = 1 To ub
        If i = 1 Then
            b$ = VD(i).K + " = " + VD(i).V
        Else
            b$ = b$ + l$ + VD(i).K + " = " + VD(i).V
        End If
    Next
    If _MessageBox("VD() 'Debug' Variable = Value:", b$, "okcancel", "question") = 0 Then End
End Sub

Here is a normal .bas program I will use in experiment to use Dictionary Key/Values to track the simple variables in program. I still use variable arrays and For loop indexes. It is a small program testing the assertion that there is a very unintuitive strategy to solve the Prisoner problem so that 31% of the time they could go Free see notes at bottom of code.

Code: (Select All)

_Title "100 Prisoners Problem" ' b+ 2022-07-17
Randomize Timer
Dim slots(1 To 100) As Long
For i = 1 To 100
    slots(i) = i
Next
Do
    freed = 0: executions = 0
    Do
        GoSub shuffle
        For p = 1 To 100 ' prisoner number
            count = 1: test = p: madeit = -1
            While count <= 50
                If slots(test) = p Then Exit While Else test = slots(test)
                count = count + 1
                If count > 50 Then madeit = 0: Exit For
            Wend
        Next
        If madeit Then freed = freed + 1 Else executions = executions + 1
    Loop Until (freed + executions) = 100000
    Print "Freed"; freed
    Print "Exceutions"; executions
    Print
    Print "Press any for another run of 100,000... "
    Sleep
    Cls
Loop Until _KeyDown(27)
End
shuffle:
For i = 100 To 2 Step -1
    Swap slots(Int(Rnd * i) + 1), slots(i)
Next
Return


'  I saw this last night and just have to check out the solution in code!
' https://www.youtube.com/watch?v=iSNsgj1OCLA

' So 100 prisoners go into a room one at a time and have 50 chances to draw their number from mailbox slots
' they must return the numbers in same box they checked.

' If all the prisoners find their number they go free else they are all executed. Whew!

' But there is a strategy that if used gives them around a 31% chance of being set free!

'       A 31% Change of being set free, how can this be!?

' Here is the startegy, go into the room and pull the number from slot that matches your number.
' From that number go to the number found in the box, contimue in this manner until you find your
' number or you've drawn from 50 slots. If you hit 50 then everyone is doomed might as well start
' another run on the experiment.

' If we run this strategy 100000 times will we get around 31,000 Set Frees and 69,000 Executions?

' Let's see...

' Wow! as predicted

OK now let's see what happens if we let the Dictionary Code track the variable names and values:

Code: (Select All)

Option _Explicit ' Dictionary 4
' 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
' 2023-04-13 for giggles add procedures for handling all? variables in a QB64 program (not sure about arrays yet)

Type Dictionary
    K As String ' Dictionary v 3+ keys all caps for faster searches
    V As String
End Type

' VD stands for Variables Dictionary .K for Key is for variable name .V for value is string version of value
ReDim Shared VD(1 To 1) As Dictionary
'ReDim MyDict(1 To 1) As Dictionary ' use ubound of array to tell how many values we have

' test program for using Dictionary for simple variables and values  =======================================================
Dim As Long i, p, lc ' not going to do For index variables
'_Title "100 Prisoners Problem" ' b+ 2022-07-17
Randomize Timer
Dim slots(1 To 100) As Long ' no not going to do array variables
For i = 1 To 100 ' nor for index variables
    slots(i) = i
Next
Do

    'integer variables
    Set "freed", "0"
    Set "executions", "0"
    Do
        GoSub shuffle
        For p = 1 To 100 ' prisoner number

            ' integer varaibles
            Set "count", "1"
            Set "test", Str$(p)
            Set "madeit", "-1"
            While LV&("count") <= 50
                If slots(LV&("test")) = p Then
                    Exit While
                Else
                    Set "test", Str$(slots(LV&("test")))
                End If
                Set "count", Str$(LV&("count") + 1)
                If Val(Vb$("count")) > 50 Then Set "madeit", "0": Exit For
            Wend
        Next
        If LV&("madeit") Then
            Set "freed", Str$(LV&("freed") + 1)
        Else
            Set "executions", Str$(LV&("executions") + 1)
        End If

        ' Lets see the current list of variables and values !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        lc = lc + 1
        If (lc Mod 200) = 0 Then SeeVD ' check every 20 tests free + executions = num tests
        ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! just like Debug !!!!!!!!!!!!


    Loop Until (LV&("freed") + LV&("executions")) = 1000
    Print "Freed"; LV&("freed")
    Print "Exceutions"; LV&("executions")
    Print
    Print "Press any for another run of 1000... "
    Sleep
    Cls
Loop Until _KeyDown(27)
End
shuffle:
For i = 100 To 2 Step -1
    Swap slots(Int(Rnd * i) + 1), slots(i)
Next
Return


'  I saw this last night and just have to check out the solution in code!
' https://www.youtube.com/watch?v=iSNsgj1OCLA

' So 100 prisoners go into a room one at a time and have 50 chances to draw their number from mailbox slots
' they must return the numbers in same box they checked.

' If all the prisoners find their number they go free else they are all executed. Whew!

' But there is a strategy that if used gives them around a 31% chance of being set free!

'       A 31% Change of being set free, how can this be!?

' Here is the startegy, go into the room and pull the number from slot that matches your number.
' From that number go to the number found in the box, contimue in this manner until you find your
' number or you've drawn from 50 slots. If you hit 50 then everyone is doomed might as well start
' another run on the experiment.

' If we run this strategy 100000 times will we get around 31,000 Set Frees and 69,000 Executions?

' Let's see...

' Wow! as predicted

'======================================== END of test program 100 Prisoners Problem ============================

Function LV& (varName$) ' handy convert to Integer
    LV& = Val(Vb$(varName$))
End Function

Function DV# (varName$) ' handy convert to Double
    DV# = Val(Vb$(varName$))
End Function

' assign or reassign a varaiiable a value
Sub Set (vName$, vValue$) ' working with special variable & values Dictionary
    AddModDictionary VD(), vName$, vValue$
End Sub

' get the value of a variable convert to number with Val() if needed
Function Vb$ (vName$)
    ' why b? 1. Can't have a single char function, b is right next door to v so typing vb is cake!
    Vb$ = GetValue$(VD(), vName$)
End Function

Sub SeeVD ' here is a debug function brought to you by bplus!
    Dim As Long ub, i
    Dim l$, b$
    ub = UBound(VD)
    l$ = Chr$(10)
    For i = 1 To ub
        If i = 1 Then
            b$ = VD(i).K + " = " + VD(i).V
        Else
            b$ = b$ + l$ + VD(i).K + " = " + VD(i).V
        End If
    Next
    If _MessageBox("VD() 'Debug' Variable = Value:", b$, "okcancel", "question") = 0 Then End
End Sub

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 Sub

It worked, much slower that regular QB64 variable tracking but still it worked. Might be handy with my Interpreter oh ?

I also added a 'Debug" function that allows you to see all your variables and values in a Message Box and allows you to shut down program if you see things going South with variable values. In the test program above I show the variables 5 times in main loop every 200 runs of 100 Prisoners scenario.

[TempodiBasic]

Hi Bplus
100 prisoners issue is on a page of Rosetta code. 
As you can see here Rosetta Code 100 prisoners problem
there is a publication of a solution in QB64.

[bplus]

Hi Bplus
100 prisoners issue is on a page of Rosetta code. 
As you can see here Rosetta Code 100 prisoners problem
there is a publication of a solution in QB64.

Mines better, less LOC (33 vrs 79), but it only confirms the strategy works getting stats on a given number of trials.
WTH? is Chainway??? QB64 RC Output gives no indication how successful the strategy is as told in the You Tube video I referenced in my code.

Well this thread is about using Dictionary stuff, I just picked 100 Prisoners out of thousands to test variable value handling with Dictionary.

[TempodiBasic]

@Bplus

WTH? is Chainway??? QB64 RC Output gives no indication how successful the strategy is as told in the You Tube video I referenced in my code.

follow the link

100 prisoners thread

[CharlieJV]

Ah this is way more fun when I have a practical application for Dictionary.

...

A great use case for a dictionary: country code lookup.

Just for the giggles, here's one silly (but interesting to me) use case for a dictionary (very rudimentary capability in BAM).  Kind of simulating a "one-liner switch" statement:

Code: (Select All)

INIT:

  _initaudio

  _mapset("CARROT", 1)
  _mapset("CORN", 2)
  _mapset("POTATO", 3)

MAIN_PROGRAM:

  getselection:
    input "Search for recipes: enter one ingredient:", selection$
    selection$ = ucase$(selection$)
    if _mapget(selection$) = "" then beep : print "sorry, no recipes for " + selection$ : goto getselection

  on _mapget(selection$) gosub CARROT, CORN, POTATO

  goto getselection

  end

SUBROUTINES:

  CARROT:
    print "setup special processing for carrot-related recipes and info"
    RETURN

  CORN:
    print "setup special processing for corn-related recipes and info"
    RETURN

  POTATO:
    print "setup special processing for potato-relatd recipes and info"
    RETURN

[bplus]

Another idea:
Perhaps one of those amusing word substitution things that Steve and Ron played with at the old forum.

[CharlieJV]

Another idea:
Perhaps one of those amusing word substitution things that Steve and Ron played with at the old forum.

Now that's a fun idea!