Memoized longest common subsequence

gistfile1.hs

module LCS where

import Data.Function.Memoize

data Z = A | B | C | D | G | T | X deriving (Eq,Enum,Show)

x1 :: [Z]
x1 = [A,B,C,B,D,A,B]
y1 :: [Z]
y1 = [B,D,C,A,B,A]

x2 :: [Z]
x2 = [A,C,C,G,G,T,C,G,A,G,T,G,C,G,C,G,G,A,A,G,C,C,G,G,C,C,G,A,A]
y2 :: [Z]
y2 = [G,T,C,G,T,T,C,G,G,A,A,T,G,C,C,G,T,T,G,C,T,C,T,G,T,A,A,A]

-- |
--
-- >>> lcs x2 y2
-- [G,T,C,G,T,C,G,G,A,A,G,C,C,G,G,C,C,G,A,A]
-- >>> lcs x1 y1
-- [B,C,B,A]

lcs :: [Z] -> [Z] -> [Z]
lcs as bs = fromInts cs
  where
    at = (length as, toInts as)
    bt = (length bs, toInts bs)
    (_,cs) = lcsMemo at bt
    lcsMemo = memoize2 go
    go :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int])
    go (_,[]) _ = (0,[])
    go _ (_,[]) = (0,[])
    go tx@(lx,x:xs) ty@(ly,y:ys)
        | x == y    = let (l, zs) = lcsMemo (lx-1,xs) (ly-1,ys)
                      in (l+1, x:zs)
        | otherwise = lcsMemo (lx-1,xs) ty `longer` lcsMemo tx (ly-1,ys)

toInts :: [Z] -> [Int]
toInts = reverse . map fromEnum

fromInts :: [Int] -> [Z]
fromInts = reverse . map toEnum

longer :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int])
longer xs ys
  | fst xs >= fst ys = xs
  | otherwise        = ys