module Data.Rivers.Streams where
import Prelude hiding (zip,unzip)
import Data.Rivers.Idiom
import Data.Rivers.NumExt
import Math.OEIS (SequenceData,lookupSequence, getSequenceByID)
import Control.Monad (liftM2)
import Test.QuickCheck (Arbitrary, CoArbitrary, arbitrary, coarbitrary)
import Test.LazySmallCheck (Serial, series, cons2)
data S v = Cons v (S v)
deriving (Eq, Ord, Show, Read)
infixr 5 <<|
infixr 5 <||
infixr 5 |~|
infixr 5 |!|
(<||) :: a -> S a -> S a
(<<|) :: [a] -> S a -> S a
(|~|) :: S a -> S a -> S a
ago :: Integer -> S a -> a
anyA :: S a
z0 :: (Num a) => S a
asum :: (Num a) => S a -> S a
bsum :: (Num a) => S a -> S a
csum :: (Num a) => S a -> S a
diff :: (Num a) => S a -> S a
inv :: (Num a) => S a -> S a
sconst :: (Num a) => a -> S a
times :: (Num a) => a -> S a -> S a
plus :: (Num a) => S a -> S a -> S a
interleave :: S a -> S a -> S a
interleave' :: S a -> S a -> S a
alternate :: S a -> S a -> S a
combStreams :: [[a]] -> [[a]]
drop0L :: S a -> S a
dropIp1L :: S a -> S a
dup :: S a -> S a
(|!|) :: (Ord a) => S a -> S a -> S a
merge :: (Ord a) => S a -> S a -> S a
union :: (Ord a) => S a -> S a -> S a
allEqual :: (Eq a) => [a] -> Bool
group :: (Eq a) => S a -> S [a]
fix :: (a -> a) -> a
inits :: S a -> S [a]
interleave3 :: S a -> S a -> S a
intersperse :: a -> S a -> S a
map1 :: (a -> b) -> S a -> S b
mapAdjacent :: (a -> a -> b) -> [a] -> [b]
turn :: (Integral a) => a -> [a]
type G v o = [v] -> o
fromFG :: G a a -> S a
revFix :: G a a -> S a
rgen :: G a b -> S a -> S b
fwdFix :: G a a -> S a
grow :: G a b -> S a -> S b
hOfFG :: G a b -> b
tOfFG :: G a b -> a -> G a b
rep :: (S a -> S b) -> G a b
rgen' :: G a b -> [a] -> S a -> S b
hOfRG :: (G a b, [a]) -> b
tOfRG :: (G a b, [a]) -> a -> (G a b, [a])
fromRG :: (G a a, [a]) -> S a
toT :: G a b -> Tree a b
toG :: Tree a b -> G a b
data Tree a o = Node o (a -> Tree a o)
branches :: Tree a b -> a -> Tree a b
fromT :: Tree a a -> S a
label :: Tree a b -> b
type Coalg c a b = (c -> b, c -> a -> c)
unfold :: Coalg c a b -> c -> Tree a b
cfix :: Coalg c a a -> c -> S a
groW :: Coalg c a b -> c -> S a -> S b
sMap :: (a -> b) -> S a -> S b
sMap2 :: (a -> b -> c) -> S a -> S b -> S c
sMap3 :: (a -> b -> c -> d) -> S a -> S b -> S c -> S d
sMap4 :: (a -> b -> c -> d -> e) -> S a -> S b -> S c -> S d -> S e
sEven :: S a -> S a
seven :: S a -> S a
sOdd :: S a -> S a
sodd :: S a -> S a
sbreak :: (a -> Bool) -> S a -> ([a], S a)
sdropWhile :: (a -> Bool) -> S a -> S a
stakeWhile :: (a -> Bool) -> S a -> [a]
sfilter :: (a -> Bool) -> S a -> S a
spartition :: (a -> Bool) -> S a -> (S a, S a)
sspan :: (a -> Bool) -> S a -> ([a], S a)
scan :: (a -> b -> a) -> a -> S b -> S a
scan' :: (a -> b -> a) -> a -> S b -> S a
scan1 :: (a -> a -> a) -> S a -> S a
scan1' :: (a -> a -> a) -> S a -> S a
scycle :: [a] -> S a
siterate :: (a -> a) -> a -> S a
shead :: S a -> a
stail :: S a -> S a
tail2 :: S a -> S a
tails :: S a -> S (S a)
stake :: Integer -> S a -> [a]
sdrop :: Int -> S a -> S a
ssplitAt :: Int -> S a -> ([a], S a)
smerge :: S a -> S a -> S a
sunzip :: S (a, b) -> (S a, S b)
szipWith :: (a -> b -> c) -> S a -> S b -> S c
transpose :: S (S a) -> S (S a)
fromJust :: Maybe a -> a
fromOEIS :: String -> [Integer]
instance Functor S where
fmap f ~(Cons h t) = f h <|| fmap f t
instance Monad S where
return = srepeat
xs >>= f = join (fmap f xs)
where
join ~(Cons zs xss) = Cons (shead zs) (join (smap stail xss))
instance Arbitrary a => Arbitrary (S a) where
arbitrary = liftM2 (<||) arbitrary arbitrary
instance CoArbitrary a => CoArbitrary (S a) where
coarbitrary xs gen = do
n <- arbitrary
coarbitrary (stake (abs n) xs) gen
instance Serial a => Serial (S a) where
series = cons2 Cons
instance Idiom S where
pure a = s where s = a <|| s
s <> t = shead s (shead t) <|| stail s <> stail t
srepeat a = s where s = a <|| s
smap f s = f (shead s) <|| smap f (stail s)
zip g s t = g (shead s) (shead t) <|| zip g (stail s) (stail t)
instance (Num a) => Num (S a) where
(+) = zip (+)
() = zip ()
(*) = zip (*)
negate = sMap negate
abs = sMap abs
signum = sMap signum
fromInteger = srepeat . fromInteger
instance (Enum a) => Enum (S a) where
toEnum i = srepeat (toEnum i)
fromEnum = error "fromEnum: not defined for streams"
instance (Real a) => Real (S a) where
toRational = error "toRational: not defined for streams"
instance (Integral a) => Integral (S a) where
div = zip div
mod = zip mod
quotRem s t = sunzip (zip quotRem s t)
toInteger = error "toInteger: currently not defined for streams"
instance (Fractional a) => Fractional (S a) where
s / t = zip (Prelude./) s t
recip = smap recip
fromRational r = srepeat (fromRational r)
sunzip s = (a <|| as , b <|| bs)
where
(a , b ) = shead s
( as , bs) = sunzip (stail s)
sfilter p ~(Cons x xs)
| p x = Cons x (sfilter p xs)
| otherwise = sfilter p xs
stakeWhile p (Cons x xs)
| p x = x : stakeWhile p xs
| otherwise = []
sdropWhile p ~(Cons x xs)
| p x = sdropWhile p xs
| otherwise = Cons x xs
sspan p (Cons x xs)
| p x = let (trues, falses) = sspan p xs
in (x : trues, falses)
| otherwise = ([], Cons x xs)
sbreak p = sspan (not . p)
ssplitAt n xs
| n == 0 = ([],xs)
| n > 0 = let (prefix,rest) = ssplitAt (n1) (stail xs)
in (shead xs : prefix, rest)
| otherwise = error "S.splitAt negative argument."
spartition p ~(Cons x xs) =
let (trues,falses) = spartition p xs
in if p x then (Cons x trues, falses)
else (trues, Cons x falses)
group ~(Cons x ys) = let (xs, zs) = sspan (\y -> x == y) ys
in (x : xs) <|| group zs
sdrop n xs
| n == 0 = xs
| n > 0 = sdrop (n 1) (stail xs)
| otherwise = error "Stream.drop: negative argument."
inits xs = Cons [] (fmap (shead xs :) (inits (stail xs)))
tails xs = Cons xs (tails (stail xs))
(<||) = Cons
shead (Cons h _) = h
stail (Cons _ t) = t
anyA = anyA
stake 0 ___________ = []
stake (n) (Cons x xs) = x : stake (n1) xs
ago 0 (Cons x __) = x
ago (n) (Cons _ xs) = (n1) `ago` xs
s |~| t = shead s <|| t |~| stail s
s |!| t = s `union` t
map1 f s = f (shead s) <|| map1 f (stail s)
sMap f (Cons x xs) = f x <|| sMap f xs
merge s@(Cons m s') t@(Cons n t') =
if m <= n
then m <|| merge s' t
else n <|| merge s t'
union s@(Cons m s') t@(Cons n t') =
case compare m n
of
LT -> m <|| union s' t
EQ -> m <|| union s' t'
GT -> n <|| union s t'
sMap2 f (Cons x xs) (Cons y ys) = f x y <|| sMap2 f xs ys
sMap3 f (Cons x xs) (Cons y ys) (Cons z zs) = f x y z <|| sMap3 f xs ys zs
sMap4 f (Cons t ts) (Cons x xs) (Cons y ys) (Cons z zs) = f t x y z <|| sMap4 f ts xs ys zs
smerge (Cons m s) t = m <|| smerge t s
plus (Cons m s) (Cons n t) = m + n <|| plus s t
alternate (Cons m s) (Cons _ t) = m <|| alternate t s
interleave (Cons m s) (Cons n t) = m <|| interleave (n <|| t) s
interleave' (Cons m s) t = m <|| interleave' t s
szipWith f ~(Cons x xs) ~(Cons y ys) = Cons (f x y) (szipWith f xs ys)
interleave3 ~(Cons x xs) ys = Cons x (interleave3 ys xs)
intersperse y ~(Cons x xs) = Cons x (Cons y (intersperse y xs))
[ ] <<| s = s
(a:as) <<| s = a <|| (as <<| s)
turn n | n == 0 = []
turn n | n > 0 = turn (n1) ++ [n1] ++ turn (n1)
turn n | n < 0 = error "turn: negative argument"
turn _ = error "blah!"
scycle xs = foldr Cons (scycle xs) xs
diff (Cons m s@(Cons n _)) = n m <|| diff s
tail2 (Cons _ (Cons n s)) = n <|| s
times n (Cons m s) = n * m <|| times n s
asum s = 0 <|| s + asum s
bsum s = t where t = 0 <|| t + s
csum s = 0 <|| srepeat (shead s) + csum (stail s)
siterate f a = a <|| siterate f (f a)
dup s@(Cons m _) = m <|| s
inv (Cons m s) = (1 m) <|| inv s
seven (Cons m (Cons _ s)) = m <|| seven s
sodd (Cons _ (Cons n s)) = n <|| sodd s
sEven s = shead s <|| sOdd (stail s)
sOdd s = sEven (stail s)
scan f z ~(Cons x xs) = z <|| scan f (f z x) xs
scan' f z xs = z <|| (scan' f $! f z (shead xs)) (stail xs)
scan1 f ~(Cons x xs) = scan f x xs
scan1' f ~(Cons x xs) = scan' f x xs
transpose ~(Cons (Cons x xs) yss) =
(x <|| smap shead yss) <|| transpose (xs <|| smap stail yss)
dropIp1L (Cons m s ) = m <|| dropIp1L (stail s )
drop0L (Cons _ (Cons n s)) = n <|| drop0L (stail (stail s))
fix f = let x = f x in x
fwdFix g = fix (grow g)
revFix g = fix (rgen g)
grow g ~(Cons x xs) = g [] <|| grow (g . (x:)) xs
rgen' g ys ~(Cons x xs) = g ys <|| rgen' g (x:ys) xs
rgen g = rgen' g []
rep f [] = shead (f anyA)
rep f (x:xs) = rep (stail . f . (x <||) ) xs
unfold (h,t) z = Node (h z) (\x -> unfold (h,t) (t z x) )
cfix (h,t) z = fix (groW (h,t) z )
groW (h,t) z ~(Cons x xs) = h z <|| groW (h,t) (t z x) xs
label (Node y _) = y
branches (Node _ f) = f
toG (Node y _) [] = y
toG (Node _ f) (x:xs) = toG (f x) xs
toT g = Node (g []) (\x -> toT (g . (x:)))
fromT = cfix (label , branches)
fromFG = cfix (hOfFG , tOfFG)
fromRG = cfix (hOfRG , tOfRG)
hOfFG g = g []
tOfFG g x = g . (x:)
hOfRG (g,xs) = g xs
tOfRG (g, xs) x = (g, x:xs)
combStreams = foldr (zipWith (:)) (Prelude.repeat [])
allEqual = and . mapAdjacent (==)
mapAdjacent f xs = zipWith f xs (tail xs)
fromOEIS str = fromJust $ getSequenceByID str
fromJust Nothing = error "My programmer promised he knew what he was doing! He's a liar!"
fromJust (Just x) = x
sconst n = n <|| srepeat 0
z0 = 0 <|| 1 <|| srepeat 0
main :: IO ()
main = putStrLn "mine.hs"