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:
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.
OK now let's see what happens if we let the Dictionary Code track the variable names and values:
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.
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 SubHere 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 predictedOK 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 SubIt 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.
b = b + ...