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.
editDistance :: Eq a => [a] -> [a] -> Int
editDistance :: [a] -> [a] -> Int
editDistance a :: [a]
a b :: [a]
b = [Int] -> Int
forall a. [a] -> a
last ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
  case () of
    _ | Int
lab Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
     -> [Int]
mainDiag
      | Int
lab Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
     -> [[Int]]
lowers [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! (Int
lab Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
      | Bool
otherwise
     -> [[Int]]
uppers [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! (-1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lab)
  where
    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) (-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
    eachDiag :: [a] -> [a] -> [[a]] -> [[a]]
eachDiag _ [] _ = []
    eachDiag _ _ [] = []
    eachDiag a' :: [a]
a' (_:bs :: [a]
bs) (lastDiag :: [a]
lastDiag:diags :: [[a]]
diags) =
      [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
      where
        nextDiag :: [a]
nextDiag = [[a]] -> [a]
forall a. [a] -> a
head ([[a]] -> [[a]]
forall a. [a] -> [a]
tail [[a]]
diags)
    oneDiag :: [a] -> [a] -> [a] -> [a] -> [a]
oneDiag a' :: [a]
a' b' :: [a]
b' diagAbove :: [a]
diagAbove diagBelow :: [a]
diagBelow = [a]
thisdiag
      where
        doDiag :: [a] -> [a] -> a -> [a] -> [a] -> [a]
doDiag [] _ _ _ _ = []
        doDiag _ [] _ _ _ = []
        -- 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 (ach :: a
ach:ach' :: a
ach':as :: [a]
as) (bch :: a
bch:bch' :: a
bch':bs :: [a]
bs) nw :: a
nw n :: [a]
n w :: [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 (ach :: a
ach:as :: [a]
as) (bch :: a
bch:bs :: [a]
bs) nw :: a
nw n :: [a]
n w :: [a]
w =
          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)
          where
            me :: a
me =
              if a
ach a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
bch
                then a
nw
                else 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)
        firstelt :: a
firstelt = 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)
    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 x :: a
x y :: a
y z :: 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