VBA - Dictionary.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Dictionary"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "Collection of keys and items which maps keys to items with a minimum cost O(1)."
'
' Version: 2017/7/04
'
' Collection of keys and items. Maps keys to items with a minimum cost, O(1).
'
' Features :
'  * Cross platform, no dependencies.
'  * Performs better than Scripting.Dictionary or Collection on large sets.
'  * New methods: TryGet, TryAdd, IndexOf and Clone
'  * Provides introspection on each key/item in the debug view.
'  * Preserves the insertion order and provides access to keys and items by index.
'  * Unlike Scripting.Dictionary, the getter raises an error if the key is missing, unless a default value is provided.
'  * Unlike Scripting.Dictionary, the getter doesn't create an entry if a key is not present.
'
' Usage:
'
'  Dim dict As New Dictionary
'
'  ' Add a key/item and raise an error if the key is already present '
'  dict.Add "a", 1
'
'  ' Assign a key/item. Overwrites the item if the key is already present '
'  dict("a") = 2
'  Set dict("b") = New Collection
'
'  ' Get an item or raise an error if the key is not present '
'  Debug.Print dict("a")
'
'  ' Get an item or a default item if the key is not present '
'  Debug.Print dict("b", Default:=3)
'
'  ' Get an item by reference if key is present '
'  Dim value
'  If dict.TryGet("a", value) Then Debug.Print value
'
'  ' Remove an item if key is present '
'  Dim value
'  If dict.Remove("a", value) Then Debug.Print "Removed " & value
'
'  ' Add an item only if the key is not already present '
'  If dict.TryAdd("a", 5) Then Debug.Print "Successfuly added"
'
'  ' Iterate the Keys/Items (Base 1 index) '
'  For i = 1 To dict.Count
'    Debug.Print dict.Keys(i), dict.Items(i)
'  Next
'
'  ' Get the Keys/Items '
'  Debug.Print Join(dict.Keys, ", ")
'  Debug.Print Join(dict.Items, ", ")
'

Option Explicit
Option Base 1

Public Enum VbCompareMethod
  vbBinaryCompare
  vbTextCompare
End Enum

Private Type TThis
  Compare As VbCompareMethod
  Count As Long        ' Count of entries '
  Deleted As Long      ' Count of deleted entries '
  Keys() As Variant    ' Ordered keys (base 1) '
  Items() As Variant   ' Ordered items (base 1) '
  Hashes() As Long     ' Ordered keys hash '
  Slots() As Long      ' Indexes of the next entry / buckets '
End Type

Private this As TThis


Public Property Get CompareMode() As VbCompareMethod
Attribute CompareMode.VB_Description = "Specifies the type of key comparison. Either vbBinaryCompare or vbTextCompare"
  CompareMode = this.Compare
End Property

Public Property Let CompareMode(ByVal Compare As VbCompareMethod)
  If Count And this.Compare <> Compare Then Err.Raise 9, , "Dictionary not empty"
  this.Compare = Compare
End Property


Public Property Get Count() As Long
Attribute Count.VB_Description = "Number of entries"
  Count = this.Count - this.Deleted
End Property


Private Property Get Entries() As Variant()
  If this.Count - this.Deleted Then x_enum Entries
End Property


Public Function Clone() As Dictionary
  Set Clone = New Dictionary
  Clone.x_load this
End Function


Public Sub Add(Key, Optional Item)
  Dim h&, s&, i&  ' hash, slot, index '
  If x_try_add(Key, h, s, i) Then Else Err.Raise 457, , "Key already associated: " & Key
  If IsObject(Item) Then Set this.Items(i) = Item Else this.Items(i) = Item
End Sub


Public Function Exists(Key) As Boolean
Attribute Exists.VB_Description = "Returns True if the key is present, False otherwise."
  Exists = x_try_get(Key, 0&, 0&, 0&)
End Function


Public Function IndexOf(Key) As Long
  If this.Deleted Then x_resize  ' collapse entries if some were removed '
  x_try_get Key, 0&, 0&, IndexOf
End Function


Public Property Get Item(Key, Optional Default)
  Dim h&, s&, i&  ' hash, slot, index '

  If x_try_get(Key, h, s, i) Then
    If IsObject(this.Items(i)) Then Set Item = this.Items(i) Else Item = this.Items(i)
  Else
    If VBA.IsMissing(Default) Then Err.Raise 9, , "Key not found: " & Key
    If IsObject(Default) Then Set Item = Default Else Item = Default
  End If
End Property


Public Property Let Item(Key, Optional Default, Item)
Attribute Item.VB_Description = "Gets or sets an item. When the key is missing, the getter returns the Default value if provided or raises error 422"
Attribute Item.VB_UserMemId = 0
  Dim h&, s&, i&  ' hash, slot, index '
  x_try_add Key, h, s, i
  this.Items(i) = Item
End Property


Public Property Set Item(Key, Optional Default, Item)
  Dim h&, s&, i&  ' hash, slot, index '
  x_try_add Key, h, s, i
  Set this.Items(i) = Item
End Property


Public Function Keys(Optional ByVal Index As Long)
Attribute Keys.VB_Description = "Returns all the keys (base 1 array) or a key at Index (base 1) if provided"
  If this.Deleted Then x_resize  ' collapse entries if some were removed '

  If Index Then   ' return the key at index '
    If Index > this.Count Then Err.Raise 9
    Keys = this.Keys(Index)
  Else            ' return all the keys in a base1 array '
    If this.Count Then x_copy Keys, this.Keys Else Keys = Array()
  End If
End Function


Public Function Items(Optional ByVal Index As Long)
Attribute Items.VB_Description = "Returns all the items (base 1 array) or an item at Index (base 1) if provided"
  If this.Deleted Then x_resize  ' collapse entries if some were removed '

  If Index Then    ' return the value at index '
    If Index > this.Count Then Err.Raise 9
    If IsObject(this.Items(Index)) Then Set Items = this.Items(Index) Else Items = this.Items(Index)
  Else             ' return all the values in a base1 array '
    If this.Count Then x_copy Items, this.Items Else Items = Array()
  End If
End Function


Public Function TryGet(Key, out) As Boolean
  Dim h&, s&, i&  ' hash, slot, index '
  If x_try_get(Key, h, s, i) Then TryGet = True Else Exit Function
  If IsObject(this.Items(i)) Then Set out = this.Items(i) Else out = this.Items(i)
End Function


Public Function TryAdd(Key, Item) As Boolean
  Dim h&, s&, i&  ' hash, slot, index '
  If x_try_add(Key, h, s, i) Then TryAdd = True Else Exit Function
  If IsObject(Item) Then Set this.Items(i) = Item Else this.Items(i) = Item
End Function


Public Function Remove(Key, Optional out) As Boolean
Attribute Remove.VB_Description = "Tries to removes a key/item pair. Returns True if the key was present, false otherwise."
  Dim h&, s&, i&  ' hash, slot, index '
  If x_try_get(Key, h, s, i) Then Remove = True Else Exit Function
  If VBA.IsMissing(out) Then Else If IsObject(this.Items(i)) Then Set out = this.Items(i) Else out = this.Items(i)
  this.Deleted = this.Deleted + 1&
  this.Slots(s) = this.Slots(i)
  this.Slots(i) = 0&
  this.Hashes(i) = 0&
  this.Keys(i) = Empty
  this.Items(i) = Empty
End Function


Public Sub RemoveAll()
Attribute RemoveAll.VB_Description = "Removes all the key/item."
  this.Count = 0&
  this.Deleted = 0&
  Erase this.Keys, this.Items, this.Hashes, this.Slots
End Sub


Private Function x_try_get(Key, h As Long, s As Long, i As Long) As Boolean
  If this.Count Then Else Exit Function

  h = x_hash(LCase$(Key)) Xor -1& ' get negative hash '
  s = UBound(this.Slots) + (h Mod UBound(this.Hashes)) ' get slot '
  Do
    i = this.Slots(s) ' get index '
    If i Then Else Exit Function  ' return if no entry '
    If this.Hashes(i) = h Then If x_equal(Key, this.Keys(i)) Then Exit Do  ' break if match '
    s = i ' next slot '
  Loop

  x_try_get = True
End Function


Private Function x_try_add(Key, h As Long, s As Long, i As Long) As Boolean
  If this.Count Then Else x_resize
  If this.Count >= UBound(this.Keys) Then x_resize

  h = x_hash(LCase$(Key)) Xor -1& ' get negative hash '
  s = UBound(this.Slots) + (h Mod UBound(this.Hashes)) ' get slot '
  Do
    i = this.Slots(s)  ' get index '
    If i Then Else Exit Do  ' break if no entry '
    If this.Hashes(i) = h Then If x_equal(Key, this.Keys(i)) Then Exit Function   ' exit if match '
    s = i ' next slot '
  Loop

  this.Count = this.Count + 1
  this.Keys(this.Count) = Key
  this.Hashes(this.Count) = h
  this.Slots(s) = this.Count
  i = this.Count

  x_try_add = True
End Function


Private Sub x_resize()
  Dim i&, s&, n&

  If this.Deleted Then  ' collapse entries '
    For i = 1 To this.Count
      If this.Hashes(i) Then  ' if entry '
        n = n + 1&
        this.Hashes(n) = this.Hashes(i)
        this.Keys(n) = this.Keys(i)
        If IsObject(this.Items(i)) Then Set this.Items(n) = this.Items(i) Else this.Items(n) = this.Items(i)
      End If
    Next

    this.Count = n
    this.Deleted = 0
    If n Then ReDim Preserve this.Keys(n), this.Items(n), this.Hashes(n) ' truncate / GC objects '
  End If

  n = 5 + this.Count * 1.973737421
  ReDim Preserve this.Keys(n), this.Items(n), this.Hashes(n)
  ReDim this.Slots(n * 2)

  For i = 1 To this.Count
    s = UBound(this.Slots) + (this.Hashes(i) Mod n)  ' get slot '

    Do While this.Slots(s)  ' until empty slot '
      s = this.Slots(s)
    Loop

    this.Slots(s) = i  ' empty slot gets the index '
  Next

End Sub


Private Function x_hash(buffer() As Byte) As Long
  Dim i&
  For i = 1 To UBound(buffer) Step 2
    x_hash = ((x_hash Mod 69208103) + buffer(i - 1)) * 31& + buffer(i)
  Next
End Function


Private Function x_equal(a, b) As Boolean
  x_equal = (VarType(a) = vbString) = (VarType(b) = vbString) And StrComp(a, b, this.Compare) = 0
End Function


Friend Sub x_load(data As TThis)
  this = data
End Sub


Private Sub x_copy(dest, src)
  dest = src
  ReDim Preserve dest(this.Count)
End Sub


Private Sub x_enum(dest())
  Dim i&, n&
  ReDim dest(1 To this.Count - this.Deleted, 1 To 2)

  For i = 1 To this.Count
    If this.Hashes(i) Then
      n = n + 1
      dest(n, 1) = this.Keys(i)
      If IsObject(this.Items(i)) Then Set dest(n, 2) = this.Items(i) Else dest(n, 2) = this.Items(i)
    End If
  Next
End Sub