Binaryworld - HashTable - a class module for storing (key,value) pairs ... [ VB -> Class & object ]

'----------------------------------------------
' HASHTABLE class module
'
' This class implements a hashtable, a structure that offers many
' of the features of a collectior or dictionary, and is often
' even faster than the built-in collection.
'
' NOTE: must make Item the default member, using the Tools | Procedure
' Attributes dialog
'
' Usage:
' Dim ht As New HashTable
' ht.SetSize 10000      ' initial number of slots (the higher,
' the better)
'
' ' enforce case-insensitive key search
' ht.IgnoreCase = True
' ' add values
' ht.Add "key", value    ' add a value associated to a key
' ' count how many values are in the table
' Print ht.Count
' ' read/write a value
' Print ht("key")
' ht("key") = newValue
'
' ' remove a value
' ht.Remove "key"
' ' remove all values
' ht.RemoveAll
' ' check whether a value exists
' If ht.Exists("key") Then ...
'
' ' get the array of keys and values
' Dim keys() As String, values() As Variant
' keys() = ht.Keys
' values() = ht.Values
'
'----------------------------------------------

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
  Any, source As Any, ByVal bytes As Long)

' default values
Const DEFAULT_HASHSIZE = 1024
Const DEFAULT_LISTSIZE = 2048
Const DEFAULT_CHUNKSIZE = 1024

Option Explicit

Private Type SlotType
  Key As String
  Value As Variant
  nextItem As Long   ' 0 if last item
End Type

' for each hash code this array holds the first element
' in slotTable() with the corresponding hash code
Dim hashTbl() As Long
' the array that holds the data
Dim slotTable() As SlotType

' pointer to first free slot
Dim FreeNdx As Long

' size of hash table
Dim m_HashSize As Long
' size of slot table
Dim m_ListSize As Long
' chunk size
Dim m_ChunkSize As Long
' items in the slot table
Dim m_Count As Long

' member variable for IgnoreCase property
Private m_IgnoreCase As Boolean

' True if keys are searched in case-unsensitive mode
' this can be assigned to only when the hash table is empty

Property Get IgnoreCase() As Boolean
  IgnoreCase = m_IgnoreCase
End Property

Property Let IgnoreCase(ByVal newValue As Boolean)
  If m_Count Then
    Err.Raise 1001, , "The Hash Table isn't empty"
  End If
  m_IgnoreCase = newValue
End Property

' initialize the hash table

Sub SetSize(ByVal HashSize As Long, Optional ByVal ListSize As Long, _
  Optional ByVal ChunkSize As Long)
  ' provide defaults
  If ListSize <= 0 Then ListSize = m_ListSize
  If ChunkSize <= 0 Then ChunkSize = m_ChunkSize
  ' save size values
  m_HashSize = HashSize
  m_ListSize = ListSize
  m_ChunkSize = ChunkSize
  m_Count = 0
  ' rebuild tables
  FreeNdx = 0
  ReDim hashTbl(0 To HashSize - 1) As Long
  ReDim slotTable(0) As SlotType
  ExpandSlotTable m_ListSize
End Sub

' check whether an item is in the hash table

Function Exists(Key As String) As Boolean
  Exists = GetSlotIndex(Key) <> 0
End Function

' add a new element to the hash table

Sub Add(Key As String, Value As Variant)
  Dim ndx As Long, Create As Boolean

  ' get the index to the slot where the value is
  ' (allocate a new slot if necessary)
  Create = True
  ndx = GetSlotIndex(Key, Create)

  If Create Then
    ' the item was actually added
    If IsObject(Value) Then
      Set slotTable(ndx).Value = Value
    Else
      slotTable(ndx).Value = Value
    End If
  Else
    ' raise error "This key is already associated with an item of this
    ' collection"
    Err.Raise 457
  End If
End Sub

' the value associated to a key
' (empty if not found)

Property Get Item(Key As String) As Variant
  Dim ndx As Long
  ' get the index to the slot where the value is
  ndx = GetSlotIndex(Key)
  If ndx = 0 Then
    ' return Empty if not found
  ElseIf IsObject(slotTable(ndx).Value) Then
    Set Item = slotTable(ndx).Value
  Else
    Item = slotTable(ndx).Value
  End If
End Property

Property Let Item(Key As String, Value As Variant)
  Dim ndx As Long
  ' get the index to the slot where the value is
  ' (allocate a new slot if necessary)
  ndx = GetSlotIndex(Key, True)
  ' store the value
  slotTable(ndx).Value = Value
End Property

Property Set Item(Key As String, Value As Object)
  Dim ndx As Long
  ' get the index to the slot where the value is
  ' (allocate a new slot if necessary)
  ndx = GetSlotIndex(Key, True)
  ' store the value
  Set slotTable(ndx).Value = Value
End Property

' remove an item from the hash table

Sub Remove(Key As String)
  Dim ndx As Long, HCode As Long, LastNdx As Long
  ndx = GetSlotIndex(Key, False, HCode, LastNdx)
  ' raise error if no such element
  If ndx = 0 Then Err.Raise 5

  If LastNdx Then
    ' this isn't the first item in the slotTable() array
    slotTable(LastNdx).nextItem = slotTable(ndx).nextItem
  ElseIf slotTable(ndx).nextItem Then
    ' this is the first item in the slotTable() array
    ' and is followed by one or more items
    hashTbl(HCode) = slotTable(ndx).nextItem
  Else
    ' this is the only item in the slotTable() array
    ' for this hash code
    hashTbl(HCode) = 0
  End If

  ' put the element back in the free list
  slotTable(ndx).nextItem = FreeNdx
  FreeNdx = ndx
  ' we have deleted an item
  m_Count = m_Count - 1

End Sub

' remove all items from the hash table

Sub RemoveAll()
  SetSize m_HashSize, m_ListSize, m_ChunkSize
End Sub

' the number of items in the hash table

Property Get Count() As Long
  Count = m_Count
End Property

' the array of all keys
' (VB5 users: convert return type to Variant)

Property Get Keys() As Variant()
  Dim i As Long, ndx As Long
  Dim n As Long
  ReDim res(0 To m_Count - 1) As Variant

  For i = 0 To m_HashSize - 1
    ' take the pointer from the hash table
    ndx = hashTbl(i)
    ' walk the slottable() array
    Do While ndx
      res(n) = slotTable(ndx).Key
      n = n + 1
      ndx = slotTable(ndx).nextItem
    Loop
  Next

  ' assign to the result
  Keys = res()
End Property

' the array of all values
' (VB5 users: convert return type to Variant)

Property Get Values() As Variant()
  Dim i As Long, ndx As Long
  Dim n As Long
  ReDim res(0 To m_Count - 1) As Variant

  For i = 0 To m_HashSize - 1
    ' take the pointer from the hash table
    ndx = hashTbl(i)
    ' walk the slottable() array
    Do While ndx
      res(n) = slotTable(ndx).Value
      n = n + 1
      ndx = slotTable(ndx).nextItem
    Loop
  Next

  ' assign to the result
  Values = res()
End Property

'-----------------------------------------
' Private procedures
'-----------------------------------------

Private Sub Class_Initialize()
  ' initialize the tables at default size
  SetSize DEFAULT_HASHSIZE, DEFAULT_LISTSIZE, DEFAULT_CHUNKSIZE
End Sub

' expand the slotTable() array

Private Sub ExpandSlotTable(ByVal numEls As Long)
  Dim newFreeNdx As Long, i As Long
  newFreeNdx = UBound(slotTable) + 1

  ReDim Preserve slotTable(0 To UBound(slotTable) + numEls) As SlotType
  ' create the linked list of free items
  For i = newFreeNdx To UBound(slotTable)
    slotTable(i).nextItem = i + 1
  Next
  ' overwrite the last (wrong) value
  slotTable(UBound(slotTable)).nextItem = FreeNdx
  ' we now know where to pick the first free item
  FreeNdx = newFreeNdx
End Sub

' return the hash code of a string

Private Function HashCode(Key As String) As Long
  Dim lastEl As Long, i As Long

  ' copy ansi codes into an array of long
  lastEl = (Len(Key) - 1) \ 4
  ReDim codes(lastEl) As Long
  ' this also converts from Unicode to ANSI
  CopyMemory codes(0), ByVal Key, Len(Key)

  ' XOR the ANSI codes of all characters
  For i = 0 To lastEl
    HashCode = HashCode Xor codes(i)
  Next

End Function

' get the index where an item is stored or 0 if not found
' if Create = True the item is created
'
' on exit Create=True only if a slot has been actually created

Private Function GetSlotIndex(ByVal Key As String, Optional Create As Boolean, _
  Optional HCode As Long, Optional LastNdx As Long) As Long
  Dim ndx As Long

  ' raise error if invalid key
  If Len(Key) = 0 Then Err.Raise 1001, , "Invalid key"

  ' keep case-unsensitiveness into account
  If m_IgnoreCase Then Key = UCase$(Key)
  ' get the index in the hashTbl() array
  HCode = HashCode(Key) Mod m_HashSize
  ' get the pointer to the slotTable() array
  ndx = hashTbl(HCode)

  ' exit if there is no item with that hash code
  Do While ndx
    ' compare key with actual value
    If slotTable(ndx).Key = Key Then Exit Do
    ' remember last pointer
    LastNdx = ndx
    ' check the next item
    ndx = slotTable(ndx).nextItem
  Loop

  ' create a new item if not there
  If ndx = 0 And Create Then
    ndx = GetFreeSlot()
    PrepareSlot ndx, Key, HCode, LastNdx
  Else
    ' signal that no item has been created
    Create = False
  End If
  ' this is the return value
  GetSlotIndex = ndx

End Function

' return the first free slot

Private Function GetFreeSlot() As Long
  ' allocate new memory if necessary
  If FreeNdx = 0 Then ExpandSlotTable m_ChunkSize
  ' use the first slot
  GetFreeSlot = FreeNdx
  ' update the pointer to the first slot
  FreeNdx = slotTable(GetFreeSlot).nextItem
  ' signal this as the end of the linked list
  slotTable(GetFreeSlot).nextItem = 0
  ' we have one more item
  m_Count = m_Count + 1
End Function

' assign a key and value to a given slot

Private Sub PrepareSlot(ByVal Index As Long, ByVal Key As String, _
  ByVal HCode As Long, ByVal LastNdx As Long)
  ' assign the key
  ' keep case-sensitiveness into account
  If m_IgnoreCase Then Key = UCase$(Key)
  slotTable(Index).Key = Key

  If LastNdx Then
    ' this is the successor of another slot
    slotTable(LastNdx).nextItem = Index
  Else
    ' this is the first slot for a given hash code
    hashTbl(HCode) = Index
  End If
End Sub