packages feed

edit-distance 0.2.1.1 → 0.2.1.2

raw patch · 9 files changed

+309/−193 lines, 9 filesdep +criteriondep +deepseqdep +timedep −old-timedep −parallelPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq, time

Dependencies removed: old-time, parallel

API changes (from Hackage documentation)

Files

README.textile view
@@ -31,7 +31,7 @@ * "Levenshtein distance":http://en.wikipedia.org/wiki/Levenshtein_distance
 * "Restricted Damerau-Levenshtein distance":http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance
 
-They have been fairly heavily optimized. Indeed, for situations where one of the strings is under 32 characters long I use a rather neat "bit vector" algorithm: see "the authors paper":http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and "the associated errata":[http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for more information. The algorithms __could__ be faster, but they aren't yet slow enough to force me into improving the situation.
+They have been fairly heavily optimized. Indeed, for situations where one of the strings is under 64 characters long I use a rather neat "bit vector" algorithm: see "the authors paper":http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and "the associated errata":[http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for more information. The algorithms __could__ be faster, but they aren't yet slow enough to force me into improving the situation.
 
 
 h2. Example
@@ -46,4 +46,4 @@ 
 * "Hackage":http://hackage.haskell.org/cgi-bin/hackage-scripts/package/edit-distance
 * "Bug Tracker":http://bsp.lighthouseapp.com/projects/14822-hs-edit-distance
-* "GitHub":http://github.com/batterseapower/edit-distance+* "GitHub":http://github.com/batterseapower/edit-distance
Text/EditDistance.hs view
@@ -8,7 +8,6 @@  import Text.EditDistance.EditCosts import qualified Text.EditDistance.Bits as Bits-import qualified Text.EditDistance.STUArray as STUArray import qualified Text.EditDistance.SquareSTUArray as SquareSTUArray  -- | Find the Levenshtein edit distance between two strings.  That is to say, the number of deletion,@@ -18,15 +17,13 @@ levenshteinDistance :: EditCosts -> String -> String -> Int levenshteinDistance costs str1 str2   | 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+  , (str1_len <= 64) == (str2_len <= 64)                             -- The Integer implementation of the Bits algorithm is quite inefficient, but scales better than the+  = Bits.levenshteinDistanceWithLengths str1_len str2_len str1 str2  -- STUArrays if both string lengths > 64. The Word64 implementation is always better, if it is applicable   | otherwise-  = STUArray.levenshteinDistanceWithLengths costs str1_len str2_len str1 str2 -- STUArray always beat making more allocations with SquareSTUArray for Levenhstein+  = SquareSTUArray.levenshteinDistanceWithLengths costs str1_len str2_len str1 str2 -- SquareSTUArray usually beat making more use of the heap with STUArray   where     str1_len = length str1     str2_len = length str2-    -    betterNotToUseBits len = len >= 33 && len <= 82 -- Upper bound determined experimentally  -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.  This algorithm calculates the cost of -- the so-called optimal string alignment, which does not always equal the appropriate edit distance. The cost of the optimal @@ -35,12 +32,10 @@ restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int restrictedDamerauLevenshteinDistance costs str1 str2   | 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+  , (str1_len <= 64) == (str2_len <= 64)                                             -- The Integer implementation of the Bits algorithm is quite inefficient, but scales better than the+  = Bits.restrictedDamerauLevenshteinDistanceWithLengths str1_len str2_len str1 str2 -- STUArrays if both string lengths > 64. The Word64 implementation is always better, if it is applicable   | otherwise-  = SquareSTUArray.restrictedDamerauLevenshteinDistanceWithLengths costs str1_len str2_len str1 str2 -- SquareSTUArray usually beat making more use of the heap with STUArray for Damerau+  = SquareSTUArray.restrictedDamerauLevenshteinDistanceWithLengths costs str1_len str2_len str1 str2 -- SquareSTUArray usually beat making more use of the heap with STUArray   where     str1_len = length str1     str2_len = length str2-    -    betterNotToUseBits len = len >= 33 && len <= 45 -- Upper bound determined experimentally
+ Text/EditDistance/ArrayUtilities.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}++module Text.EditDistance.ArrayUtilities (+    unsafeReadArray, unsafeWriteArray,+    unsafeReadArray', unsafeWriteArray',+    stringToArray+  ) where++import Control.Monad (forM_)+import Control.Monad.ST++import Data.Array.ST+import Data.Array.Base (unsafeRead, unsafeWrite, getNumElements)++#ifdef __GLASGOW_HASKELL__+import GHC.Arr (unsafeIndex)+#else+import Data.Ix (index)++{-# INLINE unsafeIndex #-}+unsafeIndex :: Ix i => (i, i) -> i -> Int+unsafeIndex = index+#endif+++{-# INLINE unsafeReadArray #-}+unsafeReadArray :: (MArray a e m, Ix i) => a i e -> i -> m e+unsafeReadArray marr i = do+    f <- unsafeReadArray' marr+    f i++{-# INLINE unsafeWriteArray #-}+unsafeWriteArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()+unsafeWriteArray marr i e = do+  f <- unsafeWriteArray' marr+  f i e+++{-# INLINE unsafeReadArray' #-}+unsafeReadArray' :: (MArray a e m, Ix i) => a i e -> m (i -> m e)+unsafeReadArray' marr = do+    (l,u) <- getBounds marr+    return $ \i -> unsafeRead marr (unsafeIndex (l,u) i)++{-# INLINE unsafeWriteArray' #-}+unsafeWriteArray' :: (MArray a e m, Ix i) => a i e -> m (i -> e -> m ())+unsafeWriteArray' marr = do+  (l,u) <- getBounds marr+  return $ \i e -> unsafeWrite marr (unsafeIndex (l,u) i) e++{-# INLINE stringToArray #-}+stringToArray :: String -> Int -> ST s (STUArray s Int Char)+stringToArray str str_len = do+    array <- newArray_ (1, str_len)+    write <- unsafeWriteArray' array+    forM_ (zip [1..] str) (uncurry write)+    return array++{-+showArray :: STUArray s (Int, Int) Int -> ST s String+showArray array = do+    ((il, jl), (iu, ju)) <- getBounds array+    flip (flip foldM "") [(i, j) | i <- [il..iu], j <- [jl.. ju]] $ \rest (i, j) -> do+        elt <- readArray array (i, j)+        return $ rest ++ show (i, j) ++ ": " ++ show elt ++ ", "+-}
Text/EditDistance/Benchmark.hs view
@@ -1,37 +1,48 @@+{-# OPTIONS_GHC -fno-full-laziness #-} module Main where  import Text.EditDistance.EditCosts+import Text.EditDistance.MonadUtilities+import qualified Text.EditDistance as BestEffort import qualified Text.EditDistance.Bits as Bits import qualified Text.EditDistance.STUArray as STUArray import qualified Text.EditDistance.SquareSTUArray as SquareSTUArray +import Criterion.Config+import Criterion.Main import System.IO import System.Exit+import System.Environment --import System.Posix.IO-import System.Time      ( ClockTime(..), getClockTime )+import Data.Time.Clock.POSIX (getPOSIXTime) import System.Random import System.Process+import System.Mem import Data.List+import Data.Monoid (mempty) import Control.Monad import Control.Exception --import Control.Concurrent       ( forkIO, threadDelay )-import Control.Parallel.Strategies      ( NFData, rnf )+import Control.DeepSeq      ( NFData, rnf )  sTRING_SIZE_STEP, mAX_STRING_SIZE :: Int sTRING_SIZE_STEP = 3 mAX_STRING_SIZE = 108 -time :: IO a -> IO Float+getTime :: IO Double+getTime = realToFrac `fmap` getPOSIXTime++time :: IO a -> IO Double time action = do -    TOD s1 ps1 <- getClockTime+    ts1 <- getTime     action-    TOD s2 ps2 <- getClockTime-    return $ (fromIntegral (s2 - s1) + (fromIntegral (ps2 - ps1) / 10^(12 :: Int)))+    ts2 <- getTime+    return $ ts2 - ts1 -augment :: Monad m => (a -> m b) -> [a] -> m [(a, b)]-augment fx xs = liftM (zip xs) $ mapM fx xs+augment :: Monad m => (a -> m b) -> [a] -> m [(a, [b])]+augment fx xs = liftM (zip xs) $ mapM (liftM (\b -> [b]) . fx) xs -sample :: NFData a => (String -> String -> a) -> (Int, Int) -> IO Float+sample :: NFData a => (String -> String -> a) -> (Int, Int) -> IO Double sample distance bounds@(i, j) = do     -- Generate two random strings of length i and j     gen <- newStdGen@@ -43,26 +54,32 @@     evaluate (rnf string1)     evaluate (rnf string2)     +    -- Don't want junk from previous runs causing a GC during the test+    performGC+     -- Our sample is the time taken to find the edit distance     putStrLn $ "Sampling " ++ show bounds-    time $ loop 1000 $ evaluate (distance string1 string2)+    time $ loop (100000 `div` (1 + i + j)) $ evaluate (distance string1 string2) >> return () -loop :: Monad m => Int -> m a -> m ()-loop n act = sequence_ (replicate n act)+loop :: Monad m => Int -> m () -> m ()+loop n act = loopM_ 1 n (const act) -joinOnKey :: Eq a => [(a, b)] -> [(a, c)] -> [(a, (b, c))]-joinOnKey xs ys = [(x_a, (x_b, y_c)) | (x_a, x_b) <- xs, (y_a, y_c) <- ys, x_a == y_a]+joinOnKey :: Eq a => [(a, [b])] -> [(a, [b])] -> [(a, [b])]+joinOnKey xs ys = [(x_a, (x_b ++ y_c)) | (x_a, x_b) <- xs, (y_a, y_c) <- ys, x_a == y_a] -gnuPlotScript :: String-gnuPlotScript = "set term postscript eps enhanced color\n\+gnuPlotScript :: [String] -> String+gnuPlotScript titles = "set term postscript eps enhanced color\n\ \set output \"data.ps\"\n\ \#unset key\n\ \set dgrid3d\n\ \set hidden3d\n\ \#set pm3d map\n\ \#splot \"data.plot\" using 1:2:3\n\-\splot \"data.plot\" using 1:2:3 title \"Bits\" with lines, \"data.plot\" using 1:2:4 title \"STUArray\" with lines, \"data.plot\" using 1:2:5 title \"SquareSTUArray\" with lines\n\+\splot " ++ splot_script ++ "\n\ \quit\n"+  where+    --splot_script = "\"data.plot\" using 1:2:3 title \"Bits\" with lines, \"data.plot\" using 1:2:4 title \"STUArray\" with lines, \"data.plot\" using 1:2:5 title \"SquareSTUArray\" with lines"+    splot_script = intercalate ", " ["\"data.plot\" using 1:2:" ++ show i ++ " title " ++ show title ++ " with lines" | (i, title) <- [3..] `zip` titles]  toGnuPlotFormat :: (Show a, Show b, Show c) => [((a, b), [c])] -> String toGnuPlotFormat samples = unlines (header : map sampleToGnuPlotFormat samples)@@ -73,19 +90,27 @@  main :: IO () main = do-    let sample_range = [(i, j) | i <- [0,sTRING_SIZE_STEP..mAX_STRING_SIZE]-                               , j <- [0,sTRING_SIZE_STEP..mAX_STRING_SIZE]]-    bits_samples  <- augment (sample $ Bits.levenshteinDistance) sample_range-    sqstu_samples <- augment (sample $ SquareSTUArray.levenshteinDistance defaultEditCosts) sample_range-    stu_samples   <- augment (sample $ STUArray.levenshteinDistance defaultEditCosts) sample_range-    let paired_samples = bits_samples `joinOnKey` (stu_samples `joinOnKey` sqstu_samples)-        listified_samples = [((i, j), [a, b, c]) | ((i, j), (a, (b, c))) <- paired_samples]-    -    writeFile "data.plot" (toGnuPlotFormat listified_samples)-    writeFile "plot.script" gnuPlotScript-    -    (_inp, _outp, _err, gp_pid) <- runInteractiveCommand "(cat plot.script | gnuplot); RETCODE=$?; rm plot.script; exit $RETCODE"-    gp_exit_code <- waitForProcess gp_pid-    case gp_exit_code of-            ExitSuccess -> putStrLn "Plotted at 'data.ps'"-            ExitFailure err_no -> putStrLn $ "Failed! Error code " ++ show err_no+    args <- getArgs+    let sample_titles = ["Bits", "SquareSTUArray", "STUArray", "Best effort"]+        sample_fns = [Bits.levenshteinDistance, SquareSTUArray.levenshteinDistance defaultEditCosts, STUArray.levenshteinDistance defaultEditCosts, BestEffort.levenshteinDistance defaultEditCosts]+    case args of+      ["plot"] -> do+        let sample_range = [(i, j) | i <- [0,sTRING_SIZE_STEP..mAX_STRING_SIZE]+                                   , j <- [0,sTRING_SIZE_STEP..mAX_STRING_SIZE]]+            --sample_fns = [Bits.restrictedDamerauLevenshteinDistance, SquareSTUArray.restrictedDamerauLevenshteinDistance defaultEditCosts, STUArray.restrictedDamerauLevenshteinDistance defaultEditCosts, BestEffort.restrictedDamerauLevenshteinDistance defaultEditCosts]+        sampless <- forM sample_fns $ \sample_fn -> augment (sample sample_fn) sample_range+        let listified_samples = foldr1 joinOnKey sampless+        +        writeFile "data.plot" (toGnuPlotFormat listified_samples)+        writeFile "plot.script" (gnuPlotScript sample_titles)+        +        (_inp, _outp, _err, gp_pid) <- runInteractiveCommand "(cat plot.script | gnuplot); RETCODE=$?; rm plot.script; exit $RETCODE"+        gp_exit_code <- waitForProcess gp_pid+        case gp_exit_code of+                ExitSuccess -> putStrLn "Plotted at 'data.ps'"+                ExitFailure err_no -> putStrLn $ "Failed! Error code " ++ show err_no    +      _ -> do+        let mkBench n m name f = bench name $ whnf (uncurry f) (replicate n 'a', replicate m 'b')+            cfg = mempty { cfgSamples = ljust 500 }+        defaultMainWith cfg (return ()) [bgroup (show (n, m)) (zipWith (mkBench n m) sample_titles sample_fns)+                                        | (n, m) <- [(32, 32), (32, mAX_STRING_SIZE), (mAX_STRING_SIZE, 32), (mAX_STRING_SIZE, mAX_STRING_SIZE)]]
Text/EditDistance/Bits.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, PatternSignatures, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE PatternGuards, PatternSignatures, ScopedTypeVariables, BangPatterns, Rank2Types #-}  module Text.EditDistance.Bits (         levenshteinDistance, levenshteinDistanceWithLengths, {-levenshteinDistanceCutoff,-} restrictedDamerauLevenshteinDistance, restrictedDamerauLevenshteinDistanceWithLengths@@ -14,6 +14,24 @@  --type BitVector = Integer +-- Continuation-passing foldl's to work around the lack of recursive CPR optimisation in GHC++{-# INLINE foldl'3k #-}+foldl'3k :: (forall res. (a, b, c) -> x -> ((a, b, c) -> res) -> res)+         -> (a, b, c) -> [x] -> (a, b, c)+foldl'3k f = go+  where go (!a, !b, !c) _      | False = undefined+        go ( a,  b,  c) []     = (a, b, c)+        go ( a,  b,  c) (x:xs) = f (a, b, c) x $ \abc -> go abc xs++{-# INLINE foldl'5k #-}+foldl'5k :: (forall res. (a, b, c, d, e) -> x -> ((a, b, c, d, e) -> res) -> res)+         -> (a, b, c, d, e) -> [x] -> (a, b, c, d, e)+foldl'5k f = go+  where go (!a, !b, !c, !d, !e) _      | False = undefined+        go ( a,  b,  c,  d,  e) []     = (a, b, c, d, e)+        go ( a,  b,  c,  d,  e) (x:xs) = f (a, b, c, d, e) x $ \abcde -> go abcde xs+ -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation levenshteinDistance :: String -> String -> Int@@ -24,27 +42,29 @@  levenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int levenshteinDistanceWithLengths !m !n str1 str2-  | m <= n    = if n <= 32 -- n must be larger so this check is sufficient-                then levenshteinDistance' (undefined :: Word32) m n str1 str2+  | m <= n    = if n <= 64 -- n must be larger so this check is sufficient+                then levenshteinDistance' (undefined :: Word64) m n str1 str2                 else levenshteinDistance' (undefined :: Integer) m n str1 str2-  | otherwise = if m <= 32 -- m must be larger so this check is sufficient-                then levenshteinDistance' (undefined :: Word32) n m str2 str1+  | otherwise = if m <= 64 -- m must be larger so this check is sufficient+                then levenshteinDistance' (undefined :: Word64) n m str2 str1                 else levenshteinDistance' (undefined :: Integer) n m str2 str1 -{-# SPECIALIZE INLINE levenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-}-{-# SPECIALIZE INLINE levenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-}+{-# SPECIALIZE levenshteinDistance' :: Word64 -> Int -> Int -> String -> String -> Int #-}+{-# SPECIALIZE levenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} levenshteinDistance' :: (Num bv, Bits bv) => bv -> Int -> Int -> String -> String -> Int levenshteinDistance' (_bv_dummy :: bv) !m !n str1 str2    | [] <- str1 = n-  | otherwise  = extractAnswer $ foldl' (levenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (m_ones, 0, m) str2+  | otherwise  = extractAnswer $ foldl'3k (levenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (m_ones, 0, m) str2   where m_ones@vector_mask = (2 ^ m) - 1         top_bit_mask = 1 `shiftL` (m - 1) :: bv         extractAnswer (_, _, distance) = distance -{-# SPECIALIZE levenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Int) -> Char -> (Word32, Word32, Int) #-}-{-# SPECIALIZE levenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Int) -> Char -> (Integer, Integer, Int) #-}-levenshteinDistanceWorker :: (Num bv, Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, Int) -> Char -> (bv, bv, Int)-levenshteinDistanceWorker !str1_mvs !top_bit_mask !vector_mask (!vp, !vn, !distance) !char2 +{-# SPECIALIZE INLINE levenshteinDistanceWorker :: IM.IntMap Word64  -> Word64  -> Word64  -> (Word64, Word64, Int)   -> Char -> ((Word64,  Word64,  Int) -> res) -> res #-}+{-# SPECIALIZE INLINE levenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Int) -> Char -> ((Integer, Integer, Int) -> res) -> res #-}+levenshteinDistanceWorker :: (Num bv, Bits bv)+                          => IM.IntMap bv -> bv -> bv -> (bv, bv, Int) -> Char+                          -> ((bv, bv, Int) -> res) -> res+levenshteinDistanceWorker !str1_mvs !top_bit_mask !vector_mask (!vp, !vn, !distance) !char2 k   = {- trace (unlines ["pm = " ++ show pm'                    ,"d0 = " ++ show d0'                    ,"hp = " ++ show hp'@@ -52,7 +72,7 @@                    ,"vp = " ++ show vp'                    ,"vn = " ++ show vn'                    ,"distance' = " ++ show distance'-                   ,"distance'' = " ++ show distance'']) -} (vp', vn', distance'')+                   ,"distance'' = " ++ show distance'']) -} vp' `seq` vn' `seq` distance'' `seq` k (vp', vn', distance'')   where     pm' = IM.findWithDefault 0 (ord char2) str1_mvs     @@ -174,28 +194,28 @@  restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths !m !n str1 str2-  | m <= n    = if n <= 32 -- n must be larger so this check is sufficient-                then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2+  | m <= n    = if n <= 64 -- n must be larger so this check is sufficient+                then restrictedDamerauLevenshteinDistance' (undefined :: Word64) m n str1 str2                 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2-  | otherwise = if m <= 32 -- m must be larger so this check is sufficient-                then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1+  | otherwise = if m <= 64 -- m must be larger so this check is sufficient+                then restrictedDamerauLevenshteinDistance' (undefined :: Word64) n m str2 str1                 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-}-{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-}+{-# SPECIALIZE restrictedDamerauLevenshteinDistance' :: Word64 -> Int -> Int -> String -> String -> Int #-}+{-# SPECIALIZE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} restrictedDamerauLevenshteinDistance' :: (Num bv, Bits bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' (_bv_dummy :: bv) !m !n str1 str2    | [] <- str1 = n-  | otherwise  = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2+  | otherwise  = extractAnswer $ foldl'5k (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2   where m_ones@vector_mask = (2 ^ m) - 1         top_bit_mask = 1 `shiftL` (m - 1) :: bv         extractAnswer (_, _, _, _, distance) = distance -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-}-{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-}-restrictedDamerauLevenshteinDistanceWorker :: (Num bv, Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)-restrictedDamerauLevenshteinDistanceWorker !str1_mvs !top_bit_mask !vector_mask (!pm, !d0, !vp, !vn, !distance) !char2 -  = (pm', d0', vp', vn', distance'')+{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word64 -> Word64 -> Word64 -> (Word64, Word64, Word64, Word64, Int) -> Char -> ((Word64, Word64, Word64, Word64, Int) -> res) -> res #-}+{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> ((Integer, Integer, Integer, Integer, Int) -> res) -> res #-}+restrictedDamerauLevenshteinDistanceWorker :: (Num bv, Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> ((bv, bv, bv, bv, Int) -> res) -> res+restrictedDamerauLevenshteinDistanceWorker !str1_mvs !top_bit_mask !vector_mask (!pm, !d0, !vp, !vn, !distance) !char2 k+  = pm' `seq` d0' `seq` vp' `seq` vn' `seq` distance'' `seq` k (pm', d0', vp', vn', distance'')   where     pm' = IM.findWithDefault 0 (ord char2) str1_mvs     @@ -213,12 +233,12 @@     distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'  -{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}+{-# SPECIALIZE INLINE sizedComplement :: Word64 -> Word64 -> Word64 #-} {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} sizedComplement :: (Num bv, Bits bv) => bv -> bv -> bv sizedComplement vector_mask vect = vector_mask `xor` vect -{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}+{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word64 #-} {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} matchVectors :: (Num bv, Bits bv) => String -> IM.IntMap bv matchVectors = snd . foldl' go (0 :: Int, IM.empty)
Text/EditDistance/MonadUtilities.hs view
@@ -4,8 +4,25 @@  {-# INLINE loopM_ #-} loopM_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()-loopM_ !from !to action-  | from > to = return ()-  | otherwise = do-    action from-    loopM_ (from + 1) to action+loopM_ from to action = go from to+  where+    go from to | from > to = return ()+               | otherwise = do action from+                                go (from + 1) to++-- foldM in Control.Monad is not defined using SAT style so optimises very poorly+{-# INLINE foldM #-}+foldM             :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a+foldM f a xs = foldr (\x rest a -> f a x >>= rest) return xs a+{-+-- If we define it like this, then we aren't able to deforest wrt. a "build" in xs, which would be sad :(+foldM f = go+  where go a (x:xs)  =  f a x >>= \fax -> go fax xs+        go a []      =  return a+-}++-- If we just use a standard foldM then our loops often box stuff up to return from the loop which is then immediately discarded+-- TODO: using this instead of foldM improves our benchmarks by about 2% but makes the code quite ugly.. figure out what to do+{-# INLINE foldMK #-}+foldMK             :: (Monad m) => (a -> b -> m a) -> a -> [b] -> (a -> m res) -> m res+foldMK f a xs k = foldr (\x rest a -> f a x >>= rest) k xs a
Text/EditDistance/STUArray.hs view
@@ -6,8 +6,9 @@  import Text.EditDistance.EditCosts import Text.EditDistance.MonadUtilities+import Text.EditDistance.ArrayUtilities -import Control.Monad+import Control.Monad hiding (foldM) import Control.Monad.ST import Data.Array.ST @@ -32,39 +33,37 @@     -- row of costs at a time, but we use two because it turns out to be faster     cost_row  <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)     cost_row' <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)++    read_str1 <- unsafeReadArray' str1_array+    read_str2 <- unsafeReadArray' str2_array           -- Fill out the first row (j = 0)-    _ <- (\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'+    _ <- (\f -> foldM f (1, 0) str1) $ \(i, deletion_cost) col_char -> let deletion_cost' = deletion_cost + deletionCost costs col_char in unsafeWriteArray cost_row i deletion_cost' >> return (i + 1, deletion_cost')          -- Fill out the remaining rows (j >= 1)-    (_, 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 -> (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 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 (insertion_cost', cost_row', cost_row)-  where-    colWorker row_char !i = do-        col_char <- readArray str1_array i+    (_, final_row, _) <- (\f -> foldM f (0, cost_row, cost_row') [1..str2_len]) $ \(!insertion_cost, !cost_row, !cost_row') !j -> do+        row_char <- read_str2 j         -        left_up <- readArray cost_row  (i - 1)-        left    <- readArray cost_row' (i - 1)-        here_up <- readArray cost_row i-        let here = standardCosts costs row_char col_char left left_up here_up-        writeArray cost_row' i here+        -- Initialize the first element of the row (i = 0)+        let insertion_cost' = insertion_cost + insertionCost costs row_char+        unsafeWriteArray cost_row' 0 insertion_cost'+        +        -- Fill the remaining elements of the row (i >= 1)+        loopM_ 1 str1_len $ \(!i) -> do+            col_char <- read_str1 i+            +            left_up <- unsafeReadArray cost_row  (i - 1)+            left    <- unsafeReadArray cost_row' (i - 1)+            here_up <- unsafeReadArray cost_row i+            let here = standardCosts costs row_char col_char left left_up here_up+            unsafeWriteArray cost_row' i here +        return (insertion_cost', cost_row', cost_row) ++    -- Return an actual answer+    unsafeReadArray final_row str1_len+ restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int restrictedDamerauLevenshteinDistance !costs str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths costs str1_len str2_len str1 str2   where@@ -84,60 +83,65 @@     -- Rows correspond to characters of str2 and columns to characters of str1. We can get away with just storing two     -- rows of costs at a time, but I use three because it turns out to be faster     cost_row <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)++    read_str1 <- unsafeReadArray' str1_array+    read_str2 <- unsafeReadArray' str2_array          -- Fill out the first row (j = 0)-    _ <- (\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'+    _ <- (\f -> foldM f (1, 0) str1) $ \(i, deletion_cost) col_char -> let deletion_cost' = deletion_cost + deletionCost costs col_char in unsafeWriteArray cost_row i deletion_cost' >> return (i + 1, deletion_cost')          if (str2_len == 0)-      then readArray cost_row str1_len+      then unsafeReadArray cost_row str1_len       else do         -- We defer allocation of these arrays to here because they aren't used in the other branch         cost_row'  <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)         cost_row'' <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)                  -- Fill out the second row (j = 1)-        row_char <- readArray str2_array 1+        row_char <- read_str2 1          -- Initialize the first element of the row (i = 0)         let zero = insertionCost costs row_char-        writeArray cost_row' 0 zero+        unsafeWriteArray 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')+        loopM_ 1 str1_len (firstRowColWorker read_str1 row_char cost_row cost_row')                  -- Fill out the remaining rows (j >= 2)-        (_, _, final_row, _, _) <- foldM (restrictedDamerauLevenshteinDistanceSTRowWorker costs str1_len str1_array str2_array) (zero, cost_row, cost_row', cost_row'', row_char) [2..str2_len]+        (_, _, final_row, _, _) <- foldM (restrictedDamerauLevenshteinDistanceSTRowWorker costs str1_len read_str1 read_str2) (zero, cost_row, cost_row', cost_row'', row_char) [2..str2_len]                  -- Return an actual answer-        readArray final_row str1_len+        unsafeReadArray final_row str1_len   where    -    firstRowColWorker !str1_array !row_char !cost_row !cost_row' !i = do-        col_char <- readArray str1_array i+    {-# INLINE firstRowColWorker #-}+    firstRowColWorker read_str1 !row_char !cost_row !cost_row' !i = do+        col_char <- read_str1 i         -        left_up <- readArray cost_row  (i - 1)-        left    <- readArray cost_row' (i - 1)-        here_up <- readArray cost_row  i+        left_up <- unsafeReadArray cost_row  (i - 1)+        left    <- unsafeReadArray cost_row' (i - 1)+        here_up <- unsafeReadArray cost_row  i         let here = standardCosts costs row_char col_char left left_up here_up-        writeArray cost_row' i here+        unsafeWriteArray cost_row' i here +{-# INLINE restrictedDamerauLevenshteinDistanceSTRowWorker #-} restrictedDamerauLevenshteinDistanceSTRowWorker :: EditCosts -> Int-                                                -> STUArray s Int Char -> STUArray s Int Char -- String arrays+                                                -> (Int -> ST s Char) -> (Int -> ST s Char) -- String array accessors                                                 -> (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+restrictedDamerauLevenshteinDistanceSTRowWorker !costs !str1_len read_str1 read_str2 (!insertion_cost, !cost_row, !cost_row', !cost_row'', !prev_row_char) !j = do+    row_char <- read_str2 j          -- Initialize the first element of the row (i = 0)-    zero_up    <- readArray cost_row' 0+    zero_up    <- unsafeReadArray cost_row' 0     let insertion_cost' = insertion_cost + insertionCost costs row_char-    writeArray cost_row'' 0 insertion_cost'+    unsafeWriteArray 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+        col_char <- read_str1 1+        one_up   <- unsafeReadArray cost_row' 1         let one = standardCosts costs row_char col_char insertion_cost' zero_up one_up-        writeArray cost_row'' 1 one+        unsafeWriteArray cost_row'' 1 one                  -- Fill the remaining elements of the row (i >= 2)         loopM_ 2 str1_len (colWorker row_char)@@ -145,19 +149,19 @@     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)-        col_char <- readArray str1_array i+        prev_col_char <- read_str1 (i - 1)+        col_char <- read_str1 i         -        left_left_up_up <- readArray cost_row (i - 2)-        left_up    <- readArray cost_row'  (i - 1)-        left       <- readArray cost_row'' (i - 1)-        here_up    <- readArray cost_row' i+        left_left_up_up <- unsafeReadArray cost_row (i - 2)+        left_up    <- unsafeReadArray cost_row'  (i - 1)+        left       <- unsafeReadArray cost_row'' (i - 1)+        here_up    <- unsafeReadArray 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 col_char row_char)                    else here_standard_only         -        writeArray cost_row'' i here+        unsafeWriteArray cost_row'' i here   {-# INLINE standardCosts #-}@@ -167,10 +171,3 @@     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)-stringToArray str !str_length = do-    array <- newArray_ (1, str_length)-    forM_ (zip [1..] str) (uncurry (writeArray array))-    return array
Text/EditDistance/SquareSTUArray.hs view
@@ -6,8 +6,9 @@  import Text.EditDistance.EditCosts import Text.EditDistance.MonadUtilities+import Text.EditDistance.ArrayUtilities -import Control.Monad+import Control.Monad hiding (foldM) import Control.Monad.ST import Data.Array.ST @@ -31,28 +32,33 @@     -- Rows correspond to characters of str2 and columns to characters of str1.     cost_array <- newArray_ ((0, 0), (str1_len, str2_len)) :: ST s (STUArray s (Int, Int) Int)     -     -- Fill out the first row (j = 0)-    _ <- (\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'+    read_str1 <- unsafeReadArray' str1_array+    read_str2 <- unsafeReadArray' str2_array+    read_cost <- unsafeReadArray' cost_array+    write_cost <- unsafeWriteArray' cost_array     +     -- Fill out the first row (j = 0)+    _ <- (\f -> foldM f (1, 0) str1) $ \(i, deletion_cost) col_char -> let deletion_cost' = deletion_cost + deletionCost costs col_char in write_cost (i, 0) deletion_cost' >> return (i + 1, deletion_cost')+     -- Fill the remaining rows (j >= 1)     _ <- (\f -> foldM f 0 [1..str2_len]) $ \insertion_cost (!j) -> do-        row_char <- readArray str2_array j+        row_char <- read_str2 j                  -- Initialize the first element of the row (i = 0)         let insertion_cost' = insertion_cost + insertionCost costs row_char-        writeArray cost_array (0, j) insertion_cost'+        write_cost (0, j) insertion_cost'                  -- Fill the remaining elements of the row (i >= 1)         loopM_ 1 str1_len $ \(!i) -> do-            col_char <- readArray str1_array i+            col_char <- read_str1 i             -            cost <- standardCosts costs cost_array row_char col_char (i, j)-            writeArray cost_array (i, j) cost+            cost <- standardCosts costs read_cost row_char col_char (i, j)+            write_cost (i, j) cost                  return insertion_cost'-    +     -- Return an actual answer-    readArray cost_array (str1_len, str2_len)+    read_cost (str1_len, str2_len)   restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int@@ -74,77 +80,66 @@     -- Rows correspond to characters of str2 and columns to characters of str1.     cost_array <- newArray_ ((0, 0), (str1_len, str2_len)) :: ST s (STUArray s (Int, Int) Int)     +    read_str1 <- unsafeReadArray' str1_array+    read_str2 <- unsafeReadArray' str2_array+    read_cost <- unsafeReadArray' cost_array+    write_cost <- unsafeWriteArray' cost_array+          -- Fill out the first row (j = 0)-    _ <- (\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'+    _ <- (\f -> foldM f (1, 0) str1) $ \(i, deletion_cost) col_char -> let deletion_cost' = deletion_cost + deletionCost costs col_char in write_cost (i, 0) deletion_cost' >> return (i + 1, deletion_cost')          -- Fill out the second row (j = 1)     when (str2_len > 0) $ do-        initial_row_char <- readArray str2_array 1+        initial_row_char <- read_str2 1                  -- Initialize the first element of the second row (i = 0)-        writeArray cost_array (0, 1) (insertionCost costs initial_row_char)+        write_cost (0, 1) (insertionCost costs initial_row_char)                  -- Initialize the remaining elements of the row (i >= 1)         loopM_ 1 str1_len $ \(!i) -> do-            col_char <- readArray str1_array i+            col_char <- read_str1 i             -            cost <- standardCosts costs cost_array initial_row_char col_char (i, 1)-            writeArray cost_array (i, 1) cost+            cost <- standardCosts costs read_cost initial_row_char col_char (i, 1)+            write_cost (i, 1) cost          -- Fill the remaining rows (j >= 2)     loopM_ 2 str2_len (\(!j) -> do-        row_char <- readArray str2_array j-        prev_row_char <- readArray str2_array (j - 1)+        row_char <- read_str2 j+        prev_row_char <- read_str2 (j - 1)                  -- Initialize the first element of the row (i = 0)-        writeArray cost_array (0, j) (insertionCost costs row_char * j)+        write_cost (0, j) (insertionCost costs row_char * j)                  -- Initialize the second element of the row (i = 1)         when (str1_len > 0) $ do-            col_char <- readArray str1_array 1+            col_char <- read_str1 1             -            cost <- standardCosts costs cost_array row_char col_char (1, j)-            writeArray cost_array (1, j) cost+            cost <- standardCosts costs read_cost row_char col_char (1, j)+            write_cost (1, j) cost                  -- Fill the remaining elements of the row (i >= 2)         loopM_ 2 str1_len (\(!i) -> do-            col_char <- readArray str1_array i-            prev_col_char <- readArray str1_array (i - 1)+            col_char <- read_str1 i+            prev_col_char <- read_str1 (i - 1)             -            standard_cost <- standardCosts costs cost_array row_char col_char (i, j)+            standard_cost <- standardCosts costs read_cost 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 col_char row_char)) $ readArray cost_array (i - 2, j - 2)+                    then do transpose_cost <- fmap (+ (transpositionCost costs col_char row_char)) $ read_cost (i - 2, j - 2)                             return (standard_cost `min` transpose_cost)                     else return standard_cost-            writeArray cost_array (i, j) cost))+            write_cost (i, j) cost))          -- Return an actual answer-    readArray cost_array (str1_len, str2_len)+    read_cost (str1_len, str2_len)   {-# 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 col_char))  $ readArray cost_array (i - 1, j)-    insertion_cost <- fmap (+ (insertionCost costs row_char)) $ readArray cost_array (i, j - 1)+standardCosts :: EditCosts -> ((Int, Int) -> ST s Int) -> Char -> Char -> (Int, Int) -> ST s Int+standardCosts !costs read_cost !row_char !col_char (!i, !j) = do+    deletion_cost  <- fmap (+ (deletionCost costs col_char))  $ read_cost (i - 1, j)+    insertion_cost <- fmap (+ (insertionCost costs row_char)) $ read_cost (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))+                           (read_cost (i - 1, j - 1))     return $ deletion_cost `min` insertion_cost `min` subst_cost--{-# INLINE stringToArray #-}-stringToArray :: String -> Int -> ST s (STUArray s Int Char)-stringToArray str !str_len = do-    array <- newArray_ (1, str_len)-    forM_ (zip [1..] str) (uncurry (writeArray array))-    return array--{--showArray :: STUArray s (Int, Int) Int -> ST s String-showArray array = do-    ((il, jl), (iu, ju)) <- getBounds array-    flip (flip foldM "") [(i, j) | i <- [il..iu], j <- [jl.. ju]] $ \rest (i, j) -> do-        elt <- readArray array (i, j)-        return $ rest ++ show (i, j) ++ ": " ++ show elt ++ ", "--}
edit-distance.cabal view
@@ -1,5 +1,5 @@ Name:                edit-distance-Version:             0.2.1.1+Version:             0.2.1.2 Cabal-Version:       >= 1.2 Category:            Algorithms Synopsis:            Levenshtein and restricted Damerau-Levenshtein edit distances@@ -32,6 +32,7 @@                                 Text.EditDistance.STUArray                                 Text.EditDistance.Bits                                 Text.EditDistance.MonadUtilities+                                Text.EditDistance.ArrayUtilities                  if flag(splitBase)                 Build-Depends:  base >= 3 && < 5, array >= 0.1, random >= 1.0, containers >= 0.1.0.1@@ -63,10 +64,10 @@                 Buildable:      False         else                 if flag(splitBase)-                        Build-Depends:  base >= 3 && < 5, array >= 0.1, random >= 1.0, old-time >= 1.0, process >= 1.0,-                                        parallel >= 1.0, unix >= 2.3+                        Build-Depends:  base >= 3 && < 5, array >= 0.1, random >= 1.0, time >= 1.0, process >= 1.0,+                                        deepseq >= 1.2, unix >= 2.3, criterion >= 0.6                 else                         Build-Depends:  base < 3,-                                        parallel >= 1.0, unix >= 2.3+                                        deepseq >= 1.2, unix >= 2.3                      Ghc-Options:            -O2