hw-rankselect 0.8.0.2 → 0.9.0.0

raw patch · 11 files changed

+827/−425 lines, 11 filesdep +bytestringdep +conduitdep +criteriondep ~basedep ~hw-bitsdep ~hw-primnew-component:exe:hw-rankselect-exePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, conduit, criterion, deepseq, directory, hedgehog, hw-hedgehog, hw-hspec-hedgehog, mmap, resourcet

Dependency ranges changed: base, hw-bits, hw-prim

API changes (from Hackage documentation)

Files

• app/Main.hs +112/−0
• bench/Main.hs +160/−0
• hw-rankselect.cabal +49/−4
• src/HaskellWorks/Data/RankSelect/CsPoppy.hs +189/−92
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs +69/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy2.hs +0/−116
• src/HaskellWorks/Data/RankSelect/Poppy512.hs +38/−27
• src/HaskellWorks/Data/RankSelect/Poppy512S.hs +36/−25
• test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs +42/−0
• test/HaskellWorks/Data/RankSelect/CsPoppy2Spec.hs +0/−94
• test/HaskellWorks/Data/RankSelect/CsPoppySpec.hs +132/−67

@@ -0,0 +1,112 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE ScopedTypeVariables  #-}++module Main where++import Control.Monad+import Data.List+import Data.Monoid ((<>))+import Foreign+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Select1+import System.Directory+import System.Environment+import System.IO.MMap++import qualified Data.Vector.Storable                   as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy   as CS+import qualified HaskellWorks.Data.RankSelect.Poppy512  as P512+import qualified HaskellWorks.Data.RankSelect.Poppy512S as P512S++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}++loadVector64 :: FilePath -> IO (DVS.Vector Word64)+loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing++loadCsPoppy :: FilePath -> IO CS.CsPoppy+loadCsPoppy filename = CS.makeCsPoppy <$> loadVector64 filename++loadPoppy512 :: FilePath -> IO P512.Poppy512+loadPoppy512 filename = P512.makePoppy512 <$> loadVector64 filename++loadPoppy512S :: FilePath -> IO P512S.Poppy512S+loadPoppy512S filename = P512S.makePoppy512S <$> loadVector64 filename++runCsPoppyBuild :: IO ()+runCsPoppyBuild = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    CS.CsPoppy !_ !_ !_ <- loadCsPoppy file+    return ()++runPoppy512Build :: IO ()+runPoppy512Build = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    P512.Poppy512 !_ !_ <- loadPoppy512 file+    -- let !_ = select1 msbs 1+    return ()++runPoppy512SBuild :: IO ()+runPoppy512SBuild = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    P512S.Poppy512S !_ !_ !_ <- loadPoppy512S file+    -- let !_ = select1 msbs 1+    return ()++runPoppy512SelectAll :: IO ()+runPoppy512SelectAll = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    v <- loadPoppy512 file+    forM_ [1..popCount1 v] $ \i -> do+      let !_ = select1 v i+      return ()+    return ()++runPoppy512SSelectAll :: IO ()+runPoppy512SSelectAll = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    v <- loadPoppy512S file+    forM_ [1..popCount1 v] $ \i -> do+      let !_ = select1 v i+      return ()+    return ()++runCsPoppySelectAll :: IO ()+runCsPoppySelectAll = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    putStrLn $ "Loading cspoppy for " <> file+    v <- loadCsPoppy file+    forM_ [1..popCount1 v] $ \i -> do+      let !_ = select1 v i+      return ()+    return ()++main :: IO ()+main = do+  args <- getArgs+  case args of+    ["cspoppy-load"]          -> runCsPoppyBuild+    ["cspoppy-select-all"]    -> runCsPoppySelectAll+    ["poppy512-load"]         -> runPoppy512Build+    ["poppy512-select-all"]   -> runPoppy512SelectAll+    ["poppy512s-load"]        -> runPoppy512SBuild+    ["poppy512s-select-all"]  -> runPoppy512SSelectAll+    _                         -> putStrLn "Invalid arguments"

@@ -0,0 +1,160 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE ScopedTypeVariables  #-}++module Main where++import Control.Monad+import Criterion.Main+import Data.List+import Foreign+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Select1+import System.Directory+import System.Environment+import System.IO.MMap++import qualified Data.Vector.Storable                   as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy   as CS+import qualified HaskellWorks.Data.RankSelect.Poppy512  as P512+import qualified HaskellWorks.Data.RankSelect.Poppy512S as P512S++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}++selectStep :: Count+selectStep = 1000++loadVector64 :: FilePath -> IO (DVS.Vector Word64)+loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing++loadCsPoppy :: FilePath -> IO CS.CsPoppy+loadCsPoppy filename = CS.makeCsPoppy <$> loadVector64 filename++loadPoppy512 :: FilePath -> IO P512.Poppy512+loadPoppy512 filename = P512.makePoppy512 <$> loadVector64 filename++loadPoppy512S :: FilePath -> IO P512S.Poppy512S+loadPoppy512S filename = P512S.makePoppy512S <$> loadVector64 filename++benchCsPoppyBuild :: IO [Benchmark]+benchCsPoppyBuild = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadVector64 filename) $ \bitString -> bgroup filename+          [ bench "CsPoppy Build"  (whnf CS.makeCsPoppy bitString)+          ]++benchCsPoppyRank1 :: IO [Benchmark]+benchCsPoppyRank1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadCsPoppy filename) $ \csPoppy -> bgroup filename+          [ bench "CsPoppy Rank1"  (whnf (CS.rank1 csPoppy) 100)+          ]++benchCsPoppySelect1 :: IO [Benchmark]+benchCsPoppySelect1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadCsPoppy filename) $ \rsbs -> bgroup filename+          [ bench "CsPoppy Select1"  (whnf (go rsbs 1 (popCount1 rsbs) ((popCount1 rsbs `div` 100) + 1)) 0)+          ]+        go rsbs a z step acc | a <= z  = go rsbs (a + step) z step (select1 rsbs a + acc)+        go _    _ _ _    acc           = acc+        {-# INLINE go #-}++benchPoppy512Build :: IO [Benchmark]+benchPoppy512Build = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadVector64 filename) $ \bitString -> bgroup filename+          [ bench "Poppy512 Build"  (whnf P512.makePoppy512 bitString)+          ]++benchPoppy512Rank1 :: IO [Benchmark]+benchPoppy512Rank1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadPoppy512 filename) $ \csPoppy -> bgroup filename+          [ bench "Poppy512 Rank1"  (whnf (CS.rank1 csPoppy) 100)+          ]++benchPoppy512Select1 :: IO [Benchmark]+benchPoppy512Select1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadPoppy512 filename) $ \rsbs -> bgroup filename+          [ bench "Poppy512 Select1"  (whnf (go rsbs 1 (popCount1 rsbs) ((popCount1 rsbs `div` 100) + 1)) 0)+          ]+        go rsbs a z step acc | a <= z  = go rsbs (a + step) z step (select1 rsbs a + acc)+        go _    _ _ _    acc           = acc+        {-# INLINE go #-}++benchPoppy512SBuild :: IO [Benchmark]+benchPoppy512SBuild = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadVector64 filename) $ \bitString -> bgroup filename+          [ bench "Poppy512S Build"  (whnf P512S.makePoppy512S bitString)+          ]++benchPoppy512SRank1 :: IO [Benchmark]+benchPoppy512SRank1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadPoppy512S filename) $ \csPoppy -> bgroup filename+          [ bench "Poppy512S Rank1"  (whnf (CS.rank1 csPoppy) 100)+          ]++benchPoppy512SSelect1 :: IO [Benchmark]+benchPoppy512SSelect1 = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return (mkBenchmark <$> files)+  where mkBenchmark filename = env (loadPoppy512S filename) $ \rsbs -> bgroup filename+          [ bench "Poppy512S Select1"  (whnf (go rsbs 1 (popCount1 rsbs) ((popCount1 rsbs `div` 100) + 1)) 0)+          ]+        go rsbs a z step acc | a <= z  = go rsbs (a + step) z step (select1 rsbs a + acc)+        go _    _ _ _    acc           = acc+        {-# INLINE go #-}++runCsPoppyBuild :: IO ()+runCsPoppyBuild = do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  forM_ files $ \file -> do+    msbs <- loadPoppy512S file+    let !_ = select1 msbs 1+    return ()++runBenchmarks :: IO ()+runBenchmarks = (defaultMain =<<) . (concat <$>) $ sequence+  [ benchCsPoppyBuild+  , benchCsPoppyRank1+  , benchCsPoppySelect1+  , benchPoppy512Build+  , benchPoppy512Rank1+  , benchPoppy512Select1+  , benchPoppy512SBuild+  , benchPoppy512SRank1+  , benchPoppy512SSelect1+  ]+++main :: IO ()+main = do+  args <- getArgs+  case args of+    []                -> runBenchmarks+    ["load-cspoppy"]  -> runCsPoppyBuild+    _                 -> putStrLn "Invalid arguments"

@@ -1,5 +1,5 @@ name:                   hw-rankselect-version:                0.8.0.2+version:                0.9.0.0 synopsis:               Rank-select description:            Please see README.md homepage:               http://github.com/haskell-works/hw-rankselect#readme@@ -16,10 +16,11 @@ library   hs-source-dirs:       src   exposed-modules:      HaskellWorks.Data.RankSelect.CsPoppy-                      , HaskellWorks.Data.RankSelect.CsPoppy2+                      , HaskellWorks.Data.RankSelect.CsPoppy.Internal                       , HaskellWorks.Data.RankSelect.Poppy512                       , HaskellWorks.Data.RankSelect.Poppy512S   build-depends:        base                          >= 4          && < 5+                      , deepseq                       , hw-balancedparens             >= 0.1.0.0                       , hw-bits                       >= 0.3.0.0                       , hw-prim                       >= 0.4.0.0@@ -29,27 +30,71 @@   default-language:     Haskell2010   ghc-options:          -Wall -O2 -msse4.2 +executable hw-rankselect-exe+  hs-source-dirs:       app+  main-is:              Main.hs+  default-language:     Haskell2010+  build-depends:        base >= 4.7 && < 5+                      -- , bytestring+                      -- , conduit+                      , directory+                      , hw-bits                       >= 0.4.0.0+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect+                      , hw-rankselect-base            >= 0.2.0.0+                      , mmap+                      -- , resourcet+                      , vector+  ghc-options:       -threaded -rtsopts -O2 -msse4.2+  default-extensions: OverloadedStrings, TupleSections+  if os(darwin)+    cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull=+ test-suite hw-rankselect-test   type:                 exitcode-stdio-1.0   hs-source-dirs:       test   main-is:              Spec.hs   other-modules:        HaskellWorks.Data.RankSelect.BasicGen                       , HaskellWorks.Data.RankSelect.CsPoppySpec-                      , HaskellWorks.Data.RankSelect.CsPoppy2Spec+                      , HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec                       , HaskellWorks.Data.RankSelect.Poppy512Spec                       , HaskellWorks.Data.RankSelect.Poppy512SSpec                       , HaskellWorks.Data.RankSelect.InternalSpec                       , HaskellWorks.Data.RankSelect.SimpleSpec   build-depends:        base                          >= 4          && < 5+                      , directory+                      , hedgehog                       , hspec-                      , hw-bits                       >= 0.3.0.0+                      , hw-bits                       >= 0.4.0.0+                      , hw-hedgehog                   >= 0.1.0.1+                      , hw-hspec-hedgehog                       , hw-prim                       >= 0.4.0.0                       , hw-rankselect                       , hw-rankselect-base            >= 0.2.0.0+                      , mmap                       , QuickCheck                       , vector   ghc-options:          -threaded -rtsopts -with-rtsopts=-N -Wall   default-language:     Haskell2010++benchmark bench+    Type: exitcode-stdio-1.0+    HS-Source-Dirs: bench+    Main-Is: Main.hs+    GHC-Options: -O2 -Wall -msse4.2+    Default-Language: Haskell2010+    Build-Depends:      base                          >= 4          && < 5+                      , bytestring+                      , conduit+                      , criterion+                      , directory+                      , hw-bits                       >= 0.4.0.0+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect+                      , hw-rankselect-base            >= 0.2.0.0+                      , mmap+                      , resourcet+                      , vector  source-repository head   type:     git

@@ -1,31 +1,64 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+ module HaskellWorks.Data.RankSelect.CsPoppy     ( CsPoppy(..)+    , Nice(..)     , Rank1(..)     , makeCsPoppy-    , sampleRange     ) where -import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitLength-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitWise-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.Positioning-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.Search-import           HaskellWorks.Data.Vector.AsVector64+import Control.DeepSeq+import Data.Monoid                                     ((<>))+import Data.Word+import GHC.Generics+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.BalancedParens.BalancedParens+import HaskellWorks.Data.BalancedParens.CloseAt+import HaskellWorks.Data.BalancedParens.Enclose+import HaskellWorks.Data.BalancedParens.FindClose+import HaskellWorks.Data.BalancedParens.FindCloseN+import HaskellWorks.Data.BalancedParens.FindOpen+import HaskellWorks.Data.BalancedParens.FindOpenN+import HaskellWorks.Data.BalancedParens.NewCloseAt+import HaskellWorks.Data.BalancedParens.OpenAt+import HaskellWorks.Data.Bits.BitLength+import HaskellWorks.Data.Bits.BitRead+import HaskellWorks.Data.Bits.BitShow+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.Drop+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal+import HaskellWorks.Data.Take+import HaskellWorks.Data.Vector.AsVector64+import Prelude                                         hiding (drop, length, pi, take) +import qualified Data.Vector.Storable as DVS++newtype Nice a = Nice a deriving Eq+ data CsPoppy = CsPoppy-  { csPoppyBits     :: DVS.Vector Word64-  , csPoppy512Index :: DVS.Vector Word64-  , csPoppyLayer0   :: DVS.Vector Word64-  , csPoppyLayer1   :: DVS.Vector Word64-  , csPoppyLayerS   :: DVS.Vector Word64 -- Sampling position of each 8192 1-bit-  } deriving (Eq, Show)+  { csPoppyBits   :: !(DVS.Vector Word64)+  , csPoppyLayerM :: !(DVS.Vector Word64)+  , csPoppyLayerS :: !(DVS.Vector Word32) -- Sampling lookup of each 8192 1-bit+  } deriving (Eq, Show, NFData, Generic) +instance Show (Nice CsPoppy) where+  showsPrec _ (Nice rsbs) = showString "CsPoppy "+    <> showString "{ csPoppyBits = "   <> shows (bitShow <$> DVS.toList (csPoppyBits     rsbs))+    <> showString ", csPoppyLayer0 = " <> shows (CsInterleaved <$> DVS.toList (csPoppyLayerM rsbs))+    <> showString ", csPoppyLayerS = " <> shows (csPoppyLayerS rsbs)+    <> showString " }"+ instance AsVector64 CsPoppy where   asVector64 = asVector64 . csPoppyBits   {-# INLINE asVector64 #-}@@ -34,49 +67,55 @@   bitLength = bitLength . csPoppyBits   {-# INLINE bitLength #-} -popCount1Range :: (DVS.Storable a, PopCount1 a) => Int -> Int -> DVS.Vector a -> Count-popCount1Range start len = popCount1 . DVS.take len . DVS.drop start+instance PopCount1 CsPoppy where+  popCount1 v = getCsiTotal (CsInterleaved (lastOrZero (csPoppyLayerM v)))+  {-# INLINE popCount1 #-} +indexOrZero :: DVS.Vector Word64 -> Position -> Word64+indexOrZero _ i | i < 0     = 0+indexOrZero v i | i < end v = v !!! i+indexOrZero _ _ = 0+{-# INLINE indexOrZero #-}++lastOrZero :: DVS.Vector Word64 -> Word64+lastOrZero v | 0 < end v  = DVS.last v+lastOrZero _ = 0+{-# INLINE lastOrZero #-}+ makeCsPoppy :: DVS.Vector Word64 -> CsPoppy makeCsPoppy v = CsPoppy-  { csPoppyBits     = v-  , csPoppy512Index = DVS.constructN (((DVS.length v +           8 - 1) `div`           8) + 1) gen512Index-  , csPoppyLayer0   = DVS.constructN (((DVS.length v + 0x100000000 - 1) `div` 0x100000000) + 1) genLayer0-  , csPoppyLayer1   = DVS.constructN (((DVS.length v +          32 - 1) `div`          32) + 1) genLayer1-  , csPoppyLayerS   = DVS.unfoldrN (fromIntegral (popCount1 v `div` 8192) + 1) genS (0, 0)+  { csPoppyBits   = v+  , csPoppyLayerM = layerM+  , csPoppyLayerS = layerS   }-  where csPoppyCum2048  = DVS.constructN (((DVS.length v +          32 - 1) `div`          32) + 1) genCum2048-        gen512Index u = let indexN = DVS.length u - 1 in-          if indexN == -1-            then 0-            else popCount1Range (indexN *           8)           8 v + DVS.last u-        genCum2048 u = let indexN = DVS.length u in-          if indexN .&. 0xffffffff == 0-            then 0-            else popCount1Range ((indexN - 1) *    32)          32 v + DVS.last u-        genLayer0 u = let indexN = DVS.length u in-          if indexN == 0-            then 0-            else popCount1Range (indexN * 0x100000000) 0x100000000 v + DVS.last u-        genLayer1 u = let indexN = DVS.length u in-          let cum = if indexN == 0 -- TODO Check boundary at 4G???-              then  0-              else  csPoppyCum2048 !!! fromIntegral indexN in-          let a = popCount1Range (indexN * 32 +  0) 8 v in-          let b = popCount1Range (indexN * 32 +  8) 8 v in-          let c = popCount1Range (indexN * 32 + 16) 8 v in-          (   ( cum       .&. 0x00000000ffffffff)-          .|. ((a .<. 32) .&. 0x000003ff00000000)-          .|. ((b .<. 42) .&. 0x000ffc0000000000)-          .|. ((c .<. 52) .&. 0x3ff0000000000000)) -- zhou-sea2013 fig 5 (c)-        genS :: (Count, Position) -> Maybe (Word64, (Count, Position))-        genS (pca, n) = if n < end v-          then  let w = v !!! n in-                let pcz = pca + popCount1 w in-                if (8192 - 1 + pca) `div` 8192 /= (8192 - 1 + pcz) `div` 8192-                  then Just (fromIntegral n * 64 + fromIntegral (select1 w (fromIntegral (8192 - (pca `mod` 8192)))), (pcz, n + 1))-                  else genS (pcz, n + 1)-          else Nothing+  where blocks  = DVS.constructN (((DVS.length v      + 8 - 1) `div` 8) + 1) genBlocks+        layerM  = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1+        layerMPopCount = getCsiTotal (CsInterleaved (lastOrZero layerM))+        layerS = DVS.unfoldrN (fromIntegral layerMPopCount) genSample (0, 1)+        genBlocks u = let i = length u in popCount1 (take 8 (drop (i * 8) v))+        genLayer1 :: DVS.Vector Word64 -> Word64+        genLayer1 u =+          let i  = end u                          in+          let lx = lastOrZero u                   in+          let la = indexOrZero blocks (i * 4 - 4) in+          let lb = indexOrZero blocks (i * 4 - 3) in+          let lc = indexOrZero blocks (i * 4 - 2) in+          let ld = indexOrZero blocks (i * 4 - 1) in+          let nx = lx + (la + lb + lc + ld)       in+          let na = indexOrZero blocks (i * 4 + 0) in+          let nb = indexOrZero blocks (i * 4 + 1) in+          let nc = indexOrZero blocks (i * 4 + 2) in+          (   ( nx         .&. 0x00000000ffffffff)+          .|. ((na .<. 32) .&. 0x000003ff00000000)+          .|. ((nb .<. 42) .&. 0x000ffc0000000000)+          .|. ((nc .<. 52) .&. 0x3ff0000000000000))+        mLookup :: Position -> Word64+        mLookup i = getCsiX (CsInterleaved (layerM !!! i))+        genSample :: (Position, Position) -> Maybe (Word32, (Position, Position))+        genSample (mi, _) | mi == maxBound                                            = Nothing+        genSample (mi, _) | mi >= end layerM                                          = Just (fromIntegral (DVS.length layerM - 1), (maxBound, maxBound))+        genSample (mi, s) | s < toPosition (getCsiTotal (CsInterleaved (mLookup mi))) = Just (fromIntegral mi - 1, (mi, s + 8192))+        genSample (mi, s) = genSample (fromIntegral mi + 1, s)  instance TestBit CsPoppy where   (.?.) = (.?.) . csPoppyBits@@ -86,40 +125,98 @@   bitRead = fmap makeCsPoppy . bitRead  instance Rank1 CsPoppy where-  rank1 (CsPoppy v _ layer0 layer1 _) p = rankPrior + rankInBasicBlock-    where rankLayer0              = layer0  !!! toPosition (p `div` 0x100000000)-          rankLayer1Word          = layer1  !!! toPosition (p `div` 2048)-          rankLayer1A             =  rankLayer1Word .&. 0x00000000ffffffff-          rankLayer1B             = (rankLayer1Word .&. 0x000003ff00000000) .>. 32-          rankLayer1C             = (rankLayer1Word .&. 0x000ffc0000000000) .>. 42-          rankLayer1D             = (rankLayer1Word .&. 0x3ff0000000000000) .>. 52-          q                       = (p `div` 512) `mod` 4 -- quarter-          rankLayer1  | q == 0    = rankLayer1A-                      | q == 1    = rankLayer1A + rankLayer1B-                      | q == 2    = rankLayer1A + rankLayer1B + rankLayer1C-                      | q == 3    = rankLayer1A + rankLayer1B + rankLayer1C + rankLayer1D-                      | otherwise = undefined-          rankPrior               = (rankLayer0 + rankLayer1) :: Count-          rankInBasicBlock        = rank1 (DVS.drop (fromIntegral p `div` 512) v) (p `mod` 512)+  rank1 (CsPoppy !v !layerM !_) p = rankPrior + rankInBasicBlock+    where mw  = layerM !!! toPosition (p `div` 2048)+          mx  =  mw .&. 0x00000000ffffffff+          ma  = (mw .&. 0x000003ff00000000) .>. 32+          mb  = (mw .&. 0x000ffc0000000000) .>. 42+          mc  = (mw .&. 0x3ff0000000000000) .>. 52+          q   = (p `div` 512) `mod` 4 -- quarter+          mi  | q == 0    = mx+              | q == 1    = mx + ma+              | q == 2    = mx + ma + mb+              | q == 3    = mx + ma + mb + mc+              | otherwise = error "Invalid interleaved entry index"+          rankPrior         = mi :: Count+          rankInBasicBlock  = rank1 (DVS.drop (fromIntegral (p `div` 512) * 8) v) (p `mod` 512)+  {-# INLINE rank1 #-} +mBinarySearch :: Word64 -> DVS.Vector Word64 -> Position -> Position -> Position+mBinarySearch !w !m !p !q = if p + 1 >= q+  then p+  else let !o = (p + q) `div` 2 in+    if w <= getCsiX (CsInterleaved (m !!! o))+      then mBinarySearch w m p o+      else mBinarySearch w m o q+{-# INLINE mBinarySearch #-}+ instance Select1 CsPoppy where-  select1 iv@(CsPoppy v i _ _ _) p = if DVS.length v /= 0-      then toCount q * 512 + select1 (DVS.drop (fromIntegral q * 8) v) (p - s)-      else 0-    where q = binarySearch (fromIntegral p) wordAt iMin iMax-          s = (i !!! q) :: Count-          wordAt = (i !!!)-          (sampleMin, sampleMax) = sampleRange iv p-          iMin = fromIntegral $  (sampleMin - 1) `div` 512      :: Position-          iMax = fromIntegral $ ((sampleMax - 1) `div` 512) + 1 :: Position+  select1 _                             p | p == 0  = 0+  select1 (CsPoppy !v !layerM !layerS)  p           =+    let !pi                 = toPosition $ (p - 1) `div` 8192                 in+    let !pj                 = (pi + 1) `min` (end layerS - 1)                 in+    let !si                 = fromIntegral   (layerS !!! pi)                  in+    let !sj                 = fromIntegral $ (layerS !!! pj) + 1              in+    let !mIndex             = mBinarySearch (fromIntegral p) layerM si sj     in+    let !me                 = CsInterleaved (layerM !!! fromIntegral mIndex)  in+    let !mx                 = getCsiX me                                      in+    let !ma                 = getCsiA me + mx                                 in+    let !mb                 = getCsiB me + ma                                 in+    let !mc                 = getCsiC me + mb                                 in+    let !bo | p <= ma       = 0+            | p <= mb       = 1+            | p <= mc       = 2+            | otherwise     = 3                                               in+    let !bp | p <= ma       = mx+            | p <= mb       = ma+            | p <= mc       = mb+            | otherwise     = mc                                              in+    let !blockStart          = toCount (mIndex * 4 + bo) * 8                  in+    let !block               = DVS.take 8 (drop blockStart v)                 in+    let !q                   = p - bp                                         in+    select1 block q + blockStart * 64+  {-# INLINE select1 #-} -sampleRange :: CsPoppy -> Count -> (Word64, Word64)-sampleRange (CsPoppy _ index _ _ samples) p =-  let j = (fromIntegral p - 1) `div` 8192 in-  if 0 <= j && j < DVS.length samples-    then  let pa = samples DVS.! j                in-          if j + 1 < DVS.length samples-            then  let pz = samples DVS.! (j + 1)          in-                  (pa, pz)-            else (pa, fromIntegral (DVS.length index - 1))-    else (1, fromIntegral (DVS.length index - 1))+instance OpenAt CsPoppy where+  openAt = openAt . csPoppyBits+  {-# INLINE openAt #-}++instance CloseAt CsPoppy where+  closeAt = closeAt . csPoppyBits+  {-# INLINE closeAt #-}++instance NewCloseAt CsPoppy where+  newCloseAt = newCloseAt . csPoppyBits+  {-# INLINE newCloseAt #-}++instance FindOpenN CsPoppy where+  findOpenN = findOpenN . csPoppyBits+  {-# INLINE findOpenN #-}++instance FindOpen CsPoppy where+  findOpen = findOpen . csPoppyBits+  {-# INLINE findOpen #-}++instance FindClose CsPoppy where+  findClose = findClose . csPoppyBits+  {-# INLINE findClose #-}++instance FindCloseN CsPoppy where+  findCloseN = findCloseN . csPoppyBits+  {-# INLINE findCloseN #-}++instance Enclose CsPoppy where+  enclose = enclose . csPoppyBits+  {-# INLINE enclose #-}++instance Rank0 CsPoppy where+  rank0 rsbs p = p - rank0 rsbs p+  {-# INLINE rank0 #-}++instance BalancedParens CsPoppy where+  firstChild  = firstChild  . csPoppyBits+  nextSibling = nextSibling . csPoppyBits+  parent      = parent      . csPoppyBits+  {-# INLINE firstChild  #-}+  {-# INLINE nextSibling #-}+  {-# INLINE parent      #-}

@@ -0,0 +1,69 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal+    ( CsInterleaved(..)+    , getCsiX+    , getCsiA+    , getCsiB+    , getCsiC+    , getCsiTotal+    , mkCsi+    , putCsiX+    , putCsiA+    , putCsiB+    , putCsiC+    ) where++import Data.Word+import Foreign.Ptr+import Foreign.Storable+import HaskellWorks.Data.Bits.BitWise++newtype CsInterleaved = CsInterleaved { unCsInterleaved :: Word64 } deriving Eq++instance Storable CsInterleaved where+  sizeOf = sizeOf . unCsInterleaved+  {-# INLINE sizeOf #-}+  alignment = alignment . unCsInterleaved+  {-# INLINE alignment #-}+  peekElemOff ptr i = CsInterleaved <$> peekElemOff (castPtr ptr) i+  {-# INLINE peekElemOff #-}+  pokeElemOff ptr i = pokeElemOff (castPtr ptr) i . unCsInterleaved+  {-# INLINE pokeElemOff #-}++mkCsi :: Word64 -> Word64 -> Word64 -> Word64 -> CsInterleaved+mkCsi x a b c = CsInterleaved+    $   ((x .&. 0xffffffff) .<.  0)+    .|. ((a .&.      0x3ff) .<. 32)+    .|. ((b .&.      0x3ff) .<. 42)+    .|. ((c .&.      0x3ff) .<. 52)++getCsiX :: CsInterleaved -> Word64+getCsiX (CsInterleaved i) = i .&. 0xffffffff++getCsiA :: CsInterleaved -> Word64+getCsiA (CsInterleaved i) = (i .>. 32) .&. 0x3ff++getCsiB :: CsInterleaved -> Word64+getCsiB (CsInterleaved i) = (i .>. 42) .&. 0x3ff++getCsiC :: CsInterleaved -> Word64+getCsiC (CsInterleaved i) = (i .>. 52) .&. 0x3ff++getCsiTotal :: CsInterleaved -> Word64+getCsiTotal csi = getCsiX csi + getCsiA csi + getCsiB csi + getCsiC csi++putCsiX :: Word64 -> CsInterleaved -> CsInterleaved+putCsiX v (CsInterleaved i) = CsInterleaved (((v .&. 0xffffffff) .<.  0) .|. (i .&. 0xffffffff00000000))++putCsiA :: Word64 -> CsInterleaved -> CsInterleaved+putCsiA v (CsInterleaved i) = CsInterleaved (((v .&.      0x3ff) .<. 32) .|. (i .&. 0xfffffc00ffffffff))++putCsiB :: Word64 -> CsInterleaved -> CsInterleaved+putCsiB v (CsInterleaved i) = CsInterleaved (((v .&.      0x3ff) .<. 42) .|. (i .&. 0xfff003ffffffffff))++putCsiC :: Word64 -> CsInterleaved -> CsInterleaved+putCsiC v (CsInterleaved i) = CsInterleaved (((v .&.      0x3ff) .<. 52) .|. (i .&. 0xc00fffffffffffff))++instance Show CsInterleaved where+  showsPrec _ i = shows (getCsiX i, getCsiA i, getCsiB i, getCsiC i)

@@ -1,116 +0,0 @@-module HaskellWorks.Data.RankSelect.CsPoppy2-    ( CsPoppy2(..)-    , Rank1(..)-    , makeCsPoppy2-    , sampleRange-    ) where--import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitLength-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitWise-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.Positioning-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.Search-import           HaskellWorks.Data.Vector.AsVector64--data CsPoppy2 = CsPoppy2-  { csPoppy2Bits     :: DVS.Vector Word64-  , csPoppy2512Index :: DVS.Vector Word64-  , csPoppy2Layer0   :: DVS.Vector Word64-  , csPoppy2Layer1   :: DVS.Vector Word64-  , csPoppy2LayerS   :: DVS.Vector Word64 -- Sampling position of each 8192 1-bit-  } deriving (Eq, Show)--instance AsVector64 CsPoppy2 where-  asVector64 = asVector64 . csPoppy2Bits-  {-# INLINE asVector64 #-}--instance BitLength CsPoppy2 where-  bitLength = bitLength . csPoppy2Bits-  {-# INLINE bitLength #-}--popCount1Range :: (DVS.Storable a, PopCount1 a) => Int -> Int -> DVS.Vector a -> Count-popCount1Range start len = popCount1 . DVS.take len . DVS.drop start--makeCsPoppy2 :: DVS.Vector Word64 -> CsPoppy2-makeCsPoppy2 v = CsPoppy2-  { csPoppy2Bits     = v-  , csPoppy2512Index = DVS.constructN (((DVS.length v +           8 - 1) `div`           8) + 1) gen512Index-  , csPoppy2Layer0   = DVS.constructN (((DVS.length v + 0x100000000 - 1) `div` 0x100000000) + 1) genLayer0-  , csPoppy2Layer1   = DVS.constructN (((DVS.length v +          32 - 1) `div`          32) + 1) genLayer1-  , csPoppy2LayerS   = DVS.unfoldrN (fromIntegral (popCount1 v `div` 8192) + 1) genS (0, 0)-  }-  where csPoppy2Cum2048  = DVS.constructN (((DVS.length v +          32 - 1) `div`          32) + 1) genCum2048-        gen512Index u = let indexN = DVS.length u - 1 in-          if indexN == -1-            then 0-            else popCount1Range (indexN *           8)           8 v + DVS.last u-        genCum2048 u = let indexN = DVS.length u in-          if indexN .&. 0xffffffff == 0-            then 0-            else popCount1Range ((indexN - 1) *    32)          32 v + DVS.last u-        genLayer0 u = let indexN = DVS.length u in-          if indexN == 0-            then 0-            else popCount1Range (indexN * 0x100000000) 0x100000000 v + DVS.last u-        genLayer1 u = let indexN = DVS.length u in-          let cum = if indexN == 0 -- TODO Check boundary at 4G???-              then  0-              else  csPoppy2Cum2048 !!! fromIntegral indexN in-          let a = popCount1Range (indexN * 32 +  0) 8 v in-          let b = popCount1Range (indexN * 32 +  8) 8 v in-          let c = popCount1Range (indexN * 32 + 16) 8 v in-          (   ( cum       .&. 0x00000000ffffffff)-          .|. ((a .<. 32) .&. 0x000003ff00000000)-          .|. ((b .<. 42) .&. 0x000ffc0000000000)-          .|. ((c .<. 52) .&. 0x3ff0000000000000)) -- zhou-sea2013 fig 5 (c)-        genS :: (Count, Position) -> Maybe (Word64, (Count, Position))-        genS (pca, n) = if n < end v-          then  let w = v !!! n in-                let pcz = pca + popCount1 w in-                if (8192 - 1 + pca) `div` 8192 /= (8192 - 1 + pcz) `div` 8192-                  then Just (fromIntegral n * 64 + fromIntegral (select1 w (fromIntegral (8192 - (pca `mod` 8192)))), (pcz, n + 1))-                  else genS (pcz, n + 1)-          else Nothing--instance BitRead CsPoppy2 where-  bitRead = fmap makeCsPoppy2 . bitRead--instance Rank1 CsPoppy2 where-  rank1 (CsPoppy2 v _ layer0 layer1 _) p = rankPrior + rankInBasicBlock-    where rankLayer0              = layer0  !!! toPosition (p `div` 0x100000000)-          rankLayer1Word          = layer1  !!! toPosition (p `div` 2048)-          rankLayer1A             =  rankLayer1Word .&. 0x00000000ffffffff-          rankLayer1B             = (rankLayer1Word .&. 0x000003ff00000000) .>. 32-          rankLayer1C             = (rankLayer1Word .&. 0x000ffc0000000000) .>. 42-          rankLayer1D             = (rankLayer1Word .&. 0x3ff0000000000000) .>. 52-          q                       = (p `div` 512) `mod` 4 -- quarter-          rankLayer1  | q == 0    = rankLayer1A-                      | q == 1    = rankLayer1A + rankLayer1B-                      | q == 2    = rankLayer1A + rankLayer1B + rankLayer1C-                      | q == 3    = rankLayer1A + rankLayer1B + rankLayer1C + rankLayer1D-                      | otherwise = undefined-          rankPrior               = (rankLayer0 + rankLayer1) :: Count-          rankInBasicBlock        = rank1 (DVS.drop (fromIntegral p `div` 512) v) (p `mod` 512)--instance Select1 CsPoppy2 where-  select1 (CsPoppy2 v i _ _ _) p = toCount q * 512 + select1 (DVS.drop (fromIntegral q * 8) v) (p - s)-    where q = binarySearch (fromIntegral p) wordAt 0 (fromIntegral $ DVS.length i - 1)-          s = (i !!! q) :: Count-          wordAt = (i !!!)--sampleRange :: CsPoppy2 -> Count -> (Word64, Word64)-sampleRange (CsPoppy2 _ index _ _ samples) p =-  let j = (fromIntegral p - 1) `div` 8192 in-  if 0 <= j && j < DVS.length samples-    then  let pa = samples DVS.! j                in-          if j + 1 < DVS.length samples-            then  let pz = samples DVS.! (j + 1)          in-                  (pa, pz)-            else (pa, fromIntegral (DVS.length index - 1))-    else (1, fromIntegral (DVS.length index - 1))

@@ -1,3 +1,7 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-} {-# LANGUAGE TypeFamilies   #-}  module HaskellWorks.Data.RankSelect.Poppy512@@ -6,35 +10,42 @@     , makePoppy512     ) where -import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitLength-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitWise-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.Positioning-import           HaskellWorks.Data.RankSelect.Base.Rank0-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select0-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.Search-import           HaskellWorks.Data.BalancedParens.BalancedParens-import           HaskellWorks.Data.BalancedParens.CloseAt-import           HaskellWorks.Data.BalancedParens.Enclose-import           HaskellWorks.Data.BalancedParens.FindClose-import           HaskellWorks.Data.BalancedParens.FindOpen-import           HaskellWorks.Data.BalancedParens.FindCloseN-import           HaskellWorks.Data.BalancedParens.FindOpenN-import           HaskellWorks.Data.BalancedParens.NewCloseAt-import           HaskellWorks.Data.BalancedParens.OpenAt-import           HaskellWorks.Data.Vector.AsVector64-import           Prelude hiding (length)+import Control.DeepSeq+import Data.Word+import GHC.Generics+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.BalancedParens.BalancedParens+import HaskellWorks.Data.BalancedParens.CloseAt+import HaskellWorks.Data.BalancedParens.Enclose+import HaskellWorks.Data.BalancedParens.FindClose+import HaskellWorks.Data.BalancedParens.FindCloseN+import HaskellWorks.Data.BalancedParens.FindOpen+import HaskellWorks.Data.BalancedParens.FindOpenN+import HaskellWorks.Data.BalancedParens.NewCloseAt+import HaskellWorks.Data.BalancedParens.OpenAt+import HaskellWorks.Data.Bits.BitLength+import HaskellWorks.Data.Bits.BitRead+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select0+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.Search+import HaskellWorks.Data.Vector.AsVector64+import Prelude                                         hiding (length) +import qualified Data.Vector.Storable as DVS+ data Poppy512 = Poppy512-  { poppy512Bits  :: DVS.Vector Word64-  , poppy512Index :: DVS.Vector Word64-  } deriving (Eq, Show)+  { poppy512Bits  :: !(DVS.Vector Word64)+  , poppy512Index :: !(DVS.Vector Word64)+  } deriving (Eq, Show, NFData, Generic)++instance PopCount1 Poppy512 where+  popCount1 = popCount1 . poppy512Bits+  {-# INLINE popCount1 #-}  instance AsVector64 Poppy512 where   asVector64 = asVector64 . poppy512Bits

@@ -1,5 +1,9 @@-{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC-funbox-strict-fields #-} +{-# LANGUAGE BangPatterns   #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+ module HaskellWorks.Data.RankSelect.Poppy512S     ( Poppy512S(..)     , Rank1(..)@@ -7,39 +11,46 @@     , sampleRange     ) where -import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitLength-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitWise-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.Positioning-import           HaskellWorks.Data.RankSelect.Base.Rank0-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.Search-import           HaskellWorks.Data.BalancedParens.BalancedParens-import           HaskellWorks.Data.BalancedParens.CloseAt-import           HaskellWorks.Data.BalancedParens.Enclose-import           HaskellWorks.Data.BalancedParens.FindClose-import           HaskellWorks.Data.BalancedParens.FindCloseN-import           HaskellWorks.Data.BalancedParens.FindOpen-import           HaskellWorks.Data.BalancedParens.FindOpenN-import           HaskellWorks.Data.BalancedParens.NewCloseAt-import           HaskellWorks.Data.BalancedParens.OpenAt-import           HaskellWorks.Data.Vector.AsVector64-import           Prelude hiding (length)+import Control.DeepSeq+import Data.Word+import GHC.Generics+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.BalancedParens.BalancedParens+import HaskellWorks.Data.BalancedParens.CloseAt+import HaskellWorks.Data.BalancedParens.Enclose+import HaskellWorks.Data.BalancedParens.FindClose+import HaskellWorks.Data.BalancedParens.FindCloseN+import HaskellWorks.Data.BalancedParens.FindOpen+import HaskellWorks.Data.BalancedParens.FindOpenN+import HaskellWorks.Data.BalancedParens.NewCloseAt+import HaskellWorks.Data.BalancedParens.OpenAt+import HaskellWorks.Data.Bits.BitLength+import HaskellWorks.Data.Bits.BitRead+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.Search+import HaskellWorks.Data.Vector.AsVector64+import Prelude                                         hiding (length) +import qualified Data.Vector.Storable as DVS+ data Poppy512S = Poppy512S   { poppy512SBits   :: !(DVS.Vector Word64)   , poppy512Index   :: !(DVS.Vector Word64)   , poppy512Samples :: !(DVS.Vector Word64) -- Sampling position of each 8192 1-bit-  } deriving (Eq, Show)+  } deriving (Eq, Show, NFData, Generic)  instance AsVector64 Poppy512S where   asVector64 = asVector64 . poppy512SBits   {-# INLINE asVector64 #-}++instance PopCount1 Poppy512S where+  popCount1 = popCount1 . poppy512SBits+  {-# INLINE popCount1 #-}  popCount1Range :: (DVS.Storable a, PopCount1 a) => Int -> Int -> DVS.Vector a -> Count popCount1Range start len = popCount1 . DVS.take len . DVS.drop start

@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec (spec) where++import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.RankSelect.CsPoppy.Internal+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Prelude                                        hiding (length)+import Test.Hspec++import qualified Hedgehog.Gen              as G+import qualified Hedgehog.Range            as R++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Data.RankSelect.CsInterleavedSpec" $ do+  describe "Interleaved Level 1 & 2" $ do+    it "have all its fields isolated" $ require $ property $ do+      vx <- forAll $ G.word64 R.constantBounded+      va <- forAll $ G.word64 R.constantBounded+      vb <- forAll $ G.word64 R.constantBounded+      vc <- forAll $ G.word64 R.constantBounded+      let actual =  putCsiX vx .+                    putCsiA va .+                    putCsiB vb .+                    putCsiC vc $ CsInterleaved 0+      getCsiX (putCsiX vx actual) === (vx .&. 0xffffffff)+      getCsiA (putCsiA va actual) === (va .&. 0x3ff)+      getCsiB (putCsiB vb actual) === (vb .&. 0x3ff)+      getCsiC (putCsiC vc actual) === (vc .&. 0x3ff)+    it "have all its fields isolated" $ require $ property $ do+      vx <- forAll $ G.word64 R.constantBounded+      va <- forAll $ G.word64 R.constantBounded+      vb <- forAll $ G.word64 R.constantBounded+      vc <- forAll $ G.word64 R.constantBounded+      getCsiX (putCsiX vx (CsInterleaved 0)) === (vx .&. 0xffffffff)+      getCsiA (putCsiA va (CsInterleaved 0)) === (va .&. 0x3ff)+      getCsiB (putCsiB vb (CsInterleaved 0)) === (vb .&. 0x3ff)+      getCsiC (putCsiC vc (CsInterleaved 0)) === (vc .&. 0x3ff)

@@ -1,94 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving       #-}-{-# LANGUAGE ScopedTypeVariables              #-}--module HaskellWorks.Data.RankSelect.CsPoppy2Spec (spec) where--import           GHC.Exts-import           Data.Maybe-import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitShow-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.RankSelect.BasicGen-import           HaskellWorks.Data.RankSelect.CsPoppy2-import           Prelude hiding (length)-import           Test.Hspec-import           Test.QuickCheck--{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}--newtype ShowVector a = ShowVector a deriving (Eq, BitShow)--instance BitShow a => Show (ShowVector a) where-  show = bitShow--vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64))-vectorSizedBetween a b = do-  n   <- choose (a, b)-  xs  <- sequence [ arbitrary | _ <- [1 .. n] ]-  return $ ShowVector (fromList xs)--spec :: Spec-spec = describe "HaskellWorks.Data.RankSelect.CsPoppy2.Rank1Spec" $ do-  genRank1Select1Spec (undefined :: CsPoppy2)-  describe "rank1 for Vector Word64 is equivalent to rank1 for CsPoppy2" $ do-    it "on empty bitvector" $-      let v = DVS.empty in-      let w = makeCsPoppy2 v in-      let i = 0 in-      rank1 v i === rank1 w i-    it "on one basic block" $-      forAll (vectorSizedBetween 1 8) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy2 v in-      rank1 v i === rank1 w i-    it "on two basic blocks" $-      forAll (vectorSizedBetween 9 16) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy2 v in-      rank1 v i === rank1 w i-    it "on three basic blocks" $-      forAll (vectorSizedBetween 17 24) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy2 v in-      rank1 v i === rank1 w i-  describe "select1 for Vector Word64 is equivalent to select1 for CsPoppy2" $ do-    it "on empty bitvector" $-      let v = DVS.empty in-      let w = makeCsPoppy2 v in-      let i = 0 in-      select1 v i === select1 w i-    it "on one full zero basic block" $-      let v = fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64 in-      let w = makeCsPoppy2 v in-      select1 v 0 === select1 w 0-    it "on one basic block" $-      forAll (vectorSizedBetween 1 8) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy2 v in-      select1 v i === select1 w i-    it "on two basic blocks" $-      forAll (vectorSizedBetween 9 16) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy2 v in-      select1 v i === select1 w i-    it "on three basic blocks" $-      forAll (vectorSizedBetween 17 24) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy2 v in-      select1 v i === select1 w i-  describe "Rank select over large buffer" $ do-    it "Rank works" $ do-      let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64-      let ps = makeCsPoppy2 cs-      (rank1 ps `map` [1 .. 4096]) `shouldBe` [(x - 1) `div` 2 + 1 | x <- [1 .. 4096]]-    it "Select works" $ do-      let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64-      let ps = makeCsPoppy2 cs-      (select1 ps `map` [1 .. 2048]) `shouldBe` [1, 3 .. 4096]

@@ -1,94 +1,159 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-}  module HaskellWorks.Data.RankSelect.CsPoppySpec (spec) where -import           GHC.Exts-import           Data.Maybe-import qualified Data.Vector.Storable                                       as DVS-import           Data.Word-import           HaskellWorks.Data.AtIndex-import           HaskellWorks.Data.Bits.BitRead-import           HaskellWorks.Data.Bits.BitShow-import           HaskellWorks.Data.Bits.PopCount.PopCount1-import           HaskellWorks.Data.RankSelect.Base.Rank1-import           HaskellWorks.Data.RankSelect.Base.Select1-import           HaskellWorks.Data.RankSelect.BasicGen-import           HaskellWorks.Data.RankSelect.CsPoppy-import           Prelude hiding (length)-import           Test.Hspec-import           Test.QuickCheck+import Control.Monad+import Control.Monad.IO.Class+import Data.List                                 (isSuffixOf)+import Data.Maybe+import Data.Word+import GHC.Exts+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.BitLength+import HaskellWorks.Data.Bits.BitRead+import HaskellWorks.Data.Bits.BitShow+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.BasicGen+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.Take+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Prelude hiding (length, take, drop)+import System.Directory+import System.IO.MMap+import System.IO.Unsafe+import Test.Hspec +import qualified Data.Vector.Storable      as DVS+import qualified HaskellWorks.Hedgehog.Gen as G+import qualified Hedgehog.Gen              as G+import qualified Hedgehog.Range            as R+ {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}  newtype ShowVector a = ShowVector a deriving (Eq, BitShow) +corpusFiles :: [FilePath]+corpusFiles = unsafePerformIO $ do+  entries <- listDirectory "data"+  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+  return files+{-# NOINLINE corpusFiles #-}++loadVector64 :: FilePath -> IO (DVS.Vector Word64)+loadVector64 filename = fromForeignRegion <$> mmapFileForeignPtr filename ReadOnly Nothing+ instance BitShow a => Show (ShowVector a) where   show = bitShow -vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64))-vectorSizedBetween a b = do-  n   <- choose (a, b)-  xs  <- sequence [ arbitrary | _ <- [1 .. n] ]-  return $ ShowVector (fromList xs)- spec :: Spec-spec = describe "HaskellWorks.Data.RankSelect.CsPoppy.Rank1Spec" $ do+spec = describe "HaskellWorks.Data.RankSelect.CsPoppySpec" $ do   genRank1Select1Spec (undefined :: CsPoppy)   describe "rank1 for Vector Word64 is equivalent to rank1 for CsPoppy" $ do-    it "on empty bitvector" $-      let v = DVS.empty in-      let w = makeCsPoppy v in-      let i = 0 in+    it "on empty bitvector" $ require $ withTests 1 $ property $ do+      let v = DVS.empty+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      let i = 0       rank1 v i === rank1 w i-    it "on one basic block" $-      forAll (vectorSizedBetween 1 8) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy v in+    it "on one basic block" $ require $ property $ do+      v       <- forAll $ G.storableVector (R.linear 1 8) (G.word64 R.constantBounded)+      i       <- forAll $ G.word64 (R.linear 0 (length v * 8))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       rank1 v i === rank1 w i-    it "on two basic blocks" $-      forAll (vectorSizedBetween 9 16) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy v in+    it "on two basic blocks" $ require $ property $ do+      v <- forAll $ G.storableVector (R.linear 9 16) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (length v * 8))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       rank1 v i === rank1 w i-    it "on three basic blocks" $-      forAll (vectorSizedBetween 17 24) $ \(ShowVector v) ->-      forAll (choose (0, length v * 8)) $ \i ->-      let w = makeCsPoppy v in+    it "on three basic blocks" $ require $ property $ do+      v <- forAll $ G.storableVector (R.linear 17 24) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (length v * 8))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       rank1 v i === rank1 w i   describe "select1 for Vector Word64 is equivalent to select1 for CsPoppy" $ do-    it "on empty bitvector" $-      let v = DVS.empty in-      let w = makeCsPoppy v in-      let i = 0 in-      select1 v i === select1 w i-    it "on one full zero basic block" $-      let v = fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64 in-      let w = makeCsPoppy v in-      select1 v 0 === select1 w 0-    it "on one basic block" $-      forAll (vectorSizedBetween 1 8) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy v in-      select1 v i === select1 w i-    it "on two basic blocks" $-      forAll (vectorSizedBetween 9 16) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy v in-      select1 v i === select1 w i-    it "on three basic blocks" $-      forAll (vectorSizedBetween 17 24) $ \(ShowVector v) ->-      forAll (choose (0, popCount1 v)) $ \i ->-      let w = makeCsPoppy v in-      select1 v i === select1 w i+    xit "on empty bitvector" $ require $ withTests 1 $ property $ do+      let v = DVS.empty+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      let i = 0+      select1 w i === select1 v i+    xit "on one full zero basic block" $ require $ withTests 1 $ property $ do+      let v = fromList [0, 0, 0, 0, 0, 0, 0, 0] :: DVS.Vector Word64+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select1 w 0 === select1 v 0+    xit "on one basic block" $ require $ property $ do+      v <- forAll $ G.storableVector (R.linear 1 8) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount1 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select1 w i === select1 v i+    xit "on two basic blocks" $ require $ property $ do+      v <- forAll $ G.storableVector (R.linear 9 16) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount1 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select1 w i === select1 v i+    xit "on three basic blocks" $ require $ property $ do+      v <- forAll $ G.storableVector (R.linear 17 24) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount1 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select1 w i === select1 v i   describe "Rank select over large buffer" $ do-    it "Rank works" $ do+    xit "Rank works" $ require $ property $ do       let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64       let ps = makeCsPoppy cs-      (rank1 ps `map` [1 .. 4096]) `shouldBe` [(x - 1) `div` 2 + 1 | x <- [1 .. 4096]]+      (rank1 ps `map` [1 .. 4096]) === [(x - 1) `div` 2 + 1 | x <- [1 .. 4096]]+    xit "Rank is consistent with pop count" $ require $ property $ do+      v         <- forAll $ G.storableVector (R.linear 0 1024) (G.word64 R.constantBounded)+      Nice rsbs <- forAll $ pure $ Nice (makeCsPoppy v)+      rank1 rsbs (bitLength rsbs) === popCount1 rsbs     it "Select works" $ do-      let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64-      let ps = makeCsPoppy cs-      (select1 ps `map` [1 .. 2048]) `shouldBe` [1, 3 .. 4096]+      let v = DVS.fromList [0x1101001000100001, 0x2202002000200002, 0x3303003000300003] :: DVS.Vector Word64+      let pc = popCount1 v+      require $ property $ do+        Nice csPoppy  <- forAll $ pure $ Nice (makeCsPoppy v)+        s             <- forAll $ G.word64 (R.linear 1 pc)+        select1 csPoppy s === select1 v s+  describe "Corpus" $ do+    describe "Shrunk Rank" $ do+      forM_ corpusFiles $ \corpusFile -> do+        xit corpusFile $ do+          fileV <- liftIO $ loadVector64 corpusFile+          require $ property $ do+            let v = DVS.take 768 fileV+            Nice csPoppy  <- forAll $ pure $ Nice $ makeCsPoppy v+            maxPos        <- forAll $ pure $ fromIntegral $ DVS.length (csPoppyBits csPoppy)+            r <- forAll $ G.word64 (R.linear 1 maxPos)+            rank1 csPoppy r === rank1 v r+    describe "Rank" $ do+      forM_ corpusFiles $ \corpusFile -> do+        it corpusFile $ do+          v <- liftIO $ loadVector64 corpusFile+          let csPoppy = makeCsPoppy v+          let maxPos = fromIntegral $ DVS.length (csPoppyBits csPoppy)+          require $ property $ do+            r <- forAll $ G.word64 (R.linear 1 maxPos)+            rank1 csPoppy r === rank1 v r+    describe "Select" $ do+      forM_ corpusFiles $ \corpusFile -> do+        it corpusFile $ do+          fileV <- liftIO $ loadVector64 corpusFile+          let csPoppy = makeCsPoppy fileV+          let pc = popCount1 (csPoppyBits csPoppy)+          require $ property $ do+            _ <- forAll $ pure $ Nice csPoppy+            s <- forAll $ G.word64 (R.linear 1 pc)+            select1 csPoppy s === select1 fileV s+    describe "Select straw man" $ do+      forM_ corpusFiles $ \corpusFile -> do+        it corpusFile $ do+          fileV <- liftIO $ loadVector64 corpusFile+          let csPoppy = makeCsPoppy fileV+          let pc = popCount1 (csPoppyBits csPoppy)+          require $ property $ do+            _ <- forAll $ pure $ csPoppyLayerS csPoppy+            s <- forAll $ G.word64 (R.linear 1 pc)+            select1 csPoppy s === select1 fileV s