purescript-free

purescript-free copied to clipboard

I worked out a way to compose cofree comonads: http://try.purescript.org/?gist=b31f48d16ad43cec8c0afcd470ac5add

there is the function:

compose
  :: forall f g a b
   . Functor f
  => Functor g
  => Cofree f a
  -> Cofree g b
  -> Cofree (Product f g) (Tuple a b)
compose f g =
  mkCofree
    (Tuple (head f) (head g))
    (fn (tail f) (tail g))
  where
    fn :: f (Cofree f a) -> g (Cofree g b) -> Product f g (Cofree (Product f g) (Tuple a b))
    fn fa gb = uncurry compose <$> (product (flip Tuple g <$> fa) (Tuple f <$> gb))

Is there a place for it in the Control.Comonad.Cofree module?

Neat :) This reminds me of the fuseWith function from coroutines.

What about this type signature?

compose
  :: forall f g h a b
   . Functor f
  => Functor g
  => Functor h
  => (f a -> g b -> h c)
  -> Cofree f a
  -> Cofree g b
  -> Cofree h c

+1 I'll craft a PR.

The most general signature that I can come up with:

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

Then my use case is covered by:

composeWith Tuple (\a b ta tb -> product (flip Tuple b <$> ta) (Tuple a <$> tb))

How about something like this?

compose
  :: forall f g h a b c
   . (forall a b c. (a -> b -> c) -> f a -> g b -> h c)
  -> (a -> b -> c)
  -> Cofree f a
  -> Cofree g b
  -> Cofree h c
compose phi psi = go where
  go f g = mkCofree (psi (head f) (head g)) (phi go (tail f) (tail g))

A type synonym tidies it up a bit too:

type Zap f g h = forall a b c. (a -> b -> c) -> f a -> g b -> h c

compose :: forall f g h. Zap f g h -> Zap (Cofree f) (Cofree g) (Cofree h)

I don't see how to get phi of type

phi :: (x -> y -> z) -> f x -> g y -> Product f g z

here

That was also a problem in the original and I went around it here:

    fn :: f (Cofree f a) -> g (Cofree g b) -> Product f g (Cofree (Product f g) (Tuple a b))
    fn fa gb = uncurry compose <$> (product (flip Tuple g <$> fa) (Tuple f <$> gb))

where on the right hand side of <$> there is Product f g (Tuple (Cofree f a) (Cofree g b)) and I had to use f and g directly to create it.

Ah yes, my mistake.

Maybe the way to go is to just abstract over Tuple :: a -> b -> c and product :: f _ -> g _ -> h _ with two functions then?

That's what I did in the composeWith above where you have

zap ::  a -> b -> c

and

zapTail :: (Cofree f a -> Cofree g b -> f (Cofree f a) -> g (Cofree g b) -> h (Tuple (Cofree f a) (Cofree g b)))

and I need zapTail to recieve the Cofree f a and Cofree g b as first two arguments. Otherwise the composition I am using will not work.

Probably we can get rid of the Tuple in codomain of zapTail - it's just composes well with uncurry compose <$> ...

I am not really happy with the signature though... your proposition was much cleaner :)

I am not really happy with the signature though

I'd just like to understand it a little better first. It's not clear to me just yet exactly what it's doing.

The bit that's not clear to me is Tuple f <$> gb. If we think of the resulting comonad as a simulation, paired with Free (Coproduct x y), then the simulation of the left hand side here (f) seems like it's one time step behind the right. So if I run a series of "right" commands, the first "left" simulation is still waiting to be run.

So if I run a series of "right" commands, the first "left" simulation is still waiting to be run.

FWIW, and I'm not sure how related it is, but this is why coroutines requires a Parallel constraint in order to make sense, otherwise the same thing can happen for push-based coroutines.

That's true Tuple f <$> gb puts f that is one step behind. It works in my use case because this leg is not used when the interpreter runs - so it does not matter. This is because I have this pairing:

pair :: forall x y. (Coproduct CommandA CommandM (x -> y)) -> Product RunCommandA RunCommandM x -> y
pair (Coproduct (Left c)) (Product (Tuple l r)) = pairA c l
pair (Coproduct (Right c)) (Product (Tuple l r)) = pairM c r

Checkout this session: http://try.purescript.org/?gist=b31f48d16ad43cec8c0afcd470ac5add&session=7b460f38-eaea-2049-5606-441ee08bdf72

There is only one StateA (additive counter) and one interpreter. The composition of cofree is:

-- compose two cofree comonands into a product
compose
  :: forall f a
   . Functor f
  => Cofree f a
  -> Cofree f a
  -> Cofree (Product f f) (Tuple a a)
compose f g =
  mkCofree
    (Tuple (head f) (head g))
    (fn (tail f) (tail g))
  where
    fn fa gb = uncurry compose <$> (product (flip Tuple g <$> fa) (Tuple g <$> gb))

So i only use the right one (flip Tuple g <$> ... and Tuple g <$> ....).

Then the result is that all the liftF $ left .... commands are ignored, and the stated of the left state in the product is indeed one behind the right one.

You can also have some fun with streams: in this gist I just duplicate a Fiibonacci sequence: http://try.purescript.org/?gist=6bac5a9839403f65c40e8494031c9a00

btw, the I am not sure if it is possible to unfold fibonacci sequence with unfoldCofree. Since the Cofree constructor is not exported, there might not be a way to generate it in a lazy way. mkCofree is not lazy, so I had to use FIdentity functor rather than Identity.

FWIW this is what I'm using in wags-lib - it's live in a couple musical works and gets the job done nicely.

convolve
  :: forall f a g b h c
   . Functor f
  => Functor g
  => (a -> b -> c)
  -> (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> Cofree f a
  -> Cofree g b
  -> Cofree h c
convolve f1 f2 c1 c2 = f1 (extract c1) (extract c2) :< convolveComonadCofree f1 f2 (unwrapCofree c1) (unwrapCofree c2)

convolveComonadCofree
  :: forall f a g b h c
   . Functor f
  => Functor g
  => (a -> b -> c)
  -> (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> f (Cofree f a)
  -> g (Cofree g b)
  -> h (Cofree h c)
convolveComonadCofree f1 f2 = f2 (convolve f1 f2)

convolveComonadCofreeChooseB
  :: forall f a g b h
   . Functor f
  => Functor g
  => (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> f (Cofree f a)
  -> g (Cofree g b)
  -> h (Cofree h b)
convolveComonadCofreeChooseB = convolveComonadCofree (const identity)

composeComonadCofree
  :: forall f a b
   . Functor f
  => f (Cofree f a)
  -> (a -> Cofree ((->) a) b)
  -> f (Cofree f b)
composeComonadCofree = convolveComonadCofreeChooseB (\cont e b -> map (cont <*> b <<< extract) e)

deferConvolve
  :: forall f a g b h c
   . Functor f
  => Functor g
  => (a -> b -> c)
  -> (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> Cofree f a
  -> Cofree g b
  -> Cofree h c
deferConvolve f1 f2 c1 c2 =
  deferCofree
    \_ -> f1 (extract c1) (extract c2) /\ deferConvolveComonadCofree f1 f2 (unwrapCofree c1) (unwrapCofree c2)

deferConvolveComonadCofree
  :: forall f a g b h c
   . Functor f
  => Functor g
  => (a -> b -> c)
  -> (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> f (Cofree f a)
  -> g (Cofree g b)
  -> h (Cofree h c)
deferConvolveComonadCofree f1 f2 = f2 (deferConvolve f1 f2)

deferConvolveComonadCofreeChooseB
  :: forall f a g b h
   . Functor f
  => Functor g
  => (forall z. (Cofree f a -> Cofree g b -> z) -> f (Cofree f a) -> g (Cofree g b) -> h z)
  -> f (Cofree f a)
  -> g (Cofree g b)
  -> h (Cofree h b)
deferConvolveComonadCofreeChooseB = deferConvolveComonadCofree (const identity)

deferComposeComonadCofree
  :: forall f a b
   . Functor f
  => f (Cofree f a)
  -> (a -> Cofree ((->) a) b)
  -> f (Cofree f b)
deferComposeComonadCofree = deferConvolveComonadCofreeChooseB (\cont e b -> map (cont <*> b <<< extract) e)

I use it for stuff like:

type CfLag a
  = Cofree ((->) a) (Either a (Tuple a a))

type ALag (a :: Type)
  = a -> CfLag a

makeLag :: forall a. ALag a
makeLag = (:<) <$> Left <*> go
  where
  go old = (:<) <$> (Right <<< Tuple old) <*> go

withLag
  :: forall f a
   . Functor f
  => f (Cofree f a)
  -> f (Cofree f (Either a (Tuple a a)))
withLag = flip composeComonadCofree makeLag

withDeferredLag
  :: forall f a
   . Functor f
  => f (Cofree f a)
  -> f (Cofree f (Either a (Tuple a a)))
withDeferredLag = flip deferComposeComonadCofree makeLag

test = do
      let
        r0 = unwrap $ withDeferredLag (let x n = deferCofree \_ -> Tuple n $ Identity (x (n + 1)) in Identity $ x 0)
        r1 = unwrap $ unwrapCofree r0
        r2 = unwrap $ unwrapCofree r1
        r3 = unwrap $ unwrapCofree r2
        r4 = unwrap $ unwrapCofree r3
        r5 = unwrap $ unwrapCofree r4
        r6 = unwrap $ unwrapCofree r5
        r7 = unwrap $ unwrapCofree r6
      extract r0 `shouldEqual` (Left $ 0)
      extract r1 `shouldEqual` (Right $ 0 /\ 1)
      extract r2 `shouldEqual` (Right $ 1 /\ 2)
      extract r3 `shouldEqual` (Right $ 2 /\ 3)
      extract r4 `shouldEqual` (Right $ 3 /\ 4)
      extract r5 `shouldEqual` (Right $ 4 /\ 5)
      extract r6 `shouldEqual` (Right $ 5 /\ 6)
      extract r7 `shouldEqual` (Right $ 6 /\ 7)