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. 17editDistance :: Eq a => [a] -> [a] -> Int 18editDistance a b = last $ 19 case () of 20 _ | lab == 0 21 -> mainDiag 22 | lab > 0 23 -> lowers !! (lab - 1) 24 | otherwise 25 -> uppers !! (-1 - lab) 26 where 27 mainDiag = oneDiag a b (head uppers) (-1 : head lowers) 28 uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals 29 lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals 30 eachDiag _ [] _ = [] 31 eachDiag _ _ [] = [] 32 eachDiag a' (_:bs) (lastDiag:diags) = 33 oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags 34 where 35 nextDiag = head (tail diags) 36 oneDiag a' b' diagAbove diagBelow = thisdiag 37 where 38 doDiag [] _ _ _ _ = [] 39 doDiag _ [] _ _ _ = [] 40 -- Check for a transposition 41 -- We don't add anything to nw here, the next character 42 -- will be different however and the transposition 43 -- will have an edit distance of 1. 44 doDiag (ach:ach':as) (bch:bch':bs) nw n w 45 | ach' == bch && ach == bch' 46 = nw : doDiag (ach' : as) (bch' : bs) nw (tail n) (tail w) 47 -- Standard case 48 doDiag (ach:as) (bch:bs) nw n w = 49 me : doDiag as bs me (tail n) (tail w) 50 where 51 me = 52 if ach == bch 53 then nw 54 else 1 + min3 (head w) nw (head n) 55 firstelt = 1 + head diagBelow 56 thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow) 57 lab = length a - length b 58 min3 x y z = 59 if x < y 60 then x 61 else min y z 62