Author Topic: multivalue dictionary + demo (v1.16.00)  (Read 2986 times)

0 Members and 1 Guest are viewing this topic.

Offline madscijr

  • Seasoned Forum Regular
  • Posts: 295
    • View Profile
multivalue dictionary + demo (v1.16.00)
« on: December 14, 2021, 05:21:35 pm »
This improves on the work here to implement a dictionary in QB64
https://www.qb64.org/forum/index.php?topic=3387.0

and adds some enhancements
  • uses a UDT to store multiple values
  • simpler command set (maybe too simple!)
  • logical delete = much faster

In the future maybe it can use a hash or sorted keys to speed it up.

But it works pretty well for smaller collections of data.

Hopefully someone will find this useful...

Code: QB64: [Select]
  1. ' #############################################################################
  2. ' ASSOCIATIVE ARRAY / DICTIONARY IMPLEMENTATION
  3. ' Version 1.16.00 by madscijr
  4.  
  5. ' BASED OFF SOME DISCUSSION AT
  6. '     associative arrays / dictionaries in QB64?
  7. '     https://www.qb64.org/forum/index.php?topic=3387.0
  8.  
  9. ' -----------------------------------------------------------------------------
  10. ' Description
  11. ' -----------------------------------------------------------------------------
  12. ' Tries to emulate a simple dictionary / associative array in QB64.
  13.  
  14. ' -----------------------------------------------------------------------------
  15. ' Customizing
  16. ' -----------------------------------------------------------------------------
  17. ' Stores mixed data types with a user defined type DictionaryType,
  18. ' which you can change as needed, as long as you leave the
  19. ' properties Key and NextFree:
  20. '     TYPE DictionaryType
  21. '         Key AS String
  22. '         NextFree As Long
  23. '         (your values here)
  24. '     END TYPE
  25. ' You will need to update DumpDictionary so the properties match
  26. ' whatever you have in the type.
  27.  
  28. ' There is a global constant
  29. '     CONST cIntDictMax = 0
  30. ' which can be used to define a maximum number of nodes to be stored.
  31. ' If the value is 0 then there is no maximum.
  32.  
  33. ' -----------------------------------------------------------------------------
  34. ' How to use
  35. ' -----------------------------------------------------------------------------
  36. ' To use the dictionary, you just declare an array of DictionaryType,
  37. ' where array(0) is reserved, so don't declare your array 1 To n,
  38. ' it must start with index 0.
  39.  
  40. ' The following functions are available:
  41. ' 1. InitDictionary initializes a new dictionary.
  42. '    Receives one parameter:
  43. '        arrDict: the array of DictionaryType
  44. '    Usage:
  45. '        InitDictionary arrDict()
  46. ' 2. SaveDictionary& writes a value to the dictionary.
  47. '    Receives two parameters:
  48. '        arrDict: the array of DictionaryType
  49. '        MyValue: a variable of type DictionaryType
  50. '                 where MyValue.Key holds the key
  51. '                 and MyMalue.{property} holds value(s) to store.
  52. '    Returns the array index the item is stored at,
  53. '    or 0 if the save failed.
  54. '    Usage:
  55. '        lngIndex = SaveDictionary&(arrDict(), MyValue)
  56. ' 3. DeleteDictionaryKey removes a value from the dictionary.
  57. '    Receives two parameters:
  58. '        arrDict: the array of DictionaryType
  59. '        sKey: the key of the item to be deleted
  60. '    Returns TRUE if the key is found and the item is deleted,
  61. '    or FALSE if the key was not found.
  62. '    Items are logically deleted and reused for future inserts
  63. '    (see below for details if you want to know how it works).
  64. '    Usage:
  65. '        bResult = DeleteDictionaryKey%(arrDict(), sKey)
  66. ' 4. FindDictionaryKey searches the dictionary for a given key.
  67. '    Receives two parameters:
  68. '        arrDict: the array of DictionaryType
  69. '        sKey: the key of the item to be found
  70. '    Returns the array index the item was found at,
  71. '    or 0 if the key was not found.
  72. '    Usage:
  73. '        lngIndex = FindDictionaryKey&(arrDict(), sKey)
  74. ' 5. DumpDictionary returns a verbose string with the
  75. '    dictionary contents. If you change DictionaryType
  76. '    you will need to update this function to reflect
  77. '    the changes.
  78. '    Receives one parameter:
  79. '        arrDict: the array of DictionaryType
  80. '    Returns a multi-line string containing the
  81. '    contents of the dictionary.
  82. '    Usage:
  83. '        MyString = DumpDictionary$(arrDict())
  84.  
  85. ' -----------------------------------------------------------------------------
  86. ' Some limitations
  87. ' -----------------------------------------------------------------------------
  88. ' 1. Not the most efficient - simply appends new keys to the end of the array,
  89. '    and searches for them in linear order).
  90. '    We can try a hashing method similar to Luke's symtab code at
  91. '        Re: associative arrays / dictionaries in QB64?
  92. '        https://www.qb64.org/forum/index.php?topic=3387.msg127022#msg127022
  93. '    or try adding the keys in sorted order (will have to experiment).
  94. ' 2. No sorting.
  95.  
  96. ' -----------------------------------------------------------------------------
  97. ' Updates
  98. ' -----------------------------------------------------------------------------
  99. ' * Logical delete = faster!
  100. '
  101. '   Uses the logical delete method for the linked list implementation at
  102. '   https://www.qb64.org/forum/index.php?topic=4008.0
  103. '
  104. '   The way it works is:
  105. '   We don't delete nodes from the dictionary, just reuse them.
  106. '   Each node has a .NextFree property that points to the index of
  107. '   the next array item to be reused.
  108. '   Array item(0) is reserved for tracking the first free item.
  109. '   When a node is "deleted", we set array(0).NextFree to the index of the deleted node.
  110. '   When we delete subsequent nodes, each one's .NextFree points to the next available
  111. '   deleted node in a "chain". When we reuse the next given node,
  112. '   we repoint array(0).NextFree to the next one, and so array(0).NextFree
  113. '   always points to the next available node to be reused.
  114. '
  115. '   If array(0).NextFree = 0, then there are no deleted nodes to be reused,
  116. '   so we append a new element to the array with REDIM _PRESERVE.
  117. '
  118. '   array(0) is the head of the "deleted" or "to be reused" chain.
  119. '
  120. ' * Returns 0 for failed instead of -1, to match the value FALSE.
  121.  
  122. ' -----------------------------------------------------------------------------
  123. ' Questions
  124. ' -----------------------------------------------------------------------------
  125. ' 1. What are some other ways this could be better implemented?
  126. ' 2. Would it be more efficient if we inserted elements in sort order,
  127. '    so the dictionary is always sorted? That would speed up read
  128. '    (which would find the key with a binary search) but slow down write.
  129. '    How do we implement this?
  130. ' 3. If we added a sort function, to sort by value OR key,
  131. '    Which algorithm would be fast (but not too complex to debug &
  132. '    understand) for integer values? For string values?
  133.  
  134. ' #############################################################################
  135.  
  136. ' =============================================================================
  137. ' GLOBAL DECLARATIONS a$=string, i%=integer, L&=long, s!=single, d#=double
  138.  
  139. ' =============================================================================
  140. ' CONSTANTS
  141. ' =============================================================================
  142. Const FALSE = 0
  143. Const TRUE = Not FALSE
  144.  
  145. Const cIntDictMax = 0 ' lets us limit the size of the dictionary, 0=no limit
  146.  
  147. ' =============================================================================
  148. ' USER DEFINED TYPES
  149. ' =============================================================================
  150. Type DictionaryType
  151.     Key As String
  152.     intValue As Integer
  153.     strValue As String
  154.     lngValue As Long
  155.     NextFree As Long ' pointer to next free node (0 means none, we redim array)
  156. End Type ' DictionaryType
  157.  
  158. ' =============================================================================
  159. ' GLOBAL VARIABLES
  160. ' =============================================================================
  161. Dim Shared ProgramPath$: ProgramPath$ = Left$(Command$(0), _InStrRev(Command$(0), "\"))
  162. Dim Shared ProgramName$: ProgramName$ = Mid$(Command$(0), _InStrRev(Command$(0), "\") + 1)
  163.  
  164. ' ****************************************************************************************************************************************************************
  165. ' ACTIVATE DEBUGGING WINDOW
  166. '$Console
  167. '_Delay 4
  168. '_Console On
  169. '_Echo "Started " + ProgramName$
  170. '_Echo "Debugging on..."
  171. ' ****************************************************************************************************************************************************************
  172.  
  173. ' =============================================================================
  174. ' LOCAL VARIABLES
  175. Dim in$
  176.  
  177. ' =============================================================================
  178. ' RUN TEST
  179. main
  180.  
  181. ' =============================================================================
  182. ' FINISH
  183. Print ProgramName$ + " finished."
  184. Input "PRESS <ENTER> TO EXIT", in$
  185. System ' return control to the operating system
  186.  
  187. ' ****************************************************************************************************************************************************************
  188. ' DEACTIVATE DEBUGGING WINDOW
  189. '_Console Off
  190. ' ****************************************************************************************************************************************************************
  191.  
  192.  
  193. ' /////////////////////////////////////////////////////////////////////////////
  194.  
  195. Sub main ()
  196.     ReDim arrDict(0) As DictionaryType
  197.     Dim MyValue As DictionaryType
  198.     Dim lngIndex As Long
  199.     Dim sKey As String
  200.     Dim bResult As Integer
  201.     Dim in$
  202.  
  203.     Cls
  204.  
  205.     Print "-------------------------------------------------------------------------------"
  206.     Print "Initializing dictionary..."
  207.     InitDictionary arrDict()
  208.  
  209.     Print
  210.     PrintPaged DumpDictionary$(arrDict()), 20
  211.     Print
  212.  
  213.     Print "-------------------------------------------------------------------------------"
  214.     Print "Writing some values..."
  215.     Print
  216.     Input "Press <ENTER> to write some values", in$
  217.     Print
  218.  
  219.     MyValue.Key = "apple"
  220.     MyValue.intValue = 3:
  221.     MyValue.strValue = "a":
  222.     MyValue.lngValue = 33:
  223.     lngIndex = SaveDictionary&(arrDict(), MyValue)
  224.     Print "SaveDictionary& for key " + Chr$(34) + MyValue.Key + Chr$(34) + " returns " + cstrl$(lngIndex)
  225.  
  226.     MyValue.Key = "africa"
  227.     MyValue.intValue = 1:
  228.     MyValue.strValue = "b":
  229.     MyValue.lngValue = 11:
  230.     lngIndex = SaveDictionary&(arrDict(), MyValue)
  231.     Print "SaveDictionary& for key " + Chr$(34) + MyValue.Key + Chr$(34) + " returns " + cstrl$(lngIndex)
  232.  
  233.     MyValue.Key = "zebra"
  234.     MyValue.intValue = 0:
  235.     MyValue.strValue = "c":
  236.     MyValue.lngValue = -1:
  237.     lngIndex = SaveDictionary&(arrDict(), MyValue)
  238.     Print "SaveDictionary& for key " + Chr$(34) + MyValue.Key + Chr$(34) + " returns " + cstrl$(lngIndex)
  239.  
  240.     MyValue.Key = "xylophone"
  241.     MyValue.intValue = 2:
  242.     MyValue.strValue = "d":
  243.     MyValue.lngValue = 22:
  244.     lngIndex = SaveDictionary&(arrDict(), MyValue)
  245.     Print "SaveDictionary& for key " + Chr$(34) + MyValue.Key + Chr$(34) + " returns " + cstrl$(lngIndex)
  246.  
  247.     MyValue.Key = "zebra"
  248.     MyValue.intValue = 4:
  249.     MyValue.strValue = "e":
  250.     MyValue.lngValue = 44:
  251.     lngIndex = SaveDictionary&(arrDict(), MyValue)
  252.     Print "SaveDictionary& for key " + Chr$(34) + MyValue.Key + Chr$(34) + " returns " + cstrl$(lngIndex)
  253.  
  254.     Print
  255.     Input "Press <ENTER> to view contents.", in$
  256.     Print
  257.     PrintPaged DumpDictionary$(arrDict()), 20
  258.  
  259.     Print "-------------------------------------------------------------------------------"
  260.     Print "Deleting some keys..."
  261.     Print
  262.     Input "Press <ENTER> to test delete function.", in$
  263.     Print
  264.  
  265.     sKey = "zebra"
  266.     bResult = DeleteDictionaryKey%(arrDict(), sKey)
  267.     Print "DeleteDictionaryKey%(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + IIFSTR$(bResult, "TRUE", "FALSE")
  268.  
  269.     sKey = "nonesuch"
  270.     bResult = DeleteDictionaryKey%(arrDict(), sKey)
  271.     Print "DeleteDictionaryKey%(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + IIFSTR$(bResult, "TRUE", "FALSE")
  272.  
  273.     sKey = "xylophone"
  274.     bResult = DeleteDictionaryKey%(arrDict(), sKey)
  275.     Print "DeleteDictionaryKey%(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + IIFSTR$(bResult, "TRUE", "FALSE")
  276.  
  277.     Print
  278.     Input "Press <ENTER> to view contents.", in$
  279.     Print
  280.     PrintPaged DumpDictionary$(arrDict()), 20
  281.     Print
  282.  
  283.     Print "-------------------------------------------------------------------------------"
  284.     Print "Look for keys..."
  285.     Print
  286.     Input "Press <ENTER> to test search function.", in$
  287.     Print
  288.  
  289.     sKey = "africa"
  290.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  291.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + cstr$(lngIndex)
  292.  
  293.     sKey = "xenophobe"
  294.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  295.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + cstr$(lngIndex)
  296.  
  297.     sKey = "APPLE"
  298.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  299.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + cstr$(lngIndex)
  300.  
  301.     sKey = "zambia"
  302.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  303.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34) + ") returns " + cstr$(lngIndex)
  304.  
  305.     Print
  306.     Input "Press <ENTER> to view contents.", in$
  307.     Print
  308.     PrintPaged DumpDictionary$(arrDict()), 20
  309.     Print
  310.  
  311.     Print "-------------------------------------------------------------------------------"
  312.     Print "Retrieving values..."
  313.  
  314.     Print
  315.     Input "Press <ENTER> to view contents of 'africa'", in$
  316.     Print
  317.  
  318.     sKey = "africa"
  319.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  320.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34); " ) returns " + cstrl$(lngIndex)
  321.     If lngIndex > 0 Then
  322.         Print "    .Key=" + Chr$(34) + arrDict(lngIndex).Key + Chr$(34)
  323.         Print "    .intValue=" + cstr$(arrDict(lngIndex).intValue)
  324.         Print "    .strValue=" + Chr$(34) + arrDict(lngIndex).strValue + Chr$(34)
  325.         Print "    .lngValue=" + cstrl$(arrDict(lngIndex).lngValue)
  326.         Print "    .NextFree=" + cstrl$(arrDict(lngIndex).NextFree)
  327.     End If
  328.  
  329.     Print
  330.     Input "Press <ENTER> to view contents of 'zebra'", in$
  331.     Print
  332.  
  333.     sKey = "zebra"
  334.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  335.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34); " ) returns " + cstrl$(lngIndex)
  336.     If lngIndex > 0 Then
  337.         Print "    .Key=" + Chr$(34) + arrDict(lngIndex).Key + Chr$(34)
  338.         Print "    .intValue=" + cstr$(arrDict(lngIndex).intValue)
  339.         Print "    .strValue=" + Chr$(34) + arrDict(lngIndex).strValue + Chr$(34)
  340.         Print "    .lngValue=" + cstrl$(arrDict(lngIndex).lngValue)
  341.         Print "    .NextFree=" + cstrl$(arrDict(lngIndex).NextFree)
  342.     End If
  343.  
  344.     Print
  345.     Input "Press <ENTER> to view contents of 'apple'", in$
  346.     Print
  347.  
  348.     sKey = "apple"
  349.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  350.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34); " ) returns " + cstrl$(lngIndex)
  351.     If lngIndex > 0 Then
  352.         Print "    .Key=" + Chr$(34) + arrDict(lngIndex).Key + Chr$(34)
  353.         Print "    .intValue=" + cstr$(arrDict(lngIndex).intValue)
  354.         Print "    .strValue=" + Chr$(34) + arrDict(lngIndex).strValue + Chr$(34)
  355.         Print "    .lngValue=" + cstrl$(arrDict(lngIndex).lngValue)
  356.         Print "    .NextFree=" + cstrl$(arrDict(lngIndex).NextFree)
  357.     End If
  358.  
  359.     Print
  360.     Input "Press <ENTER> to view contents of 'nonesuch'", in$
  361.     Print
  362.  
  363.     sKey = "nonesuch"
  364.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  365.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34); " ) returns " + cstrl$(lngIndex)
  366.     If lngIndex > 0 Then
  367.         Print "    .Key=" + Chr$(34) + arrDict(lngIndex).Key + Chr$(34)
  368.         Print "    .intValue=" + cstr$(arrDict(lngIndex).intValue)
  369.         Print "    .strValue=" + Chr$(34) + arrDict(lngIndex).strValue + Chr$(34)
  370.         Print "    .lngValue=" + cstrl$(arrDict(lngIndex).lngValue)
  371.         Print "    .NextFree=" + cstrl$(arrDict(lngIndex).NextFree)
  372.     End If
  373.  
  374.     Print
  375.     Input "Press <ENTER> to view contents of 'xylophone'", in$
  376.     Print
  377.  
  378.     sKey = "xylophone"
  379.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  380.     Print "FindDictionaryKey&(arrDict(), " + Chr$(34) + sKey + Chr$(34); " ) returns " + cstrl$(lngIndex)
  381.     If lngIndex > 0 Then
  382.         Print "    .Key=" + Chr$(34) + arrDict(lngIndex).Key + Chr$(34)
  383.         Print "    .intValue=" + cstr$(arrDict(lngIndex).intValue)
  384.         Print "    .strValue=" + Chr$(34) + arrDict(lngIndex).strValue + Chr$(34)
  385.         Print "    .lngValue=" + cstrl$(arrDict(lngIndex).lngValue)
  386.         Print "    .NextFree=" + cstrl$(arrDict(lngIndex).NextFree)
  387.     End If
  388.  
  389.     Print
  390.     Input "Press <ENTER> to view contents.", in$
  391.     Print
  392.     PrintPaged DumpDictionary$(arrDict()), 20
  393.     Print
  394.  
  395.     Print "-------------------------------------------------------------------------------"
  396.     Print "This concludes the test of the pseudo-associative array / dictionary."
  397.     Print
  398.     Input "PRESS <ENTER> TO CONTINUE", in$
  399.  
  400. End Sub ' main
  401.  
  402. ' /////////////////////////////////////////////////////////////////////////////
  403.  
  404. Sub PrintPaged (MyString$, iLinesPerPage%)
  405.     Dim delim$
  406.     ReDim arrTest$(0)
  407.     Dim iLoop%
  408.     Dim iCount%
  409.     'Dim iRow%
  410.     Dim in$
  411.  
  412.     delim$ = Chr$(13)
  413.     split MyString$, delim$, arrTest$()
  414.  
  415.     iCount% = 0
  416.     For iLoop% = LBound(arrTest$) To UBound(arrTest$)
  417.         iCount% = iCount% + 1
  418.         If iCount% > iLinesPerPage% Then
  419.             'iRow% = CSRLIN ' save the row
  420.             'INPUT "PRESS <ENTER> TO CONTINUE";in$
  421.             'LOCATE iRow% - 1, 0 ' restore saved position
  422.             Sleep
  423.             iCount% = 0
  424.         End If
  425.         Print arrTest$(iLoop%)
  426.     Next iLoop%
  427.  
  428. End Sub ' PrintPaged
  429.  
  430. ' /////////////////////////////////////////////////////////////////////////////
  431.  
  432. Sub WaitForEnter
  433.     Dim in$
  434.     Input "Press <ENTER> to continue", in$
  435. End Sub ' WaitForEnter
  436.  
  437. ' /////////////////////////////////////////////////////////////////////////////
  438.  
  439. Sub InitDictionary (arrDict() As DictionaryType)
  440.     ReDim arrDict(0) As DictionaryType
  441.     arrDict(0).NextFree = 0
  442. End Sub ' InitDictionary
  443.  
  444. ' /////////////////////////////////////////////////////////////////////////////
  445.  
  446. Function SaveDictionary& (arrDict() As DictionaryType, MyValue As DictionaryType)
  447.     Dim lngLoop As Long
  448.     Dim lngIndex As Long
  449.  
  450.     ' LOOK FOR KEY
  451.     lngIndex = 0
  452.     For lngLoop = 0 To UBound(arrDict)
  453.         If LCase$(arrDict(lngLoop).Key) = LCase$(MyValue.Key) Then
  454.             lngIndex = lngLoop
  455.             Exit For
  456.         End If
  457.     Next lngLoop
  458.  
  459.     ' IF NOT FOUND THEN ADD IT
  460.     If (lngIndex < 1) Then
  461.         ' SEE IF THERE IS A NODE WE CAN REUSE
  462.         lngIndex = arrDict(0).NextFree
  463.         If lngIndex > 0 Then
  464.             ' REUSE NODE - POINT HEAD TO NEXT FREE (IF THERE IS ONE)
  465.             arrDict(0).NextFree = arrDict(lngIndex).NextFree
  466.             arrDict(lngIndex).NextFree = 0
  467.         Else
  468.             ' NONE FREE - EXPAND ARRAY
  469.             lngIndex = UBound(arrDict) + 1
  470.  
  471.             ' IS THERE A SIZE LIMIT?
  472.             If (cIntDictMax > 0) Then
  473.                 ' IS THERE ROOM?
  474.                 If (lngIndex > cIntDictMax) Then
  475.                     ' DICTIONARY FULL!
  476.                     ' SET lngIndex TO 0 WHICH INDICATES FAILURE
  477.                     lngIndex = 0
  478.                 End If
  479.             End If
  480.  
  481.             ' OK TO ADD NEW ELEMENT
  482.             If lngIndex > 0 Then
  483.                 ReDim _Preserve arrDict(lngIndex) As DictionaryType
  484.                 arrDict(lngIndex).Key = MyValue.Key
  485.                 arrDict(lngIndex).NextFree = 0
  486.             End If
  487.         End If
  488.     End If
  489.  
  490.     ' UPDATE VALUE IF NO ERRORS
  491.     If lngIndex > 0 Then
  492.         arrDict(lngIndex).intValue = MyValue.intValue
  493.         arrDict(lngIndex).strValue = MyValue.strValue
  494.         arrDict(lngIndex).lngValue = MyValue.lngValue
  495.     End If
  496.  
  497.     ' RETURN THE INDEX (OR 0 IF NOT ADDED)
  498.     SaveDictionary& = lngIndex
  499.  
  500. End Function ' SaveDictionary&
  501.  
  502. ' /////////////////////////////////////////////////////////////////////////////
  503.  
  504. Function FindDictionaryKey& (arrDict() As DictionaryType, sKey As String)
  505.     Dim lngLoop As Long
  506.     Dim lngIndex As Long
  507.  
  508.     lngIndex = 0
  509.     For lngLoop = 1 To UBound(arrDict)
  510.         If LCase$(arrDict(lngLoop).Key) = LCase$(sKey) Then
  511.             lngIndex = lngLoop
  512.             Exit For
  513.         End If
  514.     Next lngLoop
  515.  
  516.     FindDictionaryKey& = lngIndex
  517. End Function ' FindDictionaryKey&
  518.  
  519. ' /////////////////////////////////////////////////////////////////////////////
  520.  
  521. Function DeleteDictionaryKey% (arrDict() As DictionaryType, sKey As String)
  522.     Dim lngIndex As Long
  523.  
  524.     lngIndex = FindDictionaryKey&(arrDict(), sKey)
  525.  
  526.     If (lngIndex > 0) Then
  527.         ' clear the key
  528.         arrDict(lngIndex).Key = ""
  529.  
  530.         ' do we have any deleted nodes?
  531.         If arrDict(0).NextFree > 0 Then
  532.             ' insert current node at the top of the "deleted" chain
  533.             arrDict(lngIndex).NextFree = arrDict(0).NextFree
  534.         End If
  535.  
  536.         ' soft delete
  537.         arrDict(0).NextFree = lngIndex
  538.  
  539.         ' return true (found and deleted)
  540.         DeleteDictionaryKey% = TRUE
  541.     Else
  542.         ' return false (not found)
  543.         DeleteDictionaryKey% = FALSE
  544.     End If
  545.  
  546. End Function ' DeleteDictionaryKey%
  547.  
  548. ' /////////////////////////////////////////////////////////////////////////////
  549.  
  550. Function DumpDictionary$ (arrDict() As DictionaryType)
  551.     Dim sResult As String: sResult = ""
  552.     Dim sDeleted As String: sDeleted = ","
  553.     Dim iPos As Long
  554.     Dim lngLoop As Long
  555.  
  556.     ' CREATE A LIST OF DELETED ITEMS
  557.     iPos = 0
  558.     While arrDict(iPos).NextFree > 0
  559.         iPos = arrDict(iPos).NextFree
  560.         sDeleted = sDeleted + arrDict(iPos).Key + ","
  561.     Wend
  562.  
  563.     ' DUMP ALL ITEMS
  564.     sResult = sResult + "Dictionary size: " + cstr$(UBound(arrDict) + 1) + Chr$(13)
  565.     For lngLoop = 1 To UBound(arrDict)
  566.         If InStr(1, sDeleted, "," + arrDict(lngLoop).Key + ",") = 0 Then
  567.             sResult = sResult + "Item(" + cstrl$(lngLoop) + ")" + Chr$(13)
  568.         Else
  569.             sResult = sResult + "*DELETED* Item(" + cstrl$(lngLoop) + ")" + Chr$(13)
  570.         End If
  571.         sResult = sResult + "    .Key     =" + Chr$(34) + arrDict(lngLoop).Key + Chr$(34) + Chr$(13)
  572.         sResult = sResult + "    .IntValue=" + cstr$(arrDict(lngLoop).intValue) + Chr$(13)
  573.         sResult = sResult + "    .lngValue=" + cstrl$(arrDict(lngLoop).lngValue) + Chr$(13)
  574.         sResult = sResult + "    .strValue=" + Chr$(34) + arrDict(lngLoop).strValue + Chr$(34) + Chr$(13)
  575.         sResult = sResult + "    .NextFree=" + cstrl$(arrDict(lngLoop).NextFree) + Chr$(13)
  576.         sResult = sResult + Chr$(13)
  577.     Next lngLoop
  578.  
  579.     sResult = sResult + Chr$(13)
  580.     sResult = sResult + "First deleted: " + cstrl$(arrDict(0).NextFree) + Chr$(13)
  581.  
  582.     ' RETURN RESULTS
  583.     DumpDictionary$ = sResult
  584. End Function ' DumpDictionary$
  585.  
  586. ' /////////////////////////////////////////////////////////////////////////////
  587.  
  588. Function cstr$ (myValue)
  589.     cstr = LTrim$(RTrim$(Str$(myValue)))
  590. End Function ' cstr$
  591.  
  592. ' /////////////////////////////////////////////////////////////////////////////
  593. ' Convert a Long value to string and trim it (because normal Str$ adds spaces)
  594.  
  595. Function cstrl$ (myValue As Long)
  596.     cstrl$ = _Trim$(Str$(myValue))
  597. End Function ' cstrl$
  598.  
  599. ' /////////////////////////////////////////////////////////////////////////////
  600.  
  601. Function IIF (Condition, IfTrue, IfFalse)
  602.     If Condition Then IIF = IfTrue Else IIF = IfFalse
  603.  
  604. ' /////////////////////////////////////////////////////////////////////////////
  605.  
  606. Function IIFSTR$ (Condition, IfTrue$, IfFalse$)
  607.     If Condition Then IIFSTR$ = IfTrue$ Else IIFSTR$ = IfFalse$
  608.  
  609. ' /////////////////////////////////////////////////////////////////////////////
  610. ' Split and join strings
  611. ' https://www.qb64.org/forum/index.php?topic=1073.0
  612.  
  613. 'Combine all elements of in$() into a single string with delimiter$ separating the elements.
  614.  
  615. Function join$ (in$(), delimiter$)
  616.     Dim result$
  617.     Dim i As Long
  618.     result$ = in$(LBound(in$))
  619.     For i = LBound(in$) + 1 To UBound(in$)
  620.         result$ = result$ + delimiter$ + in$(i)
  621.     Next i
  622.     join$ = result$
  623. End Function ' join$
  624.  
  625. ' /////////////////////////////////////////////////////////////////////////////
  626. ' Split and join strings
  627. ' https://www.qb64.org/forum/index.php?topic=1073.0
  628. '
  629. ' FROM luke, QB64 Developer
  630. ' Date: February 15, 2019, 04:11:07 AM »
  631. '
  632. ' Given a string of words separated by spaces (or any other character),
  633. ' splits it into an array of the words. I've no doubt many people have
  634. ' written a version of this over the years and no doubt there's a million
  635. ' ways to do it, but I thought I'd put mine here so we have at least one
  636. ' version. There's also a join function that does the opposite
  637. ' array -> single string.
  638. '
  639. ' Code is hopefully reasonably self explanatory with comments and a little demo.
  640. ' Note, this is akin to Python/JavaScript split/join, PHP explode/implode.
  641.  
  642. 'Split in$ into pieces, chopping at every occurrence of delimiter$. Multiple consecutive occurrences
  643. 'of delimiter$ are treated as a single instance. The chopped pieces are stored in result$().
  644. '
  645. 'delimiter$ must be one character long.
  646. 'result$() must have been REDIMmed previously.
  647.  
  648. ' Modified to handle multi-character delimiters
  649.  
  650. Sub split (in$, delimiter$, result$())
  651.     Dim start As Integer
  652.     Dim finish As Integer
  653.     Dim iDelimLen As Integer
  654.     ReDim result$(-1)
  655.  
  656.     iDelimLen = Len(delimiter$)
  657.  
  658.     start = 1
  659.     Do
  660.         'While Mid$(in$, start, 1) = delimiter$
  661.         While Mid$(in$, start, iDelimLen) = delimiter$
  662.             'start = start + 1
  663.             start = start + iDelimLen
  664.             If start > Len(in$) Then
  665.                 Exit Sub
  666.             End If
  667.         Wend
  668.         finish = InStr(start, in$, delimiter$)
  669.         If finish = 0 Then
  670.             finish = Len(in$) + 1
  671.         End If
  672.  
  673.         ReDim _Preserve result$(0 To UBound(result$) + 1)
  674.  
  675.         result$(UBound(result$)) = Mid$(in$, start, finish - start)
  676.         start = finish + 1
  677.     Loop While start <= Len(in$)
  678. End Sub ' split
  679.  
  680. ' /////////////////////////////////////////////////////////////////////////////
  681.  
  682. Sub SplitTest
  683.     Dim in$
  684.     Dim delim$
  685.     ReDim arrTest$(0)
  686.     Dim iLoop%
  687.  
  688.     delim$ = Chr$(10)
  689.     in$ = "this" + delim$ + "is" + delim$ + "a" + delim$ + "test"
  690.     Print "in$ = " + Chr$(34) + in$ + Chr$(34)
  691.     Print "delim$ = " + Chr$(34) + delim$ + Chr$(34)
  692.     split in$, delim$, arrTest$()
  693.  
  694.     For iLoop% = LBound(arrTest$) To UBound(arrTest$)
  695.         Print "arrTest$(" + LTrim$(RTrim$(Str$(iLoop%))) + ") = " + Chr$(34) + arrTest$(iLoop%) + Chr$(34)
  696.     Next iLoop%
  697.     Print
  698.     Print "Split test finished."
  699. End Sub ' SplitTest
  700.  
  701. ' /////////////////////////////////////////////////////////////////////////////
  702.  
« Last Edit: December 15, 2021, 12:58:53 am by madscijr »