Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
04-12-2023, 06:52 PM
(This post was last modified: 04-12-2023, 06:53 PM by 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?
b = b + ...
Posts: 529
Threads: 67
Joined: Apr 2022
Reputation:
11
04-12-2023, 07:15 PM
(This post was last modified: 04-12-2023, 07:15 PM by madscijr.)
(04-12-2023, 06:52 PM)bplus Wrote: 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!
(04-12-2023, 06:52 PM)bplus Wrote: 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!
Posts: 296
Threads: 14
Joined: Jul 2022
Reputation:
15
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.
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
04-13-2023, 07:37 PM
(This post was last modified: 04-13-2023, 07:45 PM by 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.
b = b + ...
Posts: 296
Threads: 14
Joined: Jul 2022
Reputation:
15
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.
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
04-13-2023, 09:50 PM
(This post was last modified: 04-13-2023, 09:59 PM by bplus.)
(04-13-2023, 08:39 PM)TempodiBasic Wrote: 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.
b = b + ...
Posts: 296
Threads: 14
Joined: Jul 2022
Reputation:
15
@Bplus
Quote: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
Posts: 490
Threads: 95
Joined: Apr 2022
Reputation:
23
(04-13-2023, 07:37 PM)bplus Wrote: 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
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
Another idea:
Perhaps one of those amusing word substitution things that Steve and Ron played with at the old forum.
b = b + ...
Posts: 490
Threads: 95
Joined: Apr 2022
Reputation:
23
(04-15-2023, 04:55 PM)bplus Wrote: 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!
|
