1module Options.Applicative.Help.Levenshtein (
2    editDistance
3  ) where
4
5-- | Calculate the Damerau-Levenshtein edit distance
6--   between two lists (strings).
7--
8--   This is modified from
9--   https://wiki.haskell.org/Edit_distance
10--   and is originally from Lloyd Allison's paper
11--   "Lazy Dynamic-Programming can be Eager"
12--
13--   It's been changed though from Levenshtein to
14--   Damerau-Levenshtein, which treats transposition
15--   of adjacent characters as one change instead of
16--   two.
17--
18--   Complexity
19--     O(|a|*(1 + editDistance a b))
20editDistance :: Eq a => [a] -> [a] -> Int
21editDistance a b =
22  let
23    mainDiag =
24      oneDiag a b (head uppers) (-1 : head lowers)
25    uppers =
26      eachDiag a b (mainDiag : uppers) -- upper diagonals
27    lowers =
28      eachDiag b a (mainDiag : lowers) -- lower diagonals
29
30    oneDiag a' b' diagAbove diagBelow = thisdiag
31      where
32        doDiag [] _ _ _ _ = []
33        doDiag _ [] _ _ _ = []
34        -- Check for a transposition
35        -- We don't add anything to nw here, the next character
36        -- will be different however and the transposition
37        -- will have an edit distance of 1.
38        doDiag (ach:ach':as) (bch:bch':bs) nw n w
39          | ach' == bch && ach == bch'
40          = nw : doDiag (ach' : as) (bch' : bs) nw (tail n) (tail w)
41        -- Standard case
42        doDiag (ach:as) (bch:bs) nw n w =
43          let
44            me =
45              if ach == bch then
46                nw
47              else
48                1 + min3 (head w) nw (head n)
49          in
50            me : doDiag as bs me (tail n) (tail w)
51
52        firstelt = 1 + head diagBelow
53        thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)
54
55    eachDiag _ [] _ = []
56    eachDiag _ _ [] = []
57    eachDiag a' (_:bs) (lastDiag:diags) =
58      let
59        nextDiag = head (tail diags)
60      in
61        oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags
62
63    lab =
64      length a - length b
65
66    min3 x y z =
67      if x < y then
68        x
69      else
70        min y z
71
72  in
73    last $
74      if lab == 0 then
75        mainDiag
76      else if lab > 0 then
77        lowers !! (lab - 1)
78      else
79        uppers !! (-1 - lab)
80