-----------------------------------------------------------------------------
-- |
-- Module : Data.Diff
-- Copyright : (c) 2011 University of Minho
-- License : BSD3
--
-- Maintainer : hpacheco@di.uminho.pt
-- Stability : experimental
-- Portability : non-portable
--
-- Pointless Lenses:
-- bidirectional lenses with point-free programming
--
-- This module defines provides some value differencing algorithms that produce deltas estimaating a view update.
--
-----------------------------------------------------------------------------
module Data.Diff where
import Data.Relation
import Data.Shape
import Generics.Pointless.HFunctors
import Generics.Pointless.Functors
import Data.List as List
import Data.Set (Set)
import qualified Data.Set as Set
type Delta a b = Pos a :->: Pos b
type Diff v = v -> v -> Delta v v
class (Shapely s) => Differable s where
-- | Positional differencing algorithm
positional :: Diff (s a)
-- | A generic version of a minimal edit distance differencing algorithm
s2sc :: Eq a => Diff (s a)
-- | Converting a list differencing algorithm into a generic differencing algorithm
listDiff :: Diff [a] -> Diff (s a)
-- | Differencing based on a key projection function
keyDiff :: Shapely s => (b -> k) -> Diff (s k) -> Diff (s b)
-- default definitions
s2sc = listDiff s2scList
listDiff diff v s = diff (data_ v) (data_ s)
keyDiff proj diff v' v = diff (smap proj v') (smap proj v)
instance Differable Id where
positional x y = mkRel [(0,0)]
instance Differable (Const t) where
positional x y = emptyR
instance (Differable f,Differable g) => Differable (f :+: g) where
positional (InlF x) (InlF y) = positional x y
positional (InrF x) (InrF y) = positional x y
positional x y = emptyR
instance (Differable f,Differable g) => Differable (f :*: g) where
positional x@(ProdF x1 x2) y@(ProdF y1 y2) =
(inv (fstPosR (x1,x2)) .~ positional x1 y1 .~ fstPosR (y1,y2))
`unionR` (inv (sndPosR (x1,x2)) .~ positional x2 y2 .~ sndPosR (y1,y2))
instance (Differable f,Differable g) => Differable (f :@: g) where
positional x y = zipR $ Set.toList $ positional fxi fyi
where (CompF fxi) = recover (shape x,Set.toList $ locs x)
(CompF fyi) = recover (shape y,Set.toList $ locs y)
zipR [] = emptyR
zipR ((i,j):rs) = aux (data_(fxi)!!i,data_(fyi)!!j) `unionR` zipR rs
aux (gx,gy) = mkRel [ (data_(gy)!!j,data_(gx)!!i) | (i,j) <- Set.elems $ positional gx gy ]
instance Differable [] where
positional x y = positional (hout x) (hout y)
-- * The string to string correction problem with block moves
-- | A list different algorithm inspired in the string-to-string correction problem that computes a minimal edit sequence
-- The used algorithm can be found in <http://ftp.cs.purdue.edu/research/technical_reports/1983/TR%2083-459.pdf>
s2scList :: Eq a => Diff [a]
s2scList v s = movesDelta (s2scAlg s v)
movesDelta :: [Move] -> Delta [a] [a]
movesDelta [] = emptyR
movesDelta (m:ms) = moveDelta m `Set.union` movesDelta ms
moveDelta :: Move -> Delta [a] [a]
moveDelta (s,v,m) = mkRel $ zip [v..v+m-1] [s..s+m-1]
-- position in src, position in view, length
type Move = (Int,Int,Int)
-- First argument is the original list and the second the modified list, and returns a sequence ov edit operations
s2scAlg :: Eq a => [a] -> [a] -> [Move]
s2scAlg s t = s2scAlg' 0 s t
s2scAlg' :: Eq a => Int -> [a] -> [a] -> [Move]
s2scAlg' _ s [] = []
s2scAlg' tpos s t = case findLongestPrefix t s of
Just (plen,spos) -> (spos,tpos,plen) : s2scAlg' (tpos+plen) s (drop plen t)
otherwise -> s2scAlg' (tpos+1) s (tail t)
-- finds the first list in the second returning the index at which it appears
findL :: Eq a => [a] -> [a] -> Maybe Int
findL l [] = Nothing
findL l s = if isPrefixOf l s then Just 0 else mapMaybe succ $ findL l (tail s)
mapMaybe :: (a -> b) -> Maybe a -> Maybe b
mapMaybe f Nothing = Nothing
mapMaybe f (Just a) = Just (f a)
-- length of prefix, starting position in the second list
findLongestPrefix :: Eq a => [a] -> [a] -> Maybe (Int,Int)
findLongestPrefix [] s = Nothing
findLongestPrefix l s = case findL l s of
Just i -> Just (length l,i)
otherwise -> findLongestPrefix (init l) s