diff --git a/Data/Stream/Branching.hs b/Data/Stream/Branching.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Branching.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE CPP, PatternGuards, UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Branching +-- Copyright : (C) 2011 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- +module Data.Stream.Branching ( + -- * The type of streams + Stream(..) + -- * Basic functions + , head -- Stream f a -> a + , tail -- Stream f a -> f (Stream f a) + , tails -- Stream f a -> Stream f (Stream f a) + , inits1 -- Stream f a -> Stream f (NonEmpty a) + , unfold -- + ) where + +import Prelude hiding (head, tail) + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Apply +import Control.Monad +import Data.Functor.Apply +import Data.Stream.NonEmpty hiding (tail, tails, unfold, head) +import qualified Data.Stream.NonEmpty as NonEmpty + +#ifdef GHC_TYPEABLE +import Data.Data +#endif + +infixr 5 :< + +data Stream f a = a :< f (Stream f a) + +head :: Stream f a -> a +head (a :< _) = a +{-# INLINE head #-} + +tail :: Stream f a -> f (Stream f a) +tail (_ :< as) = as +{-# INLINE tail #-} + +tails :: Functor f => Stream f a -> Stream f (Stream f a) +tails = duplicate +{-# INLINE tails #-} + +-- | equivalent to inits sans the initial [] context +inits1 :: Functor f => Stream f a -> Stream f (NonEmpty a) +inits1 (a :< as) = (a :| []) :< (fmap (NonEmpty.cons a) . inits1 <$> as) + +instance Functor f => Functor (Stream f) where + fmap f (a :< as) = f a :< fmap (fmap f) as + b <$ (_ :< as) = b :< fmap (b <$) as + +instance Functor f => Comonad (Stream f) where + extract (a :< _) = a + extend f w = f w :< fmap (extend f) (tail w) + duplicate w = w :< fmap duplicate (tail w) + +instance FunctorApply f => FunctorApply (Stream f) where + (f :< fs) <.> (a :< as) = f a :< ((<.>) <$> fs <.> as) + (f :< fs) <. (_ :< as) = f :< ((<. ) <$> fs <.> as) + (_ :< fs) .> (a :< as) = a :< (( .>) <$> fs <.> as) + +instance FunctorApply f => ComonadApply (Stream f) + +instance Applicative f => Applicative (Stream f) where + pure a = as where as = a :< pure as + (f :< fs) <*> (a :< as) = f a :< ((<*>) <$> fs <*> as) + (f :< fs) <* (_ :< as) = f :< ((<* ) <$> fs <*> as) + (_ :< fs) *> (a :< as) = a :< (( *>) <$> fs <*> as) + +unfold :: Functor f => (b -> (a, f b)) -> b -> Stream f a +unfold f c | (x, d) <- f c = x :< fmap (unfold f) d + +instance (Show (f (Stream f a)), Show a) => Show (Stream f a) where + showsPrec d (a :< as) = showParen (d > 5) $ + showsPrec 6 a . showString " :< " . showsPrec 5 as + +instance (Eq (f (Stream f a)), Eq a) => Eq (Stream f a) where + a :< as == b :< bs = a == b && as == bs + +instance (Ord (f (Stream f a)), Ord a) => Ord (Stream f a) where + compare (a :< as) (b :< bs) = case compare a b of + LT -> LT + EQ -> compare as bs + GT -> GT + +#ifdef GHC_TYPEABLE + +instance (Typeable1 f) => Typeable1 (Stream f) where + typeOf1 dfa = mkTyConApp streamTyCon [typeOf1 (f dfa)] + where + f :: Stream f a -> f a + f = undefined + +instance (Typeable1 f, Typeable a) => Typeable (Stream f a) where + typeOf = typeOfDefault + +streamTyCon :: TyCon +streamTyCon = mkTyCon "Data.Stream.Branching.Stream" +{-# NOINLINE streamTyCon #-} + +instance + ( Typeable1 f + , Data (f (Stream f a)) + , Data a + ) => Data (Stream f a) where + gfoldl f z (a :< as) = z (:<) `f` a `f` as + toConstr _ = streamConstr + gunfold k z c = case constrIndex c of + 1 -> k (k (z (:<))) + _ -> error "gunfold" + dataTypeOf _ = streamDataType + dataCast1 f = gcast1 f + +streamConstr :: Constr +streamConstr = mkConstr streamDataType ":<" [] Infix +{-# NOINLINE streamConstr #-} + +streamDataType :: DataType +streamDataType = mkDataType "Data.Stream.Branching.Stream" [streamConstr] +{-# NOINLINE streamDataType #-} + +#endif diff --git a/Data/Stream/Future.hs b/Data/Stream/Future.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Future.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Future +-- Copyright : (C) 2011 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +---------------------------------------------------------------------------- + +module Data.Stream.Future + ( Future(..) + , cons, (<|) + , head + , tail + , length + , tails + , map + , index + ) where + +import Prelude hiding (head, tail, map, length) +import Control.Applicative +import Control.Applicative.Alt +import Control.Comonad +import Control.Comonad.Apply +import Data.Foldable +import Data.Functor.Alt +import Data.Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif + +infixr 5 :<, <| + +data Future a = Last a | a :< Future a deriving + ( Eq, Ord, Show, Read +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +(<|) :: a -> Future a -> Future a +(<|) = (:<) +{-# INLINE (<|) #-} + +cons :: a -> Future a -> Future a +cons = (:<) +{-# INLINE cons #-} + +head :: Future a -> a +head (Last a) = a +head (a :< _) = a +{-# INLINE head #-} + +length :: Future a -> Int +length = go 1 + where + go !n (Last _) = n + go !n (_ :< as) = go (n + 1) as +{-# INLINE length #-} + +tail :: Future a -> Maybe (Future a) +tail (Last _) = Nothing +tail (_ :< as) = Just as +{-# INLINE tail #-} + +tails :: Future a -> Future (Future a) +tails w@(_ :< as) = w :< tails as +tails w@(Last _) = Last w +{-# INLINE tails #-} + +map :: (a -> b) -> Future a -> Future b +map f (a :< as) = f a :< map f as +map f (Last a) = Last (f a) +{-# INLINE map #-} + +index :: Int -> Future a -> a +index n aas + | n < 0 = error "index: negative index" + | n == 0 = extract aas + | otherwise = case aas of + Last _ -> error "index: out of range" + _ :< as -> index (n - 1) as + +instance Functor Future where + fmap = map + b <$ (_ :< as) = b :< (b <$ as) + b <$ _ = Last b + +instance Foldable Future where + foldMap = foldMapDefault + +instance Traversable Future where + traverse f (Last a) = Last <$> f a + traverse f (a :< as) = (:<) <$> f a <*> traverse f as + +instance Foldable1 Future + +instance Traversable1 Future where + traverse1 f (Last a) = Last <$> f a + traverse1 f (a :< as) = (:<) <$> f a <.> traverse1 f as + +instance Comonad Future where + extract = head + duplicate = tails + extend f w@(_ :< as) = f w :< extend f as + extend f w@(Last _) = Last (f w) + +instance FunctorApply Future where + Last f <.> Last a = Last (f a) + (f :< _) <.> Last a = Last (f a) + Last f <.> (a :< _ ) = Last (f a) + (f :< fs) <.> (a :< as) = f a :< (fs <.> as) + + Last a <. _ = Last a + (a :< _ ) <. Last _ = Last a + (a :< as) <. (_ :< bs) = a :< (as <. bs) + + _ .> Last b = Last b + Last _ .> (b :< _) = Last b + (_ :< as) .> (b :< bs) = b :< (as .> bs) + +instance FunctorAlt Future where + Last a bs = a :< bs + (a :< as) bs = a :< (as bs) + +instance Semigroup (Future a) where + (<>) = () + +instance ComonadApply Future + +instance Applicative Future where + pure = Last + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance ApplicativeAlt Future + + diff --git a/Data/Stream/Future/Skew.hs b/Data/Stream/Future/Skew.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Future/Skew.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE PatternGuards, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Future.Skew +-- Copyright : (C) 2008-2011 Edward Kmett, +-- (C) 2004 Dave Menendez +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- Anticausal streams implemented as non-empty skew binary random access lists +-- +-- The Applicative zips streams, but since these are potentially infinite +-- this is stricter than would be desired. You almost always want +------------------------------------------------------------------------------ + + +module Data.Stream.Future.Skew + ( Future(..) + , (<|) -- O(1) + , cons + , length -- O(log n) + , head -- O(1) + , tail -- O(1) + , tails + , last -- O(log n) + , uncons -- O(1) + , index -- O(log n) + , drop -- O(log n) + , dropWhile -- O(n) + , indexed + , from + , break + , span + , split -- O(log n) + , splitW -- O(log n) + , repeat + , replicate -- O(log n) + , insert -- O(n) + , insertBy + , update + , adjust -- O(log n) + , fromList + , toFuture + ) where + +import Control.Applicative hiding (empty) +import Control.Comonad +import Control.Comonad.Apply +import Data.Functor.Alt +import Data.Functor.Apply +import Data.Foldable hiding (toList) +import Data.Traversable (Traversable, traverse) +import qualified Data.Traversable as Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Monoid (Monoid(mappend)) +import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, break) + +infixr 5 :<, <| + +data Complete a + = Tip a + | Bin {-# UNPACK #-} !Int a !(Complete a) !(Complete a) + deriving Show + +instance Functor Complete where + fmap f (Tip a) = Tip (f a) + fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r) + +instance Comonad Complete where + extract (Tip a) = a + extract (Bin _ a _ _) = a + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + +instance Foldable Complete where + foldMap f (Tip a) = f a + foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + foldr f z (Tip a) = f a z + foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l) + +instance Foldable1 Complete where + foldMap1 f (Tip a) = f a + foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Complete where + traverse f (Tip a) = Tip <$> f a + traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Complete where + traverse1 f (Tip a) = Tip <$> f a + traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r + +bin :: a -> Complete a -> Complete a -> Complete a +bin a l r = Bin (1 + weight l + weight r) a l r +{-# INLINE bin #-} + +weight :: Complete a -> Int +weight Tip{} = 1 +weight (Bin w _ _ _) = w +{-# INLINE weight #-} + +-- A future is a non-empty skew binary random access list of nodes. +-- The last node, however, is allowed to contain fewer values. +data Future a + = Last !(Complete a) + | !(Complete a) :< Future a +-- deriving Show + + +instance Show a => Show (Future a) where + showsPrec d as = showParen (d >= 10) $ + showString "fromList " . showsPrec 11 (toList as) + +instance Functor Future where + fmap f (t :< ts) = fmap f t :< fmap f ts + fmap f (Last t) = Last (fmap f t) + +instance Comonad Future where + extract = head + extend g (Last t) = Last (extendTree g t Last) + extend g (t :< ts) = extendTree g t (:< ts) :< extend g ts + +extendTree :: (Future a -> b) -> Complete a -> (Complete a -> Future a) -> Complete b +extendTree g w@Tip{} f = Tip (g (f w)) +extendTree g w@(Bin n _ l r) f = Bin n (g (f w)) (extendTree g l (:< f r)) (extendTree g r f) + +instance FunctorApply Future where + Last (Tip f) <.> as = singleton (f (extract as)) + fs <.> Last (Tip a) = singleton (extract fs a) + Last (Bin _ f lf rf) <.> Last (Bin _ a la ra) = f a <| (lf :< Last rf <.> la :< Last ra ) + Last (Bin _ f lf rf) <.> Bin _ a la ra :< as = f a <| (lf :< Last rf <.> la :< ra :< as) + Last (Bin _ f lf rf) <.> Tip a :< as = f a <| (lf :< Last rf <.> as ) + Bin _ f lf rf :< fs <.> Last (Bin _ a la ra) = f a <| (lf :< rf :< fs <.> la :< Last ra ) + Bin _ f lf rf :< fs <.> Tip a :< as = f a <| (lf :< rf :< fs <.> as ) + Bin _ f lf rf :< fs <.> Bin _ a la ra :< as = f a <| (lf :< rf :< fs <.> la :< ra :< as) + Tip f :< fs <.> Tip a :< as = f a <| (fs <.> as ) + Tip f :< fs <.> Bin _ a la ra :< as = f a <| (fs <.> la :< ra :< as) + Tip f :< fs <.> Last (Bin _ a la ra) = f a <| (fs <.> la :< Last ra ) + +instance ComonadApply Future + +instance Applicative Future where + pure = repeat + (<*>) = (<.>) + +instance FunctorAlt Future where + as bs = foldr (<|) bs as + +instance Foldable Future where + foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts + foldMap f (Last t) = foldMap f t + foldr f z (t :< ts) = foldr f (foldr f z ts) t + foldr f z (Last t) = foldr f z t + +toList :: Future a -> [a] +toList = foldr (:) [] + +instance Foldable1 Future where + foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts + foldMap1 f (Last t) = foldMap1 f t + +instance Traversable Future where + traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts + traverse f (Last t) = Last <$> traverse f t + +instance Traversable1 Future where + traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts + traverse1 f (Last t) = Last <$> traverse1 f t + +repeat :: a -> Future a +repeat a0 = go a0 (Tip a0) + where + go :: a -> Complete a -> Future a + go a as | ass <- bin a as as = as :< go a ass +{-# INLINE repeat #-} + +-- | /O(log n)/ +replicate :: Int -> a -> Future a +replicate n a + | n <= 0 = error "replicate: non-positive argument" + | otherwise = go 1 n a (Tip a) (\0 r -> r) + where + -- invariants: + -- tb is a complete tree of i nodes all equal to b + -- 1 <= i = 2^m-1 <= j + -- k accepts r such that 0 <= r < i + go :: Int -> Int -> b -> Complete b -> (Int -> Future b -> r) -> r + go !i !j b tb k + | j >= i2p1 = go i2p1 j b (Bin i2p1 b tb tb) k' + | j >= i2 = k (j - i2) (tb :< Last tb) + | otherwise = k (j - i) (Last tb) + where + i2 = i * 2 + i2p1 = i2 + 1 + k' r xs + | r >= i2 = k (r - i2) (tb :< tb :< xs) + | r >= i = k (r - i) (tb :< xs) + | otherwise = k r xs +{-# INLINE replicate #-} + +mapWithIndex :: (Int -> a -> b) -> Future a -> Future b +mapWithIndex f0 as0 = spine f0 0 as0 + where + spine f m (Last as) = Last (tree f m as) + spine f m (a :< as) = tree f m a :< spine f (m + weight a) as + tree f m (Tip a) = Tip (f m a) + tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r) + +indexed :: Future a -> Future (Int, a) +indexed = mapWithIndex (,) +{-# INLINE indexed #-} + +from :: Num a => a -> Future a +from a = mapWithIndex ((+) . fromIntegral) (pure a) +{-# INLINE from #-} + +-- | /O(1)/ +singleton :: a -> Future a +singleton a = Last (Tip a) +{-# INLINE singleton #-} + +-- | /O(log n)/. +length :: Future a -> Int +length (Last t) = weight t +length (t :< ts) = weight t + length ts + +-- | /O(1)/ cons +(<|) :: a -> Future a -> Future a +a <| (l :< Last r) + | weight l == weight r = Last (bin a l r) +a <| (l :< r :< as) + | weight l == weight r = bin a l r :< as +a <| as = Tip a :< as +{-# INLINE (<|) #-} + + +cons :: a -> Future a -> Future a +cons = (<|) +{-# INLINE cons #-} + +-- | /O(1)/ +head :: Future a -> a +head (a :< _) = extract a +head (Last a) = extract a +{-# INLINE head #-} + +-- | /O(1)/. +tail :: Future a -> Maybe (Future a) +tail (Tip{} :< ts) = Just ts +tail (Bin _ _ l r :< ts) = Just (l :< r :< ts) +tail (Last Tip{}) = Nothing +tail (Last (Bin _ _ l r)) = Just (l :< Last r) +{-# INLINE tail #-} + +tails :: Future a -> Future (Future a) +tails = duplicate +{-# INLINE tails #-} + +-- | /O(log n)/. +last :: Future a -> a +last (_ :< as) = last as +last (Last as) = go as + where go (Tip a) = a + go (Bin _ _ _ r) = go r + +-- | /O(1)/. +uncons :: Future a -> (a, Maybe (Future a)) +uncons (Last (Tip a)) = (a, Nothing) +uncons (Last (Bin _ a l r)) = (a, Just (l :< Last r)) +uncons (Tip a :< as) = (a, Just as) +uncons (Bin _ a l r :< as) = (a, Just (l :< r :< as)) +{-# INLINE uncons #-} + +-- | /O(log n)/. +index :: Int -> Future a -> a +index i (Last t) + | i < weight t = indexComplete i t + | otherwise = error "index: out of range" +index i (t :< ts) + | i < w = indexComplete i t + | otherwise = index (i - w) ts + where w = weight t + +indexComplete :: Int -> Complete a -> a +indexComplete 0 (Tip a) = a +indexComplete i (Bin w a l r) + | i == 0 = a + | i <= w' = indexComplete (i-1) l + | otherwise = indexComplete (i-1-w') r + where w' = div w 2 +indexComplete _ _ = error "index: index out of range" + +-- | /O(log n)/. +drop :: Int -> Future a -> Maybe (Future a) +drop 0 ts = Just ts +drop i (t :< ts) = case compare i w of + LT -> Just (dropComplete i t (:< ts)) + EQ -> Just ts + GT -> drop (i - w) ts + where w = weight t +drop i (Last t) + | i < w = Just (dropComplete i t Last) + | otherwise = Nothing + where w = weight t + +dropComplete :: Int -> Complete a -> (Complete a -> Future a) -> Future a +dropComplete 0 t f = f t +dropComplete 1 (Bin _ _ l r) f = l :< f r +dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of + LT -> dropComplete (i-1) l (:< f r) + EQ -> f r + GT -> dropComplete (i-1-w') r f + where w' = div w 2 +dropComplete _ _ _ = error "drop: index out of range" + +-- /O(n)/. +dropWhile :: (a -> Bool) -> Future a -> Maybe (Future a) +dropWhile p as + | p (head as) = tail as >>= dropWhile p + | otherwise = Just as + +-- /O(n)/ +span :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +span p aas = case uncons aas of + (a, Just as) | p a, (ts, fs) <- span p as -> (a:ts, fs) + (a, Nothing) | p a -> ([a], Nothing) + (_, _) -> ([], Just aas) + +-- /O(n)/ +break :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +break p = span (not . p) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +split :: (a -> Bool) -> Future a -> ([a], Maybe (Future a)) +split p l@(Last a) + | p (extract a) = ([], Just l) + | otherwise = splitComplete p a Last +split p (a :< as) + | p (extract as) = splitComplete p a (:< as) + | (ts, fs) <- split p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a)) +splitComplete p t@(Tip a) f + | p a = ([], Just (f t)) + | otherwise = ([a], Nothing) +splitComplete p t@(Bin _ a l r) f + | p a = ([], Just (f t)) + | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs) + | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +-- +-- > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate +splitW :: (Future a -> Bool) -> Future a -> ([a], Maybe (Future a)) +splitW p l@(Last a) + | p l = ([], Just l) + | otherwise = splitCompleteW p a Last +splitW p (a :< as) + | p as = splitCompleteW p a (:< as) + | (ts, fs) <- splitW p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitCompleteW :: (Future a -> Bool) -> Complete a -> (Complete a -> Future a) -> ([a], Maybe (Future a)) +splitCompleteW p t@(Tip a) f + | w <- f t, p w = ([], Just w) + | otherwise = ([a], Nothing) +splitCompleteW p t@(Bin _ a l r) f + | w <- f t, p w = ([], Just w) + | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs) + | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs) + +fromList :: [a] -> Future a +fromList [] = error "fromList: empty list" +fromList (x:xs) = go x xs + where go a [] = singleton a + go a (b:bs) = a <| go b bs + +toFuture :: [a] -> Maybe (Future a) +toFuture [] = Nothing +toFuture xs = Just (fromList xs) + +-- /O(n)/ +insert :: Ord a => a -> Future a -> Future a +insert a as = case split (a<=) as of + (_, Nothing) -> foldr (<|) (singleton a) as + (ts, Just as') -> foldr (<|) (a <| as') ts + +-- /O(n)/. Finds the split in O(log n), but then has to recons +insertBy :: (a -> a -> Ordering) -> a -> Future a -> Future a +insertBy cmp a as = case split (\b -> cmp a b <= EQ) as of + (_, Nothing) -> foldr (<|) (singleton a) as + (ts, Just as') -> foldr (<|) (a <| as') ts + +-- /O(log n)/ Change the value of the nth entry in the future +adjust :: Int -> (a -> a) -> Future a -> Future a +adjust !n f d@(Last a) + | n < weight a = Last (adjustComplete n f a) + | otherwise = d +adjust !n f (a :< as) + | n < w = adjustComplete n f a :< as + | otherwise = a :< adjust (n - w) f as + where w = weight a + +adjustComplete :: Int -> (a -> a) -> Complete a -> Complete a +adjustComplete 0 f (Tip a) = Tip (f a) +adjustComplete _ _ t@Tip{} = t +adjustComplete n f (Bin m a l r) + | n == 0 = Bin m (f a) l r + | n < w = Bin m a (adjustComplete (n - 1) f l) r + | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r) + where w = weight l + +update :: Int -> a -> Future a -> Future a +update n = adjust n . const diff --git a/Data/Stream/Infinite.hs b/Data/Stream/Infinite.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Infinite.hs @@ -0,0 +1,444 @@ +{-# LANGUAGE PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Infinite +-- Copyright : (C) 2011 Edward Kmett, +-- (C) 2007-2010 Wouter Swierstra, Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable (Haskell 2010) +-- +---------------------------------------------------------------------------- +module Data.Stream.Infinite ( + -- * The type of streams + Stream(..) + -- * Basic functions + , head -- :: Stream a -> a + , tail -- :: Stream a -> Stream a + , inits -- :: Stream a -> Stream [a] + , tails -- :: Stream a -> Stream (Stream a) + -- * Stream transformations + , map -- :: (a -> b) -> Stream a -> Stream b + , intersperse -- :: a -> Stream a -> Stream + , interleave -- :: Stream a -> Stream a -> Stream a + , scanl -- :: (b -> a -> b) -> b -> Stream a -> Stream b + , scanl' -- :: (b -> a -> b) -> b -> Stream a -> Stream b + , scanl1 -- :: (a -> a -> a) -> Stream a -> Stream a + , scanl1' -- :: (a -> a -> a) -> Stream a -> Stream a + , transpose -- :: Stream (Stream a) -> Stream (Stream a) + -- * Building streams + , iterate -- :: (a -> a) -> a -> Stream a + , repeat -- :: a -> Stream a + , cycle -- :: NonEmpty a -> Stream a + , unfold -- :: (a -> (b, a)) -> a -> Stream b + -- * Extracting sublists + , take -- :: Int -> Stream a -> [a] + , drop -- :: Int -> Stream a -> Stream a + , splitAt -- :: Int -> Stream a -> ([a],Stream a) + , takeWhile -- :: (a -> Bool) -> Stream a -> [a] + , dropWhile -- :: (a -> Bool) -> Stream a -> Stream a + , span -- :: (a -> Bool) -> Stream a -> ([a], Stream a) + , break -- :: (a -> Bool) -> Stream a -> ([a], Stream a) + , filter -- :: (a -> Bool) -> Stream a -> Stream a + , partition -- :: (a -> Bool) -> Stream a -> (Stream a, Stream a) + , group -- :: (a -> Bool) -> Stream a -> Stream (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: [a] -> Stream a -> Bool + -- * Indexing streams + , (!!) -- :: Int -> Stream a -> a + , elemIndex -- :: Eq a => a -> Stream a -> Int + , elemIndices -- :: Eq a => a -> Stream a -> Stream Int + , findIndex -- :: (a -> Bool) -> Stream a -> Int + , findIndices -- :: (a -> Bool) -> Stream a -> Stream Int + -- * Zipping and unzipping streams + , zip -- :: Stream a -> Stream b -> Stream (a, b) + , zipWith -- :: (a -> b -> c) -> Stream a -> Stream b -> Stream c + , unzip -- :: Functor f => f (a, b) -> (f a, f b) + -- * Functions on streams of characters + , words -- :: Stream Char -> Stream String + , unwords -- :: Stream String -> Stream Char + , lines -- :: Stream Char -> Stream String + , unlines -- :: Stream String -> Stream Char + -- * Converting to and from an infinite list + , fromList -- :: [a] -> Stream a + ) where + +import Prelude hiding + ( head, tail, map, scanr, scanr1, scanl, scanl1 + , iterate, take, drop, takeWhile + , dropWhile, repeat, cycle, filter + , (!!), zip, unzip, zipWith, words + , unwords, lines, unlines, break, span + , splitAt, foldr + ) + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Apply +import Data.Char (isSpace) +import Data.Data +import Data.Functor.Apply +import Data.Monoid +import Data.Semigroup +import Data.Foldable +import Data.Traversable +import Data.Semigroup.Traversable +import Data.Semigroup.Foldable +import Data.Stream.NonEmpty (NonEmpty(..)) + +data Stream a = a :> Stream a deriving + ( Show +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +infixr 5 :> + +-- | Map a pure function over a stream +map :: (a -> b) -> Stream a -> Stream b +map f (a :> as) = f a :> map f as + +instance Functor Stream where + fmap = map + b <$ _ = repeat b + +-- | Extract the first element of the sequence. +head :: Stream a -> a +head (a :> _) = a +{-# INLINE head #-} + +-- | Extract the sequence following the head of the stream. +tail :: Stream a -> Stream a +tail (_ :> as) = as +{-# INLINE tail #-} + +-- | The 'tails' function takes a stream @xs@ and returns all the +-- suffixes of @xs@. +tails :: Stream a -> Stream (Stream a) +tails w = w :> tails (tail w) + +instance Comonad Stream where + extract = head + duplicate = tails + extend f w = f w :> extend f (tail w) + +instance FunctorApply Stream where + (f :> fs) <.> (a :> as) = f a :> (fs <.> as) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream + +-- | 'repeat' @x@ returns a constant stream, where all elements are +-- equal to @x@. +repeat :: a -> Stream a +repeat a = as where as = a :> as + +instance Applicative Stream where + pure = repeat + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Foldable Stream where + fold (m :> ms) = m `mappend` fold ms + foldMap f (a :> as) = f a `mappend` foldMap f as + foldr f0 _ = go f0 where go f (a :> as) = f a (go f as) + +instance Traversable Stream where + traverse f ~(a :> as) = (:>) <$> f a <*> traverse f as + +instance Foldable1 Stream + +instance Traversable1 Stream where + traverse1 f ~(a :> as) = (:>) <$> f a <.> traverse1 f as + sequence1 ~(a :> as) = (:>) <$> a <.> sequence1 as + +-- | The unfold function is similar to the unfold for lists. Note +-- there is no base case: all streams must be infinite. +unfold :: (a -> (b, a)) -> a -> Stream b +unfold f c | (x, d) <- f c = x :> unfold f d + +instance Monad Stream where + return = repeat + m >>= f = unfold (\(bs :> bss) -> (head bs, tail <$> bss)) (fmap f m) + _ >> bs = bs + +-- | Interleave two Streams @xs@ and @ys@, alternating elements +-- from each list. +-- +-- > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...] +interleave :: Stream a -> Stream a -> Stream a +interleave ~(x :> xs) ys = x :> interleave ys xs + +instance Semigroup (Stream a) where + (<>) = interleave + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +-- +-- Note that this 'inits' is lazier then @Data.List.inits@: +-- +-- > inits _|_ = [] ::: _|_ +-- +-- while for @Data.List.inits@: +-- +-- > inits _|_ = _|_ +inits :: Stream a -> Stream [a] +inits xs = [] :> ((head xs :) <$> inits (tail xs)) + +-- | @'intersperse' y xs@ creates an alternating stream of +-- elements from @xs@ and @y@. +intersperse :: a -> Stream a -> Stream a +intersperse y ~(x :> xs) = x :> y :> intersperse y xs + +-- | 'scanl' yields a stream of successive reduced values from: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl :: (a -> b -> a) -> a -> Stream b -> Stream a +scanl f z ~(x :> xs) = z :> scanl f (f z x) xs + +-- | 'scanl' yields a stream of successive reduced values from: +-- +-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +scanl' :: (a -> b -> a) -> a -> Stream b -> Stream a +scanl' f z ~(x :> xs) = z :> (scanl' f $! f z x) xs + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] +scanl1 :: (a -> a -> a) -> Stream a -> Stream a +scanl1 f ~(x :> xs) = scanl f x xs + +-- | @scanl1'@ is a strict 'scanl' that has no starting value. +scanl1' :: (a -> a -> a) -> Stream a -> Stream a +scanl1' f ~(x :> xs) = scanl' f x xs + +-- | 'transpose' computes the transposition of a stream of streams. +transpose :: Stream (Stream a) -> Stream (Stream a) +transpose ~((x :> xs) :> yss) = + (x :> (head <$> yss)) :> transpose (xs :> (tail <$> yss)) + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = [x, f x, f (f x), ..] +iterate :: (a -> a) -> a -> Stream a +iterate f x = x :> iterate f (f x) + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle [1,2,3] = Cons 1 (Cons 2 (Cons 3 (Cons 1 (Cons 2 ... +cycle :: NonEmpty a -> Stream a +cycle xs = ys where ys = foldr (:>) ys xs + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +take :: Int -> Stream a -> [a] +take n ~(x :> xs) + | n == 0 = [] + | n > 0 = x : take (n - 1) xs + | otherwise = error "Stream.take: negative argument" + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +drop :: Int -> Stream a -> Stream a +drop n xs + | n == 0 = xs + | n > 0 = drop (n - 1) (tail xs) + | otherwise = error "Stream.drop: negative argument" + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of +-- @xs@ of length @n@ and the remaining stream immediately following +-- this prefix. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +splitAt :: Int -> Stream a -> ([a],Stream a) +splitAt n xs + | n == 0 = ([],xs) + | n > 0, (prefix, rest) <- splitAt (n - 1) (tail xs) = (head xs : prefix, rest) + | otherwise = error "Stream.splitAt: negative argument" + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> Stream a -> [a] +takeWhile p (x :> xs) + | p x = x : takeWhile p xs + | otherwise = [] + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +-- +-- /Beware/: this function may diverge if every element of @xs@ +-- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop. +dropWhile :: (a -> Bool) -> Stream a -> Stream a +dropWhile p ~(x :> xs) + | p x = dropWhile p xs + | otherwise = x :> xs + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +span :: (a -> Bool) -> Stream a -> ([a], Stream a) +span p xxs@(x :> xs) + | p x, (ts, fs) <- span p xs = (x : ts, fs) + | otherwise = ([], xxs) + +-- | The 'break' @p@ function is equivalent to 'span' @not . p@. +break :: (a -> Bool) -> Stream a -> ([a], Stream a) +break p = span (not . p) + +-- | @'filter' p xs@, removes any elements from @xs@ that do not satisfy @p@. +-- +-- /Beware/: this function may diverge if there is no element of +-- @xs@ that satisfies @p@, e.g. @filter odd (repeat 0)@ will loop. +filter :: (a -> Bool) -> Stream a -> Stream a +filter p ~(x :> xs) + | p x = x :> filter p xs + | otherwise = filter p xs + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of streams. The first stream corresponds +-- to the elements of @xs@ for which @p@ holds; the second stream +-- corresponds to the elements of @xs@ for which @p@ does not hold. +-- +-- /Beware/: One of the elements of the tuple may be undefined. For +-- example, @fst (partition even (repeat 0)) == repeat 0@; on the +-- other hand @snd (partition even (repeat 0))@ is undefined. +partition :: (a -> Bool) -> Stream a -> (Stream a, Stream a) +partition p ~(x :> xs) + | p x = (x :> ts, fs) + | otherwise = (ts, x :> fs) + where (ts, fs) = partition p xs + +-- | The 'group' function takes a stream and returns a stream of +-- lists such that flattening the resulting stream is equal to the +-- argument. Moreover, each sublist in the resulting stream +-- contains only equal elements. For example, +-- +-- > group $ cycle "Mississippi" = "M" ::: "i" ::: "ss" ::: "i" ::: "ss" ::: "i" ::: "pp" ::: "i" ::: "M" ::: "i" ::: ... +group :: Eq a => Stream a -> Stream (NonEmpty a) +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> Stream a -> Stream (NonEmpty a) +groupBy eq ~(x :> ys) + | (xs, zs) <- span (eq x) ys + = (x :| xs) :> groupBy eq zs + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> Stream a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :> xs) + | y == x = isPrefixOf ys xs + | otherwise = False + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: passing a negative integer as the first argument will cause +-- an error. +(!!) :: Stream a -> Int -> a +(!!) (x :> xs) n + | n == 0 = x + | n > 0 = xs !! (n - 1) + | otherwise = error "Stream.!! negative argument" + +-- | The 'elemIndex' function returns the index of the first element +-- in the given stream which is equal (by '==') to the query element, +-- +-- /Beware/: @'elemIndex' x xs@ will diverge if none of the elements +-- of @xs@ equal @x@. +elemIndex :: Eq a => a -> Stream a -> Int +elemIndex x = findIndex (\y -> x == y) + +-- | The 'elemIndices' function extends 'elemIndex', by returning the +-- indices of all elements equal to the query element, in ascending order. +-- +-- /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of +-- @xs@ does not contain @x@. +elemIndices :: Eq a => a -> Stream a -> Stream Int +elemIndices x = findIndices (x==) + +-- | The 'findIndex' function takes a predicate and a stream and returns +-- the index of the first element in the stream that satisfies the predicate, +-- +-- /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of +-- @xs@ satisfy @p@. +findIndex :: (a -> Bool) -> Stream a -> Int +findIndex p = indexFrom 0 + where + indexFrom ix (x :> xs) + | p x = ix + | otherwise = (indexFrom $! (ix + 1)) xs + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending +-- order. +-- +-- /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements +-- of any suffix of @xs@ fails to satisfy @p@. +findIndices :: (a -> Bool) -> Stream a -> Stream Int +findIndices p = indicesFrom 0 where + indicesFrom ix (x :> xs) + | p x = ix :> ixs + | otherwise = ixs + where ixs = (indicesFrom $! (ix+1)) xs + +-- | The 'zip' function takes two streams and returns a list of +-- corresponding pairs. +zip :: Stream a -> Stream b -> Stream (a,b) +zip ~(x :> xs) ~(y :> ys) = (x,y) :> zip xs ys + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the functions, the elements are combined using the function +-- passed as the first argument to 'zipWith'. +zipWith :: (a -> b -> c) -> Stream a -> Stream b -> Stream c +zipWith f ~(x :> xs) ~(y :> ys) = f x y :> zipWith f xs ys + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Stream (a,b) -> (Stream a, Stream b) +unzip xs = (fst <$> xs, snd <$> xs) + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +-- +-- /Beware/: if the stream of characters @xs@ does not contain white +-- space, accessing the tail of @words xs@ will loop. +words :: Stream Char -> Stream String +words xs | (w, ys) <- break isSpace xs = w :> words ys + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +unwords :: Stream String -> Stream Char +unwords ~(x :> xs) = foldr (:>) (' ' :> unwords xs) x + +-- | The 'lines' function breaks a stream of characters into a list +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +-- +-- /Beware/: if the stream of characters @xs@ does not contain +-- newline characters, accessing the tail of @lines xs@ will loop. +lines :: Stream Char -> Stream String +lines xs | (l, ys) <- break (== '\n') xs = l :> lines (tail ys) + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: Stream String -> Stream Char +unlines ~(x :> xs) = foldr (:>) ('\n' :> unlines xs) x + +-- | The 'fromList' converts an infinite list to a +-- stream. +-- +-- /Beware/: Passing a finite list, will cause an error. +fromList :: [a] -> Stream a +fromList (x:xs) = x :> fromList xs +fromList [] = error "Stream.listToStream applied to finite list" diff --git a/Data/Stream/Infinite/Functional/Zipper.hs b/Data/Stream/Infinite/Functional/Zipper.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Infinite/Functional/Zipper.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE DeriveDataTypeable, PatternGuards, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Zipper.Infinite.Functional.Zipper +-- Copyright : (C) 2011 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This is an infinite bidirectional zipper +---------------------------------------------------------------------------- +module Data.Stream.Infinite.Functional.Zipper ( + -- * The type of streams + Zipper(..) + , tail -- :: Zipper a -> Zipper a + , untail -- :: Zipper a -> Zipper a + , intersperse -- :: a -> Zipper a -> Zipper a + , interleave -- :: Zipper a -> Zipper a -> Zipper a + , transpose -- :: Zipper (Zipper a) -> Zipper (Zipper a) + , take -- :: Integer -> Zipper a -> [a] + , drop -- :: Integer -> Zipper a -> Zipper a -- you can drop a negative number + , splitAt -- :: Integer -> Zipper a -> ([a],Zipper a) + , reverse -- :: Zipper a -> Zipper a + , (!!) -- :: Int -> Zipper a -> a + , unzip -- :: Functor f => f (a, b) -> (f a, f b) + , toSequence -- :: (Integer -> a) -> Zipper a + , head + , (<|) + , uncons + , takeWhile + , dropWhile + , span + , break + , isPrefixOf + , findIndex + , elemIndex + , zip + , zipWith + ) where + +import Prelude hiding + ( head, tail, map, scanr, scanr1, scanl, scanl1 + , iterate, take, drop, takeWhile + , dropWhile, repeat, cycle, filter + , (!!), zip, unzip, zipWith, words + , unwords, lines, unlines, break, span + , splitAt, foldr + ) + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Apply +-- import Data.Char (isSpace) +import Data.Data +import Data.Functor.Apply +-- import Data.Monoid +import Data.Semigroup +-- import Data.Foldable +-- import Data.Traversable +-- import Data.Semigroup.Traversable +-- import Data.Semigroup.Foldable +-- import Data.Zipper.NonEmpty (NonEmpty(..)) + +data Zipper a = !Integer :~ !(Integer -> a) + deriving Typeable + +toSequence :: (Integer -> a) -> Zipper a +toSequence = (0 :~) + +infixr 0 :~ + +instance Functor Zipper where + fmap g (n :~ f) = n :~ g . f + b <$ _ = 0 :~ const b + +-- | Extract the focused element +head :: Zipper a -> a +head (n :~ f) = f n + +-- | Move the head of the zipper to the right +tail :: Zipper a -> Zipper a +tail (n :~ f) = n + 1 :~ f + +-- | Move the head of the zipper to the left +untail :: Zipper a -> Zipper a +untail (n :~ f) = n - 1 :~ f + +-- | Cons before the head of the zipper. The head now points to the new element +(<|) :: a -> Zipper a -> Zipper a +a <| (n :~ f) = n :~ \z -> case compare z n of + LT -> f n + EQ -> a + GT -> f (n - 1) + +-- | Move the head of the zipper one step to the right, returning the value we move over. +uncons :: Zipper a -> (a, Zipper a) +uncons (n :~ f) = (f n, n + 1 :~ f) + +instance Comonad Zipper where + extract (n :~ f) = f n + duplicate (n :~ f) = n :~ (:~ f) + +instance FunctorApply Zipper where + (nf :~ f) <.> (na :~ a) + | dn <- na - nf + = nf :~ \n -> f n (a (n + dn)) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Zipper + +instance Applicative Zipper where + pure = repeat + (<*>) = (<.>) + as <* _ = as + _ *> bs = bs + +instance Monad Zipper where + return = repeat + (z :~ ma) >>= f = z :~ \ na -> case f (ma na) of + nb :~ mb -> mb (nb + na - z) + +repeat :: a -> Zipper a +repeat a = 0 :~ const a + +-- | Interleave two Zippers @xs@ and @ys@, alternating elements +-- from each list. +-- +-- > [x1,x2,...] `interleave` [y1,y2,...] == [x1,y1,x2,y2,...] +-- > interleave = (<>) +interleave :: Zipper a -> Zipper a -> Zipper a +interleave = (<>) +instance Semigroup (Zipper a) where + (n :~ a) <> (m :~ b) = 0 :~ \p -> case quotRem p 2 of + (q, 0) -> a (n + q) + (q, _) -> b (m + q) + +-- | @'intersperse' y xs@ creates an alternating stream of +-- elements from @xs@ and @y@. +intersperse :: a -> Zipper a -> Zipper a +intersperse y z = z <> repeat y + +-- | 'transpose' computes the transposition of a stream of streams. +transpose :: Zipper (Zipper a) -> Zipper (Zipper a) +transpose (n :~ f) = 0 :~ \z -> n :~ \n' -> let m :~ g = f n' in g (m + z) + +take :: Integer -> Zipper a -> [a] +take n0 (m0 :~ f0) + | n0 < 0 = error "Zipper.take: negative argument" + | otherwise = go n0 m0 f0 + where + go 0 !_ !_ = [] + go n m f = f m : go (n - 1) (m + 1) f + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +drop :: Integer -> Zipper a -> Zipper a +drop m (n :~ f) = m + n :~ f + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of +-- @xs@ of length @n@ and the remaining stream immediately following +-- this prefix. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error if you access the taken portion +splitAt :: Integer -> Zipper a -> ([a],Zipper a) +splitAt n xs = (take n xs, drop n xs) + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> Zipper a -> [a] +takeWhile p0 (n0 :~ f0) = go p0 n0 f0 where + go !p !n !f + | x <- f n, p x = x : go p (n + 1) f + | otherwise = [] + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +-- +-- /Beware/: this function may diverge if every element of @xs@ +-- satisfies @p@, e.g. @dropWhile even (repeat 0)@ will loop. +dropWhile :: (a -> Bool) -> Zipper a -> Zipper a +dropWhile p xs@(_ :~ f) = findIndex' p xs :~ f + +-- | @'span' p xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +span :: (a -> Bool) -> Zipper a -> ([a], Zipper a) +span p0 (n0 :~ f0) + | (ts, n') <- go p0 n0 f0 = (ts, n' :~ f0) where + go !p !n !f + | x <- f n, p x, (ts, fs) <- go p (n + 1) f = (x:ts, fs) + | otherwise = ([], n) + +-- | The 'break' @p@ function is equivalent to 'span' @not . p@. +break :: (a -> Bool) -> Zipper a -> ([a], Zipper a) +break p = span (not . p) + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> Zipper a -> Bool +isPrefixOf xs0 (n0 :~ f0) = go xs0 n0 f0 where + go [] !_ !_ = True + go (y:ys) n f = y == f n && go ys (n + 1) f + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: passing a negative integer as the first argument will cause +-- an error. +(!!) :: Zipper a -> Integer -> a +(!!) (n :~ f) m = f (n + m) + +-- | The 'findIndex' function takes a predicate and a stream and returns +-- the index of the first element in the stream that satisfies the predicate, +-- +-- /Beware/: 'findIndex' @p@ @xs@ will diverge if none of the elements of +-- @xs@ satisfy @p@. +findIndex :: (a -> Bool) -> Zipper a -> Integer +findIndex p0 (n0 :~ f0) = go p0 n0 f0 - n0 where + go !p !n !f + | x <- f n, p x = n + | otherwise = go p (n + 1) f + +-- | Internal helper, used to find an index in the +findIndex' :: (a -> Bool) -> Zipper a -> Integer +findIndex' p0 (n0 :~ f0) = go p0 n0 f0 where + go !p !n !f + | x <- f n, p x = n + | otherwise = go p (n + 1) f + +-- | The 'elemIndex' function returns the index of the first element +-- in the given stream which is equal (by '==') to the query element, +-- +-- /Beware/: @'elemIndex' x xs@ will diverge if none of the elements +-- of @xs@ equal @x@. +elemIndex :: Eq a => a -> Zipper a -> Integer +elemIndex = findIndex . (==) + +{- +-- | The 'elemIndices' function extends 'elemIndex', by returning the +-- indices of all elements equal to the query element, in ascending order. +-- +-- /Beware/: 'elemIndices' @x@ @xs@ will diverge if any suffix of +-- @xs@ does not contain @x@. +elemIndices :: Eq a => a -> Zipper a -> Zipper Int +elemIndices x = findIndices (x==) +-} + +-- | The 'zip' function takes two streams and returns a list of +-- corresponding pairs. +-- +-- > zip = liftA2 (,) +zip :: Zipper a -> Zipper b -> Zipper (a,b) +zip = liftA2 (,) + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the functions, the elements are combined using the function +-- passed as the first argument to 'zipWith'. +-- +-- > zipWith = liftA2 +zipWith :: (a -> b -> c) -> Zipper a -> Zipper b -> Zipper c +zipWith = liftA2 + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Zipper (a,b) -> (Zipper a, Zipper b) +unzip xs = (fst <$> xs, snd <$> xs) + + + +{- + +-- | The 'findIndices' function extends 'findIndex', by returning the +-- indices of all elements satisfying the predicate, in ascending +-- order. +-- +-- /Beware/: 'findIndices' @p@ @xs@ will diverge if all the elements +-- of any suffix of @xs@ fails to satisfy @p@. +findIndices :: (a -> Bool) -> Zipper a -> Zipper Int +findIndices p = indicesFrom 0 where + indicesFrom ix (x :< xs) + | p x = ix :< ixs + | otherwise = ixs + where ixs = (indicesFrom $! (ix+1)) xs + + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +-- +-- /Beware/: if the stream of characters @xs@ does not contain white +-- space, accessing the tail of @words xs@ will loop. +words :: Zipper Char -> Zipper String +words xs | (w, ys) <- break isSpace xs = w :< words ys + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +unwords :: Zipper String -> Zipper Char +unwords ~(x :< xs) = foldr (:<) (' ' :< unwords xs) x + +-- | The 'lines' function breaks a stream of characters into a list +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +-- +-- /Beware/: if the stream of characters @xs@ does not contain +-- newline characters, accessing the tail of @lines xs@ will loop. +lines :: Zipper Char -> Zipper String +lines xs | (l, ys) <- break (== '\n') xs = l :< lines (tail ys) + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: Zipper String -> Zipper Char +unlines ~(x :< xs) = foldr (:<) ('\n' :< unlines xs) x + +-- | The 'fromList' converts an infinite list to a +-- stream. +-- +-- /Beware/: Passing a finite list, will cause an error. +fromList :: [a] -> Zipper a +fromList (x:xs) = x :< fromList xs +fromList [] = error "Zipper.listToZipper applied to finite list" + +-} diff --git a/Data/Stream/Infinite/Skew.hs b/Data/Stream/Infinite/Skew.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/Infinite/Skew.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE PatternGuards, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Infinite.Skew +-- Copyright : (C) 2011 Edward Kmett, +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- Anticausal streams implemented as non-empty skew binary random access lists +-- +-- The Applicative zips streams, the monad diagonalizes +------------------------------------------------------------------------------ + + +module Data.Stream.Infinite.Skew + ( Stream + , (<|) -- O(1) + , (!!) + , head -- O(1) + , tail -- O(1) + , tails + , uncons -- O(1) + , index -- O(log n) + , drop -- O(log n) + , dropWhile -- O(n) + , span + , break + , split + , splitW + , repeat + , insert -- O(n) + , insertBy + , adjust -- O(log n) + , update -- O(log n) + , fromList + , from + , indexed + , interleave + ) where + +import Control.Arrow (first) +import Control.Applicative hiding (empty) +import Control.Comonad +import Control.Comonad.Apply +import Data.Functor.Alt +import Data.Functor.Apply +import Data.Foldable hiding (toList) +import Data.Traversable (Traversable, traverse) +import qualified Data.Traversable as Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Data.Monoid (Monoid(mappend)) +import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, (!!), break) + +infixr 5 :<, <| + +data Complete a + = Tip a + | Bin {-# UNPACK #-} !Integer a !(Complete a) !(Complete a) + deriving Show + +instance Functor Complete where + fmap f (Tip a) = Tip (f a) + fmap f (Bin w a l r) = Bin w (f a) (fmap f l) (fmap f r) + +instance Comonad Complete where + extract (Tip a) = a + extract (Bin _ a _ _) = a + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + +instance Foldable Complete where + foldMap f (Tip a) = f a + foldMap f (Bin _ a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + foldr f z (Tip a) = f a z + foldr f z (Bin _ a l r) = f a (foldr f (foldr f z r) l) + +instance Foldable1 Complete where + foldMap1 f (Tip a) = f a + foldMap1 f (Bin _ a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Complete where + traverse f (Tip a) = Tip <$> f a + traverse f (Bin n a l r) = Bin n <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Complete where + traverse1 f (Tip a) = Tip <$> f a + traverse1 f (Bin n a l r) = Bin n <$> f a <.> traverse1 f l <.> traverse1 f r + +bin :: a -> Complete a -> Complete a -> Complete a +bin a l r = Bin (1 + weight l + weight r) a l r +{-# INLINE bin #-} + +weight :: Complete a -> Integer +weight Tip{} = 1 +weight (Bin w _ _ _) = w +{-# INLINE weight #-} + +-- A future is a non-empty skew binary random access list of nodes. +-- The last node, however, is allowed to contain fewer values. +data Stream a = !(Complete a) :< Stream a +-- deriving Show + +instance Show a => Show (Stream a) where + showsPrec d as = showParen (d >= 10) $ + showString "fromList " . showsPrec 11 (toList as) + +instance Functor Stream where + fmap f (t :< ts) = fmap f t :< fmap f ts + +instance Comonad Stream where + extract = head + extend g0 (t :< ts) = go g0 t (:< ts) :< extend g0 ts + where + go :: (Stream a -> b) -> Complete a -> (Complete a -> Stream a) -> Complete b + go g w@Tip{} f = Tip (g (f w)) + go g w@(Bin n _ l r) f = Bin n (g (f w)) (go g l (:< f r)) (go g r f) + +instance FunctorApply Stream where + fs <.> as = mapWithIndex (\n f -> f (as !! n)) fs + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream + +instance Applicative Stream where + pure = repeat + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance FunctorAlt Stream where + as bs = tabulate $ \i -> case quotRem i 2 of + (q,0) -> as !! q + (q,_) -> bs !! q + +instance Foldable Stream where + foldMap f (t :< ts) = foldMap f t `mappend` foldMap f ts + foldr f z (t :< ts) = foldr f (foldr f z ts) t + +toList :: Stream a -> [a] +toList = foldr (:) [] + +instance Foldable1 Stream where + foldMap1 f (t :< ts) = foldMap1 f t <> foldMap1 f ts + +instance Traversable Stream where + traverse f (t :< ts) = (:<) <$> traverse f t <*> traverse f ts + +instance Traversable1 Stream where + traverse1 f (t :< ts) = (:<) <$> traverse1 f t <.> traverse1 f ts + +instance Semigroup (Stream a) where + (<>) = () + +instance Monad Stream where + return = pure + as >>= f = mapWithIndex (\i a -> f a !! i) as + +interleave :: Stream a -> Stream a -> Stream a +interleave = () + +repeat :: a -> Stream a +repeat b = go b (Tip b) + where + go :: a -> Complete a -> Stream a + go a as | ass <- bin a as as = as :< go a ass + +mapWithIndex :: (Integer -> a -> b) -> Stream a -> Stream b +mapWithIndex f0 as0 = spine f0 0 as0 + where + spine f m (a :< as) = tree f m a :< spine f (m + weight a) as + tree f m (Tip a) = Tip (f m a) + tree f m (Bin n a l r) = Bin n (f m a) (tree f (m + 1) l) (tree f (m + 1 + weight l) r) + +tabulate :: (Integer -> a) -> Stream a +tabulate f = mapWithIndex (const . f) (pure ()) + +indexed :: Stream a -> Stream (Integer, a) +indexed = mapWithIndex (,) + +from :: Num a => a -> Stream a +from a = mapWithIndex ((+) . fromIntegral) (pure a) + +-- | /O(1)/ cons +(<|) :: a -> Stream a -> Stream a +a <| (l :< r :< as) + | weight l == weight r = bin a l r :< as +a <| as = Tip a :< as +{-# INLINE (<|) #-} + +-- | /O(1)/ +head :: Stream a -> a +head (a :< _) = extract a +{-# INLINE head #-} + +-- | /O(1)/. +tail :: Stream a -> Stream a +tail (Tip{} :< ts) = ts +tail (Bin _ _ l r :< ts) = l :< r :< ts +{-# INLINE tail #-} + +tails :: Stream a -> Stream (Stream a) +tails = duplicate +{-# INLINE tails #-} + +-- | /O(1)/. +uncons :: Stream a -> (a, Stream a) +uncons (Tip a :< as) = (a, as) +uncons (Bin _ a l r :< as) = (a, l :< r :< as) +{-# INLINE uncons #-} + +-- | /O(log n)/. +index :: Integer -> Stream a -> a +index i (t :< ts) + | i < 0 = error "index: negative index" + | i < w = indexComplete i t + | otherwise = index (i - w) ts + where w = weight t + +indexComplete :: Integer -> Complete a -> a +indexComplete 0 (Tip a) = a +indexComplete 0 (Bin _ a _ _) = a +indexComplete i (Bin w _ l r) + | i <= w' = indexComplete (i-1) l + | otherwise = indexComplete (i-1-w') r + where w' = div w 2 +indexComplete _ _ = error "indexComplete" + +-- | /O(log n)/. +(!!) :: Stream a -> Integer -> a +(!!) = flip index + +-- | /O(log n)/. +drop :: Integer -> Stream a -> Stream a +drop 0 ts = ts +drop i (t :< ts) = case compare i w of + LT -> dropComplete i t (:< ts) + EQ -> ts + GT -> drop (i - w) ts + where w = weight t + +dropComplete :: Integer -> Complete a -> (Complete a -> Stream a) -> Stream a +dropComplete 0 t f = f t +dropComplete 1 (Bin _ _ l r) f = l :< f r +dropComplete i (Bin w _ l r) f = case compare (i - 1) w' of + LT -> dropComplete (i-1) l (:< f r) + EQ -> f r + GT -> dropComplete (i-1-w') r f + where w' = div w 2 +dropComplete _ _ _ = error "dropComplete" + +-- /O(n)/. +dropWhile :: (a -> Bool) -> Stream a -> Stream a +dropWhile p as + | p (head as) = dropWhile p (tail as) + | otherwise = as + +-- /O(n)/ +span :: (a -> Bool) -> Stream a -> ([a], Stream a) +span p as + | a <- head as, p a = first (a:) $ span p (tail as) + | otherwise = ([], as) + +-- /O(n)/ +break :: (a -> Bool) -> Stream a -> ([a], Stream a) +break p = span (not . p) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +split :: (a -> Bool) -> Stream a -> ([a], Stream a) +split p (a :< as) + | p (extract as) = splitComplete p a (:< as) + | (ts, fs) <- split p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitComplete :: (a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a) +splitComplete _ t@Tip{} f = ([], f t) +splitComplete p t@(Bin _ a l r) f + | p a = ([], f t) + | p (extract r), (ts, fs) <- splitComplete p l (:< f r) = (a:ts, fs) + | (ts, fs) <- splitComplete p r f = (a:foldr (:) ts l, fs) + +-- /(O(n), O(log n))/ split at _some_ edge where function goes from False to True. +-- best used with a monotonic function +-- +-- > splitW p xs = (map extract &&& fmap (fmap extract)) . split p . duplicate +splitW :: (Stream a -> Bool) -> Stream a -> ([a], Stream a) +splitW p (a :< as) + | p as = splitCompleteW p a (:< as) + | (ts, fs) <- splitW p as = (foldr (:) ts a, fs) + +-- for use when we know the split occurs within a given tree +splitCompleteW :: (Stream a -> Bool) -> Complete a -> (Complete a -> Stream a) -> ([a], Stream a) +splitCompleteW _ t@Tip{} f = ([], f t) +splitCompleteW p t@(Bin _ a l r) f + | w <- f t, p w = ([], w) + | w <- f r, p w, (ts, fs) <- splitCompleteW p l (:< w) = (a:ts, fs) + | (ts, fs) <- splitCompleteW p r f = (a:foldr (:) ts l, fs) + +fromList :: [a] -> Stream a +fromList = foldr (<|) (error "fromList: finite list") + +-- /O(n)/ +insert :: Ord a => a -> Stream a -> Stream a +insert a as | (ts, as') <- split (a<=) as = foldr (<|) (a <| as') ts + +-- /O(n)/. Finds the split in O(log n), but then has to recons +insertBy :: (a -> a -> Ordering) -> a -> Stream a -> Stream a +insertBy cmp a as | (ts, as') <- split (\b -> cmp a b <= EQ) as = foldr (<|) (a <| as') ts + +-- /O(log n)/ Change the value of the nth entry in the future +adjust :: Integer -> (a -> a) -> Stream a -> Stream a +adjust !n f (a :< as) + | n < w = adjustComplete n f a :< as + | otherwise = a :< adjust (n - w) f as + where w = weight a + +adjustComplete :: Integer -> (a -> a) -> Complete a -> Complete a +adjustComplete 0 f (Tip a) = Tip (f a) +adjustComplete _ _ t@Tip{} = t +adjustComplete n f (Bin m a l r) + | n == 0 = Bin m (f a) l r + | n < w = Bin m a (adjustComplete (n - 1) f l) r + | otherwise = Bin m a l (adjustComplete (n - 1 - w) f r) + where w = weight l + +update :: Integer -> a -> Stream a -> Stream a +update n = adjust n . const + diff --git a/Data/Stream/NonEmpty.hs b/Data/Stream/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/Data/Stream/NonEmpty.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE CPP, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.NonEmpty +-- Copyright : (C) 2011 Edward Kmett, +-- (C) 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- A NonEmpty list forms a monad as per list. +-- Unlike Future, the ComonadApply instance pairs all positions in both +-- comonads like the list monad applicative. +---------------------------------------------------------------------------- + +module Data.Stream.NonEmpty ( + -- * The type of streams + NonEmpty(..) + -- * non-empty stream transformations + , map -- :: (a -> b) -> NonEmpty a -> NonEmpty b + , intersperse -- :: a -> NonEmpty a -> NonEmpty a + , scanl -- :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b + , scanr -- :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b + , scanl1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + , scanr1 -- :: (a -> a -> a) -> NonEmpty a -> NonEmpty a + --, transpose -- :: NonEmpty (NonEmpty a) -> NonEmpty (NonEmpty a) + -- * Basic functions + , head -- :: NonEmpty a -> a + , tail -- :: NonEmpty a -> [a] + , last -- :: NonEmpty a -> a + , init -- :: NonEmpty a -> [a] + , (<|), cons -- :: a -> NonEmpty a -> NonEmpty a + , uncons -- :: NonEmpty a -> (a, Maybe (NonEmpty a)) + , sort -- :: NonEmpty a -> NonEmpty a + , reverse -- :: NonEmpty a -> NonEmpty a + , inits -- :: Foldable f => f a -> NonEmpty a + , tails -- :: Foldable f => f a -> NonEmpty a + -- * Building streams + , iterate -- :: (a -> a) -> a -> NonEmpty a + , repeat -- :: a -> NonEmpty a + , cycle -- :: NonEmpty a -> NonEmpty a + , unfold -- :: (a -> (b, Maybe a) -> a -> NonEmpty b + , insert -- :: Foldable f => a -> f a -> NonEmpty a + -- * Extracting sublists + , take -- :: Int -> NonEmpty a -> [a] + , drop -- :: Int -> NonEmpty a -> [a] + , splitAt -- :: Int -> NonEmpty a -> ([a], [a]) + , takeWhile -- :: Int -> NonEmpty a -> [a] + , dropWhile -- :: Int -> NonEmpty a -> [a] + , span -- :: Int -> NonEmpty a -> ([a],[a]) + , break -- :: Int -> NonEmpty a -> ([a],[a]) + , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) + , group -- :: Foldable f => Eq a => f a -> [NonEmpty a] + , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] + , group1 -- :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) + , groupBy1 -- :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) + -- * Sublist predicates + , isPrefixOf -- :: Foldable f => f a -> NonEmpty a -> Bool + -- * Indexing streams + , (!!) -- :: NonEmpty a -> Int -> a + -- * Zipping and unzipping streams + , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) + , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c + , unzip -- :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) + -- * Functions on streams of characters + , words -- :: NonEmpty Char -> NonEmpty String + , unwords -- :: NonEmpty String -> NonEmpty Char + , lines -- :: NonEmpty Char -> NonEmpty String + , unlines -- :: NonEmpty String -> NonEmpty Char + -- * Converting to and from a list + , fromList -- :: [a] -> NonEmpty a + , toList -- :: NonEmpty a -> [a] + , nonEmpty -- :: [a] -> Maybe (NonEmpty a) + ) where + + +import Prelude hiding + ( head, tail, map, reverse + , scanl, scanl1, scanr, scanr1 + , iterate, take, drop, takeWhile + , dropWhile, repeat, cycle, filter + , (!!), zip, unzip, zipWith, words + , unwords, lines, unlines, break, span + , splitAt, foldr, foldl, last, init + ) + +import Control.Applicative +import Control.Applicative.Alt +import Control.Comonad +import Control.Comonad.Apply +import Control.Monad +import Data.Functor.Alt +import Data.Foldable hiding (toList) +import qualified Data.Foldable as Foldable +import qualified Data.List as List +import Data.Monoid hiding (Last) +import Data.Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable + +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif + +infixr 5 :|, <| + +data NonEmpty a = a :| [a] deriving + ( Eq, Ord, Show, Read +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +unfold :: (a -> (b, Maybe a)) -> a -> NonEmpty b +unfold f a = case f a of + (b, Nothing) -> b :| [] + (b, Just c) -> b <| unfold f c + +nonEmpty :: [a] -> Maybe (NonEmpty a) +nonEmpty [] = Nothing +nonEmpty (a:as) = Just (a :| as) +{-# INLINE nonEmpty #-} + +uncons :: NonEmpty a -> (a, Maybe (NonEmpty a)) +uncons ~(a :| as) = (a, nonEmpty as) +{-# INLINE uncons #-} + +instance Functor NonEmpty where + fmap f ~(a :| as) = f a :| fmap f as + b <$ ~(_ :| as) = b :| (b <$ as) + +instance Comonad NonEmpty where + extract ~(a :| _) = a + extend f w@ ~(_ :| aas) = f w :| case aas of + [] -> [] + (a:as) -> toList (extend f (a :| as)) + +instance FunctorApply NonEmpty where + (<.>) = ap + +instance FunctorAlt NonEmpty where + (a :| as) ~(b :| bs) = a :| (as ++ b : bs) + +instance ComonadApply NonEmpty + +instance Applicative NonEmpty where + pure a = a :| [] + (<*>) = ap + +instance ApplicativeAlt NonEmpty + +instance Monad NonEmpty where + return a = a :| [] + ~(a :| as) >>= f + | b :| bs <- f a + , bs' <- as >>= toList . f + = b :| (bs ++ bs') + +instance Traversable NonEmpty where + traverse f ~(a :| as) = (:|) <$> f a <*> traverse f as + +instance Traversable1 NonEmpty where + traverse1 f (a :| []) = (:|[]) <$> f a + traverse1 f (a :| (b: bs)) = (\a' (b':| bs') -> a' :| b': bs') <$> f a <.> traverse1 f (b :| bs) + +instance Foldable NonEmpty where + foldr f z ~(a :| as) = f a (foldr f z as) + foldl f z ~(a :| as) = foldl f (f z a) as + foldl1 f ~(a :| as) = foldl f a as + foldMap f ~(a :| as) = f a `mappend` foldMap f as + fold ~(m :| ms) = m `mappend` fold ms + +instance Foldable1 NonEmpty where + foldMap1 f (a :| []) = f a + foldMap1 f (a :| b : bs) = f a <> foldMap1 f (b :| bs) + +instance Semigroup (NonEmpty a) where + (<>) = () + +-- | Extract the first element of the stream +head :: NonEmpty a -> a +head ~(a :| _) = a +{-# INLINE head #-} + +-- | Extract the possibly empty tail of the stream +tail :: NonEmpty a -> [a] +tail ~(_ :| as) = as +{-# INLINE tail #-} + +-- | Extract the last element of the stream +last :: NonEmpty a -> a +last ~(a :| as) = List.last (a : as) +{-# INLINE last #-} + +-- | Extract everything except the last element of the stream +init :: NonEmpty a -> [a] +init ~(a :| as) = List.init (a : as) +{-# INLINE init #-} + +-- | cons onto a stream +(<|) :: a -> NonEmpty a -> NonEmpty a +a <| ~(b :| bs) = a :| b : bs +{-# INLINE (<|) #-} + +cons :: a -> NonEmpty a -> NonEmpty a +cons = (<|) +{-# INLINE cons #-} + +-- | Sort a stream +sort :: Ord a => NonEmpty a -> NonEmpty a +sort = lift List.sort +{-# INLINE sort #-} + +-- | Converts an non-empty list to a stream. +fromList :: [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = error "NonEmpty.fromList: empty list" +{-# INLINE fromList #-} + +-- | Convert a stream to a list efficiently +toList :: NonEmpty a -> [a] +toList ~(a :| as) = a : as +{-# INLINE toList #-} + +-- | Lift list operations to work on a 'NonEmpty' stream +lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b +lift f = fromList . f . Foldable.toList +{-# INLINE lift #-} + +-- | map a function over a 'NonEmpty' stream +map :: (a -> b) -> NonEmpty a -> NonEmpty b +map f ~(a :| as) = f a :| fmap f as +{-# INLINE map #-} + +-- | The 'inits' function takes a stream @xs@ and returns all the +-- finite prefixes of @xs@. +inits :: Foldable f => f a -> NonEmpty [a] +inits = fromList . List.inits . Foldable.toList +{-# INLINE inits #-} + +-- | The 'tails' function takes a stream @xs@ and returns all the +-- suffixes of @xs@. +tails :: Foldable f => f a -> NonEmpty [a] +tails = fromList . List.tails . Foldable.toList +{-# INLINE tails #-} + +-- | 'insert' an item into a 'NonEmpty' +insert :: Foldable f => Ord a => a -> f a -> NonEmpty a +insert a = fromList . List.insert a . Foldable.toList +{-# INLINE insert #-} + +-- | 'scanl' is similar to 'foldl', but returns a stream of successive +-- reduced values from the left: +-- +-- > scanl f z [x1, x2, ...] == z :| [z `f` x1, (z `f` x1) `f` x2, ...] +-- +-- Note that +-- +-- > last (scanl f z xs) == foldl f z xs. +scanl :: Foldable f => (b -> a -> b) -> b -> f a -> NonEmpty b +scanl f z = fromList . List.scanl f z . Foldable.toList +{-# INLINE scanl #-} + +-- | 'scanr' is the right-to-left dual of 'scanl'. +-- Note that +-- +-- > head (scanr f z xs) == foldr f z xs. +scanr :: Foldable f => (a -> b -> b) -> b -> f a -> NonEmpty b +scanr f z = fromList . List.scanr f z . Foldable.toList +{-# INLINE scanr #-} + +-- | 'scanl1' is a variant of 'scanl' that has no starting value argument: +-- +-- > scanl1 f [x1, x2, ...] == x1 :| [x1 `f` x2, x1 `f` (x2 `f` x3), ...] +scanl1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanl1 f ~(a :| as) = fromList (List.scanl f a as) +{-# INLINE scanl1 #-} + +-- | 'scanr1' is a variant of 'scanr' that has no starting value argument. +scanr1 :: (a -> a -> a) -> NonEmpty a -> NonEmpty a +scanr1 f ~(a :| as) = fromList (List.scanr1 f (a:as)) +{-# INLINE scanr1 #-} + +intersperse :: a -> NonEmpty a -> NonEmpty a +intersperse a ~(b :| bs) = b :| case bs of + [] -> [] + _ -> a : List.intersperse a bs +{-# INLINE intersperse #-} + +-- | @'iterate' f x@ produces the infinite sequence +-- of repeated applications of @f@ to @x@. +-- +-- > iterate f x = [x, f x, f (f x), ..] +iterate :: (a -> a) -> a -> NonEmpty a +iterate f a = a :| List.iterate f (f a) +{-# INLINE iterate #-} + +-- | @'cycle' xs@ returns the infinite repetition of @xs@: +-- +-- > cycle [1,2,3] = 1 :| [2,3,1,2,3,...] +cycle :: NonEmpty a -> NonEmpty a +cycle = fromList . List.cycle . toList +{-# INLINE cycle #-} + +-- | 'reverse' a finite NonEmpty +reverse :: NonEmpty a -> NonEmpty a +reverse = lift List.reverse +{-# INLINE reverse #-} + +-- | @'repeat' x@ returns a constant stream, where all elements are +-- equal to @x@. +repeat :: a -> NonEmpty a +repeat a = a :| List.repeat a +{-# INLINE repeat #-} + +-- | @'take' n xs@ returns the first @n@ elements of @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +take :: Int -> NonEmpty a -> [a] +take n = List.take n . toList +{-# INLINE take #-} + +-- | @'drop' n xs@ drops the first @n@ elements off the front of +-- the sequence @xs@. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +drop :: Int -> NonEmpty a -> [a] +drop n = List.drop n . toList +{-# INLINE drop #-} + +-- | @'splitAt' n xs@ returns a pair consisting of the prefix of @xs@ +-- of length @n@ and the remaining stream immediately following this prefix. +-- +-- /Beware/: passing a negative integer as the first argument will +-- cause an error. +splitAt :: Int -> NonEmpty a -> ([a],[a]) +splitAt n = List.splitAt n . toList +{-# INLINE splitAt #-} + +-- | @'takeWhile' p xs@ returns the longest prefix of the stream +-- @xs@ for which the predicate @p@ holds. +takeWhile :: (a -> Bool) -> NonEmpty a -> [a] +takeWhile p = List.takeWhile p . toList +{-# INLINE takeWhile #-} + +-- | @'dropWhile' p xs@ returns the suffix remaining after +-- @'takeWhile' p xs@. +dropWhile :: (a -> Bool) -> NonEmpty a -> [a] +dropWhile p = List.dropWhile p . toList +{-# INLINE dropWhile #-} + +-- | 'span' @p@ @xs@ returns the longest prefix of @xs@ that satisfies +-- @p@, together with the remainder of the stream. +span :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +span p = List.span p . toList +{-# INLINE span #-} + +-- | The 'break' @p@ function is equivalent to 'span' @not . p@. +break :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +break p = span (not . p) +{-# INLINE break #-} + +-- | 'filter' @p@ @xs@, removes any elements from @xs@ that do not satisfy @p@. +filter :: (a -> Bool) -> NonEmpty a -> [a] +filter p = List.filter p . toList +{-# INLINE filter #-} + +-- | The 'partition' function takes a predicate @p@ and a stream +-- @xs@, and returns a pair of streams. The first stream corresponds +-- to the elements of @xs@ for which @p@ holds; the second stream +-- corresponds to the elements of @xs@ for which @p@ does not hold. +partition :: (a -> Bool) -> NonEmpty a -> ([a], [a]) +partition p = List.partition p . toList +{-# INLINE partition #-} + +-- | The 'group' function takes a stream and returns a stream of +-- lists such that flattening the resulting stream is equal to the +-- argument. Moreover, each sublist in the resulting stream +-- contains only equal elements. For example, +-- +-- > group $ cycle "Mississippi" = "M" : "i" : "ss" : "i" : "ss" : "i" : "pp" : "i" : "M" : "i" : ... +group :: (Foldable f, Eq a) => f a -> [NonEmpty a] +group = groupBy (==) +{-# INLINE group #-} + +groupBy :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] +groupBy eq0 = go eq0 . Foldable.toList + where + go _ [] = [] + go eq (x : xs) = (x :| ys) : groupBy eq zs + where (ys, zs) = List.span (eq x) xs + +group1 :: Eq a => NonEmpty a -> NonEmpty (NonEmpty a) +group1 = groupBy1 (==) +{-# INLINE group1 #-} + +groupBy1 :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a) +groupBy1 eq (x :| xs) = (x :| ys) :| groupBy eq zs + where (ys, zs) = List.span (eq x) xs +{-# INLINE groupBy1 #-} + +-- | The 'isPrefix' function returns @True@ if the first argument is +-- a prefix of the second. +isPrefixOf :: Eq a => [a] -> NonEmpty a -> Bool +isPrefixOf [] _ = True +isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs +{-# INLINE isPrefixOf #-} + +-- | @xs !! n@ returns the element of the stream @xs@ at index +-- @n@. Note that the head of the stream has index 0. +-- +-- /Beware/: passing a negative integer as the first argument will cause +-- an error. +(!!) :: NonEmpty a -> Int -> a +(!!) ~(x :| xs) n + | n == 0 = x + | n > 0 = xs List.!! (n - 1) + | otherwise = error "NonEmpty.!! negative argument" +{-# INLINE (!!) #-} + +-- | The 'zip' function takes two streams and returns a list of +-- corresponding pairs. +zip :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b) +zip ~(x :| xs) ~(y :| ys) = (x, y) :| List.zip xs ys +{-# INLINE zip #-} + +-- | The 'zipWith' function generalizes 'zip'. Rather than tupling +-- the functions, the elements are combined using the function +-- passed as the first argument to 'zipWith'. +zipWith :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c +zipWith f ~(x :| xs) ~(y :| ys) = f x y :| List.zipWith f xs ys +{-# INLINE zipWith #-} + +-- | The 'unzip' function is the inverse of the 'zip' function. +unzip :: Functor f => f (a,b) -> (f a, f b) +unzip xs = (fst <$> xs, snd <$> xs) +{-# INLINE unzip #-} + +-- | The 'words' function breaks a stream of characters into a +-- stream of words, which were delimited by white space. +words :: NonEmpty Char -> NonEmpty String +words = lift List.words +{-# INLINE words #-} + +-- | The 'unwords' function is an inverse operation to 'words'. It +-- joins words with separating spaces. +unwords :: NonEmpty String -> NonEmpty Char +unwords = lift List.unwords +{-# INLINE unwords #-} + +-- | The 'lines' function breaks a stream of characters into a list +-- of strings at newline characters. The resulting strings do not +-- contain newlines. +lines :: NonEmpty Char -> NonEmpty String +lines = lift List.lines +{-# INLINE lines #-} + +-- | The 'unlines' function is an inverse operation to 'lines'. It +-- joins lines, after appending a terminating newline to each. +unlines :: NonEmpty String -> NonEmpty Char +unlines = lift List.unlines +{-# INLINE unlines #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright 2011 Edward Kmett +Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen +Copyright 2007-2010 Wouter Swierstra, Bas van Dijk + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,41 @@ +-- currently implemented + +* Data.Stream.Branching data Stream f a = a :< f (Stream a) +* Data.Stream.NonEmpty data NonEmpty a = a :| [a] +* Data.Stream.Future data Future a = Last a | a :< Future a +* Data.Stream.Future.Skew data Future a = Last a | !(Complete a) :< Future a +* Data.Stream.Infinite data Future a = a :< Future a +* Data.Stream.Infinite.Skew data Future a = !(Complete a) :< Future a +* Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer + +-- TODO: refactor the existing Functional.Zipper to have a lower bound and add a Symmetric variant +-- Data.Stream.Infinite.Functional.Zipper data Zipper a = Zipper !(Integer -> a) !Integer !Integer -- can seek arbitrarily + +Data.Stream.Causal data Causal a = First a | Causal a :> a +Data.Stream.Causal.Infinite data Causal a = Causal a :> a +Data.Stream.Causal.Finite data Causal a = First a | !(Causal a) :> a +Data.Stream.Causal.Skew data Causal a = First a | Causal a :> !(Complete a) +Data.Stream.Causal.Infinite.Skew data Causal a = Causal a :> !(Complete a) + +Data.Stream.Future.Finite data Future a = Last a | a :< !(Future a) + +Data.Stream.Zipper data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| (Future a) +Data.Stream.Zipper.Symmetric data Zipper a = Now !(Causal a) | !(Causal a) :| (Future a) +Data.Stream.Zipper.Infinite data Zipper a = !(Finite.Causal a) :| Infinite.Future a +Data.Stream.Zipper.Infinite.Symmetric data Zipper a = {- #UNPACK #-} !(Infinite.Causal a) :| Infinite.Future a +Data.Stream.Zipper.Finite data Zipper a = Now !(Finite.Causal a) | !(Finite.Causal a) :| !(Finite.Future a) +Data.Stream.Zipper.Skew data Zipper a = Zipper !(Seq a) !(Seq a) !(Skew.Future a) +Data.Stream.Zipper.Skew.Symmetric data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(Skew.Future a) +Data.Stream.Zipper.Infinite.Skew data Zipper a = Zipper !(S.Causal a) !(Seq a) !(Seq a) !(IS.Future a) +Data.Stream.Zipper.Infinite.Skew.Symmetric data Zipper a = Zipper !(IS.Causal a) !(Seq a) !(Seq a) !(IS.Future a) + +Data.Stream.Infinite.Functional.Future data Future a = Future !(Integer -> a) !Integer -- increment only +Data.Stream.Infinite.Functional.Causal data Causal a = Causal !(Integer -> a) !Integer -- decrement only + +Data.Sequence.Future data Future a = Future !(Int# -> a) Int# Int# +Data.Sequence.Causal data Causal a = Causal !(Int# -> a) Int# Int# +Data.Sequence.Zipper data Zipper a = Zipper !(Int# -> a) Int# Int# Int# + +Data.Tensors data Tensors f a = Last a | a :- Tensors f (f a) +Data.Tensors.Infinite data Tensors f a = a :- Tensors f (f a) +Data.Tensors.Finite data Tensors f a = Last a | a :- !(Tensors f (f a)) diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/runhaskell +> module Main (main) where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/streams.cabal b/streams.cabal new file mode 100644 --- /dev/null +++ b/streams.cabal @@ -0,0 +1,95 @@ +name: streams +category: Control, Comonads +version: 0.1.1 +license: BSD3 +cabal-version: >= 1.6 +license-file: LICENSE +author: Edward A. Kmett +maintainer: Edward A. Kmett +stability: provisional +homepage: http://github.com/ekmett/streams +copyright: Copyright 2011 Edward Kmett + Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen + Copyright 2007-2010 Wouter Swierstra, Bas van Dijk +synopsis: Various Haskell 2010 stream comonads +build-type: Simple +extra-source-files: README +description: + Various Haskell 2010 stream comonads. + . + * "Data.Stream.Branching" provides an \"f-Branching Stream\" comonad, aka the cofree comonad, or generalized rose tree. + . + > data Stream f a = a :< f (Stream a) + . + * "Data.Stream.Future" provides a coinductive anti-causal stream, or non-empty 'ZipList'. The comonad provides access to only the + tail of the stream. Like a conventional 'ZipList', this is /not/ a monad. + . + > data Future a = Last a | a :< Future a + . + * "Data.Stream.Future.Skew" provides a non-empty skew-binary random-access-list with the semantics of @Data.Stream.Future@. As with + "Data.Stream.Future" this stream is not a 'Monad', since the 'Applicative' instance zips streams of potentially differing lengths. + The random-access-list structure provides a number of operations logarithmic access time, but makes 'Data.Stream.Future.Skew.cons' + less productive. Where applicable "Data.Stream.Infinite.Skew" may be more efficient, due to a lazier and more efficient 'Applicative' + instance. + . + > + . + * "Data.Stream.NonEmpty" provides a non-empty list comonad where the Applicative and Monad work like those of the @[a]@. + Being non-empty, it trades in the 'Alternative' and 'Monoid' instances of @[a]@ for weaker append-based 'FunctorAlt' and 'Semigroup' + instances while becoming a member of 'Comonad' and 'ComonadApply'. Acting like a list, the semantics of '<*>' and + '<.>' take a cross-product of membership from both 'NonEmpty' lists rather than zipping like a 'Future' + . + > data NonEmpty a = a :| [a] + . + * "Data.Stream.Infinite" provides a coinductive infinite anti-causal stream. The 'Comonad' provides access to the tail of the + stream and the 'Applicative' zips streams together. Unlike 'Future', infinite stream form a 'Monad'. The monad diagonalizes + the 'Stream', which is consistent with the behavior of the 'Applicative', and the view of a 'Stream' as a isomorphic to the reader + monad from the natural numbers. Being infinite in length, there is no 'Alternative' instance, but instead the 'FunctorAlt' + instance provides access to the 'Semigroup' of interleaving streams. + . + > data Stream a = a :< Stream a + . + * "Data.Stream.Infinite.Skew" provides an infinite skew-binary random-access-list with the semantics of "Data.Stream.Infinite" + Since every stream is infinite, the 'Applicative' instance can be considerably less strict than the corresponding instance for + "Data.Stream.Future.Skew" and performs asymptotically better. + . + > + . + * "Data.Stream.Infinite.Functional.Zipper" provides a bi-infinite sequence, represented as a pure function with an accumulating + parameter added to optimize moving the current focus. + . + > data Zipper a = !Integer :~ (Integer -> a) + . + /Changes since 0.1/: + . + * A number of strictness issues with 'NonEmpty' were fixed + * More documentation + +source-repository head + type: git + location: git://github.com/ekmett/streams.git + + +library + build-depends: + base >= 4 && < 4.4, + comonad >= 0.6.0 && < 0.7, + functor-apply >= 0.7.4 && < 0.8, + semigroups >= 0.3.2 && < 0.4 + + extensions: CPP + if impl(ghc) + cpp-options: -DLANGUAGE_DeriveDataTypeable + extensions: FlexibleContexts, DeriveDataTypeable + + exposed-modules: + Data.Stream.Branching + Data.Stream.Future + Data.Stream.Future.Skew + Data.Stream.NonEmpty + Data.Stream.Infinite + Data.Stream.Infinite.Skew + Data.Stream.Infinite.Functional.Zipper + + ghc-options: -Wall +