-----------------------------------------------------------------------------
-- |
-- 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