diff --git a/Data/Algorithm/Patience.hs b/Data/Algorithm/Patience.hs new file mode 100644 --- /dev/null +++ b/Data/Algorithm/Patience.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE + DeriveDataTypeable + , ViewPatterns #-} +-- | Implements \"patience diff\" and the patience algorithm for the longest +-- increasing subsequence problem. +module Data.Algorithm.Patience + ( -- * Patience diff + 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.List +import Data.Ord + +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 + +-- Number the elements of a Seq. +number :: S.Seq t -> S.Seq (Int,t) +number xs = S.zip (S.fromList [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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) Keegan McAllister 2011 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/runhaskell + +import Distribution.Simple +main = defaultMain diff --git a/patience.cabal b/patience.cabal new file mode 100644 --- /dev/null +++ b/patience.cabal @@ -0,0 +1,29 @@ +name: patience +version: 0.1 +license: BSD3 +license-file: LICENSE +synopsis: Patience diff and longest increasing subsequence +category: Algorithms, Text +author: Keegan McAllister +maintainer: Keegan McAllister +build-type: Simple +cabal-version: >=1.2 +description: + This library implements the \"patience diff\" algorithm, as well as the patience + algorithm for the longest increasing subsequence problem. + . + Patience diff computes the difference between two lists, for example the + lines of two versions of a source file. It provides a good balance of + performance, nice output for humans, and implementation simplicity. For more + information, see and + . + +extra-source-files: + test/test.hs + +library + exposed-modules: Data.Algorithm.Patience + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , containers >= 0.3 diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,45 @@ +-- Simple test for Data.Algorithm.Patience +-- +-- Invoke as: ./test r n +-- for ints r, n +-- +-- Reads lines of standard input, then repeats r times: +-- - Generate two documents of n lines each, by picking +-- randomly from the stdin lines, with replacement +-- - Compute their patience diff +-- - Check that each document is recovered by keeping the +-- respective side of the diff +module Main(main) where + +import Control.Monad +import Data.Array +import Data.Maybe +import System.Environment +import System.Random + +import Data.Algorithm.Patience + +keepOld :: [Item a] -> [a] +keepOld = catMaybes . map f where + f (Old x ) = Just x + f (New _) = Nothing + f (Both x _) = Just x + +keepNew :: [Item a] -> [a] +keepNew = catMaybes . map f where + f (Old _ ) = Nothing + f (New x) = Just x + f (Both _ x) = Just x + +main :: IO () +main = do + [r,n] <- map read `fmap` getArgs + xs <- lines `fmap` getContents + let ar = listArray (0, length xs - 1) xs + pick = replicateM n ((ar !) `fmap` randomRIO (bounds ar)) + replicateM_ r $ do + da <- pick + db <- pick + let d = diff da db + good = (da == keepOld d) && (db == keepNew d) + when (not good) $ print (da, db, d)