-- memoized version of edit distance
-- by Taylor Campbell, 3/2008

module EditDistanceSM where

import SimpleMemo
import Monad
import Char

memoEditDistance :: Integral distance => String -> String -> distance
memoEditDistance string1 string2
    = (fixMemo makeEditDistanceM) (string1, string2)

slowEditDistance :: Integral distance => String -> String -> distance
slowEditDistance string1 string2
    = (fixUnmemo makeEditDistanceM) (string1, string2)

type EditDistanceFunction distance = (String, String) -> distance

makeEditDistanceM :: (Integral distance, Monad m)
                     => ((String, String) -> m distance)
                        -> ((String, String) -> m distance)
makeEditDistanceM editDistanceM =
    (\ (string1, string2) ->
         -- What we really want is to fold the case, but Haskell
         -- strings lack such amenities as useful Unicode algorithms.
         editDistanceM' ((map toLower string1), (map toLower string2)))
  where
    editDistanceM' ([], string2) = return (fromIntegral (length string2))
    editDistanceM' (string1, []) = return (fromIntegral (length string1))
    editDistanceM' ((cs1 @ (c1 : cs1')), (cs2 @ (c2 : cs2')))
        = do d1 <- editDistanceM (cs1, cs2')
             let dInsert = d1 + 1
             d2 <- editDistanceM (cs1', cs2)
             let dDelete = d2 + 1
             d3 <- editDistanceM (cs1', cs2')
             let dSubstitute = if c1 == c2 then d3 else d3 + 1
             let loser = maximum [dInsert, dDelete, dSubstitute]
             d4 <-
                 case (cs1', cs2') of
                   (c1' : cs1'', c2' : cs2'')
                       | c1' == c2 && c2' == c1 ->
                           editDistanceM (cs1'', cs2'')
                       | otherwise -> return loser
                   _ -> return loser
             let dSwap = d4 + 1
             return (minimum [dInsert, dDelete, dSubstitute, dSwap])