diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for data-findcycle +## 0.1.1.0 -- 2025-04-24 + +* Add `nivashPart` and `nivashPartWithinBounds` as variants of `nivash` using + stack partitioning. +* Minor documentation fixes and improvements. + ## 0.1.0.0 -- 2025-03-08 * First version. Released on an unsuspecting world. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -3,11 +3,13 @@ {-# LANGUAGE RecordWildCards #-} import Control.DeepSeq +import Data.Bits ((.&.)) import Data.FindCycle import Data.Foldable (find) import Data.List (intercalate) import Data.Maybe import Data.Numbers.Primes +import Data.Word import GHC.Generics import Test.Tasty.Bench import Test.Tasty.Patterns.Printer @@ -87,6 +89,8 @@ [ ("brent", brent) , ("floyd", floyd) , ("nivash", nivash) + , ("nivashPart", nivashPart (fromIntegral :: Int -> Word8)) + , ("nivashPartWithinBounds", nivashPartWithinBounds (0, 0xff) (.&. 0xff)) , ("naiveHashable", naiveHashable) , ("naiveOrd", naiveOrd) ] diff --git a/data-findcycle.cabal b/data-findcycle.cabal --- a/data-findcycle.cabal +++ b/data-findcycle.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: data-findcycle -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Find cycles in periodic functions (and lists) description: Any function @f :: a -> a@ where the type @a@ has finitely many values @@ -29,7 +29,13 @@ base >= 4.7 && < 4.23, containers >= 0.5 && < 0.9, hashable >= 1.2 && < 1.6, - unordered-containers >= 0.2 && < 0.3 + unordered-containers >= 0.2 && < 0.3, + mtl >= 2.1 && < 2.4, + array >= 0.5 && < 0.6 + -- Data.Functor.Identity used to be in transformers instead of base. + if impl(ghc<7.10.1) + build-depends: + transformers >= 0.3 && < 0.5 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Data/FindCycle.hs b/src/Data/FindCycle.hs --- a/src/Data/FindCycle.hs +++ b/src/Data/FindCycle.hs @@ -1,5 +1,12 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {- | Module: Data.FindCycle @@ -108,6 +115,8 @@ -- ** Memory/Time Compromise nivash, + nivashPart, + nivashPartWithinBounds, -- * Running algorithms findCycle, @@ -121,13 +130,21 @@ ) where import Control.Applicative ((<*>), (<|>)) +import Control.Monad.ST +import qualified Data.Array.ST as A import Data.Functor ((<$), (<$>)) +import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable) import qualified Data.Map.Strict as M import Data.Maybe (fromJust, fromMaybe) -import Prelude hiding ((<$), (<$>), (<*>)) +import Data.Traversable (traverse) +import Prelude hiding (traverse, (<$), (<$>), (<*>)) +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind (Type) +#endif + data Input s a = Input { inpUncons :: s -> Maybe (a, s) , inpAdvance :: Int -> s -> s @@ -253,14 +270,16 @@ The lazy list might also be evaluated further than \(\mu + \lambda\) depending on the cycle finding algorithm chosen ('brent', 'floyd'). - >>> f x = x^42 `mod` 1000003 -- cycle (1, 83333) + >>> -- cycle μ=1, λ=83333 when starting from 23 + >>> let f :: Integer -> Integer; f x = x^(42 :: Int) `mod` 1000003 + >>> >>> g = cycleExp nivash f 23 >>> g 0 -- after 0 iterations - > 23 + 23 >>> -- after a googol iterations, but finishes in less than the current >>> -- age of the universe - >>> g (10^100) - > 671872 + >>> g (10^(100 :: Int)) + 671872 -} cycleExp :: CycleFinder a -> (a -> a) -> a -> Integer -> a cycleExp alg f x = cycleExpWith alg listInput (iterate f x) @@ -322,21 +341,56 @@ brent :: (Eq a) => CycleFinder a brent = CycleFinder brent' +#if __GLASGOW_HASKELL__ < 800 +#define Type * +#endif + +class NivashSt st m where + type State st m a :: Type + newSt :: st a -> m (State st m a) + checkSt :: (Ord a) => st a -> a -> Int -> State st m a -> m (Either Int (State st m a)) + +#undef Type + +data NivashStack a = NivashStack + +instance (Monad m) => NivashSt NivashStack m where + type State NivashStack m a = [(a, Int)] + newSt _ = return [] + {-# INLINE checkSt #-} + checkSt _ x i xs + | (sx, si) : _ <- xs', sx == x = return (Left si) + | otherwise = return . Right $ (x, i) : xs' + where + xs' = dropWhile ((> x) . fst) xs + +data NivashMultiStack st k a = NivashMultiStack + { partBounds :: (k, k) + , partF :: a -> k + , partDelegate :: st a + } + +instance (A.Ix k, NivashSt st (ST s)) => NivashSt (NivashMultiStack st k) (ST s) where + type State (NivashMultiStack st k) (ST s) a = A.STArray s k (State st (ST s) a) + newSt NivashMultiStack{..} = newSt partDelegate >>= A.newArray partBounds + {-# INLINE checkSt #-} + checkSt NivashMultiStack{..} x i stacks = + A.readArray stacks k + >>= checkSt partDelegate x i + >>= traverse ((stacks <$) . A.writeArray stacks k) + where + k = partF x + {-# INLINE nivash' #-} --- TODO: add a variant with stack partitioning, probably requiring a partitioning --- function as an extra argument. this version can use (const 0). -nivash' :: (Ord a) => Input s a -> s -> (Int, Int) -nivash' Input{..} = go 0 [] +nivash' :: (Ord a, NivashSt st m, Monad m) => st a -> Input s a -> s -> m (Int, Int) +nivash' stack Input{..} = (newSt stack >>=) . flip (go 0) where - go i stack = maybe (i, 0) (uncurry go') . inpUncons + go i st = maybe (return (i, 0)) (uncurry go') . inpUncons where - go' x s - | (sx, si) : _ <- stack', sx == x = (si, i - si) - | otherwise = go (i + 1) ((x, i) : stack') s - where - stack' = dropWhile ((> x) . fst) stack - --- TODO: Gosper? maybe not really that useful in practice. + go' x s = + checkSt stack x i st >>= \case + Left si -> return (si, i - si) + Right st' -> go (i + 1) st' s {- | Nivash's cycle finding algorithm. @@ -353,8 +407,61 @@ * [G. Nivasch, "Cycle detection using a stack", Information Processing Letters 90/3, pp. 135-140, 2004.](https://drive.google.com/file/d/16H_lrjeaBJqWvcn07C_w-6VNHldJ-ZZl/view) -} nivash :: (Ord a) => CycleFinder a -nivash = CycleFinder nivash' +nivash = CycleFinder $ (runIdentity .) . nivash' NivashStack +{- $ + >>> :seti -XDataKinds -XTypeApplications -XFlexibleContexts +-} + +{- | + Like 'nivash', but uses multiple independent stacks as determined by a partitioning + function. + + This trades off some additional memory usage for the ability to detect cycles earlier + in the sequence. + + Using \(k\) stacks, the cycle will be identified after, on average, a fraction of + \(\dfrac{1}{k+1}\) of the cycle length. E.g 50% above the absolute minimum achievable + for \(k=1\) ('nivash' without partitioning), or 1% above that minimum for \(k=99\). + + The entire range of @k@ will be used for partitioning, with each value from 'minBound' + to 'maxBound' having its own partition. Use a type appropriate for the number of + partitions you'd like to use. Use 'nivashPartWithinBounds' if you'd like to explicitly + use a continuous subrange of @k@ instead. + + >>> import Data.Word (Word8) + >>> let alg256 = nivashPart (fromIntegral :: Integer -> Word8) + + >>> import Data.Finite (modulo) -- >= 0.2 for the Ix instance + >>> let alg100 = nivashPart (modulo @100) +-} +nivashPart :: (A.Ix k, Bounded k, Ord a) => (a -> k) -> CycleFinder a +nivashPart = nivashPartWithinBounds (minBound, maxBound) + +{- | + Like 'nivashPart', but allows for a specific continuous subrange of @k@ to be used for + partitioning rather than creating a partition for each possible value of @k@. + + >>> let alg100 = nivashPartWithinBounds (0, 99) (`mod` 100) +-} +nivashPartWithinBounds :: + forall k a. + (A.Ix k, Ord a) => + {- | + the lower and upper bound (inclusive), respectively, of the partition keys + returned by the partition function + -} + (k, k) -> + {- | + the partition function. Returning values outside of the specified bounds will + cause run-time errors. + -} + (a -> k) -> + CycleFinder a +nivashPartWithinBounds bounds f = CycleFinder $ \inp s -> + runST $ nivash' (NivashMultiStack bounds f NivashStack) inp s + +-- TODO: Gosper? maybe not really that useful in practice. -- TODO: Sedgewick, Szymanski, Yao {-# INLINE floyd' #-} @@ -396,9 +503,10 @@ if you're running the t'CycleFinder' using any of the functions which cache the sequence of values (any but 'findCycle' and 'cycleExp''). -} -minimalMu :: (Eq a) => CycleFinder a -> CycleFinder a +minimalMu :: forall a. (Eq a) => CycleFinder a -> CycleFinder a minimalMu alg = CycleFinder go where + go :: forall s. Input s a -> s -> (Int, Int) go inp@Input{..} s = maybeFindMu (runCycleFinder alg inp s) where maybeFindMu r@(_, lambda) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import Data.Functor ((<$>)) import Data.Maybe import Data.Numbers.Primes +import Data.Word import Test.Tasty import Test.Tasty.QuickCheck import Prelude hiding (Foldable, foldMap, (<$>), (<*>)) @@ -62,7 +63,9 @@ partialAlgs = AlgClass (Labeled "nivash" nivash) - [ Labeled "brent" brent + [ Labeled "nivashPart" (nivashPart (fromIntegral :: Integer -> Word8)) + , Labeled "nivashPartWithinBounds" (nivashPartWithinBounds (0, 99) (`mod` 100)) + , Labeled "brent" brent , Labeled "floyd" floyd ]