edit-distance 0.2.1.3 → 0.2.2.1
raw patch · 15 files changed
+383/−228 lines, 15 filesdep +test-framework-quickcheck2dep −test-framework-quickcheckdep ~QuickCheckdep ~basedep ~criterionnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: test-framework-quickcheck2
Dependencies removed: test-framework-quickcheck
Dependency ranges changed: QuickCheck, base, criterion
API changes (from Hackage documentation)
Files
- LICENSE +1/−1
- README.md +42/−0
- README.textile +0/−49
- Text/EditDistance.hs +17/−7
- Text/EditDistance/ArrayUtilities.hs +2/−2
- Text/EditDistance/Benchmark.hs +21/−27
- Text/EditDistance/Bits.hs +23/−23
- Text/EditDistance/EditCosts.hs +0/−0
- Text/EditDistance/MonadUtilities.hs +3/−3
- Text/EditDistance/STUArray.hs +24/−24
- Text/EditDistance/SquareSTUArray.hs +23/−23
- Text/EditDistance/Tests.hs +0/−0
- Text/EditDistance/Tests/EditOperationOntology.hs +89/−0
- Text/EditDistance/Tests/Properties.hs +94/−0
- edit-distance.cabal +44/−69
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2008, Maximilian Bolingbroke+Copyright (c) 2008-2013 Maximilian Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted
+ README.md view
@@ -0,0 +1,42 @@+# Edit Distance Algorithms++[](https://travis-ci.org/phadej/edit-distance)+[](http://hackage.haskell.org/package/edit-distance)++## Installing++To just install the library:++```+cabal configure+cabal build+cabal install+```++## Description++Edit distances algorithms for fuzzy matching. Specifically, this library provides:++- [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 64 characters long we 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 us into improving the situation.++## Example++```hs+Text.EditDistance> levenshteinDistance defaultEditCosts "witch" "kitsch"+2+```+++## Links++- [Hackage](http://hackage.haskell.org/package/edit-distance)+- [GitHub](http://github.com/phadej/edit-distance)+- [Original gitHub](http://github.com/batterseapower/edit-distance)
− README.textile
@@ -1,49 +0,0 @@-h1. Edit Distance Algorithms - -You can help improve this README with extra snippets and advice by using the "GitHub wiki":http://github.com/batterseapower/edit-distance/wikis/readme. - - -h2. Installing - -To just install the library: - -<pre> -<code>runghc Setup.lhs configure -runghc Setup.lhs build -sudo runghc Setup.lhs install -</pre> -</code> - -If you want to build the tests, to check it's all working: - -<pre> -<code>runghc Setup.lhs configure -ftests -runghc Setup.lhs build -dist/build/edit-distance-tests/edit-distance-tests -</pre> -</code> - - -h2. Description - -Edit distances algorithms for fuzzy matching. Specifically, this library provides: - -* "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 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 - -<pre> -<code>Text.EditDistance> levenshteinDistance defaultEditCosts "witch" "kitsch" -2</code> -</pre> - - -h2. Linkage - -* "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
Text/EditDistance.hs view
@@ -1,8 +1,18 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE Safe #-} --- | Computing the edit distances between strings-module Text.EditDistance ( - Costs(..), EditCosts(..), defaultEditCosts, +----------------------------------------------------------------------------+-- |+-- Module : Text.EditDistance+-- Copyright : (C) 2010-2015 Maximilian Bolingbroke+-- License : BSD-3-Clause (see the file LICENSE)+--+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- Computing the edit distances between strings+----------------------------------------------------------------------------+module Text.EditDistance (+ Costs(..), EditCosts(..), defaultEditCosts, levenshteinDistance, restrictedDamerauLevenshteinDistance ) where @@ -12,7 +22,7 @@ -- | Find the Levenshtein edit distance between two strings. That is to say, the number of deletion, -- insertion and substitution operations that are required to make the two strings equal. Note that--- this algorithm therefore does not make use of the 'transpositionCost' field of the costs. See also:+-- this algorithm therefore does not make use of the @transpositionCost@ field of the costs. See also: -- <http://en.wikipedia.org/wiki/Levenshtein_distance>. levenshteinDistance :: EditCosts -> String -> String -> Int levenshteinDistance costs str1 str2@@ -25,9 +35,9 @@ str1_len = length str1 str2_len = length str2 --- | 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 --- string alignment is the number of edit operations needed to make the input strings equal under the condition that no substring +-- | 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+-- string alignment is the number of edit operations needed to make the input strings equal under the condition that no substring -- is edited more than once. See also: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int restrictedDamerauLevenshteinDistance costs str1 str2
Text/EditDistance/ArrayUtilities.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, Trustworthy #-} module Text.EditDistance.ArrayUtilities ( unsafeReadArray, unsafeWriteArray,@@ -10,7 +10,7 @@ import Control.Monad.ST import Data.Array.ST-import Data.Array.Base (unsafeRead, unsafeWrite, getNumElements)+import Data.Array.Base (unsafeRead, unsafeWrite) #ifdef __GLASGOW_HASKELL__ import GHC.Arr (unsafeIndex)
Text/EditDistance/Benchmark.hs view
@@ -1,29 +1,24 @@ {-# OPTIONS_GHC -fno-full-laziness #-} module Main where -import Text.EditDistance.EditCosts-import Text.EditDistance.MonadUtilities+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 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.DeepSeq ( NFData, rnf )+import Control.DeepSeq ( NFData, rnf )+import Control.Exception+import Control.Monad+import Criterion.Main+import Data.List+import Data.Time.Clock.POSIX (getPOSIXTime)+import System.Environment+import System.Exit+import System.Mem+import System.Process+import System.Random sTRING_SIZE_STEP, mAX_STRING_SIZE :: Int sTRING_SIZE_STEP = 3@@ -33,7 +28,7 @@ getTime = realToFrac `fmap` getPOSIXTime time :: IO a -> IO Double-time action = do +time action = do ts1 <- getTime action ts2 <- getTime@@ -48,12 +43,12 @@ gen <- newStdGen let (string1, string2_long) = splitAt i (randoms gen) string2 = take j string2_long- + -- Force the two strings to be evaluated so they don't meddle -- with the benchmarking evaluate (rnf string1) evaluate (rnf string2)- + -- Don't want junk from previous runs causing a GC during the test performGC @@ -100,17 +95,16 @@ --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 + 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)]]+ defaultMain [ 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, Rank2Types #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables, BangPatterns, Rank2Types #-} module Text.EditDistance.Bits ( levenshteinDistance, levenshteinDistanceWithLengths, {-levenshteinDistanceCutoff,-} restrictedDamerauLevenshteinDistance, restrictedDamerauLevenshteinDistanceWithLengths@@ -20,7 +20,7 @@ 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+ where go (!_, !_, !_) _ | False = undefined go ( a, b, c) [] = (a, b, c) go ( a, b, c) (x:xs) = f (a, b, c) x $ \abc -> go abc xs @@ -28,7 +28,7 @@ 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+ where go (!_, !_, !_, !_, !_) _ | 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 @@ -52,7 +52,7 @@ {-# 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 +levenshteinDistance' (_bv_dummy :: bv) !m !n str1 str2 | [] <- str1 = n | 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@@ -75,16 +75,16 @@ ,"distance'' = " ++ show distance'']) -} vp' `seq` vn' `seq` distance'' `seq` k (vp', vn', distance'') where pm' = IM.findWithDefault 0 (ord char2) str1_mvs- + d0' = ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp- + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask hn'_shift = (hn' `shiftL` 1) .&. vector_mask vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) vn' = d0' .&. hp'_shift- + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' @@ -96,12 +96,12 @@ -- 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 levenshteinDistanceCutoff :: Int -> String -> String -> Int-levenshteinDistanceCutoff cutoff str1 str2 +levenshteinDistanceCutoff cutoff str1 str2 | length str1 <= length str2 = levenshteinDistanceCutoff' cutoff str1 str2 | otherwise = levenshteinDistanceCutoff' cutoff str2 str1 levenshteinDistanceCutoff' :: Int -> String -> String -> Int-levenshteinDistanceCutoff' cutoff str1 str2 +levenshteinDistanceCutoff' cutoff str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ foldl' (levenshteinDistanceCutoffFlatWorker (matchVectors str1)) (foldl' (levenshteinDistanceCutoffDiagWorker (matchVectors str1)) (top_bit_mask, vector_mask, all_ones, 0, initial_pm_offset, initial_dist) str2_diag)@@ -114,19 +114,19 @@ all_ones@vector_mask = (2 ^ vector_length) - 1 top_bit_mask = trace (show bottom_factor ++ ", " ++ show vector_length) $ 1 `shiftL` (vector_length - 1) extractAnswer (_, _, _, _, _, distance) = distance- + len_difference = n - m top_factor = cutoff + len_difference bottom_factor = cutoff - len_difference bottom_factor_shift = (bottom_factor `shiftR` 1)- + initial_dist = bottom_factor_shift -- The distance the virtual first vector ended on initial_pm_offset = (top_factor `shiftR` 1) -- The amount of left shift to apply to the >next< pattern match vector diag_threshold = negate bottom_factor_shift + m -- The index in str2 where we stop going diagonally down and start going across (str2_diag, str2_flat) = splitAt diag_threshold str2 levenshteinDistanceCutoffDiagWorker :: IM.IntMap BitVector -> (BitVector, BitVector, BitVector, BitVector, Int, Int) -> Char -> (BitVector, BitVector, BitVector, BitVector, Int, Int)-levenshteinDistanceCutoffDiagWorker !str1_mvs (!top_bit_mask, !vector_mask, !vp, !vn, !pm_offset, !distance) !char2 +levenshteinDistanceCutoffDiagWorker !str1_mvs (!top_bit_mask, !vector_mask, !vp, !vn, !pm_offset, !distance) !char2 = trace (unlines ["vp = " ++ show vp ,"vn = " ++ show vn ,"vector_mask = " ++ show vector_mask@@ -142,19 +142,19 @@ where unshifted_pm = IM.findWithDefault 0 (ord char2) str1_mvs pm' = (unshifted_pm `shift` pm_offset) .&. vector_mask- + d0' = ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp- + d0'_shift = d0' `shiftR` 1 vp' = hn' .|. sizedComplement vector_mask (d0'_shift .|. hp') vn' = d0'_shift .&. hp'- + distance' = if d0' .&. top_bit_mask /= 0 then distance else distance + 1 levenshteinDistanceCutoffFlatWorker :: IM.IntMap BitVector -> (BitVector, BitVector, BitVector, BitVector, Int, Int) -> Char -> (BitVector, BitVector, BitVector, BitVector, Int, Int)-levenshteinDistanceCutoffFlatWorker !str1_mvs (!top_bit_mask, !vector_mask, !vp, !vn, !pm_offset, !distance) !char2 +levenshteinDistanceCutoffFlatWorker !str1_mvs (!top_bit_mask, !vector_mask, !vp, !vn, !pm_offset, !distance) !char2 = trace (unlines ["pm_offset = " ++ show pm_offset ,"top_bit_mask' = " ++ show top_bit_mask' ,"vector_mask' = " ++ show vector_mask'@@ -170,15 +170,15 @@ top_bit_mask' = top_bit_mask `shiftR` 1 vector_mask' = vector_mask `shiftR` 1 pm' = (IM.findWithDefault 0 (ord char2) str1_mvs `rotate` pm_offset) .&. vector_mask'- + d0' = ((((pm' .&. vp) + vp) `xor` vp) .|. pm' .|. vn) .&. vector_mask' hp' = vn .|. sizedComplement vector_mask' (d0' .|. vp) hn' = d0' .&. vp- + d0'_shift = d0' `shiftR` 1 vp' = hn' .|. sizedComplement vector_mask' (d0'_shift .|. hp') vn' = d0'_shift .&. hp'- + distance' = if hp' .&. top_bit_mask' /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask' /= 0 then distance' - 1 else distance' @@ -204,7 +204,7 @@ {-# 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 +restrictedDamerauLevenshteinDistance' (_bv_dummy :: bv) !m !n str1 str2 | [] <- str1 = n | 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@@ -218,17 +218,17 @@ = 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- + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) -- No need to mask the shiftL because of the restricted range of pm .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp- + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask hn'_shift = (hn' `shiftL` 1) .&. vector_mask vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) vn' = d0' .&. hp'_shift- + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
Text/EditDistance/EditCosts.hs view
Text/EditDistance/MonadUtilities.hs view
@@ -4,7 +4,7 @@ {-# INLINE loopM_ #-} loopM_ :: Monad m => Int -> Int -> (Int -> m ()) -> m ()-loopM_ from to action = go from to+loopM_ xfrom xto action = go xfrom xto where go from to | from > to = return () | otherwise = do action from@@ -13,7 +13,7 @@ -- 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+foldM f x xs = foldr (\y rest a -> f a y >>= rest) return xs x {- -- 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@@ -25,4 +25,4 @@ -- 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+foldMK f x xs k = foldr (\y rest a -> f a y >>= rest) k xs x
Text/EditDistance/STUArray.hs view
@@ -27,31 +27,31 @@ -- Create string arrays str1_array <- stringToArray str1 str1_len str2_array <- stringToArray str2 str2_len- + -- Create array of costs for a single row. Say we index costs by (i, j) where i is the column index and j the row index. -- Rows correspond to characters of str2 and columns to characters of str1. We can get away with just storing a single -- 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)+ start_cost_row <- newArray_ (0, str1_len) :: ST s (STUArray s Int Int)+ start_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 (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')- + _ <- (\f -> foldM f (1, 0) str1) $ \(i, deletion_cost) col_char -> let deletion_cost' = deletion_cost + deletionCost costs col_char in unsafeWriteArray start_cost_row i deletion_cost' >> return (i + 1, deletion_cost')+ -- Fill out the remaining rows (j >= 1)- (_, final_row, _) <- (\f -> foldM f (0, cost_row, cost_row') [1..str2_len]) $ \(!insertion_cost, !cost_row, !cost_row') !j -> do+ (_, final_row, _) <- (\f -> foldM f (0, start_cost_row, start_cost_row') [1..str2_len]) $ \(!insertion_cost, !cost_row, !cost_row') !j -> do row_char <- read_str2 j- + -- 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@@ -78,7 +78,7 @@ -- Create string arrays str1_array <- stringToArray str1 str1_len str2_array <- stringToArray str2 str2_len- + -- Create array of costs for a single row. Say we index costs by (i, j) where i is the column index and j the row index. -- 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@@ -86,17 +86,17 @@ read_str1 <- unsafeReadArray' str1_array read_str2 <- unsafeReadArray' str2_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 unsafeWriteArray cost_row i deletion_cost' >> return (i + 1, deletion_cost')- + if (str2_len == 0) 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 <- read_str2 1 @@ -106,17 +106,17 @@ -- Fill the remaining elements of the row (i >= 1) 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 read_str1 read_str2) (zero, cost_row, cost_row', cost_row'', row_char) [2..str2_len]- + -- Return an actual answer unsafeReadArray final_row str1_len- where + where {-# INLINE firstRowColWorker #-} firstRowColWorker read_str1 !row_char !cost_row !cost_row' !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@@ -130,28 +130,28 @@ -> 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 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 <- unsafeReadArray cost_row' 0 let insertion_cost' = insertion_cost + insertionCost costs row_char unsafeWriteArray cost_row'' 0 insertion_cost'- + -- Initialize the second element of the row (i = 1) when (str1_len > 0) $ do 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 unsafeWriteArray cost_row'' 1 one- + -- Fill the remaining elements of the row (i >= 2) loopM_ 2 str1_len (colWorker row_char)- + return (insertion_cost', cost_row', cost_row'', cost_row, row_char) where colWorker !row_char !i = do prev_col_char <- read_str1 (i - 1) col_char <- read_str1 i- + left_left_up_up <- unsafeReadArray cost_row (i - 2) left_up <- unsafeReadArray cost_row' (i - 1) left <- unsafeReadArray cost_row'' (i - 1)@@ -160,7 +160,7 @@ 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- + unsafeWriteArray cost_row'' i here
Text/EditDistance/SquareSTUArray.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables, BangPatterns, Trustworthy #-} module Text.EditDistance.SquareSTUArray ( levenshteinDistance, levenshteinDistanceWithLengths, restrictedDamerauLevenshteinDistance, restrictedDamerauLevenshteinDistanceWithLengths@@ -27,34 +27,34 @@ -- Create string arrays str1_array <- stringToArray str1 str1_len str2_array <- stringToArray str2 str2_len- + -- Create array of costs. Say we index it by (i, j) where i is the column index and j the row index. -- 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 (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 <- read_str2 j- + -- Initialize the first element of the row (i = 0) let insertion_cost' = insertion_cost + insertionCost costs row_char write_cost (0, j) insertion_cost'- + -- Fill the remaining elements of the row (i >= 1) loopM_ 1 str1_len $ \(!i) -> do col_char <- read_str1 i- + cost <- standardCosts costs read_cost row_char col_char (i, j) write_cost (i, j) cost- + return insertion_cost' -- Return an actual answer@@ -75,60 +75,60 @@ -- Create string arrays str1_array <- stringToArray str1 str1_len str2_array <- stringToArray str2 str2_len- + -- Create array of costs. Say we index it by (i, j) where i is the column index and j the row index. -- 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 (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 <- read_str2 1- + -- Initialize the first element of the second row (i = 0) 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 <- read_str1 i- + 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 <- read_str2 j prev_row_char <- read_str2 (j - 1)- + -- Initialize the first element of the row (i = 0) 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 <- read_str1 1- + 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 <- read_str1 i prev_col_char <- read_str1 (i - 1)- + 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)) $ read_cost (i - 2, j - 2) return (standard_cost `min` transpose_cost) else return standard_cost write_cost (i, j) cost))- + -- Return an actual answer read_cost (str1_len, str2_len) @@ -139,7 +139,7 @@ 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 + then 0 else (substitutionCost costs col_char row_char)) (read_cost (i - 1, j - 1)) return $ deletion_cost `min` insertion_cost `min` subst_cost
Text/EditDistance/Tests.hs view
+ Text/EditDistance/Tests/EditOperationOntology.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE PatternGuards #-}+module Text.EditDistance.Tests.EditOperationOntology where++import Text.EditDistance.EditCosts++import Test.QuickCheck+import Control.Monad++class Arbitrary ops => EditOperation ops where+ edit :: String -> ops -> Gen (String, EditCosts -> Int)+ containsTransposition :: ops -> Bool++instance EditOperation op => EditOperation [op] where+ edit ys ops = foldM (\(xs, c) op -> fmap (\(xs', cost') -> (xs', \ecs -> c ecs + cost' ecs)) $ edit xs op) (ys, const 0) ops+ containsTransposition = any containsTransposition+++data EditedString ops = MkEditedString {+ oldString :: String,+ newString :: String,+ operations :: ops,+ esCost :: EditCosts -> Int+}++instance Show ops => Show (EditedString ops) where+ show (MkEditedString old_string new_string ops _cost) = show old_string ++ " ==> " ++ show new_string ++ " (by " ++ show ops ++ ")"++instance EditOperation ops => Arbitrary (EditedString ops) where+ arbitrary = do+ old_string <- arbitrary+ edit_operations <- arbitrary+ (new_string, cost) <- edit old_string edit_operations+ return $ MkEditedString {+ oldString = old_string,+ newString = new_string,+ operations = edit_operations,+ esCost = cost+ }+++data ExtendedEditOperation = Deletion+ | Insertion Char+ | Substitution Char+ | Transposition+ deriving (Show)++instance Arbitrary ExtendedEditOperation where+ arbitrary = oneof [return Deletion, fmap Insertion arbitrary, fmap Substitution arbitrary, return Transposition]++instance EditOperation ExtendedEditOperation where+ edit str op = do+ let max_split_ix | Transposition <- op = length str - 1+ | otherwise = length str+ split_ix <- choose (1, max_split_ix)+ let (str_l, str_r) = splitAt split_ix str+ non_null = not $ null str+ transposable = length str > 1+ case op of+ Deletion | non_null -> do+ let old_ch = last str_l+ return (init str_l ++ str_r, \ec -> deletionCost ec old_ch)+ Insertion new_ch | non_null -> do+ return (str_l ++ new_ch : str_r, \ec -> insertionCost ec new_ch)+ Insertion new_ch | otherwise -> return ([new_ch], \ec -> insertionCost ec new_ch) -- Need special case because randomR (1, 0) is undefined+ Substitution new_ch | non_null -> do+ let old_ch = last str_l+ return (init str_l ++ new_ch : str_r, \ec -> substitutionCost ec old_ch new_ch)+ Transposition | transposable -> do -- Need transposable rather than non_null because randomR (1, 0) is undefined+ let backwards_ch = head str_r+ forwards_ch = last str_l+ return (init str_l ++ backwards_ch : forwards_ch : tail str_r, \ec -> transpositionCost ec backwards_ch forwards_ch)+ _ -> return (str, const 0)++ containsTransposition Transposition = True+ containsTransposition _ = False+++-- This all really sucks but I can't think of something better right now+newtype BasicEditOperation = MkBasic ExtendedEditOperation++instance Show BasicEditOperation where+ show (MkBasic x) = show x++instance Arbitrary BasicEditOperation where+ arbitrary = fmap MkBasic $ oneof [return Deletion, fmap Insertion arbitrary, fmap Substitution arbitrary]++instance EditOperation BasicEditOperation where+ edit str (MkBasic op) = edit str op+ containsTransposition _ = False
+ Text/EditDistance/Tests/Properties.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}++module Text.EditDistance.Tests.Properties (+ tests+ ) where++import Text.EditDistance.EditCosts+import qualified Text.EditDistance.SquareSTUArray as SquareSTUArray+import qualified Text.EditDistance.STUArray as STUArray+import qualified Text.EditDistance.Bits as Bits+import Text.EditDistance.Tests.EditOperationOntology++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+++tests :: [Test]+tests = [ testGroup "Levenshtein Distance (SquareSTUArray)" sqstu_levenshteinDistanceTests+ , testGroup "Restricted Damerau-Levenshtein Distance (SquareSTUArray)" sqstu_restrictedDamerauLevenshteinDistanceTests+ , testGroup "Levenshtein Distance (STUArray)" stu_levenshteinDistanceTests+ , testGroup "Restricted Damerau-Levenshtein Distance (STUArray)" stu_restrictedDamerauLevenshteinDistanceTests+ , testGroup "Levenshtein Distance (Bits)" bits_levenshteinDistanceTests+ , testGroup "Restricted Damerau-Levenshtein Distance (Bits)" bits_restrictedDamerauLevenshteinDistanceTests+ , testGroup "Levenshtein Distance Crosschecks" levenshteinDistanceCrosscheckTests+ , testGroup "Restricted Damerau-Levenshtein Distance Crosschecks" restrictedDamerauLevenshteinDistanceCrosscheckTests+ --, testGroup "Levenshtein Distance Cutoff (Bits)" bits_levenshteinDistanceCutoffTests+ ]+ where+ sqstu_levenshteinDistanceTests = standardDistanceTests SquareSTUArray.levenshteinDistance interestingCosts (undefined :: BasicEditOperation)+ sqstu_restrictedDamerauLevenshteinDistanceTests = standardDistanceTests SquareSTUArray.restrictedDamerauLevenshteinDistance interestingCosts (undefined :: ExtendedEditOperation)+ stu_levenshteinDistanceTests = standardDistanceTests STUArray.levenshteinDistance interestingCosts (undefined :: BasicEditOperation)+ stu_restrictedDamerauLevenshteinDistanceTests = standardDistanceTests STUArray.restrictedDamerauLevenshteinDistance interestingCosts (undefined :: ExtendedEditOperation)+ bits_levenshteinDistanceTests = standardDistanceTests (const Bits.levenshteinDistance) defaultEditCosts (undefined :: BasicEditOperation)+ bits_restrictedDamerauLevenshteinDistanceTests = standardDistanceTests (const Bits.restrictedDamerauLevenshteinDistance) defaultEditCosts (undefined :: ExtendedEditOperation)++ --bits_levenshteinDistanceCutoffTests = [ testProperty "Cutoff vs. Non-Cutoff" (forAll arbitrary (\cutoff -> distanceEqIfBelowProperty cutoff (Bits.levenshteinDistanceCutoff cutoff) Bits.levenshteinDistance defaultEditCosts (undefined :: BasicEditOperation))) ]++ levenshteinDistanceCrosscheckTests+ = crossCheckTests [ ("SquareSTUArray", SquareSTUArray.levenshteinDistance defaultEditCosts)+ , ("STUArray", STUArray.levenshteinDistance defaultEditCosts)+ , ("Bits", Bits.levenshteinDistance) ]+ (undefined :: BasicEditOperation)++ restrictedDamerauLevenshteinDistanceCrosscheckTests+ = crossCheckTests [ ("SquareSTUArray", SquareSTUArray.restrictedDamerauLevenshteinDistance defaultEditCosts)+ , ("STUArray", STUArray.restrictedDamerauLevenshteinDistance defaultEditCosts)+ , ("Bits", Bits.restrictedDamerauLevenshteinDistance) ]+ (undefined :: ExtendedEditOperation)+++interestingCosts :: EditCosts+interestingCosts = EditCosts {+ deletionCosts = ConstantCost 1,+ insertionCosts = ConstantCost 2,+ substitutionCosts = ConstantCost 3, -- Can't be higher than deletion + insertion+ transpositionCosts = ConstantCost 3 -- Can't be higher than deletion + insertion+}+++crossCheckTests :: forall op. (EditOperation op, Show op) => [(String, String -> String -> Int)] -> op -> [Test]+crossCheckTests named_distances _op_dummy+ = [ testProperty (name1 ++ " vs. " ++ name2) (distanceEqProperty distance1 distance2 _op_dummy)+ | (ix1, (name1, distance1)) <- enumerated_named_distances, (ix2, (name2, distance2)) <- enumerated_named_distances, ix2 > ix1 ]+ where+ enumerated_named_distances = [(1 :: Int)..] `zip` named_distances++distanceEqProperty :: (String -> String -> Int) -> (String -> String -> Int) -> op -> EditedString op -> Bool+distanceEqProperty distance1 distance2 _op_dummy (MkEditedString old new _ _) = distance1 old new == distance2 old new++--distanceEqIfBelowProperty :: (EditOperation op) => Int -> (String -> String -> Int) -> (String -> String -> Int) -> EditCosts -> op -> EditedString op -> Property+--distanceEqIfBelowProperty cutoff distance1 distance2 costs _op_dummy (MkEditedString old new ops) = (editCost costs ops <= cutoff) ==> distance1 old new == distance2 old new++standardDistanceTests :: forall op. (EditOperation op, Show op) => (EditCosts -> String -> String -> Int) -> EditCosts -> op -> [Test]+standardDistanceTests distance costs _op_dummy+ = [ testProperty "Self distance is zero" prop_self_distance_zero+ , testProperty "Pure deletion has the right cost" prop_pure_deletion_cost_correct+ , testProperty "Pure insertion has the right cost" prop_pure_insertion_cost_correct+ , testProperty "Single operations have the right cost" prop_single_op_cost_is_distance+ , testProperty "Cost bound is respected" prop_combined_op_cost_at_least_distance+ ]+ where+ testableDistance = distance costs++ prop_self_distance_zero str+ = testableDistance str str == 0+ prop_pure_deletion_cost_correct str+ = testableDistance str "" == sum [deletionCost costs c | c <- str]+ prop_pure_insertion_cost_correct str+ = testableDistance "" str == sum [insertionCost costs c | c <- str]+ prop_single_op_cost_is_distance (MkEditedString old new _ops cost :: EditedString op)+ = (length old > 2) ==> testableDistance old new == cost costs || old == new+ prop_combined_op_cost_at_least_distance (MkEditedString old new ops cost :: EditedString [op])+ = not (containsTransposition ops) ==> testableDistance old new <= cost costs
edit-distance.cabal view
@@ -1,73 +1,48 @@-Name: edit-distance-Version: 0.2.1.3-Cabal-Version: >= 1.2-Category: Algorithms-Synopsis: Levenshtein and restricted Damerau-Levenshtein edit distances-Description: Optimized edit distances for fuzzy matching, including Levenshtein and restricted Damerau-Levenshtein algorithms.-License: BSD3-License-File: LICENSE-Extra-Source-Files: README.textile-Author: Max Bolingbroke-Maintainer: batterseapower@hotmail.com-Homepage: http://github.com/batterseapower/edit-distance-Build-Type: Simple--Flag Tests- Description: Enable building the tests- Default: False--Flag Benchmark- Description: Enable building the benchmark suite- Default: False--Flag SplitBase- Description: Choose the new smaller, split-up base package- Default: True---Library- Exposed-Modules: Text.EditDistance- Other-Modules: Text.EditDistance.EditCosts- Text.EditDistance.SquareSTUArray- 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- else- Build-Depends: base < 3-- Ghc-Options: -O2--Executable edit-distance-tests- Main-Is: Text/EditDistance/Tests.hs-- Extensions: PatternGuards, PatternSignatures,- ScopedTypeVariables- Ghc-Options: -O2+name: edit-distance+version: 0.2.2.1+cabal-version: >= 1.10+category: Algorithms+synopsis: Levenshtein and restricted Damerau-Levenshtein edit distances+description: Optimized edit distances for fuzzy matching, including Levenshtein and restricted Damerau-Levenshtein algorithms.+license: BSD3+license-File: LICENSE+extra-source-files: README.md+author: Max Bolingbroke <batterseapower@hotmail.com>+copyright: (c) 2008-2013 Maximilian Bolinbroke+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+homepage: http://github.com/phadej/edit-distance+build-type: Simple - if !flag(tests)- Buildable: False- else- 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- Build-Depends: base < 3+library+ default-language: Haskell98+ exposed-modules: Text.EditDistance+ other-modules: Text.EditDistance.EditCosts+ Text.EditDistance.SquareSTUArray+ Text.EditDistance.STUArray+ Text.EditDistance.Bits+ Text.EditDistance.MonadUtilities+ Text.EditDistance.ArrayUtilities+ build-depends: base >= 4.5 && < 5, array >= 0.1, random >= 1.0, containers >= 0.1.0.1+ ghc-options: -O2 -Wall -Executable edit-distance-benchmark- Main-Is: Text/EditDistance/Benchmark.hs+test-suite edit-distance-tests+ default-language: Haskell98+ main-is: Text/EditDistance/Tests.hs+ other-modules: Text.EditDistance.Tests.EditOperationOntology+ Text.EditDistance.Tests.Properties+ type: exitcode-stdio-1.0+ ghc-options: -O2 -Wall+ build-depends: base >= 4.5 && < 5, array >= 0.1, random >= 1.0, containers >= 0.1.0.1,+ test-framework >= 0.1.1, QuickCheck >= 2.4 && <2.9, test-framework-quickcheck2 - if !flag(benchmark)- Buildable: False- else- if flag(splitBase)- 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,- deepseq >= 1.2, unix >= 2.3+benchmark edit-distance-benchmark+ default-language: Haskell98+ main-is: Text/EditDistance/Benchmark.hs+ type: exitcode-stdio-1.0+ build-depends: base >= 4.5 && < 5, array >= 0.1, random >= 1.0, time >= 1.0, process >= 1.0,+ deepseq >= 1.2, unix >= 2.3, criterion >= 1.1, containers >= 0.1.0.1+ ghc-options: -O2 - Ghc-Options: -O2+source-repository head+ type: git+ location: https://github.com/phadej/edit-distance.git