Visual Basic 4 Power Pack/Visual_Basic4_Power_Pack.bin/vb4files/bitvctr/bitvectr.cls

Text File | 1996-11-20 | 6.1 KB | 276 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BitVector"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
'
' BitVector Class
' Copyright ⌐ 1995-1996 by Gregg S. Irwin. All Rights Reserved.
'

Option Explicit
DefInt A-Z

Const CLASS_NAME = "BitVector"
Const CLASS_VERSION = "110"

'-- Version 100     12/04/95
' ╖ Initial release
'-- Version 110     01/24/96
' ╖ Added Bit Property (read-write)
' ╖ Added validation to NumElements Let procedure


' * PROPERTIES *
' .NumElements
' .Bit(BitIndex)        ; Version 110

' * METHODS    *
' .ClearAll
' .ClearBit (BitIndex)
' .GetBit   (BitIndex)
' .IsBitSet (BitIndex)
' .SetAll
' .SetBit   (BitIndex)
' .Toggle   (BitIndex)

' * ERRORS     *
' Subscript out of range

Const vbErrSubscriptOutOfRange = 9


Const BITS_PER_ELEMENT = 8


Private mBits()      As Byte
Private mNumElements As Long


'-- The following code:
'
'      ArrayIdx = Index \ BITS_PER_ELEMENT
'      Bit = Index Mod BITS_PER_ELEMENT
'
'   appears in a few procedures and could/should be
'   broken out into one or two procedures itself. I
'   just haven't been able to come up with a good,
'   clean syntax that I like yet.


'------------------------------------------------------
'-- CLASS EVENTS
'------------------------------------------------------

' _Initialize
Private Sub Class_Initialize()

End Sub

' _Terminate
Private Sub Class_Terminate()
    Erase mBits
End Sub


'------------------------------------------------------
'-- PROPERTIES
'------------------------------------------------------

' .NumElements
Public Property Let NumElements(NewValue As Long)
    '-- Trap for bad values
    Select Case NewValue
        Case Is > 0
            mNumElements = NewValue
            ReDim Preserve mBits(mNumElements \ BITS_PER_ELEMENT)
            'Debug.Print UBound(mBits)
        Case 0
            mNumElements = 0
            Erase mBits
        Case Else
            Call RaiseError(vbErrSubscriptOutOfRange)
    End Select
End Property

Public Property Get NumElements() As Long
    NumElements = mNumElements
End Property


' .Bit
Public Property Let Bit(Index As Long, NewBitValue As Integer)
    If NewBitValue <> 0 Then
        Call SetBit(Index)
    Else
        Call ClearBit(Index)
    End If
End Property

Public Property Get Bit(Index As Long) As Integer
    Bit = GetBit(Index)
End Property


'------------------------------------------------------
'-- METHODS
'------------------------------------------------------

' .ClearAll
Public Sub ClearAll()
    Dim i As Long

    '-- Set bit values in BITS_PER_ELEMENT chunks for speed
    For i = LBound(mBits) To UBound(mBits)
        mBits(i) = &H0
    Next i

End Sub

' .ClearBit
Public Sub ClearBit(Index As Long)
'-- Set Bit(Index) value to 0
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Clearing ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    mBits(ArrayIdx) = mBits(ArrayIdx) And (Not (2 ^ Bit))

End Sub

' .GetBit
Public Function GetBit(Index As Long) As Integer
'-- Returns 0 or 1

    Call ValidateIndex(Index)

    If IsBitSet(Index) Then
        GetBit = 1
    Else
        GetBit = 0
    End If

End Function

' .IsBitSet
Public Function IsBitSet(Index As Long) As Boolean
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Testing ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    If mBits(ArrayIdx) And 2 ^ Bit Then
        IsBitSet = True
    Else
        IsBitSet = False
    End If

End Function

' .SetAll
Public Sub SetAll()
    Dim i As Long

    '-- Set bit values in BITS_PER_ELEMENT chunks for speed
    For i = LBound(mBits) To UBound(mBits)
        mBits(i) = &HFF
    Next i

End Sub

' .SetBit
Public Sub SetBit(Index As Long)
'-- Set Bit(Index) value to 1
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Setting ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    mBits(ArrayIdx) = mBits(ArrayIdx) Or 2 ^ Bit

End Sub

' .ToggleBit
Public Sub ToggleBit(Index As Long)
'-- Toggle the value of Bit(Index)

    Call ValidateIndex(Index)

    If IsBitSet(Index) Then
        Call ClearBit(Index)
    Else
        Call SetBit(Index)
    End If

End Sub


'------------------------------------------------------
'-- INTERNAL SUPPORT
'------------------------------------------------------

''!! This is an unused (and untested) procedure. It's just
''   here to remind me that we can get the exponentiation
''   out of the inline code and do table lookups instead.
'Private Sub InitBitValueTable(BitValueTable() As Long)
'    Dim i As Integer
'
'    For i = 1 To BITS_PER_ELEMENT
'        BitValueTable(i) = 2 ^ i
'    Next i
'
'End Sub

' .ValidateIndex
Private Sub ValidateIndex(Index As Long)

    '-- Our bounds checking code is aware that this is
    '   a 0 based array of bits.
    If (Index < 0) Or (Index > (mNumElements - 1)) Then
        Call RaiseError(vbErrSubscriptOutOfRange)
    End If

End Sub


'------------------------------------------------------
'-- ERRORS
'------------------------------------------------------

' .GetErrorDesc
Private Function GetErrorDesc(ErrCode As Long) As String
    Dim Desc As String

    Select Case ErrCode
        Case vbErrSubscriptOutOfRange
            Desc = "Subscript out of Range"
        Case Else
            Desc = "Unknown error (" & CStr(ErrCode) & ")"
    End Select

    GetErrorDesc = Desc

End Function


' .RaiseError
Private Sub RaiseError(ErrCode As Long)

    Err.Raise Number:=vbObjectError + ErrCode, _
              Source:=CLASS_NAME & " " & CLASS_VERSION, _
              Description:=GetErrorDesc(ErrCode)

End Sub