diff --git a/Data/TST.hs b/Data/TST.hs new file mode 100644 --- /dev/null +++ b/Data/TST.hs @@ -0,0 +1,133 @@ +-- | Implementation of a Ternary Search Tree: +-- , which is a structure +-- useful to store any list-like thing. It is quite resistant to non-random +-- data without needing rebalancing and can be as fast or faster than hash +-- tables. +-- +-- The usual finite map operations are provided, plus utilities to match +-- wildcarded words efficiently. +module Data.TST + ( -- * Types + TST + -- * Operations + , empty + , singleton + , insert + , insertWith + , lookup + , delete + , toList + , fromList + + -- * Wildcards + , WildCard (..) + , WildList + , matchWL + ) where + +import Control.Arrow (first) +import Prelude hiding (lookup) + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ TST ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +data TST sym v = Branch !sym !(TST sym v) !(TST sym v) !(TST sym v) + | End v !(TST sym v) + | Null + +instance (Ord sym, Eq v) => Eq (TST sym v) where + t1 == t2 = toList t1 == toList t2 + +instance (Show sym, Ord sym, Show v) => Show (TST sym v) where + show t1 = "fromList " ++ show (toList t1) + +empty :: Ord sym => TST sym v +empty = Null + +singleton :: Ord sym => [sym] -> v -> TST sym v +singleton [] v = End v Null +singleton (c : s) v = Branch c Null (singleton s v) Null + +insertWith :: Ord sym => (v -> v -> v) -> [sym] -> v -> TST sym v -> TST sym v +insertWith _ s v Null = singleton s v +insertWith f [] v (End v' t) = End (f v v') t +insertWith f [] v (Branch c l m r) = Branch c (insertWith f [] v l) m r +insertWith f (c : s) v (End v' t) = End v' (insertWith f (c : s) v t) +insertWith f (c : s) v (Branch c' l m r) = + case compare c c' of + LT -> Branch c' (insertWith f (c : s) v l) m r + EQ -> Branch c' l (insertWith f s v m) r + GT -> Branch c' l m (insertWith f (c : s) v r) + +insert :: Ord sym => [sym] -> v -> TST sym v -> TST sym v +insert = insertWith const + +lookup :: Ord sym => [sym] -> TST sym v -> Maybe v +lookup _ Null = Nothing +lookup [] (End v _) = Just v +lookup [] (Branch _ l _ _) = lookup [] l +lookup (c : s) (End _ t) = lookup (c : s) t +lookup (c : s) (Branch c' l m r) = case compare c c' of + LT -> lookup (c : s) l + EQ -> lookup s m + GT -> lookup (c : s) r + +-- | We don't need this and it's slow. But you've got to have a `delete'! +delete :: Ord sym => [sym] -> TST sym v -> TST sym v +delete s0 t0 = go id id t0 s0 t0 + where + go hole _ root _ Null = + hole root + go hole _ root [] (End _ _) = + hole (fromList (purge root)) + go hole partial _ [] (Branch c l m r) = + go (\t' -> hole (partial (Branch c t' m r))) id l [] l + go hole partial root (_ : s) (End v t) = + go (hole . partial . End v) id root s t + go hole partial root (c : s) (Branch c' l m r) = + case compare c c' of + LT -> go (\t -> hole (partial (Branch c' t m r))) id l (c : s) l + EQ -> go hole (\t -> partial (Branch c' l t r)) root s m + GT -> go (\t -> hole (partial (Branch c' l m t))) id r (c : s) r + + -- This can be made faster + purge Null = error "Language.Distance.Search.TST.delete.purge" + purge (End _ t) = toList t + purge (Branch c l m r) = toList l ++ map (first (c :)) (purge m) ++ toList r + +toList :: Ord sym => TST sym v -> [([sym], v)] +toList Null = [] +toList (End v t) = ([], v) : toList t +toList (Branch c l m r) = toList l ++ map (first (c :)) (toList m) ++ toList r + +fromList :: Ord sym => [([sym], v)] -> TST sym v +fromList = foldr (uncurry insert) empty + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Wildcards ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +data WildCard a = WildCard + | El a + deriving (Eq, Ord) + +instance Show a => Show (WildCard a) where + show WildCard = "*" + show (El c) = show c + +type WildList a = [WildCard a] + +matchWL :: Ord sym => WildList sym -> TST sym v -> [([sym], v)] +matchWL _ Null = [] +matchWL [] (End v _) = [([], v)] +matchWL [] (Branch _ l _ _) = matchWL [] l +matchWL (c : s) (End _ t) = matchWL (c : s) t +matchWL (c : s) (Branch c' l m r) = let left = matchWL (c : s) l + middle = map (first (c' :)) (matchWL s m) + right = matchWL (c : s) r + in case (c, compare c (El c')) of + (WildCard, _ ) -> left ++ middle ++ right + (_, LT) -> left + (_, EQ) -> middle + (_, GT) -> right diff --git a/Data/TSTSet.hs b/Data/TSTSet.hs new file mode 100644 --- /dev/null +++ b/Data/TSTSet.hs @@ -0,0 +1,55 @@ +-- | A wrapper for @'TST' sym ()@. +module Data.TSTSet + ( -- * Types + TSTSet + -- * Operations + , empty + , singleton + , insert + , member + , delete + , toList + , fromList + + -- * Wildcards + , TST.WildCard (..) + , TST.WildList + , matchWL + ) where + +import Prelude hiding (lookup) + +import Data.TST (TST, WildList) +import qualified Data.TST as TST + +newtype TSTSet sym = TSTSet {unTSTSet :: TST sym ()} + +instance Ord sym => Eq (TSTSet sym) where + t1 == t2 = toList t1 == toList t2 + +instance (Show sym, Ord sym) => Show (TSTSet sym) where + show t1 = "fromList " ++ show (toList t1) + +empty :: Ord sym => TSTSet sym +empty = TSTSet TST.empty + +singleton :: Ord sym => [sym] -> TSTSet sym +singleton s = TSTSet $ TST.singleton s () + +insert :: Ord sym => [sym] -> TSTSet sym -> TSTSet sym +insert s = TSTSet . TST.insert s () . unTSTSet + +member :: Ord sym => [sym] -> TSTSet sym -> Bool +member s (TSTSet tst) = TST.lookup s tst == Just () + +delete :: Ord sym => [sym] -> TSTSet sym -> TSTSet sym +delete s = TSTSet . TST.delete s . unTSTSet + +toList :: Ord sym => TSTSet sym -> [[sym]] +toList = map fst . TST.toList . unTSTSet + +fromList :: Ord sym => [[sym]] -> TSTSet sym +fromList = TSTSet . TST.fromList . map (\s -> (s, ())) + +matchWL :: Ord sym => WildList sym -> TSTSet sym -> [[sym]] +matchWL s = map fst . TST.matchWL s . unTSTSet diff --git a/Language/Distance.hs b/Language/Distance.hs new file mode 100644 --- /dev/null +++ b/Language/Distance.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Generic interface to calculate the edit instance between two list-like +-- things using various algorithms. +-- +-- Right now, two algorithms are provided, 'Levenshtein' and +-- 'DamerauLevenshtein'. +module Language.Distance + ( -- * Types + Distance + , getDistance + , EditDistance (..) + -- * Algorithms + -- ** Levenshtein + , Levenshtein + , levenshtein + -- ** Damerau-Levenshtein + , DamerauLevenshtein + , damerauLevenshtein + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM_, foldM_) +import Control.Monad.ST (runST, ST) +import Data.Monoid ((<>)) +import Prelude hiding ((!!)) + +import Data.ByteString (ByteString) +import Data.ListLike (ListLike) +import qualified Data.ListLike as ListLike +import Data.ListLike.Text () +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Vector.Unboxed.Mutable (STVector, Unbox) +import qualified Data.Vector.Unboxed.Mutable as Vector + +import Language.Distance.Internal + + +{-| +Generic typeclass for edit distances. Specify the type manually to use a +specific algorithm, for instance + +@ +distance \"foo\" \"bar\" :: 'Distance' 'DamerauLevenshtein' +@ + +Monomorphic functions are also provided, see 'levenshtein' and +'damerauLevenshtein'. +-} +class EditDistance sym algo where + distance :: ListLike full sym => full -> full -> Distance algo + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Levenshtein ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- | The classic Levenshtein distance, where adding, removing or changing a +-- character are taken into account. +-- +-- More information: . +data Levenshtein + +instance Eq sym => EditDistance sym Levenshtein where + distance = levenshtein + +levenshtein :: (ListLike full sym, Eq sym) => full -> full -> Distance Levenshtein +levenshtein s1 s2 = runST $ do v <- Vector.replicate ((len1 + 1) * (len2 + 1)) 0 + mapM_ (\r -> Vector.write v (ix r 0) r) [0..len1] + mapM_ (\c -> Vector.write v (ix 0 c) c) [0..len2] + forM_ [(r, c) | r <- [1..len1], c <- [1..len2]] (go v) + Distance <$> vlast v + where + len1 = ListLike.length s1 + len2 = ListLike.length s2 + ix r c = r * (len2 + 1) + c + go v (r, c) = do d1 <- (+1) <$> Vector.read v (ix (r - 1) c) + d2 <- (+1) <$> Vector.read v (ix r (c - 1)) + d3 <- (if s1 !! (r - 1) == s2 !! (c - 1) then id else (+1)) + <$> Vector.read v (ix (r - 1) (c - 1)) + Vector.write v (ix r c) (min3 d1 d2 d3) +{-# SPECIALISE levenshtein :: String -> String -> Distance Levenshtein #-} +{-# SPECIALISE levenshtein :: ByteString -> ByteString -> Distance Levenshtein #-} +{-# SPECIALISE levenshtein :: Text -> Text -> Distance Levenshtein #-} + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Damerau-Levenshtein ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- | Like 'Levenshtein', but transpositions are also taken into account: +-- . +data DamerauLevenshtein + +instance Ord sym => EditDistance sym DamerauLevenshtein where + distance = damerauLevenshtein + +damerauLevenshtein + :: (ListLike full sym, Ord sym) => full -> full -> Distance DamerauLevenshtein +damerauLevenshtein s1 s2 + | ListLike.null s1 = Distance (ListLike.length s2) + | ListLike.null s2 = Distance (ListLike.length s1) + | otherwise = runST $ do v <- Vector.replicate ((len1 + 2) * (len2 + 2)) 0 + let inf = (len1 + len2) + Vector.write v 0 inf + mapM_ (\r -> Vector.write v (ix (r + 1) 0) inf >> + Vector.write v (ix (r + 1) 1) r) [0..len1] + mapM_ (\c -> Vector.write v (ix 0 (c + 1)) inf >> + Vector.write v (ix 1 (c + 1)) c) [0..len2] + foldM_ (go1 v) chPos' [1..len1] + Distance <$> vlast v + where + len1 = ListLike.length s1 + len2 = ListLike.length s2 + ix r c = r * (len2 + 2) + c + chPos' = ListLike.foldr (\ch -> Map.insert ch 0) Map.empty (s1 <> s2) + go1 v chPos r = do foldM_ (go2 v chPos r) 0 [1..len2] + return (Map.insert (s1 !! (r - 1)) r chPos) + go2 v chPos r db c = + let ch1 = s1 !! (r - 1) + ch2 = s2 !! (c - 1) + r1 = chPos Map.! ch2 + c1 = db + in do d1 <- Vector.read v (ix r c) + (d2, db') <- if ch1 == ch2 then return (d1, c) + else do d3 <- Vector.read v (ix (r + 1) c) + d4 <- Vector.read v (ix r (c + 1)) + return (min3 d1 d3 d4 + 1, db) + d5 <- (\n -> n + (r - r1 - 1) + 1 + (c - c1 - 1)) <$> + Vector.read v (ix r1 c1) + Vector.write v (ix (r + 1) (c + 1)) (min d2 d5) + return db' +{-# SPECIALISE damerauLevenshtein :: String -> String -> Distance DamerauLevenshtein #-} +{-# SPECIALISE damerauLevenshtein :: ByteString -> ByteString -> Distance DamerauLevenshtein #-} +{-# SPECIALISE damerauLevenshtein :: Text -> Text -> Distance DamerauLevenshtein #-} + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Hamming ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Longest Common Subsequence ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Utils ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +min3 :: Ord a => a -> a -> a -> a +min3 x y z = min x (min y z) + +(!!) :: ListLike full sym => full -> Int -> sym +(!!) = ListLike.index + +vlast :: Unbox a => STVector s a -> ST s a +vlast v = Vector.read v (Vector.length v - 1) diff --git a/Language/Distance/Internal.hs b/Language/Distance/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Distance/Internal.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | This module lets you tamper with 'Distance' - in other words you can give +-- it whatever phantom type since the constructor is exported. +-- +-- The only use for this module is to construct new 'Distance' data when +-- writing 'EditDistance' instances, but be careful not to change the phantom +-- type of existing 'Distance's! +module Language.Distance.Internal (Distance (..)) where + +newtype Distance algo = Distance {getDistance :: Int} + deriving (Eq, Ord, Show) diff --git a/Language/Distance/Search.hs b/Language/Distance/Search.hs new file mode 100644 --- /dev/null +++ b/Language/Distance/Search.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | The 'Search' typeclass lets you build dictinaries and then query them to +-- find words close to a given one. +-- +-- Right now two data types are provided: 'TST.TST' and 'BK.BK', monomorphic +-- functions are provided as well. The difference is in performance: +-- 'TST.TST' is faster for low distances (less than 3) but impractical for +-- larger ones, where 'BK.BK' is more suited. See the specific modules for +-- more info. +module Language.Distance.Search + ( Search (..) + , TSTDist (..) + , BKDist (..) + ) where + +import Data.ListLike (ListLike) +import qualified Data.ListLike as ListLike + +import Data.TSTSet (TSTSet) +import qualified Data.TSTSet as TSTSet +import Language.Distance +import Language.Distance.Search.BK (BKTree) +import qualified Language.Distance.Search.BK as BK +import Language.Distance.Search.Class +import qualified Language.Distance.Search.TST as TST + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ TST Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- | We need to wrap 'TSTSet' in a newtype because we need the algorithm and the +-- container have to depend on the type. +newtype TSTDist full sym algo = TSTDist {getTST :: TSTSet sym} + +instance (Ord sym, ListLike full sym, EditDistance sym Levenshtein) + => Search (TSTDist full sym Levenshtein) full Levenshtein where + empty = TSTDist TST.empty + insert ll = TSTDist . TST.insert ll . getTST + query maxd s = TST.levenshtein maxd s . getTST + +instance (Ord sym, ListLike full sym, EditDistance sym DamerauLevenshtein) + => Search (TSTDist full sym DamerauLevenshtein) full DamerauLevenshtein where + empty = TSTDist TST.empty + insert ll = TSTDist . TSTSet.insert (ListLike.toList ll) . getTST + query maxd s = TST.damerauLevenshtein maxd s . getTST + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ BK Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +-- | Again, wrapping 'BKTree' to have the phantom types in place. +newtype BKDist full sym algo = BKDist {getBK :: BKTree full algo} + +instance (Eq sym, ListLike full sym, EditDistance sym algo) + => Search (BKDist full sym algo) full algo where + empty = BKDist BK.empty + insert s = BKDist . BK.insert s . getBK + query maxd s = BK.query maxd s . getBK diff --git a/Language/Distance/Search/BK.hs b/Language/Distance/Search/BK.hs new file mode 100644 --- /dev/null +++ b/Language/Distance/Search/BK.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | An implementation of 'Language.Distance.Search' based on a BK-tree: +-- . It performs reasonably, and it +-- scales decently as the query distance increases. Moreover the data +-- structure can work on any instance of 'EditDistance', or in fact any metric +-- space (although no interface for that purpose is defined): +-- . +-- +-- However, for very short distances (less than 3), +-- 'Language.Distance.Search.TST' is faster. +module Language.Distance.Search.BK + ( -- * Data type + BKTree + -- * Operations + , empty + , insert + , query + , levenshtein + , damerauLevenshtein + ) where + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Data.ListLike (ListLike) + +import Language.Distance (EditDistance (..), Levenshtein, DamerauLevenshtein) +import Language.Distance.Internal + +data BKTree full algo + = EmptyBK + | BKTree !full !(IntMap (BKTree full algo)) + +narrow :: Int -> Int -> IntMap a -> IntMap a +narrow n m im | n == m = IntMap.fromList (maybe [] (\v -> [(n, v)]) (IntMap.lookup n im)) +narrow n m im | otherwise = insMaybe m res pr + where + (_, pl, res0) = IntMap.splitLookup n im + (res, pr, _) = IntMap.splitLookup m (insMaybe n res0 pl) + insMaybe k im' = maybe im' (\v -> IntMap.insert k v im') + +empty :: BKTree full algo +empty = EmptyBK + +insert :: forall full sym algo. (Eq sym, EditDistance sym algo, ListLike full sym) + => full -> BKTree full algo -> BKTree full algo +insert str EmptyBK = BKTree str IntMap.empty +insert str bk@(BKTree str' bks) + | dist == 0 = bk + | otherwise = BKTree str' $ flip (IntMap.insert dist) bks $ + maybe (insert str EmptyBK) (insert str) (IntMap.lookup dist bks) + where dist = getDistance (distance str str' :: Distance algo) + +query :: forall full sym algo. (ListLike full sym, EditDistance sym algo) + => Int -> full -> BKTree full algo -> [(full, Distance algo)] +query _ _ EmptyBK = [] +query maxd str (BKTree str' bks) = match ++ concatMap (query maxd str) children + where + dist = distance str str' :: Distance algo + intDist = getDistance dist + match = if (intDist <= maxd) then [(str', dist)] else [] + children = IntMap.elems $ narrow (max (intDist - maxd) 0) (intDist + maxd) bks + +levenshtein :: (ListLike full sym, EditDistance sym Levenshtein) + => Int -> full -> BKTree full Levenshtein -> [(full, Distance Levenshtein)] +levenshtein = query + +damerauLevenshtein :: (ListLike full sym, EditDistance sym DamerauLevenshtein) + => Int -> full -> BKTree full DamerauLevenshtein + -> [(full, Distance DamerauLevenshtein)] +damerauLevenshtein = query diff --git a/Language/Distance/Search/Class.hs b/Language/Distance/Search/Class.hs new file mode 100644 --- /dev/null +++ b/Language/Distance/Search/Class.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Language.Distance.Search.Class (Search (..)) where + +import Data.ListLike (ListLike) + +import Language.Distance + +-- | Generic class for data structures that can perform queries retrieving words +-- close to a given one. +-- +-- Minimal definition: 'empty', 'insert', and 'query'. + +-- It would be nice to have the ListLike and EditDistance constraints on the +-- class, but I can't, see . +class Search container full algo | container -> full, container -> algo where + empty :: container + insert :: full -> container -> container + query :: Int -- ^ The maximum distance to search for + -> full -- ^ The starting word + -> container + -> [(full, Distance algo)] + + singleton :: full -> container + singleton str = insert str empty + + member :: full -> container -> Bool + member x = not . null . query 0 x + + fromList :: [full] -> container + fromList = foldr insert empty diff --git a/Language/Distance/Search/TST.hs b/Language/Distance/Search/TST.hs new file mode 100644 --- /dev/null +++ b/Language/Distance/Search/TST.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | An implementation of 'Search' based on a ternary search tree +-- ('Data.TSTSet'): . +-- +-- The searches are performed by manually generating the close word by +-- deleting, transposing, or adding wildcards to match additional characters. +-- +-- This makes this structure fast for small distances with a small number of +-- generated candidates, but impractical for even slightly larger distances - +-- in my tests 'Language.Distance.Search.BK' outpeforms this module when the +-- distance is greater than 2. +-- +-- The data structure has no knowledge of the distance and thus it does not +-- need to be rebuilt if different edit distances are needed. However this +-- means that it cannot work with arbitrary 'EditDistance' instances are +-- functions need to be defined manually to generate the candidates. In this +-- case 'levenshtein' uses 'deletions', 'replaces', and 'insertions' to +-- generate the candidates; while 'damerauLevenshtein' also uses +-- 'transpositions'. +module Language.Distance.Search.TST + ( -- * Type + TSTSet + -- * Operations + , TSTSet.empty + , insert + , levenshtein + , damerauLevenshtein + -- * Candidates generation + -- $Wildcard + -- ** Types + , WildCard (..) + , WildList + -- ** Operations + , deletions + , transpositions + , replaces + , insertions + ) where + +import Control.Arrow (first) +import Data.Word (Word8) + +import Data.ByteString (ByteString) +import Data.Text (Text) + +import Data.ListLike (ListLike) +import qualified Data.ListLike as ListLike +import Data.ListLike.Text () + +import Data.TST (WildCard (..), WildList) +import qualified Data.TST as TST +import Data.TSTSet (TSTSet) +import qualified Data.TSTSet as TSTSet +import Language.Distance (Levenshtein, DamerauLevenshtein) +import Language.Distance.Internal + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Edits ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +{- $Wildcard + +The following functions generate candidates distant 1 from the given word, and +they are reexported for completeness. + +'deletions' and 'transpositions' do not need to wildcard the word, while +'replaces' and 'insertions' do since we are adding characters. + +-} + +deletions, transpositions :: [a] -> [[a]] +replaces, insertions :: WildList a -> [WildList a] + +deletions [] = [] +deletions (c : s) = s : map (c :) (deletions s) + +transpositions [] = [] +transpositions [x] = [[x]] +transpositions (x : y : s) = (y : x : s) : map (x :) (transpositions (y : s)) + +replaces [] = [] +replaces (c : s) = (WildCard : s) : map (c :) (replaces s) + +insertions [] = [[WildCard]] +insertions (c : s) = (WildCard : c : s) : map (c :) (insertions s) + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +levenshtein :: (Ord sym, ListLike full sym) => Int -> full -> TSTSet sym + -> [(full, Distance Levenshtein)] +levenshtein = queryTST (\s -> deletions s ++ replaces s ++ insertions s) + +damerauLevenshtein :: (Ord sym, ListLike full sym) => Int -> full -> TSTSet sym + -> [(full, Distance DamerauLevenshtein)] +damerauLevenshtein = + queryTST (\s -> deletions s ++ replaces s ++ insertions s ++ transpositions s) + +insert :: (Ord sym, ListLike full sym) => full -> TSTSet sym -> TSTSet sym +insert ll = TSTSet.insert (ListLike.toList ll) +{-# SPECIALISE insert :: String -> TSTSet Char -> TSTSet Char #-} +{-# SPECIALISE insert :: ByteString -> TSTSet Word8 -> TSTSet Word8 #-} +{-# SPECIALISE insert :: Text -> TSTSet Char -> TSTSet Char #-} + +queryTST :: (Ord sym, ListLike full sym) + => (WildList sym -> [WildList sym]) + -> Int -> full -> TSTSet sym -> [(full, Distance algo)] +queryTST f maxd s tst = + map (first ListLike.fromList) $ TST.toList $ + go 0 TSTSet.empty [wildList $ ListLike.toList s] TST.empty + where + go n visited edits matches + | n <= maxd = let edits' = filter (\x -> not (TSTSet.member x visited)) edits + newMatches = zip (concatMap (flip TSTSet.matchWL tst) edits') + (map Distance (repeat n)) + in go (n + 1) (foldr TSTSet.insert visited edits') + (concatMap f edits') (update newMatches matches) + | otherwise = matches + + update new matches = foldr (uncurry (TST.insertWith (flip const))) matches new +{-# SPECIALISE queryTST :: (WildList Char -> [WildList Char]) + -> Int -> String -> TSTSet Char + -> [(String, Distance algo)] #-} +{-# SPECIALISE queryTST :: (WildList Word8 -> [WildList Word8]) + -> Int -> ByteString -> TSTSet Word8 + -> [(ByteString, Distance algo)] #-} +{-# SPECIALISE queryTST :: (WildList Char -> [WildList Char]) + -> Int -> Text -> TSTSet Char + -> [(Text, Distance algo)] #-} + +wildList :: ListLike full sym => full -> WildList sym +wildList = map El . ListLike.toList diff --git a/Language/Phonetic.hs b/Language/Phonetic.hs new file mode 100644 --- /dev/null +++ b/Language/Phonetic.hs @@ -0,0 +1,7 @@ +module Language.Phonetic + ( module Language.Phonetic.Encoder + , module Language.Phonetic.Soundex + ) where + +import Language.Phonetic.Encoder +import Language.Phonetic.Soundex diff --git a/Language/Phonetic/Encoder.hs b/Language/Phonetic/Encoder.hs new file mode 100644 --- /dev/null +++ b/Language/Phonetic/Encoder.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Phonetic.Encoder (Encoder (..)) where + +import qualified Data.Set as Set + +import Data.ListLike (ListLike) +import qualified Data.ListLike as ListLike + +import Language.Phonetic.Internal + + +class Encoder enc where + alphabet :: Alphabet enc + encodeUnsafe :: ListLike full Char => full -> Code enc + + encode :: ListLike full Char => full -> Maybe (Code enc) + encode ll | ListLike.all (flip Set.member alph) ll = Just (encodeUnsafe ll) + | otherwise = Nothing + where alph = getAlphabet (alphabet :: Alphabet enc) diff --git a/Language/Phonetic/Internal.hs b/Language/Phonetic/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Phonetic/Internal.hs @@ -0,0 +1,8 @@ +module Language.Phonetic.Internal where + +import Data.ByteString (ByteString) + +import Data.Set (Set) + +newtype Code enc = Code {getCode :: ByteString} deriving (Eq, Show) +newtype Alphabet enc = Alphabet {getAlphabet :: Set Char} deriving (Eq, Show) diff --git a/Language/Phonetic/Soundex.hs b/Language/Phonetic/Soundex.hs new file mode 100644 --- /dev/null +++ b/Language/Phonetic/Soundex.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE EmptyDataDecls #-} +module Language.Phonetic.Soundex where + +import Data.Char (toUpper) +import Data.Word (Word8) + +import Data.Array (Array) +import qualified Data.Array as Array +import qualified Data.ByteString.Char8 as ByteString +import qualified Data.Set as Set + +import qualified Data.ListLike as ListLike + +import Language.Phonetic.Encoder +import Language.Phonetic.Internal + + +table :: Array Char (Either Bool Word8) +table = Array.array ('A', 'Z') + [ ('A', Left True ), ('B', Right 1 ), ('C', Right 2 ), + ('D', Right 3 ), ('E', Left True ), ('F', Right 1 ), + ('G', Right 2 ), ('H', Left False), ('I', Left True ), + ('J', Right 2 ), ('K', Right 2 ), ('L', Right 4 ), + ('M', Right 5 ), ('N', Right 5 ), ('O', Left True ), + ('P', Right 1 ), ('Q', Right 2 ), ('R', Right 6 ), + ('S', Right 2 ), ('T', Right 3 ), ('U', Left True ), + ('V', Right 1 ), ('W', Left False), ('X', Right 2 ), + ('Y', Left True ), ('Z', Right 2 ) ] + +data Soundex + +instance Encoder Soundex where + alphabet = Alphabet $ Set.fromList (letters ++ map toUpper letters) + where letters = "abcdefghijklmnopqrstuvwxyz" + + encodeUnsafe ll = + case map toUpper (ListLike.toList ll) of + [] -> error "Language.Phonetic.Soundex.encode" + (c : s) -> Code . ByteString.pack . (c :) . pad . map toDigit . + (go1 (table Array.! c)) . map (table Array.!) $ s + where + pad (b1 : b2 : b3 : _) = [b1, b2, b3] + pad bs = bs ++ replicate (3 - length bs) '0' + + go1 (Left _) s = go2 s + go1 (Right n) s = collapse n s + + go2 [] = [] + go2 (Right n : s) = n : collapse n s + go2 (Left _ : s) = go2 s + + collapse _ [] = [] + collapse n (Right n' : l) | n == n' = collapse n l + | otherwise = go2 (Right n' : l) + collapse _ (Left True : l) = go2 l + collapse n (Left False : l) = collapse n l + + toDigit = head . (show :: Word8 -> String) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench.hs b/bench.hs new file mode 100644 --- /dev/null +++ b/bench.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Control.Applicative ((<$>)) + +import Data.Char (toLower) +import Data.Monoid (Last (..)) + +import Control.DeepSeq (NFData) +import qualified Data.ByteString.Char8 as ByteString +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time.Clock.POSIX (getPOSIXTime) + +import Criterion.Config +import Criterion.Main +import Data.ListLike.Text () +import System.Random.Shuffle + +import Language.Distance.Internal (Distance (..)) +import qualified Language.Distance.Search.BK as BK +import qualified Language.Distance.Search.TST as TST + + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Utils and dictionaries ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +everyN n xs = case drop n xs of + [] -> [] + (x : xs') -> x : everyN n xs' + +-- We get every 20 words since testing with the whole dict is too much +dict m lin read_ = (map (m toLower)) . everyN 20 . lin <$> read_ "/usr/share/dict/words" + +dictS = dict map lines readFile + +dictBS = dict ByteString.map ByteString.lines ByteString.readFile + +dictT = dict Text.map Text.lines Text.readFile + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +deriving instance NFData (Distance algo) + +query queryc n ss dist = map (\s -> queryc n s dist) ss + +group1 emptyc insertc queryc ss rand1ss rand2ss name = + dist `seq` distRand `seq` + [ bench ("insert " ++ name) $ whnf (foldr insertc emptyc) ss + , bench ("insert rand " ++ name) $ whnf (foldr insertc emptyc) rand1ss + , bench ("lookup " ++ name) $ nf (query queryc 0 rand2ss) dist + , bench ("lookup rand " ++ name) $ nf (query queryc 0 rand2ss) distRand + , bench ("query 1 " ++ name) $ nf (query queryc 1 (take 100 rand2ss)) dist + , bench ("query 1 rand " ++ name) $ nf (query queryc 1 (take 100 rand2ss)) distRand + , bench ("query 2 " ++ name) $ nf (query queryc 2 (take 100 rand2ss)) dist + , bench ("query 2 rand " ++ name) $ nf (query queryc 2 (take 100 rand2ss)) distRand + ] + where + dist = foldr insertc emptyc ss + distRand = foldr insertc emptyc rand1ss + +#define group2(NAME, TYPE, SS, RAND1SS, RAND2SS, EMPTY, INSERT, LEVEN, DAMLEV) \ + (bgroup (NAME ++ " " ++ TYPE) \ + ((group1 EMPTY INSERT LEVEN SS RAND1SS RAND2SS "lev") ++ \ + (group1 EMPTY INSERT LEVEN SS RAND1SS RAND2SS "dam-lev"))) + +group3 ss rand1ss rand2ss = + [ group2("tst", "string", ss, rand1ss, rand2ss, TST.empty, TST.insert, + TST.levenshtein, TST.damerauLevenshtein) + , group2("tst", "bytestring", bss, rand1bss, rand2bss, TST.empty, TST.insert, + TST.levenshtein, TST.damerauLevenshtein) + , group2("tst", "text", ts, rand1ts, rand2ts, TST.empty, TST.insert, TST.levenshtein, + TST.damerauLevenshtein) + , group2("bk", "string", ss, rand1ss, rand2ss, BK.empty, BK.insert, BK.levenshtein, + BK.damerauLevenshtein) + , group2("bk", "bytestring", bss, rand1bss, rand2bss, BK.empty, BK.insert, + BK.levenshtein, BK.damerauLevenshtein) + , group2("bk", "text", ts, rand1ts, rand2ts, BK.empty, BK.insert, BK.levenshtein, + BK.damerauLevenshtein) + ] + where + bss = map ByteString.pack ss + rand1bss = map ByteString.pack rand1ss + rand2bss = map ByteString.pack rand2ss + ts = map Text.pack ss + rand1ts = map Text.pack rand1ss + rand2ts = map Text.pack rand2ss + +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~ Distance ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- + +main = do ss <- dictS + rand1ss <- shuffleM ss + rand2ss <- shuffleM ss + fn <- (++ ".html") . (show :: Integer -> String) . ceiling <$> + getPOSIXTime + let config = defaultConfig { cfgReport = (Last (Just fn)) + , cfgSamples = (Last (Just 100)) + } + defaultMainWith config (return ()) (group3 ss rand1ss rand2ss) diff --git a/language-spelling.cabal b/language-spelling.cabal new file mode 100644 --- /dev/null +++ b/language-spelling.cabal @@ -0,0 +1,79 @@ +Cabal-Version: >= 1.8 +Name: language-spelling +Version: 0.1 +Author: Francesco Mazzoli (f@mazzo.li) +Maintainer: Francesco Mazzoli (f@mazzo.li) +Build-Type: Simple +License: PublicDomain +Build-Type: Simple +Category: Foreign binding, Text +Synopsis: Various tools to detect/correct mistakes in words +Tested-With: GHC==7.4.1 +Homepage: https://github.com/bitonic/language-spelling +Bug-Reports: https://github.com/bitonic/language-spelling/issues +Description: + Haskell library meant to be a set of tools to correct spelling mistakes, + homophones, and OCR errors. + . + Sample session: + . + @ + ghci> :m + Language.Distance.Search.BK + ghci> distance \"foo\" \"bar\" :: Distance DamerauLevenshtein + 3 + ghci> let bk = foldr insert empty [\"foo\", \"foa\", \"fooa\", \"ofo\", \"arstu\", \"nana\", \"faa\"] :: BKTree String 'DamerauLevenshtein' + ghci> query 0 \"foo\" bk + [(\"foo\",Distance 0)] + ghci> query 2 \"foo\" bk + [(\"faa\",Distance 2),(\"foa\",Distance 1),(\"fooa\",Distance 1),(\"foo\",Distance 0),(\"ofo\",Distance 1)] + @ + . + TODO: + . + * Phonetic algorithms: metaphone, double metaphone, maybe others + . + * Tests and better benchmarking + . + * Cost tuning when searching + +source-repository head + type: git + location: git://github.com/bitonic/language-spelling.git + +Library + Build-Depends: base >= 3 && < 5, + array, + bytestring, + containers, + ListLike, + listlike-instances, + text, + vector >= 0.5 + + GHC-Options: -Werror -O2 + + Exposed-Modules: Language.Distance, + Language.Distance.Internal, + Language.Distance.Search, + Language.Distance.Search.Class, + Language.Distance.Search.BK, + Language.Distance.Search.TST, + Language.Phonetic, + Language.Phonetic.Encoder, + Language.Phonetic.Soundex, + Language.Phonetic.Internal, + Data.TST, + Data.TSTSet + +Test-Suite benchmarks + Type: exitcode-stdio-1.0 + + Main-Is: bench.hs + + GHC-Options: -O2 -Werror + + Build-Depends: base, + criterion, + random-shuffle, + bytestring, + time