language-spelling (empty) → 0.1
raw patch · 15 files changed
+936/−0 lines, 15 filesdep +ListLikedep +arraydep +basesetup-changed
Dependencies added: ListLike, array, base, bytestring, containers, criterion, listlike-instances, random-shuffle, text, time, vector
Files
- Data/TST.hs +133/−0
- Data/TSTSet.hs +55/−0
- Language/Distance.hs +156/−0
- Language/Distance/Internal.hs +11/−0
- Language/Distance/Search.hs +61/−0
- Language/Distance/Search/BK.hs +74/−0
- Language/Distance/Search/Class.hs +31/−0
- Language/Distance/Search/TST.hs +135/−0
- Language/Phonetic.hs +7/−0
- Language/Phonetic/Encoder.hs +20/−0
- Language/Phonetic/Internal.hs +8/−0
- Language/Phonetic/Soundex.hs +58/−0
- Setup.hs +2/−0
- bench.hs +106/−0
- language-spelling.cabal +79/−0
+ Data/TST.hs view
@@ -0,0 +1,133 @@+-- | Implementation of a Ternary Search Tree:+-- <https://en.wikipedia.org/wiki/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
+ Data/TSTSet.hs view
@@ -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
+ Language/Distance.hs view
@@ -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: <https://en.wikipedia.org/wiki/Levenshtein_distance>.+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:+-- <https://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.+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)
+ Language/Distance/Internal.hs view
@@ -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)
+ Language/Distance/Search.hs view
@@ -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
+ Language/Distance/Search/BK.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | An implementation of 'Language.Distance.Search' based on a BK-tree:+-- <https://en.wikipedia.org/wiki/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):+-- <https://en.wikipedia.org/wiki/Metric_space>.+--+-- 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
+ Language/Distance/Search/Class.hs view
@@ -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 <http://hackage.haskell.org/trac/ghc/ticket/7100>.+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
+ Language/Distance/Search/TST.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | An implementation of 'Search' based on a ternary search tree+-- ('Data.TSTSet'): <https://en.wikipedia.org/wiki/Ternary_search_tree>. +--+-- 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
+ Language/Phonetic.hs view
@@ -0,0 +1,7 @@+module Language.Phonetic+ ( module Language.Phonetic.Encoder+ , module Language.Phonetic.Soundex+ ) where++import Language.Phonetic.Encoder+import Language.Phonetic.Soundex
+ Language/Phonetic/Encoder.hs view
@@ -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)
+ Language/Phonetic/Internal.hs view
@@ -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)
+ Language/Phonetic/Soundex.hs view
@@ -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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench.hs view
@@ -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)
+ language-spelling.cabal view
@@ -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