module Data.RationalList (
RationalList,
fromList, repeat, cycle,
iterate, unfoldr,
prefix, repetend,
map,
concat, concatMap,
zip, zipWith, unzip,
filter, partition,
takeWhile, dropWhile, span,
take, drop, splitAt,
tails,
finite,
elementAt,
elemIndex, find, findIndex, any, all,
maximumBy, minimumBy,
foldMapTake,
) 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)
data RationalList a = RationalList !(Seq a) !(Seq a)
instance Eq a => Eq (RationalList a) where
RationalList fr1 re1 == RationalList fr2 re2 = fr1 == fr2 && re1 == re2
instance Ord a => Ord (RationalList a) where
compare xs ys
| xs == ys = EQ
| otherwise = compare (toList xs) (toList ys)
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
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
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
instance Eq a => Monoid (RationalList a) where
mempty = RationalList Seq.empty Seq.empty
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
fromList :: [a] -> RationalList a
fromList xs = RationalList (Seq.fromList xs) Seq.empty
repeat :: a -> RationalList a
repeat x = RationalList Seq.empty (Seq.singleton x)
cycle :: Eq a => [a] -> RationalList a
cycle xs = RationalList Seq.empty (minLoop (Seq.fromList xs))
iterate :: Eq a => (a -> a) -> a -> RationalList a
iterate = iterateBrent
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 :: (Eq a, Eq b) => (b -> Maybe (a, b)) -> b -> RationalList a
unfoldr = unfoldrBrent
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
prefix :: RationalList a -> [a]
prefix (RationalList f _) = toList f
repetend :: RationalList a -> [a]
repetend (RationalList _ r) = toList r
map :: Eq b => (a -> b) -> RationalList a -> RationalList b
map f (RationalList fr re) = rationalList (fmap f fr) (fmap f re)
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 :: 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 :: 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 :: 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 :: (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
filter :: Eq a => (a -> Bool) -> RationalList a -> RationalList a
filter p (RationalList fr re) =
rationalList (Seq.filter p fr) (Seq.filter p re)
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 :: 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 :: 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 :: 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 :: Integral i => i -> RationalList a -> [a]
{-# SPECIALIZE take :: Int -> RationalList a -> [a] #-}
take n xs = List.take (fromIntegral n) (toList 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 :: (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 :: 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
finite :: RationalList a -> Bool
finite (RationalList _ re) = Seq.null re
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 :: Eq a => a -> RationalList a -> Maybe Int
elemIndex x = findIndex (== x)
find :: (a -> Bool) -> RationalList a -> Maybe a
find p (RationalList fr re) = Foldable.find p fr `mplus` Foldable.find p re
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 :: (a -> Bool) -> RationalList a -> Bool
any p (RationalList fr re) = Foldable.any p fr || Foldable.any p re
all :: (a -> Bool) -> RationalList a -> Bool
all p (RationalList fr re) = Foldable.any p fr && Foldable.any p re
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 :: (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 :: (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)
rationalList :: Eq a => Seq a -> Seq a -> RationalList a
rationalList fr re
| Seq.null re = RationalList fr mempty
| otherwise = rollup fr (minLoop re)
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"
takes :: Int -> Seq a -> [Seq a]
takes n xs
| Seq.null xs = []
| otherwise = front:takes n rest
where
(front, rest) = Seq.splitAt n xs
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"
primes :: [Int]
primes = 2:List.filter isPrime [3,5..]
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