diff --git a/Data/BKTree.hs b/Data/BKTree.hs deleted file mode 100644 --- a/Data/BKTree.hs +++ /dev/null @@ -1,69 +0,0 @@ --- | Implementation of a BK-tree: -module Data.BKTree - ( -- * Types - Distance - , BKTree - -- * Operations - , empty - , insert - , query - ) where - -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -type Distance s = s -> s -> Int - -data BKTree s = - BKTree !(BK s) (Distance s) - -data BK s - = EmptyBK - | BK !s !(IntMap (BK s)) - -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 :: Distance s -- ^ The distance function \"d\" must be a metric on \"s\" - -- (): - -- - -- * d x y >= 0 - -- - -- * d x y == 0 iff x == y - -- - -- * d x y == d y x - -- - -- * d x z <= d x y + d y z - -> BKTree s -empty = BKTree EmptyBK - -insert :: s -> BKTree s -> BKTree s -insert s (BKTree bk f) = BKTree (insert' s f bk) f - -insert' :: s -> Distance s -> BK s -> BK s -insert' s _ EmptyBK = BK s IntMap.empty -insert' s f bk@(BK s' bks) - | dist == 0 = bk - | otherwise = BK s' $ flip (IntMap.insert dist) bks $ - maybe (insert' s f EmptyBK) (insert' s f) (IntMap.lookup dist bks) - where dist = f s s' - -query :: Int -- ^ The maximum distance to search for. - -> s -> BKTree s - -> [(s, Int)] -- ^ All the words with a distance less than the - -- one specified, and their respective - -- distances. -query maxd s (BKTree bk f) = query' maxd s f bk - -query' :: Int -> s -> Distance s -> BK s -> [(s, Int)] -query' _ _ _ EmptyBK = [] -query' maxd s f (BK s' bks) = match ++ concatMap (query' maxd s f) children - where - dist = f s s' - match = if (dist <= maxd) then [(s', dist)] else [] - children = IntMap.elems $ narrow (max (dist - maxd) 0) (dist + maxd) bks diff --git a/Data/TST.hs b/Data/TST.hs deleted file mode 100644 --- a/Data/TST.hs +++ /dev/null @@ -1,133 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Data/TSTSet.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | 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-spelling.cabal b/language-spelling.cabal --- a/language-spelling.cabal +++ b/language-spelling.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.8 Name: language-spelling -Version: 0.2 +Version: 0.3 Author: Francesco Mazzoli (f@mazzo.li) Maintainer: Francesco Mazzoli (f@mazzo.li) Build-Type: Simple @@ -48,8 +48,11 @@ ListLike, listlike-instances, text, - vector >= 0.5 + vector >= 0.5, + bk-tree, + tst + GHC-Options: -Werror -O2 Exposed-Modules: Language.Distance, @@ -58,10 +61,7 @@ Language.Distance.Search.BK, Language.Distance.Search.TST, Language.Phonetic, - Language.Phonetic.Internal, - Data.BKTree, - Data.TST, - Data.TSTSet + Language.Phonetic.Internal Other-Modules: Language.Distance.Search.Class, Language.Phonetic.Soundex,