Наибольшая общая подпоследовательность

import Data.List
 
longest xs ys = if length xs > length ys then xs else ys
 
lcs xs ys = head $ foldr(\xs -> map head. scanr1 f. zipWith (\x y -> [x,y]) xs) e m where
    m = map (\x -> flip (++) [[]] $ map (\y -> [x | x==y]) ys) xs
    e = replicate (length ys) []
    f [a,b] [c,d] 
     | null a = longest b c: [b]
     | otherwise = (a++d):[b]

module LCS where
import Control.Monad
data State a = Empty | State [a] [a] [a] Integer deriving Show
isEmpty :: State a -> Bool
isEmpty Empty = True
isEmpty _ = False
diagonal :: Eq a => State a -> State a
diagonal (State initial (a:as) (b:bs) depth)
    | a == b =
        diagonal $ State (a:initial) as bs (depth+2)
diagonal s = s
first :: State a -> State a
first (State initial (_:as) bs depth) = State initial as bs (depth+1)
first _ = Empty
second :: State a -> State a
second (State initial as (_:bs) depth) = State initial as bs (depth+1)
second _ = Empty
merge :: State a -> State a -> State a
merge s1@(State _ _ _ depth1) s2@(State _ _ _ depth2) =
    if depth1 > depth2 then s1 else s2
merge Empty s2 = s2
merge s1 Empty = s1
checkFinal :: State a -> Either [a] ()
checkFinal (State initial [] [] _) = Left $ reverse initial
checkFinal _ = return ()
fuse :: Eq a => State a -> State a -> Either [a] (State a)
fuse s1 s2 =
    do let s = diagonal $ merge s1 s2
       checkFinal s
       return s
step :: Eq a => [State a] -> Either [a] [State a]
step states =
    liftM (dropWhile isEmpty) $
    zipWithM fuse (map first states ++ [Empty]) (Empty : map second states)
repeatM :: Monad m => (a -> m a) -> a -> m b
repeatM h = repeatM' where repeatM' a = h a >>= repeatM'
lcs :: Eq a => [a] -> [a] -> [a]
lcs as bs =
    let initialState = diagonal $ State [] as bs 0 in
    case checkFinal initialState >> repeatM step [initialState] of
      Left answer -> answer
      Right () -> error "impossible"