Хеш-таблица со строковыми ключами.

[The trick]

Код: Выделить всё

' //
' // CHashTable.cls - hash table with string keys
' // The trick, 2023
' //

Option Explicit
Option Base 0

Private Const HASH_SIZE As Long = 587

Private Type tHashPointer
    lHash   As Long
    lIndex  As Long
End Type

Private Type tHashItem
    vValue      As Variant
    sKey        As String
    lNext       As Long
    lPrevEnum   As Long
    lNextEnum   As Long
End Type

Private Declare Function CharLowerBuff Lib "user32" _
                         Alias "CharLowerBuffW" ( _
                         ByVal lpsz As Long, _
                         ByVal cchLength As Long) As Long
Private Declare Sub HashData Lib "shlwapi" ( _
                    ByRef pbData As Any, _
                    ByVal cbData As Long, _
                    ByRef pbHash As Any, _
                    ByVal cbHash As Long)

Private m_tItems()          As tHashItem
Private m_bCaseInsensitive  As Boolean
Private m_lCount            As Long
Private m_lFirstFree        As Long
Private m_lFirstItem        As Long
Private m_lLastItem         As Long

Public Property Get CaseInsensitive() As Boolean
    CaseInsensitive = m_bCaseInsensitive
End Property

Public Property Let CaseInsensitive( _
                    ByVal bValue As Boolean)
   
    If m_lCount Then
        Err.Raise 5
    End If
   
    m_bCaseInsensitive = bValue
   
End Property

Public Function Exists( _
                ByRef sKey As String) As Boolean
    Exists = FindItem(sKey).lIndex <> -1
End Function

Public Property Get Item( _
                    ByRef sKey As String) As Variant
    Dim tPointer    As tHashPointer
   
    tPointer = FindItem(sKey)
   
    If tPointer.lIndex = -1 Then
        Item = Empty
    Else
        If IsObject(m_tItems(tPointer.lIndex).vValue) Then
            Set Item = m_tItems(tPointer.lIndex).vValue
        Else
             Item = m_tItems(tPointer.lIndex).vValue
        End If
    End If

End Property

Public Property Let Item( _
                    ByRef sKey As String, _
                    ByVal vValue As Variant)
    Dim tPointer    As tHashPointer
   
    tPointer = FindItem(sKey)

    If IsEmpty(vValue) Then
        If tPointer.lIndex = -1 Then
            Exit Property
        Else
            DeleteItem sKey
        End If
    Else
   
        If tPointer.lIndex = -1 Then
            tPointer = AddItem(sKey)
        End If
       
        m_tItems(tPointer.lIndex).vValue = vValue
       
    End If
   
End Property

Public Property Set Item( _
                    ByRef sKey As String, _
                    ByVal vValue As Variant)
    Dim tPointer    As tHashPointer
   
    tPointer = FindItem(sKey)

    If IsEmpty(vValue) Then
        If tPointer.lIndex = -1 Then
            Exit Property
        Else
            DeleteItem sKey
        End If
    Else
   
        If tPointer.lIndex = -1 Then
            tPointer = AddItem(sKey)
        End If
       
        Set m_tItems(tPointer.lIndex).vValue = vValue
       
    End If
   
End Property

Public Property Get Count() As Long
    Count = m_lCount
End Property

Public Sub Clear()
    Dim lIndex  As Long
   
    ReDim m_tItems(HASH_SIZE - 1)
   
    For lIndex = 0 To HASH_SIZE - 1
   
        m_tItems(lIndex).lNext = -1
        m_tItems(lIndex).lNextEnum = -1
        m_tItems(lIndex).lPrevEnum = -1
       
    Next
   
    m_lFirstFree = HASH_SIZE
    m_lFirstItem = -1
    m_lLastItem = -1
    m_lCount = 0
   
End Sub

Public Property Get Items() As Variant
    Dim lIndex      As Long
    Dim lItemIndex  As Long
    Dim vRet()      As Variant
   
    If m_lCount Then
       
        ReDim vRet(m_lCount - 1)
       
        lItemIndex = m_lFirstItem
       
        For lIndex = 0 To m_lCount - 1
       
            If IsObject(m_tItems(lItemIndex).vValue) Then
                Set vRet(lIndex) = m_tItems(lItemIndex).vValue
            Else
                vRet(lIndex) = m_tItems(lItemIndex).vValue
            End If
           
            lItemIndex = m_tItems(lItemIndex).lNextEnum
           
        Next
       
        Items = vRet
       
    Else
        Items = Split("")
    End If
   
End Property

Public Property Get Keys() As String()
    Dim lIndex      As Long
    Dim lItemIndex  As Long
    Dim sRet()      As String
   
    If m_lCount Then
       
        ReDim sRet(m_lCount - 1)
       
        lItemIndex = m_lFirstItem
       
        For lIndex = 0 To m_lCount - 1
       
            sRet(lIndex) = m_tItems(lItemIndex).sKey
            lItemIndex = m_tItems(lItemIndex).lNextEnum
           
        Next
   
    End If
   
    Keys = sRet
   
End Property

Public Function CalculateHash( _
                ByVal sKey As String) As Long
    Dim lHash   As Long
   
    If m_bCaseInsensitive Then
        CharLowerBuff StrPtr(sKey), Len(sKey)
    End If
   
    HashData ByVal StrPtr(sKey), LenB(sKey), lHash, Len(lHash)
   
    CalculateHash = (lHash And &H7FFFFFFF) Mod HASH_SIZE
   
End Function

Private Sub DeleteItem( _
            ByRef sKey As String)
    Dim lHash       As Long
    Dim lIndex      As Long
    Dim lNextIndex  As Long
    Dim lPrevIndex  As Long
    Dim eComp       As VbCompareMethod
   
    lHash = CalculateHash(sKey)
   
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
   
    lIndex = lHash
    lPrevIndex = -1
   
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
   
        lPrevIndex = lIndex
        lIndex = m_tItems(lIndex).lNext
        If lIndex = -1 Then Exit Sub    ' // Not found
       
    Loop

    If lPrevIndex = -1 Then
       
        ' // In main hash table
        lNextIndex = m_tItems(lIndex).lNext

        If lNextIndex <> -1 Then
           
            ' // Move next collision to main table
            m_tItems(lIndex).sKey = m_tItems(lNextIndex).sKey
           
            If IsObject(m_tItems(lNextIndex).vValue) Then
                Set m_tItems(lIndex).vValue = m_tItems(lNextIndex).vValue
            Else
                m_tItems(lIndex).vValue = m_tItems(lNextIndex).vValue
            End If
           
            If m_tItems(lIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
            End If
           
            If m_tItems(lIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
            End If
           
            If m_tItems(lNextIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lNextIndex).lPrevEnum).lNextEnum = lIndex
            End If
           
            If m_tItems(lNextIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lNextIndex).lNextEnum).lPrevEnum = lIndex
            End If
           
            If m_lFirstItem = lNextIndex Then
                m_lFirstItem = lIndex
            ElseIf m_lFirstItem = lIndex Then
                If m_tItems(lIndex).lNextEnum <> lNextIndex Then
                    m_lFirstItem = m_tItems(lIndex).lNextEnum
                End If
            End If
           
            If m_lLastItem = lNextIndex Then
                m_lLastItem = lIndex
            ElseIf m_lLastItem = lIndex Then
                If m_tItems(lIndex).lPrevEnum <> lNextIndex Then
                    m_lLastItem = m_tItems(lIndex).lPrevEnum
                End If
            End If
           
            m_tItems(lIndex).lNextEnum = m_tItems(lNextIndex).lNextEnum
            m_tItems(lIndex).lPrevEnum = m_tItems(lNextIndex).lPrevEnum
            m_tItems(lIndex).lNext = m_tItems(lNextIndex).lNext
           
            DeallocItem lNextIndex
           
        Else
           
            If m_lFirstItem = lIndex Then
                m_lFirstItem = m_tItems(lIndex).lNextEnum
            End If
           
            If m_lLastItem = lIndex Then
                m_lLastItem = m_tItems(lIndex).lPrevEnum
            End If
           
            If m_tItems(lIndex).lNextEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
            End If
           
            If m_tItems(lIndex).lPrevEnum <> -1 Then
                m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
            End If

            m_tItems(lIndex).sKey = vbNullString
            m_tItems(lIndex).vValue = Empty
            m_tItems(lIndex).lNext = -1
            m_tItems(lIndex).lNextEnum = -1
            m_tItems(lIndex).lPrevEnum = -1
           
        End If

    Else
       
        m_tItems(lPrevIndex).lNext = m_tItems(lIndex).lNext
       
        If m_lFirstItem = lIndex Then
            m_lFirstItem = m_tItems(lIndex).lNextEnum
        End If
       
        If m_lLastItem = lIndex Then
            m_lLastItem = m_tItems(lIndex).lPrevEnum
        End If
           
        If m_tItems(lIndex).lNextEnum <> -1 Then
            m_tItems(m_tItems(lIndex).lNextEnum).lPrevEnum = m_tItems(lIndex).lPrevEnum
        End If
       
        If m_tItems(lIndex).lPrevEnum <> -1 Then
            m_tItems(m_tItems(lIndex).lPrevEnum).lNextEnum = m_tItems(lIndex).lNextEnum
        End If
       
        DeallocItem lIndex
       
    End If
   
    m_lCount = m_lCount - 1
   
End Sub

Private Function AddItem( _
                 ByRef sKey As String) As tHashPointer
    Dim lIndex      As Long
    Dim lNewIndex   As Long
    Dim eComp       As VbCompareMethod
   
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
   
    lIndex = CalculateHash(sKey)
   
    AddItem.lHash = lIndex
   
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
        If m_tItems(lIndex).lNext = -1 Then
           
            If lIndex = AddItem.lHash And Len(m_tItems(lIndex).sKey) = 0 Then
                lNewIndex = lIndex
            Else
                lNewIndex = AllocItem
                m_tItems(lIndex).lNext = lNewIndex
            End If
           
            m_tItems(lNewIndex).sKey = sKey
            m_tItems(lNewIndex).lNext = -1
            m_tItems(lNewIndex).lNextEnum = -1
           
            If m_lFirstItem = -1 Then
                m_lFirstItem = lNewIndex
            End If
           
            m_tItems(lNewIndex).lPrevEnum = m_lLastItem
           
            If m_lLastItem <> -1 Then
                m_tItems(m_lLastItem).lNextEnum = lNewIndex
            End If
           
            m_lLastItem = lNewIndex
           
            lIndex = lNewIndex
           
            m_lCount = m_lCount + 1
           
            Exit Do
           
        Else
            lIndex = m_tItems(lIndex).lNext
        End If
    Loop
   
    AddItem.lIndex = lIndex
   
End Function

Private Function FindItem( _
                 ByRef sKey As String) As tHashPointer
    Dim lIndex  As Long
    Dim eComp   As VbCompareMethod
   
    If m_bCaseInsensitive Then
        eComp = vbTextCompare
    Else
        eComp = vbBinaryCompare
    End If
   
    lIndex = CalculateHash(sKey)
   
    FindItem.lHash = lIndex
   
    Do While StrComp(sKey, m_tItems(lIndex).sKey, eComp)
        lIndex = m_tItems(lIndex).lNext
        If lIndex = -1 Then Exit Do
    Loop
   
    FindItem.lIndex = lIndex
   
End Function

Private Sub DeallocItem( _
            ByVal lIndex As Long)
               
    m_tItems(lIndex).sKey = vbNullString
    m_tItems(lIndex).vValue = Empty
    m_tItems(lIndex).lNext = m_lFirstFree
    m_tItems(lIndex).lNextEnum = -1
    m_tItems(lIndex).lPrevEnum = -1
   
    m_lFirstFree = lIndex
               
End Sub

Private Function AllocItem() As Long
    Dim lIndex      As Long
    Dim lCurSize    As Long
   
    If m_lFirstFree > UBound(m_tItems) Then
       
        lCurSize = (UBound(m_tItems) + 1)
        ReDim Preserve m_tItems(lCurSize * 2 - 1)
       
        For lIndex = lCurSize To UBound(m_tItems)
       
            m_tItems(lIndex).lNext = lIndex + 1
            m_tItems(lIndex).lNextEnum = -1
            m_tItems(lIndex).lPrevEnum = -1
           
        Next
       
    End If
   
    AllocItem = m_lFirstFree
    m_lFirstFree = m_tItems(m_lFirstFree).lNext
   
End Function

Private Sub Class_Initialize()

    Clear
    m_bCaseInsensitive = True
   
End Sub