story-cata.hs

type family Apply g a b :: * where
    Apply (->) a b = a -> b
    Apply Snd  a b = b

data StoryF g a = Change Character ChangeType (Apply g ChangeResult a)
                | forall x x'. Interrupt (Free (StoryF g) x')
                                         (Free (StoryF g) x)
                                         (Apply g x a)
                | Macguffin (Apply g Desirable a)

instance Functor (StoryF Snd) where
    fmap f (Change c ct k)   = Change    c ct (f k)
    fmap f (Interrupt a x k) = Interrupt a x  (f k)
    fmap f (Macguffin k)     = Macguffin      (f k)

instance Functor (StoryF (->)) where
    fmap f (Change c ct k)   = Change    c ct (fmap f k)
    fmap f (Interrupt a x k) = Interrupt a  x (fmap f k)
    fmap f (Macguffin k)     = Macguffin      (fmap f k)

-- transform 
apply :: Free (StoryF (->)) a -> Free (StoryF Snd) a
apply (Free (Change c ct k)) = Free
                             . Change c ct
                             . apply
                             . k
                             $ ChangeResult c ct
apply (Free (Interrupt a a' k)) =
    let b = fst $ runStory a' appStory
     in   Free
        . Interrupt (apply a) (apply a')
        . apply
        $ k b
apply (Free (Macguffin k)) = Free
                           . Macguffin
                           . apply
                           . k
                           $ Desirable ""
apply (Pure a) = Pure a

type Algebra f a = f a -> a

-- cata over Free
fcata :: Functor f => Algebra f a -> (b -> a) -> Free f b -> a
fcata alg f (Pure b) = f b
fcata alg f (Free free) = alg . fmap (fcata alg f) $ free

-- cata over StoryF
scata :: Algebra (StoryF Snd) a -> (b -> a) -> Free (StoryF (->)) b -> a
scata alg f = fcata alg f . apply

-- now we can do nice folds over StoryF:
characters :: Algebra (StoryF Snd) (Set Character)
characters (Change c _ cs) = S.insert c cs
characters (Interrupt (fcata characters (const S.empty) -> as)
                      (fcata characters (const S.empty) -> bs)
                      cs) = mconcat [as, bs, cs]
characters (Macguffin cs) = cs