|author||tv <email@example.com>||2014-08-07 13:17:29 +0200|
|committer||tv <firstname.lastname@example.org>||2014-08-07 13:17:29 +0200|
1 files changed, 154 insertions, 0 deletions
diff --git a/src/Data/Algorithm/Patience.hs b/src/Data/Algorithm/Patience.hs
new file mode 100644
@@ -0,0 +1,154 @@
+ , ViewPatterns
+ , CPP #-}
+-- | Implements \"patience diff\" and the patience algorithm for the longest
+-- increasing subsequence problem.
+ ( -- * Patience diff
+ , Item(..), itemChar, itemValue
+ -- * Longest increasing subsequence
+ , longestIncreasing
+ ) where
+import qualified Data.Sequence as S
+import Data.Sequence ( (<|), (|>), (><), ViewL(..), ViewR(..) )
+import qualified Data.Foldable as F
+import qualified Data.Map as M
+import qualified Data.IntMap as IM
+import Data.Typeable ( Typeable )
+import Data.Data ( Data )
+-- If key xi is in the map, move it to xf while adjusting the value with f.
+adjMove :: (a -> a) -> Int -> Int -> IM.IntMap a -> IM.IntMap a
+adjMove f xi xf m = case IM.updateLookupWithKey (\_ _ -> Nothing) xi m of
+ (Just v, mm) -> IM.insert xf (f v) mm
+ (Nothing, _) -> m
+-- A "card" is an integer value (with annotation) plus a "backpointer" to
+-- a card in the previous pile, if any.
+data Card a = Card Int a (Maybe (Card a))
+-- | Given: a list of distinct integers. Picks a subset of the integers
+-- in the same order, i.e. a subsequence, with the property that
+-- * it is monotonically increasing, and
+-- * it is at least as long as any other such subsequence.
+-- This function uses patience sort:
+-- For implementation reasons, the actual list returned is the reverse of
+-- the subsequence.
+-- You can pair each integer with an arbitrary annotation, which will be
+-- carried through the algorithm.
+longestIncreasing :: [(Int,a)] -> [(Int,a)]
+longestIncreasing = extract . foldl' ins IM.empty where
+ -- Insert a card into the proper pile.
+ -- type Pile a = [Card a]
+ -- type Piles a = IM.IntMap (Pile a) -- keyed by smallest element
+ ins m (x,a) =
+ let (lt, gt) = IM.split x m
+ prev = (head . fst) `fmap` IM.maxView lt
+ new = Card x a prev
+ in case IM.minViewWithKey gt of
+ Nothing -> IM.insert x [new] m -- new pile
+ Just ((k,_),_) -> adjMove (new:) k x m -- top of old pile
+ -- Walk the backpointers, starting at the top card of the
+ -- highest-keyed pile.
+ extract (IM.maxView -> Just (c,_)) = walk $ head c
+ extract _ = 
+ walk (Card x a c) = (x,a) : maybe  walk c
+-- Elements whose second component appears exactly once.
+unique :: (Ord t) => S.Seq (a,t) -> M.Map t a
+unique = M.mapMaybe id . F.foldr ins M.empty where
+ ins (a,x) = M.insertWith' (\_ _ -> Nothing) x (Just a)
+-- Given two sequences of numbered "lines", returns a list of points
+-- where unique lines match up.
+solveLCS :: (Ord t) => S.Seq (Int,t) -> S.Seq (Int,t) -> [(Int,Int)]
+solveLCS ma mb =
+ let xs = M.elems $ M.intersectionWith (,) (unique ma) (unique mb)
+ in longestIncreasing $ sortBy (comparing snd) xs
+-- Type for decomposing a diff problem. We either have two
+-- lines that match, or a recursive subproblem.
+data Piece a
+ = Match a a
+ | Diff (S.Seq a) (S.Seq a)
+ deriving (Show)
+-- Subdivides a diff problem according to the indices of matching lines.
+chop :: S.Seq t -> S.Seq t -> [(Int,Int)] -> [Piece t]
+chop xs ys 
+ | S.null xs && S.null ys = 
+ | otherwise = [Diff xs ys]
+chop xs ys ((nx,ny):ns) =
+ let (xsr, S.viewl -> (x :< xse)) = S.splitAt nx xs
+ (ysr, S.viewl -> (y :< yse)) = S.splitAt ny ys
+ in Diff xse yse : Match x y : chop xsr ysr ns
+-- Zip a list with a Seq.
+zipLS :: [a] -> S.Seq b -> S.Seq (a, b)
+zipLS = S.zip . S.fromList
+zipLS xs = S.fromList . zip xs . F.toList
+-- Number the elements of a Seq.
+number :: S.Seq t -> S.Seq (Int,t)
+number xs = zipLS [0..S.length xs - 1] xs
+-- | An element of a computed difference.
+data Item t
+ = Old t -- ^ Value taken from the \"old\" list, i.e. left argument to 'diff'
+ | New t -- ^ Value taken from the \"new\" list, i.e. right argument to 'diff'
+ | Both t t -- ^ Value taken from both lists. Both values are provided, in case
+ -- your type has a non-structural definition of equality.
+ deriving (Eq, Ord, Show, Read, Typeable, Data)
+instance Functor Item where
+ fmap f (Old x ) = Old (f x)
+ fmap f (New x ) = New (f x)
+ fmap f (Both x y) = Both (f x) (f y)
+-- | The difference between two lists, according to the
+-- \"patience diff\" algorithm.
+diff :: (Ord t) => [t] -> [t] -> [Item t]
+diff xsl ysl = F.toList $ go (S.fromList xsl) (S.fromList ysl) where
+ -- Handle common elements at the beginning / end.
+ go (S.viewl -> (x :< xs)) (S.viewl -> (y :< ys))
+ | x == y = Both x y <| go xs ys
+ go (S.viewr -> (xs :> x)) (S.viewr -> (ys :> y))
+ | x == y = go xs ys |> Both x y
+ -- Find an increasing sequence of matching unique lines, then
+ -- subdivide at those points and recurse.
+ go xs ys = case chop xs ys $ solveLCS (number xs) (number ys) of
+ -- If we fail to subdivide, just record the chunk as is.
+ [Diff _ _] -> fmap Old xs >< fmap New ys
+ ps -> recur ps
+ -- Apply the algorithm recursively to a decomposed problem.
+ -- The decomposition list is in reversed order.
+ recur  = S.empty
+ recur (Match x y : ps) = recur ps |> Both x y
+ recur (Diff xs ys : ps) = recur ps >< go xs ys
+-- | The character @\'-\'@ or @\'+\'@ or @\' \'@ for 'Old' or 'New' or 'Both' respectively.
+itemChar :: Item t -> Char
+itemChar (Old _ ) = '-'
+itemChar (New _ ) = '+'
+itemChar (Both _ _) = ' '
+-- | The value from an 'Item'. For 'Both', returns the \"old\" value.
+itemValue :: Item t -> t
+itemValue (Old x ) = x
+itemValue (New x ) = x
+itemValue (Both x _) = x