data-findcycle (empty) → 0.1.0.0
raw patch · 6 files changed
+809/−0 lines, 6 filesdep +QuickCheckdep +basedep +containers
Dependencies added: QuickCheck, base, containers, data-findcycle, deepseq, hashable, primes, tasty, tasty-bench, tasty-quickcheck, unordered-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- bench/Main.hs +109/−0
- data-findcycle.cabal +63/−0
- src/Data/FindCycle.hs +412/−0
- test/Main.hs +200/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for data-findcycle++## 0.1.0.0 -- 2025-03-08++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2025 Florian Ragwitz++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.
+ bench/Main.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}++import Control.DeepSeq+import Data.FindCycle+import Data.Foldable (find)+import Data.List (intercalate)+import Data.Maybe+import Data.Numbers.Primes+import GHC.Generics+import Test.Tasty.Bench+import Test.Tasty.Patterns.Printer++data CycleSpec = CycleSpec {cycMu, cycLambda, cycDelay :: Int}++instance Show CycleSpec where+ show CycleSpec{..} =+ intercalate+ ","+ [ showParam "mu" cycMu+ , showParam "lambda" cycLambda+ , showParam "delay" cycDelay+ ]+ where+ showParam s v = concat [s, "=", show v]++data Cycle = Cycle {cycF :: Int -> Int, cycX0 :: Int}+ deriving (Generic, NFData)++mkCycle :: CycleSpec -> Cycle+mkCycle CycleSpec{..} = Cycle (delayed cycDelay f) (g 0)+ where+ n = cycMu + cycLambda+ m = fromJust $ find (> n) primes+ a = 123457+ b = 98765+ g i = (a * i + b) `mod` m+ f x+ | i < n - 1 = g (i + 1)+ | otherwise = g cycMu+ where+ i = (modInv a m * ((x - b) `mod` m)) `mod` m+ modInv 1 _ = 1+ modInv x y = (i * y + 1) `div` x+ where+ i = x - modInv (y `mod` x) x++{-# NOINLINE delayed #-}+delayed :: Int -> (a -> b) -> (a -> b)+delayed n f x = countTo n `seq` f x+ where+ countTo 0 = ()+ countTo i = countTo (i - 1)++main :: IO ()+main = defaultMain [mapLeafBenchmarks compareBrent benchmark]+ where+ compareBrent (name : xs)+ | name /= "brent" = bcompare (printAwkExpr (locateBenchmark ("brent" : xs)))+ compareBrent _ = id++cycles :: [CycleSpec]+cycles =+ [ CycleSpec mu lambda delay+ | mu <- [0, 10000, 1000000]+ , lambda <- [10000, 1000000]+ , delay <- [0, 10, 100, 1000]+ ]++runners :: [(String, CycleFinder Int -> Cycle -> Benchmarkable)]+runners =+ [ ("findCycle", nf . runAlg findCycle)+ , ("findExtractCycle", nf . runAlg findCycleExtract)+ , ("findExtractCycle+drop", nf . (dropLists .) . runAlg findCycleExtract)+ ,+ ( "unsafeFindCycleFromList"+ , nf . runAlg (\alg -> (unsafeFindCycleFromList alg .) . iterate)+ )+ ]+ where+ runAlg f alg Cycle{..} = f alg cycF cycX0+ dropLists (a, b, _) = (a, b)++algs :: [(String, CycleFinder Int)]+algs =+ [ ("brent", brent)+ , ("floyd", floyd)+ , ("nivash", nivash)+ , ("naiveHashable", naiveHashable)+ , ("naiveOrd", naiveOrd)+ ]++benchmark :: Benchmark+benchmark =+ bgroup+ "Data.FindCycle"+ [ bgroup+ rName+ [ env (pure (mkCycle spec)) $ \cyc ->+ bgroup+ (show spec)+ [ bench name (rf alg cyc)+ | (name, alg) <- algs+ ]+ | spec <- cycles+ ]+ | (rName, rf) <- runners+ ]
+ data-findcycle.cabal view
@@ -0,0 +1,63 @@+cabal-version: 1.18+name: data-findcycle+version: 0.1.0.0+synopsis: Find cycles in periodic functions (and lists)+description:+ Any function @f :: a -> a@ where the type @a@ has finitely many values+ eventually has to be cyclic when iterated from some initial @a@.+ .+ This module provides a number of common algorithms and utilities to identify+ and work with such cycles.+homepage: https://github.com/rafl/data-findcycle+license: MIT+license-file: LICENSE+author: Florian Ragwitz+maintainer: florian.ragwitz@gmail.com+copyright: (c) 2025 Florian Ragwitz+category: Data+build-type: Simple+extra-doc-files: CHANGELOG.md++source-repository head+ type: git+ branch: main+ location: https://github.com/rafl/data-findcycle++library+ exposed-modules: Data.FindCycle+ build-depends:+ base >= 4.7 && < 4.23,+ containers >= 0.5 && < 0.9,+ hashable >= 1.2 && < 1.6,+ unordered-containers >= 0.2 && < 0.3+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++test-suite data-findcycle-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ base,+ data-findcycle,+ QuickCheck >= 2.7 && < 2.16,+ primes >= 0.2 && < 0.3,+ tasty >= 0.10 && < 1.6,+ tasty-quickcheck >= 0.8 && < 0.12+ ghc-options: -Wall -threaded -rtsopts++benchmark data-findcycle-bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ main-is: Main.hs+ build-depends:+ base,+ data-findcycle,+ tasty,+ tasty-bench >= 0.4 && < 0.5,+ primes,+ deepseq >= 1.5 && < 1.6+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-A64m -fproc-alignment=64
+ src/Data/FindCycle.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++{- |+ Module: Data.FindCycle+ Description: Find cycles in periodic functions (and lists)+ Copyright: (c) 2025 Florian Ragwitz+ License: MIT++ Any function @f :: a -> a@ where the type @a@ has finitely many values+ eventually has to be cyclic when iterated from some initial @a@.++ This module provides a number of common algorithms and utilities to identify+ and work with such cycles.+-}+module Data.FindCycle (+ -- * Typical Usage++ {- |+ The value of iterating @someCyclicFunc@ for \(10^{100}\) times from+ @startingValue@, using the 'brent' algorithm for cycle detection:++ > let fastCyclicFunc = cycleExp brent someCyclicFunc startingValue+ > fastCyclicFunc (10^100)++ The length of the non-repeating prefix and the length of the cycle, as+ determined using the 'nivash' algorithm:++ > let (mu, lambda) = findCycle nivash someCyclicFunc startingValue++ The same two lengths, plus two lists containing the values of the prefix and+ cyclic parts of the sequence using the 'naiveOrd' algorithm:++ > let (mu, lambda, (pre, cyc)) = findCycleExtract naiveOrd someCyclicFunc startingValue++ When you already have a list of values created by iterating a cyclic+ function:++ > let xs = iterate someCyclicFunc startingValue+ > let (mu, lambda, (pre, cyc)) = unsafeFindCycleFromList brent xs+ -}++ -- * CycleFinder type+ CycleFinder,++ -- * Algorithms++ {- |+ Cycles are typically described with a pair \((\mu, \lambda)\), where+ \(\mu\) represents the length of the non-cyclic prefix of the sequence, and+ \(\lambda\) represents the length of the repeating cycle of the sequence.++ The cycle finding algorithms provided by this module return such a pair as+ a result, but some might return an upper bound \(\tilde{\mu}\) instead of+ the minimal \(\mu\) in order to avoid the computational cost of finding the+ minimal value. This approximation is acceptable in many practical cases,+ such as when using 'cycleExp', which uses the cyclic behavior of a function+ to efficiently compute \(f^n(x)\) for large \(n\).++ When a minimal \(\mu\) is needed, it can be computed from a t'CycleFinder'+ returning a non-minimal \(\tilde{\mu}\) using 'minimalMu'.++ All algorithms always provide a minimal \(\lambda\) as opposed to a+ multiple of the true cycle length.++ In practice, you'll usually want to use 'nivash', 'brent', or one of the+ naive variants. If performance matters and you're not sure what to choose,+ compare the alternatives by benchmarking for your usecase.+ -}++ -- ** Naive++ {- |+ These algorithms use Map-like structures to store the index of the first+ occurrence of each value in the sequence until a duplicate is found.++ They always produce the minimal \((\mu, \lambda)\).++ They never iterate the sequence further than \(\mu + \lambda\) elements.++ They never compute an element at a given position in the sequence more than+ once.++ They use memory approximately proportional to \(\mu + \lambda\).++ 'naiveHashable' tends to perform slightly better and uses slightly less+ memory. Both are provided for completeness and for cases where you might+ not have a 'Hashable' instance or don't want to write one.+ -}+ naiveOrd,+ naiveHashable,++ -- ** Constant Memory++ {- |+ These algorithms use a constant amount of memory, at the cost of having to+ potentially evaluate values in the sequence more than once.++ 'brent' is always better than 'floyd', and the latter is only present for+ completeness and as a baseline for testing. You shouldn't use 'floyd'.++ They always compute a minimal \(\lambda\), but only an upper bound+ \(\tilde{\mu}\) for the cycle length. Combine with 'minimalMu' if the+ minimal \(\mu\) is needed.+ -}+ brent,+ floyd,++ -- ** Memory/Time Compromise+ nivash,++ -- * Running algorithms+ findCycle,+ findCycleExtract,+ cycleExp,+ cycleExp',+ unsafeFindCycleFromList,++ -- * Utilities+ minimalMu,+) where++import Control.Applicative ((<*>), (<|>))+import Data.Functor ((<$), (<$>))+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 ((<$), (<$>), (<*>))++data Input s a = Input+ { inpUncons :: s -> Maybe (a, s)+ , inpAdvance :: Int -> s -> s+ }++funcInput :: (a -> a) -> Input a a+funcInput f = Input (\x -> Just (x, f x)) advance+ where+ advance 0 a = a+ advance n a = advance (n - 1) (f a)++listInput :: Input [a] a+listInput = Input uncons drop+ where+ uncons [] = Nothing+ uncons (x : xs) = Just (x, xs)++{- |+ An algorithm to find the cycle in a function from @a@ to @a@ (or a list of @a@s).+-}+newtype CycleFinder a = CycleFinder+ { runCycleFinder :: forall s. Input s a -> s -> (Int, Int)+ }++{- |+ Runs a t'CycleFinder' algorithm for the given function and starting value,+ returning a pair \((\mu, \lambda)\) representing the length of the+ non-cyclic prefix and the length of the cycle of the sequence.+-}+findCycle :: CycleFinder a -> (a -> a) -> a -> (Int, Int)+findCycle alg f = runCycleFinder alg (funcInput f)++extract :: Int -> Int -> [a] -> ([a], [a])+extract mu lambda = fmap (take lambda) . splitAt mu++{- |+ Like 'findCycle', but also returns a third value @(pre, cyc)@ such that++ > pre ++ cycle cyc == iterate f x++ In addition to extracting the prefix and cyclic part of the list, this can+ also be used to cache some function calls to @f@ which the specified+ t'CycleFinder' might make, as the results of all calls to @f@ in the sequence+ are memorised in a lazy list which is later used to extract @pre@ and @cyc@.++ If you're only interested in caching calls to @f@ but don't need the two+ parts of the list, just don't evaluate the last part of the return value to+ not pay the cost of those parts being computed.+-}+findCycleExtract :: CycleFinder a -> (a -> a) -> a -> (Int, Int, ([a], [a]))+findCycleExtract alg f x = (mu, lambda, extract mu lambda xs)+ where+ xs = iterate f x+ (mu, lambda) = runCycleFinder alg listInput xs++{- |+ Runs the t'CycleFinder' for a given input list.++ This function is provided as a convenience for when you already have a list+ of values you'd like to find a cycle in. It's referred to as "unsafe", because+ it might lead to surprising results when the input doesn't satisfy the+ invariants that different algorithms assume.++ All algorithms assume that the sequence they're searching can be constructed+ by repeated function application from a starting value. Many sequences can't+ be, such as @[1,2,1,3,1,4,1,5,...]@ (because there can only be one unique+ successor of @1@).++ Algorithms also assume the input sequence to be infinite, and they will+ commonly consume more than \(\mu + \lambda\) (or \(\tilde{\mu} + \lambda\))+ elements from it. If you provide a finite input list, cycles might not be+ identified correctly if the chosen algorithm runs into the end of it, even+ though the input does technically contain an identifiable cycle.++ If an assumption is violated, algorithms might wrongly identify cycles or+ never terminate. Try to stick to 'findCycle', 'findCycleExtract', 'cycleExp',+ or 'cycleExp'' if possible, or only pass infinite lists generated via+ @iterate f x@ (or equivalent) to 'unsafeFindCycleFromList'.++ Similar to 'findCycleExtract', just don't evaluate the last part of the+ return value if you don't need it and want to avoid the cost of computing it.+-}+unsafeFindCycleFromList :: CycleFinder a -> [a] -> (Int, Int, ([a], [a]))+unsafeFindCycleFromList alg xs = (mu, lambda, extract mu lambda xs)+ where+ (mu, lambda) = runCycleFinder alg listInput xs++{-# INLINE cycleExpWith #-}+cycleExpWith :: CycleFinder a -> Input s a -> s -> Integer -> a+cycleExpWith alg inp@Input{..} s n =+ fst . fromJust . inpUncons $ inpAdvance (fromIntegral ix) s+ where+ (mu, lambda) = runCycleFinder alg inp s+ (mu', lambda') = (fromIntegral mu, fromIntegral lambda)+ ix+ | n < mu' = n+ | otherwise = mu' + ((n - mu') `mod` lambda')++{- |+ Constructs an efficient evaluator for a cyclic function by "exponentiating" it.+ Given a t'CycleFinder' for a function @f@ and an initial value @x@, it returns+ a function of type @Integer -> a@ which computes the nth iterate (i.e. the+ value of \(f^n(x)\)).++ Using the pair \((\mu, \lambda)\) obtained by the t'CycleFinder', this+ function computes++ \[ f^n(x) = \begin{cases}+ f^n(x) & \text{if } n < \mu, \\+ f^{\mu + ((n - \mu) \bmod \lambda)}(x) & \text{if } n \ge \mu.+ \end{cases} \]++ which allows \(f^n(x)\) to be computed for very large \(n\) without requiring+ \(n\) function applications.++ Note that this function will use a lazy list generated by @iterate f x@. This+ list will only be evaluated up to \(\mu + \lambda\) elements and is shared+ between the cycle finding phase and the computation of the value after @n@+ iterations, but might still require a significant amount of memory. Use+ 'cycleExp'' if you'd rather re-evaluate @f@ many more times but use less+ memory at the expense of more time.++ 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)+ >>> g = cycleExp nivash f 23+ >>> g 0 -- after 0 iterations+ > 23+ >>> -- after a googol iterations, but finishes in less than the current+ >>> -- age of the universe+ >>> g (10^100)+ > 671872+-}+cycleExp :: CycleFinder a -> (a -> a) -> a -> Integer -> a+cycleExp alg f x = cycleExpWith alg listInput (iterate f x)++-- | Like 'cycleExp', but doesn't cache. Probably not very useful in practice.+cycleExp' :: CycleFinder a -> (a -> a) -> a -> Integer -> a+cycleExp' alg f = cycleExpWith alg (funcInput f)++data NaiveContainer m a = NaiveContainer+ { emptyC :: m+ , lookupC :: a -> m -> Maybe Int+ , insertC :: a -> Int -> m -> m+ }++naive :: NaiveContainer m a -> Input s a -> s -> (Int, Int)+naive NaiveContainer{..} Input{..} = go 0 emptyC . inpUncons+ where+ go i _ Nothing = (i, 0)+ go i m (Just (x, xs))+ | Just j <- lookupC x m = (j, i - j)+ | otherwise = go (i + 1) (insertC x i m) (inpUncons xs)++naiveOrd' :: (Ord a) => Input s a -> s -> (Int, Int)+naiveOrd' = naive (NaiveContainer M.empty M.lookup M.insert)++-- | Naive cycle finding algorithm using t'Data.Map.Strict.Map'.+naiveOrd :: (Ord a) => CycleFinder a+naiveOrd = CycleFinder naiveOrd'++naiveHashable' :: (Eq a, Hashable a) => Input s a -> s -> (Int, Int)+naiveHashable' = naive (NaiveContainer HM.empty HM.lookup HM.insert)++-- | Naive cycle finding algorithm using t'Data.HashMap.Strict.HashMap'.+naiveHashable :: (Eq a, Hashable a) => CycleFinder a+naiveHashable = CycleFinder naiveHashable'++{-# INLINE brent' #-}+brent' :: (Eq a) => Input s a -> s -> (Int, Int)+brent' Input{..} = maybe (0, 0) (uncurry (findLambda 1 1)) . inpUncons+ where+ findLambda pow lambda t hs =+ maybe (pow + lambda - 1, 0) (uncurry go) (inpUncons hs)+ where+ go h hs'+ | t == h = (pow, lambda)+ | pow == lambda = findLambda (2 * pow) 1 h hs'+ | otherwise = findLambda pow (1 + lambda) t hs'++{- |+ Brent's cycle finding algorithm.++ Evaluates at most \(2(\mu + \lambda)\) elements of the sequence.++ Always better than floyd.++ * [Brent, R. P. "An improved Monte Carlo factorization algorithm", BIT Numerical Mathematics, 20(2):176–184, 1980.](https://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf)+ * <https://en.wikipedia.org/wiki/Cycle_detection#Brent's_algorithm>+-}+brent :: (Eq a) => CycleFinder a+brent = CycleFinder brent'++{-# 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 []+ where+ go i stack = maybe (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.++{- |+ Nivash's cycle finding algorithm.++ Never computes an element at a given position in the sequence more than once.++ Might use memory proportional to \(\mu + \lambda\) in the worst case of an+ ascending sequence, but commonly uses much less for reasonably "random"+ sequences.++ Can often be faster than 'brent' while not using nearly as much memory as+ 'naiveOrd' or 'naiveHashable'.++ * [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'++-- TODO: Sedgewick, Szymanski, Yao++{-# INLINE floyd' #-}+floyd' :: (Eq a) => Input s a -> s -> (Int, Int)+floyd' Input{..} s = detectCycle 0 s s+ where+ detectCycle n ts hs =+ fromMaybe (2 * n, 0) $+ go <$> inpUncons ts <*> (inpUncons . snd =<< skipped)+ <|> (2 * n + 1, 0) <$ skipped+ where+ skipped = inpUncons hs+ go (t, ts') (h, hs')+ | t == h = (n, findLambda 1 t ts')+ | otherwise = detectCycle (n + 1) ts' hs'+ findLambda n m ms =+ maybe n (uncurry go) (inpUncons ms)+ where+ go x xs+ | m == x = n+ | otherwise = findLambda (n + 1) m xs++{- |+ Floyd's / Tortoise and Hare cycle finding algorithm.++ Always worse than 'brent'. Don't use this.++ * <https://en.wikipedia.org/wiki/Cycle_detection#Floyd's_tortoise_and_hare>+-}+floyd :: (Eq a) => CycleFinder a+floyd = CycleFinder floyd'++{- |+ Compute a minimal result \((\mu, \lambda)\) from a partial result+ \((\tilde{\mu}, \lambda)\).++ This involves re-traversing the sequence from the start and from \(\lambda\)+ which might be expensive for large \(\mu\). This should largely be negligible+ 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 alg = CycleFinder go+ where+ go inp@Input{..} s = maybeFindMu (runCycleFinder alg inp s)+ where+ maybeFindMu r@(_, lambda)+ | lambda == 0 = r+ | otherwise = (findMu 0 s (inpAdvance lambda s), lambda)+ findMu mu ts ms =+ fromMaybe mu $ go' <$> inpUncons ts <*> inpUncons ms+ where+ go' (t, ts') (m, ms')+ | t == m = mu+ | otherwise = findMu (mu + 1) ts' ms'
+ test/Main.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Applicative ((<*>))+import Data.FindCycle+import Data.Foldable (Foldable, find, foldMap, toList)+import Data.Functor ((<$>))+import Data.Maybe+import Data.Numbers.Primes+import Test.Tasty+import Test.Tasty.QuickCheck+import Prelude hiding (Foldable, foldMap, (<$>), (<*>))++data Cycle = Cycle+ { cycMu, cycLambda :: Int+ , cycF :: Integer -> Integer+ , cycX0 :: Integer+ }++instance Show Cycle where+ show Cycle{..} = unwords ["Cycle", show cycMu, show cycLambda]++instance Arbitrary Cycle where+ arbitrary = do+ (Positive muPlusLambda) <- scaled smooth arbitrary+ mu <- choose (0, muPlusLambda - 1)+ let m = fromJust $ find (> fromIntegral muPlusLambda) primes+ -- TODO: just pick using Large suchThat mod m /= 0?+ let nonZeroModM = choose (1, m - 1)+ (f, x0) <- mkF mu (muPlusLambda - mu) m <$> nonZeroModM <*> nonZeroModM+ return (Cycle mu (muPlusLambda - mu) f x0)+ where+ scaled f g = sized $ \x -> resize (f x) g+ smooth s = max 1 (round $ (10 ** 5 :: Double) ** (fromIntegral s / 100))+ mkF mu lambda m a b = (f, g 0)+ where+ n = fromIntegral $ mu + lambda+ g i = (a * i + b) `mod` m+ f x+ | i < n - 1 = g (i + 1)+ | otherwise = g (fromIntegral mu)+ where+ i = (modInv a m * ((x - b) `mod` m)) `mod` m+ modInv 1 _ = 1+ modInv x y = (a * y + 1) `div` x+ where+ a = x - modInv (y `mod` x) x++data AlgClass a = AlgClass {algDef :: a, algAlt :: [a]}+instance Foldable AlgClass where+ foldMap f AlgClass{..} = foldMap f (algDef : algAlt)++data Labeled a = Labeled String a++totalAlgs :: AlgClass (Labeled (CycleFinder Integer))+totalAlgs =+ AlgClass+ (Labeled "naiveHashable" naiveHashable)+ [Labeled "naiveOrd" naiveOrd]++partialAlgs :: AlgClass (Labeled (CycleFinder Integer))+partialAlgs =+ AlgClass+ (Labeled "nivash" nivash)+ [ Labeled "brent" brent+ , Labeled "floyd" floyd+ ]++defAlg :: CycleFinder Integer+defAlg = alg+ where+ AlgClass (Labeled _ alg) _ = partialAlgs++type Runner r = Cycle -> r+type Extractor = Runner (Int, Int, ([Integer], [Integer]))++extractors :: AlgClass (Labeled (CycleFinder Integer -> Extractor))+extractors =+ AlgClass+ (Labeled "findCycleExtract" findExtract)+ [Labeled "unsafeFindCycleFromList" unsafeFromList]+ where+ findExtract alg Cycle{..} = findCycleExtract alg cycF cycX0+ unsafeFromList alg Cycle{..} =+ unsafeFindCycleFromList alg (iterate cycF cycX0)++defExtractor :: CycleFinder Integer -> Extractor+defExtractor = alg+ where+ AlgClass (Labeled _ alg) _ = extractors++discardExtract :: Runner (a, a, b) -> Runner (a, a)+discardExtract f c = (mu, lambda)+ where+ (mu, lambda, _) = f c++prop_algCorrect :: CycleFinder Integer -> Cycle -> Property+prop_algCorrect alg Cycle{..} = findCycle alg cycF cycX0 === (cycMu, cycLambda)++prop_algsAgree :: CycleFinder Integer -> CycleFinder Integer -> Cycle -> Property+prop_algsAgree a b Cycle{..} =+ findCycleExtract a cycF cycX0 === findCycleExtract b cycF cycX0++prop_runnersAgree :: (Eq r, Show r) => Runner r -> Runner r -> Cycle -> Property+prop_runnersAgree a b c = a c === b c++prop_muUpperBound :: CycleFinder Integer -> Cycle -> Property+prop_muUpperBound alg Cycle{..} =+ counterexample ("Should be at least " ++ show cycMu) $+ fst (findCycle alg cycF cycX0) >= cycMu++prop_extract :: CycleFinder Integer -> Cycle -> Property+prop_extract alg Cycle{..} =+ (length pre, length cyc, pre ++ cyc ++ cyc)+ === (mu, lambda, take (mu + 2 * lambda) (iterate cycF cycX0))+ where+ (mu, lambda, (pre, cyc)) = findCycleExtract alg cycF cycX0++prop_cycleExp :: CycleFinder Integer -> Cycle -> Property+prop_cycleExp alg Cycle{..} =+ property $ \(NonNegative n) ->+ counterexample ("n=" ++ show n) $+ g (fromIntegral n)+ === xs !! (n - max 0 (n - cycMu - ((n - cycMu) `mod` cycLambda)))+ where+ g = cycleExp alg cycF cycX0+ xs = iterate cycF cycX0++prop_cycleExpsAgree :: CycleFinder Integer -> Cycle -> Property+prop_cycleExpsAgree alg Cycle{..} =+ property $ \(NonNegative (n :: Int)) ->+ counterexample ("n=" ++ show n) $+ g (fromIntegral n) === g' (fromIntegral n)+ where+ g = cycleExp alg cycF cycX0+ g' = cycleExp' alg cycF cycX0++prop_finite :: CycleFinder Integer -> Cycle -> Property+prop_finite alg Cycle{..} =+ unsafeFindCycleFromList (minimalMu alg) (take cycMu xs)+ === (cycMu, 0, (take cycMu xs, []))+ where+ xs = iterate cycF cycX0++tests :: TestTree+tests =+ testGroup+ "Data.FindCycle minimal tests"+ [ let AlgClass (Labeled name alg) _ = totalAlgs+ in testProperty+ (name ++ " is correct")+ (prop_algCorrect alg)+ , testGroup+ "All total algorithms agree"+ [ testProperty (refName ++ " ~ " ++ name) (prop_algsAgree refAlg alg)+ | let AlgClass (Labeled refName refAlg) algs = totalAlgs+ , Labeled name alg <- algs+ ]+ , testGroup+ "Total agrees with minimalMu of partial"+ [ testProperty+ (refName ++ " ~ minimalMu " ++ algName)+ (prop_algsAgree refAlg (minimalMu alg))+ | let AlgClass (Labeled refName refAlg) _ = totalAlgs+ , Labeled algName alg <- toList partialAlgs+ ]+ , testGroup+ "mu upper bound for partial"+ [ testProperty name (prop_muUpperBound alg)+ | Labeled name alg <- toList partialAlgs+ ]+ , testProperty+ "minimalMu is idempotent"+ (prop_algsAgree (minimalMu defAlg) (minimalMu (minimalMu defAlg)))+ , testGroup+ "Extractors agree"+ [ testProperty+ (refName ++ " ~ " ++ rName)+ (prop_runnersAgree (refR defAlg) (r defAlg))+ | let AlgClass (Labeled refName refR) rs = extractors+ , Labeled rName r <- rs+ ]+ , testProperty+ "findCycle agrees with extractors"+ ( prop_runnersAgree+ (discardExtract (defExtractor defAlg))+ (\Cycle{..} -> findCycle defAlg cycF cycX0)+ )+ , testProperty "extraction is correct" (prop_extract defAlg)+ , testProperty "cycleExp matches naive iteration" (prop_cycleExp defAlg)+ , testProperty "cycleExp' agrees with cycleExp " (prop_cycleExpsAgree defAlg)+ , testGroup+ "finite lists"+ [ testProperty name (prop_finite alg)+ | Labeled name alg <- toList totalAlgs ++ toList partialAlgs+ ]+ ]++main :: IO ()+main = defaultMain tests