module Data.PrimitiveArray.Index.BitSet1 where
import Control.DeepSeq (NFData(..))
import Control.Lens (makeLenses)
import Control.Monad.Except
import Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey)
import Data.Binary (Binary)
import Data.Bits
import Data.Bits.Extras
import Data.Hashable (Hashable)
import Data.Serialize (Serialize)
import Data.Vector.Unboxed.Deriving
import Data.Vector.Unboxed (Unbox(..))
import Debug.Trace
import GHC.Generics (Generic)
import qualified Data.Vector.Fusion.Stream.Monadic as SM
import Test.QuickCheck
import Data.Bits.Ordered
import Data.PrimitiveArray.Index.BitSet0 (BitSet(..),LimitType(..))
import Data.PrimitiveArray.Index.BitSetClasses
import Data.PrimitiveArray.Index.Class
import Data.PrimitiveArray.Index.IOC
data BitSet1 i ioc = BitSet1 { _bitset ∷ !(BitSet ioc), _boundary ∷ !(Boundary i ioc) }
deriving (Eq,Ord,Generic,Show)
makeLenses ''BitSet1
derivingUnbox "BitSet1"
[t| forall i ioc . BitSet1 i ioc → (Int,Int) |]
[| \ (BitSet1 (BitSet set) (Boundary bnd)) → (set,bnd) |]
[| \ (set,bnd) → BitSet1 (BitSet set) (Boundary bnd) |]
instance Index (BitSet1 bnd ioc) where
newtype LimitType (BitSet1 bnd ioc) = LtNumBits1 Int
linearIndex (LtNumBits1 pc) (BitSet1 set (Boundary bnd))
= linearIndex (LtBitSet pc) set * pc + bnd
{-# Inline linearIndex #-}
size (LtNumBits1 pc) = 2^pc * pc + 1
{-# Inline size #-}
inBounds (LtNumBits1 pc) (BitSet1 set bnd) = popCount set <= pc && 0 <= bnd && getBoundary bnd <= pc
{-# Inline inBounds #-}
zeroBound = BitSet1 zeroBound zeroBound
{-# Inline zeroBound #-}
zeroBound' = LtNumBits1 0
{-# Inline zeroBound' #-}
totalSize (LtNumBits1 pc) =
let z = fromIntegral pc
in [z * 2 ^ z]
deriving instance Show (LimitType (BitSet1 bnd ioc))
instance IndexStream z ⇒ IndexStream (z:.BitSet1 i I) where
streamUp (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamUpMk l h) (streamUpStep l h) $ streamUp ls hs
streamDown (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs
{-# Inline streamUp #-}
{-# Inline streamDown #-}
instance IndexStream z ⇒ IndexStream (z:.BitSet1 i O) where
streamUp (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamUp ls hs
streamDown (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamUpMk l h) (streamUpStep l h) $ streamDown ls hs
{-# Inline streamUp #-}
{-# Inline streamDown #-}
instance IndexStream (Z:.BitSet1 i t) ⇒ IndexStream (BitSet1 i t) where
streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)
{-# Inline streamUp #-}
streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)
{-# Inline streamDown #-}
streamUpMk ∷ Monad m ⇒ Int → Int → z → m (z, Maybe (BitSet1 c ioc))
streamUpMk l h z =
let set = BitSet $ 2^l-1
bnd = Boundary 0
in return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)
{-# Inline [0] streamUpMk #-}
streamUpStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))
streamUpStep l h (z, Nothing) = return $ SM.Done
streamUpStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)
{-# Inline [0] streamUpStep #-}
streamDownMk ∷ Monad m ⇒ Int → Int → z → m (z, Maybe (BitSet1 c ioc))
streamDownMk l h z =
let set = BitSet $ 2^h-1
bnd = Boundary 0
in return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)
{-# Inline [0] streamDownMk #-}
streamDownStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))
streamDownStep l h (z, Nothing) = return $ SM.Done
streamDownStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)
{-# Inline [0] streamDownStep #-}
instance SetPredSucc (BitSet1 t ioc) where
setSucc pcl pch (BitSet1 s (Boundary is))
| cs > pch = Nothing
| Just is' <- maybeNextActive is s = Just $ BitSet1 s (Boundary is')
| Just s' <- popPermutation pch s = Just $ BitSet1 s' (Boundary $ lsbZ s')
| cs >= pch = Nothing
| cs < pch = let s' = BitSet $ 2^(cs+1)-1
in Just (BitSet1 s' (Boundary (lsbZ s')))
where cs = popCount s
{-# Inline setSucc #-}
setPred pcl pch (BitSet1 s (Boundary is))
| cs < pcl = Nothing
| Just is' <- maybeNextActive is s = Just $ BitSet1 s (Boundary is')
| Just s' <- popPermutation pch s = Just $ BitSet1 s' (Boundary $ lsbZ s')
| cs <= pcl = Nothing
| cs > pcl = let s' = BitSet $ 2^(cs-1)-1
in Just (BitSet1 s' (Boundary (max 0 $ lsbZ s')))
where cs = popCount s
{-# Inline setPred #-}
instance Arbitrary (BitSet1 t ioc) where
arbitrary = do
s <- arbitrary
if s==0
then return (BitSet1 s 0)
else do i <- elements $ activeBitsL s
return (BitSet1 s $ Boundary i)
shrink (BitSet1 s i) =
let s' = [ BitSet1 (s `clearBit` a) i
| a <- activeBitsL s
, Boundary a /= i ]
++ [ BitSet1 0 0 | popCount s == 1 ]
in s' ++ concatMap shrink s'