diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 John Ky + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +# hw-balancedparens +[![0.0-branch](https://circleci.com/gh/haskell-works/hw-balancedparens/tree/0.0-branch.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-balancedparens/tree/0.0-branch) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello world" diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Criterion.Main +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.FindClose +import HaskellWorks.Data.BalancedParens.RangeMinMax +import HaskellWorks.Data.Bits.Broadword +import HaskellWorks.Data.Bits.FromBitTextByteString +import HaskellWorks.Data.Naive +import HaskellWorks.Data.RankSelect.Base + +setupEnvVector :: Int -> IO (DVS.Vector Word64) +setupEnvVector n = return $ DVS.fromList (take n (cycle [maxBound, 0])) + +setupEnvRmmVector :: Int -> IO (RangeMinMax (DVS.Vector Word64)) +setupEnvRmmVector n = return $ mkRangeMinMax $ DVS.fromList (take n (cycle [maxBound, 0])) + +setupEnvBP2 :: IO Word64 +setupEnvBP2 = return $ DVS.head (fromBitTextByteString "10") + +setupEnvBP4 :: IO Word64 +setupEnvBP4 = return $ DVS.head (fromBitTextByteString "1100") + +setupEnvBP8 :: IO Word64 +setupEnvBP8 = return $ DVS.head (fromBitTextByteString "11101000") + +setupEnvBP16 :: IO Word64 +setupEnvBP16 = return $ DVS.head (fromBitTextByteString "11111000 11100000") + +setupEnvBP32 :: IO Word64 +setupEnvBP32 = return $ DVS.head (fromBitTextByteString "11111000 11101000 11101000 11100000") + +setupEnvBP64 :: IO Word64 +setupEnvBP64 = return $ DVS.head (fromBitTextByteString "11111000 11101000 11101000 11101000 11101000 11101000 11101000 11100000") + +benchRankSelect :: [Benchmark] +benchRankSelect = + [ env setupEnvBP2 $ \w -> bgroup "FindClose 2-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env setupEnvBP4 $ \w -> bgroup "FindClose 4-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env setupEnvBP8 $ \w -> bgroup "FindClose 8-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env setupEnvBP16 $ \w -> bgroup "FindClose 16-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env setupEnvBP32 $ \w -> bgroup "FindClose 32-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env setupEnvBP64 $ \w -> bgroup "FindClose 64-bit" + [ bench "Broadword" (whnf (findClose (Broadword w)) 1) + , bench "Naive" (whnf (findClose (Naive w)) 1) + ] + , env (setupEnvVector 1000000) $ \bv -> bgroup "RangeMinMax" + [ bench "findClose" (nf (map (findClose bv)) [0, 1000..10000000]) + ] + , env (setupEnvVector 1000000) $ \bv -> bgroup "Rank" + [ bench "Rank - Once" (whnf (rank1 bv) 1) + , bench "Select - Once" (whnf (select1 bv) 1) + , bench "Rank - Many" (nf (map (rank1 bv)) [0, 1000..10000000]) + ] + ] + +main :: IO () +main = defaultMain benchRankSelect diff --git a/hw-balancedparens.cabal b/hw-balancedparens.cabal new file mode 100644 --- /dev/null +++ b/hw-balancedparens.cabal @@ -0,0 +1,91 @@ +name: hw-balancedparens +version: 0.0.0.1 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-balancedparens#readme +license: MIT +license-file: LICENSE +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016 John Ky +category: Data, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.22 + +executable hw-balancedparens-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 + build-depends: base >= 4 && < 5 + , hw-balancedparens + default-language: Haskell2010 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.BalancedParens + , HaskellWorks.Data.BalancedParens.BalancedParens + , HaskellWorks.Data.BalancedParens.Broadword + , HaskellWorks.Data.BalancedParens.CloseAt + , HaskellWorks.Data.BalancedParens.Enclose + , HaskellWorks.Data.BalancedParens.FindClose + , HaskellWorks.Data.BalancedParens.FindCloseN + , HaskellWorks.Data.BalancedParens.FindOpen + , HaskellWorks.Data.BalancedParens.FindOpenN + , HaskellWorks.Data.BalancedParens.NewCloseAt + , HaskellWorks.Data.BalancedParens.NewOpenAt + , HaskellWorks.Data.BalancedParens.OpenAt + , HaskellWorks.Data.BalancedParens.RangeMinMax + , HaskellWorks.Data.BalancedParens.RangeMinMax2 + , HaskellWorks.Data.BalancedParens.Simple + build-depends: base >= 4 && < 5 + , hw-bits >= 0.3.0.0 + , hw-excess >= 0.0.0.1 + , hw-prim >= 0.3.0.5 + , hw-rankselect-base >= 0.1.0.0 + , hw-string-parse >= 0.0.0.2 + , safe + , vector + + default-language: Haskell2010 + ghc-options: -Wall -O2 -msse4.2 + +test-suite hw-balancedparens-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.BalancedParens.Internal.BroadwordSpec + , HaskellWorks.Data.BalancedParens.RangeMinMaxSpec + , HaskellWorks.Data.BalancedParens.RangeMinMax2Spec + , HaskellWorks.Data.BalancedParens.SimpleSpec + build-depends: base >= 4 && < 5 + , hspec + , hw-bits >= 0.3.0.0 + , hw-prim >= 0.3.0.5 + , hw-balancedparens + , hw-rankselect-base >= 0.1.0.0 + , QuickCheck + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-balancedparens + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -O2 -Wall -msse4.2 + Default-Language: Haskell2010 + Build-Depends: base >= 4 && < 5 + , bytestring + , conduit + , criterion + , hw-bits >= 0.3.0.0 + , hw-prim >= 0.3.0.5 + , hw-balancedparens + , hw-rankselect-base >= 0.1.0.0 + , mmap + , vector diff --git a/src/HaskellWorks/Data/BalancedParens.hs b/src/HaskellWorks/Data/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens.hs @@ -0,0 +1,13 @@ +module HaskellWorks.Data.BalancedParens + ( module X + ) where + +import HaskellWorks.Data.BalancedParens.BalancedParens as X +import HaskellWorks.Data.BalancedParens.CloseAt as X +import HaskellWorks.Data.BalancedParens.Enclose as X +import HaskellWorks.Data.BalancedParens.FindClose as X +import HaskellWorks.Data.BalancedParens.FindCloseN as X +import HaskellWorks.Data.BalancedParens.FindOpen as X +import HaskellWorks.Data.BalancedParens.FindOpenN as X +import HaskellWorks.Data.BalancedParens.OpenAt as X +import HaskellWorks.Data.BalancedParens.Simple as X diff --git a/src/HaskellWorks/Data/BalancedParens/BalancedParens.hs b/src/HaskellWorks/Data/BalancedParens/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/BalancedParens.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.BalancedParens + ( BalancedParens(..) + , depth + , subtreeSize + ) where + +import Control.Monad +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.BalancedParens.Enclose +import HaskellWorks.Data.BalancedParens.FindClose +import HaskellWorks.Data.BalancedParens.FindOpen +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 + +class (OpenAt v, CloseAt v, FindOpen v, FindClose v, Enclose v) => BalancedParens v where + -- TODO Second argument should be Int + firstChild :: v -> Count -> Maybe Count + nextSibling :: v -> Count -> Maybe Count + parent :: v -> Count -> Maybe Count + firstChild v p = if openAt v p && openAt v (p + 1) then Just (p + 1) else Nothing + nextSibling v p = if closeAt v p + then Nothing + else openAt v `mfilter` (findClose v p >>= (\q -> + if p /= q + then return (q + 1) + else Nothing)) + parent v p = enclose v p >>= (\r -> if r >= 1 then return r else Nothing) + {-# INLINE firstChild #-} + {-# INLINE nextSibling #-} + {-# INLINE parent #-} + +depth :: (BalancedParens v, Rank0 v, Rank1 v) => v -> Count -> Maybe Count +depth v p = (\q -> rank1 v q - rank0 v q) <$> findOpen v p +{-# INLINE depth #-} + +subtreeSize :: BalancedParens v => v -> Count -> Maybe Count +subtreeSize v p = (\q -> (q - p + 1) `quot` 2) <$> findClose v p +{-# INLINE subtreeSize #-} + +instance BalancedParens [Bool] + +instance BalancedParens (DVS.Vector Word8) + +instance BalancedParens (DVS.Vector Word16) + +instance BalancedParens (DVS.Vector Word32) + +instance BalancedParens (DVS.Vector Word64) + +instance BalancedParens Word8 + +instance BalancedParens Word16 + +instance BalancedParens Word32 + +instance BalancedParens Word64 + +instance BalancedParens (Naive Word64) diff --git a/src/HaskellWorks/Data/BalancedParens/Broadword.hs b/src/HaskellWorks/Data/BalancedParens/Broadword.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/Broadword.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.BalancedParens.Broadword + ( findCloseW64 + , ocCalc8 + , ocCalc64 + , showPadded + , kkBitDiffPos + , kkBitDiff + , kkBitDiffSimple + ) where + +import qualified Data.Bits as DB +import Data.Int +import Data.Word +import Debug.Trace +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.Broadword + +traceW :: String -> Word64 -> Word64 +traceW s w = trace (s ++ ": " ++ show (BitShown w) ++ " : " ++ show w ++ ", " ++ show (fromIntegral w :: Int64)) w + +findCloseW64 :: Word64 -> Word64 +findCloseW64 x = -- let !_ = traceW "x00" x in + let !b00 = x - ((x .&. 0xaaaaaaaaaaaaaaaa) .>. 1) in -- let !_ = traceW "b00" b00 in + let !b01 = (b00 .&. 0x3333333333333333) + ((b00 .>. 2) .&. 0x3333333333333333) in -- let !_ = traceW "b01" b01 in + let !b02 = (b01 + (b01 .>. 4)) .&. 0x0f0f0f0f0f0f0f0f in -- let !_ = traceW "b02" b02 in + let !b03 = (b02 * 0x0101010101010101) .<. 1 in -- let !_ = traceW "b03" b03 in + let !b04 = kBitDiffUnsafe 8 (h 8 .|. 0x4038302820181008) b03 in -- let !_ = traceW "b04" b04 in + let !u00 = (((((b04 .|. h 8) - l 8) .>. 7) .&. l 8) .|. h 8) - l 8 in -- let !_ = traceW "u00" u00 in + let !z00 = ((h 8 .>. 1) .|. (l 8 * 7)) .&. u00 in -- let !_ = traceW "z00" z00 in + -- let !_ = trace "" False in + let !d10 = (l 8 * 2 - (((x .>. 6) .&. (l 8 .<. 1)) + ((x .>. 5) .&. (l 8 .<. 1)))) in -- let !_ = traceW "d10" d10 in + let !b10 = b04 - d10 in -- let !_ = traceW "b10" b10 in + let !u10 = (((((b10 .|. h 8) - l 8) .>. 7) .&. l 8) .|. h 8) - l 8 in -- let !_ = traceW "u10" u10 in + let !z10 = (z00 .&. comp u10) .|. (((h 8 .>. 1) .|. (l 8 * 5)) .&. u10) in -- let !_ = traceW "z10" z10 in + -- let !_ = trace "" False in + let !d20 = (l 8 * 2 - (((x .>. 4) .&. (l 8 .<. 1)) + ((x .>. 3) .&. (l 8 .<. 1)))) in -- let !_ = traceW "d20" d20 in + let !b20 = b10 - d20 in -- let !_ = traceW "b20" b20 in + let !u20 = (((((b20 .|. h 8) - l 8) .>. 7) .&. l 8) .|. h 8) - l 8 in -- let !_ = traceW "u20" u20 in + let !z20 = (z10 .&. comp u20) .|. (((h 8 .>. 1) .|. (l 8 * 3)) .&. u20) in -- let !_ = traceW "z20" z20 in + -- let !_ = trace "" False in + let !d30 = (l 8 * 2 - (((x .>. 2) .&. (l 8 .<. 1)) + ((x .>. 1) .&. (l 8 .<. 1)))) in -- let !_ = traceW "d30" d30 in + let !b30 = b20 - d30 in -- let !_ = traceW "b30" b30 in + let !u30 = (((((b30 .|. h 8) - l 8) .>. 7) .&. l 8) .|. h 8) - l 8 in -- let !_ = traceW "u30" u30 in + let !z30 = (z20 .&. comp u30) .|. (((h 8 .>. 1) .|. l 8 ) .&. u30) in -- let !_ = traceW "z30" z30 in + + let !p00 = lsb (z30 .>. 6 .&. l 8) in -- let !_ = traceW "p00" p00 in + let !r00 = ((p00 + ((z30 .>. fromIntegral p00) .&. 0x3f)) .|. (p00 .>. 8)) .&. 0x7f in -- let !_ = traceW "r00" r00 in + r00 +{-# INLINE findCloseW64 #-} + +-- µ0 :: Word64 +-- µ0 = 0x5555555555555555 + +µ1 :: Word64 +µ1 = 0x3333333333333333 + +µ2 :: Word64 +µ2 = 0x0F0F0F0F0F0F0F0F + +µ3 :: Word64 +µ3 = 0x00FF00FF00FF00FF + +µ4 :: Word64 +µ4 = 0x0000FFFF0000FFFF + +µ5 :: Word64 +µ5 = 0x00000000FFFFFFFF + +ocCalc64 :: Word64 -> (Word64, Word64) +ocCalc64 x = + let b0 = x .&. 0x5555555555555555 in let !_ = traceW "b0 " b0 in + let b1 = (x .&. 0xAAAAAAAAAAAAAAAA) .>. 1 in let !_ = traceW "b1 " b1 in + let ll = (b0 .^. b1) .&. b1 in let !_ = traceW "ll " ll in + let o1 = (b0 .&. b1) .<. 1 .|. ll in let !_ = traceW "o1 " o1 in + let c1 = ((b0 .|. b1) .^. 0x5555555555555555) .<. 1 .|. ll in let !_ = traceW "c1 " c1 in + + let eo1 = o1 .&. µ1 in let !_ = traceW "eo1" eo1 in + let ec1 = ((c1 .&. µ1) .<. 2) .>. 2 in let !_ = traceW "ec1" ec1 in + let o2 = (((o1 .&. µ1) .<. 2) .>. 2) + kBitDiffPos 8 eo1 ec1 in let !_ = traceW "o2 " o2 in + let c2 = (c1 .&. µ1) + kBitDiffPos 8 ec1 eo1 in let !_ = traceW "c2 " c2 in + + let eo2 = o2 .&. µ2 in let !_ = traceW "eo2" eo2 in + let ec2 = ((c2 .&. µ2) .<. 4) .>. 4 in let !_ = traceW "ec2" ec2 in + let o3 = (((o2 .&. µ2) .<. 4) .>. 4) + kBitDiffPos 8 eo2 ec2 in let !_ = traceW "o3 " o3 in + let c3 = (c2 .&. µ2) + kBitDiffPos 8 ec2 eo2 in let !_ = traceW "c3 " c3 in + + let eo3 = o3 .&. µ3 in let !_ = traceW "eo3" eo3 in + let ec3 = ((c3 .&. µ3) .<. 8) .>. 8 in let !_ = traceW "ec3" ec3 in + let o4 = (((o3 .&. µ3) .<. 8) .>. 8) + kBitDiffPos 8 eo3 ec3 in let !_ = traceW "o4 " o4 in + let c4 = (c3 .&. µ3) + kBitDiffPos 8 ec3 eo3 in let !_ = traceW "c4 " c4 in + + let eo4 = o4 .&. µ4 in let !_ = traceW "eo4" eo4 in + let ec4 = ((c4 .&. µ4) .<. 16) .>. 16 in let !_ = traceW "ec4" ec4 in + let o5 = (((o4 .&. µ4) .<. 16) .>. 16) + kBitDiffPos 8 eo4 ec4 in let !_ = traceW "o5 " o5 in + let c5 = (c4 .&. µ4) + kBitDiffPos 8 ec4 eo4 in let !_ = traceW "c5 " c5 in + + let eo5 = o5 .&. µ5 in let !_ = traceW "eo5" eo5 in + let ec5 = ((c5 .&. µ5) .<. 32) .>. 32 in let !_ = traceW "ec5" ec5 in + let o6 = (((o5 .&. µ5) .<. 32) .>. 32) + kBitDiffPos 8 eo5 ec5 in let !_ = traceW "o6 " o6 in + let c6 = (c5 .&. µ5) + kBitDiffPos 8 ec5 eo5 in let !_ = traceW "c6 " c6 in + + (o6, c6) + +-- µµ0 :: Word8 +-- µµ0 = 0x55 + +µµ1 :: Word8 +µµ1 = 0x33 + +µµ2 :: Word8 +µµ2 = 0x0F + +hh :: Int -> Word8 +hh 2 = 0xaa +hh 4 = 0x88 +hh 8 = 0x80 +hh 16 = 0x80 +hh 32 = 0x80 +hh 64 = 0x80 +hh k = error ("Invalid h k where k = " ++ show k) +{-# INLINE hh #-} + +kkBitDiff :: Int -> Word8 -> Word8 -> Word8 +kkBitDiff k x y = ((x .|. hh k) - (y .&. comp (hh k))) .^. ((x .^. comp y) .&. hh k) +{-# INLINE kkBitDiff #-} + +kkBitDiffSimple :: Int -> Word8 -> Word8 -> Word8 +kkBitDiffSimple k x y = ((x .|. hh k) - y) .^. hh k +{-# INLINE kkBitDiffSimple #-} + +kkBitDiffPos :: Int -> Word8 -> Word8 -> Word8 +kkBitDiffPos k x y = let d = kkBitDiff k x y in d .&. kkBitDiff k (d .>. fromIntegral (k - 1)) 1 +{-# INLINE kkBitDiffPos #-} + +showPadded :: Show a => Int -> a -> String +showPadded n a = reverse (take n (reverse (show a) ++ [' ', ' ' ..])) + +traceWW :: String -> Word8 -> Word8 +traceWW s w = trace (s ++ ": " ++ show (BitShown w) ++ " : " ++ showPadded 3 w ++ ", " ++ showPadded 3 (fromIntegral w :: Int8)) w + +(.>+.) :: Word8 -> Int -> Word8 +(.>+.) w n = fromIntegral ((fromIntegral w :: Int8) `DB.shift` (-n)) + +-- import qualified Data.Vector.Storable as DVS +-- import HaskellWorks.Data.Bits.FromBitTextByteString +-- import Data.Word +-- import HaskellWorks.Data.BalancedParens.Broadword + +ocCalc8 :: Word8 -> Word8 -> Word8 +ocCalc8 p x = + let b0 = x .&. 0x55 in let !_ = traceWW "b0 " b0 in + let b1 = (x .&. 0xAA) .>. 1 in let !_ = traceWW "b1 " b1 in + let ll = (b0 .^. b1) .&. b1 in let !_ = traceWW "ll " ll in + let o1 = (b0 .&. b1) .<. 1 .|. ll in let !_ = traceWW "o1 " o1 in + let c1 = ((b0 .|. b1) .^. 0x55) .<. 1 .|. ll in let !_ = traceWW "c1 " c1 in + + -- arithmetic operators come first, ordered in the standard way + -- followed by shifts + -- .&. + -- .^. + -- .|. + let eo1 = o1 .&. µµ1 in let !_ = traceWW "eo1" eo1 in + let ec1 = (c1 .&. (µµ1 .<. 2)) .>. 2 in let !_ = traceWW "ec1" ec1 in + let o2 = ((o1 .&. (µµ1 .<. 2)) .>. 2) + kkBitDiffPos 4 eo1 ec1 in let !_ = traceWW "o2 " o2 in -- <- Should this be 8 or 4? + let !_ = traceWW "xxx" (kkBitDiffPos 4 ec1 eo1) in + let !_ = traceWW "yyy" (c1 .&. µµ1) in + let c2 = (c1 .&. µµ1) + kkBitDiffPos 4 ec1 eo1 in let !_ = traceWW "c2 " c2 in + + let eo2 = o2 .&. µµ2 in let !_ = traceWW "eo2" eo2 in + let ec2 = (c2 .&. (µµ2 .<. 4)) .>. 4 in let !_ = traceWW "ec2" ec2 in + let o3 = ((o2 .&. (µµ2 .<. 4)) .>. 4) + kkBitDiffPos 8 eo2 ec2 in let !_ = traceWW "o3 " o3 in + let c3 = (c2 .&. µµ2) + kkBitDiffPos 8 ec2 eo2 in let !_ = traceWW "c3 " c3 in + + let nnn = ((c2 .>. 0) .&. 15) in let !_ = traceWW "nnn" nnn in + let qqq = (((c2 .>. 0) .&. 15) - p) in let !_ = traceWW "qqq" qqq in + let bb2 = ((((c2 .>. 0) .&. 15) - p) .>+. 7) in let !_ = traceWW "bb2" bb2 in + let mm2 = bb2 .&. 15 in let !_ = traceWW "mm2" mm2 in + let pa2 = p - (c2 .&. mm2) in let !_ = traceWW "pa2" pa2 in + let pb2 = pa2 + (o2 .&. mm2) in let !_ = traceWW "pb2" pb2 in + let ss2 = 4 .&. bb2 in let !_ = traceWW "ss2" ss2 in + + -- let nnn = ((c1 .>. fromIntegral ss2) .&. 3) in let !_ = traceWW "nnn" nnn in + -- let qqq = (((c1 .>. fromIntegral ss2) .&. 3) - pb2) in let !_ = traceWW "qqq" qqq in + let bb1 = ((((c1 .>. fromIntegral ss2) .&. 3) - pb2) .>+. 7) in let !_ = traceWW "bb1" bb1 in + let mm1 = bb1 .&. 3 in let !_ = traceWW "mm1" mm1 in + let pa1 = pa2 - (c1 .&. mm1) in let !_ = traceWW "pa1" pa1 in + let pb1 = pa1 + (o1 .&. mm1) in let !_ = traceWW "pb1" pb1 in + let ss1 = ss2 + (2 .&. bb1) in let !_ = traceWW "ss1" ss1 in + + let rrr = ss1 + pb1 + (((x .>. fromIntegral ss1) .&. ((pb1 .<. 1) .|. 1)) .<. 1) in let !_ = traceWW "rrr" rrr in + + rrr diff --git a/src/HaskellWorks/Data/BalancedParens/CloseAt.hs b/src/HaskellWorks/Data/BalancedParens/CloseAt.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/CloseAt.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.CloseAt + ( CloseAt(..) + ) where + +import Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.Broadword +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Naive + +closeAt' :: TestBit a => a -> Count -> Bool +closeAt' v c = not (v .?. toPosition (c - 1)) +{-# INLINE closeAt' #-} + +class CloseAt v where + closeAt :: v -> Count -> Bool + +instance (BitLength a, TestBit a) => CloseAt (BitShown a) where + closeAt = closeAt' . bitShown + {-# INLINE closeAt #-} + +instance CloseAt [Bool] where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt (DVS.Vector Word8) where + closeAt = closeAt' + {-# INLINE closeAt #-} + + +instance CloseAt (DVS.Vector Word16) where + closeAt = closeAt' + {-# INLINE closeAt #-} + + +instance CloseAt (DVS.Vector Word32) where + closeAt = closeAt' + {-# INLINE closeAt #-} + + +instance CloseAt (DVS.Vector Word64) where + closeAt = closeAt' + {-# INLINE closeAt #-} + + +instance CloseAt Word8 where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt Word16 where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt Word32 where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt Word64 where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt (Naive Word64) where + closeAt = closeAt' + {-# INLINE closeAt #-} + +instance CloseAt (Broadword Word64) where + closeAt = closeAt . broadword + {-# INLINE closeAt #-} diff --git a/src/HaskellWorks/Data/BalancedParens/Enclose.hs b/src/HaskellWorks/Data/BalancedParens/Enclose.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/Enclose.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.Enclose + ( Enclose(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.FindOpenN +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class Enclose v where + enclose :: v -> Count -> Maybe Count + +instance (Enclose a) => Enclose (BitShown a) where + enclose = enclose . bitShown + {-# INLINE enclose #-} + +instance Enclose [Bool] where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose (DVS.Vector Word8) where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose (DVS.Vector Word16) where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose (DVS.Vector Word32) where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose (DVS.Vector Word64) where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose Word8 where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose Word16 where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose Word32 where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose Word64 where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} + +instance Enclose (Naive Word64) where + enclose v = findOpenN v 1 + {-# INLINE enclose #-} diff --git a/src/HaskellWorks/Data/BalancedParens/FindClose.hs b/src/HaskellWorks/Data/BalancedParens/FindClose.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/FindClose.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.FindClose + ( FindClose(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.Broadword +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.BalancedParens.FindCloseN +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.Broadword +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class FindClose v where + findClose :: v -> Count -> Maybe Count + +instance (FindClose a) => FindClose (BitShown a) where + findClose = findClose . bitShown + {-# INLINE findClose #-} + +instance FindClose [Bool] where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose (DVS.Vector Word8) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose (DVS.Vector Word16) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose (DVS.Vector Word32) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose (DVS.Vector Word64) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose Word8 where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose Word16 where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose Word32 where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose Word64 where + findClose = findClose . Broadword + {-# INLINE findClose #-} + +instance FindClose (Naive Word64) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindClose (Broadword Word64) where + findClose (Broadword w) p = let x = w .>. (p - 1) in + case negate (x .&. 1) .&. findCloseW64 x of + 127 -> Nothing + r -> let r' = fromIntegral r + p in if r' > 64 then Nothing else Just r' + {-# INLINE findClose #-} diff --git a/src/HaskellWorks/Data/BalancedParens/FindCloseN.hs b/src/HaskellWorks/Data/BalancedParens/FindCloseN.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/FindCloseN.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.FindCloseN + ( FindCloseN(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class FindCloseN v where + findCloseN :: v -> Count -> Count -> Maybe Count + +findClose' :: (BitLength a, CloseAt a, TestBit a) => a -> Count -> Count -> Maybe Count +findClose' v c p = if 0 < p && p <= bitLength v + then if v `closeAt` p + then if c <= 1 + then Just p + else findClose' v (c - 1) (p + 1) + else findClose' v (c + 1) (p + 1) + else Nothing +{-# INLINE findClose' #-} + +instance (CloseAt a, TestBit a, BitLength a) => FindCloseN (BitShown a) where + findCloseN = findClose' . bitShown + {-# INLINE findCloseN #-} + +instance FindCloseN [Bool] where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN (DVS.Vector Word8) where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN (DVS.Vector Word16) where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN (DVS.Vector Word32) where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN (DVS.Vector Word64) where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN Word8 where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN Word16 where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN Word32 where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN Word64 where + findCloseN = findClose' + {-# INLINE findCloseN #-} + +instance FindCloseN (Naive Word64) where + findCloseN = findClose' + {-# INLINE findCloseN #-} diff --git a/src/HaskellWorks/Data/BalancedParens/FindOpen.hs b/src/HaskellWorks/Data/BalancedParens/FindOpen.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/FindOpen.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.FindOpen + ( FindOpen(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.FindOpenN +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class FindOpen v where + findOpen :: v -> Count -> Maybe Count + +instance (FindOpen a) => FindOpen (BitShown a) where + findOpen = findOpen . bitShown + {-# INLINE findOpen #-} + +instance FindOpen [Bool] where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen (DVS.Vector Word8) where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen (DVS.Vector Word16) where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen (DVS.Vector Word32) where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen (DVS.Vector Word64) where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen Word8 where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen Word16 where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen Word32 where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen Word64 where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} + +instance FindOpen (Naive Word64) where + findOpen v p = if v `openAt` p then Just p else findOpenN v 0 (p - 1) + {-# INLINE findOpen #-} diff --git a/src/HaskellWorks/Data/BalancedParens/FindOpenN.hs b/src/HaskellWorks/Data/BalancedParens/FindOpenN.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/FindOpenN.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.FindOpenN + ( FindOpenN(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class FindOpenN v where + findOpenN :: v -> Count -> Count -> Maybe Count + +findOpen' :: (BitLength a, OpenAt a, TestBit a) => a -> Count -> Count -> Maybe Count +findOpen' v c p = if 0 < p && p <= bitLength v + then if v `openAt` p + then if c == 0 + then Just p + else findOpen' v (c - 1) (p - 1) + else findOpen' v (c + 1) (p - 1) + else Nothing +{-# INLINE findOpen' #-} + +instance (BitLength a, OpenAt a, TestBit a) => FindOpenN (BitShown a) where + findOpenN = findOpen' . bitShown + {-# INLINE findOpenN #-} + +instance FindOpenN [Bool] where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN (DVS.Vector Word8) where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN (DVS.Vector Word16) where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN (DVS.Vector Word32) where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN (DVS.Vector Word64) where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN Word8 where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN Word16 where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN Word32 where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN Word64 where + findOpenN = findOpen' + {-# INLINE findOpenN #-} + +instance FindOpenN (Naive Word64) where + findOpenN = findOpen' + {-# INLINE findOpenN #-} diff --git a/src/HaskellWorks/Data/BalancedParens/NewCloseAt.hs b/src/HaskellWorks/Data/BalancedParens/NewCloseAt.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/NewCloseAt.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.NewCloseAt + ( NewCloseAt(..) + , newCloseAt' + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Positioning + +class NewCloseAt v where + newCloseAt :: v -> Count -> Bool + +newCloseAt' :: TestBit a => a -> Count -> Bool +newCloseAt' v c = not (v .?. toPosition c) +{-# INLINE newCloseAt' #-} + +instance (BitLength a, TestBit a) => NewCloseAt (BitShown a) where + newCloseAt = newCloseAt' . bitShown + {-# INLINE newCloseAt #-} + +instance NewCloseAt [Bool] where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt (DVS.Vector Word8) where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt (DVS.Vector Word16) where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt (DVS.Vector Word32) where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt (DVS.Vector Word64) where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt Word8 where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt Word16 where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt Word32 where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} + +instance NewCloseAt Word64 where + newCloseAt = newCloseAt' + {-# INLINE newCloseAt #-} diff --git a/src/HaskellWorks/Data/BalancedParens/NewOpenAt.hs b/src/HaskellWorks/Data/BalancedParens/NewOpenAt.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/NewOpenAt.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.NewOpenAt + ( NewOpenAt(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Positioning + +class NewOpenAt v where + newOpenAt :: v -> Count -> Bool + +newOpenAt' :: (BitLength a, TestBit a) => a -> Count -> Bool +newOpenAt' v c = (0 <= c && c < bitLength v) && (v .?. toPosition c) +{-# INLINE newOpenAt' #-} + +instance (BitLength a, TestBit a) => NewOpenAt (BitShown a) where + newOpenAt = newOpenAt' . bitShown + {-# INLINE newOpenAt #-} + +instance NewOpenAt [Bool] where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt (DVS.Vector Word8) where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt (DVS.Vector Word16) where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt (DVS.Vector Word32) where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt (DVS.Vector Word64) where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt Word8 where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt Word16 where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt Word32 where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} + +instance NewOpenAt Word64 where + newOpenAt = newOpenAt' + {-# INLINE newOpenAt #-} diff --git a/src/HaskellWorks/Data/BalancedParens/OpenAt.hs b/src/HaskellWorks/Data/BalancedParens/OpenAt.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/OpenAt.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.BalancedParens.OpenAt + ( OpenAt(..) + ) where + +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Bits.Broadword +import HaskellWorks.Data.Naive +import HaskellWorks.Data.Positioning + +class OpenAt v where + openAt :: v -> Count -> Bool + +openAt' :: (BitLength a, TestBit a) => a -> Count -> Bool +openAt' v c = (0 <= c && c < bitLength v) && (v .?. toPosition (c - 1)) +{-# INLINE openAt' #-} + +instance (BitLength a, TestBit a) => OpenAt (BitShown a) where + openAt = openAt' . bitShown + {-# INLINE openAt #-} + +instance OpenAt [Bool] where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (DVS.Vector Word8) where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (DVS.Vector Word16) where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (DVS.Vector Word32) where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (DVS.Vector Word64) where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt Word8 where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt Word16 where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt Word32 where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt Word64 where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (Naive Word64) where + openAt = openAt' + {-# INLINE openAt #-} + +instance OpenAt (Broadword Word64) where + openAt = openAt . broadword + {-# INLINE openAt #-} diff --git a/src/HaskellWorks/Data/BalancedParens/RangeMinMax.hs b/src/HaskellWorks/Data/BalancedParens/RangeMinMax.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/RangeMinMax.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} + +module HaskellWorks.Data.BalancedParens.RangeMinMax + ( RangeMinMax(..) + , mkRangeMinMax + ) where + +import Data.Int +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import HaskellWorks.Data.AtIndex +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.BalancedParens.Enclose +import HaskellWorks.Data.BalancedParens.FindClose +import HaskellWorks.Data.BalancedParens.FindCloseN +import HaskellWorks.Data.BalancedParens.FindOpen +import HaskellWorks.Data.BalancedParens.FindOpenN +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.BalancedParens.NewCloseAt +import HaskellWorks.Data.Bits.AllExcess.AllExcess1 +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Excess.MinMaxExcess1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.Vector.AsVector64 +import Prelude hiding (length) + +data RangeMinMax a = RangeMinMax + { rangeMinMaxBP :: !a + , rangeMinMaxL0Min :: !(DVS.Vector Int8) + , rangeMinMaxL0Max :: !(DVS.Vector Int8) + , rangeMinMaxL0Excess :: !(DVS.Vector Int8) + , rangeMinMaxL1Min :: !(DVS.Vector Int16) + , rangeMinMaxL1Max :: !(DVS.Vector Int16) + , rangeMinMaxL1Excess :: !(DVS.Vector Int16) + , rangeMinMaxL2Min :: !(DVS.Vector Int16) + , rangeMinMaxL2Max :: !(DVS.Vector Int16) + , rangeMinMaxL2Excess :: !(DVS.Vector Int16) + } + +factorL0 :: Integral a => a +factorL0 = 1 +{-# INLINE factorL0 #-} + +factorL1 :: Integral a => a +factorL1 = 32 +{-# INLINE factorL1 #-} + +factorL2 :: Integral a => a +factorL2 = 32 +{-# INLINE factorL2 #-} + +pageSizeL0 :: Integral a => a +pageSizeL0 = factorL0 +{-# INLINE pageSizeL0 #-} + +pageSizeL1 :: Integral a => a +pageSizeL1 = pageSizeL0 * factorL1 +{-# INLINE pageSizeL1 #-} + +pageSizeL2 :: Integral a => a +pageSizeL2 = pageSizeL1 * factorL2 +{-# INLINE pageSizeL2 #-} + +mkRangeMinMax :: AsVector64 a => a -> RangeMinMax a +mkRangeMinMax bp = RangeMinMax + { rangeMinMaxBP = bp + , rangeMinMaxL0Min = rmmL0Min + , rangeMinMaxL0Max = rmmL0Max + , rangeMinMaxL0Excess = dvsReword rmmL0Excess + , rangeMinMaxL1Min = rmmL1Min + , rangeMinMaxL1Max = rmmL1Max + , rangeMinMaxL1Excess = dvsReword rmmL1Excess + , rangeMinMaxL2Min = rmmL2Min + , rangeMinMaxL2Max = rmmL2Max + , rangeMinMaxL2Excess = rmmL2Excess + } + where bpv = asVector64 bp + lenBP = fromIntegral (length bpv) :: Int + lenL0 = lenBP + lenL1 = (DVS.length rmmL0Min `div` pageSizeL1) + 1 :: Int + lenL2 = (DVS.length rmmL0Min `div` pageSizeL2) + 1 :: Int + allMinMaxL0 = dvConstructNI lenL0 (\i -> if i == lenBP then (-64, -64, 0) else minMaxExcess1 (bpv !!! fromIntegral i)) + allMinMaxL1 = dvConstructNI lenL1 (\i -> minMaxExcess1 (dropTake (i * pageSizeL1) pageSizeL1 bpv)) + allMinMaxL2 = dvConstructNI lenL2 (\i -> minMaxExcess1 (dropTake (i * pageSizeL2) pageSizeL2 bpv)) + rmmL0Excess = dvsConstructNI lenL0 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL0 (-64) bpv))) :: DVS.Vector Int16 + rmmL1Excess = dvsConstructNI lenL1 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL1 (-64) bpv))) :: DVS.Vector Int16 + rmmL2Excess = dvsConstructNI lenL2 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL2 (-64) bpv))) :: DVS.Vector Int16 + rmmL0Min = dvsConstructNI lenL0 (\i -> let (minE, _, _) = allMinMaxL0 DV.! i in fromIntegral minE) + rmmL1Min = dvsConstructNI lenL1 (\i -> let (minE, _, _) = allMinMaxL1 DV.! i in fromIntegral minE) + rmmL2Min = dvsConstructNI lenL2 (\i -> let (minE, _, _) = allMinMaxL2 DV.! i in fromIntegral minE) + rmmL0Max = dvsConstructNI lenL0 (\i -> let (_, _, maxE) = allMinMaxL0 DV.! i in fromIntegral maxE) + rmmL1Max = dvsConstructNI lenL1 (\i -> let (_, _, maxE) = allMinMaxL1 DV.! i in fromIntegral maxE) + rmmL2Max = dvsConstructNI lenL2 (\i -> let (_, _, maxE) = allMinMaxL2 DV.! i in fromIntegral maxE) + +dropTake :: DVS.Storable a => Int -> Int -> DVS.Vector a -> DVS.Vector a +dropTake n o = DVS.take o . DVS.drop n +{-# INLINE dropTake #-} + +dvsReword :: (DVS.Storable a, Integral a, DVS.Storable b, Num b) => DVS.Vector a -> DVS.Vector b +dvsReword v = dvsConstructNI (DVS.length v) (\i -> fromIntegral (v DVS.! i)) +{-# INLINE dvsReword #-} + +pageFill :: DVS.Storable a => Int -> Int -> a -> DVS.Vector a -> DVS.Vector a +pageFill n s = dropTakeFill (n * s) s +{-# INLINE pageFill #-} + +dropTakeFill :: DVS.Storable a => Int -> Int -> a -> DVS.Vector a -> DVS.Vector a +dropTakeFill n o a v = let r = DVS.take o (DVS.drop n v) in + let len = DVS.length r in + if len == o then r else DVS.concat [r, DVS.fromList (replicate (o - len) a)] +{-# INLINE dropTakeFill #-} + +dvConstructNI :: Int -> (Int -> a) -> DV.Vector a +dvConstructNI n g = DV.constructN n (g . DV.length) +{-# INLINE dvConstructNI #-} + +dvsConstructNI :: DVS.Storable a => Int -> (Int -> a) -> DVS.Vector a +dvsConstructNI n g = DVS.constructN n (g . DVS.length) +{-# INLINE dvsConstructNI #-} + +data FindState = FindBP + | FindL0 | FindFromL0 + | FindL1 | FindFromL1 + | FindL2 | FindFromL2 + +rmm2FindClose :: (BitLength a, NewCloseAt a) => RangeMinMax a -> Int -> Count -> FindState -> Maybe Count +rmm2FindClose v s p FindBP = if v `newCloseAt` p + then if s <= 1 + then Just p + else rmm2FindClose v (s - 1) (p + 1) FindFromL0 + else rmm2FindClose v (s + 1) (p + 1) FindFromL0 +rmm2FindClose v s p FindL0 = + let i = p `div` 64 in + let mins = rangeMinMaxL0Min v in + let minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindBP + else if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMaxL0Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + 64) FindFromL0 +rmm2FindClose v s p FindL1 = + let !i = p `div` (64 * pageSizeL1) in + let !mins = rangeMinMaxL1Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL0 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMaxL1Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL1)) FindFromL1 + else Nothing +rmm2FindClose v s p FindL2 = + let !i = p `div` (64 * pageSizeL2) in + let !mins = rangeMinMaxL2Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL1 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMaxL2Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL2)) FindFromL2 + else Nothing +rmm2FindClose v s p FindFromL0 + | p `mod` 64 == 0 = rmm2FindClose v s p FindFromL1 + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindBP + | otherwise = Nothing +rmm2FindClose v s p FindFromL1 + | p `mod` (64 * pageSizeL1) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindFromL2 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL0 + | otherwise = Nothing +rmm2FindClose v s p FindFromL2 + | p `mod` (64 * pageSizeL2) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindL2 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL1 + | otherwise = Nothing +{-# INLINE rmm2FindClose #-} + +instance TestBit a => TestBit (RangeMinMax a) where + (.?.) = (.?.) . rangeMinMaxBP + {-# INLINE (.?.) #-} + +instance Rank1 a => Rank1 (RangeMinMax a) where + rank1 = rank1 . rangeMinMaxBP + {-# INLINE rank1 #-} + +instance Rank0 a => Rank0 (RangeMinMax a) where + rank0 = rank0 . rangeMinMaxBP + {-# INLINE rank0 #-} + +instance BitLength a => BitLength (RangeMinMax a) where + bitLength = bitLength . rangeMinMaxBP + {-# INLINE bitLength #-} + +instance OpenAt a => OpenAt (RangeMinMax a) where + openAt = openAt . rangeMinMaxBP + {-# INLINE openAt #-} + +instance CloseAt a => CloseAt (RangeMinMax a) where + closeAt = closeAt . rangeMinMaxBP + {-# INLINE closeAt #-} + +instance NewCloseAt a => NewCloseAt (RangeMinMax a) where + newCloseAt = newCloseAt . rangeMinMaxBP + {-# INLINE newCloseAt #-} + +instance FindOpenN a => FindOpenN (RangeMinMax a) where + findOpenN = findOpenN . rangeMinMaxBP + {-# INLINE findOpenN #-} + +instance (BitLength a, NewCloseAt a) => FindCloseN (RangeMinMax a) where + findCloseN v s p = (+ 1) `fmap` rmm2FindClose v (fromIntegral s) (p - 1) FindFromL0 + {-# INLINE findCloseN #-} + +instance (BitLength a, CloseAt a, NewCloseAt a, FindCloseN a) => FindClose (RangeMinMax a) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindOpen (RangeMinMax a) where + findOpen = undefined + {-# INLINE findOpen #-} + +instance Enclose (RangeMinMax a) where + enclose = undefined + {-# INLINE enclose #-} + +instance (BitLength a, NewCloseAt a, CloseAt a, OpenAt a, FindCloseN a) => BalancedParens (RangeMinMax a) diff --git a/src/HaskellWorks/Data/BalancedParens/RangeMinMax2.hs b/src/HaskellWorks/Data/BalancedParens/RangeMinMax2.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/RangeMinMax2.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} + +module HaskellWorks.Data.BalancedParens.RangeMinMax2 + ( RangeMinMax2(..) + , mkRangeMinMax2 + , genMin + , genMax + ) where + +import Data.Int +import qualified Data.Vector as DV +import qualified Data.Vector.Storable as DVS +import HaskellWorks.Data.AtIndex +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.BalancedParens.Enclose +import HaskellWorks.Data.BalancedParens.FindClose +import HaskellWorks.Data.BalancedParens.FindCloseN +import HaskellWorks.Data.BalancedParens.FindOpen +import HaskellWorks.Data.BalancedParens.FindOpenN +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.BalancedParens.NewCloseAt +import HaskellWorks.Data.Bits.AllExcess.AllExcess1 +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Excess.MinMaxExcess1 +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.Vector.AsVector64 +import Prelude hiding (length) + +data RangeMinMax2 a = RangeMinMax2 + { rangeMinMax2BP :: !a + , rangeMinMax2L0Min :: !(DVS.Vector Int8) + , rangeMinMax2L0Max :: !(DVS.Vector Int8) + , rangeMinMax2L0Excess :: !(DVS.Vector Int8) + , rangeMinMax2L1Min :: !(DVS.Vector Int16) + , rangeMinMax2L1Max :: !(DVS.Vector Int16) + , rangeMinMax2L1Excess :: !(DVS.Vector Int16) + , rangeMinMax2L2Min :: !(DVS.Vector Int16) + , rangeMinMax2L2Max :: !(DVS.Vector Int16) + , rangeMinMax2L2Excess :: !(DVS.Vector Int16) + , rangeMinMax2L3Min :: !(DVS.Vector Int16) + , rangeMinMax2L3Max :: !(DVS.Vector Int16) + , rangeMinMax2L3Excess :: !(DVS.Vector Int16) + , rangeMinMax2L4Min :: !(DVS.Vector Int16) + , rangeMinMax2L4Max :: !(DVS.Vector Int16) + , rangeMinMax2L4Excess :: !(DVS.Vector Int16) + } + +factorL0 :: Integral a => a +factorL0 = 1 +{-# INLINE factorL0 #-} + +factorL1 :: Integral a => a +factorL1 = 32 +{-# INLINE factorL1 #-} + +factorL2 :: Integral a => a +factorL2 = 32 +{-# INLINE factorL2 #-} + +factorL3 :: Integral a => a +factorL3 = 32 +{-# INLINE factorL3 #-} + +factorL4 :: Integral a => a +factorL4 = 32 +{-# INLINE factorL4 #-} + +pageSizeL0 :: Integral a => a +pageSizeL0 = factorL0 +{-# INLINE pageSizeL0 #-} + +pageSizeL1 :: Integral a => a +pageSizeL1 = pageSizeL0 * factorL1 +{-# INLINE pageSizeL1 #-} + +pageSizeL2 :: Integral a => a +pageSizeL2 = pageSizeL1 * factorL2 +{-# INLINE pageSizeL2 #-} + +pageSizeL3 :: Integral a => a +pageSizeL3 = pageSizeL2 * factorL3 +{-# INLINE pageSizeL3 #-} + +pageSizeL4 :: Integral a => a +pageSizeL4 = pageSizeL3 * factorL4 +{-# INLINE pageSizeL4 #-} + +mkRangeMinMax2 :: AsVector64 a => a -> RangeMinMax2 a +mkRangeMinMax2 bp = RangeMinMax2 + { rangeMinMax2BP = bp + , rangeMinMax2L0Min = dvsReword rmmL0Min + , rangeMinMax2L0Max = dvsReword rmmL0Max + , rangeMinMax2L0Excess = dvsReword rmmL0Excess + , rangeMinMax2L1Min = rmmL1Min + , rangeMinMax2L1Max = rmmL1Max + , rangeMinMax2L1Excess = rmmL1Excess + , rangeMinMax2L2Min = rmmL2Min + , rangeMinMax2L2Max = rmmL2Max + , rangeMinMax2L2Excess = rmmL2Excess + , rangeMinMax2L3Min = rmmL3Min + , rangeMinMax2L3Max = rmmL3Max + , rangeMinMax2L3Excess = rmmL3Excess + , rangeMinMax2L4Min = rmmL4Min + , rangeMinMax2L4Max = rmmL4Max + , rangeMinMax2L4Excess = rmmL4Excess + } + where bpv = asVector64 bp + lenBP = fromIntegral (length bpv) :: Int + lenL0 = lenBP + lenL1 = (DVS.length rmmL0Min `div` pageSizeL1) + 1 :: Int + lenL2 = (DVS.length rmmL0Min `div` pageSizeL2) + 1 :: Int + lenL3 = (DVS.length rmmL0Min `div` pageSizeL3) + 1 :: Int + lenL4 = (DVS.length rmmL0Min `div` pageSizeL4) + 1 :: Int + allMinMaxL0 = dvConstructNI lenL0 (\i -> if i == lenBP then (-64, -64, 0) else minMaxExcess1 (bpv !!! fromIntegral i)) + rmmL0Excess = dvsConstructNI lenL0 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL0 (-64) bpv))) :: DVS.Vector Int16 + rmmL1Excess = dvsConstructNI lenL1 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL1 (-64) bpv))) :: DVS.Vector Int16 + rmmL2Excess = dvsConstructNI lenL2 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL2 (-64) bpv))) :: DVS.Vector Int16 + rmmL3Excess = dvsConstructNI lenL3 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL3 (-64) bpv))) :: DVS.Vector Int16 + rmmL4Excess = dvsConstructNI lenL4 (\i -> fromIntegral (allExcess1 (pageFill i pageSizeL4 (-64) bpv))) :: DVS.Vector Int16 + rmmL0Min = dvsConstructNI lenL0 (\i -> let (minE, _, _) = allMinMaxL0 DV.! i in fromIntegral minE) :: DVS.Vector Int16 + rmmL1Min = dvsConstructNI lenL1 (\i -> genMin 0 (pageFill i factorL1 0 rmmL0Min) (pageFill i factorL1 0 rmmL0Excess)) + rmmL2Min = dvsConstructNI lenL2 (\i -> genMin 0 (pageFill i factorL2 0 rmmL1Min) (pageFill i factorL2 0 rmmL1Excess)) + rmmL3Min = dvsConstructNI lenL3 (\i -> genMin 0 (pageFill i factorL3 0 rmmL2Min) (pageFill i factorL3 0 rmmL2Excess)) + rmmL4Min = dvsConstructNI lenL4 (\i -> genMin 0 (pageFill i factorL4 0 rmmL3Min) (pageFill i factorL4 0 rmmL3Excess)) + rmmL0Max = dvsConstructNI lenL0 (\i -> let (_, _, maxE) = allMinMaxL0 DV.! i in fromIntegral maxE) :: DVS.Vector Int16 + rmmL1Max = dvsConstructNI lenL1 (\i -> genMax 0 (pageFill i factorL1 0 rmmL0Max) (pageFill i factorL1 0 rmmL0Excess)) + rmmL2Max = dvsConstructNI lenL2 (\i -> genMax 0 (pageFill i factorL2 0 rmmL1Max) (pageFill i factorL2 0 rmmL1Excess)) + rmmL3Max = dvsConstructNI lenL3 (\i -> genMax 0 (pageFill i factorL3 0 rmmL2Max) (pageFill i factorL3 0 rmmL2Excess)) + rmmL4Max = dvsConstructNI lenL4 (\i -> genMax 0 (pageFill i factorL4 0 rmmL3Max) (pageFill i factorL4 0 rmmL3Excess)) + +genMin :: (Integral a, DVS.Storable a) => a -> DVS.Vector a -> DVS.Vector a -> a +genMin mL mins excesses = if not (DVS.null mins) || not (DVS.null excesses) + then genMin (dvsLastOrZero mins `min` (mL + dvsLastOrZero excesses)) (DVS.init mins) (DVS.init excesses) + else mL + +genMax :: (Integral a, DVS.Storable a) => a -> DVS.Vector a -> DVS.Vector a -> a +genMax mL maxs excesses = if not (DVS.null maxs) || not (DVS.null excesses) + then genMax (dvsLastOrZero maxs `max` (mL + dvsLastOrZero excesses)) (DVS.init maxs) (DVS.init excesses) + else mL + +pageFill :: DVS.Storable a => Int -> Int -> a -> DVS.Vector a -> DVS.Vector a +pageFill n s = dropTakeFill (n * s) s +{-# INLINE pageFill #-} + +dropTakeFill :: DVS.Storable a => Int -> Int -> a -> DVS.Vector a -> DVS.Vector a +dropTakeFill n s a v = let r = DVS.take s (DVS.drop n v) in + let rLen = DVS.length r in + if rLen == s then r else DVS.concat [r, DVS.replicate (s - rLen) a] +{-# INLINE dropTakeFill #-} + +dvConstructNI :: Int -> (Int -> a) -> DV.Vector a +dvConstructNI n g = DV.constructN n (g . DV.length) +{-# INLINE dvConstructNI #-} + +dvsConstructNI :: DVS.Storable a => Int -> (Int -> a) -> DVS.Vector a +dvsConstructNI n g = DVS.constructN n (g . DVS.length) +{-# INLINE dvsConstructNI #-} + +dvsReword :: (DVS.Storable a, Integral a, DVS.Storable b, Num b) => DVS.Vector a -> DVS.Vector b +dvsReword v = dvsConstructNI (DVS.length v) (\i -> fromIntegral (v DVS.! i)) +{-# INLINE dvsReword #-} + +dvsLastOrZero :: (DVS.Storable a, Integral a) => DVS.Vector a -> a +dvsLastOrZero v = if not (DVS.null v) then DVS.last v else 0 +{-# INLINE dvsLastOrZero #-} + +data FindState = FindBP + | FindL0 | FindFromL0 + | FindL1 | FindFromL1 + | FindL2 | FindFromL2 + | FindL3 | FindFromL3 + | FindL4 | FindFromL4 + +rmm2FindClose :: (BitLength a, NewCloseAt a) => RangeMinMax2 a -> Int -> Count -> FindState -> Maybe Count +rmm2FindClose v s p FindBP = if v `newCloseAt` p + then if s <= 1 + then Just p + else rmm2FindClose v (s - 1) (p + 1) FindFromL0 + else rmm2FindClose v (s + 1) (p + 1) FindFromL0 +rmm2FindClose v s p FindL0 = + let i = p `div` 64 in + let mins = rangeMinMax2L0Min v in + let minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindBP + else if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMax2L0Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + 64) FindFromL0 +rmm2FindClose v s p FindL1 = + let !i = p `div` (64 * pageSizeL1) in + let !mins = rangeMinMax2L1Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL0 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMax2L1Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL1)) FindFromL1 + else Nothing +rmm2FindClose v s p FindL2 = + let !i = p `div` (64 * pageSizeL2) in + let !mins = rangeMinMax2L2Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL1 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMax2L2Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL2)) FindFromL2 + else Nothing +rmm2FindClose v s p FindL3 = + let !i = p `div` (64 * pageSizeL3) in + let !mins = rangeMinMax2L3Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL2 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMax2L3Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL3)) FindFromL3 + else Nothing +rmm2FindClose v s p FindL4 = + let !i = p `div` (64 * pageSizeL4) in + let !mins = rangeMinMax2L4Min v in + let !minE = fromIntegral (mins !!! fromIntegral i) :: Int in + if fromIntegral s + minE <= 0 + then rmm2FindClose v s p FindL3 + else if 0 <= p && p < bitLength v + then if v `newCloseAt` p && s <= 1 + then Just p + else let excesses = rangeMinMax2L4Excess v in + let excess = fromIntegral (excesses !!! fromIntegral i) :: Int in + rmm2FindClose v (fromIntegral (excess + fromIntegral s)) (p + (64 * pageSizeL4)) FindFromL4 + else Nothing +rmm2FindClose v s p FindFromL0 + | p `mod` 64 == 0 = rmm2FindClose v s p FindFromL1 + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindBP + | otherwise = Nothing +rmm2FindClose v s p FindFromL1 + | p `mod` (64 * pageSizeL1) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindFromL2 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL0 + | otherwise = Nothing +rmm2FindClose v s p FindFromL2 + | p `mod` (64 * pageSizeL2) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindFromL3 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL1 + | otherwise = Nothing +rmm2FindClose v s p FindFromL3 + | p `mod` (64 * pageSizeL3) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindFromL4 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL2 + | otherwise = Nothing +rmm2FindClose v s p FindFromL4 + | p `mod` (64 * pageSizeL4) == 0 = if 0 <= p && p < bitLength v then rmm2FindClose v s p FindL4 else Nothing + | 0 <= p && p < bitLength v = rmm2FindClose v s p FindL3 + | otherwise = Nothing +{-# INLINE rmm2FindClose #-} + +instance TestBit a => TestBit (RangeMinMax2 a) where + (.?.) = (.?.) . rangeMinMax2BP + {-# INLINE (.?.) #-} + +instance Rank1 a => Rank1 (RangeMinMax2 a) where + rank1 = rank1 . rangeMinMax2BP + {-# INLINE rank1 #-} + +instance Rank0 a => Rank0 (RangeMinMax2 a) where + rank0 = rank0 . rangeMinMax2BP + {-# INLINE rank0 #-} + +instance BitLength a => BitLength (RangeMinMax2 a) where + bitLength = bitLength . rangeMinMax2BP + {-# INLINE bitLength #-} + +instance OpenAt a => OpenAt (RangeMinMax2 a) where + openAt = openAt . rangeMinMax2BP + {-# INLINE openAt #-} + +instance CloseAt a => CloseAt (RangeMinMax2 a) where + closeAt = closeAt . rangeMinMax2BP + {-# INLINE closeAt #-} + +instance NewCloseAt a => NewCloseAt (RangeMinMax2 a) where + newCloseAt = newCloseAt . rangeMinMax2BP + {-# INLINE newCloseAt #-} + +instance FindOpenN a => FindOpenN (RangeMinMax2 a) where + findOpenN = findOpenN . rangeMinMax2BP + {-# INLINE findOpenN #-} + +instance (BitLength a, FindCloseN a, NewCloseAt a) => FindCloseN (RangeMinMax2 a) where + findCloseN v s p = (+ 1) `fmap` rmm2FindClose v (fromIntegral s) (p - 1) FindFromL0 + {-# INLINE findCloseN #-} + +instance (BitLength a, NewCloseAt a, CloseAt a, FindCloseN a) => FindClose (RangeMinMax2 a) where + findClose v p = if v `closeAt` p then Just p else findCloseN v 1 (p + 1) + {-# INLINE findClose #-} + +instance FindOpen (RangeMinMax2 a) where + findOpen = undefined + {-# INLINE findOpen #-} + +instance Enclose (RangeMinMax2 a) where + enclose = undefined + {-# INLINE enclose #-} + +instance (BitLength a, NewCloseAt a, CloseAt a, OpenAt a, FindCloseN a) => BalancedParens (RangeMinMax2 a) diff --git a/src/HaskellWorks/Data/BalancedParens/Simple.hs b/src/HaskellWorks/Data/BalancedParens/Simple.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/BalancedParens/Simple.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module HaskellWorks.Data.BalancedParens.Simple + ( SimpleBalancedParens(..) + ) where + +import Control.Monad +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.CloseAt +import HaskellWorks.Data.BalancedParens.Enclose +import HaskellWorks.Data.BalancedParens.FindClose +import HaskellWorks.Data.BalancedParens.FindOpen +import HaskellWorks.Data.BalancedParens.OpenAt +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.BitWise +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 Prelude as P + +newtype SimpleBalancedParens a = SimpleBalancedParens a + deriving (BalancedParens, FindOpen, FindClose, Enclose, OpenAt, CloseAt, BitLength, BitShow, Eq, Rank0, Rank1, Select0, Select1, TestBit) + +instance Functor SimpleBalancedParens where + fmap f (SimpleBalancedParens a) = SimpleBalancedParens (f a) + {-# INLINABLE fmap #-} + +instance BitShow a => Show (SimpleBalancedParens a) where + show = bitShow diff --git a/test/HaskellWorks/Data/BalancedParens/Internal/BroadwordSpec.hs b/test/HaskellWorks/Data/BalancedParens/Internal/BroadwordSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/BalancedParens/Internal/BroadwordSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.BalancedParens.Internal.BroadwordSpec where + +-- import Data.Maybe +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens.FindClose +-- import HaskellWorks.Data.Bits.BitLength +-- import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.Broadword +import HaskellWorks.Data.Bits.FromBitTextByteString +import HaskellWorks.Data.Positioning +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} + +newtype ShowVector a = ShowVector a deriving (Eq, BitShow) + +instance BitShow a => Show (ShowVector a) where + show = bitShow + +spec :: Spec +spec = describe "HaskellWorks.Data.BalancedParens.BroadwordSpec" $ do + describe "For (()(()())) 1101101000" $ do + let bs = Broadword (91 :: Word64) + it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + -- it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + -- it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + -- it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + -- it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + -- describe "For (()(()())) 1101101000" $ do + -- let bs = Broadword (fromJust (bitRead "1101101000") :: [Bool]) + -- it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + -- it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + -- it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + -- it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + -- it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + -- it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + -- it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + -- it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + -- it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + -- it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + -- it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + -- it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + -- it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + -- it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + -- it "firstChild 1" $ firstChild bs 1 `shouldBe` Just 2 + -- it "firstChild 4" $ firstChild bs 4 `shouldBe` Just 5 + -- it "nextSibling 2" $ nextSibling bs 2 `shouldBe` Just 4 + -- it "nextSibling 5" $ nextSibling bs 5 `shouldBe` Just 7 + -- it "parent 2" $ parent bs 2 `shouldBe` Just 1 + -- it "parent 5" $ parent bs 5 `shouldBe` Just 4 + -- it "depth 1" $ depth bs 1 `shouldBe` Just 1 + -- it "depth 2" $ depth bs 2 `shouldBe` Just 2 + -- it "depth 3" $ depth bs 3 `shouldBe` Just 2 + -- it "depth 4" $ depth bs 4 `shouldBe` Just 2 + -- it "depth 5" $ depth bs 5 `shouldBe` Just 3 + -- it "depth 6" $ depth bs 6 `shouldBe` Just 3 + -- it "depth 7" $ depth bs 7 `shouldBe` Just 3 + -- it "depth 8" $ depth bs 8 `shouldBe` Just 3 + -- it "depth 9" $ depth bs 9 `shouldBe` Just 2 + -- it "depth 10" $ depth bs 10 `shouldBe` Just 1 + -- it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` Just 5 + -- it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` Just 1 + -- it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` Just 0 + -- it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` Just 3 + -- it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` Just 1 + -- it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` Just 0 + -- it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` Just 1 + -- it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` Just 0 + -- it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` Just 0 + -- it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` Just 0 + describe "For (()(()())) 11011010 00000000 :: DVS.Vector Word8" $ do + let bs = Broadword (DVS.head (fromBitTextByteString "11011010 00000000") :: Word64) + it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + -- it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + -- it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + -- it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + -- it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + -- it "firstChild 1" $ firstChild bs 1 `shouldBe` Just 2 + -- it "firstChild 4" $ firstChild bs 4 `shouldBe` Just 5 + -- it "nextSibling 2" $ nextSibling bs 2 `shouldBe` Just 4 + -- it "nextSibling 5" $ nextSibling bs 5 `shouldBe` Just 7 + -- it "parent 2" $ parent bs 2 `shouldBe` Just 1 + -- it "parent 5" $ parent bs 5 `shouldBe` Just 4 + -- it "depth 1" $ depth bs 1 `shouldBe` Just 1 + -- it "depth 2" $ depth bs 2 `shouldBe` Just 2 + -- it "depth 3" $ depth bs 3 `shouldBe` Just 2 + -- it "depth 4" $ depth bs 4 `shouldBe` Just 2 + -- it "depth 5" $ depth bs 5 `shouldBe` Just 3 + -- it "depth 6" $ depth bs 6 `shouldBe` Just 3 + -- it "depth 7" $ depth bs 7 `shouldBe` Just 3 + -- it "depth 8" $ depth bs 8 `shouldBe` Just 3 + -- it "depth 9" $ depth bs 9 `shouldBe` Just 2 + -- it "depth 10" $ depth bs 10 `shouldBe` Just 1 + -- it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` Just 5 + -- it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` Just 1 + -- it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` Just 0 + -- it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` Just 3 + -- it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` Just 1 + -- it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` Just 0 + -- it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` Just 1 + -- it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` Just 0 + -- it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` Just 0 + -- it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` Just 0 + -- describe "Does not suffer exceptions" $ do + -- it "when calling nextSibling from valid locations" $ do + -- forAll (vectorSizedBetween 1 64) $ \(ShowVector v) -> do + -- [nextSibling v p | p <- [1..bitLength v]] `shouldBe` [nextSibling v p | p <- [1..bitLength v]] + it "Broadword findClose should behave the same as Naive findClose" $ do + property $ \(w :: Word64) -> + forAll (choose (1, 64 :: Count)) $ \p -> + findClose w p == findClose (Broadword w) p diff --git a/test/HaskellWorks/Data/BalancedParens/RangeMinMax2Spec.hs b/test/HaskellWorks/Data/BalancedParens/RangeMinMax2Spec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/BalancedParens/RangeMinMax2Spec.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.BalancedParens.RangeMinMax2Spec where + +import qualified Data.Vector.Storable as DVS +import Data.Word +-- import HaskellWorks.Data.BalancedParens +-- import HaskellWorks.Data.BalancedParens.RangeMinMax +-- import HaskellWorks.Data.BalancedParens.RangeMinMax2 +-- import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShow +-- import HaskellWorks.Data.Bits.FromBitTextByteString +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} + +newtype ShowVector a = ShowVector a deriving (Eq, BitShow) + +instance BitShow a => Show (ShowVector a) where + show = bitShow + +vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64)) +vectorSizedBetween a b = do + n <- choose (a, b) + xs <- sequence [ arbitrary | _ <- [1 .. n] ] + return $ ShowVector (DVS.fromList xs) + +maxVectorSize :: Int +maxVectorSize = 16384 +{-# INLINE maxVectorSize #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.BalancedParens.RangeMinMaxSpec2" $ do + it "Skip tests" $ do + True `shouldBe` True + -- it "For a simple bit string can find close" $ do + -- let v = fromBitTextByteString "11101111 10100101 01111110 10110010 10111011 10111011 00011111 11011100" :: DVS.Vector Word64 + -- let !rmm = mkRangeMinMax v + -- findClose rmm 61 `shouldBe` findClose v 61 + -- it "findClose should return the same result" $ do + -- forAll (vectorSizedBetween 1 4) $ \(ShowVector v) -> do + -- let !rmm = mkRangeMinMax v + -- let len = bitLength v + -- [findClose rmm i | i <- [1..len]] `shouldBe `[findClose v i | i <- [1..len]] + -- it "findClose should return the same result over all counts" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- forAll (choose (1, bitLength v)) $ \p -> do + -- let !rmm = mkRangeMinMax v + -- findClose rmm p `shouldBe` findClose v p + -- it "nextSibling should return the same result" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm = mkRangeMinMax v + -- nextSibling rmm 0 `shouldBe` nextSibling v 0 + -- it "nextSibling should return the same result over all counts" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- forAll (choose (1, bitLength v)) $ \p -> do + -- let !rmm = mkRangeMinMax v + -- nextSibling rmm p `shouldBe` nextSibling v p + -- it "Pass" $ do + -- True `shouldBe` True + -- it "rangeMinMaxBP should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2BP rmm2 `shouldBe` rangeMinMaxBP rmm1 + -- it "rangeMinMaxL0Excess should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L0Excess rmm2 `shouldBe` rangeMinMaxL0Excess rmm1 + -- it "rangeMinMaxL0Min should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L0Min rmm2 `shouldBe` rangeMinMaxL0Min rmm1 + -- it "rangeMinMaxL0Max should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L0Max rmm2 `shouldBe` rangeMinMaxL0Max rmm1 + -- it "rangeMinMaxL1Min should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L1Min rmm2 `shouldBe` rangeMinMaxL1Min rmm1 + -- it "rangeMinMaxL1Max should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L1Max rmm2 `shouldBe` rangeMinMaxL1Max rmm1 + -- it "rangeMinMaxL1Excess should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L1Excess rmm2 `shouldBe` rangeMinMaxL1Excess rmm1 + -- it "rangeMinMaxL2Min should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L2Min rmm2 `shouldBe` rangeMinMaxL2Min rmm1 + -- it "rangeMinMaxL2Max should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L2Max rmm2 `shouldBe` rangeMinMaxL2Max rmm1 + -- it "rangeMinMaxL2Excess should match" $ do + -- forAll (vectorSizedBetween 1 maxVectorSize) $ \(ShowVector v) -> do + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- rangeMinMax2L2Excess rmm2 `shouldBe` rangeMinMaxL2Excess rmm1 + -- describe "For example long bit string" $ do + -- let v = fromBitTextByteString " \ + -- \ 01101101 01111100 10011111 01100101 11111100 01101111 00000000 00000000 10001010 11000000 01000010 01010010 01001101 01000101 00000000 00000000 \ + -- \ " :: DVS.Vector Word64 + -- let !rmm1 = mkRangeMinMax v + -- let !rmm2 = mkRangeMinMax2 v + -- it "l0 max matches" $ do + -- rangeMinMax2L0Max rmm2 `shouldBe` rangeMinMaxL0Max rmm1 + -- it "l1 max matches" $ do + -- rangeMinMax2L1Max rmm2 `shouldBe` rangeMinMaxL1Max rmm1 + -- it "l2 max matches" $ do + -- rangeMinMax2L2Max rmm2 `shouldBe` rangeMinMaxL2Max rmm1 + -- it "l0 min matches" $ do + -- rangeMinMax2L0Min rmm2 `shouldBe` rangeMinMaxL0Min rmm1 + -- it "l1 min matches" $ do + -- rangeMinMax2L1Min rmm2 `shouldBe` rangeMinMaxL1Min rmm1 + -- it "l2 min matches" $ do + -- putStrLn $ "--> data: " ++ show (BitShown (DVS.take 80 v)) + -- putStrLn $ "--> rangeMinMaxAL0Min: " ++ show (DVS.take 80 (rangeMinMaxL0Min rmm1)) + -- putStrLn $ "--> rangeMinMaxAL0Max: " ++ show (DVS.take 80 (rangeMinMaxL0Max rmm1)) + -- putStrLn $ "--> rangeMinMaxAL0Excess: " ++ show (DVS.take 80 (rangeMinMaxL0Excess rmm1)) + -- putStrLn $ "--> rangeMinMaxBL0Min: " ++ show (DVS.take 80 (rangeMinMax2L0Min rmm2)) + -- putStrLn $ "--> rangeMinMaxBL0Max: " ++ show (DVS.take 80 (rangeMinMax2L0Max rmm2)) + -- putStrLn $ "--> rangeMinMaxBL0Excess: " ++ show (DVS.take 80 (rangeMinMax2L0Excess rmm2)) + -- putStrLn $ "--> rangeMinMaxAL1Min: " ++ show (DVS.take 80 (rangeMinMaxL1Min rmm1)) + -- putStrLn $ "--> rangeMinMaxAL1Max: " ++ show (DVS.take 80 (rangeMinMaxL1Max rmm1)) + -- putStrLn $ "--> rangeMinMaxAL1Excess: " ++ show (DVS.take 80 (rangeMinMaxL1Excess rmm1)) + -- putStrLn $ "--> rangeMinMaxBL1Min: " ++ show (DVS.take 80 (rangeMinMax2L1Min rmm2)) + -- putStrLn $ "--> rangeMinMaxBL1Max: " ++ show (DVS.take 80 (rangeMinMax2L1Max rmm2)) + -- putStrLn $ "--> rangeMinMaxBL1Excess: " ++ show (DVS.take 80 (rangeMinMax2L1Excess rmm2)) + -- putStrLn $ "--> rangeMinMaxAL2Min: " ++ show (DVS.take 80 (rangeMinMaxL2Min rmm1)) + -- putStrLn $ "--> rangeMinMaxAL2Max: " ++ show (DVS.take 80 (rangeMinMaxL2Max rmm1)) + -- putStrLn $ "--> rangeMinMaxAL2Excess: " ++ show (DVS.take 80 (rangeMinMaxL2Excess rmm1)) + -- putStrLn $ "--> rangeMinMaxBL2Min: " ++ show (DVS.take 80 (rangeMinMax2L2Min rmm2)) + -- putStrLn $ "--> rangeMinMaxBL2Max: " ++ show (DVS.take 80 (rangeMinMax2L2Max rmm2)) + -- putStrLn $ "--> rangeMinMaxBL2Excess: " ++ show (DVS.take 80 (rangeMinMax2L2Excess rmm2)) + -- rangeMinMax2L2Min rmm2 `shouldBe` rangeMinMaxL2Min rmm1 diff --git a/test/HaskellWorks/Data/BalancedParens/RangeMinMaxSpec.hs b/test/HaskellWorks/Data/BalancedParens/RangeMinMaxSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/BalancedParens/RangeMinMaxSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.BalancedParens.RangeMinMaxSpec where + +import qualified Data.Vector.Storable as DVS +import Data.Word +-- import HaskellWorks.Data.BalancedParens +-- import HaskellWorks.Data.BalancedParens.RangeMinMax +-- import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitShow +-- import HaskellWorks.Data.Bits.FromBitTextByteString +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} + +newtype ShowVector a = ShowVector a deriving (Eq, BitShow) + +instance BitShow a => Show (ShowVector a) where + show = bitShow + +vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64)) +vectorSizedBetween a b = do + n <- choose (a, b) + xs <- sequence [ arbitrary | _ <- [1 .. n] ] + return $ ShowVector (DVS.fromList xs) + +factor :: Int +factor = 16384 +{-# INLINE factor #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.BalancedParens.RangeMinMaxSpec" $ do + it "Skip tests" $ do + True `shouldBe` True + -- it "For a simple bit string can find close" $ do + -- let v = fromBitTextByteString "11101111 10100101 01111110 10110010 10111011 10111011 00011111 11011100" :: DVS.Vector Word64 + -- let !rmm = mkRangeMinMax v + -- findClose rmm 61 `shouldBe` findClose v 61 + -- it "findClose should return the same result" $ do + -- forAll (vectorSizedBetween 1 4) $ \(ShowVector v) -> do + -- let !rmm = mkRangeMinMax v + -- let len = bitLength v + -- [findClose rmm i | i <- [1..len]] `shouldBe `[findClose v i | i <- [1..len]] + -- it "findClose should return the same result over all counts" $ do + -- forAll (vectorSizedBetween 1 factor) $ \(ShowVector v) -> do + -- forAll (choose (1, bitLength v)) $ \p -> do + -- let !rmm = mkRangeMinMax v + -- findClose rmm p `shouldBe` findClose v p + -- it "nextSibling should return the same result" $ do + -- forAll (vectorSizedBetween 1 factor) $ \(ShowVector v) -> do + -- let !rmm = mkRangeMinMax v + -- nextSibling rmm 0 `shouldBe` nextSibling v 0 + -- it "nextSibling should return the same result over all counts" $ do + -- forAll (vectorSizedBetween 1 factor) $ \(ShowVector v) -> do + -- forAll (choose (1, bitLength v)) $ \p -> do + -- let !rmm = mkRangeMinMax v + -- nextSibling rmm p `shouldBe` nextSibling v p diff --git a/test/HaskellWorks/Data/BalancedParens/SimpleSpec.hs b/test/HaskellWorks/Data/BalancedParens/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/BalancedParens/SimpleSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.BalancedParens.SimpleSpec where + +import Data.Maybe +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.BalancedParens +import HaskellWorks.Data.Bits.BitLength +import HaskellWorks.Data.Bits.BitRead +import HaskellWorks.Data.Bits.BitShow +import Test.Hspec +import Test.QuickCheck + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} + +newtype ShowVector a = ShowVector a deriving (Eq, BitShow) + +instance BitShow a => Show (ShowVector a) where + show = bitShow + +vectorSizedBetween :: Int -> Int -> Gen (ShowVector (DVS.Vector Word64)) +vectorSizedBetween a b = do + n <- choose (a, b) + xs <- sequence [ arbitrary | _ <- [1 .. n] ] + return $ ShowVector (DVS.fromList xs) + +spec :: Spec +spec = describe "HaskellWorks.Data.BalancedParens.SimpleSpec" $ do + describe "For (()(()())) 1101101000" $ do + let bs = SimpleBalancedParens (91 :: Word64) + it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + describe "For (()(()())) 1101101000" $ do + let bs = SimpleBalancedParens (fromJust (bitRead "1101101000") :: [Bool]) + it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + it "firstChild 1" $ firstChild bs 1 `shouldBe` Just 2 + it "firstChild 4" $ firstChild bs 4 `shouldBe` Just 5 + it "nextSibling 2" $ nextSibling bs 2 `shouldBe` Just 4 + it "nextSibling 5" $ nextSibling bs 5 `shouldBe` Just 7 + it "parent 2" $ parent bs 2 `shouldBe` Just 1 + it "parent 5" $ parent bs 5 `shouldBe` Just 4 + it "depth 1" $ depth bs 1 `shouldBe` Just 1 + it "depth 2" $ depth bs 2 `shouldBe` Just 2 + it "depth 3" $ depth bs 3 `shouldBe` Just 2 + it "depth 4" $ depth bs 4 `shouldBe` Just 2 + it "depth 5" $ depth bs 5 `shouldBe` Just 3 + it "depth 6" $ depth bs 6 `shouldBe` Just 3 + it "depth 7" $ depth bs 7 `shouldBe` Just 3 + it "depth 8" $ depth bs 8 `shouldBe` Just 3 + it "depth 9" $ depth bs 9 `shouldBe` Just 2 + it "depth 10" $ depth bs 10 `shouldBe` Just 1 + it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` Just 5 + it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` Just 1 + it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` Just 0 + it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` Just 3 + it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` Just 1 + it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` Just 0 + it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` Just 1 + it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` Just 0 + it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` Just 0 + it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` Just 0 + describe "For (()(()())) 11011010 00000000 :: DVS.Vector Word8" $ do + let bs = SimpleBalancedParens (fromJust (bitRead "11011010 00000000") :: DVS.Vector Word8) + it "Test 1a" $ findClose bs 1 `shouldBe` Just 10 + it "Test 1b" $ findClose bs 2 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 3 `shouldBe` Just 3 + it "Test 1b" $ findClose bs 4 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 5 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 6 `shouldBe` Just 6 + it "Test 1b" $ findClose bs 7 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 8 `shouldBe` Just 8 + it "Test 1b" $ findClose bs 9 `shouldBe` Just 9 + it "Test 1b" $ findClose bs 10 `shouldBe` Just 10 + it "Test 2a" $ findOpen bs 10 `shouldBe` Just 1 + it "Test 2b" $ findOpen bs 3 `shouldBe` Just 2 + it "Test 3a" $ enclose bs 2 `shouldBe` Just 1 + it "Test 3b" $ enclose bs 7 `shouldBe` Just 4 + it "firstChild 1" $ firstChild bs 1 `shouldBe` Just 2 + it "firstChild 4" $ firstChild bs 4 `shouldBe` Just 5 + it "nextSibling 2" $ nextSibling bs 2 `shouldBe` Just 4 + it "nextSibling 5" $ nextSibling bs 5 `shouldBe` Just 7 + it "parent 2" $ parent bs 2 `shouldBe` Just 1 + it "parent 5" $ parent bs 5 `shouldBe` Just 4 + it "depth 1" $ depth bs 1 `shouldBe` Just 1 + it "depth 2" $ depth bs 2 `shouldBe` Just 2 + it "depth 3" $ depth bs 3 `shouldBe` Just 2 + it "depth 4" $ depth bs 4 `shouldBe` Just 2 + it "depth 5" $ depth bs 5 `shouldBe` Just 3 + it "depth 6" $ depth bs 6 `shouldBe` Just 3 + it "depth 7" $ depth bs 7 `shouldBe` Just 3 + it "depth 8" $ depth bs 8 `shouldBe` Just 3 + it "depth 9" $ depth bs 9 `shouldBe` Just 2 + it "depth 10" $ depth bs 10 `shouldBe` Just 1 + it "subtreeSize 1" $ subtreeSize bs 1 `shouldBe` Just 5 + it "subtreeSize 2" $ subtreeSize bs 2 `shouldBe` Just 1 + it "subtreeSize 3" $ subtreeSize bs 3 `shouldBe` Just 0 + it "subtreeSize 4" $ subtreeSize bs 4 `shouldBe` Just 3 + it "subtreeSize 5" $ subtreeSize bs 5 `shouldBe` Just 1 + it "subtreeSize 6" $ subtreeSize bs 6 `shouldBe` Just 0 + it "subtreeSize 7" $ subtreeSize bs 7 `shouldBe` Just 1 + it "subtreeSize 8" $ subtreeSize bs 8 `shouldBe` Just 0 + it "subtreeSize 9" $ subtreeSize bs 9 `shouldBe` Just 0 + it "subtreeSize 10" $ subtreeSize bs 10 `shouldBe` Just 0 + describe "Does not suffer exceptions" $ do + it "when calling nextSibling from valid locations" $ do + forAll (vectorSizedBetween 1 64) $ \(ShowVector v) -> do + [nextSibling v p | p <- [1..bitLength v]] `shouldBe` [nextSibling v p | p <- [1..bitLength v]] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}