hw-rankselect 0.12.0.4 → 0.13.4.1
raw patch · 37 files changed
Files
- app/App/Commands.hs +0/−1
- app/App/Commands/Build.hs +22/−16
- app/App/Commands/Options/Lens.hs +0/−16
- app/App/Commands/Options/Type.hs +19/−15
- app/App/Commands/SelectAll.hs +17/−12
- app/App/Commands/UnitTest.hs +14/−13
- app/App/Commands/Validate.hs +19/−14
- app/Main.hs +6/−6
- bench/Main.hs +15/−22
- doctest/DoctestDriver.hs +12/−0
- gen/HaskellWorks/Data/RankSelect/Gen.hs +16/−0
- hw-rankselect.cabal +176/−140
- src/HaskellWorks/Data/RankSelect/BitSeq.hs +86/−0
- 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 +27/−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/Internal/BitSeq.hs +151/−0
- src/HaskellWorks/Data/RankSelect/Internal/List.hs +18/−0
- src/HaskellWorks/Data/RankSelect/Internal/Word.hs +30/−0
- src/HaskellWorks/Data/RankSelect/Poppy512.hs +7/−1
- test/HaskellWorks/Data/RankSelect/BasicGen.hs +4/−4
- test/HaskellWorks/Data/RankSelect/BinarySearchSpec.hs +2/−2
- test/HaskellWorks/Data/RankSelect/BitSeqSpec.hs +145/−0
- test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs +15/−7
- test/HaskellWorks/Data/RankSelect/CsPoppySpec.hs +85/−15
- test/HaskellWorks/Data/RankSelect/InternalSpec.hs +9/−7
- test/HaskellWorks/Data/RankSelect/Poppy512Spec.hs +2/−2
- test/HaskellWorks/Data/RankSelect/SimpleSpec.hs +1/−1
- test/HaskellWorks/Data/RankSelect/ValidateSpec.hs +2/−2
app/App/Commands.hs view
@@ -4,7 +4,6 @@ import App.Commands.SelectAll import App.Commands.UnitTest import App.Commands.Validate-import Data.Monoid ((<>)) import Options.Applicative cmdOpts :: Parser (IO ())
app/App/Commands/Build.hs view
@@ -1,41 +1,47 @@-{-# 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.List-import Data.Monoid ((<>))+import Data.Generics.Product.Any 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 Data.List as L+import qualified HaskellWorks.Data.RankSelect.CsPoppy as CS+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+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}++runBuild :: Z.BuildOptions -> IO ()+runBuild opts = case opts ^. the @"indexType" of+ Z.CsPoppy -> do entries <- getDirectoryContents "data"- let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+ let files = ("data/" ++) <$> (".ib" `L.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+ let files = ("data/" ++) <$> (".ib" `L.isSuffixOf`) `filter` entries forM_ files $ \file -> do putStrLn $ "Loading cspoppy for " <> file 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"
− app/App/Commands/Options/Lens.hs
@@ -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
app/App/Commands/Options/Type.hs view
@@ -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
app/App/Commands/SelectAll.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module App.Commands.SelectAll ( cmdSelectAll@@ -7,8 +9,7 @@ import Control.Lens import Control.Monad-import Data.List-import Data.Monoid ((<>))+import Data.Generics.Product.Any import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Select1@@ -17,14 +18,18 @@ 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+import qualified Data.List as L -runSelectAll :: O.SelectAllOptions -> IO ()-runSelectAll opts = case opts ^. L.indexType of- O.CsPoppy -> do+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}++runSelectAll :: Z.SelectAllOptions -> IO ()+runSelectAll opts = case opts ^. the @"indexType" of+ Z.CsPoppy -> do entries <- getDirectoryContents "data"- let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+ let files = ("data/" ++) <$> (".ib" `L.isSuffixOf`) `filter` entries forM_ files $ \file -> do putStrLn $ "Loading cspoppy for " <> file v :: CsPoppy <- mmapFromForeignRegion file@@ -32,9 +37,9 @@ let !_ = select1 v i return () return ()- O.Poppy512 -> do+ Z.Poppy512 -> do entries <- getDirectoryContents "data"- let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+ let files = ("data/" ++) <$> (".ib" `L.isSuffixOf`) `filter` entries forM_ files $ \file -> do putStrLn $ "Loading cspoppy for " <> file v :: Poppy512 <- mmapFromForeignRegion file@@ -43,8 +48,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"
app/App/Commands/UnitTest.hs view
@@ -1,27 +1,31 @@ {-# 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.Monoid ((<>))+import Data.Generics.Product.Any import Data.Word import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.RankSelect.Base.Select1 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+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}++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 +36,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 +46,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 +56,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"
app/App/Commands/Validate.hs view
@@ -1,15 +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.Monoid ((<>))+import Data.Generics.Product.Any import Data.Word import HaskellWorks.Data.AtIndex import HaskellWorks.Data.Bits.PopCount.PopCount1@@ -17,24 +18,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)+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -} +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 +64,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"
app/Main.hs view
@@ -5,8 +5,6 @@ import App.Commands import Control.Monad-import Data.List-import Data.Monoid ((<>)) import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Select1@@ -15,13 +13,15 @@ import Options.Applicative import System.Directory -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+import qualified Data.List as L +{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+ runPoppy512SelectAll :: IO () runPoppy512SelectAll = do entries <- getDirectoryContents "data"- let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+ let files = ("data/" ++) <$> (".ib" `L.isSuffixOf`) `filter` entries forM_ files $ \file -> do putStrLn $ "Loading cspoppy for " <> file v :: Poppy512 <- mmapFromForeignRegion file@@ -33,7 +33,7 @@ runCsPoppySelectAll :: IO () runCsPoppySelectAll = do entries <- getDirectoryContents "data"- let files = ("data/" ++) <$> (".ib" `isSuffixOf`) `filter` entries+ let files = ("data/" ++) <$> (".ib" `L.isSuffixOf`) `filter` entries forM_ files $ \file -> do putStrLn $ "Loading cspoppy for " <> file v :: CsPoppy <- mmapFromForeignRegion file
bench/Main.hs view
@@ -6,14 +6,17 @@ import Control.Monad import Criterion.Main import Data.List-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@@ -22,8 +25,8 @@ import qualified HaskellWorks.Data.RankSelect.CsPoppy as CS import qualified HaskellWorks.Data.RankSelect.Poppy512 as P512 -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} selectStep :: Count selectStep = 1000@@ -43,7 +46,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 +76,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 +100,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 +120,7 @@ ] mkEnv filename = do !v <- mmapFromForeignRegion filename- return (makeCsPoppyBlocks2 v)+ return (makeCsPoppyBlocks v) benchGenCsSamples :: IO [Benchmark] benchGenCsSamples = do@@ -138,7 +132,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 +145,7 @@ <> [benchPoppy512Build] <> [benchPoppy512Rank1] <> [benchPoppy512Select1]- <> [benchMakeCsPoppyBlocks1]- <> [benchMakeCsPoppyBlocks2]+ <> [benchMakeCsPoppyBlocks] <> [benchMakeCsPoppyLayerM] <> [benchGenCsSamples] when (null benchmarks) $ putStrLn "Warning: No benchmarks found"
+ doctest/DoctestDriver.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE CPP #-}++#if MIN_VERSION_GLASGOW_HASKELL(8,4,4,0)+{-# OPTIONS_GHC -F -pgmF doctest-discover #-}+#else+module Main where++import qualified System.IO as IO++main :: IO ()+main = IO.putStrLn "WARNING: doctest will not run on GHC versions earlier than 8.4.4"+#endif
+ gen/HaskellWorks/Data/RankSelect/Gen.hs view
@@ -0,0 +1,16 @@+module HaskellWorks.Data.RankSelect.Gen+ ( bitSeq+ ) where++import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.BitSeq (BitSeq)+import Hedgehog++import qualified HaskellWorks.Data.RankSelect.BitSeq as BS+import qualified Hedgehog.Gen as G++bools :: MonadGen m => Range Count -> m [Bool]+bools r = G.list (fmap fromIntegral r) G.bool++bitSeq :: MonadGen m => Range Count -> m BitSeq+bitSeq r = BS.fromBools <$> bools r
hw-rankselect.cabal view
@@ -1,27 +1,22 @@--- This file has been generated from package.yaml by hpack version 0.18.1.------ see: https://github.com/sol/hpack--name: hw-rankselect-version: 0.12.0.4-synopsis: Rank-select-description: Please see README.md-category: Data, Bit, Succinct Data Structures, Data Structures-homepage: http://github.com/haskell-works/hw-rankselect#readme-bug-reports: https://github.com/haskell-works/hw-rankselect/issues-author: John Ky-maintainer: newhoggy@gmail.com-copyright: 2016 John Ky-license: BSD3-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+cabal-version: 2.2 -extra-source-files:- data/README.md- data/sample-000.idx- README.md+name: hw-rankselect+version: 0.13.4.1+synopsis: Rank-select+description: Please see README.md+category: Data, Bit, Succinct Data Structures, Data Structures+homepage: http://github.com/haskell-works/hw-rankselect#readme+bug-reports: https://github.com/haskell-works/hw-rankselect/issues+author: John Ky+maintainer: newhoggy@gmail.com+copyright: 2016-2021 John Ky+license: BSD-3-Clause+license-file: LICENSE+tested-with: GHC == 9.2.2, GHC == 9.0.2, GHC == 8.10.7, GHC == 8.8.4, GHC == 8.6.5+build-type: Simple+extra-source-files: README.md+ data/README.md+ data/sample-000.idx source-repository head type: git@@ -32,127 +27,168 @@ 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- if (impl(ghc >= 8.0.1))- ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints- exposed-modules:- HaskellWorks.Data.RankSelect.CsPoppy- HaskellWorks.Data.RankSelect.CsPoppy.Internal- HaskellWorks.Data.RankSelect.Poppy512- other-modules:- Paths_hw_rankselect+common base { build-depends: base >= 4.11 && < 5 }++common QuickCheck { build-depends: QuickCheck >= 2.10 && < 2.15 }+common bytestring { build-depends: bytestring >= 0.10 && < 0.12 }+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.4 }+common doctest { build-depends: doctest >= 0.16.2 && < 0.21 }+common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 }+common generic-lens { build-depends: generic-lens >= 1.2.0.1 && < 2.3 }+common hedgehog { build-depends: hedgehog >= 1.0 && < 1.2 }+common hspec { build-depends: hspec >= 2.4 && < 3 }+common hw-balancedparens { build-depends: hw-balancedparens >= 0.2.2.0 && < 0.5 }+common hw-bits { build-depends: hw-bits >= 0.4.0.0 && < 0.8 }+common hw-fingertree { build-depends: hw-fingertree >= 0.1.1.0 && < 1.2 }+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.2.23 && < 0.7 }+common hw-rankselect-base { build-depends: hw-rankselect-base >= 0.2.0.0 && < 0.4 }+common lens { build-depends: lens >= 4 && < 6 }+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.18 }+common resourcet { build-depends: resourcet >= 1.1 && < 1.3 }+common transformers { build-depends: transformers >= 0.4 && < 0.7 }+common vector { build-depends: vector >= 0.12 && < 0.13 }++common config 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+ if (impl(ghc > 8.2.2))+ ghc-options: -O2 -Wall -msse4.2 +common hw-rankselect+ build-depends: hw-rankselect++library+ import: base, config+ , deepseq+ , hw-balancedparens+ , hw-bits+ , hw-fingertree+ , hw-prim+ , hw-rankselect-base+ , vector+ exposed-modules: HaskellWorks.Data.RankSelect.BitSeq+ HaskellWorks.Data.RankSelect.CsPoppy+ 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.Internal.BitSeq+ HaskellWorks.Data.RankSelect.Internal.List+ HaskellWorks.Data.RankSelect.Internal.Word+ HaskellWorks.Data.RankSelect.Poppy512+ other-modules: Paths_hw_rankselect+ autogen-modules: Paths_hw_rankselect+ hs-source-dirs: src++library hw-rankselect-gen+ import: base, config+ , deepseq+ , hedgehog+ , hspec+ , hw-prim+ , vector+ exposed-modules: HaskellWorks.Data.RankSelect.Gen+ build-depends: hw-rankselect+ hs-source-dirs: gen+ 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- 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+ import: base, config+ , directory+ , generic-lens+ , hw-bits+ , hw-prim+ , hw-rankselect+ , hw-rankselect-base+ , lens+ , mmap+ , mtl+ , optparse-applicative+ , vector+ main-is: Main.hs+ other-modules: App.Commands+ App.Commands.Build+ App.Commands.Options.Type+ App.Commands.SelectAll+ App.Commands.UnitTest+ App.Commands.Validate+ hs-source-dirs: app+ default-extensions: OverloadedStrings TupleSections+ ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite hw-rankselect-test- 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- HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec- HaskellWorks.Data.RankSelect.CsPoppySpec- HaskellWorks.Data.RankSelect.Gen- HaskellWorks.Data.RankSelect.InternalSpec- HaskellWorks.Data.RankSelect.Poppy512Spec- HaskellWorks.Data.RankSelect.SimpleSpec- HaskellWorks.Data.RankSelect.SpecCommon- HaskellWorks.Data.RankSelect.ValidateSpec- Test.Common- default-language: Haskell2010+ import: base, config+ , QuickCheck+ , directory+ , hedgehog+ , hspec+ , hw-bits+ , hw-hedgehog+ , hw-hspec-hedgehog+ , hw-prim+ , hw-rankselect+ , hw-rankselect-base+ , mmap+ , transformers+ , vector+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: HaskellWorks.Data.RankSelect.BasicGen+ HaskellWorks.Data.RankSelect.BinarySearchSpec+ HaskellWorks.Data.RankSelect.BitSeqSpec+ HaskellWorks.Data.RankSelect.CsPoppy.InternalSpec+ HaskellWorks.Data.RankSelect.CsPoppySpec+ HaskellWorks.Data.RankSelect.Gen+ HaskellWorks.Data.RankSelect.InternalSpec+ HaskellWorks.Data.RankSelect.Poppy512Spec+ HaskellWorks.Data.RankSelect.SimpleSpec+ HaskellWorks.Data.RankSelect.SpecCommon+ HaskellWorks.Data.RankSelect.ValidateSpec+ Test.Common+ 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, config+ , 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+ hs-source-dirs: bench+ ghc-options: -threaded -rtsopts -with-rtsopts=-N++test-suite doctest+ import: base, config+ , doctest+ , doctest-discover+ , hw-rankselect+ type: exitcode-stdio-1.0+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ main-is: DoctestDriver.hs+ HS-Source-Dirs: doctest+ build-tool-depends: doctest-discover:doctest-discover
+ src/HaskellWorks/Data/RankSelect/BitSeq.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.RankSelect.BitSeq+ ( BitSeq(..)+ , mempty+ , size+ , fromWord64s+ , fromPartialWord64s+ , toPartialWord64s+ , fromBools+ , toBools+ , BS.splitAt+ , take+ , drop+ , (<|), (><), (|>)+ , select1+ ) where++import Data.Coerce+import Data.Foldable+import Data.Word+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.FingerTree (ViewL (..), ViewR (..), (<|), (><), (|>))+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Select1 (select1)+import HaskellWorks.Data.RankSelect.Internal.BitSeq (BitSeq (BitSeq), BitSeqFt, Elem (Elem))+import Prelude hiding (drop, max, min, splitAt, take)++import qualified Data.List as L+import qualified HaskellWorks.Data.FingerTree as FT+import qualified HaskellWorks.Data.RankSelect.Internal.BitSeq as BS+import qualified HaskellWorks.Data.RankSelect.Internal.Word as W++empty :: BitSeq+empty = BitSeq FT.empty++size :: BitSeq -> Count+size (BitSeq parens) = BS.measureBitCount (FT.measure parens)++-- TODO Needs optimisation+fromWord64s :: Traversable f => f Word64 -> BitSeq+fromWord64s = foldl go empty+ where go :: BitSeq -> Word64 -> BitSeq+ go ps w = BitSeq (BS.parens ps |> Elem w 64)++-- TODO Needs optimisation+fromPartialWord64s :: Traversable f => f (Word64, Count) -> BitSeq+fromPartialWord64s = foldl go empty+ where go :: BitSeq -> (Word64, Count) -> BitSeq+ go ps (w, n) = BitSeq (BS.parens ps |> Elem w n)++toPartialWord64s :: BitSeq -> [(Word64, Count)]+toPartialWord64s = L.unfoldr go . coerce+ where go :: BitSeqFt -> Maybe ((Word64, Count), BitSeqFt)+ go ft = case FT.viewl ft of+ BS.Elem w n :< rt -> Just ((w, coerce n), rt)+ FT.EmptyL -> Nothing++fromBools :: [Bool] -> BitSeq+fromBools = go empty+ where go :: BitSeq -> [Bool] -> BitSeq+ go (BitSeq ps) (b:bs) = case FT.viewr ps of+ FT.EmptyR -> go (BitSeq (FT.singleton (Elem b' 1))) bs+ lt :> Elem w n ->+ let newPs = if n >= 64+ then ps |> Elem b' 1+ else lt |> Elem (w .|. (b' .<. fromIntegral n)) (n + 1)+ in go (BitSeq newPs) bs+ where b' = if b then 1 else 0 :: Word64+ go ps [] = ps++toBools :: BitSeq -> [Bool]+toBools ps = toBoolsDiff ps []++toBoolsDiff :: BitSeq -> [Bool] -> [Bool]+toBoolsDiff ps = mconcat (fmap go (toPartialWord64s ps))+ where go :: (Word64, Count) -> [Bool] -> [Bool]+ go (w, n) = W.partialToBoolsDiff (fromIntegral n) w++drop :: Count -> BitSeq -> BitSeq+drop n ps = snd (BS.splitAt n ps)++take :: Count -> BitSeq -> BitSeq+take n ps = fst (BS.splitAt n ps)
src/HaskellWorks/Data/RankSelect/CsPoppy.hs view
@@ -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
− src/HaskellWorks/Data/RankSelect/CsPoppy/Internal.hs
@@ -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)
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Alpha0.hs view
@@ -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.generate (((DVS.length vv + 8 - 1) `div` 8) + 1) genBlocks+ where e = DVS.length vv+ genBlocks :: Int -> Word64+ genBlocks u = let i = fromIntegral 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 #-}
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Alpha1.hs view
@@ -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.generate (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks+ where e = DVS.length v+ genBlocks :: Int -> Word64+ genBlocks u = let i = fromIntegral 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 #-}
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/CsInterleaved.hs view
@@ -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)
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Lookup.hs view
@@ -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 #-}
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Nice.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleInstances #-}++module HaskellWorks.Data.RankSelect.CsPoppy.Internal.Nice where++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 " }"
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Reference.hs view
@@ -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))+
+ src/HaskellWorks/Data/RankSelect/CsPoppy/Internal/Vector.hs view
@@ -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 #-}
+ src/HaskellWorks/Data/RankSelect/CsPoppy0.hs view
@@ -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 #-}
+ src/HaskellWorks/Data/RankSelect/CsPoppy1.hs view
@@ -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 #-}
+ src/HaskellWorks/Data/RankSelect/Internal/BitSeq.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module HaskellWorks.Data.RankSelect.Internal.BitSeq+ ( Elem(..)+ , Measure(..)+ , BitSeq(..)+ , BitSeqFt+ , (|>#)+ , (#<|)+ , ftSplit+ , atBitCountBelow+ , atPopCountBelow+ , splitAt+ ) where++import Control.DeepSeq+import Data.Word+import GHC.Generics+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.FingerTree (ViewL (..), ViewR (..), (<|), (><), (|>))+import HaskellWorks.Data.Positioning+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import Prelude hiding (max, min, splitAt)++import qualified HaskellWorks.Data.Cons as HW+import qualified HaskellWorks.Data.Container as HW+import qualified HaskellWorks.Data.FingerTree as FT+import qualified HaskellWorks.Data.Snoc as HW++data Elem = Elem+ { elemBits :: {-# UNPACK #-} !Word64+ , elemSize :: {-# UNPACK #-} !Count+ } deriving (Eq, Show, Generic)++instance NFData Elem++data Measure = Measure+ { measureBitCount :: {-# UNPACK #-} !Count+ , measurePopCount :: {-# UNPACK #-} !Count+ } deriving (Eq, Ord, Show, Generic)++instance NFData Measure++type BitSeqFt = FT.FingerTree Measure Elem++newtype BitSeq = BitSeq+ { parens :: BitSeqFt+ } deriving (Show, NFData, Generic)++instance Semigroup Measure where+ a <> b = Measure+ { measureBitCount = measureBitCount a + measureBitCount b+ , measurePopCount = measurePopCount a + measurePopCount b+ }++instance Monoid Measure where+ mempty = Measure 0 0+ mappend = (<>)++instance FT.Measured Measure Elem where+ measure (Elem w size) = Measure+ { measureBitCount = size+ , measurePopCount = popCount1 w+ }++instance HW.Container BitSeq where+ type Elem BitSeq = Bool++instance HW.Cons BitSeq where+ cons b (BitSeq ft) = BitSeq $ case FT.viewl ft of+ Elem w nw :< rt -> if nw >= 0 && nw < 64+ then Elem ((w .<. 1) .|. bw) (nw + 1) <| rt+ else Elem bw 1 <| ft+ FT.EmptyL -> FT.singleton (Elem bw 1)+ where bw = if b then 1 else 0++instance HW.Snoc BitSeq where+ snoc (BitSeq ft) b = BitSeq $ case FT.viewr ft of+ lt :> Elem w nw -> if nw >= 0 && nw < 64+ then Elem (w .|. (bw .<. nw)) (nw + 1) <| lt+ else Elem bw 1 <| lt+ FT.EmptyR -> FT.singleton (Elem bw 1)+ where bw = if b then 1 else 0++instance Semigroup BitSeq where+ BitSeq tl <> BitSeq tr = BitSeq $ case FT.viewr tl of+ tll :> Elem wl nwl -> case FT.viewl tr of+ Elem wr nwr :< trr -> let nw = nwl + nwr in if nw <= 64+ then (tll |> Elem (wl .|. (wr .<. nwl)) nw) >< trr+ else tl >< tr+ FT.EmptyL -> tr+ FT.EmptyR -> FT.empty++instance Select1 BitSeq where+ select1 (BitSeq ft) n = case FT.split (atPopCountBelow n) ft of+ (lt, _) -> case FT.viewr lt of+ FT.EmptyR -> 0+ llt :> Elem w _ ->+ let llpc = measurePopCount (FT.measure llt :: Measure) in+ let llbc = measureBitCount (FT.measure llt :: Measure) in+ llbc + select1 w (n - llpc)++instance Rank1 BitSeq where+ rank1 bs n = let (lt, _) = splitAt n bs in popCount1 lt++instance PopCount1 BitSeq where+ popCount1 (BitSeq ft) = measureBitCount (FT.measure ft :: Measure)++(|>#) :: BitSeqFt -> Elem -> BitSeqFt+(|>#) ft e@(Elem _ wn) = if wn > 0 then ft |> e else ft++(#<|) :: Elem ->BitSeqFt -> BitSeqFt+(#<|) e@(Elem _ wn) ft = if wn > 0 then e <| ft else ft++ftSplit :: (Measure -> Bool) -> BitSeqFt -> (BitSeqFt, BitSeqFt)+ftSplit p ft = case FT.viewl rt of+ Elem w nw :< rrt -> let c = go w nw nw in (lt |># Elem w c, Elem (w .>. c) (nw - c) #<| rrt)+ FT.EmptyL -> (ft, FT.empty)+ where (lt, rt) = FT.split p ft+ ltm = FT.measure lt+ go :: Word64 -> Count -> Count -> Count+ go w c nw = if c > 0+ then if p (ltm <> FT.measure (Elem (w .<. (64 - c) .>. (64 - c)) c))+ then go w (c - 1) nw+ else c+ else 0++atBitCountBelow :: Count -> Measure -> Bool+atBitCountBelow n m = n < measureBitCount (m :: Measure)++atPopCountBelow :: Count -> Measure -> Bool+atPopCountBelow n m = n < measurePopCount (m :: Measure)++splitAt :: Count -> BitSeq -> (BitSeq, BitSeq)+splitAt n (BitSeq ft) = case FT.split (atBitCountBelow n) ft of+ (lt, rt) -> let+ n' = n - measureBitCount (FT.measure lt)+ u = 64 - n'+ in case FT.viewl rt of+ Elem w nw :< rrt -> if n' >= nw+ then (BitSeq lt , BitSeq rrt )+ else (BitSeq (lt |> Elem ((w .<. u) .>. u) n'), BitSeq (Elem (w .>. n') (nw - n') <| rrt))+ FT.EmptyL -> (BitSeq lt, BitSeq FT.empty)
+ src/HaskellWorks/Data/RankSelect/Internal/List.hs view
@@ -0,0 +1,18 @@+module HaskellWorks.Data.RankSelect.Internal.List+ ( chunkBy+ , toBools+ ) where++import Data.Word++import qualified HaskellWorks.Data.BalancedParens.Internal.Word as W++chunkBy :: Int -> [a] -> [[a]]+chunkBy n bs = case (take n bs, drop n bs) of+ (as, zs) -> if null zs then [as] else as:chunkBy n zs++toBoolsDiff :: [Word64] -> [Bool] -> [Bool]+toBoolsDiff = foldr ((.) . W.toBoolsDiff) id++toBools :: [Word64] -> [Bool]+toBools ws = toBoolsDiff ws []
+ src/HaskellWorks/Data/RankSelect/Internal/Word.hs view
@@ -0,0 +1,30 @@+module HaskellWorks.Data.RankSelect.Internal.Word+ ( toBools+ , toBoolsDiff+ , partialToBoolsDiff+ ) where++import Data.Word+import HaskellWorks.Data.Bits.BitWise+import HaskellWorks.Data.Positioning++toBools :: Word64 -> [Bool]+toBools w = toBoolsDiff w []++partialToBoolsDiff :: Count -> Word64 -> [Bool] -> [Bool]+partialToBoolsDiff n w | n > 0 = partialToBoolsDiff (n - 1) w . ((w .?. fromIntegral (n - 1)):)+partialToBoolsDiff 0 _ = id+partialToBoolsDiff _ _ = error "Invalid size"++toBoolsDiff :: Word64 -> [Bool] -> [Bool]+toBoolsDiff w =+ go 0x00 . go 0x01 . go 0x02 . go 0x03 . go 0x04 . go 0x05 . go 0x06 . go 0x07 .+ go 0x08 . go 0x09 . go 0x0a . go 0x0b . go 0x0c . go 0x0d . go 0x0e . go 0x0f .+ go 0x10 . go 0x11 . go 0x12 . go 0x13 . go 0x14 . go 0x15 . go 0x16 . go 0x17 .+ go 0x18 . go 0x19 . go 0x1a . go 0x1b . go 0x1c . go 0x1d . go 0x1e . go 0x1f .+ go 0x20 . go 0x21 . go 0x22 . go 0x23 . go 0x24 . go 0x25 . go 0x26 . go 0x27 .+ go 0x28 . go 0x29 . go 0x2a . go 0x2b . go 0x2c . go 0x2d . go 0x2e . go 0x2f .+ go 0x30 . go 0x31 . go 0x32 . go 0x33 . go 0x34 . go 0x35 . go 0x36 . go 0x37 .+ go 0x38 . go 0x39 . go 0x3a . go 0x3b . go 0x3c . go 0x3d . go 0x3e . go 0x3f+ where go :: Position -> [Bool] -> [Bool]+ go p = ((w .?. p):)
src/HaskellWorks/Data/RankSelect/Poppy512.hs view
@@ -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@@ -47,6 +48,10 @@ instance FromForeignRegion Poppy512 where fromForeignRegion = makePoppy512 . fromForeignRegion +instance PopCount0 Poppy512 where+ popCount0 = popCount0 . poppy512Bits+ {-# INLINE popCount0 #-}+ instance PopCount1 Poppy512 where popCount1 = popCount1 . poppy512Bits {-# INLINE popCount1 #-}@@ -60,7 +65,8 @@ { poppy512Bits = v , poppy512Index = DVS.constructN (((DVS.length v + 7) `div` 8) + 1) gen512Index }- where gen512Index u = let indexN = DVS.length u - 1 in+ where gen512Index :: DVS.Vector Word64 -> Word64+ gen512Index u = let indexN = DVS.length u - 1 in if indexN == -1 then 0 else popCount1 (DVS.take 8 (DVS.drop (indexN * 8) v)) + DVS.last u
test/HaskellWorks/Data/RankSelect/BasicGen.hs view
@@ -19,8 +19,8 @@ import Hedgehog import Test.Hspec -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} genRank0UpTo8Spec :: forall s. (Typeable s, BitRead s, Rank0 s, Show s) => s -> Spec genRank0UpTo8Spec _ = describe ("Generically up to 8 bits for " ++ show (typeOf (undefined :: s))) $ do@@ -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]
test/HaskellWorks/Data/RankSelect/BinarySearchSpec.hs view
@@ -13,8 +13,8 @@ import qualified Data.Vector.Storable as DVS -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} spec :: Spec spec = describe "HaskellWorks.Data.RankSelect.BinarySearchSpec" $ do
+ test/HaskellWorks/Data/RankSelect/BitSeqSpec.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.RankSelect.BitSeqSpec where++import HaskellWorks.Data.Bits.PopCount.PopCount1+import HaskellWorks.Data.RankSelect.Base.Rank1+import HaskellWorks.Data.RankSelect.Base.Select1+import HaskellWorks.Data.RankSelect.BitSeq ((<|), (><), (|>))+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified HaskellWorks.Data.RankSelect.BitSeq as BS+import qualified HaskellWorks.Data.RankSelect.Gen as G+import qualified HaskellWorks.Data.RankSelect.Internal.List as L+import qualified Hedgehog.Gen as G+import qualified Hedgehog.Range as R++{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}++spec :: Spec+spec = describe "HaskellWorks.Data.RankSelect.Internal.BitSeqSpec" $ do+ it "fromWord64s should produce Rmm of the right size" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)++ BS.size (BS.fromWord64s ws) === fromIntegral (length ws * 64)+ it "fromWord64s should produce Rmm with the right data" $ requireProperty $ do+ wns <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.word64 R.constantBounded+ <*> G.count (R.linear 1 64)++ BS.size (BS.fromPartialWord64s wns) === sum (snd <$> wns)+ it "fromWord64s should produce Rmm with the right data" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)++ BS.toPartialWord64s (BS.fromWord64s ws) === zip ws (repeat 64)+ it "fromPartialWord64s should produce Rmm with the right data" $ requireProperty $ do+ wns <- forAll $ G.list (R.linear 0 10) $ (,)+ <$> G.word64 R.constantBounded+ <*> G.count (R.linear 1 64)++ BS.toPartialWord64s (BS.fromPartialWord64s wns) === wns+ it "fromBools should produce Rmm with the right data" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)++ BS.toPartialWord64s (BS.fromBools (L.toBools ws)) === zip ws (repeat 64)+ it "drop should drop the right amount of data" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)+ let ps = BS.fromWord64s ws+ n <- forAll $ G.count (R.linear 0 (BS.size ps))++ BS.size (BS.drop n ps) === BS.size ps - n+ it "take should take the right amount of data" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)+ let ps = BS.fromWord64s ws+ n <- forAll $ G.count (R.linear 0 (BS.size ps))++ BS.size (BS.take n ps) === n+ it "splitAt should split at the correct point" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)+ let ps = BS.fromWord64s ws+ n <- forAll $ G.count (R.linear 0 (BS.size ps))++ let (lt, rt) = BS.splitAt n ps+ BS.size lt === n+ BS.size rt === BS.size ps - n+ BS.toBools lt >< BS.toBools rt === BS.toBools ps+ it "firstChild should choose the first child" $ requireProperty $ do+ ws <- forAll $ G.list (R.linear 0 10) (G.word64 R.constantBounded)+ let ps = BS.fromWord64s ws+ n <- forAll $ G.count (R.linear 0 (BS.size ps))++ BS.size (BS.drop n ps) === BS.size ps - n+ it "rose tree should be generatable" $ requireProperty $ do+ bs <- forAll $ G.list (R.linear 1 1000) G.bool++ BS.toBools (BS.fromBools bs) === bs+ it "(><) should append" $ requireTest $ do+ bs1 <- forAll $ G.list (R.linear 1 1000) G.bool+ bs2 <- forAll $ G.list (R.linear 1 1000) G.bool+ ps1 <- forAll $ pure $ BS.fromBools bs1+ ps2 <- forAll $ pure $ BS.fromBools bs2++ BS.toBools (ps1 >< ps2) === BS.toBools ps1 >< BS.toBools ps2+ it "(<|) should cons" $ requireTest $ do+ b <- forAll $ G.bool+ bs <- forAll $ G.list (R.linear 1 1000) G.bool+ ps <- forAll $ pure $ BS.fromBools bs++ BS.toBools (b <| ps) === b:BS.toBools ps+ it "(|>) should snoc" $ requireTest $ do+ b <- forAll $ G.bool+ bs <- forAll $ G.list (R.linear 1 1000) G.bool+ ps <- forAll $ pure $ BS.fromBools bs++ BS.toBools (ps |> b) === BS.toBools ps <> [b]+ describe "one bitseq" $ do+ it "select1" $ requireTest $ do+ n <- forAll $ G.count (R.linear 0 1000)+ bools <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bs <- forAll $ pure $ BS.fromBools bools+ i <- forAll $ G.count (R.linear 0 n)++ select1 bools i === select1 bs i+ it "rank1" $ requireTest $ do+ n <- forAll $ G.count (R.linear 0 1000)+ bools <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bs <- forAll $ pure $ BS.fromBools bools+ i <- forAll $ G.count (R.linear 0 (popCount1 bools))++ rank1 bools i === rank1 bs i+ it "popCount1" $ requireTest $ do+ bools <- forAll $ G.list (R.linear 0 1000) G.bool+ bs <- forAll $ pure $ BS.fromBools bools++ popCount1 bools === popCount1 bs+ describe "concatenated bitseq" $ do+ it "select1" $ requireTest $ do+ n <- forAll $ G.count (R.linear 0 1000)+ bools1 <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bools2 <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bs1 <- forAll $ pure $ BS.fromBools bools1+ bs2 <- forAll $ pure $ BS.fromBools bools2+ i <- forAll $ G.count (R.linear 0 n)++ select1 (bools1 <> bools2) i === select1 (bs1 <> bs2) i+ it "rank1" $ requireTest $ do+ n <- forAll $ G.count (R.linear 0 1000)+ bools1 <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bools2 <- forAll $ G.list (R.singleton (fromIntegral n)) G.bool+ bs1 <- forAll $ pure $ BS.fromBools bools1+ bs2 <- forAll $ pure $ BS.fromBools bools2+ i <- forAll $ G.count (R.linear 0 (popCount1 (bools1 <> bools2)))++ rank1 (bools1 <> bools2) i === rank1 (bs1 <> bs2) i+ it "popCount1" $ requireTest $ do+ bools1 <- forAll $ G.list (R.linear 0 1000) G.bool+ bools2 <- forAll $ G.list (R.linear 0 1000) G.bool+ bs1 <- forAll $ pure $ BS.fromBools bools1+ bs2 <- forAll $ pure $ BS.fromBools bools2++ popCount1 (bools1 <> bools2) === popCount1 (bs1 <> bs2)
test/HaskellWorks/Data/RankSelect/CsPoppy/InternalSpec.hs view
@@ -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 Reduce duplication" :: String) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} +makeCsPoppyBlocksRef :: DVS.Vector Word64 -> DVS.Vector Word64+makeCsPoppyBlocksRef v = DVS.generate (((DVS.length v + 8 - 1) `div` 8) + 1) genBlocks+ where genBlocks :: Int -> Word64+ genBlocks u = let i = fromIntegral 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
test/HaskellWorks/Data/RankSelect/CsPoppySpec.hs view
@@ -8,35 +8,41 @@ import Control.Monad import Control.Monad.IO.Class+import Data.Function import Data.Maybe-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) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} newtype ShowVector a = ShowVector a deriving (Eq, BitShow) @@ -67,6 +73,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 +119,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 +213,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
test/HaskellWorks/Data/RankSelect/InternalSpec.hs view
@@ -1,8 +1,10 @@-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+ module HaskellWorks.Data.RankSelect.InternalSpec (spec) where +import Data.Maybe import HaskellWorks.Data.Bits.BitRead import HaskellWorks.Data.Bits.PopCount.PopCount1 import HaskellWorks.Data.RankSelect.Base.Rank@@ -15,23 +17,23 @@ 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) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} spec :: Spec spec = describe "HaskellWorks.Data.RankSelect.InternalSpec" $ do describe "For [Bool]" $ do it "rank True 10010010 over [0..8] should be 011122233" $ requireProperty $ do- let (Just bs) = bitRead "10010010" :: Maybe [Bool]+ let bs = fromJust $ bitRead "10010010" :: [Bool] fmap (rank True bs) [0..8] === [0, 1, 1, 1, 2, 2, 2, 3, 3] it "rank True 10010010 over [0..8] should be 001223445" $ requireProperty $ do- let (Just bs) = bitRead "10010010" :: Maybe [Bool]+ let bs = fromJust $ bitRead "10010010" :: [Bool] fmap (rank False bs) [0..8] === [0, 0, 1, 2, 2, 3, 4, 4, 5] it "select True 10010010 over [0..3] should be 0147" $ requireProperty $ do- let (Just bs) = bitRead "10010010" :: Maybe [Bool]+ let bs = fromJust $ bitRead "10010010" :: [Bool] fmap (select True bs) [0..3] === [0, 1, 4, 7] it "select False 10010010 over [0..5] should be 023568" $ requireProperty $ do- let (Just bs) = bitRead "10010010" :: Maybe [Bool]+ let bs = fromJust $ bitRead "10010010" :: [Bool] fmap (select False bs) [0..5] === [0, 2, 3, 5, 6, 8] it "Rank and select form a galois connection" $ requireProperty $ do bs <- forAll $ G.list (R.linear 0 70) G.bool
test/HaskellWorks/Data/RankSelect/Poppy512Spec.hs view
@@ -27,8 +27,8 @@ 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) #-}+{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -} spec :: Spec spec = describe "HaskellWorks.Data.RankSelect.Poppy512.Rank1Spec" $ do
test/HaskellWorks/Data/RankSelect/SimpleSpec.hs view
@@ -16,7 +16,7 @@ import qualified Hedgehog.Gen as G import qualified Hedgehog.Range as R -{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{- HLINT ignore "Redundant do" -} spec :: Spec spec = describe "HaskellWorks.Data.SuccinctSpec" $ do
test/HaskellWorks/Data/RankSelect/ValidateSpec.hs view
@@ -6,11 +6,11 @@ import Control.Monad import Control.Monad.IO.Class import Data.List (isSuffixOf)-import Data.Monoid ((<>)) import Data.Word 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@@ -24,7 +24,7 @@ import qualified Hedgehog.Range as R import qualified System.Directory as IO -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{- HLINT ignore "Reduce duplication" -} entries :: [FilePath] entries = mfilter (".idx" `isSuffixOf`) <$> unsafePerformIO $ IO.getDirectoryContents "data"