edit-distance 0.1.2 → 0.2.0

raw patch · 6 files changed

+87/−53 lines, 6 filesdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• Text/EditDistance.hs +2/−2
• Text/EditDistance/EditCosts.hs +40/−10
• Text/EditDistance/MonadUtilities.hs +1/−1
• Text/EditDistance/STUArray.hs +21/−22
• Text/EditDistance/SquareSTUArray.hs +18/−13
• edit-distance.cabal +5/−5

@@ -17,7 +17,7 @@ -- <http://en.wikipedia.org/wiki/Levenshtein_distance>. 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: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. 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

@@ -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

@@ -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

@@ -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)

@@ -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 #-}

@@ -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