diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,1 +1,8 @@ language: haskell +notifications: + irc: + channels: + - "irc.freenode.org#haskell-lens" + skip_join: true + template: + - "\x0313streams\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" diff --git a/Data/Stream/Future.hs b/Data/Stream/Future.hs deleted file mode 100644 --- a/Data/Stream/Future.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# 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.Comonad -import Data.Foldable -import Data.Functor.Alt -import Data.Functor.Extend -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 Extend Future where - extended = extend - -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 Apply 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 ComonadApply Future where - (<@>) = (<.>) - -instance Alt Future where - Last a bs = a :< bs - (a :< as) bs = a :< (as bs) - -instance Semigroup (Future a) where - (<>) = () - -instance Applicative Future where - pure = Last - (<*>) = (<.>) - (<* ) = (<. ) - ( *>) = ( .>) - - diff --git a/Data/Stream/Future/Skew.hs b/Data/Stream/Future/Skew.hs deleted file mode 100644 --- a/Data/Stream/Future/Skew.hs +++ /dev/null @@ -1,426 +0,0 @@ -{-# 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 Data.Functor.Alt -import Data.Functor.Extend -import Data.Foldable hiding (toList) -import Data.Traversable (Traversable, traverse) -import Data.Semigroup hiding (Last) -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -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 Extend Complete where - extended = extend - -instance Comonad Complete where - extend f w@Tip {} = Tip (f w) - extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) - extract (Tip a) = a - extract (Bin _ a _ _) = a - -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 Extend Future where - extended = extend - -instance Comonad Future where - extend g (Last t) = Last (extendTree g t Last) - extend g (t :< ts) = extendTree g t (:< ts) :< extend g ts - extract = head - -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 Apply 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 where - (<@>) = (<.>) - -instance Applicative Future where - pure = repeat - (<*>) = (<.>) - -instance Alt 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) (\ _ 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 deleted file mode 100644 --- a/Data/Stream/Infinite.hs +++ /dev/null @@ -1,455 +0,0 @@ -{-# 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) - , groupBy -- :: (a -> 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 Data.Char (isSpace) -import Data.Data -import Data.Functor.Apply -import Data.Functor.Extend -import Data.Semigroup -import Data.Foldable -import Data.Traversable -import Data.Distributive -import Data.Semigroup.Traversable -import Data.Semigroup.Foldable -import Data.List.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 - -instance Distributive Stream where - distribute w = fmap head w :> distribute (fmap tail w) - --- | 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 Extend Stream where - duplicated = tails - extended f w = f w :> extended f (tail w) - -instance Comonad Stream where - duplicate = tails - extend f w = f w :> extend f (tail w) - extract = head - -instance Apply Stream where - (f :> fs) <.> (a :> as) = f a :> (fs <.> as) - as <. _ = as - _ .> bs = bs - -instance ComonadApply Stream where - (f :> fs) <@> (a :> as) = f a :> (fs <@> as) - as <@ _ = as - _ @> bs = bs - --- | '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 deleted file mode 100644 --- a/Data/Stream/Infinite/Functional/Zipper.hs +++ /dev/null @@ -1,334 +0,0 @@ -{-# LANGUAGE CPP, 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 Data.Char (isSpace) -#ifdef LANGUAGE_DeriveDataTypeable -import Data.Data -#endif -import Data.Functor.Extend -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) -#ifdef LANGUAGE_DeriveDataTypeable - deriving Typeable -#endif - -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 Extend Zipper where - duplicated (n :~ f) = n :~ (:~ f) - -instance Comonad Zipper where - duplicate (n :~ f) = n :~ (:~ f) - extract (n :~ f) = f n - -instance Apply Zipper where - (nf :~ f) <.> (na :~ a) - | dn <- na - nf - = nf :~ \n -> f n (a (n + dn)) - as <. _ = as - _ .> bs = bs - -instance ComonadApply Zipper where - (<@>) = (<.>) - (<@) = (<.) - (@>) = (.>) - - -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 deleted file mode 100644 --- a/Data/Stream/Infinite/Skew.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# 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 - , tabulate - ) where - -import Control.Arrow (first) -import Control.Applicative hiding (empty) -import Control.Comonad -import Data.Distributive -import Data.Functor.Alt -import Data.Functor.Extend -import Data.Foldable hiding (toList) -import Data.Traversable -import Data.Semigroup hiding (Last) -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, (!!), break) - -infixr 5 :<, <| - -data Complete a - = Tip a - | Bin !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 Extend Complete where - extended f w@Tip {} = Tip (f w) - extended f w@(Bin n _ l r) = Bin n (f w) (extended f l) (extended f r) - -instance Comonad Complete where - extend f w@Tip {} = Tip (f w) - extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) - extract (Tip a) = a - extract (Bin _ a _ _) = a - -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 Extend Stream where - extended = extend - -instance Comonad Stream where - 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) - extract = head - -instance Apply Stream where - fs <.> as = mapWithIndex (\n f -> f (as !! n)) fs - as <. _ = as - _ .> bs = bs - -instance ComonadApply Stream where - (<@>) = (<.>) - (<@) = (<.) - (@>) = (.>) - -instance Applicative Stream where - pure = repeat - (<*>) = (<.>) - (<* ) = (<. ) - ( *>) = ( .>) - -instance Alt 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 Distributive Stream where - distribute w = tabulate (\i -> fmap (!! i) w) - -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/Supply.hs b/Data/Stream/Supply.hs deleted file mode 100644 --- a/Data/Stream/Supply.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} ------------------------------------------------------------------------------ --- | --- Module : Data.Stream.Supply --- Copyright : (C) 2008-2011 Edward Kmett, --- (C) 2008 Iavor S. Diatchki --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This library can be used to generate values (for example, new names) --- without the need to thread state. This means that functions that --- need to generate new values only need a supply object as an argument, --- and they do not need to return a new supply object as a result. --- This decreases the number of data-dependencies in a program, which --- makes it easier to exploit parallelism. --- --- The technique for generating new values is based on the paper --- ''On Generating Unique Names'' by Lennart Augustsson, Mikael Rittri, --- and Dan Synek. ----------------------------------------------------------------------------- -module Data.Stream.Supply - ( Supply - , newSupply - , newEnumSupply - , newNumSupply - , newDupableSupply - , newDupableEnumSupply - , newDupableNumSupply - , leftSupply - , rightSupply - , split - , splits - , splitSkew - , split2 - , split3 - , split4 - ) where - -import Control.Applicative -import Control.Comonad -import Data.Functor.Apply -import Data.Functor.Extend -import Data.Foldable -import Data.IORef(newIORef, atomicModifyIORef) -import Data.Traversable -import Data.Semigroup -import Data.Semigroup.Foldable -import Data.Semigroup.Traversable -import System.IO.Unsafe (unsafeInterleaveIO) -import Data.Stream.Infinite -import qualified Data.Stream.Infinite.Skew as Skew - -#ifdef LANGUAGE_DeriveDataTypeable -import Data.Data -#endif - -#ifdef __GLASGOW_HASKELL__ >= 608 -import GHC.IO(unsafeDupableInterleaveIO) -#else -unsafeDupableInterleaveIO :: IO a -> IO a -unsafeDupableInterleaveIO = unsafeInterleaveIO -#endif - -data Supply a = Supply a (Supply a) (Supply a) deriving - ( Show, Read, Eq, Ord -#ifdef LANGUAGE_DeriveDataTypeable - , Data, Typeable -#endif - ) - -instance Functor Supply where - fmap f (Supply a l r) = Supply (f a) (fmap f l) (fmap f r) - a <$ _ = pure a - -instance Extend Supply where - extended f s@(Supply _ l r) = Supply (f s) (extended f l) (extended f r) - duplicated s@(Supply _ l r) = Supply s (duplicated l) (duplicated r) - -instance Comonad Supply where - extend f s@(Supply _ l r) = Supply (f s) (extend f l) (extend f r) - duplicate s@(Supply _ l r) = Supply s (duplicate l) (duplicate r) - extract (Supply a _ _) = a - -instance Apply Supply where - Supply f fl fr <.> Supply a al ar = Supply (f a) (fl <.> al) (fr <.> ar) - a <. _ = a - _ .> a = a - -instance Applicative Supply where - pure a = as where as = Supply a as as - Supply f fl fr <*> Supply a al ar = Supply (f a) (fl <*> al) (fr <*> ar) - a <* _ = a - _ *> a = a - -instance Foldable Supply where - foldMap f (Supply a l r) = f a `mappend` foldMap f l `mappend` foldMap f r - -instance Foldable1 Supply where - foldMap1 f (Supply a l r) = f a <> foldMap1 f l <> foldMap1 f r - -instance Traversable Supply where - traverse f (Supply a l r) = Supply <$> f a <*> traverse f l <*> traverse f r - -instance Traversable1 Supply where - traverse1 f (Supply a l r) = Supply <$> f a <.> traverse1 f l <.> traverse1 f r - -leftSupply :: Supply a -> Supply a -leftSupply (Supply _ l _) = l - -rightSupply :: Supply a -> Supply a -rightSupply (Supply _ _ r) = r - --- unfoldsW :: (Comonad w, Functor f) => (w a -> (b, f a)) -> w a -> StreamT f w b -newSupply :: (a -> a) -> a -> IO (Supply a) -newSupply f x = gen =<< newIORef x - where gen r = unsafeInterleaveIO $ - Supply <$> unsafeInterleaveIO (atomicModifyIORef r update) - <*> gen r - <*> gen r - update a = b `seq` (b, a) where b = f a -{-# INLINE newSupply #-} - -newDupableSupply :: (a -> a) -> a -> IO (Supply a) -newDupableSupply f x = gen =<< newIORef x - where gen r = unsafeDupableInterleaveIO $ - Supply <$> unsafeDupableInterleaveIO (atomicModifyIORef r update) - <*> gen r - <*> gen r - update a = b `seq` (b, a) where b = f a -{-# INLINE newDupableSupply #-} - -newEnumSupply :: Enum a => IO (Supply a) -newEnumSupply = newSupply succ (toEnum 0) -{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} - -newNumSupply :: Num a => IO (Supply a) -newNumSupply = newSupply (1+) 0 -{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} - -newDupableEnumSupply :: Enum a => IO (Supply a) -newDupableEnumSupply = newSupply succ (toEnum 0) -{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} - -newDupableNumSupply :: Num a => IO (Supply a) -newDupableNumSupply = newSupply (1+) 0 -{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} - -split :: Supply a -> Stream (Supply a) -split (Supply _ l r) = l :> split r - -splits :: Integral b => Supply a -> b -> Supply a -splits (Supply _ l r) n = case n `quotRem` 2 of - (0,0) -> leftSupply l - (q,-1) -> splits (rightSupply l) q - (q,0) -> splits (leftSupply r) q - (q,1) -> splits (rightSupply r) q - (_,_) -> error "quotRem: impossible result" -{-# SPECIALIZE splits :: Supply a -> Int -> Supply a #-} -{-# SPECIALIZE splits :: Supply a -> Integer -> Supply a #-} - -splitSkew :: Supply a -> Skew.Stream (Supply a) -splitSkew = Skew.tabulate . splits - -split2 :: Supply a -> (Supply a, Supply a) -split2 (Supply _ l r) = (l, r) - -split3 :: Supply a -> (Supply a, Supply a, Supply a) -split3 (Supply _ a (Supply _ b c)) = (a, b, c) - -split4 :: Supply a -> (Supply a, Supply a, Supply a, Supply a) -split4 (Supply _ (Supply _ a b) (Supply _ c d)) = (a, b, c, d) diff --git a/README b/README --- a/README +++ b/README @@ -34,7 +34,7 @@ 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.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) diff --git a/src/Data/Stream/Future.hs b/src/Data/Stream/Future.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Future.hs @@ -0,0 +1,148 @@ +{-# 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.Comonad +import Data.Foldable +import Data.Functor.Alt +import Data.Functor.Extend +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 Extend Future where + extended = extend + +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 Apply 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 ComonadApply Future where + (<@>) = (<.>) + +instance Alt Future where + Last a bs = a :< bs + (a :< as) bs = a :< (as bs) + +instance Semigroup (Future a) where + (<>) = () + +instance Applicative Future where + pure = Last + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + + diff --git a/src/Data/Stream/Future/Skew.hs b/src/Data/Stream/Future/Skew.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Future/Skew.hs @@ -0,0 +1,426 @@ +{-# 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 Data.Functor.Alt +import Data.Functor.Extend +import Data.Foldable hiding (toList) +import Data.Traversable (Traversable, traverse) +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +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 Extend Complete where + extended = extend + +instance Comonad Complete where + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + extract (Tip a) = a + extract (Bin _ a _ _) = a + +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 Extend Future where + extended = extend + +instance Comonad Future where + extend g (Last t) = Last (extendTree g t Last) + extend g (t :< ts) = extendTree g t (:< ts) :< extend g ts + extract = head + +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 Apply 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 where + (<@>) = (<.>) + +instance Applicative Future where + pure = repeat + (<*>) = (<.>) + +instance Alt 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) (\ _ 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/src/Data/Stream/Infinite.hs b/src/Data/Stream/Infinite.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Infinite.hs @@ -0,0 +1,455 @@ +{-# 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) + , groupBy -- :: (a -> 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 Data.Char (isSpace) +import Data.Data +import Data.Functor.Apply +import Data.Functor.Extend +import Data.Semigroup +import Data.Foldable +import Data.Traversable +import Data.Distributive +import Data.Semigroup.Traversable +import Data.Semigroup.Foldable +import Data.List.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 + +instance Distributive Stream where + distribute w = fmap head w :> distribute (fmap tail w) + +-- | 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 Extend Stream where + duplicated = tails + extended f w = f w :> extended f (tail w) + +instance Comonad Stream where + duplicate = tails + extend f w = f w :> extend f (tail w) + extract = head + +instance Apply Stream where + (f :> fs) <.> (a :> as) = f a :> (fs <.> as) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream where + (f :> fs) <@> (a :> as) = f a :> (fs <@> as) + as <@ _ = as + _ @> bs = bs + +-- | '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/src/Data/Stream/Infinite/Functional/Zipper.hs b/src/Data/Stream/Infinite/Functional/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Infinite/Functional/Zipper.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE CPP, 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 Data.Char (isSpace) +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif +import Data.Functor.Extend +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) +#ifdef LANGUAGE_DeriveDataTypeable + deriving Typeable +#endif + +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 Extend Zipper where + duplicated (n :~ f) = n :~ (:~ f) + +instance Comonad Zipper where + duplicate (n :~ f) = n :~ (:~ f) + extract (n :~ f) = f n + +instance Apply Zipper where + (nf :~ f) <.> (na :~ a) + | dn <- na - nf + = nf :~ \n -> f n (a (n + dn)) + as <. _ = as + _ .> bs = bs + +instance ComonadApply Zipper where + (<@>) = (<.>) + (<@) = (<.) + (@>) = (.>) + + +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/src/Data/Stream/Infinite/Skew.hs b/src/Data/Stream/Infinite/Skew.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Infinite/Skew.hs @@ -0,0 +1,348 @@ +{-# 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 + , tabulate + ) where + +import Control.Arrow (first) +import Control.Applicative hiding (empty) +import Control.Comonad +import Data.Distributive +import Data.Functor.Alt +import Data.Functor.Extend +import Data.Foldable hiding (toList) +import Data.Traversable +import Data.Semigroup hiding (Last) +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import Prelude hiding (null, head, tail, drop, dropWhile, length, foldr, last, span, repeat, replicate, (!!), break) + +infixr 5 :<, <| + +data Complete a + = Tip a + | Bin !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 Extend Complete where + extended f w@Tip {} = Tip (f w) + extended f w@(Bin n _ l r) = Bin n (f w) (extended f l) (extended f r) + +instance Comonad Complete where + extend f w@Tip {} = Tip (f w) + extend f w@(Bin n _ l r) = Bin n (f w) (extend f l) (extend f r) + extract (Tip a) = a + extract (Bin _ a _ _) = a + +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 Extend Stream where + extended = extend + +instance Comonad Stream where + 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) + extract = head + +instance Apply Stream where + fs <.> as = mapWithIndex (\n f -> f (as !! n)) fs + as <. _ = as + _ .> bs = bs + +instance ComonadApply Stream where + (<@>) = (<.>) + (<@) = (<.) + (@>) = (.>) + +instance Applicative Stream where + pure = repeat + (<*>) = (<.>) + (<* ) = (<. ) + ( *>) = ( .>) + +instance Alt 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 Distributive Stream where + distribute w = tabulate (\i -> fmap (!! i) w) + +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/src/Data/Stream/Supply.hs b/src/Data/Stream/Supply.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stream/Supply.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Stream.Supply +-- Copyright : (C) 2008-2011 Edward Kmett, +-- (C) 2008 Iavor S. Diatchki +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : provisional +-- Portability : portable +-- +-- This library can be used to generate values (for example, new names) +-- without the need to thread state. This means that functions that +-- need to generate new values only need a supply object as an argument, +-- and they do not need to return a new supply object as a result. +-- This decreases the number of data-dependencies in a program, which +-- makes it easier to exploit parallelism. +-- +-- The technique for generating new values is based on the paper +-- ''On Generating Unique Names'' by Lennart Augustsson, Mikael Rittri, +-- and Dan Synek. +---------------------------------------------------------------------------- +module Data.Stream.Supply + ( Supply + , newSupply + , newEnumSupply + , newNumSupply + , newDupableSupply + , newDupableEnumSupply + , newDupableNumSupply + , leftSupply + , rightSupply + , split + , splits + , splitSkew + , split2 + , split3 + , split4 + ) where + +import Control.Applicative +import Control.Comonad +import Data.Functor.Apply +import Data.Functor.Extend +import Data.Foldable +import Data.IORef(newIORef, atomicModifyIORef) +import Data.Traversable +import Data.Semigroup +import Data.Semigroup.Foldable +import Data.Semigroup.Traversable +import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Stream.Infinite +import qualified Data.Stream.Infinite.Skew as Skew + +#ifdef LANGUAGE_DeriveDataTypeable +import Data.Data +#endif + +#ifdef __GLASGOW_HASKELL__ >= 608 +import GHC.IO(unsafeDupableInterleaveIO) +#else +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO = unsafeInterleaveIO +#endif + +data Supply a = Supply a (Supply a) (Supply a) deriving + ( Show, Read, Eq, Ord +#ifdef LANGUAGE_DeriveDataTypeable + , Data, Typeable +#endif + ) + +instance Functor Supply where + fmap f (Supply a l r) = Supply (f a) (fmap f l) (fmap f r) + a <$ _ = pure a + +instance Extend Supply where + extended f s@(Supply _ l r) = Supply (f s) (extended f l) (extended f r) + duplicated s@(Supply _ l r) = Supply s (duplicated l) (duplicated r) + +instance Comonad Supply where + extend f s@(Supply _ l r) = Supply (f s) (extend f l) (extend f r) + duplicate s@(Supply _ l r) = Supply s (duplicate l) (duplicate r) + extract (Supply a _ _) = a + +instance Apply Supply where + Supply f fl fr <.> Supply a al ar = Supply (f a) (fl <.> al) (fr <.> ar) + a <. _ = a + _ .> a = a + +instance Applicative Supply where + pure a = as where as = Supply a as as + Supply f fl fr <*> Supply a al ar = Supply (f a) (fl <*> al) (fr <*> ar) + a <* _ = a + _ *> a = a + +instance Foldable Supply where + foldMap f (Supply a l r) = f a `mappend` foldMap f l `mappend` foldMap f r + +instance Foldable1 Supply where + foldMap1 f (Supply a l r) = f a <> foldMap1 f l <> foldMap1 f r + +instance Traversable Supply where + traverse f (Supply a l r) = Supply <$> f a <*> traverse f l <*> traverse f r + +instance Traversable1 Supply where + traverse1 f (Supply a l r) = Supply <$> f a <.> traverse1 f l <.> traverse1 f r + +leftSupply :: Supply a -> Supply a +leftSupply (Supply _ l _) = l + +rightSupply :: Supply a -> Supply a +rightSupply (Supply _ _ r) = r + +-- unfoldsW :: (Comonad w, Functor f) => (w a -> (b, f a)) -> w a -> StreamT f w b +newSupply :: (a -> a) -> a -> IO (Supply a) +newSupply f x = gen =<< newIORef x + where gen r = unsafeInterleaveIO $ + Supply <$> unsafeInterleaveIO (atomicModifyIORef r update) + <*> gen r + <*> gen r + update a = b `seq` (b, a) where b = f a +{-# INLINE newSupply #-} + +newDupableSupply :: (a -> a) -> a -> IO (Supply a) +newDupableSupply f x = gen =<< newIORef x + where gen r = unsafeDupableInterleaveIO $ + Supply <$> unsafeDupableInterleaveIO (atomicModifyIORef r update) + <*> gen r + <*> gen r + update a = b `seq` (b, a) where b = f a +{-# INLINE newDupableSupply #-} + +newEnumSupply :: Enum a => IO (Supply a) +newEnumSupply = newSupply succ (toEnum 0) +{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} + +newNumSupply :: Num a => IO (Supply a) +newNumSupply = newSupply (1+) 0 +{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} + +newDupableEnumSupply :: Enum a => IO (Supply a) +newDupableEnumSupply = newSupply succ (toEnum 0) +{-# SPECIALIZE newEnumSupply :: IO (Supply Int) #-} + +newDupableNumSupply :: Num a => IO (Supply a) +newDupableNumSupply = newSupply (1+) 0 +{-# SPECIALIZE newNumSupply :: IO (Supply Int) #-} + +split :: Supply a -> Stream (Supply a) +split (Supply _ l r) = l :> split r + +splits :: Integral b => Supply a -> b -> Supply a +splits (Supply _ l r) n = case n `quotRem` 2 of + (0,0) -> leftSupply l + (q,-1) -> splits (rightSupply l) q + (q,0) -> splits (leftSupply r) q + (q,1) -> splits (rightSupply r) q + (_,_) -> error "quotRem: impossible result" +{-# SPECIALIZE splits :: Supply a -> Int -> Supply a #-} +{-# SPECIALIZE splits :: Supply a -> Integer -> Supply a #-} + +splitSkew :: Supply a -> Skew.Stream (Supply a) +splitSkew = Skew.tabulate . splits + +split2 :: Supply a -> (Supply a, Supply a) +split2 (Supply _ l r) = (l, r) + +split3 :: Supply a -> (Supply a, Supply a, Supply a) +split3 (Supply _ a (Supply _ b c)) = (a, b, c) + +split4 :: Supply a -> (Supply a, Supply a, Supply a, Supply a) +split4 (Supply _ (Supply _ a b) (Supply _ c d)) = (a, b, c, d) diff --git a/streams.cabal b/streams.cabal --- a/streams.cabal +++ b/streams.cabal @@ -1,6 +1,6 @@ name: streams category: Control, Comonads -version: 3.0.0.1 +version: 3.0.1 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE @@ -9,7 +9,7 @@ stability: provisional homepage: http://github.com/ekmett/streams homepage: http://github.com/ekmett/streams/issues -copyright: Copyright 2011-2012 Edward Kmett +copyright: Copyright 2011-2013 Edward Kmett Copyright 2010 Tony Morris, Oliver Taylor, Eelis van der Weegen Copyright 2007-2010 Wouter Swierstra, Bas van Dijk Copyright 2008 Iavor S. Diatchki @@ -52,24 +52,6 @@ . * "Data.Stream.Supply" provides a comonadic supply of unique values, which are generated impurely as the tree is explored. - . - /Changes since 0.6.3/: - . - * "Data.Stream.NonEmpty" renamed to "Data.List.NonEmpty" and pushed upstream into the semigroups package. - . - /Changes since 0.5.1/: - . - * Removed a redundant UNPACK pragma - . - /Changes since 0.5/: - . - * Data.Stream.Supply added - . - /Changes since 0.1/: - . - * A number of strictness issues with 'NonEmpty' were fixed - . - * More documentation source-repository head type: git @@ -81,11 +63,11 @@ BangPatterns build-depends: - base >= 4 && < 5, - comonad == 3.0.*, - distributive >= 0.2.1 && < 0.4, - semigroupoids == 3.0.*, - semigroups >= 0.8.3.1 && < 0.9 + base >= 4 && < 5, + comonad >= 3, + distributive >= 0.2.1, + semigroupoids >= 3, + semigroups >= 0.8.3.1 extensions: CPP if impl(ghc) @@ -100,5 +82,6 @@ Data.Stream.Infinite.Functional.Zipper Data.Stream.Supply + hs-source-dirs: src ghc-options: -Wall