1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
-- | Description: Calculate differences between vectors.
--
-- This module implements a variation on the
-- <http://en.wikipedia.org/wiki/Wagner–Fischer_algorithm Wagner-Fischer>
-- algorithm to find the shortest sequences of operations which transforms
-- one vector of values into another.
module Data.Vector.Distance (
-- * Types
Params(..),
ChangeMatrix(..),
-- * Operations
leastChanges,
allChanges,
-- * Example
strParams,
) where
import Control.Applicative
import Control.Arrow ((***))
import Data.Function
import Data.List hiding (delete, insert)
import Data.Maybe
import Data.Monoid
import Data.Vector (Vector)
import qualified Data.Vector as V
-- | Operations invoked by the Wagner-Fischer algorithm.
--
-- The parameters to this type are as follows:
--
-- * 'v' is the type of values being compared,
-- * 'o' is the type representing operations,
-- * 'c' is the type representing costs.
--
-- The chief restrictions on these type parameters is that the cost type 'c'
-- must have instances of 'Monoid' and 'Ord'. A good default choice might be
-- the type @('Sum' 'Int')@.
data Params v o c = Params
{ equivalent :: v -> v -> Bool
-- ^ Are two values equivalent?
, delete :: Int -> v -> o
-- ^ Delete the element at an index.
, insert :: Int -> v -> o
-- ^ Insert an element at an index.
, substitute :: Int -> v -> v -> o
-- ^ Substitute an element at an index.
, cost :: o -> c
-- ^ Cost of a change.
, positionOffset :: o -> Int
-- ^ Positions to advance after a change. E.g. @0@ for a deletion.
}
-- | Matrix of optimal edit scripts and costs for all prefixes of two vectors.
--
-- This is a representation of the @n * m@ dynamic programming matrix
-- constructed by the algorithm. The matrix is stored in a 'Vector' in
-- row-major format with an additional row and column corresponding to the
-- empty prefix of the source and destination 'Vectors'.
type ChangeMatrix o c = Vector (c, [o])
-- | /O(nm)./ Find the cost and optimal edit script to transform one 'Vector'
-- into another.
leastChanges
:: (Monoid c, Ord c)
=> Params v o c
-> Vector v -- ^ \"Source\" vector.
-> Vector v -- ^ \"Destination" vector.
-> (c, [o])
leastChanges p ss tt = fmap (catMaybes . reverse) . V.last $ rawChanges p ss tt
-- | /O(nm)./ Calculate the complete matrix of edit scripts and costs between
-- two vectors.
allChanges
:: (Monoid c, Ord c)
=> Params v o c
-> Vector v -- ^ \"Source\" vector.
-> Vector v -- ^ \"Destination" vector.
-> ChangeMatrix o c
allChanges p src dst = V.map (fmap (catMaybes . reverse)) $ rawChanges p src dst
-- | /O(nm)./ Calculate the complete matrix of edit scripts and costs between
-- two vectors.
--
-- This is a fairly direct implementation of Wagner-Fischer algorithm using
-- the 'Vector' data-type. The 'ChangeMatrix' is constructed in a single-pass.
--
-- Note: The change matrix is \"raw\" in that the edit script in each cell is
-- in reverse order and uses 'Maybe' to allow for steps at which no change is
-- necessary.
rawChanges
:: (Monoid c, Ord c)
=> Params v o c
-> Vector v -- ^ \"Source\" vector.
-> Vector v -- ^ \"Destination" vector.
-> Vector (c, [Maybe o])
rawChanges p@Params{..} src dst =
let len_x = 1 + V.length dst
len_y = 1 + V.length src
len_n = len_x * len_y
ix x y = (x * len_y) + y
-- Get a cell from the 'ChangeMatrix'. It is an error to get a cell
-- which hasn't been calculated yet!
get :: Vector (c, [Maybe o]) -> Int -> Int -> (c, [Maybe o])
get m x y = fromMaybe (error $ "Unable to get " <> show (x,y) <> " from change matrix") (m V.!? (ix x y))
-- Calculate the position to be updated by the next edit in a script.
position = sum . fmap (maybe 1 positionOffset)
-- Given a partially complete 'ChangeMatrix', compute the next cell.
ctr v = case V.length v `quotRem` len_y of
-- Do nothing for "" ~> ""
( 0, 0) -> (mempty, mempty)
-- Delete everything in src for "..." ~> ""
( 0, pred -> y) ->
let o = delete 0 (src V.! y)
(pc, po) = get v 0 y
in (cost o <> pc, Just o : po)
-- Insert everything in dst for "" ~> "..."
(pred -> x, 0) ->
let o = insert x (fromMaybe (error "NAH") $ dst V.!? x)
(pc, po) = get v x 0
in (cost o <> pc, Just o : po)
-- Compare options between src and dst for "..." ~> "..."
(pred -> x, pred -> y) ->
let s = src V.! y
d = dst V.! x
tl = get v (x) (y)
top = get v (x+1) (y)
left = get v (x) (y+1)
in if s `equivalent` d
then (Nothing:) <$> get v x y
else minimumBy (compare `on` fst)
-- Option 1: perform a deletion.
[ let c = delete (position . snd $ top) s
in (cost c <>) *** (Just c :) $ top
-- Option 2: perform an insertion.
, let c = insert (position . snd $ left) d
in (cost c <>) *** (Just c :) $ left
-- Option 3: perform a substitution.
, let c = substitute (position . snd $ tl) s d
in (cost c <>) *** (Just c :) $ tl
]
in V.constructN len_n ctr
-- | Example 'Params' to compare @('Vector' 'Char')@ values.
--
-- The algorithm will produce edit distances in terms of @('Sum' 'Int')@ and
-- edit scripts containing @(String, Int, Char)@ values.
--
-- The first component of each operation is either @"delete"@, @"insert"@, or
-- @"replace"@.
strParams :: Params Char (String, Int, Char) (Sum Int)
strParams = Params{..}
where
equivalent = (==)
delete i c = ("delete", i, c)
insert i c = ("insert", i, c)
substitute i c c' = ("replace", i, c')
cost _ = Sum 1
positionOffset ("delete", _, _) = 0
positionOffset _ = 1
|
