Compose Streams

Main.purs

module Main where

import Prelude
import TryPureScript

import Control.Comonad.Cofree (Cofree, head, mkCofree, tail, unfoldCofree)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Unsafe (unsafePerformEff)
import Data.Array (fromFoldable)
import Data.Foldable (fold)
import Data.Identity (Identity(..))
import Data.List (List(..), (:))
import Data.Tuple (Tuple(..), uncurry)
import Unsafe.Coerce (unsafeCoerce)

data FIdentity a = FIdentity a | End

derive instance functorFIdentity :: Functor FIdentity

instance eqFIdentity :: (Eq a) => Eq (FIdentity a) where
  eq (FIdentity a) (FIdentity b) = a == b
  eq End End = true
  eq _ _ = false

composeWith
  :: forall f g h a b c
   . Functor f
  => Functor g
  => Functor h
  => (a -> b -> c)
  -> (Cofree f a -> Cofree g b -> f (Cofree f a) -> g (Cofree g b) -> h (Tuple (Cofree f a) (Cofree g b)))
  -> Cofree f a
  -> Cofree g b
  -> Cofree h c
composeWith zap zapTail f g =
  mkCofree
    (zap (head f) (head g))
    (fn (tail f) (tail g))
  where
    fn :: f (Cofree f a) -> g (Cofree g b) -> h (Cofree h c)
    fn fa gb = uncurry (composeWith zap zapTail) <$> zapTail f g fa gb

fibStream :: Cofree FIdentity Int
fibStream = gen next 0
  where
    next :: Int -> Int -> FIdentity Int
    next a b | a > 1000 = End
             | otherwise = FIdentity $ a + b

    gen
      :: (Int -> Int -> FIdentity Int)
      -> Int
      -> Cofree FIdentity Int
    gen n a = mkCofree a (gen n <$> n a (a + 1))

composedStream :: Cofree FIdentity (Tuple Int Int)
composedStream = composeWith Tuple fn fibStream fibStream
  where
    fn _ _ (FIdentity c1) (FIdentity c2) = FIdentity (Tuple c1 c2)
    fn _ _ _ _ = End

toList :: forall a. Cofree FIdentity a -> List a
toList c = case tail c of
             End -> head c : Nil
             FIdentity c' -> head c : toList c'

main = do
  render $ fold $
    [ h1 (text "Compose Streams")
    , p $ code $ text $ show $ fromFoldable $ toList composedStream
    ]