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