{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Bit.Internal where
import Data.Bits
import Data.List
import Data.Typeable
newtype Bit = Bit { unBit :: Bool }
deriving (Bounded, Enum, Eq, Ord, FiniteBits, Bits, Typeable)
fromBool :: Bool -> Bit
fromBool b = Bit b
instance Show Bit where
showsPrec _ (Bit False) = showString "0"
showsPrec _ (Bit True ) = showString "1"
instance Read Bit where
readsPrec p (' ':rest) = readsPrec p rest
readsPrec _ ('0':rest) = [(Bit False, rest)]
readsPrec _ ('1':rest) = [(Bit True, rest)]
readsPrec _ _ = []
lg2 :: Int -> Int
lg2 n = i
where Just i = findIndex (>= toInteger n) (iterate (`shiftL` 1) 1)
wordSize :: Int
wordSize = finiteBitSize (0 :: Word)
lgWordSize, wordSizeMask, wordSizeMaskC :: Int
lgWordSize = case wordSize of
32 -> 5
64 -> 6
_ -> lg2 wordSize
wordSizeMask = wordSize - 1
wordSizeMaskC = complement wordSizeMask
divWordSize :: Bits a => a -> a
divWordSize x = shiftR x lgWordSize
modWordSize :: Int -> Int
modWordSize x = x .&. (wordSize - 1)
mulWordSize :: Bits a => a -> a
mulWordSize x = shiftL x lgWordSize
nWords :: Int -> Int
nWords ns = divWordSize (ns + wordSize - 1)
nBits :: Bits a => a -> a
nBits ns = mulWordSize ns
aligned :: Int -> Bool
aligned x = (x .&. wordSizeMask == 0)
notAligned :: Int -> Bool
notAligned x = x /= alignDown x
alignUp :: Int -> Int
alignUp x
| x == x' = x'
| otherwise = x' + wordSize
where x' = alignDown x
alignDown :: Int -> Int
alignDown x = x .&. wordSizeMaskC
readBit :: Int -> Word -> Bit
readBit i w = fromBool (w .&. (1 `unsafeShiftL` i) /= 0)
extendToWord :: Bit -> Word
extendToWord (Bit False) = 0
extendToWord (Bit True) = complement 0
mask :: Int -> Word
mask b = m
where
m | b >= finiteBitSize m = complement 0
| b < 0 = 0
| otherwise = bit b - 1
masked :: Int -> Word -> Word
masked b x = x .&. mask b
isMasked :: Int -> Word -> Bool
isMasked b x = (masked b x == x)
meld :: Int -> Word -> Word -> Word
meld b lo hi = (lo .&. m) .|. (hi .&. complement m)
where m = mask b
{-# INLINE extractWord #-}
extractWord :: Int -> Word -> Word -> Word
extractWord k lo hi = (lo `shiftR` k) .|. (hi `shiftL` (wordSize - k))
{-# INLINE spliceWord #-}
spliceWord :: Int -> Word -> Word -> Word -> (Word, Word)
spliceWord k lo hi x =
( meld k lo (x `shiftL` k)
, meld k (x `shiftR` (wordSize - k)) hi
)
reverseWord :: Word -> Word
reverseWord xx = foldr swap xx masks
where
nextMask (d, x) = (d', x `xor` shift x d')
where !d' = d `shiftR` 1
!(_:masks) =
takeWhile ((0 /=) . snd)
(iterate nextMask (finiteBitSize xx, maxBound))
swap (n, m) x = ((x .&. m) `shiftL` n) .|. ((x .&. complement m) `shiftR` n)
reversePartialWord :: Int -> Word -> Word
reversePartialWord n w
| n >= wordSize = reverseWord w
| otherwise = reverseWord w `shiftR` (wordSize - n)
diff :: Word -> Word -> Word
diff w1 w2 = w1 .&. complement w2
ffs :: Word -> Maybe Int
ffs 0 = Nothing
ffs x = Just $! (popCount (x `xor` complement (-x)) - 1)
bitsInWord :: Int -> Word -> [Int] -> [Int]
bitsInWord j = loop id
where
loop is !w = case ffs w of
Nothing -> is
Just i -> loop (is . (j + i :)) (clearBit w i)
selectWord :: Word -> Word -> (Int, Word)
selectWord m x = loop 0 0 0
where
loop !i !ct !y
| i >= wordSize = (ct, y)
| testBit m i = loop (i+1) (ct+1) (if testBit x i then setBit y ct else y)
| otherwise = loop (i+1) ct y