module Options.Applicative.Help.Levenshtein (
    editDistance
  ) where

-- | Calculate the Damerau-Levenshtein edit distance
--   between two lists (strings).
--
--   This is modified from
--   https://wiki.haskell.org/Edit_distance
--   and is originally from Lloyd Allison's paper
--   "Lazy Dynamic-Programming can be Eager"
--
--   It's been changed though from Levenshtein to
--   Damerau-Levenshtein, which treats transposition
--   of adjacent characters as one change instead of
--   two.
--
--   Complexity
--     O(|a|*(1 + editDistance a b))
editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: [a] -> [a] -> Int
editDistance [a]
a [a]
b =
  let
    mainDiag :: [Int]
mainDiag =
      [a] -> [a] -> [Int] -> [Int] -> [Int]
forall a a. (Num a, Ord a, Eq a) => [a] -> [a] -> [a] -> [a] -> [a]
oneDiag [a]
a [a]
b ([[Int]] -> [Int]
forall a. [a] -> a
head [[Int]]
uppers) (-Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [[Int]] -> [Int]
forall a. [a] -> a
head [[Int]]
lowers)
    uppers :: [[Int]]
uppers =
      [a] -> [a] -> [[Int]] -> [[Int]]
forall a a. (Num a, Ord a, Eq a) => [a] -> [a] -> [[a]] -> [[a]]
eachDiag [a]
a [a]
b ([Int]
mainDiag [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
uppers) -- upper diagonals
    lowers :: [[Int]]
lowers =
      [a] -> [a] -> [[Int]] -> [[Int]]
forall a a. (Num a, Ord a, Eq a) => [a] -> [a] -> [[a]] -> [[a]]
eachDiag [a]
b [a]
a ([Int]
mainDiag [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
lowers) -- lower diagonals

    oneDiag :: [a] -> [a] -> [a] -> [a] -> [a]
oneDiag [a]
a' [a]
b' [a]
diagAbove [a]
diagBelow = [a]
thisdiag
      where
        doDiag :: [a] -> [a] -> a -> [a] -> [a] -> [a]
doDiag [] [a]
_ a
_ [a]
_ [a]
_ = []
        doDiag [a]
_ [] a
_ [a]
_ [a]
_ = []
        -- Check for a transposition
        -- We don't add anything to nw here, the next character
        -- will be different however and the transposition
        -- will have an edit distance of 1.
        doDiag (a
ach:a
ach':[a]
as) (a
bch:a
bch':[a]
bs) a
nw [a]
n [a]
w
          | a
ach' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bch Bool -> Bool -> Bool
&& a
ach a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bch'
          = a
nw a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> a -> [a] -> [a] -> [a]
doDiag (a
ach' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as) (a
bch' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs) a
nw ([a] -> [a]
forall a. [a] -> [a]
tail [a]
n) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
w)
        -- Standard case
        doDiag (a
ach:[a]
as) (a
bch:[a]
bs) a
nw [a]
n [a]
w =
          let
            me :: a
me =
              if a
ach a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bch then
                a
nw
              else
                a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
min3 ([a] -> a
forall a. [a] -> a
head [a]
w) a
nw ([a] -> a
forall a. [a] -> a
head [a]
n)
          in
            a
me a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> a -> [a] -> [a] -> [a]
doDiag [a]
as [a]
bs a
me ([a] -> [a]
forall a. [a] -> [a]
tail [a]
n) ([a] -> [a]
forall a. [a] -> [a]
tail [a]
w)

        firstelt :: a
firstelt = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ [a] -> a
forall a. [a] -> a
head [a]
diagBelow
        thisdiag :: [a]
thisdiag = a
firstelt a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> a -> [a] -> [a] -> [a]
forall a a.
(Num a, Ord a, Eq a) =>
[a] -> [a] -> a -> [a] -> [a] -> [a]
doDiag [a]
a' [a]
b' a
firstelt [a]
diagAbove ([a] -> [a]
forall a. [a] -> [a]
tail [a]
diagBelow)

    eachDiag :: [a] -> [a] -> [[a]] -> [[a]]
eachDiag [a]
_ [] [[a]]
_ = []
    eachDiag [a]
_ [a]
_ [] = []
    eachDiag [a]
a' (a
_:[a]
bs) ([a]
lastDiag:[[a]]
diags) =
      let
        nextDiag :: [a]
nextDiag = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [[a]]
forall a. [a] -> [a]
tail [[a]]
diags)
      in
        [a] -> [a] -> [a] -> [a] -> [a]
forall a a. (Num a, Ord a, Eq a) => [a] -> [a] -> [a] -> [a] -> [a]
oneDiag [a]
a' [a]
bs [a]
nextDiag [a]
lastDiag [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [[a]] -> [[a]]
eachDiag [a]
a' [a]
bs [[a]]
diags

    lab :: Int
lab =
      [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
b

    min3 :: a -> a -> a -> a
min3 a
x a
y a
z =
      if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y then
        a
x
      else
        a -> a -> a
forall a. Ord a => a -> a -> a
min a
y a
z

  in
    [Int] -> Int
forall a. [a] -> a
last ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
      if Int
lab Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
        [Int]
mainDiag
      else if Int
lab Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
        [[Int]]
lowers [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! (Int
lab Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      else
        [[Int]]
uppers [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! (-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lab)