patience 0.1.1 → 0.2.0.0

raw patch · 6 files changed

+205/−218 lines, 6 filesdep ~basedep ~containersnew-uploader

Dependency ranges changed: base, containers

Files

CHANGELOG.md +4/−0
Data/Algorithm/Patience.hs +0/−154
README.md +15/−0
patience.cabal +31/−19
src/Patience.hs +155/−0
test/test.hs +0/−45

+ CHANGELOG.md view

@@ -0,0 +1,4 @@+# Changes in version 0.2.0.0+  * Move `Data.Algorithm.Patience` to `Patience`+  * Remove use of deprecated `Data.Map.insertWith'`+  * Add strictness/UNPACK annotations to `Int` values

− Data/Algorithm/Patience.hs

@@ -1,154 +0,0 @@-{-# LANGUAGE-    DeriveDataTypeable-  , ViewPatterns-  , CPP #-}--- | 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:--- <http://en.wikipedia.org/wiki/Patience_sorting>.--- 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)-#if MIN_VERSION_containers(0,3,0)-zipLS = S.zip . S.fromList-#else-zipLS xs = S.fromList . zip xs . F.toList-#endif---- 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

+ README.md view

@@ -0,0 +1,15 @@+[![Hackage](https://img.shields.io/hackage/v/patience.svg)](https://hackage.haskell.org/package/patience)++# patience++## About+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 these two blog posts: [alfedenzo](http://alfedenzo.livejournal.com/170301.html), [bramcohen](http://bramcohen.livejournal.com/73318.html)++## Install++Install with `cabal (new-)install patience`.

patience.cabal view

@@ -1,13 +1,14 @@-name:                patience-version:             0.1.1-license:             BSD3-license-file:        LICENSE-synopsis:            Patience diff and longest increasing subsequence-category:            Algorithms, Text-author:              Keegan McAllister <mcallister.keegan@gmail.com>-maintainer:          Keegan McAllister <mcallister.keegan@gmail.com>-build-type:          Simple-cabal-version:       >=1.2+cabal-version: 2.2+name:+  patience+version:+  0.2.0.0+license:+  BSD-3-Clause+license-file:+  LICENSE+synopsis:+  Patience diff and longest increasing subsequence description:   This library implements the \"patience diff\" algorithm, as well as the patience   algorithm for the longest increasing subsequence problem.@@ -17,16 +18,27 @@   performance, nice output for humans, and implementation simplicity.  For more   information, see <http://alfedenzo.livejournal.com/170301.html> and   <http://bramcohen.livejournal.com/73318.html>.-  .-  New in version 0.1.1: relaxed @containers@ dependency, so it should build on-  GHC 6.10.-+category:+  Algorithms, Text+author:+  Keegan McAllister <mcallister.keegan@gmail.com>+maintainer:+  chessai <chessai1996@gmail.com> +build-type:+  Simple extra-source-files:-  test/test.hs+  CHANGELOG.md+  README.md  library-  exposed-modules:  Data.Algorithm.Patience-  ghc-options:      -Wall+  hs-source-dirs:+    src+  exposed-modules:+    Patience+  ghc-options:+    -Wall+  default-language:+    Haskell2010   build-depends:-      base >= 3 && < 5-    , containers >= 0.2+      base >= 4.3 && < 5+    , containers >= 0.5.9 && < 0.7

+ src/Patience.hs view

@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns       #-}++-- | Implements \"patience diff\" and the patience algorithm for the longest+--   increasing subsequence problem.+module Patience+  ( -- * Patience diff+    diff+  , Item(..), itemChar, itemValue+    -- * Longest increasing subsequence+  , longestIncreasing+  ) where++import           Data.Data       (Data)+import qualified Data.Foldable   as F+import qualified Data.IntMap     as IM+import           Data.List+import qualified Data.Map        as M+import qualified Data.Map.Strict as MS+import           Data.Ord+import           Data.Sequence   ( (<|), (|>), (><), ViewL(..), ViewR(..) )+import qualified Data.Sequence   as S+import           Data.Typeable   (Typeable)++-- 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 {-# UNPACK #-} !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:+-- <http://en.wikipedia.org/wiki/Patience_sorting>.+-- 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 . F.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) = MS.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)+#if MIN_VERSION_containers(0,3,0)+zipLS = S.zip . S.fromList+#else+zipLS xs = S.fromList . zip xs . F.toList+#endif++-- 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

− test/test.hs

@@ -1,45 +0,0 @@--- 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)