ac-library-hs 1.5.0.0 → 1.5.1.0
raw patch · 24 files changed
+1579/−138 lines, 24 filesdep ~transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: transformers
API changes (from Hackage documentation)
+ AtCoder.Extra.Tree.Lct: jumpMaybe :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> Int -> m (Maybe Vertex)
+ AtCoder.Extra.Tree.Lct: lcaMaybe :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m (Maybe Vertex)
+ AtCoder.Extra.Tree.Lct: lengthBetween :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Vertex
+ AtCoder.Extra.Tree.Lct: prodTree :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> m a
+ AtCoder.Extra.Tree.Lct: read :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> m a
+ AtCoder.Extra.Tree.Lct: same :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Bool
+ AtCoder.Extra.Vector: chunks :: Vector v a => Int -> v a -> Vector (v a)
+ AtCoder.Extra.Vector: compress :: Vector Int -> (Vector Int, Vector Int)
+ AtCoder.Extra.Vector: concatMapM :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> m (v b)) -> v a -> m (v b)
+ AtCoder.Extra.Vector: iconcatMap :: (HasCallStack, Vector v a, Vector v b) => (Int -> a -> v b) -> v a -> v b
+ AtCoder.Extra.Vector: iconcatMapM :: (HasCallStack, Monad m, Vector v a, Vector v b) => (Int -> a -> m (v b)) -> v a -> m (v b)
+ AtCoder.Extra.Vector: mapAccumL :: forall v s a b. (HasCallStack, Vector v a, Vector v b) => (s -> a -> (s, b)) -> s -> v a -> (s, v b)
+ AtCoder.Extra.Vector: maxRangeSum :: (Vector v a, Ord a, Num a) => v a -> a
+ AtCoder.Extra.Vector: minRangeSum :: (Vector v a, Ord a, Num a) => v a -> a
+ AtCoder.Extra.Vector: postscanlM :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: postscanlM' :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: prescanlM :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: prescanlM' :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: scanl1M :: (HasCallStack, Monad m, Vector v a) => (a -> a -> m a) -> v a -> m (v a)
+ AtCoder.Extra.Vector: scanl1M' :: (HasCallStack, Monad m, Vector v a) => (a -> a -> m a) -> v a -> m (v a)
+ AtCoder.Extra.Vector: scanlM :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: scanlM' :: (HasCallStack, Monad m, Vector v a, Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)
+ AtCoder.Extra.Vector: slideMaxIndices :: HasCallStack => Int -> Vector Int -> Vector Int
+ AtCoder.Extra.Vector: slideMinIndices :: HasCallStack => Int -> Vector Int -> Vector Int
+ AtCoder.Internal.Csr: adj1 :: (HasCallStack, Unbox w) => Csr w -> Int -> Vector (Int, Int)
- AtCoder.Extra.Tree.Lct: lca :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Int -> Int -> m Vertex
+ AtCoder.Extra.Tree.Lct: lca :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Vertex
- AtCoder.Extra.Tree.Lct: parent :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Int -> m (Maybe Vertex)
+ AtCoder.Extra.Tree.Lct: parent :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> m (Maybe Vertex)
- AtCoder.Extra.Tree.Lct: root :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Int -> m Vertex
+ AtCoder.Extra.Tree.Lct: root :: (HasCallStack, PrimMonad m, Monoid a, Unbox a) => Lct (PrimState m) a -> Vertex -> m Vertex
- AtCoder.Extra.Vector: argsort :: (Ord a, Unbox a) => Vector a -> Vector Int
+ AtCoder.Extra.Vector: argsort :: (HasCallStack, Ord a, Unbox a) => Vector a -> Vector Int
Files
- CHANGELOG.md +14/−0
- README.md +3/−0
- ac-library-hs.cabal +13/−5
- benchmarks/Bench/Vector/ConcatMapM.hs +129/−0
- benchmarks/Bench/Vector/IConcatMapM.hs +127/−0
- benchmarks/Bench/Vector/MapAccumL.hs +26/−0
- benchmarks/BenchLib/Vector/ConcatMapM.hs +101/−0
- benchmarks/BenchLib/Vector/MapAccumL.hs +111/−0
- benchmarks/Main.hs +8/−4
- src/AtCoder/Extra/Bisect.hs +10/−10
- src/AtCoder/Extra/Graph.hs +8/−8
- src/AtCoder/Extra/Math/Montgomery64.hs +1/−1
- src/AtCoder/Extra/SegTree2d/Dense.hs +1/−1
- src/AtCoder/Extra/Semigroup/Permutation.hs +5/−2
- src/AtCoder/Extra/Tree.hs +8/−5
- src/AtCoder/Extra/Tree/Hld.hs +7/−3
- src/AtCoder/Extra/Tree/Lct.hs +258/−84
- src/AtCoder/Extra/Vector.hs +388/−13
- src/AtCoder/Internal/Csr.hs +11/−0
- test/Main.hs +6/−0
- test/Tests/Extra/KdTree.hs +1/−1
- test/Tests/Extra/LazyKdTree.hs +1/−1
- test/Tests/Extra/Tree.hs +27/−0
- test/Tests/Extra/Tree/Lct.hs +315/−0
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Revision history for acl-hs +## 1.5.1.0 -- June 2025++- Added `transformers` as a new dependency.+- Added more functions:+ - `AtCoder.Extra.Lct`: `read`, `lcaMaybe`, `lengthBetween` and `prodTree`.+ - `AtCoder.Extra.Graph`: `adj1`.+ - `AtCoder.Internal.Csr`: `adj1`.+ - `AtCoder.Extra.Vector`:+ - `iconcatMap`, `concatMapM`, `iconcatMapM`+ - `compress`, `mapAccumL`, `chunks`+ - `scanlM` variants,+ - `maxRangeSum`, `minRangeSum`+ - `slideMinIndices`, `slideMaxIndices`+ ## 1.5.0.0 -- May 2025 - Changed the parameter orders of `bfs01` and `dijkstra` in `AtCoder.Extra.Graph`.
README.md view
@@ -1,5 +1,8 @@ # ac-library-hs +[](https://deepwiki.com/toyboot4e/ac-library-hs)+<!-- DeepWiki badge generated by https://deepwiki.ryoppippi.com/ -->+ Haskell port of [ac-library](https://github.com/atcoder/ac-library), a library for competitive programming on [AtCoder](https://atcoder.jp/). The `main` branch is the version avaiable on AtCoder (+ documentation fixes). See `dev` branch for upcoming updates.
ac-library-hs.cabal view
@@ -4,11 +4,11 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 1.5.0.0+version: 1.5.1.0 synopsis: Data structures and algorithms description: Haskell port of [ac-library](https://github.com/atcoder/ac-library), a library for competitive- programming on [AtCoder](https://atcoder.jp/).+ programming on [AtCoder](https://atcoder.jp/). ([GitHub](https://github.com/toyboot4e/ac-library-hs), [DeepWiki](https://deepwiki.com/toyboot4e/ac-library-hs)) - Functions primarily use half-open interval \([l, r)\). - The `Extra` module contains additional utilities beyond the original C++ library.@@ -39,7 +39,8 @@ , bitvec <1.2 , bytestring <0.14 , primitive >=0.6.4.0 && <0.10- , random >=1.2.0 && < 1.3+ , transformers >= 0.2.0.0+ , random >=1.2.0 && <1.3 , vector >=0.13.0 && <0.14 , vector-algorithms <0.10 , wide-word <0.2@@ -170,6 +171,8 @@ Tests.Extra.Semigroup.Permutation Tests.Extra.Seq Tests.Extra.Seq.Map+ Tests.Extra.Tree+ Tests.Extra.Tree.Lct Tests.Extra.WaveletMatrix Tests.Extra.WaveletMatrix.BitVector Tests.Extra.WaveletMatrix.Raw@@ -230,17 +233,22 @@ Bench.RepeatWithIndex Bench.RepeatWithoutIndex Bench.SwapDupe+ Bench.Vector.ConcatMapM+ Bench.Vector.IConcatMapM+ Bench.Vector.MapAccumL BenchLib.AddMod BenchLib.Matrix BenchLib.ModInt.ModIntNats BenchLib.ModInt.Modulus+ BenchLib.Montgomery64.Inline+ BenchLib.Montgomery64.Noinline BenchLib.MulMod.Barrett64 BenchLib.MulMod.BarrettWideWord BenchLib.MulMod.Montgomery- BenchLib.Montgomery64.Inline- BenchLib.Montgomery64.Noinline BenchLib.PowMod BenchLib.SwapDupe+ BenchLib.Vector.ConcatMapM+ BenchLib.Vector.MapAccumL build-depends: , ac-library-hs
+ benchmarks/Bench/Vector/ConcatMapM.hs view
@@ -0,0 +1,129 @@+module Bench.Vector.ConcatMapM (benches) where++import BenchLib.Vector.ConcatMapM qualified as ConcatMapM+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (runST)+import Control.Monad.Trans.State.Strict (StateT (..), evalState, evalStateT)+import Control.Monad.State.Class (MonadState, modify')+import Criterion+import Data.Vector.Unboxed qualified as VU+import Data.Vector.Unboxed.Mutable qualified as VUM+import System.Random++benches :: Benchmark+benches =+ bgroup+ "concatMapM"+ [ -- FIXME: too fast, something is wrong.+ bench "list" $ nf (concatMap fList) (VU.toList vec),+ bench "prim IO" $ nfIO (prim1 vec),+ bench "monad 1 IO" $ nfIO (io1 vec),+ bench "monad 2 IO" $ nfIO (io2 vec),+ bench "prim ST" $ nf (\xs -> runST (prim1 xs)) vec,+ bench "monad 1 ST" $ nf st1 vec,+ bench "monad 2 ST" $ nf st2 vec,+ bench "prim StateT" $ nf (\vec -> runST $ (`evalStateT` (0 :: Int)) (ConcatMapM.primConcatMapM1 g vec)) vec,+ bench "monad 1 State" $ nf ((`evalState` (0 :: Int)) . ConcatMapM.concatMapM1 g) vec,+ bench "monad 2 State" $ nf ((`evalState` (0 :: Int)) . ConcatMapM.concatMapM2 g) vec,+ bench "prime StateT + IO" $ nfIO (evalStateT (primStateT1 vec) (0 :: Int)),+ bench "monad 1 StateT + IO" $ nfIO (evalStateT (stateT1 vec) (0 :: Int)),+ bench "monad 2 StateT + IO" $ nfIO (evalStateT (stateT2 vec) (0 :: Int))+ ]+ where+ n = 10 ^ 3 :: Int+ vec :: VU.Vector Int+ vec = VU.unfoldrExactN n (uniformR (0, n - 1)) (mkStdGen (1 + 123456789))++ f :: Int -> VU.Vector Int+ f x = VU.fromList [x, x, x, x, x]++ fList :: Int -> [Int]+ fList x = [x, x, x, x, x]++ g :: (MonadState Int m) => Int -> m (VU.Vector Int)+ g x = do+ modify' (+ 1)+ pure $ f x++ prim1 :: (PrimMonad m) => VU.Vector Int -> m (VU.Vector Int)+ prim1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.primConcatMapM1+ ( \x -> do+ VUM.modify ref (+ 1) 0+ pure $ f x+ )+ vec++ io1 :: VU.Vector Int -> IO (VU.Vector Int)+ io1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM1+ ( \x -> do+ VUM.modify ref (+ 1) 0+ pure $ f x+ )+ vec++ io2 :: VU.Vector Int -> IO (VU.Vector Int)+ io2 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM2+ ( \x -> do+ VUM.modify ref (+ 1) 0+ pure $ f x+ )+ vec++ st1 :: VU.Vector Int -> VU.Vector Int+ st1 vec = runST $ do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM1+ ( \x -> do+ VUM.modify ref (+ 1) 0+ pure $ f x+ )+ vec++ st2 :: VU.Vector Int -> VU.Vector Int+ st2 vec = runST $ do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM2+ ( \x -> do+ VUM.modify ref (+ 1) 0+ pure $ f x+ )+ vec++ stateT1 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ stateT1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM1+ ( \x -> do+ VUM.modify ref (+ 1) 0+ modify' (+ 1)+ pure $ f x+ )+ vec++ stateT2 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ stateT2 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.concatMapM2+ ( \x -> do+ VUM.modify ref (+ 1) 0+ modify' (+ 1)+ pure $ f x+ )+ vec++ primStateT1 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ primStateT1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.primConcatMapM1+ ( \x -> do+ VUM.modify ref (+ 1) 0+ modify' (+ 1)+ pure $ f x+ )+ vec
+ benchmarks/Bench/Vector/IConcatMapM.hs view
@@ -0,0 +1,127 @@+module Bench.Vector.IConcatMapM (benches) where++import BenchLib.Vector.ConcatMapM qualified as ConcatMapM+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (runST)+import Control.Monad.Trans.State.Strict (State (..), StateT (..), evalState, evalStateT)+import Control.Monad.State.Class (MonadState, modify')+import Criterion+import Data.Vector.Fusion.Bundle.Monadic qualified as BundleM+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM+import Data.Vector.Unboxed qualified as VU+import Data.Vector.Unboxed.Mutable qualified as VUM+import System.Random++benches :: Benchmark+benches =+ bgroup+ "iconcatMapM"+ [ bench "prim IO" $ nfIO (prim1 vec),+ bench "monad 1 IO" $ nfIO (io1 vec),+ bench "monad 2 IO" $ nfIO (io2 vec),+ bench "prim ST" $ whnf (\xs -> runST (prim1 xs)) vec,+ bench "monad 1 ST" $ whnf st1 vec,+ bench "monad 2 ST" $ whnf st2 vec,+ bench "prim StateT" $ whnf (\vec -> runST $ (`evalStateT` (0 :: Int)) (ConcatMapM.primIConcatMapM1 g vec)) vec,+ bench "monad 1 State" $ whnf ((`evalState` (0 :: Int)) . ConcatMapM.iconcatMapM1 g) vec,+ bench "monad 2 State" $ whnf ((`evalState` (0 :: Int)) . ConcatMapM.iconcatMapM2 g) vec,+ bench "prime StateT + IO" $ nfIO (evalStateT (primStateT1 vec) (0 :: Int)),+ bench "monad 1 StateT + IO" $ nfIO (evalStateT (stateT1 vec) (0 :: Int)),+ bench "monad 2 StateT + IO" $ nfIO (evalStateT (stateT2 vec) (0 :: Int))+ ]+ where+ n = 10 ^ 3 :: Int+ vec :: VU.Vector Int+ vec = VU.unfoldrExactN n (uniformR (0, n - 1)) (mkStdGen (1 + 123456789))++ f :: Int -> Int -> VU.Vector Int+ f i x = VU.fromList [i + x, i + x, i + x, i + x, i + x]++ g :: (MonadState Int m) => Int -> Int -> m (VU.Vector Int)+ g i x = do+ modify' (+ i)+ pure $ f i x++ prim1 :: (PrimMonad m) => VU.Vector Int -> m (VU.Vector Int)+ prim1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.primIConcatMapM1+ ( \i x -> do+ VUM.modify ref (+ i) 0+ pure $ f i x+ )+ vec++ io1 :: VU.Vector Int -> IO (VU.Vector Int)+ io1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM1+ ( \i x -> do+ VUM.modify ref (+ i) 0+ pure $ f i x+ )+ vec++ io2 :: VU.Vector Int -> IO (VU.Vector Int)+ io2 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM2+ ( \i x -> do+ VUM.modify ref (+ i) 0+ pure $ f i x+ )+ vec++ st1 :: VU.Vector Int -> VU.Vector Int+ st1 vec = runST $ do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM1+ ( \i x -> do+ VUM.modify ref (+ i) 0+ pure $ f i x+ )+ vec++ st2 :: VU.Vector Int -> VU.Vector Int+ st2 vec = runST $ do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM2+ ( \i x -> do+ VUM.modify ref (+ i) 0+ pure $ f i x+ )+ vec++ stateT1 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ stateT1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM1+ ( \i x -> do+ VUM.modify ref (+ i) 0+ modify' (+ i)+ pure $ f i x+ )+ vec++ stateT2 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ stateT2 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.iconcatMapM2+ ( \i x -> do+ VUM.modify ref (+ i) 0+ modify' (+ i)+ pure $ f i x+ )+ vec++ primStateT1 :: VU.Vector Int -> StateT Int IO (VU.Vector Int)+ primStateT1 vec = do+ ref <- VUM.replicate 1 (0 :: Int)+ ConcatMapM.primIConcatMapM1+ ( \i x -> do+ VUM.modify ref (+ i) 0+ modify' (+ i)+ pure $ f i x+ )+ vec
+ benchmarks/Bench/Vector/MapAccumL.hs view
@@ -0,0 +1,26 @@+module Bench.Vector.MapAccumL (benches) where++import BenchLib.Vector.MapAccumL qualified as MapAccumL+import Criterion+import Data.List qualified as L+import Data.Vector.Unboxed qualified as VU+import System.Random++benches :: Benchmark+benches =+ bgroup+ "mapAccumL"+ [ -- whnf did not work (somehow) for mapAccumL1, so I'm using nf+ -- NOTE: list is not fair to compare though+ bench "list" $ nf (L.mapAccumL f (0 :: Int)) (VU.toList vec),+ bench "mapM + State" $ nf (MapAccumL.mapAccumL1 f (0 :: Int)) vec,+ bench "ifoldM'" $ nf (MapAccumL.mapAccumL2 f (0 :: Int)) vec,+ bench "bundle" $ nf (MapAccumL.mapAccumL3 f (0 :: Int)) vec,+ bench "mapM + State + PrimMonad" $ nf (MapAccumL.mapAccumL4 f (0 :: Int)) vec+ ]+ where+ n = 10 ^ 3 :: Int+ vec :: VU.Vector Int+ vec = VU.unfoldrExactN n (uniformR (0, n - 1)) (mkStdGen (1 + 123456789))+ f :: Int -> Int -> (Int, Int)+ f s x = (s + 10, s * x)
+ benchmarks/BenchLib/Vector/ConcatMapM.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE RecordWildCards #-}++-- | Fast modular multiplication by barrett reduction.+module BenchLib.Vector.ConcatMapM+ ( primConcatMapM1,+ concatMapM1,+ concatMapM2,+ primIConcatMapM1,+ iconcatMapM1,+ iconcatMapM2,+ )+where++import Control.Monad.Primitive (PrimMonad)+import Data.Vector.Fusion.Bundle.Monadic qualified as BundleM+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM++-- I expected these functions do not perform well with State monad, but+-- they're working as fast as IO and ST?++-- | https://github.com/haskell/vector/issues/416+--+-- With this wrapper+unstreamPrimM :: (PrimMonad m, VG.Vector v a) => BundleM.Bundle m u a -> m (v a)+{-# INLINE [1] unstreamPrimM #-}+unstreamPrimM s = VGM.munstream s >>= VG.unsafeFreeze++-- | PrimMonad only. This addes more constraints, but performs well with complex monads.+{-# INLINE primConcatMapM1 #-}+primConcatMapM1 ::+ (PrimMonad m, VG.Vector v a, VG.Vector v b) =>+ (a -> m (v b)) ->+ v a ->+ m (v b)+primConcatMapM1 f =+ unstreamPrimM+ . BundleM.concatVectors+ . BundleM.mapM f+ . BundleM.fromVector++{-# INLINE concatMapM1 #-}+concatMapM1 ::+ (Monad m, VG.Vector v a, VG.Vector v b) =>+ (a -> m (v b)) ->+ v a ->+ m (v b)+concatMapM1 f =+ VG.unstreamM+ . BundleM.concatVectors+ . BundleM.mapM f+ . BundleM.fromVector++{-# INLINE concatMapM2 #-}+concatMapM2 ::+ (Monad m, VG.Vector v a, VG.Vector v b) =>+ (a -> m (v b)) ->+ v a ->+ m (v b)+concatMapM2 f xs =+ VG.unstreamM+ . BundleM.concatVectors+ $ BundleM.generateM (VG.length xs) (f . VG.unsafeIndex xs)++-- | PrimMonad only. This addes more constraints, but performs well with complex monads.+{-# INLINE primIConcatMapM1 #-}+primIConcatMapM1 ::+ (PrimMonad m, VG.Vector v a, VG.Vector v b) =>+ (Int -> a -> m (v b)) ->+ v a ->+ m (v b)+primIConcatMapM1 f =+ unstreamPrimM+ . BundleM.concatVectors+ . BundleM.mapM (uncurry f)+ . BundleM.indexed+ . BundleM.fromVector++{-# INLINE iconcatMapM1 #-}+iconcatMapM1 ::+ (Monad m, VG.Vector v a, VG.Vector v b) =>+ (Int -> a -> m (v b)) ->+ v a ->+ m (v b)+iconcatMapM1 f =+ VG.unstreamM+ . BundleM.concatVectors+ . BundleM.mapM (uncurry f)+ . BundleM.indexed+ . BundleM.fromVector++{-# INLINE iconcatMapM2 #-}+iconcatMapM2 ::+ (Monad m, VG.Vector v a, VG.Vector v b) =>+ (Int -> a -> m (v b)) ->+ v a ->+ m (v b)+iconcatMapM2 f xs =+ VG.unstreamM+ . BundleM.concatVectors+ $ BundleM.generateM (VG.length xs) (\i -> f i (VG.unsafeIndex xs i))
+ benchmarks/BenchLib/Vector/MapAccumL.hs view
@@ -0,0 +1,111 @@+-- | Fast modular multiplication by barrett reduction.+module BenchLib.Vector.MapAccumL+ ( mapAccumL1,+ mapAccumL2,+ mapAccumL3,+ mapAccumL4,+ )+where++import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (ST, runST)+import Control.Monad.Trans.State.Strict (StateT, runState, runStateT, state)+import Data.Vector.Fusion.Bundle qualified as Bundle+import Data.Vector.Fusion.Bundle.Monadic qualified as BundleM+import Data.Vector.Fusion.Bundle.Size qualified as Bundle+import Data.Vector.Fusion.Stream.Monadic qualified as MS+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM++{-# INLINE mapAccumL1 #-}+mapAccumL1 ::+ (VG.Vector v a, VG.Vector v b) =>+ (s -> a -> (s, b)) ->+ s ->+ v a ->+ (s, v b)+mapAccumL1 f s0 xs = (\(!x, !s) -> (s, x)) $ runState (VG.mapM g xs) s0+ where+ g a =+ state+ ( \s ->+ let (!s', !b) = f s a+ in (b, s')+ )++{-# INLINE mapAccumL2 #-}+mapAccumL2 ::+ (VG.Vector v a, VG.Vector v b) =>+ (s -> a -> (s, b)) ->+ s ->+ v a ->+ (s, v b)+mapAccumL2 f s0 xs = runST $ do+ vec <- VGM.unsafeNew (VG.length xs)+ !res <-+ VG.ifoldM'+ ( \ !s i x -> do+ let (!s', !x') = f s x+ VGM.write vec i x'+ pure s'+ )+ s0+ xs+ vec' <- VG.unsafeFreeze vec+ pure (res, vec')++{-# INLINE mapAccumL3 #-}+mapAccumL3 ::+ forall v s a b.+ (VG.Vector v a, VG.Vector v b) =>+ (s -> a -> (s, b)) ->+ s ->+ v a ->+ (s, v b)+mapAccumL3 f s0 xs = (\(!x, !s) -> (s, x)) $ runST $ (`runStateT` s0) $ do+ unstreamPrimM+ . BundleM.mapM g+ $ BundleM.fromVector xs+ where+ g :: forall st. a -> StateT s (ST st) b+ g a =+ state+ ( \s ->+ let (!s', !b) = f s a+ in (b, s')+ )++-- | https://github.com/haskell/vector/issues/416+unstreamPrimM :: (PrimMonad m, VG.Vector v a) => BundleM.Bundle m u a -> m (v a)+{-# INLINE [1] unstreamPrimM #-}+unstreamPrimM s = VGM.munstream s >>= VG.unsafeFreeze++-- @cojna/iota. Note that it does not return state value.+{-# INLINE mapAccumL4 #-}+mapAccumL4 ::+ (VG.Vector v a, VG.Vector v b) =>+ (s -> a -> (s, b)) ->+ s ->+ v a ->+ v b+mapAccumL4 f x =+ VG.unstream+ . Bundle.inplace+ (streamAccumM (\s a -> pure (f s a)) x)+ Bundle.toMax+ . VG.stream++-- @cojna/iota+streamAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> MS.Stream m a -> MS.Stream m b+streamAccumM f s0 (MS.Stream step x0) = MS.Stream step' (s0, x0)+ where+ step' (!s, x) = do+ r <- step x+ case r of+ MS.Yield a x' -> do+ (s', b) <- f s a+ return $ MS.Yield b (s', x')+ MS.Skip x' -> return $ MS.Skip (s, x')+ MS.Done -> return MS.Done+ {-# INLINE [0] step' #-}+{-# INLINE [1] streamAccumM #-}
benchmarks/Main.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Main where import Bench.AddMod qualified@@ -11,12 +9,15 @@ import Bench.RepeatWithIndex qualified import Bench.RepeatWithoutIndex qualified import Bench.SwapDupe qualified+import Bench.Vector.ConcatMapM qualified+import Bench.Vector.IConcatMapM qualified+import Bench.Vector.MapAccumL qualified import Criterion.Main main :: IO () main = defaultMain- -- TODO: generate criterion graph by benchmark group?+ -- TODO: Filter benchmark cases with command line arguments. Currently I'm filtering benchmarks by hand. [ Bench.MulMod.benches, Bench.ModInt.benches, Bench.AddMod.benches,@@ -25,5 +26,8 @@ Bench.Montgomery64.benches, Bench.RepeatWithIndex.benches, Bench.RepeatWithoutIndex.benches,- Bench.SwapDupe.benches+ Bench.SwapDupe.benches,+ Bench.Vector.ConcatMapM.benches,+ Bench.Vector.IConcatMapM.benches,+ Bench.Vector.MapAccumL.benches ]
src/AtCoder/Extra/Bisect.hs view
@@ -10,7 +10,7 @@ -- @ -- -- ==== __Example__--- Perform index compression:+-- Perform index compression with `lowerBound`: -- -- >>> import AtCoder.Extra.Bisect -- >>> import Data.Vector.Algorithms.Intro qualified as VAI@@ -22,13 +22,13 @@ -- -- @since 1.3.0.0 module AtCoder.Extra.Bisect- ( -- * C++-like binary search+ ( -- * C++-like binary searches lowerBound, lowerBoundIn, upperBound, upperBoundIn, - -- * Generic bisection method+ -- * Generic bisection methods maxRight, maxRightM, minLeft,@@ -45,7 +45,7 @@ -- -- @ -- Y Y Y Y Y N N N N N Y: x_i < x_ref--- --------- *---------> x N: x_i >= x_ref+-- --------- *---------> x N: not Y -- R R: the right boundary point returned -- @ --@@ -106,8 +106,8 @@ -- | \(O(\log n)\) Returns the maximum \(r\) where \(x_i \le x_{ref}\) holds for \(i \in [0, r)\). -- -- @--- Y Y Y Y Y N N N N N Y: x_i <= x_ref,--- --------- *---------> x N: x_i > x_ref,+-- Y Y Y Y Y N N N N N Y: x_i <= x_ref+-- --------- *---------> x N: not Y -- R R: the right boundary point returned -- @ --@@ -175,8 +175,8 @@ -- right boundary point. -- -- @--- Y Y Y Y Y N N N N N Y: p(i) returns `true`,--- --------- *---------> x N: p(i) returns `false`,+-- Y Y Y Y Y N N N N N Y: p(i) returns `true`+-- --------- *---------> x N: not Y -- R R: the right boundary point returned -- @ --@@ -223,8 +223,8 @@ -- left boundary point. -- -- @--- N N N N N Y Y Y Y Y Y: p(i) returns `true`,--- --------* ----------> x N: p(i) returns `false`,+-- N N N N N Y Y Y Y Y Y: p(i) returns `true`+-- --------* ----------> x N: not Y -- L L: the left boundary point returned -- @ --
src/AtCoder/Extra/Graph.hs view
@@ -1686,7 +1686,7 @@ where idx !from !to = nVerts * from + to --- | \(O(n)\) Given a predecessor array, retrieves a path from the root to a vertex.+-- | \(O(n)\) Given a predecessor array, reconstructs a path from the root to a vertex. -- -- ==== Constraints -- - The path must not make a cycle, otherwise this function loops forever.@@ -1698,7 +1698,7 @@ constructPathFromRoot :: (HasCallStack) => VU.Vector Int -> Int -> VU.Vector Int constructPathFromRoot parents = VU.reverse . constructPathToRoot parents --- | \(O(n)\) Given a predecessor array, retrieves a path from a vertex to the root.+-- | \(O(n)\) Given a predecessor array, reconstructs a path from a vertex to the root. -- -- ==== Constraints -- - The path must not make a cycle, otherwise this function loops forever.@@ -1713,7 +1713,7 @@ f (-1) = Nothing f v = Just (v, parents VG.! v) --- | \(O(n)\) Given a NxN predecessor matrix (created with `trackingFloydWarshall`), retrieves a+-- | \(O(n)\) Given a NxN predecessor matrix (created with `trackingFloydWarshall`), reconstructs a -- path from the root to a sink vertex. -- -- ==== Constraints@@ -1735,7 +1735,7 @@ VU.Vector Int constructPathFromRootMat parents source = VU.reverse . constructPathToRootMat parents source --- | \(O(n)\) Given a NxN predecessor matrix(created with `trackingFloydWarshall`), retrieves a+-- | \(O(n)\) Given a NxN predecessor matrix(created with `trackingFloydWarshall`), reconstructs a -- path from a vertex to the root. -- -- ==== Constraints@@ -1763,8 +1763,8 @@ -- https://zenn.dev/mod_poppo/articles/atcoder-beginner-contest-284-d#%E8%A7%A3%E6%B3%953%EF%BC%9Asqrt%E3%81%A8round%E3%82%92%E4%BD%BF%E3%81%86 n :: Int = round . sqrt $ (fromIntegral (VU.length parents) :: Double) --- | \(O(n)\) Given a NxN predecessor matrix (created with `newTrackingFloydWarshall`), retrieves a--- path from the root to a sink vertex.+-- | \(O(n)\) Given a NxN predecessor matrix (created with `newTrackingFloydWarshall`), reconstructs+-- a path from the root to a sink vertex. -- -- ==== Constraints -- - The path must not make a cycle, otherwise this function loops forever.@@ -1785,8 +1785,8 @@ m (VU.Vector Int) constructPathFromRootMatM parents source = (VU.reverse <$>) . constructPathToRootMatM parents source --- | \(O(n)\) Given a NxN predecessor matrix (created with `newTrackingFloydWarshall`), retrieves a--- path from a vertex to the root.+-- | \(O(n)\) Given a NxN predecessor matrix (created with `newTrackingFloydWarshall`),+-- reconstructs a path from a vertex to the root. -- -- ==== Constraints -- - The path must not make a cycle, otherwise this function loops forever.
src/AtCoder/Extra/Math/Montgomery64.hs view
@@ -84,7 +84,7 @@ let !m128 :: Word128 = fromIntegral m !n2 = word128Lo64 $ (-m128) `mod` m128 !r = getR m 0- !_ = ACIA.runtimeAssert (r * m == -1) "AtCoder.Extra.Montgomery64.fromVal: internal implementation error"+ !_ = ACIA.runtimeAssert (r * m == maxBound) "AtCoder.Extra.Montgomery64.fromVal: internal implementation error" in Montgomery64 m r n2 where !_ = ACIA.runtimeAssert (odd m && m <= bit 62) $ "AtCoder.Extra.Montgomery64.fromVal: not given odd modulus value that is less than or equal to 2^62: " ++ show m
src/AtCoder/Extra/SegTree2d/Dense.hs view
@@ -180,7 +180,7 @@ -- @since 1.2.3.0 {-# INLINE write #-} write :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => DenseSegTree2d (PrimState m) a -> Int -> Int -> a -> m ()-write seg@DenseSegTree2d {..} x y a = stToPrim $ do+write seg x y a = stToPrim $ do modifyM seg (pure . const a) x y -- | \(O(\log h \log w)\) Given a user function \(f\), modifies the monoid value at \((x, y)\) with
src/AtCoder/Extra/Semigroup/Permutation.hs view
@@ -61,6 +61,9 @@ -- | \(O(1)\) Creates a `Permutation`, performing boundary check on input vector. --+-- ==== Constraints+-- - \(-1 \le x \lt n\)+-- -- @since 1.1.0.0 {-# INLINE new #-} new :: (HasCallStack) => VU.Vector Int -> Permutation@@ -91,7 +94,7 @@ zero :: Int -> Permutation zero n = Permutation $ VU.replicate n (-1) --- | \(O(1)\) Maps an index.+-- | \(O(1)\) Maps an index with the permutation. -- -- @since 1.1.0.0 {-# INLINE act #-}@@ -112,6 +115,6 @@ {-# INLINE (<>) #-} Permutation r2 <> Permutation r1 = Permutation $ VU.map f r1 where- !_ = ACIA.runtimeAssert (VU.length r2 == VU.length r1) "AtCoder.Extra.Semigroup.Permutation.(<>): legth mismatch"+ !_ = ACIA.runtimeAssert (VU.length r2 == VU.length r1) "AtCoder.Extra.Semigroup.Permutation.(<>): length mismatch" f (-1) = -1 f i = VG.unsafeIndex r2 i
src/AtCoder/Extra/Tree.hs view
@@ -101,9 +101,10 @@ !w = bfs2 VG.! to in (Gr.constructPathFromRoot parents to, w) --- | \(O(m \log m)\) Kruskal's algorithm. Returns edge indices for building a minimum spanning tree.+-- | \(O(m \log m)\) Kruskal's algorithm. Returns \((w, \mathrm{use}, \mathrm{mst})\): (weight of the minimum+-- spanning tree, edge use flags, minimum spanning tree). ----- NOTE: The edges should not be duplicated: only one of \((u, v, w)\) or \((v, u, w)\) is required+-- NOTE: The edges need not be duplicated: only one of \((u, v, w)\) or \((v, u, w)\) is required -- for each edge. -- -- ==== __Example__@@ -127,10 +128,12 @@ mst :: (Num w, Ord w, VU.Unbox w) => Int -> VU.Vector (Int, Int, w) -> (w, VU.Vector Bit, Gr.Csr w) mst = mstBy (comparing id) --- | \(O(m \log m)\) Kruskal's algorithm. Returns edge indices for building a minimum/maximum--- spanning tree.+-- | \(O(m \log m)\) Kruskal's algorithm for creating either minimum or maximum spanning tree. Returns+-- \((w, \mathrm{use}, \mathrm{mst})\): (weight of the minimum spanning tree, edge use flags, minimum+-- spanning tree). ----- NOTE: The edges should not be duplicated: only one of \((u, v, w)\) or \((v, u, w)\) is required+--+-- NOTE: The edges need not be duplicated: only one of \((u, v, w)\) or \((v, u, w)\) is required -- for each edge. -- -- ==== __Example__
src/AtCoder/Extra/Tree/Hld.hs view
@@ -84,6 +84,9 @@ -- >>> Hld.ancestor hld 5 3 -- go up three parents from `5` -- 0 --+-- >>> Hld.lca hld 2 5 -- lowest common ancestor of `2` and `5`:+-- 1+-- -- >>> Hld.jump hld 5 2 3 -- go to the third vertex from `5` to `2`: -- Just 2 --@@ -93,7 +96,8 @@ -- >>> Hld.path hld 5 3 -- get the path between `5` and `3`: -- [5,4,1,2,3] ----- Our `Hld` is rooted at @0@ vertex and subtree queries are available:+-- So the subtree queries are run with recpect to root vertex `0`, since our HLD is created with+-- `new`: -- -- >>> Hld.isInSubtree hld 2 3 -- `3` is in the subtree of `2` -- True@@ -218,7 +222,7 @@ -- -- ==== Constraints -- - \(n \ge 1\)--- - The input graph must be a tree; the edges must be undirected (both \((u, v, w)\) and+-- - The input graph must be a tree. Note that the edges must be undirected (both \((u, v, w)\) and -- \((v, u, w)\) edges are required). -- -- @since 1.1.0.0@@ -230,7 +234,7 @@ -- -- ==== Constraints -- - \(n \ge 1\)--- - The input graph must be a tree; the edges must be undirected (both \((u, v, w)\) and+-- - The input graph must be a tree. Note that the edges must be undirected (both \((u, v, w)\) and -- \((v, u, w)\) edges are required). -- -- @since 1.1.0.0
src/AtCoder/Extra/Tree/Lct.hs view
@@ -2,11 +2,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} --- | Link/cut tree: forest with monoid values.+-- | Link/cut tree: dynamic forest with monoid values on vertices. If you need to have monoid values+-- on edges, treat the original edges as new vertices. --+-- - __Most operations are unsafe__; user must ensure connectivities of \(u\) and \(v\) before+-- running each query.+-- - This specific implementation is not capable of applying monoid action to a subtree.+-- -- ==== __Example__ ----- Create a link/cut tree of @Sum Int@ with inverse operator `negate`:+-- Create a link/cut tree of monoid @Sum Int@ with inverse operator `negate`: -- -- >>> import AtCoder.Extra.Tree.Lct qualified as Lct -- >>> import Data.Semigroup (Sum (..))@@ -15,11 +20,14 @@ -- >>> -- +--3 -- >>> lct <- Lct.buildInv negate (VU.generate 4 Sum) $ VU.fromList [(0, 1), (1, 2), (1, 3)] --+-- ===== `prodPath`, `prodSubtree`, `prodTree`+-- -- Monoid products can be calculated for paths or subtrees: -- -- >>> Lct.prodPath lct 0 2 -- Sum {getSum = 3} --+-- >>> -- If we create the LCT with `buildInv`, we can use `prodSubtree`: -- >>> Lct.prodSubtree lct 1 {- parent -} 2 -- Sum {getSum = 4} --@@ -28,6 +36,8 @@ -- >>> Lct.root lct 3 -- 2 --+-- ===== `lca`, `jump`, `lengthBetween`+-- -- Set (`evert`) the root of the underlying tree to \(0\) and get the `lca` of vertices \(2\) and -- \(3\): --@@ -37,12 +47,27 @@ -- -- Similar to @Hld@, `Lct` allows various tree queries: ----- >>> Lct.parent lct 3--- Just 1------ >>> Lct.jump lct 2 3 2+-- >>> Lct.jump lct {- path -} 2 3 {- k -} 2 -- 3 --+-- >>> Lct.jumpMaybe lct {- path -} 2 3 {- k -} 1000+-- Nothing+--+-- >>> Lct.lengthBetween lct {- path -} 2 3+-- 2+--+-- ===== `parent`+--+-- >>> Lct.evert lct 0 -- set root `0`+-- >>> Lct.parent lct 0 -- under root `0`, parent of `0` is `Nothing`:+-- Nothing+--+-- >>> Lct.evert lct 0 -- set root `0`+-- >>> Lct.parent lct 1 -- under root `0`, parent of `1` is `0`:+-- Just 0+--+-- ===== `link` / `cut`+-- -- Edges can be dynamically added (`link`) or removed (`cut`): -- -- >>> -- 0 1 2@@ -71,13 +96,14 @@ build, buildInv, - -- * Modifications-- -- ** Write+ -- * Monoid value access+ read, write, modify, modifyM, + -- * Tree operations+ -- ** Link/cut link, cut,@@ -88,16 +114,19 @@ expose_, -- * Tree queries-- -- ** Root, parent, jump, LCA root,+ same, parent, jump,+ jumpMaybe,+ lengthBetween, lca,+ lcaMaybe, - -- ** Products+ -- ** Monoid products prodPath, prodSubtree,+ prodTree, ) where @@ -107,10 +136,12 @@ import Control.Monad.ST (ST) import Data.Bit import Data.Bits+import Data.Maybe import Data.Vector.Generic.Mutable qualified as VGM import Data.Vector.Unboxed qualified as VU import Data.Vector.Unboxed.Mutable qualified as VUM import GHC.Stack (HasCallStack)+import Prelude hiding (read) -- import GHC.Stack (HasCallStack) @@ -151,7 +182,7 @@ -- -- @since 1.1.1.0 sLct :: !(VUM.MVector s Int),- -- | Decomposed node data storage: reverse flag.+ -- | Decomposed node data storage: reverse flags. -- -- @since 1.1.1.0 revLct :: !(VUM.MVector s Bit),@@ -163,12 +194,12 @@ -- -- @since 1.1.1.0 prodLct :: !(VUM.MVector s a),- -- | Decomposed node data storage: dual monod product (right fold). This is required for+ -- | Decomposed node data storage: dual monoid products (right foldings). This is required for -- non-commutative monoids only. -- -- @since 1.1.1.0 dualProdLct :: !(VUM.MVector s a),- -- | Decomposed node data storage: path-parent monoid product. This works for subtree product+ -- | Decomposed node data storage: path-parent monoid products. This works for subtree product -- queries over commutative monoids only. -- -- @since 1.1.1.0@@ -193,8 +224,8 @@ new :: (PrimMonad m, Monoid a, VU.Unbox a) => Int -> m (Lct (PrimState m) a) new = newInv id --- | \(O(n + m \log n)\) Creates a link/cut tree with an inverse operator, initial monoid values and--- no edges. This setup enables subtree queries (`prodSubtree`).+-- | \(O(n)\) Creates a link/cut tree with an inverse operator, initial monoid values and no edges.+-- This setup enables subtree queries (`prodSubtree`). -- -- @since 1.1.1.0 {-# INLINE newInv #-}@@ -204,6 +235,9 @@ -- | \(O(n + m \log n)\) Creates a link/cut tree of initial monoid values and initial edges. This -- setup disables subtree queries (`prodSubtree`). --+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE build #-} build ::@@ -219,6 +253,9 @@ -- | \(O(n + m \log n)\) Creates a link/cut tree with an inverse operator, initial monoid values and -- initial edges. This setup enables subtree queries (`prodSubtree`). --+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE buildInv #-} buildInv ::@@ -234,46 +271,68 @@ buildInv invOpLct xs es = stToPrim $ buildST invOpLct xs es -- ---------------------------------------------------------------------------------------------------- Write+-- Monoid value access -- ------------------------------------------------------------------------------------------------- --- | Amortized \(O(\log n)\). Writes the monoid value of a vertex.+-- | \(O(1)\). Reads the monoid value on a vertex \(v\). --+-- ==== Constraints+-- - \(0 \le v \lt n\)+--+-- @since 1.5.1.0+{-# INLINE read #-}+read :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m a+read lct v = stToPrim $ do+ VGM.read (vLct lct) v+ where+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.read" v (nLct lct)++-- | Amortized \(O(\log n)\). Writes to the monoid value of a vertex \(v\).+--+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE write #-} write :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> a -> m () write lct v x = stToPrim $ do- -- make @v@ the new root of the underlying tree:+ -- make @v@ a new root of the underlying tree: evertST lct v VGM.unsafeWrite (vLct lct) v x where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.write" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.write" v (nLct lct) -- | Amortized \(O(\log n)\). Given a user function \(f\), modifies the monoid value of a vertex -- \(v\). --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE modify #-} modify :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> (a -> a) -> Vertex -> m () modify lct f v = stToPrim $ do- -- make @v@ the new root of the underlying tree:+ -- make @v@ a new root of the underlying tree: evertST lct v VGM.unsafeModify (vLct lct) f v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.modify" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.modify" v (nLct lct) -- | Amortized \(O(\log n)\). Given a user function \(f\), modifies the monoid value of a vertex -- \(v\). --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE modifyM #-} modifyM :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> (a -> m a) -> Vertex -> m () modifyM lct f v = do- -- make @v@ the new root of the underlying tree:+ -- make @v@ a new root of the underlying tree: stToPrim $ evertST lct v VGM.unsafeModifyM (vLct lct) f v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.modifyM" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.modifyM" v (nLct lct) -- ------------------------------------------------------------------------------------------------- -- Link/cut operations@@ -282,99 +341,179 @@ -- | Amortized \(O(\log n)\). Creates an edge between \(c\) and \(p\). In the represented tree, the -- \(p\) will be the parent of \(c\). --+-- ==== Constraints+-- - \(0 \le c, p \lt n\)+-- - \(u \ne v\)+-- - \(c\) and \(p\) are in different trees, otherwise the behavior is undefined.+-- -- @since 1.1.1.0 {-# INLINE link #-} link :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m () link lct c p = stToPrim $ linkST lct c p where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.link" c (nLct lct)- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.link" p (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.link" c (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.link" p (nLct lct) -- | Amortized \(O(\log n)\). Deletes an edge between \(u\) and \(v\). --+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- - \(u \ne v\)+-- - There's an edge between \(u\) and \(v\), otherwise the behavior is undefined.+-- -- @since 1.1.1.0 {-# INLINE cut #-} cut :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m () cut lct u v = stToPrim $ cutST lct u v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.cut" u (nLct lct)- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.cut" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.cut" u (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.cut" v (nLct lct) -- | Amortized \(O(\log n)\). Makes \(v\) a new root of the underlying tree. --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE evert #-} evert :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m () evert lct v = stToPrim $ evertST lct v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.evert" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.evert" v (nLct lct) -- | Amortized \(O(\log n)\). Makes \(v\) and the root to be in the same preferred path (auxiliary--- tree). After the opeartion, \(v\) will be the new root and all the children will be detached from+-- tree). After the operation, \(v\) will be the new root and all the children will be detached from -- the preferred path. --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE expose #-} expose :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m Vertex expose lct v = stToPrim $ exposeST lct v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.expose_" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.expose" v (nLct lct) -- | Amortized \(O(\log n)\). `expose` with the return value discarded. --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE expose_ #-} expose_ :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m () expose_ lct v0 = stToPrim $ do _ <- exposeST lct v0 pure ()- where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.expose_" v0 (nLct lct) -- ------------------------------------------------------------------------------------------------- -- Jump, LCA -- ------------------------------------------------------------------------------------------------- --- | \(O(\log n)\) Returns the root of the underlying tree. Two vertices in the same connected--- component have the same root vertex.+-- | \(O(\log n)\) Returns the root of the underlying tree. --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE root #-}-root :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Int -> m Vertex+root :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m Vertex root lct c0 = stToPrim $ rootST lct c0 +-- | \(O(\log n)\) Returns whether the vertices \(u\) and \(v\) are in the same connected component+-- (have the same `root`).+--+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+--+-- @since 1.5.1.0+{-# INLINE same #-}+same :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Bool+same lct u v = stToPrim $ do+ r1 <- rootST lct u+ r2 <- rootST lct v+ pure $ r1 == r2+ -- | \(O(\log n)\) Returns the parent vertex in the underlying tree. --+-- ==== Constraints+-- - \(0 \le v \lt n\)+-- -- @since 1.1.1.0 {-# INLINE parent #-}-parent :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Int -> m (Maybe Vertex)-parent lct x = stToPrim $ parentST lct x+parent :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> m (Maybe Vertex)+parent lct v = stToPrim $ parentST lct v --- | \(O(\log n)\) Given a path between \(u\) and \(v\), returns the \(k\)-th vertex of the path.+-- | \(O(\log n)\) Given a path between \(u\) and \(v\), returns the \(k\)-th vertex from \(u\) in+-- the path. -- -- ==== Constraints--- - The \(k\)-th vertex must exist.+-- - \(0 \le u, v \lt n\)+-- - \(0 \le k \lt \mathrm{|path|}\)+-- - \(u\) and \(v\) must be in the same connected component, otherwise the vehavior is undefined. -- -- @since 1.1.1.0 {-# INLINE jump #-} jump :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> Int -> m Vertex-jump lct u v k = stToPrim $ jumpST lct u v k+jump lct u v k = stToPrim $ do+ fromMaybe (error "AtCoder.Extra.Tree.Lct.jump: invalid jump") <$> jumpMaybeST lct u v k +-- | \(O(\log n)\) Given a path between \(u\) and \(v\), returns the \(k\)-th vertex from \(u\) in+-- the path.+--+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- - \(u\) and \(v\) must be in the same connected component, otherwise the vehavior is undefined.+--+-- @since 1.5.1.0+{-# INLINE jumpMaybe #-}+jumpMaybe :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> Int -> m (Maybe Vertex)+jumpMaybe lct u v k = stToPrim $ jumpMaybeST lct u v k++-- | \(O(\log n)\) Returns the length of path between \(u\) and \(v\).+--+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- - \(u\) and \(v\) must be in the same connected component.+--+-- @since 1.5.1.0+{-# INLINE lengthBetween #-}+lengthBetween :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Vertex+lengthBetween lct u v = stToPrim $ do+ lengthBetweenST lct u v+ -- | \(O(\log n)\) Returns the LCA of \(u\) and \(v\). Because the root of the underlying tree changes -- in almost every operation, one might want to use `evert` beforehand. -- -- ==== Constraints+-- - \(0 \le u, v \lt n\) -- - \(u\) and \(v\) must be in the same connected component. -- -- @since 1.1.1.0 {-# INLINE lca #-}-lca :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Int -> Int -> m Vertex+lca :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m Vertex lca lct u v = stToPrim $ do+ fromMaybe (error ("AtCoder.Extra.Tree.Lct.lca: given two vertices in different connected components " ++ show (u, v)))+ <$> lcaMaybe lct u v++-- | \(O(\log n)\) Returns the LCA of \(u\) and \(v\). Because the root of the underlying tree changes+-- in almost every operation, one might want to use `evert` beforehand.+--+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+--+-- @since 1.5.1.0+{-# INLINE lcaMaybe #-}+lcaMaybe :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m (Maybe Vertex)+lcaMaybe lct u v = stToPrim $ do ru <- rootST lct u rv <- rootST lct v- let !_ = ACIA.runtimeAssert (ru == rv) $ "AtCoder.Extra.Lct.lca: given two vertices in different connected components " ++ show (u, v)- _ <- exposeST lct u- exposeST lct v+ if ru == rv+ then do+ _ <- exposeST lct u+ Just <$> exposeST lct v+ else pure Nothing -- ------------------------------------------------------------------------------------------------- -- Monoid product@@ -382,6 +521,11 @@ -- | Amortized \(O(\log n)\). Folds a path between \(u\) and \(v\) (inclusive). --+-- ==== Constraints+-- - \(0 \le u, v \lt n\)+-- - \(u\) and \(v\) must be in the same connected component, otherwise the return value is+-- nonsense.+-- -- @since 1.1.1.0 {-# INLINE prodPath #-} prodPath :: (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => Lct (PrimState m) a -> Vertex -> Vertex -> m a@@ -393,14 +537,15 @@ -- now that @v@ is at the root of the auxiliary tree, its aggregation value is the path folding: VGM.unsafeRead prodLct v where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.prodPath" u (nLct lct)- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.prodPath" v (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.prodPath" u (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.prodPath" v (nLct lct) -- | Amortized \(O(\log n)\). Fold the subtree under \(v\), considering \(p\) as the root-side -- vertex. Or, if \(p\) equals \(v\), \(v\) will be the new root. -- -- ==== Constraints--- - The inverse operator has to be set on construction (`newInv` or `buildInv`).+-- - The inverse operator must be set on construction (`newInv` or `buildInv`).+-- - \(0 \le u, v \lt n\) -- -- @since 1.1.1.0 {-# INLINE prodSubtree #-}@@ -408,14 +553,32 @@ (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) => -- | Link/cut tree Lct (PrimState m) a ->- -- | Vertex+ -- | Vertex \(v\) Vertex ->- -- | Root or parent+ -- | Parent \(p\) (not need be adjacent to \(v\)), or same as \(v\), making it a new root. Vertex -> -- | Subtree's monoid product m a prodSubtree lct v rootOrParent = stToPrim $ prodSubtreeST lct v rootOrParent +-- | Amortized \(O(\log n)\). Fold a tree that contains \(v\).+--+-- ==== Constraints+-- - The inverse operator must be set on construction (`newInv` or `buildInv`).+-- - \(0 \le v \lt n\)+--+-- @since 1.5.1.0+{-# INLINE prodTree #-}+prodTree ::+ (HasCallStack, PrimMonad m, Monoid a, VU.Unbox a) =>+ -- | Link/cut tree+ Lct (PrimState m) a ->+ -- | Vertex \(v\)+ Vertex ->+ -- | Subtree's monoid product+ m a+prodTree lct v = stToPrim $ prodSubtreeST lct v v+ -- ------------------------------------------------------------------------------------------------- -- Internal -- -------------------------------------------------------------------------------------------------@@ -590,7 +753,7 @@ -- Node operations -- ------------------------------------------------------------------------------------------------- --- | \(O(1)\) Propgates the lazily propagated values on a node.+-- | \(O(1)\) Propagates the lazily propagated values on a node. {-# INLINEABLE pushNodeST #-} pushNodeST :: (VU.Unbox a) => Lct s a -> Vertex -> ST s () pushNodeST lct@Lct {lLct, rLct, revLct} v = do@@ -614,7 +777,7 @@ {-# INLINEABLE swapLrNodeST #-} swapLrNodeST :: (VU.Unbox a) => Lct s a -> Vertex -> ST s () swapLrNodeST Lct {lLct, rLct, prodLct, dualProdLct} i = do- -- swap chidlren+ -- swap children VGM.unsafeModifyM lLct (VGM.unsafeExchange rLct i) i -- swap prodLct[i] and dualProdLct[i] VGM.unsafeModifyM prodLct (VGM.unsafeExchange dualProdLct i) i@@ -686,6 +849,7 @@ _ <- exposeST lct p pushNodeST lct p + -- no assertion and very unsafe.. -- dbgM $ do -- cp <- VGM.unsafeRead pLct c -- let !_ = ACIA.runtimeAssert (nullLct cp) $ "cp must be null: " ++ show (c, cp)@@ -698,6 +862,7 @@ VGM.unsafeWrite rLct p c updateNodeST lct p +-- no assertion and very unsafe.. {-# INLINEABLE cutST #-} cutST :: (Monoid a, VU.Unbox a) => Lct s a -> Vertex -> Vertex -> ST s () cutST lct@Lct {pLct, lLct} u v = do@@ -773,7 +938,7 @@ -- do -- -- FIXME: remove -- pRes <- VGM.unsafeRead pLct res- -- unless (nullLct pRes) $ error $ "xxx must be null!!! " ++ show (res, pRes)+ -- unless (nullLct pRes) $ error $ "must be null!!! " ++ show (res, pRes) splayST lct v0 @@ -802,7 +967,7 @@ splayST lct c' pure c' where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.rootST" c0 (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.rootST" c0 (nLct lct) {-# INLINEABLE parentST #-} parentST :: (HasCallStack, Monoid a, VU.Unbox a) => Lct s a -> Int -> ST s (Maybe Vertex)@@ -823,36 +988,35 @@ inner yr Just <$> inner xl where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.parentST" x (nLct lct)+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.parentST" x (nLct lct) -{-# INLINEABLE jumpST #-}-jumpST :: (HasCallStack, Monoid a, VU.Unbox a) => Lct s a -> Vertex -> Vertex -> Int -> ST s Vertex-jumpST lct@Lct {lLct, rLct, sLct} u0 v0 k0 = do+{-# INLINEABLE jumpMaybeST #-}+jumpMaybeST :: (HasCallStack, Monoid a, VU.Unbox a) => Lct s a -> Vertex -> Vertex -> Int -> ST s (Maybe Vertex)+jumpMaybeST lct@Lct {lLct, rLct, sLct} u0 v0 k0 = do -- make @v0@ a new root of the underlying tree evertST lct v0 -- make @u0@ in the same preferred path as the root (@v0) _ <- exposeST lct u0-- do- size <- VGM.unsafeRead sLct u0- let !_ = ACIA.runtimeAssert (0 <= k0 && k0 < size) "invalid jump"- pure ()-- let inner k u = do- pushNodeST lct u- -- TODO: what is happening?- ur <- VGM.unsafeRead rLct u- urSize <- if nullLct ur then pure 0 else VGM.unsafeRead sLct ur- case compare k urSize of- LT -> inner k ur- EQ -> pure u- GT -> do- ul <- VGM.unsafeRead lLct u- inner (k - (urSize + 1)) ul+ size <- VGM.unsafeRead sLct u0+ if 0 <= k0 && k0 < size+ then do+ let inner k u = do+ pushNodeST lct u+ -- TODO: what is happening?+ ur <- VGM.unsafeRead rLct u+ urSize <- if nullLct ur then pure 0 else VGM.unsafeRead sLct ur+ case compare k urSize of+ LT -> inner k ur+ EQ -> pure u+ GT -> do+ ul <- VGM.unsafeRead lLct u+ inner (k - (urSize + 1)) ul - res <- inner k0 u0- splayST lct res- pure res+ res <- inner k0 u0+ splayST lct res+ pure $ Just res+ else do+ pure Nothing {-# INLINEABLE prodSubtreeST #-} prodSubtreeST ::@@ -861,7 +1025,7 @@ Lct s a -> -- | Vertex Vertex ->- -- | Root or parent+ -- | Parent \(p\) (not need be adjacent to \(v\)), or same as \(v\), making it a new root. Vertex -> -- | Subtree's monoid product ST s a@@ -872,8 +1036,8 @@ evertST lct v VGM.unsafeRead subtreeProdLct v else do- -- @rootOrParent@ can be far. retrieve the adjacent vertex:- parent_ <- jumpST lct v rootOrParent 1+ -- retrieve the adjacent parent:+ parent_ <- fromJust <$> jumpMaybeST lct v rootOrParent 1 -- detach @v@ from the parent. now that it's the root of the subtree vertices, the aggregation -- value is the aggregation of all the subtree vertices. cutST lct v parent_@@ -882,5 +1046,15 @@ linkST lct v parent_ pure res where- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.prodSubtree" v nLct- !_ = ACIA.checkIndex "AtCoder.Extra.Lct.prodSubtree" rootOrParent nLct+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.prodSubtreeST" v nLct+ !_ = ACIA.checkIndex "AtCoder.Extra.Tree.Lct.prodSubtreeST" rootOrParent nLct++{-# INLINEABLE lengthBetweenST #-}+lengthBetweenST :: (HasCallStack, Monoid a, VU.Unbox a) => Lct s a -> Vertex -> Vertex -> ST s Int+lengthBetweenST lct@Lct {sLct} u0 v0 = do+ -- make @v0@ a new root of the underlying tree+ evertST lct v0+ -- make @u0@ in the same preferred path as the root (@v0)+ _ <- exposeST lct u0+ size <- VGM.unsafeRead sLct u0+ pure $ size - 1
src/AtCoder/Extra/Vector.hs view
@@ -1,35 +1,410 @@--- | Miscellaneous vector methods.+-- | Miscellaneous vector functions. These functions are __not__ the fastest implementations, but+-- fills in some lacking features. -- -- @since 1.2.2.0 module AtCoder.Extra.Vector- ( argsort,+ ( -- * Sort functions+ argsort,++ -- * Index compression+ compress,++ -- * Vector Utilities+ iconcatMap,+ concatMapM,+ iconcatMapM,+ mapAccumL,+ chunks,++ -- ** Monadic scanl+ prescanlM,+ prescanlM',+ postscanlM,+ postscanlM',+ scanlM,+ scanlM',+ scanl1M,+ scanl1M',++ -- * Queries+ maxRangeSum,+ minRangeSum,+ slideMinIndices,+ slideMaxIndices, ) where +-- TODO: maybe add lexicographic permutations, combinations, and subsequences.++import AtCoder.Internal.Assert qualified as ACIA+import AtCoder.Internal.Queue qualified as Q+import AtCoder.Extra.Bisect (lowerBound)+import Control.Monad (when)+import Control.Monad.Fix (fix)+import Control.Monad.Primitive (PrimMonad)+import Control.Monad.ST (ST, runST)+import Control.Monad.Trans.State.Strict (StateT, runStateT, state)+import Data.Ord (Down (..))+import Data.Vector qualified as V import Data.Vector.Algorithms.Intro qualified as VAI+import Data.Vector.Fusion.Bundle qualified as Bundle+import Data.Vector.Fusion.Bundle.Monadic qualified as BundleM+import Data.Vector.Fusion.Stream.Monadic qualified as S import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM import Data.Vector.Unboxed qualified as VU+import GHC.Stack (HasCallStack) --- | \(O(n \log n)\) Returns indices of the vector, stably sorted by their value.+-- | \(O(n \log n)\) Returns indices of the vector elements, stably sorted by their value. -- -- ==== Example--- >>> import Data.Vector.Algorithms.Intro qualified as VAI+-- >>> import AtCoder.Extra.Vector qualified as EV -- >>> import Data.Vector.Unboxed qualified as VU--- >>> argsort $ VU.fromList [0, 1, 0, 1, 0]+-- >>> EV.argsort $ VU.fromList @Int [0, 1, 0, 1, 0] -- [0,2,4,1,3] -- -- @since 1.2.3.0 {-# INLINEABLE argsort #-}-argsort :: (Ord a, VU.Unbox a) => VU.Vector a -> VU.Vector Int+-- TODO: use generic vector+argsort :: (HasCallStack, Ord a, VU.Unbox a) => VU.Vector a -> VU.Vector Int argsort xs = VU.modify- ( VAI.sortBy- ( \i j ->- ( compare (xs VG.! i) (xs VG.! j) <> compare i j- )- )- )+ (VAI.sortBy (\i j -> compare (xs VG.! i) (xs VG.! j) <> compare i j)) $ VU.generate (VU.length xs) id --- TODO: maybe add lexicographic permutations, combinations, and subsequences.+-- | \(O(n \log n)\) One dimensional index compression: xs -> (nubSortXs, xs')+--+-- ==== Example+-- >>> import AtCoder.Extra.Bisect (lowerBound)+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> let xs = VU.fromList [0, 20, 40, 10, 30]+-- >>> let (dict, xs') = EV.compress xs+-- >>> xs'+-- [0,2,4,1,3]+-- >>> lowerBound dict 10+-- 1+--+-- @since 1.5.1.0+{-# INLINE compress #-}+compress :: VU.Vector Int -> (VU.Vector Int, VU.Vector Int)+compress xs = (dict, VG.map (lowerBound dict) xs)+ where+ !dict = VG.uniq $ VG.modify VAI.sort xs +-- | Maps each element to a vector and concatenate the results.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.iconcatMap (\i x -> VU.fromList [i + x, i + x]) $ VU.replicate @Int 3 0+-- [0,0,1,1,2,2]+--+-- @since 1.5.1.0+{-# INLINE iconcatMap #-}+iconcatMap :: (HasCallStack, VG.Vector v a, VG.Vector v b) => (Int -> a -> v b) -> v a -> v b+iconcatMap f =+ VG.unstream+ . Bundle.concatVectors+ . Bundle.inplace (S.map (uncurry f) . S.indexed) id+ . VG.stream++-- | Maps each element to a vector and concatenate the results.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.iconcatMap (\x -> pure (VU.fromList [x, x])) $ VU.generate @Int 3 id+-- [0,0,1,1,2,2]+--+-- @since 1.5.1.0+{-# INLINE concatMapM #-}+concatMapM ::+ (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) =>+ (a -> m (v b)) ->+ v a ->+ m (v b)+concatMapM f =+ VG.unstreamM+ . BundleM.concatVectors+ . BundleM.mapM f+ . BundleM.fromVector++-- | Maps each element to a vector and concatenate the results.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.iconcatMapM (\i x -> pure (VU.fromList [i + x, i + x])) $ VU.replicate @Int 3 0+-- [0,0,1,1,2,2]+--+-- @since 1.5.1.0+{-# INLINE iconcatMapM #-}+iconcatMapM ::+ (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) =>+ (Int -> a -> m (v b)) ->+ v a ->+ m (v b)+iconcatMapM f =+ VG.unstreamM+ . BundleM.concatVectors+ . BundleM.mapM (uncurry f)+ . BundleM.indexed+ . BundleM.fromVector++-- | \(O(n)\) Maps a vector with an accumulator.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.mapAccumL (\s x -> (s + 1, s * x)) (0 :: Int) $ VU.generate @Int 4 id+-- (4,[0,1,4,9])+--+-- @since 1.5.1.0+{-# INLINE mapAccumL #-}+mapAccumL ::+ forall v s a b.+ (HasCallStack, VG.Vector v a, VG.Vector v b) =>+ (s -> a -> (s, b)) ->+ s ->+ v a ->+ (s, v b)+mapAccumL f s0 xs = (\(!x, !s) -> (s, x)) $ runST $ (`runStateT` s0) $ do+ unstreamPrimM+ . BundleM.mapM g+ $ BundleM.fromVector xs+ where+ g :: forall st. a -> StateT s (ST st) b+ g a =+ state+ ( \s ->+ let (!s', !b) = f s a+ in (b, s')+ )++-- | https://github.com/haskell/vector/issues/416+{-# INLINE [1] unstreamPrimM #-}+unstreamPrimM :: (PrimMonad m, VG.Vector v a) => BundleM.Bundle m u a -> m (v a)+unstreamPrimM s = VGM.munstream s >>= VG.unsafeFreeze++-- | @since 1.5.1.0+{-# INLINE prescanlM #-}+prescanlM :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+prescanlM f x0 =+ VG.unstreamM+ . prescanlMB f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE prescanlM' #-}+prescanlM' :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+prescanlM' f x0 =+ VG.unstreamM+ . prescanlMB' f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE postscanlM #-}+postscanlM :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+postscanlM f x0 =+ VG.unstreamM+ . postscanlMB f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE postscanlM' #-}+postscanlM' :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+postscanlM' f x0 =+ VG.unstreamM+ . postscanlMB' f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE scanlM #-}+scanlM :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+scanlM f x0 =+ VG.unstreamM+ . scanlMB f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE scanlM' #-}+scanlM' :: (HasCallStack, Monad m, VG.Vector v a, VG.Vector v b) => (a -> b -> m a) -> a -> v b -> m (v a)+scanlM' f x0 =+ VG.unstreamM+ . scanlMB' f x0+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE scanl1M #-}+scanl1M :: (HasCallStack, Monad m, VG.Vector v a) => (a -> a -> m a) -> v a -> m (v a)+scanl1M f =+ VG.unstreamM+ . scanl1MB f+ . VG.stream++-- | @since 1.5.1.0+{-# INLINE scanl1M' #-}+scanl1M' :: (HasCallStack, Monad m, VG.Vector v a) => (a -> a -> m a) -> v a -> m (v a)+scanl1M' f =+ VG.unstreamM+ . scanl1MB' f+ . VG.stream++{-# INLINE prescanlMB #-}+prescanlMB :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+prescanlMB f x0 = BundleM.prescanlM f x0 . Bundle.lift++{-# INLINE prescanlMB' #-}+prescanlMB' :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+prescanlMB' f x0 = BundleM.prescanlM' f x0 . Bundle.lift++{-# INLINE postscanlMB #-}+postscanlMB :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+postscanlMB f x0 = BundleM.postscanlM f x0 . Bundle.lift++{-# INLINE postscanlMB' #-}+postscanlMB' :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+postscanlMB' f x0 = BundleM.postscanlM' f x0 . Bundle.lift++{-# INLINE scanlMB #-}+scanlMB :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+scanlMB f x0 = BundleM.scanlM f x0 . Bundle.lift++{-# INLINE scanlMB' #-}+scanlMB' :: (Monad m) => (a -> b -> m a) -> a -> Bundle.Bundle v b -> BundleM.Bundle m v a+scanlMB' f x0 = BundleM.scanlM' f x0 . Bundle.lift++{-# INLINE scanl1MB #-}+scanl1MB :: (Monad m) => (a -> a -> m a) -> Bundle.Bundle v a -> BundleM.Bundle m v a+scanl1MB f = BundleM.scanl1M f . Bundle.lift++{-# INLINE scanl1MB' #-}+scanl1MB' :: (Monad m) => (a -> a -> m a) -> Bundle.Bundle v a -> BundleM.Bundle m v a+scanl1MB' f = BundleM.scanl1M' f . Bundle.lift++-- | \(O(n)\) Converts a vector into chunks of vectors with lenth \(k\). The last vector may have+-- smaller length than \(k\).+--+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.chunks 3 $ VU.fromList ([1, 2, 3, 4, 5, 6, 7] :: [Int])+-- [[1,2,3],[4,5,6],[7]]+--+-- @since 1.5.1.0+{-# INLINE chunks #-}+chunks :: (VG.Vector v a) => Int -> v a -> V.Vector (v a)+chunks len xs0 = V.unfoldrExactN n step xs0+ where+ n = (VG.length xs0 + len - 1) `div` len+ step xs = (VG.take len xs, VG.drop len xs)++-- | \(O(n)\) Returns maximum range sum.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.maxRangeSum $ VU.fromList @Int [-3, 1, 6, -2, 7, -5]+-- 12+--+-- @since 1.5.1.0+{-# INLINE maxRangeSum #-}+maxRangeSum :: forall v a. (VG.Vector v a, Ord a, Num a) => v a -> a+maxRangeSum xs = fst $ VG.foldl' f (0 :: a, 0 :: a) csum+ where+ csum = VG.postscanl' (+) (0 :: a) xs+ f (!acc, !minL) x = (max acc (x - minL), min minL x)++-- | \(O(n)\) Returns minimum range sum.+--+-- ==== Example+-- >>> import AtCoder.Extra.Vector qualified as EV+-- >>> import Data.Vector.Unboxed qualified as VU+-- >>> EV.minRangeSum $ VU.fromList @Int[-3, 1, 6, -20, 7, -9]+-- -22+--+-- @since 1.5.1.0+{-# INLINE minRangeSum #-}+minRangeSum :: forall v a. (VG.Vector v a, Ord a, Num a) => v a -> a+minRangeSum xs = fst $ VG.foldl' f (0 :: a, 0 :: a) csum+ where+ csum = VG.postscanl' (+) (0 :: a) xs+ f (!acc, !maxL) x = (min acc (x - maxL), max maxL x)++-- | \(O(N)\) Returns indices of minimum values in the windows with the specified length.+--+-- ==== Constraints+-- - \(k \gt 0\)+--+-- ==== Example+--+-- >>> slideMinIndices 3 (VU.fromList [0 .. 5])+-- [0,1,2,3]+-- >>> slideMinIndices 3 (VU.fromList [5, 4 .. 0])+-- [2,3,4,5]+--+-- @since 1.5.1.0+{-# INLINE slideMinIndices #-}+slideMinIndices :: (HasCallStack) => Int -> VU.Vector Int -> VU.Vector Int+slideMinIndices k xs+ | VU.null xs = VU.empty+ | k >= VU.length xs = VU.singleton $ VU.minIndex xs+ | otherwise = slideCmpIndicesOn Down k xs+ where+ !_ = ACIA.runtimeAssert (k > 0) "AtCoder.Extra.Vector.slideMinIndices: given non-positive k"++-- | \(O(N)\) Returns indices of maximum values in the windows with the specified length.+--+-- ==== Constraints+-- - \(k \gt 0\)+--+-- ==== Example+--+-- @+-- indices: 0 1 2 3 4 5+-- values: 0 1 2 3 4 5 max value indices:+-- [---] 2+-- [---] 3+-- [---] 4+-- [---] 5+-- @+--+-- >>> slideMaxIndices 3 (VU.fromList [0 .. 5])+-- [2,3,4,5]+-- >>> slideMaxIndices 3 (VU.fromList [5, 4 .. 0])+-- [0,1,2,3]+--+-- @since 1.5.1.0+{-# INLINE slideMaxIndices #-}+slideMaxIndices :: (HasCallStack) => Int -> VU.Vector Int -> VU.Vector Int+slideMaxIndices k xs+ | VU.null xs = VU.empty+ | k >= VU.length xs = VU.singleton $ VU.maxIndex xs+ | otherwise = slideCmpIndicesOn id k xs+ where+ !_ = ACIA.runtimeAssert (k > 0) "AtCoder.Extra.Vector.slideMaxIndices: given non-positive k"++-- | \(O(N)\) (1) in <https://qiita.com/kuuso1/items/318d42cd089a49eeb332>+{-# INLINE slideCmpIndicesOn #-}+slideCmpIndicesOn :: (VG.Vector v a, Ord b) => (a -> b) -> Int -> v a -> VU.Vector Int+slideCmpIndicesOn wrap len xs = runST $ do+ -- dequeue of maximum number indices.+ !buf <- Q.new (VG.length xs)++ fmap (VU.drop (len - 1)) $ VG.generateM (VG.length xs) $ \i -> do+ -- remove the front indices that are no longer in the span+ fix $ \loop -> do+ b <- maybe False (<= i - len) <$> Q.readMaybeFront buf 0+ when b $ do+ Q.popFront_ buf+ loop++ -- remove the last indices that are less attractive to the new coming value+ fix $ \loop -> do+ b <- maybe False ((< wrap (xs VG.! i)) . wrap . (xs VG.!)) <$> Q.readMaybeBack buf 0+ when b $ do+ Q.popBack_ buf+ loop++ Q.pushBack buf i+ Q.readFront buf 0
src/AtCoder/Internal/Csr.hs view
@@ -43,6 +43,7 @@ -- * Accessors adj, adjW,+ adj1, eAdj, eAdjW, )@@ -157,6 +158,16 @@ let il = startCsr VG.! i ir = startCsr VG.! (i + 1) in VU.zip (VU.slice il (ir - il) adjCsr) (VU.slice il (ir - il) wCsr)++-- | \(O(1)\) Returns the adjacent vertices with \(1\) weights.+--+-- @since 1.5.1.0+{-# INLINE adj1 #-}+adj1 :: (HasCallStack, VU.Unbox w) => Csr w -> Int -> VU.Vector (Int, Int)+adj1 Csr {..} i =+ let il = startCsr VG.! i+ ir = startCsr VG.! (i + 1)+ in VU.zip (VU.slice il (ir - il) adjCsr) (VU.replicate (ir - il) 1) -- | \(O(n)\) Returns a vector of @(csrEdgeIndex, adjacentVertex)@. --
test/Main.hs view
@@ -32,6 +32,9 @@ import Tests.Extra.Semigroup.Permutation qualified import Tests.Extra.Seq qualified import Tests.Extra.Seq.Map qualified+import Tests.Extra.Tree qualified+import Tests.Extra.Tree.Lct qualified+import Tests.Extra.Vector qualified import Tests.Extra.WaveletMatrix qualified import Tests.Extra.WaveletMatrix.BitVector qualified import Tests.Extra.WaveletMatrix.Raw qualified@@ -91,6 +94,9 @@ testGroup "Semigroup.Permutation" Tests.Extra.Semigroup.Permutation.tests, testGroup "Seq" Tests.Extra.Seq.tests, testGroup "Seq.Map" Tests.Extra.Seq.Map.tests,+ testGroup "Tree" Tests.Extra.Tree.tests,+ testGroup "Tree.Lct" Tests.Extra.Tree.Lct.tests,+ testGroup "Vector" Tests.Extra.Vector.tests, testGroup "WaveletMatrix" Tests.Extra.WaveletMatrix.tests, testGroup "WaveletMatrix.BitVector" Tests.Extra.WaveletMatrix.BitVector.tests, testGroup "WaveletMatrix.Raw" Tests.Extra.WaveletMatrix.Raw.tests,
test/Tests/Extra/KdTree.hs view
@@ -33,7 +33,7 @@ -- n <- QC.chooseInt (1, 256) n <- QC.chooseInt (1, 8) -- q <- QC.chooseInt (1, 256)- q <- QC.chooseInt (1, 4)+ q <- QC.chooseInt (1, 32) refVec <- (VU.fromList <$>) $ QC.vectorOf n $ do x <- QC.chooseInt rng y <- QC.chooseInt rng
test/Tests/Extra/LazyKdTree.hs view
@@ -44,7 +44,7 @@ instance QC.Arbitrary Init where arbitrary = do n <- QC.chooseInt (1, 256)- q <- QC.chooseInt (1, 256)+ q <- QC.chooseInt (1, 1024) xyws <- (VU.fromList <$>) $ QC.vectorOf n $ do x <- QC.chooseInt rng y <- QC.chooseInt rng
+ test/Tests/Extra/Tree.hs view
@@ -0,0 +1,27 @@+module Tests.Extra.Tree where++import AtCoder.Extra.Graph qualified as Gr+import AtCoder.Extra.Tree qualified as Tree+import Data.Bit (Bit (..))+import Data.Ord (Down (..), comparing)+import Data.Semigroup (Sum (..))+import Data.Vector.Unboxed qualified as VU+import Test.Tasty+import Test.Tasty.HUnit++unit_one :: TestTree+unit_one = testCase "one" $ do+ let n = 1+ let !t = Gr.build @Int n VU.empty+ Tree.diameter n (Gr.adjW t) (-1) @?= ((0, 0), 0)+ Tree.diameterPath 1 (Gr.adjW t) (-1) @?= (VU.singleton 0, 0)+ Tree.mst n (VU.singleton (0, 0, 100)) @?= (0, VU.singleton (Bit False), t)+ Tree.mstBy (comparing Down) 1 (VU.singleton (0, 0, 100)) @?= (0, VU.singleton (Bit False), t)+ Tree.fold (Gr.adjW t) (const (Sum (10 :: Int))) (\(Sum a) (!_, !dw) -> Sum (a + dw)) (<>) 0 @?= 10+ Tree.scan n (Gr.adjW t) (const (Sum (10 :: Int))) (\(Sum a) (!_, !dw) -> Sum (a + dw)) (<>) 0 @?= VU.singleton 10+ Tree.foldReroot n (Gr.adjW t) (const (Sum (10 :: Int))) (\(Sum a) (!_, !dw) -> Sum (a + dw)) (<>) @?= VU.singleton 10++tests :: [TestTree]+tests =+ [ unit_one+ ]
+ test/Tests/Extra/Tree/Lct.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE RecordWildCards #-}++-- | Not complete!+module Tests.Extra.Tree.Lct where++import AtCoder.Extra.Graph qualified as Gr+import AtCoder.Extra.Tree.Lct (Lct (..))+import AtCoder.Extra.Tree.Lct qualified as Lct+import AtCoder.Internal.Buffer qualified as B+import Control.Monad (when)+import Control.Monad.Primitive (PrimMonad, PrimState)+import Data.Foldable (for_)+import Data.Maybe (isJust, fromJust)+import Data.Semigroup (Sum (..))+import Data.Vector qualified as V+import Data.Vector.Generic qualified as VG+import Data.Vector.Generic.Mutable qualified as VGM+import Data.Vector.Unboxed qualified as VU+import Data.Vector.Unboxed.Mutable qualified as VUM+import Test.QuickCheck.Monadic as QCM+import Test.Tasty+import Test.Tasty.QuickCheck as QC++-- | Maximum number of vertices.+maxN :: Int+maxN = 16++-- | Maximum number of queries.+maxQ :: Int+maxQ = 1000++-- | Range of monoid value.+rng :: (Int, Int)+rng = (-rngI, rngI)++-- | Range of monoid value.+rngI :: Int+rngI = 10++data Init s = Init+ { n :: {-# UNPACK #-} !Int,+ q :: {-# UNPACK #-} !Int,+ initialMonoids :: {-# UNPACK #-} !(VU.Vector (Sum Int)),+ refM :: !(IO Ref),+ lctM :: !(IO (Lct.Lct s (Sum Int)))+ }++-- | Referencial implementation+data Ref = Ref+ { nR :: {-# UNPACK #-} !Int,+ -- | Monoid values+ vecR :: !(VUM.MVector VUM.RealWorld (Sum Int)),+ -- | NxN+ edgeR :: !(VUM.MVector VUM.RealWorld Bool)+ }++newRef :: Int -> VU.Vector (Sum Int) -> IO Ref+newRef nR xs = do+ vecR <- VU.thaw xs+ edgeR <- VUM.replicate (nR * nR) False+ pure Ref {..}++instance Show (Init s) where+ show Init {..} = show (n, q, initialMonoids)++instance QC.Arbitrary (Init VUM.RealWorld) where+ arbitrary = do+ n <- QC.chooseInt (1, maxN)+ q <- QC.chooseInt (1, maxQ)+ initialMonoids <- (VU.fromList <$>) $ QC.vectorOf n (Sum <$> QC.chooseInt rng)+ let lctM = Lct.buildInv negate initialMonoids VU.empty+ let refM = let nR = n in newRef n initialMonoids+ pure Init {..}++data Query+ = Read Int+ | Write Int (Sum Int)+ | Modify Int (Sum Int)+ | ModifyM Int (Sum Int)+ | Link Int Int+ | Cut Int Int+ | Evert Int+ | Expose Int+ | Expose_ Int+ | -- | Root Int+ Same Int Int+ | -- TODO: Test parent!++ -- | Parent Int+ -- | Jump+ JumpMaybe Int Int Int+ | LengthBetween Int Int+ | -- | Lca Int Int+ -- | LcaMaybe Int Int+ ProdPath Int Int+ | ProdSubtree Int Int+ -- -- | ProdTree Int Int+ deriving (Eq, Show)++-- | Arbitrary return type for the `Query` result.+data Result+ = None+ | I !Int+ | MI !(Maybe Int)+ | B Bool+ | SI (Sum Int)+ deriving (Show, Eq)++queryGen :: Int -> QC.Gen Query+queryGen n =+ QC.oneof+ [ Read <$> u,+ Write <$> u <*> x,+ Modify <$> u <*> x,+ ModifyM <$> u <*> x,+ Link <$> u <*> v,+ Cut <$> u <*> v,+ Evert <$> u,+ Expose <$> u,+ Expose_ <$> u,+ -- \| Root <$> Int+ Same <$> u <*> v,+ -- \| Parent <$> Int+ -- \| Jump+ JumpMaybe <$> u <*> v <*> k,+ LengthBetween <$> u <*> v,+ -- Lca <$> u <*> v,+ -- LcaMaybe <$> u <*> v,+ ProdPath <$> u <*> v+ -- TODO: test prod subtree+ -- ProdSubtree <$> u <*> v+ ]+ where+ u = QC.chooseInt (0, n - 1)+ v = QC.chooseInt (0, n - 1)+ x = Sum <$> QC.chooseInt rng+ k = QC.chooseInt (-1, n)++toCsrM :: Ref -> IO (Gr.Csr ())+toCsrM Ref {..} = do+ es <- VU.unsafeFreeze edgeR+ let uvs = (`VU.mapMaybe` VU.generate (nR * nR) id) $ \i ->+ let (!u, !v) = i `divMod` nR+ in if u /= v && es VG.! (nR * u + v)+ then Just (u, v)+ else Nothing+ pure $ Gr.build' nR uvs++findPath :: Gr.Csr () -> Int -> Int -> Maybe (VU.Vector Int)+findPath gr v1 v2+ | ws VG.! v2 == -1 = Nothing+ | otherwise = Just $ Gr.constructPathFromRoot tree v2+ where+ (!ws, !tree) = Gr.trackingBfs (Gr.nCsr gr) grF (-1 :: Int) src+ grF = Gr.adj1 gr+ src = VU.singleton (v1, 0)++-- | containers. (referencial implementation)+handleRef :: Ref -> Query -> IO Result+handleRef ref@Ref {..} q = do+ case q of+ Read i -> do+ SI <$> VGM.read vecR i+ Write i x -> do+ VGM.write vecR i x+ pure None+ Modify i x -> do+ VGM.modify vecR (+ x) i+ pure None+ ModifyM i x -> do+ VGM.modifyM vecR (pure . (+ x)) i+ pure None+ Link u v -> do+ VGM.write edgeR (nR * u + v) True+ VGM.write edgeR (nR * v + u) True+ pure None+ Cut u v -> do+ VGM.write edgeR (nR * u + v) False+ VGM.write edgeR (nR * v + u) False+ pure None+ Evert _ -> do+ pure None+ Expose _ -> do+ pure None+ Expose_ _ -> do+ pure None+ -- \| Root Int+ Same u v -> do+ gr <- toCsrM ref+ pure . B . isJust $ findPath gr u v+ -- \| Parent Int+ -- \| Jump+ JumpMaybe u v k -> do+ gr <- toCsrM ref+ case findPath gr u v of+ Nothing -> pure $ MI Nothing+ Just path -> pure . MI $ path VG.!? k+ LengthBetween u v -> do+ gr <- toCsrM ref+ let !path = fromJust $ findPath gr u v+ pure . I $ VU.length path - 1+ -- LcaMaybe u v -> do+ -- gr <- toCsrM ref+ -- -- FIXME: HLD cannot be used+ -- let connected = isJust $ findPath gr u v+ -- if connected+ -- then pure . MI . Just $ Hld.lca (Hld.new gr) u v+ -- else pure $ MI Nothing+ ProdPath u v -> do+ gr <- toCsrM ref+ ws <- VU.unsafeFreeze vecR+ case findPath gr u v of+ Nothing -> pure $ SI mempty+ Just path -> pure . SI $ VU.foldMap (ws VG.!) path+ ProdSubtree u v -> do+ -- TODO: fix this+ pure None++-- | ACL+handleAcl :: (PrimMonad m) => Lct (PrimState m) (Sum Int) -> Query -> m Result+handleAcl lct q = case q of+ Read i -> do+ SI <$> Lct.read lct i+ Write i x -> do+ Lct.write lct i x+ pure None+ Modify i x -> do+ Lct.modify lct (+ x) i+ pure None+ ModifyM i x -> do+ Lct.modifyM lct (pure . (+ x)) i+ pure None+ Link u v -> do+ -- TODO: detect if already connect+ Lct.link lct u v+ pure None+ Cut u v -> do+ Lct.cut lct u v+ pure None+ Evert i -> do+ Lct.evert lct i+ pure None+ Expose i -> do+ _ <- Lct.expose lct i+ pure None+ Expose_ i -> do+ Lct.expose_ lct i+ pure None+ -- \| Root Int+ Same u v -> do+ B <$> Lct.same lct u v+ -- \| Parent Int+ -- \| Jump+ JumpMaybe u v k -> do+ MI <$> Lct.jumpMaybe lct u v k+ LengthBetween u v -> do+ I <$> Lct.lengthBetween lct u v+ -- LcaMaybe u v -> do+ -- MI <$> Lct.lcaMaybe lct u v+ ProdPath u v -> do+ SI <$> Lct.prodPath lct u v+ ProdSubtree u v -> do+ SI <$> Lct.prodSubtree lct u v++prop_randomTest :: Init VUM.RealWorld -> QC.Property+prop_randomTest Init {..} = QCM.monadicIO $ do+ lct <- QCM.run lctM+ ref <- QCM.run refM+ qs <- QCM.pick $ QC.vectorOf q (queryGen n)+ record <- QCM.run $ B.new q+ for_ qs $ \query -> do+ b <- QCM.run $ filterRefM ref query+ when b $ do+ QCM.run $ B.pushBack record $ VU.DoNotUnboxStrict query+ record' <- QCM.run $ B.unsafeFreeze record+ expected <- QCM.run $ handleRef ref query+ result <- QCM.run $ handleAcl lct query+ when (expected /= result) $ do+ -- show all the run queries on failure+ let s = show . V.map (\(VU.DoNotUnboxStrict x) -> x) $ VU.convert record'+ QCM.monitor $ QC.counterexample $ "actual queries in use: " ++ s+ QCM.assertWith (expected == result) $ show (query, expected, result)++-- | Filter invalid queries+filterRefM :: Ref -> Query -> IO Bool+filterRefM ref@Ref {..} q = case q of+ Read _ -> pure True+ Write _ _ -> pure True+ Modify _ _ -> pure True+ ModifyM _ _ -> pure True+ Link u v+ | u == v -> pure False+ | otherwise -> not <$> same u v+ Cut u v -> do+ es <- VU.unsafeFreeze edgeR+ pure $ es VG.! (nR * u + v)+ Evert _ -> pure True+ Expose _ -> pure True+ Expose_ _ -> pure True+ Same _ _ -> pure True+ JumpMaybe u v _ -> same u v+ LengthBetween u v -> same u v+ -- LcaMaybe u v -> same u v+ ProdPath u v -> same u v+ ProdSubtree u v -> same u v+ where+ same u v = do+ gr <- toCsrM ref+ let connected = isJust $ findPath gr u v+ pure connected++tests :: [TestTree]+tests =+ [ QC.testProperty "randomTest" prop_randomTest+ ]