hw-rankselect 0.12.0.4 → 0.13.0.0

raw patch · 24 files changed

+1164/−553 lines, 24 filesdep +generic-lensdep ~basedep ~directorydep ~hedgehogPVP ok

version bump matches the API change (PVP)

Dependencies added: generic-lens

Dependency ranges changed: base, directory, hedgehog, hw-bits, hw-prim, hw-rankselect-base

API changes (from Hackage documentation)

Files

• app/App/Commands/Build.hs +20/−12
• app/App/Commands/Options/Lens.hs +0/−16
• app/App/Commands/Options/Type.hs +19/−15
• app/App/Commands/SelectAll.hs +14/−8
• app/App/Commands/UnitTest.hs +14/−12
• app/App/Commands/Validate.hs +19/−13
• bench/Main.hs +14/−20
• hw-rankselect.cabal +116/−101
• src/HaskellWorks/Data/RankSelect/CsPoppy.hs +26/−127
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs +0/−208
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Alpha0.hs +171/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Alpha1.hs +171/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/CsInterleaved.hs +72/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Lookup.hs +62/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Nice.hs +28/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Reference.hs +35/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Vector.hs +21/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy0.hs +128/−0
• src/HaskellWorks/Data/RankSelect/CsPoppy1.hs +128/−0
• src/HaskellWorks/Data/RankSelect/Poppy512.hs +5/−0
• test/HaskellWorks/Data/RankSelect/BasicGen.hs +2/−2
• test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs +14/−6
• test/HaskellWorks/Data/RankSelect/CsPoppySpec.hs +84/−13
• test/HaskellWorks/Data/RankSelect/ValidateSpec.hs +1/−0

@@ -1,32 +1,40 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TypeApplications #-}  module App.Commands.Build   ( cmdBuild   ) where -import App.Commands.Options.Type import Control.Lens import Control.Monad+import Data.Generics.Product.Any import Data.List import Data.Monoid                         ((<>)) import HaskellWorks.Data.FromForeignRegion import Options.Applicative import System.Directory -import qualified App.Commands.Options.Lens             as L-import qualified HaskellWorks.Data.RankSelect.CsPoppy  as CS-import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512+import qualified App.Commands.Options.Type                            as Z+import qualified HaskellWorks.Data.RankSelect.CsPoppy                 as CS+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0 as A0+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1+import qualified HaskellWorks.Data.RankSelect.Poppy512                as P512 -runBuild :: BuildOptions -> IO ()-runBuild opts = case opts ^. L.indexType of-  CsPoppy  -> do+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Redundant return"    :: String) #-}++runBuild :: Z.BuildOptions -> IO ()+runBuild opts = case opts ^. the @"indexType" of+  Z.CsPoppy  -> do     entries <- getDirectoryContents "data"     let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries     forM_ files $ \file -> do       putStrLn $ "Loading cspoppy for " <> file-      CS.CsPoppy !_ !_ !_ <- mmapFromForeignRegion file+      CS.CsPoppy !_ !_ (A1.CsPoppyIndex !_ !_) <- mmapFromForeignRegion file       return ()-  Poppy512 -> do+  Z.Poppy512 -> do     entries <- getDirectoryContents "data"     let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries     forM_ files $ \file -> do@@ -34,8 +42,8 @@       P512.Poppy512 !_ !_ <- mmapFromForeignRegion file       return () -optsBuild :: Parser BuildOptions-optsBuild = BuildOptions+optsBuild :: Parser Z.BuildOptions+optsBuild = Z.BuildOptions   <$> option auto       (   long "index-type"       <>  help "Index type"

@@ -1,16 +0,0 @@-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TypeSynonymInstances   #-}--module App.Commands.Options.Lens where--import App.Commands.Options.Type-import Control.Lens--makeFields ''BuildOptions-makeFields ''SelectAllOptions-makeFields ''UnitTestOptions-makeFields ''ValidateOptions-makeFields ''ValidateState

@@ -1,29 +1,33 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+ module App.Commands.Options.Type where  import Data.Word+import GHC.Generics -data IndexType = CsPoppy | Poppy512 deriving (Eq, Read, Show)+data IndexType = CsPoppy | Poppy512 deriving (Eq, Read, Show, Generic) -data BuildOptions = BuildOptions-  { _buildOptionsIndexType :: IndexType-  } deriving (Eq, Show)+newtype BuildOptions = BuildOptions+  { indexType :: IndexType+  } deriving (Eq, Show, Generic) -data SelectAllOptions = SelectAllOptions-  { _selectAllOptionsIndexType :: IndexType-  } deriving (Eq, Show)+newtype SelectAllOptions = SelectAllOptions+  { indexType :: IndexType+  } deriving (Eq, Show, Generic)  newtype UnitTestOptions = UnitTestOptions-  { _unitTestOptionsName :: String-  } deriving (Eq, Show)+  { name :: String+  } deriving (Eq, Show, Generic)  data ValidateOptions = ValidateOptions-  { _validateOptionsIndexType :: IndexType-  , _validateOptionsFile      :: FilePath-  } deriving (Eq, Show)+  { indexType :: IndexType+  , file      :: FilePath+  } deriving (Eq, Show, Generic) -data ValidateState = ValidateState-  { _validateStateCumulativePopCount :: Word64-  } deriving (Eq, Show)+newtype ValidateState = ValidateState+  { cumulativePopCount :: Word64+  } deriving (Eq, Show, Generic)  emptyValidateState :: ValidateState emptyValidateState = ValidateState 0

@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module App.Commands.SelectAll   ( cmdSelectAll@@ -7,6 +9,7 @@  import Control.Lens import Control.Monad+import Data.Generics.Product.Any import Data.List import Data.Monoid                               ((<>)) import HaskellWorks.Data.Bits.PopCount.PopCount1@@ -17,12 +20,15 @@ import Options.Applicative                       hiding (columns) import System.Directory -import qualified App.Commands.Options.Lens as L-import qualified App.Commands.Options.Type as O+import qualified App.Commands.Options.Type as Z -runSelectAll :: O.SelectAllOptions -> IO ()-runSelectAll opts = case opts ^. L.indexType of-  O.CsPoppy -> do+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Redundant return"    :: String) #-}++runSelectAll :: Z.SelectAllOptions -> IO ()+runSelectAll opts = case opts ^. the @"indexType" of+  Z.CsPoppy -> do     entries <- getDirectoryContents "data"     let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries     forM_ files $ \file -> do@@ -32,7 +38,7 @@         let !_ = select1 v i         return ()       return ()-  O.Poppy512 -> do+  Z.Poppy512 -> do     entries <- getDirectoryContents "data"     let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries     forM_ files $ \file -> do@@ -43,8 +49,8 @@         return ()       return () -optsSelectAll :: Parser O.SelectAllOptions-optsSelectAll = O.SelectAllOptions+optsSelectAll :: Parser Z.SelectAllOptions+optsSelectAll = Z.SelectAllOptions   <$> option auto       (   long "index-type"       <>  help "Index type"

@@ -1,13 +1,15 @@ {-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module App.Commands.UnitTest   ( cmdUnitTest   ) where -import App.Commands.Options.Type import Control.Lens import Control.Monad+import Data.Generics.Product.Any import Data.Monoid                               ((<>)) import Data.Word import HaskellWorks.Data.Bits.PopCount.PopCount1@@ -15,13 +17,16 @@ import HaskellWorks.Data.RankSelect.CsPoppy import Options.Applicative -import qualified App.Commands.Options.Lens           as L+import qualified App.Commands.Options.Type           as Z import qualified Data.Vector.Storable                as DVS import qualified HaskellWorks.Data.FromForeignRegion as IO import qualified System.IO                           as IO -runUnitTest :: UnitTestOptions -> IO ()-runUnitTest opts = case opts ^. L.name of+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++runUnitTest :: Z.UnitTestOptions -> IO ()+runUnitTest opts = case opts ^. the @"name" of   "select1 example 1" -> do     let v :: DVS.Vector Word64 = DVS.fromList           [    0,   19,   80,  129,  161,  179,  237,  281,  302,  350,  394,  438,  438,  458,  470,  524@@ -32,8 +37,7 @@     let !rsbs = makeCsPoppy v     let !p = select1 v r -    when (select1 rsbs r /= p) $ do-      error "Failed unit test"+    when (select1 rsbs r /= p) $ error "Failed unit test"   "select1 example 2" -> do     fileV <- IO.mmapFromForeignRegion "data/example.ib"     let csPoppy = makeCsPoppy fileV@@ -43,8 +47,7 @@      let !p = select1 fileV r -    when (select1 csPoppy r /= p) $ do-      error "Failed unit test"+    when (select1 csPoppy r /= p) $ error "Failed unit test"   "select1 example 3" -> do     fileV <- IO.mmapFromForeignRegion "data/example.ib"     let csPoppy = makeCsPoppy fileV@@ -54,12 +57,11 @@      let !p = select1 fileV r -    when (select1 csPoppy r /= p) $ do-      error "Failed unit test"+    when (select1 csPoppy r /= p) $ error "Failed unit test"   xs -> IO.putStrLn $ "Invalid unit test" <> xs -optsUnitTest :: Parser UnitTestOptions-optsUnitTest = UnitTestOptions+optsUnitTest :: Parser Z.UnitTestOptions+optsUnitTest = Z.UnitTestOptions   <$> strOption       (   long "name"       <>  help "Unit test name"

@@ -1,14 +1,16 @@ {-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}  module App.Commands.Validate   ( cmdValidate   ) where -import App.Commands.Options.Type import Control.Lens import Control.Monad import Control.Monad.State+import Data.Generics.Product.Any import Data.Monoid                               ((<>)) import Data.Word import HaskellWorks.Data.AtIndex@@ -17,24 +19,28 @@ import HaskellWorks.Data.RankSelect.Base.Select1 import Options.Applicative -import qualified App.Commands.Options.Lens            as L+import qualified App.Commands.Options.Type            as Z import qualified Data.Vector.Storable                 as DVS import qualified HaskellWorks.Data.FromForeignRegion  as IO import qualified HaskellWorks.Data.RankSelect.CsPoppy as CS import qualified System.IO                            as IO -runValidate :: ValidateOptions -> IO ()-runValidate opts = case opts ^. L.indexType of-  CsPoppy  -> do-    !(v :: DVS.Vector Word64) <- IO.mmapFromForeignRegion (opts ^. L.file)+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Redundant return"    :: String) #-} +runValidate :: Z.ValidateOptions -> IO ()+runValidate opts = case opts ^. the @"indexType" of+  Z.CsPoppy  -> do+    !(v :: DVS.Vector Word64) <- IO.mmapFromForeignRegion (opts ^. the @"file")+     let !csIndex = CS.makeCsPoppy v -    (_, final) <- flip runStateT emptyValidateState $+    (_, final) <- flip runStateT Z.emptyValidateState $       forM_ [0 .. fromIntegral (DVS.length v - 1)] $ \i -> do         let w = v !!! i         let wPopCount = popCount1 w-        lastPopCount <- use L.cumulativePopCount+        lastPopCount <- use (the @"cumulativePopCount")          forM_ [0 .. 64] $ \pw -> do           let r = rank1 w pw + lastPopCount@@ -59,19 +65,19 @@             return ()           return () -        L.cumulativePopCount += wPopCount+        the @"cumulativePopCount" += wPopCount          return () -    IO.putStrLn $ "PopCounts validated: " <> show (final ^. L.cumulativePopCount)+    IO.putStrLn $ "PopCounts validated: " <> show (final ^. the @"cumulativePopCount")      return ()-  Poppy512 -> do+  Z.Poppy512 -> do     putStrLn "Not implemented"     return () -optsValidate :: Parser ValidateOptions-optsValidate = ValidateOptions+optsValidate :: Parser Z.ValidateOptions+optsValidate = Z.ValidateOptions   <$> option auto       (   long "index-type"       <>  help "Index type"

@@ -6,14 +6,18 @@ import Control.Monad import Criterion.Main import Data.List-import Data.Monoid ((<>))+import Data.Monoid                                                 ((<>)) import Data.Word import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.CsPoppy-import HaskellWorks.Data.RankSelect.CsPoppy.Internal+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Reference+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector import HaskellWorks.Data.RankSelect.Poppy512 import System.Directory import System.Environment@@ -43,7 +47,7 @@   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)   where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: CsPoppy) -> bgroup filename-          [ bench "CsPoppy Rank1"  (whnf (CS.rank1 v) 100)+          [ bench "CsPoppy Rank1"  (whnf (rank1 v) 100)           ]  benchCsPoppySelect1 :: IO [Benchmark]@@ -73,7 +77,7 @@   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)   where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(rsbs :: Poppy512) -> bgroup filename-          [ bench "Poppy512 Rank1"  (whnf (CS.rank1 rsbs) 100)+          [ bench "Poppy512 Rank1"  (whnf (rank1 rsbs) 100)           ]  benchPoppy512Select1 :: IO [Benchmark]@@ -97,22 +101,13 @@     let !_ = select1 msbs 1     return () -benchMakeCsPoppyBlocks1 :: IO [Benchmark]-benchMakeCsPoppyBlocks1 = do-  entries <- getDirectoryContents "data"-  let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries-  return (mkBenchmark <$> files)-  where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: DVS.Vector Word64) -> bgroup filename-          [ bench "makeCsPoppyBlocks1"  (whnf makeCsPoppyBlocks1 v)-          ]--benchMakeCsPoppyBlocks2 :: IO [Benchmark]-benchMakeCsPoppyBlocks2 = do+benchMakeCsPoppyBlocks :: IO [Benchmark]+benchMakeCsPoppyBlocks = do   entries <- getDirectoryContents "data"   let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries   return (mkBenchmark <$> files)   where mkBenchmark filename = env (mmapFromForeignRegion filename) $ \(v :: DVS.Vector Word64) -> bgroup filename-          [ bench "makeCsPoppyBlocks2"  (whnf makeCsPoppyBlocks2 v)+          [ bench "makeCsPoppyBlocks"  (whnf makeCsPoppyBlocks v)           ]  benchMakeCsPoppyLayerM :: IO [Benchmark]@@ -126,7 +121,7 @@           ]         mkEnv filename = do           !v <- mmapFromForeignRegion filename-          return (makeCsPoppyBlocks2 v)+          return (makeCsPoppyBlocks v)  benchGenCsSamples :: IO [Benchmark] benchGenCsSamples = do@@ -138,7 +133,7 @@           ]         mkEnv filename = do           !v <- mmapFromForeignRegion filename-          let !blocks          = makeCsPoppyBlocks2 v+          let !blocks          = makeCsPoppyBlocks v           let !layerM          = makeCsPoppyLayerM blocks           return (getCsiTotal (CsInterleaved (lastOrZero layerM)), v) @@ -151,8 +146,7 @@     <> [benchPoppy512Build]     <> [benchPoppy512Rank1]     <> [benchPoppy512Select1]-    <> [benchMakeCsPoppyBlocks1]-    <> [benchMakeCsPoppyBlocks2]+    <> [benchMakeCsPoppyBlocks]     <> [benchMakeCsPoppyLayerM]     <> [benchGenCsSamples]   when (null benchmarks) $ putStrLn "Warning: No benchmarks found"

@@ -1,9 +1,7 @@--- This file has been generated from package.yaml by hpack version 0.18.1.------ see: https://github.com/sol/hpack+cabal-version:  2.2  name:           hw-rankselect-version:        0.12.0.4+version:        0.13.0.0 synopsis:       Rank-select description:    Please see README.md category:       Data, Bit, Succinct Data Structures, Data Structures@@ -11,17 +9,15 @@ bug-reports:    https://github.com/haskell-works/hw-rankselect/issues author:         John Ky maintainer:     newhoggy@gmail.com-copyright:      2016 John Ky-license:        BSD3+copyright:      2016-2019 John Ky+license:        BSD-3-Clause license-file:   LICENSE tested-with:    GHC == 8.4.2, GHC == 8.2.2, GHC == 8.0.2, GHC == 7.10.3 build-type:     Simple-cabal-version:  >= 1.10- extra-source-files:+    README.md     data/README.md     data/sample-000.idx-    README.md  source-repository head   type: git@@ -32,90 +28,111 @@   manual: False   default: False -library-  hs-source-dirs:-      src-  ghc-options: -Wall -O2 -msse4.2-  build-depends:-      hw-rankselect-base    >= 0.2.0.0    && < 0.4-    , vector                >= 0.12       && < 0.13-    , base                >= 4          && < 5-    , deepseq             >= 1.4        && < 1.5-    , hw-balancedparens   >= 0.1.0.0    && < 0.3-    , hw-bits             >= 0.6.0.0    && < 0.8-    , hw-prim             >= 0.6        && < 0.7-  if (flag(bmi2)) && (impl(ghc >=8.4.1))-    ghc-options: -mbmi2 -msse4.2-    cpp-options: -DBMI2_ENABLED+common base                 { build-depends: base                 >= 4          && < 5      }++common QuickCheck           { build-depends: QuickCheck           >= 2.10       && < 2.12   }+common bytestring           { build-depends: bytestring           >= 0.10       && < 0.11   }+common conduit              { build-depends: conduit              >= 1.2        && < 1.4    }+common criterion            { build-depends: criterion            >= 1.1        && < 1.6    }+common deepseq              { build-depends: deepseq              >= 1.4        && < 1.5    }+common directory            { build-depends: directory            >= 1.2        && < 1.5    }+common generic-lens         { build-depends: generic-lens         >= 1.0.0.0    && < 1.2    }+common hedgehog             { build-depends: hedgehog             >= 0.5        && < 0.7    }+common hspec                { build-depends: hspec                >= 2.4        && < 2.6    }+common hw-balancedparens    { build-depends: hw-balancedparens    >= 0.1.0.0    && < 0.3    }+common hw-bits              { build-depends: hw-bits              >= 0.4.0.0    && < 0.8    }+common hw-hedgehog          { build-depends: hw-hedgehog          >= 0.1.0.1    && < 0.2    }+common hw-hspec-hedgehog    { build-depends: hw-hspec-hedgehog    >= 0.1        && < 0.2    }+common hw-prim              { build-depends: hw-prim              >= 0.6        && < 0.8    }+common hw-rankselect-base   { build-depends: hw-rankselect-base   >= 0.2.0.0    && < 0.4    }+common lens                 { build-depends: lens                 >= 4          && < 5      }+common mmap                 { build-depends: mmap                 >= 0.5        && < 0.6    }+common mtl                  { build-depends: mtl                  >= 2.2        && < 2.3    }+common optparse-applicative { build-depends: optparse-applicative >= 0.11       && < 0.15   }+common resourcet            { build-depends: resourcet            >= 1.1        && < 1.3    }+common transformers         { build-depends: transformers         >= 0.4        && < 0.6    }+common vector               { build-depends: vector               >= 0.12       && < 0.13   }++common common+  default-language: Haskell2010   if (impl(ghc >= 8.0.1))     ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  if (flag(bmi2)) && (impl(ghc >=8.4.1))+    ghc-options: -mbmi2+    cpp-options: -DBMI2_ENABLED+  ghc-options:   -O2 -Wall -msse4.2++library+  import:   base+          , common+          , deepseq+          , hw-balancedparens+          , hw-bits+          , hw-prim+          , hw-rankselect-base+          , vector   exposed-modules:       HaskellWorks.Data.RankSelect.CsPoppy-      HaskellWorks.Data.RankSelect.CsPoppy.Internal+      HaskellWorks.Data.RankSelect.CsPoppy0+      HaskellWorks.Data.RankSelect.CsPoppy1+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Lookup+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Nice+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Reference+      HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector       HaskellWorks.Data.RankSelect.Poppy512-  other-modules:-      Paths_hw_rankselect-  default-language: Haskell2010+  other-modules:    Paths_hw_rankselect+  autogen-modules:  Paths_hw_rankselect+  hs-source-dirs:   src  executable hw-rankselect-  main-is: Main.hs-  hs-source-dirs:-      app-  default-extensions: OverloadedStrings TupleSections-  ghc-options: -threaded -rtsopts -Wall -O2 -msse4.2-  build-depends:-      hw-rankselect-base    >= 0.2.0.0    && < 0.4-    , vector                >= 0.12       && < 0.13-    , base                  >= 4.7        && < 5-    , directory             >= 1.2        && < 1.4-    , hw-bits               >= 0.4.0.0    && < 0.8-    , hw-prim               >= 0.4.0.0    && < 0.7-    , hw-rankselect-    , lens                  >= 4          && < 5-    , mmap                  >= 0.5        && < 0.6-    , mtl                   >= 2.2        && < 2.3-    , optparse-applicative  >= 0.11       && < 0.15-  if (flag(bmi2)) && (impl(ghc >=8.4.1))-    ghc-options: -mbmi2 -msse4.2-    cpp-options: -DBMI2_ENABLED-  if (impl(ghc >= 8.0.1))-    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  import:   base+          , common+          , directory+          , generic-lens+          , hw-bits+          , hw-prim+          , hw-rankselect-base+          , lens+          , mmap+          , mtl+          , optparse-applicative+          , vector+  main-is:            Main.hs+  build-depends:      hw-rankselect   other-modules:       App.Commands       App.Commands.Build-      App.Commands.Options.Lens       App.Commands.Options.Type       App.Commands.SelectAll       App.Commands.UnitTest       App.Commands.Validate-  default-language: Haskell2010+      Paths_hw_rankselect+  autogen-modules:    Paths_hw_rankselect+  hs-source-dirs:     app+  default-extensions: OverloadedStrings TupleSections+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N  test-suite hw-rankselect-test+  import:   base+          , common+          , QuickCheck+          , directory+          , hedgehog+          , hspec+          , hw-bits+          , hw-hedgehog+          , hw-hspec-hedgehog+          , hw-prim+          , hw-rankselect-base+          , mmap+          , transformers+          , vector+  build-depends: hw-rankselect   type: exitcode-stdio-1.0   main-is: Spec.hs-  hs-source-dirs:-      test-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall-  build-depends:-      hw-rankselect-base    >= 0.2.0.0    && < 0.4-    , vector                >= 0.12       && < 0.13-    , base                >= 4          && < 5-    , QuickCheck          >= 2.10       && < 2.12-    , directory           >= 1.2        && < 1.4-    , hedgehog            >= 0.5        && < 0.7-    , hspec               >= 2.4        && < 2.6-    , hw-bits             >= 0.4.0.0    && < 0.8-    , hw-hedgehog         >= 0.1.0.1    && < 0.2-    , hw-hspec-hedgehog   >= 0.1        && < 0.2-    , hw-prim             >= 0.5.0.4    && < 0.7-    , hw-rankselect-    , mmap                >= 0.5        && < 0.6-    , transformers        >= 0.4        && < 0.6-  if (flag(bmi2)) && (impl(ghc >=8.4.1))-    ghc-options: -mbmi2 -msse4.2-    cpp-options: -DBMI2_ENABLED-  if (impl(ghc >=8.0.1))-    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints   other-modules:       HaskellWorks.Data.RankSelect.BasicGen       HaskellWorks.Data.RankSelect.BinarySearchSpec@@ -128,31 +145,29 @@       HaskellWorks.Data.RankSelect.SpecCommon       HaskellWorks.Data.RankSelect.ValidateSpec       Test.Common-  default-language: Haskell2010+      Paths_hw_rankselect+  autogen-modules:    Paths_hw_rankselect+  hs-source-dirs:     test+  build-tool-depends: hspec-discover:hspec-discover+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N  benchmark bench-  type: exitcode-stdio-1.0-  main-is: Main.hs-  hs-source-dirs:-      bench-  ghc-options: -O2 -Wall -msse4.2-  build-depends:-      hw-rankselect-base    >= 0.2.0.0    && < 0.4-    , vector                >= 0.12       && < 0.13-    , base                  >= 4          && < 5-    , bytestring            >= 0.10       && < 0.11-    , conduit               >= 1.2        && < 1.4-    , criterion             >= 1.1        && < 1.6-    , directory             >= 1.2        && < 1.5-    , hw-bits               >= 0.4.0.0    && < 0.8-    , hw-prim               >= 0.6.0.0    && < 0.7-    , hw-rankselect-    , hw-rankselect-base    >= 0.3.1.0    && < 0.4-    , mmap                  >= 0.5        && < 0.6-    , resourcet             >= 1.1        && < 1.3-  if (flag(bmi2)) && (impl(ghc >=8.4.1))-    ghc-options: -mbmi2 -msse4.2-    cpp-options: -DBMI2_ENABLED-  if (impl(ghc                >= 8.0.1))-    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints-  default-language: Haskell2010+  import:   base+          , common+          , bytestring        +          , conduit+          , criterion+          , directory+          , hw-bits+          , hw-prim+          , hw-rankselect-base+          , mmap+          , resourcet+          , vector+  build-depends:      hw-rankselect+  type:               exitcode-stdio-1.0+  main-is:            Main.hs+  autogen-modules:    Paths_hw_rankselect+  other-modules:      Paths_hw_rankselect+  hs-source-dirs:     bench+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N

@@ -11,20 +11,12 @@  module HaskellWorks.Data.RankSelect.CsPoppy     ( CsPoppy(..)-    , Nice(..)-    , Rank1(..)     , makeCsPoppy-    , genCsSamples-    , layerMPositions-    , lookupLayerMFrom1-    , lookupLayerMFrom2     ) where  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@@ -36,39 +28,32 @@ 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.PopCount0 import HaskellWorks.Data.Bits.PopCount.PopCount1-import HaskellWorks.Data.Drop import HaskellWorks.Data.FromForeignRegion-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.RankSelect.CsPoppy.Internal+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector import HaskellWorks.Data.Vector.AsVector64-import Prelude                                         hiding (drop, length, pi, take)--import qualified Data.Vector.Storable as DVS+import Prelude                                                     hiding (drop, length, pi, take) -newtype Nice a = Nice a deriving Eq+import qualified Data.Vector.Storable                                 as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0 as A0+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1  data CsPoppy = CsPoppy   { csPoppyBits   :: !(DVS.Vector Word64)-  , csPoppyLayerM :: !(DVS.Vector Word64)-  , csPoppyLayerS :: !(DVS.Vector Word64) -- Sampling lookup of each 8192 1-bit+  , csPoppyIndex0 :: !A0.CsPoppyIndex+  , csPoppyIndex1 :: !A1.CsPoppyIndex   } deriving (Eq, Show, NFData, Generic)  instance FromForeignRegion CsPoppy where   fromForeignRegion = makeCsPoppy . fromForeignRegion -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 #-}@@ -77,21 +62,20 @@   bitLength = bitLength . csPoppyBits   {-# INLINE bitLength #-} +instance PopCount0 CsPoppy where+  popCount0 v = getCsiTotal (CsInterleaved (lastOrZero (A0.csPoppyLayerM (csPoppyIndex0 v))))+  {-# INLINE popCount0 #-}+ instance PopCount1 CsPoppy where-  popCount1 v = getCsiTotal (CsInterleaved (lastOrZero (csPoppyLayerM v)))+  popCount1 v = getCsiTotal (CsInterleaved (lastOrZero (A1.csPoppyLayerM (csPoppyIndex1 v))))   {-# INLINE popCount1 #-} --- TODO Try to get rid of indexOrZero call makeCsPoppy :: DVS.Vector Word64 -> CsPoppy makeCsPoppy v = CsPoppy   { csPoppyBits   = v-  , csPoppyLayerM = layerM-  , csPoppyLayerS = layerS+  , csPoppyIndex0 = A0.makeCsPoppyIndex v+  , csPoppyIndex1 = A1.makeCsPoppyIndex v   }-  where blocks          = makeCsPoppyBlocks2 v-        layerM          = makeCsPoppyLayerM2 blocks-        layerMPopCount  = getCsiTotal (CsInterleaved (lastOrZero layerM))-        layerS          = genCsSamples layerMPopCount v  instance TestBit CsPoppy where   (.?.) = (.?.) . csPoppyBits@@ -100,101 +84,20 @@ instance BitRead CsPoppy where   bitRead = fmap makeCsPoppy . bitRead +instance Rank0 CsPoppy where+  rank0 (CsPoppy !v i _) = A0.rank0On v i+  {-# INLINE rank0 #-}+ instance Rank1 CsPoppy where-  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)+  rank1 (CsPoppy !v _ i) = A1.rank1On v i   {-# INLINE rank1 #-} -binarySearchPBounds :: (Word64 -> Bool) -> (DVS.Vector Word64) -> Word64 -> Word64 -> Word64-binarySearchPBounds p v = loop-  where loop :: Word64 -> Word64 -> Word64-        loop !l !u-          | u <= l    = l-          | otherwise = let e = v !!! fromIntegral k in if p e then loop l k else loop (k + 1) u-          where k = (u + l) .>. 1-{-# INLINE binarySearchPBounds #-}--layerMPositions :: CsPoppy -> [Word64]-layerMPositions (CsPoppy _ v _) = DVS.toList v >>= expand-  where expand mw = [nx, na, nb, nc]-          where mx  =  mw .&. 0x00000000ffffffff          :: Word64-                ma  = (mw .&. 0x000003ff00000000) .>. 32  :: Word64-                mb  = (mw .&. 0x000ffc0000000000) .>. 42  :: Word64-                mc  = (mw .&. 0x3ff0000000000000) .>. 52  :: Word64-                nx  = mx                                  :: Word64-                na  = nx + ma                             :: Word64-                nb  = na + mb                             :: Word64-                nc  = nb + mc                             :: Word64--lookupLayerMXFrom :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> Word64-lookupLayerMXFrom prev i r v | i < length v =-  let mw  = v !!! fromIntegral i                      :: Word64-      mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64-  in if r <= mx-    then prev-    else lookupLayerMXFrom i (i + 1) r v-lookupLayerMXFrom prev _ _ _ = prev-{-# INLINE lookupLayerMXFrom #-}--lookupLayerMFrom1 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)-lookupLayerMFrom1 i _ r v-  | r <= mx   = error "This shouldn't happen"-  | r <= ma   = (mx, j * 4    )-  | r <= mb   = (ma, j * 4 + 1)-  | r <= mc   = (mb, j * 4 + 2)-  | otherwise = (mc, j * 4 + 3)-  where j   = lookupLayerMXFrom 0 i r v-        mw  = v !!! fromIntegral j                      :: Word64-        mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64-        ma  = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64-        mb  = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64-        mc  = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64-{-# INLINE lookupLayerMFrom1 #-}--lookupLayerMFrom2 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)-lookupLayerMFrom2 i j r v =-  let cmp w = (r - 1) < (w .&. 0xffffffff)-      !k  = (binarySearchPBounds cmp v i j - 1) `max` 0-      !mw = v !!! fromIntegral k                      :: Word64-      !mx =      ( mw .&. 0x00000000ffffffff        ) :: Word64-      !ma = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64-      !mb = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64-      !mc = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64-  in if-    | r <= mx   -> (0 , 0        )-    | r <= ma   -> (mx, k * 4    )-    | r <= mb   -> (ma, k * 4 + 1)-    | r <= mc   -> (mb, k * 4 + 2)-    | otherwise -> (mc, k * 4 + 3)-{-# INLINE lookupLayerMFrom2 #-}+instance Select0 CsPoppy where+  select0 (CsPoppy !v i _) = A0.select0On v i+  {-# INLINE select0 #-}  instance Select1 CsPoppy where-  select1 _                             r | r == 0  = 0-  select1 (CsPoppy !v !layerM !layerS)  r           =-    let !si                 = (r - 1) `div` 8192                              in-    let !spi                = layerS !!! fromIntegral si                      in-    let vBitSize = fromIntegral (DVS.length v) * 64                           in-    let !spj                = atIndexOr vBitSize layerS (fromIntegral si + 1) in-    let !mi                 = spi `div` (512 * 4)                             in-    let !mj                 = spj `div` (512 * 4)                             in-    -- let !(!bbr, !bbi)     = lookupLayerMFrom1 mi (mj + 1) r layerM            in-    let !(!bbr, !bbi)     = lookupLayerMFrom2 mi (mj + 1) r layerM            in-    let !block              = DVS.take 8 (drop (bbi * 8) v)                   in-    let !q                  = r - bbr                                         in--    select1 block q + bbi * 512+  select1 (CsPoppy !v _ i) = A1.select1On v i   {-# INLINE select1 #-}  instance OpenAt CsPoppy where@@ -228,10 +131,6 @@ instance Enclose CsPoppy where   enclose = enclose . csPoppyBits   {-# INLINE enclose #-}--instance Rank0 CsPoppy where-  rank0 rsbs p = p - rank1 rsbs p-  {-# INLINE rank0 #-}  instance BalancedParens CsPoppy where   firstChild  = firstChild  . csPoppyBits

@@ -1,208 +0,0 @@-{-# OPTIONS_GHC-funbox-strict-fields #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE Rank2Types          #-}-{-# LANGUAGE ScopedTypeVariables #-}--module HaskellWorks.Data.RankSelect.CsPoppy.Internal-    ( CsInterleaved(..)-    , getCsiX-    , getCsiA-    , getCsiB-    , getCsiC-    , getCsiTotal-    , mkCsi-    , putCsiX-    , putCsiA-    , putCsiB-    , putCsiC-    , indexOrZero-    , lastOrZero-    , makeCsPoppyBlocks1-    , makeCsPoppyBlocks2-    , makeCsPoppyLayerM-    , makeCsPoppyLayerM2-    , genCsSamples-    ) where--import Data.Word-import Foreign.Ptr-import Foreign.Storable-import HaskellWorks.Data.AtIndex-import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.Bits.PopCount.PopCount1-import HaskellWorks.Data.Positioning-import HaskellWorks.Data.RankSelect.Base.Select1--import qualified Control.Monad.ST             as ST-import qualified Data.Vector.Storable         as DVS-import qualified Data.Vector.Storable.Mutable as DVSM--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)--makeCsPoppyBlocks1 :: DVS.Vector Word64 -> DVS.Vector Word64-makeCsPoppyBlocks1 v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks-  where genBlocks :: DVS.Vector Word64 -> Word64-        genBlocks u = let i = DVS.length u in popCount1 (DVS.take 8 (DVS.drop (i * 8) v))--makeCsPoppyBlocks2 :: DVS.Vector Word64 -> DVS.Vector Word64-makeCsPoppyBlocks2 v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks-  where e = DVS.length v-        genBlocks :: DVS.Vector Word64 -> Word64-        genBlocks u = let i = DVS.length u in if-          | (i + 1) * 8 <= e -> let j = i * 8 in-              popCount1 (DVS.unsafeIndex v (j + 0)) +-              popCount1 (DVS.unsafeIndex v (j + 1)) +-              popCount1 (DVS.unsafeIndex v (j + 2)) +-              popCount1 (DVS.unsafeIndex v (j + 3)) +-              popCount1 (DVS.unsafeIndex v (j + 4)) +-              popCount1 (DVS.unsafeIndex v (j + 5)) +-              popCount1 (DVS.unsafeIndex v (j + 6)) +-              popCount1 (DVS.unsafeIndex v (j + 7))-          | otherwise -> popCount1 (DVS.take 8 (DVS.drop (i * 8) v))--makeCsPoppyLayerM :: DVS.Vector Word64 -> DVS.Vector Word64-makeCsPoppyLayerM blocks = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1-  where 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))--makeCsPoppyLayerM2 :: DVS.Vector Word64 -> DVS.Vector Word64-makeCsPoppyLayerM2 blocks = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1-  where genLayer1 :: DVS.Vector Word64 -> Word64-        genLayer1 u = let ui = end u in if ui > 0 && ui * 4 + 4 < end blocks-          then  let lx = DVS.unsafeIndex u      (fromIntegral (ui     - 1)) in-                let la = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 4)) in-                let lb = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 3)) in-                let lc = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 2)) in-                let ld = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 1)) in-                let nx = lx + (la + lb + lc + ld)                           in-                let na = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 0)) in-                let nb = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 1)) in-                let nc = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 2)) in-                (   ( nx         .&. 0x00000000ffffffff)-                .|. ((na .<. 32) .&. 0x000003ff00000000)-                .|. ((nb .<. 42) .&. 0x000ffc0000000000)-                .|. ((nc .<. 52) .&. 0x3ff0000000000000))-          else  let lx = lastOrZero u                     in-                let la = indexOrZero blocks (ui * 4 - 4)  in-                let lb = indexOrZero blocks (ui * 4 - 3)  in-                let lc = indexOrZero blocks (ui * 4 - 2)  in-                let ld = indexOrZero blocks (ui * 4 - 1)  in-                let nx = lx + (la + lb + lc + ld)         in-                let na = indexOrZero blocks (ui * 4 + 0)  in-                let nb = indexOrZero blocks (ui * 4 + 1)  in-                let nc = indexOrZero blocks (ui * 4 + 2)  in-                (   ( nx         .&. 0x00000000ffffffff)-                .|. ((na .<. 32) .&. 0x000003ff00000000)-                .|. ((nb .<. 42) .&. 0x000ffc0000000000)-                .|. ((nc .<. 52) .&. 0x3ff0000000000000))--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 #-}--sampleWidth :: Count-sampleWidth = 8192-{-# INLINE sampleWidth #-}--genCsSamples :: Count -> DVS.Vector Word64 -> DVS.Vector Word64-genCsSamples pc v = DVS.create (genCsSamplesST pc v)--genCsSamplesST :: Count -> DVS.Vector Word64 -> (forall s . ST.ST s (DVS.MVector s Word64))-genCsSamplesST pc v = do-  u :: DVSM.MVector s Word64 <- DVSM.unsafeNew maxSize--  go u 0 0 (DVS.length v) 0 1-  where maxSize :: Int-        maxSize = fromIntegral $ (pc `div` 8192) + 1-        go :: DVS.MVector s Word64 -> Int -> Int -> Int -> Count -> Count -> ST.ST s (DVS.MVector s Word64)-        go u ui vi vie lpc epc | vi < vie = do-          -- u:   Target vector-          -- ui:  Target vector index-          -- uim: Target vector end index-          -- v:   Source vector-          -- vi:  Target vector index-          -- lpc: Last pop count-          -- epc: Expectant pop count--          -- uw <- DVSM.read u ui-          let vw = DVS.unsafeIndex v vi -- Source word-          let vwpc = popCount1 vw       -- Source word pop count-          let npc = vwpc + lpc          -- Next pop count--          if npc >= epc-            then do -- Emit a position-              let dpc = epc - lpc-              let ewp = select1 vw dpc + fromIntegral vi * 64 -- Expectant word position-              DVSM.unsafeWrite u ui ewp-              go u (ui + 1) (vi + 1) vie npc (epc + sampleWidth)-            else do -- Don't emit a position this time-              go u ui (vi + 1) vie npc epc-        go u ui _ _ _ _ = return (DVSM.take ui u)

@@ -0,0 +1,171 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0+    ( CsPoppyIndex(..)+    , makeCsPoppyIndex+    , makeCsPoppyBlocks+    , makeCsPoppyLayerM2+    , genCsSamples+    , rank0On+    , select0On+    ) where++import Control.DeepSeq+import Data.Word+import GHC.Generics+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount0+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.Select0+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Lookup+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector++import Prelude hiding (drop)++import qualified Control.Monad.ST             as ST+import qualified Data.Vector.Storable         as DVS+import qualified Data.Vector.Storable.Mutable as DVSM++data CsPoppyIndex = CsPoppyIndex+  { csPoppyLayerM :: !(DVS.Vector Word64)+  , csPoppyLayerS :: !(DVS.Vector Word64) -- Sampling lookup of each 8192 1-bit+  } deriving (Eq, Show, NFData, Generic)++makeCsPoppyIndex :: DVS.Vector Word64 -> CsPoppyIndex+makeCsPoppyIndex vv = CsPoppyIndex+  { csPoppyLayerM = layerM+  , csPoppyLayerS = layerS+  }+  where blocks          = makeCsPoppyBlocks vv+        layerM          = makeCsPoppyLayerM2 blocks+        layerMPopCount  = getCsiTotal (CsInterleaved (lastOrZero layerM))+        layerS          = genCsSamples layerMPopCount vv++makeCsPoppyBlocks :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyBlocks vv = DVS.constructN (((DVS.length vv + 8 - 1) `div` 8) + 1) genBlocks+  where e = DVS.length vv+        genBlocks :: DVS.Vector Word64 -> Word64+        genBlocks u = let i = DVS.length u in if+          | (i + 1) * 8 <= e -> let j = i * 8 in+              popCount0 (DVS.unsafeIndex vv (j + 0)) ++              popCount0 (DVS.unsafeIndex vv (j + 1)) ++              popCount0 (DVS.unsafeIndex vv (j + 2)) ++              popCount0 (DVS.unsafeIndex vv (j + 3)) ++              popCount0 (DVS.unsafeIndex vv (j + 4)) ++              popCount0 (DVS.unsafeIndex vv (j + 5)) ++              popCount0 (DVS.unsafeIndex vv (j + 6)) ++              popCount0 (DVS.unsafeIndex vv (j + 7))+          | otherwise -> popCount0 (DVS.take 8 (DVS.drop (i * 8) vv))++makeCsPoppyLayerM2 :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyLayerM2 blocksv = DVS.constructN (((DVS.length blocksv + 4 - 1) `div` 4) + 1) genLayer1+  where genLayer1 :: DVS.Vector Word64 -> Word64+        genLayer1 u = let ui = end u in if ui > 0 && ui * 4 + 4 < end blocksv+          then  let lx = DVS.unsafeIndex u       (fromIntegral (ui     - 1)) in+                let la = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 - 4)) in+                let lb = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 - 3)) in+                let lc = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 - 2)) in+                let ld = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 - 1)) in+                let nx = lx + (la + lb + lc + ld)                           in+                let na = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 + 0)) in+                let nb = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 + 1)) in+                let nc = DVS.unsafeIndex blocksv (fromIntegral (ui * 4 + 2)) in+                (   ( nx         .&. 0x00000000ffffffff)+                .|. ((na .<. 32) .&. 0x000003ff00000000)+                .|. ((nb .<. 42) .&. 0x000ffc0000000000)+                .|. ((nc .<. 52) .&. 0x3ff0000000000000))+          else  let lx = lastOrZero u                     in+                let la = indexOrZero blocksv (ui * 4 - 4)  in+                let lb = indexOrZero blocksv (ui * 4 - 3)  in+                let lc = indexOrZero blocksv (ui * 4 - 2)  in+                let ld = indexOrZero blocksv (ui * 4 - 1)  in+                let nx = lx + (la + lb + lc + ld)         in+                let na = indexOrZero blocksv (ui * 4 + 0)  in+                let nb = indexOrZero blocksv (ui * 4 + 1)  in+                let nc = indexOrZero blocksv (ui * 4 + 2)  in+                (   ( nx         .&. 0x00000000ffffffff)+                .|. ((na .<. 32) .&. 0x000003ff00000000)+                .|. ((nb .<. 42) .&. 0x000ffc0000000000)+                .|. ((nc .<. 52) .&. 0x3ff0000000000000))++sampleWidth :: Count+sampleWidth = 8192+{-# INLINE sampleWidth #-}++genCsSamples :: Count -> DVS.Vector Word64 -> DVS.Vector Word64+genCsSamples pc v = DVS.create (genCsSamplesST pc v)++genCsSamplesST :: Count -> DVS.Vector Word64 -> (forall s . ST.ST s (DVS.MVector s Word64))+genCsSamplesST pc vv = do+  u :: DVSM.MVector s Word64 <- DVSM.unsafeNew maxSize++  go u 0 0 (DVS.length vv) 0 1+  where maxSize :: Int+        maxSize = fromIntegral $ (pc `div` 8192) + 1+        go :: DVS.MVector s Word64 -> Int -> Int -> Int -> Count -> Count -> ST.ST s (DVS.MVector s Word64)+        go u ui vi vie lpc epc | vi < vie = do+          -- u:   Target vector+          -- ui:  Target vector index+          -- uim: Target vector end index+          -- v:   Source vector+          -- vi:  Target vector index+          -- lpc: Last pop count+          -- epc: Expectant pop count++          -- uw <- DVSM.read u ui+          let vw    = comp (DVS.unsafeIndex vv vi)  -- Source word+          let vwpc  = popCount1 vw                  -- Source word pop count+          let npc   = vwpc + lpc                    -- Next pop count++          if npc >= epc+            then do -- Emit a position+              let dpc = epc - lpc+              let ewp = select0 vw dpc + fromIntegral vi * 64 -- Expectant word position+              DVSM.unsafeWrite u ui ewp+              go u (ui + 1) (vi + 1) vie npc (epc + sampleWidth)+            else go u ui (vi + 1) vie npc epc -- Don't emit a position this time+        go u ui _ _ _ _ = return (DVSM.take ui u)++rank0On :: DVS.Vector Word64 -> CsPoppyIndex -> Count -> Count+rank0On v (CsPoppyIndex 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  = rank0 (DVS.drop (fromIntegral (p `div` 512) * 8) v) (p `mod` 512)+{-# INLINE rank0On #-}++select0On :: DVS.Vector Word64 -> CsPoppyIndex -> Count -> Count+select0On _ _ r | r == 0  = 0+select0On v (CsPoppyIndex !layerM !layerS) r =+  let !si                 = (r - 1) `div` 8192                              in+  let !spi                = layerS !!! fromIntegral si                      in+  let vBitSize            = fromIntegral (DVS.length v) * 64                in+  let !spj                = atIndexOr vBitSize layerS (fromIntegral si + 1) in+  let !mi                 = spi `div` (512 * 4)                             in+  let !mj                 = spj `div` (512 * 4)                             in+  let !(!bbr, !bbi)       = lookupLayerMFrom2 mi (mj + 1) r layerM          in+  let !block              = DVS.take 8 (drop (bbi * 8) v)                   in+  let !q                  = r - bbr                                         in++  select0 block q + bbi * 512+{-# INLINE select0On #-}

@@ -0,0 +1,171 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1+    ( CsPoppyIndex(..)+    , makeCsPoppyIndex+    , makeCsPoppyBlocks+    , makeCsPoppyLayerM2+    , genCsSamples+    , rank1On+    , select1On+    ) where++import Control.DeepSeq+import Data.Word+import GHC.Generics+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.Drop+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Lookup+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector++import Prelude hiding (drop)++import qualified Control.Monad.ST             as ST+import qualified Data.Vector.Storable         as DVS+import qualified Data.Vector.Storable.Mutable as DVSM++data CsPoppyIndex = CsPoppyIndex+  { csPoppyLayerM :: !(DVS.Vector Word64)+  , csPoppyLayerS :: !(DVS.Vector Word64) -- Sampling lookup of each 8192 1-bit+  } deriving (Eq, Show, NFData, Generic)++makeCsPoppyIndex :: DVS.Vector Word64 -> CsPoppyIndex+makeCsPoppyIndex v = CsPoppyIndex+  { csPoppyLayerM = layerM+  , csPoppyLayerS = layerS+  }+  where blocks          = makeCsPoppyBlocks v+        layerM          = makeCsPoppyLayerM2 blocks+        layerMPopCount  = getCsiTotal (CsInterleaved (lastOrZero layerM))+        layerS          = genCsSamples layerMPopCount v++makeCsPoppyBlocks :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyBlocks v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks+  where e = DVS.length v+        genBlocks :: DVS.Vector Word64 -> Word64+        genBlocks u = let i = DVS.length u in if+          | (i + 1) * 8 <= e -> let j = i * 8 in+              popCount1 (DVS.unsafeIndex v (j + 0)) ++              popCount1 (DVS.unsafeIndex v (j + 1)) ++              popCount1 (DVS.unsafeIndex v (j + 2)) ++              popCount1 (DVS.unsafeIndex v (j + 3)) ++              popCount1 (DVS.unsafeIndex v (j + 4)) ++              popCount1 (DVS.unsafeIndex v (j + 5)) ++              popCount1 (DVS.unsafeIndex v (j + 6)) ++              popCount1 (DVS.unsafeIndex v (j + 7))+          | otherwise -> popCount1 (DVS.take 8 (DVS.drop (i * 8) v))++makeCsPoppyLayerM2 :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyLayerM2 blocks = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1+  where genLayer1 :: DVS.Vector Word64 -> Word64+        genLayer1 u = let ui = end u in if ui > 0 && ui * 4 + 4 < end blocks+          then  let lx = DVS.unsafeIndex u      (fromIntegral (ui     - 1)) in+                let la = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 4)) in+                let lb = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 3)) in+                let lc = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 2)) in+                let ld = DVS.unsafeIndex blocks (fromIntegral (ui * 4 - 1)) in+                let nx = lx + (la + lb + lc + ld)                           in+                let na = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 0)) in+                let nb = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 1)) in+                let nc = DVS.unsafeIndex blocks (fromIntegral (ui * 4 + 2)) in+                (   ( nx         .&. 0x00000000ffffffff)+                .|. ((na .<. 32) .&. 0x000003ff00000000)+                .|. ((nb .<. 42) .&. 0x000ffc0000000000)+                .|. ((nc .<. 52) .&. 0x3ff0000000000000))+          else  let lx = lastOrZero u                     in+                let la = indexOrZero blocks (ui * 4 - 4)  in+                let lb = indexOrZero blocks (ui * 4 - 3)  in+                let lc = indexOrZero blocks (ui * 4 - 2)  in+                let ld = indexOrZero blocks (ui * 4 - 1)  in+                let nx = lx + (la + lb + lc + ld)         in+                let na = indexOrZero blocks (ui * 4 + 0)  in+                let nb = indexOrZero blocks (ui * 4 + 1)  in+                let nc = indexOrZero blocks (ui * 4 + 2)  in+                (   ( nx         .&. 0x00000000ffffffff)+                .|. ((na .<. 32) .&. 0x000003ff00000000)+                .|. ((nb .<. 42) .&. 0x000ffc0000000000)+                .|. ((nc .<. 52) .&. 0x3ff0000000000000))++sampleWidth :: Count+sampleWidth = 8192+{-# INLINE sampleWidth #-}++genCsSamples :: Count -> DVS.Vector Word64 -> DVS.Vector Word64+genCsSamples pc v = DVS.create (genCsSamplesST pc v)++genCsSamplesST :: Count -> DVS.Vector Word64 -> (forall s . ST.ST s (DVS.MVector s Word64))+genCsSamplesST pc v = do+  u :: DVSM.MVector s Word64 <- DVSM.unsafeNew maxSize++  go u 0 0 (DVS.length v) 0 1+  where maxSize :: Int+        maxSize = fromIntegral $ (pc `div` 8192) + 1+        go :: DVS.MVector s Word64 -> Int -> Int -> Int -> Count -> Count -> ST.ST s (DVS.MVector s Word64)+        go u ui vi vie lpc epc | vi < vie = do+          -- u:   Target vector+          -- ui:  Target vector index+          -- uim: Target vector end index+          -- v:   Source vector+          -- vi:  Target vector index+          -- lpc: Last pop count+          -- epc: Expectant pop count++          -- uw <- DVSM.read u ui+          let vw    = DVS.unsafeIndex v vi  -- Source word+          let vwpc  = popCount1 vw          -- Source word pop count+          let npc   = vwpc + lpc            -- Next pop count++          if npc >= epc+            then do -- Emit a position+              let dpc = epc - lpc+              let ewp = select1 vw dpc + fromIntegral vi * 64 -- Expectant word position+              DVSM.unsafeWrite u ui ewp+              go u (ui + 1) (vi + 1) vie npc (epc + sampleWidth)+            else go u ui (vi + 1) vie npc epc -- Don't emit a position this time+        go u ui _ _ _ _ = return (DVSM.take ui u)++rank1On :: DVS.Vector Word64 -> CsPoppyIndex -> Count -> Count+rank1On v (CsPoppyIndex 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 rank1On #-}++select1On :: DVS.Vector Word64 -> CsPoppyIndex -> Count -> Count+select1On _ _ r | r == 0  = 0+select1On v (CsPoppyIndex !layerM !layerS) r =+  let !si                 = (r - 1) `div` 8192                              in+  let !spi                = layerS !!! fromIntegral si                      in+  let vBitSize            = fromIntegral (DVS.length v) * 64                in+  let !spj                = atIndexOr vBitSize layerS (fromIntegral si + 1) in+  let !mi                 = spi `div` (512 * 4)                             in+  let !mj                 = spj `div` (512 * 4)                             in+  let !(!bbr, !bbi)       = lookupLayerMFrom2 mi (mj + 1) r layerM          in+  let !block              = DVS.take 8 (drop (bbi * 8) v)                   in+  let !q                  = r - bbr                                         in++  select1 block q + bbi * 512+{-# INLINE select1On #-}

@@ -0,0 +1,72 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+    ( 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)

@@ -0,0 +1,62 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf   #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Lookup where++import Data.Word+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Bits.BitWise+import Prelude                        hiding (drop, length, pi, take)++import qualified Data.Vector.Storable as DVS++binarySearchPBounds :: (Word64 -> Bool) -> DVS.Vector Word64 -> Word64 -> Word64 -> Word64+binarySearchPBounds p v = loop+  where loop :: Word64 -> Word64 -> Word64+        loop !l !u+          | u <= l    = l+          | otherwise = let e = v !!! fromIntegral k in if p e then loop l k else loop (k + 1) u+          where k = (u + l) .>. 1+{-# INLINE binarySearchPBounds #-}++lookupLayerMXFrom :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> Word64+lookupLayerMXFrom prev i r v | i < length v =+  let mw  = v !!! fromIntegral i                      :: Word64+      mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64+  in if r <= mx+    then prev+    else lookupLayerMXFrom i (i + 1) r v+lookupLayerMXFrom prev _ _ _ = prev+{-# INLINE lookupLayerMXFrom #-}++lookupLayerMFrom1 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)+lookupLayerMFrom1 i _ r v+  | r <= mx   = error "This shouldn't happen"+  | r <= ma   = (mx, j * 4    )+  | r <= mb   = (ma, j * 4 + 1)+  | r <= mc   = (mb, j * 4 + 2)+  | otherwise = (mc, j * 4 + 3)+  where j   = lookupLayerMXFrom 0 i r v+        mw  = v !!! fromIntegral j                      :: Word64+        mx  =      ( mw .&. 0x00000000ffffffff        ) :: Word64+        ma  = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64+        mb  = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64+        mc  = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64+{-# INLINE lookupLayerMFrom1 #-}++lookupLayerMFrom2 :: Word64 -> Word64 -> Word64 -> DVS.Vector Word64 -> (Word64, Word64)+lookupLayerMFrom2 i j r v =+  let cmp w = (r - 1) < (w .&. 0xffffffff)+      !k  = (binarySearchPBounds cmp v i j - 1) `max` 0+      !mw = v !!! fromIntegral k                      :: Word64+      !mx =      ( mw .&. 0x00000000ffffffff        ) :: Word64+      !ma = mx + ((mw .&. 0x000003ff00000000) .>. 32) :: Word64+      !mb = ma + ((mw .&. 0x000ffc0000000000) .>. 42) :: Word64+      !mc = mb + ((mw .&. 0x3ff0000000000000) .>. 52) :: Word64+  in if+    | r <= mx   -> (0 , 0        )+    | r <= ma   -> (mx, k * 4    )+    | r <= mb   -> (ma, k * 4 + 1)+    | r <= mc   -> (mb, k * 4 + 2)+    | otherwise -> (mc, k * 4 + 3)+{-# INLINE lookupLayerMFrom2 #-}

@@ -0,0 +1,28 @@+{-# LANGUAGE FlexibleInstances #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Nice where++import Data.Semigroup                                              ((<>))+import HaskellWorks.Data.Bits.BitShow+import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved++import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0 as A0+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1++import qualified Data.Vector.Storable as DVS++newtype Nice a = Nice a deriving Eq++instance Show (Nice CsPoppy) where+  showsPrec _ (Nice rsbs) = showString "CsPoppy "+    <> showString "{ csPoppyBits = "   <> shows (bitShow <$> DVS.toList (csPoppyBits     rsbs))+    <> showString ", csPoppyIndex0 = CsPoppyIndex"+    <> showString "{ csPoppyLayerM = " <> shows (CsInterleaved <$> DVS.toList (A0.csPoppyLayerM (csPoppyIndex0 rsbs)))+    <> showString ", csPoppyLayerS = " <> shows (A0.csPoppyLayerS (csPoppyIndex0 rsbs))+    <> showString " }"+    <> showString ", csPoppyIndex1 = CsPoppyIndex"+    <> showString "{ csPoppyLayerM = " <> shows (CsInterleaved <$> DVS.toList (A1.csPoppyLayerM (csPoppyIndex1 rsbs)))+    <> showString ", csPoppyLayerS = " <> shows (A1.csPoppyLayerS (csPoppyIndex1 rsbs))+    <> showString " }"+    <> showString " }"

@@ -0,0 +1,35 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Reference+    ( makeCsPoppyLayerM+    ) where++import Data.Word+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Length+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector++import qualified Data.Vector.Storable as DVS++makeCsPoppyLayerM :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyLayerM blocks = DVS.constructN (((DVS.length blocks + 4 - 1) `div` 4) + 1) genLayer1+  where 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))+

@@ -0,0 +1,21 @@+module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector+  ( indexOrZero+  , lastOrZero+  ) where++import Data.Word+import HaskellWorks.Data.AtIndex+import HaskellWorks.Data.Positioning++import qualified Data.Vector.Storable as DVS++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 #-}

@@ -0,0 +1,128 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy0+    ( CsPoppy0(..)+    , makeCsPoppy0+    ) where++import Control.DeepSeq+import Data.Word+import GHC.Generics+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.PopCount0+import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select0+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector+import HaskellWorks.Data.Vector.AsVector64+import Prelude                                                     hiding (drop, length, pi, take)++import qualified Data.Vector.Storable                                 as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha0 as A0++data CsPoppy0 = CsPoppy0+  { csPoppy0Bits   :: !(DVS.Vector Word64)+  , csPoppy0Index0 :: !A0.CsPoppyIndex+  } deriving (Eq, Show, NFData, Generic)++instance FromForeignRegion CsPoppy0 where+  fromForeignRegion = makeCsPoppy0 . fromForeignRegion++instance AsVector64 CsPoppy0 where+  asVector64 = asVector64 . csPoppy0Bits+  {-# INLINE asVector64 #-}++instance BitLength CsPoppy0 where+  bitLength = bitLength . csPoppy0Bits+  {-# INLINE bitLength #-}++instance PopCount0 CsPoppy0 where+  popCount0 v = getCsiTotal (CsInterleaved (lastOrZero (A0.csPoppyLayerM (csPoppy0Index0 v))))+  {-# INLINE popCount0 #-}++makeCsPoppy0 :: DVS.Vector Word64 -> CsPoppy0+makeCsPoppy0 v = CsPoppy0+  { csPoppy0Bits   = v+  , csPoppy0Index0 = A0.makeCsPoppyIndex v+  }++instance TestBit CsPoppy0 where+  (.?.) = (.?.) . csPoppy0Bits+  {-# INLINE (.?.) #-}++instance BitRead CsPoppy0 where+  bitRead = fmap makeCsPoppy0 . bitRead++instance Rank1 CsPoppy0 where+  rank1 rsbs p = p - rank0 rsbs p+  {-# INLINE rank1 #-}++instance Rank0 CsPoppy0 where+  rank0 (CsPoppy0 !v i) = A0.rank0On v i+  {-# INLINE rank0 #-}++instance Select0 CsPoppy0 where+  select0 (CsPoppy0 !v i) = A0.select0On v i+  {-# INLINE select0 #-}++instance OpenAt CsPoppy0 where+  openAt = openAt . csPoppy0Bits+  {-# INLINE openAt #-}++instance CloseAt CsPoppy0 where+  closeAt = closeAt . csPoppy0Bits+  {-# INLINE closeAt #-}++instance NewCloseAt CsPoppy0 where+  newCloseAt = newCloseAt . csPoppy0Bits+  {-# INLINE newCloseAt #-}++instance FindOpenN CsPoppy0 where+  findOpenN = findOpenN . csPoppy0Bits+  {-# INLINE findOpenN #-}++instance FindOpen CsPoppy0 where+  findOpen = findOpen . csPoppy0Bits+  {-# INLINE findOpen #-}++instance FindClose CsPoppy0 where+  findClose = findClose . csPoppy0Bits+  {-# INLINE findClose #-}++instance FindCloseN CsPoppy0 where+  findCloseN = findCloseN . csPoppy0Bits+  {-# INLINE findCloseN #-}++instance Enclose CsPoppy0 where+  enclose = enclose . csPoppy0Bits+  {-# INLINE enclose #-}++instance BalancedParens CsPoppy0 where+  firstChild  = firstChild  . csPoppy0Bits+  nextSibling = nextSibling . csPoppy0Bits+  parent      = parent      . csPoppy0Bits+  {-# INLINE firstChild  #-}+  {-# INLINE nextSibling #-}+  {-# INLINE parent      #-}

@@ -0,0 +1,128 @@+{-# OPTIONS_GHC-funbox-strict-fields #-}++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.CsPoppy1+    ( CsPoppy1(..)+    , makeCsPoppy+    ) where++import Control.DeepSeq+import Data.Word+import GHC.Generics+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.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Rank0+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Vector+import HaskellWorks.Data.Vector.AsVector64+import Prelude                                                     hiding (drop, length, pi, take)++import qualified Data.Vector.Storable                                 as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1++data CsPoppy1 = CsPoppy1+  { csPoppy1Bits   :: !(DVS.Vector Word64)+  , csPoppy1Index1 :: !A1.CsPoppyIndex+  } deriving (Eq, Show, NFData, Generic)++instance FromForeignRegion CsPoppy1 where+  fromForeignRegion = makeCsPoppy . fromForeignRegion++instance AsVector64 CsPoppy1 where+  asVector64 = asVector64 . csPoppy1Bits+  {-# INLINE asVector64 #-}++instance BitLength CsPoppy1 where+  bitLength = bitLength . csPoppy1Bits+  {-# INLINE bitLength #-}++instance PopCount1 CsPoppy1 where+  popCount1 v = getCsiTotal (CsInterleaved (lastOrZero (A1.csPoppyLayerM (csPoppy1Index1 v))))+  {-# INLINE popCount1 #-}++makeCsPoppy :: DVS.Vector Word64 -> CsPoppy1+makeCsPoppy v = CsPoppy1+  { csPoppy1Bits   = v+  , csPoppy1Index1 = A1.makeCsPoppyIndex v+  }++instance TestBit CsPoppy1 where+  (.?.) = (.?.) . csPoppy1Bits+  {-# INLINE (.?.) #-}++instance BitRead CsPoppy1 where+  bitRead = fmap makeCsPoppy . bitRead++instance Rank0 CsPoppy1 where+  rank0 rsbs p = p - rank1 rsbs p+  {-# INLINE rank0 #-}++instance Rank1 CsPoppy1 where+  rank1 (CsPoppy1 !v i) = A1.rank1On v i+  {-# INLINE rank1 #-}++instance Select1 CsPoppy1 where+  select1 (CsPoppy1 !v i) = A1.select1On v i+  {-# INLINE select1 #-}++instance OpenAt CsPoppy1 where+  openAt = openAt . csPoppy1Bits+  {-# INLINE openAt #-}++instance CloseAt CsPoppy1 where+  closeAt = closeAt . csPoppy1Bits+  {-# INLINE closeAt #-}++instance NewCloseAt CsPoppy1 where+  newCloseAt = newCloseAt . csPoppy1Bits+  {-# INLINE newCloseAt #-}++instance FindOpenN CsPoppy1 where+  findOpenN = findOpenN . csPoppy1Bits+  {-# INLINE findOpenN #-}++instance FindOpen CsPoppy1 where+  findOpen = findOpen . csPoppy1Bits+  {-# INLINE findOpen #-}++instance FindClose CsPoppy1 where+  findClose = findClose . csPoppy1Bits+  {-# INLINE findClose #-}++instance FindCloseN CsPoppy1 where+  findCloseN = findCloseN . csPoppy1Bits+  {-# INLINE findCloseN #-}++instance Enclose CsPoppy1 where+  enclose = enclose . csPoppy1Bits+  {-# INLINE enclose #-}++instance BalancedParens CsPoppy1 where+  firstChild  = firstChild  . csPoppy1Bits+  nextSibling = nextSibling . csPoppy1Bits+  parent      = parent      . csPoppy1Bits+  {-# INLINE firstChild  #-}+  {-# INLINE nextSibling #-}+  {-# INLINE parent      #-}

@@ -26,6 +26,7 @@ import HaskellWorks.Data.Bits.BitLength import HaskellWorks.Data.Bits.BitRead import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount0 import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Positioning@@ -46,6 +47,10 @@  instance FromForeignRegion Poppy512 where   fromForeignRegion = makePoppy512 . fromForeignRegion++instance PopCount0 Poppy512 where+  popCount0 = popCount0 . poppy512Bits+  {-# INLINE popCount0 #-}  instance PopCount1 Poppy512 where   popCount1 = popCount1 . poppy512Bits

@@ -58,14 +58,14 @@     _ <- forAll $ pure bs     fmap (rank1 bs) [0..16] === [0, 1, 2, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6] -genSelect0UpTo8Spec :: forall s. (Typeable s, BitRead s, Select0 s, Show s) => s -> Spec+genSelect0UpTo8Spec :: forall s. Typeable s => s -> Spec genSelect0UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do   it "select0 10010010 over [0..5] should be 023568" $ requireProperty $ do     let bs = fromJust $ bitRead "10010010" :: Word8     _ <- forAll $ pure bs     fmap (select0 bs) [0..5] === [0, 2, 3, 5, 6, 8] -genSelect0UpTo16Spec :: forall s. (Typeable s, BitRead s, Select0 s, Show s) => s -> Spec+genSelect0UpTo16Spec :: forall s. Typeable s => s -> Spec genSelect0UpTo16Spec _ = describe ("Generically up to 16 bits for " ++ show (typeOf (undefined :: s))) $ do   it "select0 11011010 00 over [0..5]" $ requireProperty $ do     let bs = fromJust $ bitRead "1101101 000" :: [Bool]

@@ -2,20 +2,28 @@  module HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec (spec) where +import Data.Word import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.RankSelect.CsPoppy.Internal+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.CsInterleaved import HaskellWorks.Hspec.Hedgehog import Hedgehog-import Prelude                                       hiding (length)+import Prelude                                                     hiding (length) import Test.Hspec  import qualified Data.Vector.Storable as DVS import qualified Hedgehog.Gen         as G import qualified Hedgehog.Range       as R -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} +makeCsPoppyBlocksRef :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyBlocksRef v = DVS.constructN (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks+  where genBlocks :: DVS.Vector Word64 -> Word64+        genBlocks u = let i = DVS.length u in popCount1 (DVS.take 8 (DVS.drop (i * 8) v))+ spec :: Spec spec = describe "HaskellWorks.Data.RankSelect.CsInterleavedSpec" $ do   describe "Interleaved Level 1 & 2" $ do@@ -41,10 +49,10 @@       getCsiA (putCsiA va (CsInterleaved 0)) === (va .&. 0x3ff)       getCsiB (putCsiB vb (CsInterleaved 0)) === (vb .&. 0x3ff)       getCsiC (putCsiC vc (CsInterleaved 0)) === (vc .&. 0x3ff)-  describe "makeCsPoppyBlocks2" $ do+  describe "makeCsPoppyBlocks" $ do     it "must behave like makeCsPoppyBlocks1" $ requireProperty $ do       xs <- forAll $ G.list (R.linear 0 1000) (G.word64 R.constantBounded)       v  <- forAll $ pure $ DVS.fromList xs-      a  <- forAll $ pure $ makeCsPoppyBlocks2 v-      e  <- forAll $ pure $ makeCsPoppyBlocks1 v+      a  <- forAll $ pure $ makeCsPoppyBlocks    v+      e  <- forAll $ pure $ makeCsPoppyBlocksRef v       a === e

@@ -8,32 +8,39 @@  import Control.Monad import Control.Monad.IO.Class+import Data.Function import Data.Maybe-import Data.Monoid ((<>))+import Data.Monoid                                        ((<>)) 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.PopCount0 import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.Product+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.RankSelect.BasicGen import HaskellWorks.Data.RankSelect.CsPoppy+import HaskellWorks.Data.RankSelect.CsPoppy.Internal.Nice import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.Take import HaskellWorks.Hspec.Hedgehog import Hedgehog-import Prelude                                   hiding (length, take)+import Prelude                                            hiding (length, take) import Test.Common 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+import qualified Data.Vector.Storable                                 as DVS+import qualified HaskellWorks.Data.RankSelect.CsPoppy.Internal.Alpha1 as A1+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) #-}@@ -67,6 +74,27 @@       i <- forAll $ G.word64 (R.linear 0 (length v * 8))       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       rank1 v i === rank1 w i+  describe "rank0 for Vector Word64 is equivalent to rank0 for CsPoppy" $ do+    it "on empty bitvector" $ require $ withTests 1 $ property $ do+      let v = DVS.empty+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      let i = 0+      rank0 v i === rank0 w i+    it "on one basic block" $ requireProperty $ 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+      rank0 v i === rank0 w i+    it "on two basic blocks" $ requireProperty $ 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+      rank0 v i === rank0 w i+    it "on three basic blocks" $ requireProperty $ 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+      rank0 v i === rank0 w i   describe "select1 for Vector Word64 is equivalent to select1 for CsPoppy" $ do     it "on empty bitvector" $ require $ withTests 1 $ property $ do       let v = DVS.empty@@ -92,6 +120,31 @@       i <- forAll $ G.word64 (R.linear 0 (popCount1 v))       Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v       select1 w i === select1 v i+  describe "select0 for Vector Word64 is equivalent to select0 for CsPoppy" $ do+    it "on empty bitvector" $ require $ withTests 1 $ property $ do+      let v = DVS.empty+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      let i = 0+      select0 w i === select0 v i+    it "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+      select0 w 0 === select0 v 0+    it "on one basic block" $ requireProperty $ do+      v <- forAll $ G.storableVector (R.linear 1 8) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount0 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select0 w i === select0 v i+    it "on two basic blocks" $ requireProperty $ do+      v <- forAll $ G.storableVector (R.linear 9 16) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount0 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select0 w i === select0 v i+    it "on three basic blocks" $ requireProperty $ do+      v <- forAll $ G.storableVector (R.linear 17 24) (G.word64 R.constantBounded)+      i <- forAll $ G.word64 (R.linear 0 (popCount0 v))+      Nice w  <- forAll $ pure $ Nice $ makeCsPoppy v+      select0 w i === select0 v i   describe "Rank select over large buffer" $ do     it "Rank works" $ requireProperty $ do       let cs = fromJust (bitRead (take 4096 (cycle "10"))) :: DVS.Vector Word64@@ -161,24 +214,42 @@           let pc = popCount1 (csPoppyBits csPoppy)           requireProperty $ do             _ <- forAll $ pure $ corpusFile-            _ <- forAll $ pure $ csPoppyLayerS csPoppy+            _ <- forAll $ pure $ A1.csPoppyLayerS (csPoppyIndex1 csPoppy)             s <- forAll $ G.word64 (R.linear 1 pc)             select1 csPoppy s === select1 fileV s -  describe "Corpus specific" $ do+  describe "Corpus specific" $     describe "data/sample-000.idx" $ do+      it "A popCount0" $ requireTest $ do+        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion "data/sample-000.idx"++        actual <- safely $ popCount0 va++        actual === popCount0 vr+      it "A popCount1" $ requireTest $ do+        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion "data/sample-000.idx"++        actual <- safely $ popCount1 va++        actual === popCount1 vr       it "A select1" $ requireTest $ do-        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion ("data/sample-000.idx")+        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion "data/sample-000.idx" -        actual <- safely $ select1 va 158209+        actual <- safely $ select1 va 176670 -        actual === select1 vr 158209+        actual === select1 vr 176670+      it "A select0" $ requireTest $ do+        (va :: CsPoppy) :*: (vr :: Poppy512) <- liftIO $ mmapFromForeignRegion "data/sample-000.idx"++        actual <- safely $ select0 va 1302306++        actual === select0 vr 1302306       it "Check new samples" $ requireTest $ do-        vr :: Poppy512 <- liftIO $ mmapFromForeignRegion ("data/sample-000.idx")+        vr :: Poppy512 <- liftIO $ mmapFromForeignRegion "data/sample-000.idx"          let v = poppy512Bits vr         let pcv = popCount1 v-        let samples = genCsSamples pcv v+        let samples = A1.genCsSamples pcv v          forM_ (zip (DVS.toList samples) [1,8193..]) $ \(sample, i) -> do           select1 vr i === sample

@@ -11,6 +11,7 @@ import HaskellWorks.Data.AtIndex import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion+import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.CsPoppy import HaskellWorks.Hspec.Hedgehog