----------------------------------------------------------------------------- -- | -- Module : Data.RationalList -- Copyright : (c) Ross Paterson 2019 -- License : BSD-style -- Maintainer : R.Paterson@city.ac.uk -- Portability : portable -- -- A rational list (a special kind of rational tree) is a list that is -- either finite or of the form @xs ++ cycle ys@ where @xs@ and @ys@ -- are finite lists and @ys@ is non-empty. (Another name is /rho-lists/, -- after the Greek letter ρ whose shape suggests cyclic repetition -- after some prefix.) Such lists have a useful finite representation. -- -- Many functions in this module have the same names as functions in the -- "Prelude", "Data.Foldable" and "Data.List". On finite lists, these -- functions have the same behaviour as their list counterparts. Due to -- the finite representation, they are also total, even on infinite lists. -- Many operations on infinite lists are also substantially faster than -- using lists, because they exploit the repetition. For example: -- -- >>> num_list = iterate (\n -> (n*n + 1) `mod` 100) 19 -- >>> num_list -- fromList [19,62,45] <> cycle [26,77,30,1,2,5] -- >>> toList num_list -- [19,62,45,26,77,30,1,2,5,26,77,30,1,2,5,26,77,30,1,2,5,26,77,30,... -- >>> maximum num_list -- 77 -- >>> elementAt 2000000000000000000 num_list -- Just 5 -- ----------------------------------------------------------------------------- module Data.RationalList ( RationalList, -- * Construction fromList, repeat, cycle, iterate, unfoldr, -- * Components -- | Any rational list @xs@ satisfies -- -- prop> fromList (prefix xs) <> cycle (repetend xs) = xs prefix, repetend, -- * Modification map, concat, concatMap, zip, zipWith, unzip, -- * Sublists filter, partition, takeWhile, dropWhile, span, take, drop, splitAt, tails, -- * Queries -- | These are similar to list functions, but take advantage of -- repetition for efficiency and to work even with infinite lists. -- Several more are provided by the 'Foldable' instance. finite, elementAt, elemIndex, find, findIndex, any, all, maximumBy, minimumBy, foldMapTake, -- * Examples -- $examples ) where import Control.Monad (mplus) import Data.Foldable (toList, fold) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.Semigroup import Data.Sequence (Seq, ViewR(..), (<|), (|>), (><)) import qualified Data.Sequence as Seq import Prelude hiding ( map, repeat, cycle, iterate, concat, concatMap, filter, takeWhile, dropWhile, span, take, drop, splitAt, any, all, zip, zipWith, unzip) -- | A list of the form @'fromList' xs '<>' 'cycle' ys@ where @xs@ and @ys@ -- are finite lists. data RationalList a = RationalList !(Seq a) !(Seq a) -- minimal prefix and repetend -- | Total functions testing whether lists have the same unfoldings instance Eq a => Eq (RationalList a) where RationalList fr1 re1 == RationalList fr2 re2 = fr1 == fr2 && re1 == re2 -- | Total functions giving the relationship between unfoldings instance Ord a => Ord (RationalList a) where compare xs ys | xs == ys = EQ | otherwise = compare (toList xs) (toList ys) -- | Canonical form of the list instance Show a => Show (RationalList a) where showsPrec d (RationalList fr re) | null re = showParen (d > app_prec) shows_fr | null fr = showParen (d > app_prec) shows_re | otherwise = showParen (d > plus_prec) $ shows_fr . showString " <> " . shows_re where shows_fr = showString "fromList " . showsPrec (app_prec+1) (toList fr) shows_re = showString "cycle " . showsPrec (app_prec+1) (toList re) app_prec = 10 plus_prec = 6 -- | Reads the form produced by 'show' instance (Read a, Eq a) => Read (RationalList a) where readsPrec d = readParen (d > plus_prec) (\ r -> [(xs <> ys, u) | (xs, s) <- readFromList r, ("<>", t) <- lex s, (ys, u) <- readCycle t]) <> readParen (d > app_prec) (readFromList <> readCycle) where readCycle r = [(cycle xs, t) | ("cycle", s) <- lex r, (xs, t) <- readsPrec (app_prec+1) s] readFromList r = [(fromList xs, t) | ("fromList", s) <- lex r, (xs, t) <- readsPrec (app_prec+1) s] app_prec = 10 plus_prec = 6 -- | '<>' is concatenation. -- In particular, if the first list is infinite, the second is ignored. instance Eq a => Semigroup (RationalList a) where RationalList fr1 re1 <> RationalList fr2 re2 | Seq.null re1 && Seq.null fr2 = rollup fr1 re2 | Seq.null re1 = RationalList (fr1 <> fr2) re2 | otherwise = RationalList fr1 re1 -- | 'mempty' is the empty list. instance Eq a => Monoid (RationalList a) where mempty = RationalList Seq.empty Seq.empty -- | Specialized implementations of 'null', 'length', 'elem', 'maximum' and -- 'minimum' instance Foldable RationalList where foldr f z (RationalList fr re) = foldr f rest fr where rest | Seq.null re = z | otherwise = foldr f rest re null (RationalList fr re) = null fr && null re length (RationalList fr re) | null re = length fr | otherwise = error "length of infinite RationalList" elem x (RationalList fr re) = elem x fr || elem x re maximum = maximumBy compare minimum = maximumBy compare -- Construction -- | @'fromList' xs@ is a representation of the list @xs@, which must -- be finite. fromList :: [a] -> RationalList a fromList xs = RationalList (Seq.fromList xs) Seq.empty -- | @'repeat' x@ is the infinite repetition of a single value. repeat :: a -> RationalList a repeat x = RationalList Seq.empty (Seq.singleton x) -- | @'cycle' xs@ is the infinite repetition of the list @xs@, which -- must be finite. cycle :: Eq a => [a] -> RationalList a cycle xs = RationalList Seq.empty (minLoop (Seq.fromList xs)) -- | @'iterate' f x@ is an infinite list of repeated applications of @f@ -- to @x@, provided an earlier value is repeated at some point. -- If no repetition occurs, the computation does not terminate. iterate :: Eq a => (a -> a) -> a -> RationalList a iterate = iterateBrent -- Brent's algorithm iterateBrent :: Eq a => (a -> a) -> a -> RationalList a iterateBrent f = start Seq.empty where start front tortoise = loop Seq.empty (f tortoise) where n = Seq.length front loop skip hare | hare == tortoise = rollup front (tortoise <| skip) | Seq.length skip == n = start (front >< (tortoise <| skip)) hare | otherwise = loop (skip |> hare) (f hare) -- | @'unfoldr' f z@ is a list built from a seed value @z@. The function -- @f@ takes a seed value and returns 'Nothing' if it is done producing -- the list or returns @'Just' (a,b)@, in which case, @a@ is a prepended -- to the list and @b@ is used as the next seed value in a recursive call. -- This will not terminate unless one of these evaluations of @f@ returns -- 'Nothing' or @'Just' (a,b)@ where @b@ is a previously seen value. unfoldr :: (Eq a, Eq b) => (b -> Maybe (a, b)) -> b -> RationalList a unfoldr = unfoldrBrent -- Brent's algorithm unfoldrBrent :: (Eq a, Eq b) => (b -> Maybe (a, b)) -> b -> RationalList a unfoldrBrent f = start Seq.empty where start front tortoise = loop Seq.empty (f tortoise) where n = Seq.length front loop skip Nothing = RationalList (front >< skip) Seq.empty loop skip (Just (x, hare)) | hare == tortoise = rationalList front skip' | Seq.length skip == n = start (front >< skip') hare | otherwise = loop skip' (f hare) where skip' = skip |> x -- Components -- | @'prefix' xs@ is the minimal non-repeating part at the front of @xs@. prefix :: RationalList a -> [a] prefix (RationalList f _) = toList f -- | @'repetend' xs@ is the minimal repeating part of @xs@, or @[]@ -- if @xs@ is finite. repetend :: RationalList a -> [a] repetend (RationalList _ r) = toList r -- Modification -- | @'map' f xs@ is the list obtained by applying @f@ to each element of @xs@. map :: Eq b => (a -> b) -> RationalList a -> RationalList b map f (RationalList fr re) = rationalList (fmap f fr) (fmap f re) -- | @'concat' xss@ is the concatenation of all the lists in @xss@. concat :: Eq a => RationalList (RationalList a) -> RationalList a concat (RationalList fr re) | Seq.null fr_re && Seq.null re_re = rationalList fr_fr re_fr | otherwise = f_fr <> f_re where f_fr@(RationalList fr_fr fr_re) = fold fr f_re@(RationalList re_fr re_re) = fold re -- | @'concatMap' f xs@ is the concatenation of mapping @f@ over the -- elements of @xs@. -- -- prop> concatMap f xs = concat (map f xs) -- concatMap :: Eq b => (a -> RationalList b) -> RationalList a -> RationalList b concatMap f (RationalList fr re) | Seq.null fr_re && Seq.null re_re = rationalList fr_fr re_fr | otherwise = f_fr <> f_re where f_fr@(RationalList fr_fr fr_re) = foldMap f fr f_re@(RationalList re_fr re_re) = foldMap f re -- | @'zip' xs ys@ is a list of corresponding pairs in @xs@ and @ys@. -- If one input list is shorter, unmatched elements of the longer list -- are not included. zip :: RationalList a -> RationalList b -> RationalList (a, b) zip (RationalList fr1 re1) (RationalList fr2 re2) | Seq.null re1 && Seq.null re2 || Seq.null re1 && nf1 <= nf2 || Seq.null re2 && nf2 <= nf1 = RationalList (Seq.zip fr1 fr2) Seq.empty | nf1 <= nf2 = let n = nf2 - nf1 in RationalList (Seq.zip (fr1 >< Seq.cycleTaking n re1) fr2) (zipRepeats (rotateLeft n re1) re2) | otherwise = let n = nf1 - nf2 in RationalList (Seq.zip fr1 (fr2 >< Seq.cycleTaking n re2)) (zipRepeats re1 (rotateLeft n re2)) where nf1 = Seq.length fr1 nf2 = Seq.length fr2 -- | @'zipWith' f xs ys@ is a list of @f@ applied to corresponding -- elements from @xs@ and @ys@. -- If one input list is shorter, unmatched elements of the longer list -- are not included. zipWith :: Eq c => (a -> b -> c) -> RationalList a -> RationalList b -> RationalList c zipWith f (RationalList fr1 re1) (RationalList fr2 re2) | Seq.null re1 && Seq.null re2 || Seq.null re1 && nf1 <= nf2 || Seq.null re2 && nf2 <= nf1 = RationalList (Seq.zipWith f fr1 fr2) Seq.empty | nf1 <= nf2 = let n = nf2 - nf1 in rationalList (Seq.zipWith f (fr1 >< Seq.cycleTaking n re1) fr2) (zipRepeatsWith f (rotateLeft n re1) re2) | otherwise = let n = nf1 - nf2 in rationalList (Seq.zipWith f fr1 (fr2 >< Seq.cycleTaking n re2)) (zipRepeatsWith f re1 (rotateLeft n re2)) where nf1 = Seq.length fr1 nf2 = Seq.length fr2 rotateLeft :: Int -> Seq a -> Seq a rotateLeft n xs = back >< front where (front, back) = Seq.splitAt (n `mod` Seq.length xs) xs zipRepeats :: Seq a -> Seq b -> Seq (a,b) zipRepeats = zipRepeatsWith (,) zipRepeatsWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipRepeatsWith f xs ys | nx == 0 || ny == 0 = Seq.empty | otherwise = Seq.zipWith f (Seq.cycleTaking n xs) (Seq.cycleTaking n ys) where nx = Seq.length xs ny = Seq.length ys n = lcm nx ny -- | @'unzip' xys@ in a pair of the list of first components of @xys@ -- and the list of second components. unzip :: (Eq a, Eq b) => RationalList (a, b) -> (RationalList a, RationalList b) unzip (RationalList fr re) = (rationalList fr1 re1, rationalList fr2 re2) where (fr1, fr2) = Seq.unzip fr (re1, re2) = Seq.unzip re -- Sublists -- | @'filter' p xs@ is the list of elements @x@ of @xs@ for which @p x@ -- is 'True'. filter :: Eq a => (a -> Bool) -> RationalList a -> RationalList a filter p (RationalList fr re) = rationalList (Seq.filter p fr) (Seq.filter p re) -- | @'partition' p xs@ is the list of elements @x@ of @xs@ for which -- @p x@ is 'True' and the list of those for which it is 'False'. partition :: Eq a => (a -> Bool) -> RationalList a -> (RationalList a, RationalList a) partition p (RationalList fr re) = (rationalList (Seq.filter p fr1) (Seq.filter p re1), rationalList (Seq.filter p fr2) (Seq.filter p re2)) where (fr1, fr2) = Seq.partition p fr (re1, re2) = Seq.partition p re -- | @'takeWhile' p xs@ is the longest prefix (possibly empty) of @xs@ -- of elements that satisfy @p@. takeWhile :: Eq a => (a -> Bool) -> RationalList a -> RationalList a takeWhile p (RationalList fr re) | not (null fr2) = RationalList fr1 Seq.empty | not (null re2) = RationalList (fr1 >< re1) Seq.empty | otherwise = RationalList fr re where (fr1, fr2) = Seq.spanl p fr (re1, re2) = Seq.spanl p re -- | @'dropWhile' p xs@ is the remainder of the list after the longest -- prefix (possibly empty) of @xs@ of elements that satisfy @p@. -- If no element satisfies @p@, the result is an empty list. dropWhile :: Eq a => (a -> Bool) -> RationalList a -> RationalList a dropWhile p (RationalList fr re) | not (null fr2) = RationalList fr2 re | not (null re2) = RationalList Seq.empty (re2 >< re1) | otherwise = mempty where fr2 = Seq.dropWhileL p fr (re1, re2) = Seq.spanl p re -- | @'span' p xs@ is a pair whose first element is the longest prefix -- (possibly empty) of @xs@ of elements that satisfy @p@ and whose second -- element is the remainder of the list. -- If no element satisfies @p@, the first list is @xs@ and the second -- is empty. span :: Eq a => (a -> Bool) -> RationalList a -> (RationalList a, RationalList a) span p (RationalList fr re) | not (null fr2) = (RationalList fr1 Seq.empty, RationalList fr2 re) | not (null re2) = (RationalList (fr1 >< re1) Seq.empty, RationalList Seq.empty (re2 >< re1)) | otherwise = (RationalList fr re, mempty) where (fr1, fr2) = Seq.spanl p fr (re1, re2) = Seq.spanl p re -- | @'take' n xs@ is the prefix of @xs@ of length @n@, or all of @xs@ -- if @xs@ is finite and @n > 'length' xs@. take :: Integral i => i -> RationalList a -> [a] {-# SPECIALIZE take :: Int -> RationalList a -> [a] #-} take n xs = List.take (fromIntegral n) (toList xs) -- | @'drop' n xs@ is the suffix of @xs@ after the first @n@ elements, -- or empty if @xs@ is finite and @n > 'length' xs@. drop :: (Integral i, Eq a) => i -> RationalList a -> RationalList a {-# SPECIALIZE drop :: (Eq a) => Int -> RationalList a -> RationalList a #-} drop n (RationalList fr re) | offset <= 0 = RationalList (Seq.drop (fromIntegral n) fr) re | null re = mempty | otherwise = let (re1, re2) = Seq.splitAt re_ix re in RationalList Seq.empty (re2 >< re1) where offset = toInteger n - toInteger (Seq.length fr) re_ix = fromInteger (offset `mod` toInteger (Seq.length re)) -- | @'splitAt' n xs@ is a pair whose first element is the prefix of @xs@ -- of length @n@ and whose second element is the remainder of the list. splitAt :: (Integral i, Eq a) => i -> RationalList a -> ([a], RationalList a) {-# SPECIALIZE splitAt :: (Eq a) => Int -> RationalList a -> ([a], RationalList a) #-} splitAt n (RationalList fr re) | offset <= 0 = let (fr1, fr2) = Seq.splitAt (fromIntegral n) fr in (toList fr1, RationalList fr2 re) | null re = (toList fr, mempty) | otherwise = let (re1, re2) = Seq.splitAt re_ix re in (List.take (fromIntegral n) (toList (RationalList fr re)), RationalList Seq.empty (re2 >< re1)) where offset = toInteger n - toInteger (Seq.length fr) re_ix = fromInteger (offset `mod` toInteger (Seq.length re)) -- | @'tails' xs@ is the list of final segments of @xs@, longest first. tails :: RationalList a -> RationalList (RationalList a) tails (RationalList fr re) | null re = finiteList (fmap finiteList (Seq.tails fr)) | otherwise = RationalList (Seq.fromList [RationalList (Seq.drop n fr) re | n <- [0..nf-1]]) (Seq.fromList [RationalList mempty (rotateLeft n re) | n <- [0..nr-1]]) where nf = length fr nr = length re finiteList s = RationalList s mempty -- Queries -- | @'finite' xs@ is 'True' when @xs@ is finite. finite :: RationalList a -> Bool finite (RationalList _ re) = Seq.null re -- | @'elementAt' i xs@ is the element of @xs@ at position @i@ (counting -- from zero), or 'Nothing' if @xs@ has fewer than @i@ elements. elementAt :: Integral i => i -> RationalList a -> Maybe a {-# SPECIALIZE elementAt :: Int -> RationalList a -> Maybe a #-} elementAt n (RationalList fr re) | offset < 0 = Seq.lookup (fromIntegral n) fr | Seq.null re = Nothing | otherwise = Seq.lookup re_ix re where offset = toInteger n - toInteger (Seq.length fr) re_ix = fromInteger (offset `mod` toInteger (Seq.length re)) -- | @'elemIndex' x xs@ is the index of the first element in @xs@ that -- is equal (by '==') to @x@, or 'Nothing' if there is no such element. elemIndex :: Eq a => a -> RationalList a -> Maybe Int elemIndex x = findIndex (== x) -- | @'find' p xs@ is @'Just' x@ if @x@ is the first element of @xs@ -- for which @p x@ is 'True', or 'Nothing' if there is no such element. find :: (a -> Bool) -> RationalList a -> Maybe a find p (RationalList fr re) = Foldable.find p fr `mplus` Foldable.find p re -- | @'findIndex' p xs@ is @'Just' i@ if @i@ is the first element @x@ -- of @xs@ for which @p x@ is 'True', or 'Nothing' if there is no such -- element. findIndex :: (a -> Bool) -> RationalList a -> Maybe Int findIndex p (RationalList fr re) = Seq.findIndexL p fr `mplus` fmap (length fr +) (Seq.findIndexL p re) -- | @'any' p xs@ is 'True' if any only if @p x@ is 'True' for any -- element of @xs@. any :: (a -> Bool) -> RationalList a -> Bool any p (RationalList fr re) = Foldable.any p fr || Foldable.any p re -- | @'all' p xs@ is 'True' if any only if @p x@ is 'True' for all -- elements of @xs@. all :: (a -> Bool) -> RationalList a -> Bool all p (RationalList fr re) = Foldable.any p fr && Foldable.any p re -- | @'maximumBy' cmp xs@ is the greatest element of @xs@ (which must -- be non-empty) with respect to the comparison function @cmp@. maximumBy :: (a -> a -> Ordering) -> RationalList a -> a maximumBy cmp (RationalList fr re) | null re = max_fr | null fr = max_re | otherwise = case cmp max_fr max_re of GT -> max_fr _ -> max_re where max_fr = Foldable.maximumBy cmp fr max_re = Foldable.maximumBy cmp re -- | @'minimumBy' cmp xs@ is the least element of @xs@ (which must be -- non-empty) with respect to the comparison function @cmp@. minimumBy :: (a -> a -> Ordering) -> RationalList a -> a minimumBy cmp (RationalList fr re) | null re = min_fr | null fr = min_re | otherwise = case cmp min_fr min_re of GT -> min_re _ -> min_fr where min_fr = Foldable.minimumBy cmp fr min_re = Foldable.minimumBy cmp re -- | @'foldMapTake' f n xs@ applies @f@ to the first @n@ elements of @xs@ -- and combines the results: -- -- prop> foldMapTake f n = foldMap f . take n -- -- but may be significantly faster for some monoids. foldMapTake :: (Integral i, Monoid m) => (a -> m) -> i -> RationalList a -> m {-# SPECIALIZE foldMapTake :: (Monoid m) => (a -> m) -> Int -> RationalList a -> m #-} foldMapTake f n (RationalList fr re) | offset <= 0 || Seq.null re = foldMap f (Seq.take (fromIntegral n) fr) | q == 0 = foldMap f fr <> remainder | otherwise = foldMap f fr <> stimes q (foldMap f re) <> remainder where offset = toInteger n - toInteger (Seq.length fr) (q, r) = offset `divMod` toInteger (Seq.length re) remainder = foldMap f (Seq.take (fromInteger r) re) -- Internals -- smart constructor rationalList :: Eq a => Seq a -> Seq a -> RationalList a rationalList fr re | Seq.null re = RationalList fr mempty | otherwise = rollup fr (minLoop re) -- minimize a recurring list -- TODO: consider fewer primes? minLoop :: Eq a => Seq a -> Seq a minLoop = factorize primes where factorize (p:ps) xs | p > n = xs | n `mod` p == 0 && List.all (== first) rest = factorize (p:ps) first | otherwise = factorize ps xs where n = Seq.length xs first:rest = takes (n `div` p) xs factorize [] _ = error "finite prime list" -- subsequences of length n takes :: Int -> Seq a -> [Seq a] takes n xs | Seq.null xs = [] | otherwise = front:takes n rest where (front, rest) = Seq.splitAt n xs -- is n prime? isPrime :: Int -> Bool isPrime n = noFactors primes where noFactors (p:ps) = p*p > n || n `mod` p /= 0 && noFactors ps noFactors [] = error "finite prime list" -- infinite list of prime numbers primes :: [Int] primes = 2:List.filter isPrime [3,5..] -- assuming the recurring part is minimal, minimize the prefix rollup :: Eq a => Seq a -> Seq a -> RationalList a rollup fr re = case Seq.viewr fr of EmptyR -> RationalList fr re fr' :> x -> case Seq.viewr re of re' :> y | x == y -> rollup fr' (x <| re') _ -> RationalList fr re {- $examples == Decimal fractions The following function takes a number @0 <= x < 1@ and returns the leading digit of its decimal representation, as well as the residue: > digit :: Rational -> Maybe (Int, Rational) > digit x > | x == 0 = Nothing > | otherwise = Just (properFraction (x * 10)) Unfolding with this function gives decimal representations of fractions: >>> Data.List.unfoldr digit (3/8) [3,7,5] >>> Data.List.unfoldr digit (3/28) [1,0,7,1,4,2,8,5,7,1,4,2,8,5,7,1,4,2,8,5,7,1,4,2,8,5,7,1,4,2,... The latter infinite list repeats the subsequence @7,1,4,2,8,5@ indefinitely. The rational list version of 'unfoldr' detects the repetition and yields a finite representation: >>> unfoldr digit (3/8) fromList [3,7,5] >>> unfoldr digit (3/28) fromList [1,0] <> cycle [7,1,4,2,8,5] With this representation, several list functions can be implemented more efficiently, e.g. >>> elementAt 1000000000 $ unfoldr digit (3/28) Just 4 while others terminate even for infinite lists: >>> elem 3 $ unfoldr digit (3/28) False == Fibonacci numbers Puzzle: what is the last digit of the 1000000000th Fibonacci number? (where the first and second Fibonacci numbers are both 1.) The infinite list of Fibonacci numbers can be defined as >>> Data.List.map fst $ Data.List.iterate (\ (a,b) -> (b,(a+b))) (0,1) [0,1,1,2,3,5,8,13,21,34,55,89,144,233,377,610,987,1597,2584,4181,... However, we only need the last digit of each number, so we can replace @a+b@ with @(a+b) \`mod\` 10@. Then the list of pairs must repeat, since there are a finite number of possible combinations, so it can be represented as a rational list, and the solution is >>> elementAt 1000000000 $ map fst $ iterate (\ (a,b) -> (b, (a+b) `mod` 10)) (0,1) Just 5 Here 'elementAt' calculates the appropriate position in the repeating part of the list and returns that, without calculating lots of numbers. -}