diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Change Log + +All notable changes to this package are documented in this file. This project adheres to [Haskell PVP](https://pvp.haskell.org/) versioning. + +## 0.1.0.0 + +- Implement Levenshtein distance functions diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Taimoor Zaeem + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,63 @@ +# fuzzystrmatch-pg + +[![Build](https://github.com/taimoorzaeem/fuzzystrmatch-pg/actions/workflows/build.yml/badge.svg)](https://github.com/taimoorzaeem/fuzzystrmatch-pg/actions/workflows/build.yml) + +Haskell implementation of PostgreSQL extension/module [fuzzystrmatch](https://www.postgresql.org/docs/current/fuzzystrmatch.html). + +## Roadmap + +- [x] Levenshtein - Implement Levenshtein distance functions + +## Quick Start + +```haskell +import Data.FuzzyStrMatch (levenshtein) +import Data.Text + +kitten = "kitten" :: Text +sitting = "sitting" :: Text + +ghci> levenshtein kitten sitting +3 + +ghci> levenshteinLessEqual kitten sitting 3 +Just 3 + +-- Bounded version which exits early, hence much faster +ghci> levenshteinLessEqual kitten sitting 2 +Nothing +``` + +## Benchmark + +Benchmarking with `criterion` library: + +```haskell +let source = "aaaaaaaaaaaaaaaaaaaaaaaaaaaa" + target = "abababababababababababababababababababababababababababab" + maxD = 3 + +defaultMain + [ + bench "levenshtein" $ nf (levenshtein source) target + , bench "levenshteinLessEqual" $ nf (levenshteinLessEqual source target) maxD + ] +``` + +``` +benchmarking levenshtein +time 217.0 μs (214.5 μs .. 219.0 μs) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 212.9 μs (211.4 μs .. 214.6 μs) +std dev 5.201 μs (4.374 μs .. 6.315 μs) +variance introduced by outliers: 19% (moderately inflated) + +benchmarking levenshteinLessEqual +time 45.01 μs (44.79 μs .. 45.29 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 45.09 μs (44.86 μs .. 45.49 μs) +std dev 936.6 ns (617.6 ns .. 1.526 μs) +variance introduced by outliers: 17% (moderately inflated) +``` + +We believe that the difference would be much more on longer strings. diff --git a/fuzzystrmatch-pg.cabal b/fuzzystrmatch-pg.cabal new file mode 100644 --- /dev/null +++ b/fuzzystrmatch-pg.cabal @@ -0,0 +1,57 @@ +name: fuzzystrmatch-pg +version: 0.1.0.0 +synopsis: Determine string similarities and distance +description: Haskell implementation of PostgreSQL fuzzystrmatch + extension +license: MIT +license-file: LICENSE +author: Taimoor Zaeem +maintainer: Taimoor Zaeem +category: Data, Text, Algorithms +homepage: https://github.com/taimoorzaeem/fuzzystrmatch-pg +bug-reports: https://github.com/taimoorzaeem/fuzzystrmatch-pg/issues +build-type: Simple +extra-source-files: CHANGELOG.md +extra-doc-files: README.md +cabal-version: 1.18 + +tested-with: + GHC == 9.4.8 + , GHC == 9.6.6 + , GHC == 9.8.4 + , GHC == 9.10.1 + , GHC == 9.12.2 + +source-repository head + type: git + location: https://github.com/taimoorzaeem/fuzzystrmatch-pg + +library + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + hs-source-dirs: src + exposed-modules: Data.FuzzyStrMatch + Data.FuzzyStrMatch.Levenshtein + build-depends: base >= 4.9 && < 4.23 + , text >= 1.2.2 && < 2.2 + , vector >= 0.11 && < 0.14 + + ghc-options: -Wall -Wunused-packages + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + OverloadedStrings + hs-source-dirs: test/spec + main-is: Main.hs + other-modules: LevenshteinSpec + build-depends: base >= 4.9 && < 4.23 + , criterion + , fuzzystrmatch-pg + , hspec >= 2.3 && < 2.12 + , quickcheck-instances >= 0.3.33 && < 0.4 + , text >= 1.2.2 && < 2.2 + + ghc-options: -Wall -Wunused-packages diff --git a/src/Data/FuzzyStrMatch.hs b/src/Data/FuzzyStrMatch.hs new file mode 100644 --- /dev/null +++ b/src/Data/FuzzyStrMatch.hs @@ -0,0 +1,22 @@ +{- | +Module : Data.FuzzyStrMatch +Description : Export all string matching functions +Copyright : (c) 2026 Taimoor Zaeem +License : MIT +Maintainer : Taimoor Zaeem +Stability : Experimental +Portability : Portable + +Determine string similarities and distance +-} +module Data.FuzzyStrMatch + ( + -- * API + levenshtein + , levenshteinWithCosts + , levenshteinLessEqual + , levenshteinLessEqualWithCosts + ) + where + +import Data.FuzzyStrMatch.Levenshtein diff --git a/src/Data/FuzzyStrMatch/Levenshtein.hs b/src/Data/FuzzyStrMatch/Levenshtein.hs new file mode 100644 --- /dev/null +++ b/src/Data/FuzzyStrMatch/Levenshtein.hs @@ -0,0 +1,276 @@ +{- | +Module : Data.FuzzyStrMatch.Levenshtein +Description : Calculate Levenshtein distances between texts +Copyright : (c) 2026 Taimoor Zaeem +License : MIT +Maintainer : Taimoor Zaeem +Stability : Experimental +Portability : Portable + +Calculate levenshtein distance between strings +-} +{-# LANGUAGE RecordWildCards #-} +module Data.FuzzyStrMatch.Levenshtein + ( levenshtein + , levenshteinWithCosts + , levenshteinLessEqual + , levenshteinLessEqualWithCosts + ) +where + +import qualified Data.Vector.Unboxed.Mutable as MVU +import qualified Data.Text as T + +import Control.Monad.ST (runST, ST) +import Data.Text (Text) +import Prelude + +-- Function Signatures taken from: +-- https://www.postgresql.org/docs/current/fuzzystrmatch.html + +-- Algorithm: +-- https://en.wikipedia.org/wiki/Wagner–Fischer_algorithm + +-- We have 3 popular vector implementation: +-- 1. Data.Vector +-- Linked-List implemenataion, allows thunks/laziness +-- 2. Data.Vector.Unboxed +-- Continuously allocated, much faster for primitive types, strict evaluation +-- 3. Data.Vector.Storable +-- C Compatible memory layout, used in FFI +-- +-- Each of these also have a mutable implementation: +-- 1. Data.Vector.Mutable +-- 2. Data.Vector.Unboxed.Mutable +-- 3. Data.Vector.Storable.Mutable +-- +-- Considering that we only store Int types and that we need +-- mutability + don't need laziness, the right data structure to +-- use here is "Unboxed Mutable Vector". + +-- | Levenshtein distance state +data LState s = LState { + source :: Text + , target :: Text + , sLen :: Int + , tLen :: Int + , prev :: MVU.MVector s Int + , curr :: MVU.MVector s Int + , insCost :: Int + , delCost :: Int + , subCost :: Int + , maxD :: Maybe Int +} + +-- | Initialize the state +initLState :: Text -> Text -> Int -> Int -> Int -> Maybe Int -> ST s (LState s) +initLState s t ins del sub maxD = do + let sLen = T.length s + tLen = T.length t + -- We always keep the larger string on the x-axis, helpes implementation + -- For costs, we have to switch ins and del cost when source >= target + sourceLenGreater = sLen >= tLen + (s',t',sLen',tLen',ins',del') = + if sourceLenGreater + then (t,s,tLen,sLen,del,ins) + else (s,t,sLen,tLen,ins,del) + + prev <- MVU.new $ tLen' + 1 + -- Init: [0,1,2,..,tLen] for default 1 cost of insertion + -- Init: [0,2,4,..,tLen * 2] for cost of insertion equal 2 and so on + _ <- mapFromUpto 0 tLen' (\i -> do + MVU.write prev i (i * ins') + return False + ) + + curr <- MVU.new $ tLen' + 1 + return $ LState s' t' sLen' tLen' prev curr ins' del' sub maxD + +-- Calculation Matrix For Wagner-Fisher algorithm: +-- ============================================== +-- +-- deletion cost, 1 for each by default +-- | +-- | +---+---+---+---+---+---+---+ +-- v | S | I | T | T | I | N | G | +-- +---+---+---+---+---+---+---+---+ +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | <-- insertion 1 for each by default +-- +---|---+---+---+---+---+---+---+---+ +-- | K | 1 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | +-- +---|---+---+---+---+---+---+---+---+ +-- | I | 2 | 2 | 1 | 2 | 3 | 4 | 5 | 6 | +-- +---|---+---+---+---+---+---+---+---+ +-- | T | 3 | 3 | 2 | 1 | 2 | 3 | 4 | 5 | +-- +---|---+---+---+---+---+---+---+---+ +-- | T | 4 | 4 | 3 | 2 | 1 | 2 | 3 | 4 | +-- +---|---+---+---+---+---+---+---+---+ +-- | E | 5 | 5 | 4 | 3 | 2 | 2 | 3 | 4 | +-- +---|---+---+---+---+---+---+---+---+ +-- | N | 6 | 6 | 5 | 4 | 3 | 3 | 2 | 3 | <-- This is our answer!! +-- +---|---+---+---+---+---+---+---+---+ + +-- We only have to use two vectors prev and curr for calculation: +-- In this example: +-- +-- +---+---+---+---+---+---+---+ +-- | S | I | T | T | I | N | G | +-- +---+---+---+---+---+---+---+---+ +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | <-- prev +-- +---|---+---+---+---+---+---+---+---+ +-- | K | 1 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | <-- curr, becomes prev on next i +-- +---|---+---+---+---+---+---+---+---+ +-- | I | 2 | 2 | 1 | 2 | 3 | 4 | 5 | 6 | <-- becomes curr on next i and so on +-- . +-- . +-- . + +-- | +-- Calculate levenshtein distance between source and target string +-- +-- @ +-- >>> levenshtein "kitten" "sitting" +-- 3 +-- @ +levenshtein :: Text -> Text -> Int +levenshtein source target = levenshteinWithCosts source target 1 1 1 + +-- | +-- Calculate the levenshtein distance with different costs +-- +-- @ +-- >>> levenshteinWithCosts "kitten" "sitting" 1 1 2 +-- 5 +-- @ +-- +-- The costs correspond to insertion cost, deletion cost and substitution +-- cost respectively. In the above example, the total cost is @5@ because +-- there are 2 substitions, each with cost 2 and 1 deletion with cost 1. +levenshteinWithCosts :: Text -> Text -> Int -> Int -> Int -> Int +levenshteinWithCosts s t ins del sub = runST $ do + + lState@LState{..} <- initLState s t ins del sub Nothing + _ <- runLevenshtein lState + + MVU.read prev tLen -- The last one is the answer at target length position + +-- | Run Levenshtein algorithm +runLevenshtein :: LState s -> ST s Bool +runLevenshtein lState@LState{..} = do + exit <- mapFromUpto 0 (sLen - 1) $ calculateCurrentCostAndWrite lState + if exit then return True else return False + +-- | Calculate cost for all cells in the current row +calculateCurrentCostAndWrite :: LState s -> (Int -> ST s Bool) +calculateCurrentCostAndWrite lState@LState{..} i = do + -- Init: delete cost, goes like 1,2,3... for default 1 cost of deletion + -- Init: delete cost, goes like 2,4,6... for when cost of deletion is 2 and so on + MVU.write curr 0 ((i + 1) * delCost) + exit <- mapFromUpto 0 (tLen - 1) $ calculateCurrentCellCostAndWrite lState i + MVU.copy prev curr -- Copy current to previous before next iteration + if exit then return True else return False + +-- | Return closure/function/handler to compute the values in a row +-- This reads the current cell and write the minimum cost +-- after calculating insert cost, del cost and sub cost +calculateCurrentCellCostAndWrite :: LState s -> Int -> (Int -> ST s Bool) +calculateCurrentCellCostAndWrite LState{..} i j = do + subCost' <- MVU.read prev j + insCost' <- MVU.read prev (j + 1) + delCost' <- MVU.read curr j + + -- NOTE: Although T.index is unsafe, safety can be guaranteed through + -- outside bounds checking. + + -- If the character being compared are not equal, then it costs + -- substitution cost. + let curCost = if T.index source i == T.index target j then 0 else subCost + minCost = minimum [ insCost' + insCost, delCost' + delCost, subCost' + curCost ] + + MVU.write curr (j + 1) minCost + + return $ case maxD of + Nothing -> False + Just n -> minCost > n && i == (j+1) -- if we are on the diagonal and the minCost > maxD, we break + +-- | Map over the vector from index i to j and apply f on i +mapFromUpto :: Int -> Int -> (Int -> ST s Bool) -> ST s Bool +-- "s" is the type signature is a "Phantom Type" which is needed by GHC +-- state monad for type checking reasons. At runtime, "s" is nothing. So, +-- dont' worry about it too much +mapFromUpto i j f + | i > j = return False + | otherwise = do + exit <- f i + if exit then return True else mapFromUpto (i+1) j f + + +-- ======================== +-- Threshold Optimization: +-- https://en.wikipedia.org/wiki/Wagner-Fischer_algorithm#Possible_modifications +-- ========================= + +-- | +-- Calculate the levenshtein distance with an upper bound. If the cost is +-- more than maximum, it returns @Nothing@. +-- +-- @ +-- >>> levenshteinLessEqual "kitten" "sitting" 3 +-- Just 3 +-- @ +-- +-- @ +-- >>> levenshteinLessEqual "kitten" "sitting" 2 +-- Nothing +-- @ +-- +-- It is important to note that this doesn't necessarily calculate the +-- complete cost and exits early as soon as the minimum costs exceeds +-- bound, hence much faster. +levenshteinLessEqual :: Text -> Text -> Int -> Maybe Int +levenshteinLessEqual source target = levenshteinLessEqualWithCosts source target 1 1 1 + +-- | +-- Calculate the levenshtein distance with an upper bound with different +-- costs. It works same as `levenshteinWithCosts` but with an upper bound. +levenshteinLessEqualWithCosts :: Text -> Text -> Int -> Int -> Int -> Int -> Maybe Int +levenshteinLessEqualWithCosts s t ins del sub maxD' = runST $ do + + lState@LState{..} <- initLState s t ins del sub (Just maxD') + exit <- runLevenshtein lState + + if exit -- If exit if True, that means we have broken early, return Nothing + then return Nothing + else do + -- An edge case we need to check, if the iterations are complete, + -- we calculate the cost all the way for last row and then check + -- if this is greater than maxD + -- | +---+---+---+---+---+---+---+ + -- v | S | I | T | T | I | N | G | + -- +---+---+---+---+---+---+---+---+ + -- | 0 | | | | | | | | + -- +---|---+---+---+---+---+---+---+---+ + -- | K | 1 | 1 | | | | | | | + -- +---|---+---+---+---+---+---+---+---+ + -- | I | 2 | 2 | 1 | 2 | 3 | 4 | 5 | 6 | <- the diagnoal ends with cost 1 + -- +---|---+---+---+---+---+---+---+---+ but inserstion costs are added + -- + -- Transpose case for this: + -- | +---+---+---+ + -- v | S | I | T | -- We DON'T need to implement this case, + -- +---+---+---+---+ -- because we always choose the longer string + -- | 0 | | | | -- to be target INTERNALLY. + -- +---|---+---+---+---+ + -- | K | 1 | 1 | | | + -- +---|---+---+---+---+ + -- | I | 2 | 2 | 1 | 2 | + -- +---|---+---+---+---+ + -- | T | 3 | 3 | 2 | 1 | <- exit here, no need to calculate further + -- +---|---+---+---+---+ + -- | T | 4 | 4 | 3 | 2 | + -- +---|---+---+---+---+ + -- | E | 5 | 5 | 4 | 3 | + -- +---|---+---+---+---+ + -- | N | 6 | 6 | 5 | 4 | <-- This is our answer, but we need to exit early + -- +---|---+---+---+---+ + d <- MVU.read prev tLen + return $ if d > maxD' then Nothing else Just d diff --git a/test/spec/LevenshteinSpec.hs b/test/spec/LevenshteinSpec.hs new file mode 100644 --- /dev/null +++ b/test/spec/LevenshteinSpec.hs @@ -0,0 +1,76 @@ +module LevenshteinSpec where + +import qualified Data.Text as T + +import Data.Text (Text) +import Data.FuzzyStrMatch.Levenshtein + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck.Instances () -- imports instances only +import Prelude + +empty :: Text +empty = "" + +kitten :: Text +kitten = "kitten" + +sitting :: Text +sitting = "sitting" + +-- TODO: Test very large strings +spec :: Spec +spec = do + describe "Test Levenshtein Distance" $ do + context "should be 0 when inputs are equal" $ do + prop "when both are non-empty strings" $ do + \txt -> levenshtein txt txt `shouldBe` 0 + + it "when both are empty strings" $ + levenshtein empty empty `shouldBe` 0 + + context "distance should be equal to expectation" $ do + it "should be 3 between kitten and sitting" $ + levenshtein kitten sitting `shouldBe` 3 + + prop "when one argument is empty, distance should be length of other arg" $ do + \source -> levenshtein source empty == (T.length source) + + context "order of arguments should not matter" $ do + prop "application is commutative" $ + \source target -> levenshtein source target == (levenshtein target source) + + context "levenshtein with different costs" $ do + it "insertion cost is doubled" $ + levenshteinWithCosts empty kitten 2 1 1 `shouldBe` 12 -- 6 insertions, so we get 12 + + it "deletion cost is doubled" $ + levenshteinWithCosts kitten empty 1 2 1 `shouldBe` 12 -- 6 deletions, so we get 12 + + it "substitution cost is doubled" $ + levenshteinWithCosts kitten sitting 1 1 2 `shouldBe` 5 -- 2 substitutions + 1 deletion, so we get (2 * 2) + 1 = 5 + + prop "if arguments order is switched, the result is same when switching insert and delete cost" $ + \source target cost -> if cost > 0 then levenshteinWithCosts source target cost 1 1 == levenshteinWithCosts target source 1 cost 1 else True + + + -- ================================ + -- Tests for "levenshteinLessEqual" + -- ================================ + context "levenshtein less equal" $ do + prop "for all successful result, it should be less than maxD" $ + \source target maxD -> + case levenshteinLessEqual source target maxD of + Just d -> d <= maxD + Nothing -> True + + prop "for all successful result, it should be equal to their levenstehin" $ + \source target maxD -> + case levenshteinLessEqual source target maxD of + Just d -> d == levenshtein source target + Nothing -> True + + it "test on kitten and sitting example" $ do + levenshteinLessEqual kitten sitting 3 `shouldBe` (Just 3) + levenshteinLessEqual kitten sitting 2 `shouldBe` Nothing diff --git a/test/spec/Main.hs b/test/spec/Main.hs new file mode 100644 --- /dev/null +++ b/test/spec/Main.hs @@ -0,0 +1,45 @@ +module Main + ( main ) + where + +import qualified Criterion.Main as C +import qualified Test.Hspec as HS + +import qualified LevenshteinSpec + +import Data.FuzzyStrMatch.Levenshtein +import Test.Hspec.Runner +import Prelude + +specs :: Spec +specs = do + HS.describe "Run all tests" $ do + LevenshteinSpec.spec + +main :: IO () +main = do + summary <- hspecWithResult defaultConfig + { configColorMode = ColorAuto + } specs + + putStrLn $ "Total tests: " ++ show (summaryExamples summary) + putStrLn $ "Failures: " ++ show (summaryFailures summary) + + -- ========= + -- Benchmark: + -- ========= + -- TODO: Use more examples, for now this will do + let source = "aaaaaaaaaaaaaaaaaaaaaaaaaaaa" + target = "abababababababababababababababababababababababababababab" + + -- We evaluate to normal form, because we want full evaluation + C.defaultMain + [ + -- According to bench mark, a full distance calculation time = ~225 us + -- In comparison, bounded calculation time = ~50 us + + -- Hence proving that this exits early as soon as the bound hits, I + -- believe the difference would be even larger for bigger strings + C.bench "levenshtein" $ C.nf (levenshtein source) target + , C.bench "levenshteinLessEqual" $ C.nf (levenshteinLessEqual source target) 3 + ]