Collate.hs

-- Collation of infinite streams. I guess.
module Collate where

import Prelude hiding (take, zip, repeat, head, tail)
import qualified Data.List as List

infixr 5 :<

-- An infinite stream of values
data Stream a = a :< Stream a

-- The Church encopding for Streams. This is like foldr for lists. Did you know
-- that you can name variables like operators? Cool.
stream :: (a -> b -> b) -> Stream a -> b
stream (*) (x :< xs) = x * stream (*) xs

instance Functor Stream where
  fmap f = stream ((:<) . f)

-- Some useful Stream utils

toList :: Stream a -> [a]
toList  = stream (:)

take :: Int -> Stream a -> [a]
take n = List.take n . toList

head :: Stream a -> a
head (x :< _) = x

tail :: Stream a -> Stream a
tail (_ :< xs) = xs

-- Now for the fun stuff

-- We need the Applicative instance for Streams. We can write it like this:
--
--     instance Applicative Stream where
--       (f :< fs) <*> (x :< xs) = f x :< (fs <*> xs)
--       pure x = x :< pure x
--
-- but that's boring.

zip :: Stream a -> Stream b -> Stream (a,b)
zip (a :< as) (b :< bs) = (a,b) :< zip as bs

-- You might like one of these better
--
--     zap (f, x) = f x
--     zap p = fst p $ snd p
--     zap = fst <*> snd
zap :: (a -> b, a) -> b
zap = uncurry ($)

repeat :: a -> Stream a
repeat x = x :< repeat x

instance Applicative Stream where
  fs <*> xs = zap <$> zip fs xs
  pure = repeat

-- Transposes a list of streams into a stream of lists. This is like transpose
-- for lists. If Stream was Foldable, this would be sequenceA. We might as well
-- make it as general as possible while we're at it.
transpose :: Functor f => f (Stream a) -> Stream (f a)
transpose s = fmap head s :< transpose (fmap tail s)

-- Where the magic happens. We could just write this as
--
--     collate f streams = f <$> transpose streams
--
-- or
--
--     collate f = fmap f . transpose
--
-- but nah
collate :: Functor f => (f a -> b) -> f (Stream a) -> Stream b
collate = (<$> transpose) <$> (<$>)

s1, s2 :: Stream Int
s1 = 1 :< 2 :< 4 :< 6 :< s1
s2 = 2 :< 1 :< 3 :< 7 :< s2

main = do
  printSome s1
  printSome s2
  ============
  printSome (collate minimum [s1, s2])
  where
    -- Tricksy Hobbit
    k ============ l = k >> line >> l
    line = putStrLn (replicate 21 '=')
    printSome = print . take 10

-- [1,2,4,6,1,2,4,6,1,2]
-- [2,1,3,7,2,1,3,7,2,1]
-- =====================
-- [1,1,3,6,1,1,3,6,1,1]