diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +# Edit Distance Algorithms + +[![Build Status](https://travis-ci.org/phadej/edit-distance.svg?branch=master)](https://travis-ci.org/phadej/edit-distance) +[![Hackage](https://img.shields.io/hackage/v/edit-distance.svg)](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) diff --git a/README.textile b/README.textile deleted file mode 100644 --- a/README.textile +++ /dev/null @@ -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: - -
-runghc Setup.lhs configure
-runghc Setup.lhs build
-sudo runghc Setup.lhs install
-
- - -If you want to build the tests, to check it's all working: - -
-runghc Setup.lhs configure -ftests
-runghc Setup.lhs build
-dist/build/edit-distance-tests/edit-distance-tests
-
- - - -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 - -
-Text.EditDistance> levenshteinDistance defaultEditCosts "witch" "kitsch"
-2
-
- - -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 diff --git a/Text/EditDistance.hs b/Text/EditDistance.hs --- a/Text/EditDistance.hs +++ b/Text/EditDistance.hs @@ -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 +-- +-- 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: -- . 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: . restrictedDamerauLevenshteinDistance :: EditCosts -> String -> String -> Int restrictedDamerauLevenshteinDistance costs str1 str2 diff --git a/Text/EditDistance/ArrayUtilities.hs b/Text/EditDistance/ArrayUtilities.hs --- a/Text/EditDistance/ArrayUtilities.hs +++ b/Text/EditDistance/ArrayUtilities.hs @@ -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) diff --git a/Text/EditDistance/Benchmark.hs b/Text/EditDistance/Benchmark.hs --- a/Text/EditDistance/Benchmark.hs +++ b/Text/EditDistance/Benchmark.hs @@ -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)]] diff --git a/Text/EditDistance/Bits.hs b/Text/EditDistance/Bits.hs --- a/Text/EditDistance/Bits.hs +++ b/Text/EditDistance/Bits.hs @@ -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' diff --git a/Text/EditDistance/EditCosts.hs b/Text/EditDistance/EditCosts.hs --- a/Text/EditDistance/EditCosts.hs +++ b/Text/EditDistance/EditCosts.hs diff --git a/Text/EditDistance/MonadUtilities.hs b/Text/EditDistance/MonadUtilities.hs --- a/Text/EditDistance/MonadUtilities.hs +++ b/Text/EditDistance/MonadUtilities.hs @@ -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 diff --git a/Text/EditDistance/STUArray.hs b/Text/EditDistance/STUArray.hs --- a/Text/EditDistance/STUArray.hs +++ b/Text/EditDistance/STUArray.hs @@ -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 diff --git a/Text/EditDistance/SquareSTUArray.hs b/Text/EditDistance/SquareSTUArray.hs --- a/Text/EditDistance/SquareSTUArray.hs +++ b/Text/EditDistance/SquareSTUArray.hs @@ -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 diff --git a/Text/EditDistance/Tests.hs b/Text/EditDistance/Tests.hs --- a/Text/EditDistance/Tests.hs +++ b/Text/EditDistance/Tests.hs diff --git a/Text/EditDistance/Tests/EditOperationOntology.hs b/Text/EditDistance/Tests/EditOperationOntology.hs new file mode 100644 --- /dev/null +++ b/Text/EditDistance/Tests/EditOperationOntology.hs @@ -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 diff --git a/Text/EditDistance/Tests/Properties.hs b/Text/EditDistance/Tests/Properties.hs new file mode 100644 --- /dev/null +++ b/Text/EditDistance/Tests/Properties.hs @@ -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 diff --git a/edit-distance.cabal b/edit-distance.cabal --- a/edit-distance.cabal +++ b/edit-distance.cabal @@ -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 +copyright: (c) 2008-2013 Maximilian Bolinbroke +maintainer: Oleg Grenrus +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