diff --git a/Text/EditDistance.hs b/Text/EditDistance.hs --- a/Text/EditDistance.hs +++ b/Text/EditDistance.hs @@ -17,7 +17,7 @@ -- . levenshteinDistance :: EditCosts -> String -> String -> Int levenshteinDistance costs str1 str2 - | costs == defaultEditCosts + | isDefaultEditCosts costs , not (betterNotToUseBits str1_len || betterNotToUseBits str2_len) -- The Integer implementation of the Bits algorithm is quite inefficient, but scales better = Bits.levenshteinDistanceWithLengths str1_len str2_len str1 str2 -- than the STUArrays. The Word32 implementation is always better, if it is applicable | otherwise @@ -34,7 +34,7 @@ -- is edited more than once. See also: . restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int restrictedDamerauLevenshteinDistance costs str1 str2 - | costs == defaultEditCosts + | isDefaultEditCosts costs , not (betterNotToUseBits str1_len || betterNotToUseBits str2_len) -- The Integer implementation of the Bits algorithm is quite inefficient, but scales better = Bits.restrictedDamerauLevenshteinDistanceWithLengths str1_len str2_len str1 str2 -- than the STUArrays. The Word32 implementation is always better, if it is applicable | otherwise diff --git a/Text/EditDistance/EditCosts.hs b/Text/EditDistance/EditCosts.hs --- a/Text/EditDistance/EditCosts.hs +++ b/Text/EditDistance/EditCosts.hs @@ -1,20 +1,50 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} -module Text.EditDistance.EditCosts where +module Text.EditDistance.EditCosts ( + Costs(..), + EditCosts(..), deletionCost, insertionCost, substitutionCost, transpositionCost, + defaultEditCosts, isDefaultEditCosts + ) where +data Costs a = ConstantCost !Int + | VariableCost (a -> Int) + +{-# INLINE cost #-} +cost :: Costs a -> a -> Int +cost (ConstantCost i) _ = i +cost (VariableCost f) x = f x + data EditCosts = EditCosts { - deletionCost :: !Int, - insertionCost :: !Int, - substitutionCost :: !Int, - transpositionCost :: !Int + deletionCosts :: Costs Char, + insertionCosts :: Costs Char, + substitutionCosts :: Costs (Char, Char), + transpositionCosts :: Costs (Char, Char) } - deriving (Eq) +{-# INLINE deletionCost #-} +deletionCost :: EditCosts -> Char -> Int +deletionCost ec deleted = cost (deletionCosts ec) deleted +{-# INLINE insertionCost #-} +insertionCost :: EditCosts -> Char -> Int +insertionCost ec inserted = cost (insertionCosts ec) inserted + +{-# INLINE substitutionCost #-} +substitutionCost :: EditCosts -> Char -> Char -> Int +substitutionCost ec old new = cost (substitutionCosts ec) (old, new) + +{-# INLINE transpositionCost #-} +transpositionCost :: EditCosts -> Char -> Char -> Int +transpositionCost ec backwards forwards = cost (transpositionCosts ec) (backwards, forwards) + defaultEditCosts :: EditCosts defaultEditCosts = EditCosts { - deletionCost = 1, - insertionCost = 1, - substitutionCost = 1, - transpositionCost = 1 + deletionCosts = ConstantCost 1, + insertionCosts = ConstantCost 1, + substitutionCosts = ConstantCost 1, + transpositionCosts = ConstantCost 1 } + +isDefaultEditCosts :: EditCosts -> Bool +isDefaultEditCosts (EditCosts { deletionCosts = ConstantCost 1, insertionCosts = ConstantCost 1, substitutionCosts = ConstantCost 1, transpositionCosts = ConstantCost 1 }) = True +isDefaultEditCosts _ = False diff --git a/Text/EditDistance/MonadUtilities.hs b/Text/EditDistance/MonadUtilities.hs --- a/Text/EditDistance/MonadUtilities.hs +++ b/Text/EditDistance/MonadUtilities.hs @@ -3,7 +3,7 @@ module Text.EditDistance.MonadUtilities where {-# INLINE loopM_ #-} -loopM_ :: Monad m => Int -> Int -> (Int -> m a) -> m () +loopM_ :: Monad m => Int -> Int -> (Int -> m ()) -> m () loopM_ !from !to action | from > to = return () | otherwise = do diff --git a/Text/EditDistance/STUArray.hs b/Text/EditDistance/STUArray.hs --- a/Text/EditDistance/STUArray.hs +++ b/Text/EditDistance/STUArray.hs @@ -10,7 +10,6 @@ import Control.Monad import Control.Monad.ST import Data.Array.ST -import Data.Array.MArray levenshteinDistance :: EditCosts -> String -> String -> Int @@ -35,26 +34,26 @@ cost_row' <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int) -- Fill out the first row (j = 0) - loopM_ 1 str1_len $ \i -> writeArray cost_row i (deletionCost costs * i) + _ <- (\f -> foldM f 0 ([1..] `zip` str1)) $ \deletion_cost (i, col_char) -> let deletion_cost' = deletion_cost + deletionCost costs col_char in writeArray cost_row i deletion_cost' >> return deletion_cost' -- Fill out the remaining rows (j >= 1) - (final_row, _) <- foldM (levenshteinDistanceSTRowWorker costs str1_len str1_array str2_array) (cost_row, cost_row') [1..str2_len] + (_, final_row, _) <- foldM (levenshteinDistanceSTRowWorker costs str1_len str1_array str2_array) (0, cost_row, cost_row') [1..str2_len] -- Return an actual answer readArray final_row str1_len -levenshteinDistanceSTRowWorker :: EditCosts -> Int -> STUArray s Int Char -> STUArray s Int Char -> (STUArray s Int Int, STUArray s Int Int) -> Int -> ST s (STUArray s Int Int, STUArray s Int Int) -levenshteinDistanceSTRowWorker !costs !str1_len !str1_array !str2_array (!cost_row, !cost_row') !j = do +levenshteinDistanceSTRowWorker :: EditCosts -> Int -> STUArray s Int Char -> STUArray s Int Char -> (Int, STUArray s Int Int, STUArray s Int Int) -> Int -> ST s (Int, STUArray s Int Int, STUArray s Int Int) +levenshteinDistanceSTRowWorker !costs !str1_len !str1_array !str2_array (!insertion_cost, !cost_row, !cost_row') !j = do row_char <- readArray str2_array j -- Initialize the first element of the row (i = 0) - let here = insertionCost costs * j - writeArray cost_row' 0 here + let insertion_cost' = insertion_cost + insertionCost costs row_char + writeArray cost_row' 0 insertion_cost' -- Fill the remaining elements of the row (i >= 1) loopM_ 1 str1_len (colWorker row_char) - return (cost_row', cost_row) + return (insertion_cost', cost_row', cost_row) where colWorker row_char !i = do col_char <- readArray str1_array i @@ -87,7 +86,7 @@ cost_row <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int) -- Fill out the first row (j = 0) - loopM_ 1 str1_len $ \i -> writeArray cost_row i (deletionCost costs * i) + _ <- (\f -> foldM f 0 ([1..] `zip` str1)) $ \deletion_cost (!i, col_char) -> let deletion_cost' = deletion_cost + deletionCost costs col_char in writeArray cost_row i deletion_cost' >> return deletion_cost' if (str2_len == 0) then readArray cost_row str1_len @@ -100,14 +99,14 @@ row_char <- readArray str2_array 1 -- Initialize the first element of the row (i = 0) - let zero = insertionCost costs + let zero = insertionCost costs row_char writeArray cost_row' 0 zero -- Fill the remaining elements of the row (i >= 1) loopM_ 1 str1_len (firstRowColWorker str1_array row_char cost_row cost_row') -- Fill out the remaining rows (j >= 2) - (_, final_row, _, _) <- foldM (restrictedDamerauLevenshteinDistanceSTRowWorker costs str1_len str1_array str2_array) (cost_row, cost_row', cost_row'', row_char) [2..str2_len] + (_, _, final_row, _, _) <- foldM (restrictedDamerauLevenshteinDistanceSTRowWorker costs str1_len str1_array str2_array) (zero, cost_row, cost_row', cost_row'', row_char) [2..str2_len] -- Return an actual answer readArray final_row str1_len @@ -123,27 +122,27 @@ restrictedDamerauLevenshteinDistanceSTRowWorker :: EditCosts -> Int -> STUArray s Int Char -> STUArray s Int Char -- String arrays - -> (STUArray s Int Int, STUArray s Int Int, STUArray s Int Int, Char) -> Int -- Incoming rows of the matrix in recency order - -> ST s (STUArray s Int Int, STUArray s Int Int, STUArray s Int Int, Char) -- Outgoing rows of the matrix in recency order -restrictedDamerauLevenshteinDistanceSTRowWorker !costs !str1_len !str1_array !str2_array (!cost_row, !cost_row', !cost_row'', !prev_row_char) !j = do + -> (Int, STUArray s Int Int, STUArray s Int Int, STUArray s Int Int, Char) -> Int -- Incoming rows of the matrix in recency order + -> ST s (Int, STUArray s Int Int, STUArray s Int Int, STUArray s Int Int, Char) -- Outgoing rows of the matrix in recency order +restrictedDamerauLevenshteinDistanceSTRowWorker !costs !str1_len !str1_array !str2_array (!insertion_cost, !cost_row, !cost_row', !cost_row'', !prev_row_char) !j = do row_char <- readArray str2_array j -- Initialize the first element of the row (i = 0) zero_up <- readArray cost_row' 0 - let zero = insertionCost costs * j - writeArray cost_row'' 0 zero + let insertion_cost' = insertion_cost + insertionCost costs row_char + writeArray cost_row'' 0 insertion_cost' -- Initialize the second element of the row (i = 1) when (str1_len > 0) $ do col_char <- readArray str1_array 1 one_up <- readArray cost_row' 1 - let one = standardCosts costs row_char col_char zero zero_up one_up + let one = standardCosts costs row_char col_char insertion_cost' zero_up one_up writeArray cost_row'' 1 one -- Fill the remaining elements of the row (i >= 2) loopM_ 2 str1_len (colWorker row_char) - return (cost_row', cost_row'', cost_row, row_char) + return (insertion_cost', cost_row', cost_row'', cost_row, row_char) where colWorker !row_char !i = do prev_col_char <- readArray str1_array (i - 1) @@ -155,7 +154,7 @@ here_up <- readArray cost_row' i let here_standard_only = standardCosts costs row_char col_char left left_up here_up here = if prev_row_char == col_char && prev_col_char == row_char - then here_standard_only `min` (left_left_up_up + (transpositionCost costs)) + then here_standard_only `min` (left_left_up_up + transpositionCost costs col_char row_char) else here_standard_only writeArray cost_row'' i here @@ -165,9 +164,9 @@ standardCosts :: EditCosts -> Char -> Char -> Int -> Int -> Int -> Int standardCosts !costs !row_char !col_char !cost_left !cost_left_up !cost_up = deletion_cost `min` insertion_cost `min` subst_cost where - deletion_cost = cost_left + deletionCost costs - insertion_cost = cost_up + insertionCost costs - subst_cost = cost_left_up + if row_char == col_char then 0 else substitutionCost costs + deletion_cost = cost_left + deletionCost costs col_char + insertion_cost = cost_up + insertionCost costs row_char + subst_cost = cost_left_up + if row_char == col_char then 0 else substitutionCost costs col_char row_char {-# INLINE stringToArray #-} stringToArray :: String -> Int -> ST s (STUArray s Int Char) diff --git a/Text/EditDistance/SquareSTUArray.hs b/Text/EditDistance/SquareSTUArray.hs --- a/Text/EditDistance/SquareSTUArray.hs +++ b/Text/EditDistance/SquareSTUArray.hs @@ -10,7 +10,6 @@ import Control.Monad import Control.Monad.ST import Data.Array.ST -import Data.Array.MArray levenshteinDistance :: EditCosts -> String -> String -> Int @@ -33,21 +32,24 @@ cost_array <- newArray_ ((0, 0), (str1_len, str2_len)) :: ST s (STUArray s (Int, Int) Int) -- Fill out the first row (j = 0) - loopM_ 1 str1_len $ \(!i) -> writeArray cost_array (i, 0) (deletionCost costs * i) + _ <- (\f -> foldM f 0 ([1..] `zip` str1)) $ \deletion_cost (!i, col_char) -> let deletion_cost' = deletion_cost + deletionCost costs col_char in writeArray cost_array (i, 0) deletion_cost' >> return deletion_cost' -- Fill the remaining rows (j >= 1) - loopM_ 1 str2_len (\(!j) -> do + _ <- (\f -> foldM f 0 [1..str2_len]) $ \insertion_cost (!j) -> do row_char <- readArray str2_array j -- Initialize the first element of the row (i = 0) - writeArray cost_array (0, j) (insertionCost costs * j) + let insertion_cost' = insertion_cost + insertionCost costs row_char + writeArray cost_array (0, j) insertion_cost' -- Fill the remaining elements of the row (i >= 1) - loopM_ 1 str1_len (\(!i) -> do + loopM_ 1 str1_len $ \(!i) -> do col_char <- readArray str1_array i cost <- standardCosts costs cost_array row_char col_char (i, j) - writeArray cost_array (i, j) cost)) + writeArray cost_array (i, j) cost + + return insertion_cost' -- Return an actual answer readArray cost_array (str1_len, str2_len) @@ -73,14 +75,14 @@ cost_array <- newArray_ ((0, 0), (str1_len, str2_len)) :: ST s (STUArray s (Int, Int) Int) -- Fill out the first row (j = 0) - loopM_ 1 str1_len $ \(!i) -> writeArray cost_array (i, 0) (deletionCost costs * i) + _ <- (\f -> foldM f 0 ([1..] `zip` str1)) $ \deletion_cost (!i, col_char) -> let deletion_cost' = deletion_cost + deletionCost costs col_char in writeArray cost_array (i, 0) deletion_cost' >> return deletion_cost' -- Fill out the second row (j = 1) when (str2_len > 0) $ do initial_row_char <- readArray str2_array 1 -- Initialize the first element of the second row (i = 0) - writeArray cost_array (0, 1) (insertionCost costs) + writeArray cost_array (0, 1) (insertionCost costs initial_row_char) -- Initialize the remaining elements of the row (i >= 1) loopM_ 1 str1_len $ \(!i) -> do @@ -95,7 +97,7 @@ prev_row_char <- readArray str2_array (j - 1) -- Initialize the first element of the row (i = 0) - writeArray cost_array (0, j) (insertionCost costs * j) + writeArray cost_array (0, j) (insertionCost costs row_char * j) -- Initialize the second element of the row (i = 1) when (str1_len > 0) $ do @@ -111,7 +113,7 @@ standard_cost <- standardCosts costs cost_array row_char col_char (i, j) cost <- if prev_row_char == col_char && prev_col_char == row_char - then do transpose_cost <- fmap (+ (transpositionCost costs)) $ readArray cost_array (i - 2, j - 2) + then do transpose_cost <- fmap (+ (transpositionCost costs col_char row_char)) $ readArray cost_array (i - 2, j - 2) return (standard_cost `min` transpose_cost) else return standard_cost writeArray cost_array (i, j) cost)) @@ -123,9 +125,12 @@ {-# INLINE standardCosts #-} standardCosts :: EditCosts -> STUArray s (Int, Int) Int -> Char -> Char -> (Int, Int) -> ST s Int standardCosts !costs !cost_array !row_char !col_char (!i, !j) = do - deletion_cost <- fmap (+ (deletionCost costs)) $ readArray cost_array (i - 1, j) - insertion_cost <- fmap (+ (insertionCost costs)) $ readArray cost_array (i, j - 1) - subst_cost <- fmap (+ if row_char == col_char then 0 else substitutionCost costs) $ readArray cost_array (i - 1, j - 1) + deletion_cost <- fmap (+ (deletionCost costs col_char)) $ readArray cost_array (i - 1, j) + insertion_cost <- fmap (+ (insertionCost costs row_char)) $ readArray cost_array (i, j - 1) + subst_cost <- fmap (+ if row_char == col_char + then 0 + else (substitutionCost costs col_char row_char)) + (readArray cost_array (i - 1, j - 1)) return $ deletion_cost `min` insertion_cost `min` subst_cost {-# INLINE stringToArray #-} diff --git a/edit-distance.cabal b/edit-distance.cabal --- a/edit-distance.cabal +++ b/edit-distance.cabal @@ -1,5 +1,5 @@ Name: edit-distance -Version: 0.1.2 +Version: 0.2.0 Cabal-Version: >= 1.2 Category: Algorithms Synopsis: Levenshtein and restricted Damerau-Levenshtein edit distances @@ -38,19 +38,19 @@ else Build-Depends: base < 3 - Ghc-Options: -O2 -fvia-C -Wall + Ghc-Options: -O2 Executable edit-distance-tests Main-Is: Text/EditDistance/Tests.hs Extensions: PatternGuards, PatternSignatures, ScopedTypeVariables - Ghc-Options: -O2 -fvia-C -Wall -fno-warn-orphans + Ghc-Options: -O2 if !flag(tests) Buildable: False else - Build-Depends: test-framework >= 0.1.1, QuickCheck >= 1.1, test-framework-quickcheck + Build-Depends: test-framework >= 0.1.1, QuickCheck >= 1.1 && < 2.0, test-framework-quickcheck if flag(splitBase) Build-Depends: base >= 3 && < 5, array >= 0.1, random >= 1.0 else @@ -69,4 +69,4 @@ Build-Depends: base < 3, parallel >= 1.0, unix >= 2.3 - Ghc-Options: -O2 -fvia-C -Wall + Ghc-Options: -O2