{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Util.Myers(
diff,
diff2,
DiffElement(..),
) where
import Data.Array
import Control.Monad.ST
import Data.Array.ST
import Util.ExtendedPrelude
data DiffElement v =
InBoth [v]
| InFirst [v]
| InSecond [v] deriving (Show)
diff :: (Eq a) => [a] -> [a] -> [DiffElement a]
diff l1 l2 =
let
common = lcss l1 l2
addFirst :: [a] -> [DiffElement a] -> [DiffElement a]
addFirst [] de0 = de0
addFirst l1 de0 = InFirst l1 : de0
addSecond :: [a] -> [DiffElement a] -> [DiffElement a]
addSecond [] de0 = de0
addSecond l1 de0 = InSecond l1 : de0
doCommon :: Eq a => [a] -> [a] -> [a] -> [DiffElement a]
doCommon [] l1 l2 = (addFirst l1) . (addSecond l2) $ []
doCommon (c:cs) l10 l20 =
let
Just (l1A,l11) = splitToElem (== c) l10
Just (l2A,l21) = splitToElem (== c) l20
de0 = doCommon cs l11 l21
de1 = case de0 of
(InBoth cs:rest) -> InBoth (c:cs):rest
_ -> InBoth [c] : de0
in
(addFirst l1A) . (addSecond l2A) $ de1
in
doCommon common l1 l2
algb :: (Eq a) => [a] -> [a] -> [Int]
algb xs ys
= 0 : algb1 xs [ (y,0) | y <- ys ]
where
algb1 [] ys' = map snd ys'
algb1 (x:xs) ys'
= algb1 xs (algb2 0 0 ys')
where
algb2 _ _ [] = []
algb2 k0j1 k1j1 ((y,k0j):ys)
= let kjcurr = if x == y then k0j1+1 else max k1j1 k0j
in (y,kjcurr) : algb2 k0j kjcurr ys
algc :: (Eq a) => Int -> Int -> [a] -> [a] -> [a] -> [a]
algc m n xs [] = id
algc m n [x] ys = if x `elem` ys then (x:) else id
algc m n xs ys
= algc m2 k xs1 (take k ys) . algc (m-m2) (n-k) xs2 (drop k ys)
where
m2 = m `div` 2
xs1 = take m2 xs
xs2 = drop m2 xs
l1 = algb xs1 ys
l2 = reverse (algb (reverse xs2) (reverse ys))
k = findk 0 0 (-1) (zip l1 l2)
findk k km m [] = km
findk k km m ((x,y):xys)
| x+y >= m = findk (k+1) k (x+y) xys
| otherwise = findk (k+1) km m xys
lcss :: (Eq a) => [a] -> [a] -> [a]
lcss xs ys = algc (length xs) (length ys) xs ys []
diff2 :: Eq v => [v] -> [v] -> [DiffElement v]
diff2 [] [] = []
diff2 a b = runST (diffST2 a b)
diffST2 :: forall v s . Eq v => [v] -> [v] -> ST s [DiffElement v]
diffST2 a b =
do
let
m = length a
(aArr :: Array Int v) = listArray (1,m) a
n = length b
(bArr :: Array Int v) = listArray (1,n) b
match :: Int -> Int -> Bool
match x y = (aArr ! x) == (bArr ! y)
scan :: Int -> Int -> (Int,Int)
scan x y =
if x < m && y < n
then
let
x' = x+1
y' = y+1
in
if match x' y' then scan x' y' else (x,y)
else
(x,y)
max = m+n
(v :: STUArray s Int Int) <- newArray (-max-1,max+1) (-1)
writeArray v 1 0
(w :: STArray s Int [(Int,Int)]) <- newArray (-max,max) []
let
step :: Int -> Int -> ST s [(Int,Int)]
step d k =
if k > d
then
innerStep (d+1) (-(d+1))
else
innerStep d k
innerStep :: Int -> Int -> ST s [(Int,Int)]
innerStep d k =
do
vkplus <- readArray v (k+1)
vkminus <- readArray v (k-1)
(x,l0) <- if vkminus < vkplus
then
do
l0 <- readArray w (k+1)
return (vkplus,l0)
else
do
l <- readArray w (k-1)
return (vkminus+1,l)
let
y = x - k
(x',_) = scan x y
l1 =
if x' == x
then
l0
else
(x,y) : l0
if x' >= m && (y + (x' - x)) >= n
then
return l1
else
do
writeArray v k x'
writeArray w k l1
step d (k+2)
snakes <- step 0 0
let
addSnake :: (Int,Int) -> (Int,Int)
-> [DiffElement v] -> [DiffElement v]
addSnake (lastX,lastY) (x,y) l0 =
let
(x',y') = scan x y
l1 = (InSecond (map (\ index -> bArr ! index)
[y'+1..lastY])) : l0
l2 = (InFirst (map (\ index -> aArr ! index)
[x'+1..lastX])) : l1
l3 = (InBoth (map (\ index -> aArr ! index)
[x+1..x'])) : l2
in
l3
doSnakes :: (Int,Int) -> [(Int,Int)] -> [DiffElement v]
-> [DiffElement v]
doSnakes last [] l0 =
if last /= (0,0) then addSnake last (0,0) l0 else l0
doSnakes last (s:ss) l0 =
let
l1 = addSnake last s l0
in
doSnakes s ss l1
result0 = doSnakes (m,n) snakes []
result1 = filter
(\ de -> case de of
InFirst [] -> False
InSecond [] -> False
InBoth [] -> False
_ -> True
)
result0
return result1