Source

lingo / aline / Align.hs

Full commit
module Align
       (
         Op(..)
       , isEmpty
       , align
       , shiftUp
       )
where       
import LCS
import qualified Data.List as List
import qualified Data.Map  as Map
import Data.Maybe

data Op a = Op { inserts :: [a], deletes :: Maybe a } deriving (Show)

empty :: Op a
empty = Op { inserts = [], deletes = Nothing }

isEmpty :: Op a -> Bool
isEmpty op = null (inserts op) && isNothing (deletes op)

-- | 'align src tgt' for each position in src returns record of edit
-- operations need to transform into tgt.
align :: (Ord a) => [a] -> [a] -> [Op a]
align src tgt = 
  let table = compress $ ses src tgt 
  in [ Map.findWithDefault empty i table | i <- [0 .. length src+1] ]
       
-- | shiftUp ops moves insert operations one position up.     
shiftUp :: [Op a] -> [Op a]     
shiftUp ops = zipWith shift ops (tail ops) 
  where shift o1 o2 = o1 { inserts = inserts o2 }
     
compress :: [Edit a] -> Map.Map Int (Op a)
compress es = Map.fromList [ (pos . head $ g, stringify g) 
                           | g <- List.groupBy (\a b -> pos a == pos b) es ]  

stringify :: [Edit a] -> Op a
stringify es =
  let is = filter ins es 
      ds = filter del es
  in Op { inserts = map char is, deletes = listToMaybe . map char $ ds }

pos :: Edit a -> Int     
pos (Ins _ i) = i
pos (Del _ i) = i

ins :: Edit a -> Bool
ins (Ins _ _) = True
ins _         = False

del :: Edit a -> Bool
del = not . ins
   
char :: Edit a -> a
char (Ins a _) = a
char (Del a _) = a