Parallel, terminating recursion scheme

parfold2.hs

{-# LANGUAGE Rank2Types, DeriveFunctor #-}

newtype Rec f = In { out :: f (Rec f) }

fold :: (Functor f, Functor g) => (forall a b a' b'. (a -> b -> x) -> (a -> b' -> x) -> (a' -> b -> x) -> a' -> b' -> f a -> g b-> x) -> Rec f -> Rec g -> x
fold phi = let f = \x y -> (phi f f f) x y (out x) (out y) in f

data List a t = Nil | Cons a t deriving (Show, Functor)

nil = In Nil
cons a = In . Cons a

lcs :: (Eq a) => Rec (List a) -> Rec (List a) -> Int
lcs = fold lcs' where
  lcs' f g h _ _ Nil _ = 0
  lcs' f g h _ _ _ Nil = 0
  lcs' f g h l1 l2 (Cons a1 l3) (Cons a2 l4) | a1 == a2 = 1 + f l3 l4
                                             | otherwise = max (g l3 l2) (h l1 l4)

test = lcs (cons 'A' $ cons 'B' $ cons 'C' $ cons 'D' $ nil) (cons 'B' $ cons 'D' $ cons 'E' $ nil)