modbitops.bas

改进遗传算法程序

Attribute VB_Name = "modBitOps"
Option Explicit

Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&)

'used in mutation
Public Function BitToggle(ByVal value As Long, ByVal bit As Long) As Long
    BitToggle = (value Xor Power2(bit))
End Function

'used for crossover (mating)
Public Function BitToLong(bitexpr As String) As Long
    Static t%(31): Dim asc0%
    If Len(bitexpr) <> 32 Then Exit Function
    RtlMoveMemory t(0), ByVal StrPtr(bitexpr), 64
    asc0 = KeyCodeConstants.vbKey0
    BitToLong = t(1) - asc0
    BitToLong = 2 * BitToLong + t(2) - asc0
    BitToLong = 2 * BitToLong + t(3) - asc0
    BitToLong = 2 * BitToLong + t(4) - asc0
    BitToLong = 2 * BitToLong + t(5) - asc0
    BitToLong = 2 * BitToLong + t(6) - asc0
    BitToLong = 2 * BitToLong + t(7) - asc0
    BitToLong = 2 * BitToLong + t(8) - asc0
    BitToLong = 2 * BitToLong + t(9) - asc0
    BitToLong = 2 * BitToLong + t(10) - asc0
    BitToLong = 2 * BitToLong + t(11) - asc0
    BitToLong = 2 * BitToLong + t(12) - asc0
    BitToLong = 2 * BitToLong + t(13) - asc0
    BitToLong = 2 * BitToLong + t(14) - asc0
    BitToLong = 2 * BitToLong + t(15) - asc0
    BitToLong = 2 * BitToLong + t(16) - asc0
    BitToLong = 2 * BitToLong + t(17) - asc0
    BitToLong = 2 * BitToLong + t(18) - asc0
    BitToLong = 2 * BitToLong + t(19) - asc0
    BitToLong = 2 * BitToLong + t(20) - asc0
    BitToLong = 2 * BitToLong + t(21) - asc0
    BitToLong = 2 * BitToLong + t(22) - asc0
    BitToLong = 2 * BitToLong + t(23) - asc0
    BitToLong = 2 * BitToLong + t(24) - asc0
    BitToLong = 2 * BitToLong + t(25) - asc0
    BitToLong = 2 * BitToLong + t(26) - asc0
    BitToLong = 2 * BitToLong + t(27) - asc0
    BitToLong = 2 * BitToLong + t(28) - asc0
    BitToLong = 2 * BitToLong + t(29) - asc0
    BitToLong = 2 * BitToLong + t(30) - asc0
    BitToLong = t(31) - asc0 + 2 * BitToLong
    If t(0) <> asc0 Then BitToLong = BitToLong Or &H80000000
End Function

'used for crossover (mating)
Public Static Function LongToBit(l As Long) As String
  Dim lDone&, sNibble(0 To 15) As String, sByte(0 To 255) As String
  If lDone = 0 Then
    sNibble(0) = "0000"
    sNibble(1) = "0001"
    sNibble(2) = "0010"
    sNibble(3) = "0011"
    sNibble(4) = "0100"
    sNibble(5) = "0101"
    sNibble(6) = "0110"
    sNibble(7) = "0111"
    sNibble(8) = "1000"
    sNibble(9) = "1001"
    sNibble(10) = "1010"
    sNibble(11) = "1011"
    sNibble(12) = "1100"
    sNibble(13) = "1101"
    sNibble(14) = "1110"
    sNibble(15) = "1111"
    For lDone = 0 To 255
      sByte(lDone) = sNibble(lDone \ &H10) & sNibble(lDone And &HF)
    Next
  End If
  If l < 0 Then
    LongToBit = sByte(128 + (l And &H7FFFFFFF) \ &H1000000 And &HFF) _
                & sByte((l And &H7FFFFFFF) \ &H10000 And &HFF) _
                & sByte((l And &H7FFFFFFF) \ &H100 And &HFF) _
                & sByte(l And &HFF)
  Else
    LongToBit = sByte(l \ &H1000000 And &HFF) _
                & sByte(l \ &H10000 And &HFF) _
                & sByte(l \ &H100 And &HFF) _
                & sByte(l And &HFF)
  End If
End Function

'used by the BitToggle mutation routine
Public Function Power2(ByVal exponent As Long) As Long
    Static res(0 To 31) As Long
    Dim i As Long
    If exponent < 0 Or exponent > 31 Then Err.Raise 5
    If res(0) = 0 Then
        res(0) = 1
        For i = 1 To 30
            res(i) = res(i - 1) * 2
        Next
        res(31) = &H80000000
    End If
    Power2 = res(exponent)
End Function