diff --git a/Data/Set/BKTree.hs b/Data/Set/BKTree.hs --- a/Data/Set/BKTree.hs +++ b/Data/Set/BKTree.hs @@ -215,24 +215,7 @@ -- | Constructs a tree from a list fromList :: Metric a => [a] -> BKTree a -fromList xs = constructTree (\a -> Just (a,[])) xs - -constructTree extract [] = Empty -constructTree extract (a:as) - = case extract a of - Nothing -> constructTree extract as - Just (piv,rest) -> - (\imap -> Node piv (1 + sum (map size (M.elems imap))) imap) $ - M.fromAscList $ - map recurse $ - L.groupBy ((==) `on` fst) $ - L.sortBy (compare `on` fst) $ - concatMap (mkDist piv) $ - as ++ rest - where mkDist piv m = case extract m of - Just (a,_) -> [(distance piv a,m)] - Nothing -> [] - recurse bs@((k,_):_) = (k, constructTree extract (map snd bs)) +fromList xs = L.foldl' (flip insert) empty xs -- | Merges several trees unions :: Metric a => [BKTree a] -> BKTree a @@ -249,7 +232,7 @@ closest a tree@(Node b _ _) = Just (closeLoop a (b,distance a b) tree) closeLoop a candidate Empty = candidate -closeLoop a candidate@(b,d) (Node x _ imap) +closeLoop a candidate@(_,d) (Node x _ imap) = L.foldl' (closeLoop a) newCand (M.elems subMap) where newCand = if j >= d then candidate @@ -268,41 +251,40 @@ -- Testing -- N.B. This code requires QuickCheck 2.0 +{- Testing using algebraic specification. The idea is that we have this +naive inefficient distance function. But instead of comparing it to our actual +implementation we take each clause in the definition and make it into an +equation. We also change each occurrence of the name naive to a call to the +distance function. --- We use a more standard implementation of the levenshtein edit distance --- to check the hirschberg algorithm -levenshtein :: Eq a => [a] -> [a] -> Int -levenshtein xs ys = let - lxs = length xs - lys = length ys - d x y cx cy = minimum - [dist!(x-1,y-1) + (if cx == cy then 0 else 1) - ,dist!(x-1,y) + 1 - ,dist!(x,y-1) + 1 - ] - dist :: Array (Int,Int) Int - dist = array ((0,0),(lxs,lys)) - ( [((0,0),0)] - ++ [((x,0),x) | x <- [1..lxs]] - ++ [((0,y),y) | y <- [1..lys]] - ++ [ ((x,y),d x y cx cy) - | (x,cx) <- zip [1..] xs - , (y,cy) <- zip [1..] ys]) - in dist!(lxs,lys) +naive [] ys = length ys +naive xs [] = length xs +naive (x:xs) (y:ys) | x == y = naive xs ys +naive (x:xs) (y:ys) = 1 + minimum [naive (x:xs) ys + ,naive (x:xs) (x:ys) + ,naive xs (y:ys)] --- These properties are all rather weaker than I would like. --- Think of something better. -prop_levenshtein xs ys = distance xs ys == levenshtein xs (ys :: [Int]) +For example, the third clause becomes: +distance (x:xs) (x:ys) == distance xs ys -prop_levenshteinRepeat (NonZero (NonNegative n)) (NonZero (NonNegative m)) = - distance (replicate n (0::Int)) (replicate m 0) == distance n m +That way we can construct a quickCheck property from it. So, one property for +each equation in the naive algorithm. Pretty sweet! Credits go to Koen. +-} -prop_levenshteinLength xs = - forAll (vectorOf (length xs) arbitrary) $ \ys -> - distance xs ys == length xs && allDifferent xs ys - || distance xs ys < length (xs :: [Int]) - where allDifferent xs ys = all (==False) (zipWith (==) xs ys) +-- Way too inefficient! +-- prop_naive xs ys = distance xs ys == naive xs (ys :: [Int]) +prop_naiveEmpty xs = + distance [] xs == length xs && + distance xs [] == length (xs::[Int]) +prop_naiveCons x xs ys = distance (x:xs) (x:ys) == distance xs (ys::[Int]) +prop_naiveDiff x y xs ys = x /= y ==> + distance (x:xs) (y:ys) == + 1 + minimum [distance (x:xs) (ys :: [Int]) + ,distance (x:xs) (x:ys) + ,distance xs (y:ys)] + +-- ---------------------------------------------------- -- Semantics of BKTrees. Just a boring list of integers sem tree = L.sort (elems tree) :: [Int] @@ -374,7 +356,13 @@ prop_unionInv xs ys = invariant (union (fromList (xs :: [Int])) (fromList (ys :: [Int]))) +-- Error case : 0 [1073741824,0] +-- QuickCheck 2.1 finds this easily. +-- The above error case hit the limit of Int. +-- Maybe I should use Integer after all? prop_closest n xs = + -- Some arbitrary level so that we don't hit the limit of Int + all (\x -> abs x < 100000) xs ==> case (closest n (fromList xs),xs) of (Nothing,[]) -> True (Just (_,d),ys) -> d == minimum (map (distance n) (ys::[Int])) @@ -413,42 +401,47 @@ -- All the tests -tests = [("empty", quickCheck' prop_empty) - ,("null", quickCheck' prop_null) - ,("singleton", quickCheck' prop_singleton) - ,("fromList", quickCheck' prop_fromList) - ,("fromList inv", quickCheck' prop_fromListInv) - ,("insert", quickCheck' prop_insert) - ,("insert inv", quickCheck' prop_insertInv) - ,("member", quickCheck' prop_member) - ,("memberDistance", quickCheck' prop_memberDistance) - ,("delete", quickCheck' prop_delete) - ,("delete inv", quickCheck' prop_deleteInv) - ,("elems", quickCheck' prop_elems) - ,("elemsDistance", quickCheck' prop_elemsDistance) - ,("unions", quickCheck' prop_unions) - ,("unions inv", quickCheck' prop_unionsInv) - ,("union", quickCheck' prop_union) - ,("union inv", quickCheck' prop_unionInv) - ,("closest", quickCheck' prop_closest) - ,("size/empty", quickCheck' prop_sizeEmpty) - ,("size/fromList", quickCheck' prop_sizeFromList) - ,("size/succ", quickCheck' prop_sizeSucc) - ,("size/delete", quickCheck' prop_sizeDelete) - ,("size/union", quickCheck' prop_sizeUnion) - ,("size/unions", quickCheck' prop_sizeUnions) - ,("insert/delete", quickCheck' prop_insertDelete) - ,("fromList/member", quickCheck' prop_fromListMember) - ,("unions/member", quickCheck' prop_unionsMember) - ,("levenshtein", quickCheck' prop_levenshtein) - ,("levenshtein repeat",quickCheck' prop_levenshteinRepeat) - ,("levenshtein length",quickCheck' prop_levenshteinLength) +data TestCase = forall prop. Testable prop => Tc String prop + +tests = [Tc "empty" prop_empty + ,Tc "null" prop_null + ,Tc "singleton" prop_singleton + ,Tc "fromList" prop_fromList + ,Tc "fromList inv" prop_fromListInv + ,Tc "insert" prop_insert + ,Tc "insert inv" prop_insertInv + ,Tc "member" prop_member + ,Tc "memberDistance" prop_memberDistance + ,Tc "delete" prop_delete + ,Tc "delete inv" prop_deleteInv + ,Tc "elems" prop_elems + ,Tc "elemsDistance" prop_elemsDistance + ,Tc "unions" prop_unions + ,Tc "unions inv" prop_unionsInv + ,Tc "union" prop_union + ,Tc "union inv" prop_unionInv + ,Tc "closest" prop_closest + ,Tc "size/empty" prop_sizeEmpty + ,Tc "size/fromList" prop_sizeFromList + ,Tc "size/succ" prop_sizeSucc + ,Tc "size/delete" prop_sizeDelete + ,Tc "size/union" prop_sizeUnion + ,Tc "size/unions" prop_sizeUnions + ,Tc "insert/delete" prop_insertDelete + ,Tc "fromList/member" prop_fromListMember + ,Tc "unions/member" prop_unionsMember + ,Tc "naiveEmpty" prop_naiveEmpty + ,Tc "naiveCons" prop_naiveCons + ,Tc "naiveDiff" prop_naiveDiff ] runTests = mapM_ runTest tests - where runTest (s,a) = do printf "%-25s :" s - b <- a - if b - then return () - else exitFailure + where runTest (Tc s prop) + = do printf "%-25s :" s + result <- quickCheckResult prop + case result of + Success _ -> return () + GaveUp _ _ -> return () + _ -> exitFailure + #endif diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,19 @@ +This is a module I hacked together quickly after having read the following +blog post: +http://blog.notdot.net/archives/30-Damn-Cool-Algorithms,-Part-1-BK-Trees.html + +I thought the data structure sounded cool so I thought it would be an +interesting excerise to implement it. + +BK-trees can apparently perform very good in some circumstances. The +paper "Fast Approximate String Matching in a Dictionary" (Baeza-Yates, +Navarro 1998) recommends them over other structures for doing +approximate search. +http://citeseer.ist.psu.edu/1593.html + +The original paper can be found here: +http://portal.acm.org/citation.cfm?id=362003.362025 + +Henning Günter generously supplied two algorithms for +computing the levenshtein edit distance. The better one of the two is used in +the list instance for the Metric class. diff --git a/bktrees.cabal b/bktrees.cabal --- a/bktrees.cabal +++ b/bktrees.cabal @@ -1,5 +1,5 @@ name: bktrees -version: 0.2.1 +version: 0.2.2 license: BSD3 license-file: LICENSE author: Josef Svenningsson @@ -14,16 +14,17 @@ you are searching for. cabal-version: >=1.2 extra-source-files: test/Test.hs +extra-source-files: README +build-type: Simple flag splitBase description: Choose the new smaller, split-up base package. library if flag(splitBase) - build-depends: base >= 3, containers, array + build-depends: base >= 3, base < 4, containers, array else build-depends: base < 3 exposed-modules: Data.Set.BKTree extensions: CPP - ghc-options: -O