{-# LANGUAGE FlexibleInstances #-} module Main ( main ) where import Data.RTree.Base import Data.RTree.MBB hiding (mbb) -- import qualified Data.Set as S import Prelude hiding (lookup, map, null, length) import Data.Binary (encode, decode) import Data.Function (on) import Data.List ((\\)) import qualified Data.List as L (length) import Control.Applicative ((<$>)) import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary, shrink) import Test.QuickCheck.Gen (suchThat) import Test.HUnit hiding (Test, Testable) import Text.Show.Functions () --import Graphics.Gnuplot.Simple -- todo: write tests main :: IO () main = do defaultMain [ testCase "test_null" test_null , testCase "test_singleton" test_singleton , testCase "test_insert" test_insert , testCase "test_lookup" test_lookup , testCase "test_lookupRange" test_lookupRange , testCase "test_lookupRangeWithKey" test_lookupRangeWithKey , testCase "test_lookupContainsRange" test_lookupContainsRange , testCase "test_lookupContainsRangeWithKey" test_lookupContainsRangeWithKey , testCase "test_union" test_union , testCase "test_unionWith" test_unionWith , testCase "test_length" test_length , testCase "test_keys" test_keys , testCase "test_values" test_values , testCase "test_delete" test_delete , testCase "test_fromList" test_fromList , testCase "test_binary" test_binary , testProperty "prop_mbb" prop_mbb , testProperty "prop_rtree" prop_rtree -- , testProperty "map a StringMap" prop_map ] -- ------------------------ t_mbb1, t_mbb2 , t_mbb3, t_mbb4, t_mbb5, t_mbb6, t_mbb7, t_mbb8 :: MBB t_mbb1 = (MBB 0.0 0.0 1.0 1.0) t_mbb2 = (MBB 5.0 0.0 6.0 1.0) t_mbb3 = (MBB 1.0 2.0 2.0 3.0) t_mbb4 = (MBB 6.0 2.0 7.0 3.0) t_mbb5 = (MBB 3.0 3.0 4.0 4.0) t_mbb6 = (MBB 0.0 0.0 0.0 0.0) t_mbb7 = (MBB 1.0 2.0 5.0 4.0) t_mbb8 = (MBB 4.0 0.0 6.0 3.0) t_1, t_2, t_3 :: RTree String t_1 = singleton t_mbb1 "a" t_2 = singleton t_mbb2 "b" t_3 = singleton t_mbb3 "c" u_1, u_2, u_3 :: [(MBB, String)] u_1 = [(t_mbb1, "a"), (t_mbb2, "b"),(t_mbb3, "c"),(t_mbb4, "d")] u_2 = [(t_mbb5, "e"), (t_mbb6, "f")] ++ u_1 u_3 = [(t_mbb7, "g"), (t_mbb8, "h")] ++ u_2 tu_1, tu_2, tu_3 :: RTree String tu_1 = fromList u_1 tu_2 = fromList u_2 tu_3 = fromList u_3 -- ------------------------ eqRt :: (Show a, Eq a) => RTree a -> RTree a -> Assertion eqRt = eqList `on` toList eqList :: (Show a, Eq a) => [a] -> [a] -> Assertion eqList l1 l2 = do [] @=? (l1 \\ l2) (L.length l1) @=? (L.length l2) -- ------------------------ test_null :: Assertion test_null = do null empty @?= True null t_1 @?= False test_singleton :: Assertion test_singleton = do t_1 `eqRt` t_1 length t_1 @?= 1 keys t_1 @?= [t_mbb1] values t_1 @?= ["a"] test_insert :: Assertion test_insert = do insert t_mbb2 "b" t_1 `eqRt` fromList [(t_mbb1, "a"), (t_mbb2, "b")] insert t_mbb1 "a" t_2 `eqRt` fromList [(t_mbb1, "a"), (t_mbb2, "b")] insert t_mbb1 "a+" t_1 `eqRt` fromList [(t_mbb1, "a+")] insert t_mbb1 "a" empty `eqRt` t_1 insert t_mbb5 "e" (fromList u_1) `eqRt` fromList (u_1 ++ [(t_mbb5, "e")]) insert t_mbb6 "f" (fromList u_1) `eqRt` fromList (u_1 ++ [(t_mbb6, "f")]) test_lookup :: Assertion test_lookup = do lookup t_mbb3 t_3 @?= Just "c" lookup t_mbb1 tu_1 @?= Just "a" lookup t_mbb2 tu_2 @?= Just "b" lookup t_mbb3 tu_2 @?= Just "c" lookup t_mbb4 tu_2 @?= Just "d" lookup t_mbb5 tu_2 @?= Just "e" lookup t_mbb6 tu_2 @?= Just "f" lookup t_mbb2 tu_3 @?= Just "b" lookup t_mbb3 tu_3 @?= Just "c" lookup t_mbb4 tu_3 @?= Just "d" lookup t_mbb5 tu_3 @?= Just "e" lookup t_mbb6 tu_3 @?= Just "f" lookup t_mbb7 tu_3 @?= Just "g" lookup t_mbb8 tu_3 @?= Just "h" lookup t_mbb1 empty @?= (Nothing :: Maybe ()) lookup t_mbb6 (fromList u_1) @?= Nothing test_lookupRange :: Assertion test_lookupRange = do lookupRange t_mbb3 t_3 @?= ["c"] lookupRange t_mbb1 tu_1 @?= ["a"] lookupRange t_mbb2 tu_2 @?= ["b"] lookupRange t_mbb3 tu_2 @?= ["c"] lookupRange t_mbb4 tu_2 @?= ["d"] lookupRange t_mbb5 tu_2 @?= ["e"] lookupRange t_mbb6 tu_2 @?= ["f"] lookupRange (MBB 1.0 1.0 7.0 3.0) tu_2 @?= ["c", "d"] lookupRange (MBB 0.0 0.0 1.0 1.0) tu_2 @?= ["f", "a"] lookupRange (MBB 0.0 0.0 7.0 4.0) tu_2 @?= ["e","c","f","a","b","d"] -- todo order irrelevant lookupRange t_mbb2 tu_3 @?= ["b"] lookupRange t_mbb3 tu_3 @?= ["c"] lookupRange t_mbb4 tu_3 @?= ["d"] lookupRange t_mbb5 tu_3 @?= ["e"] lookupRange t_mbb6 tu_3 @?= ["f"] lookupRange t_mbb7 tu_3 `eqList` ["g","e","c"] lookupRange t_mbb8 tu_3 `eqList` ["h", "b"] lookupRange (MBB 3.0 2.0 7.0 4.0) tu_3 `eqList` ["e","d"] lookupRange (MBB 0.0 0.0 5.0 3.0) tu_3 `eqList` ["f","a","c"] test_lookupRangeWithKey :: Assertion test_lookupRangeWithKey = do lookupRangeWithKey t_mbb3 t_3 @?= [(t_mbb3, "c")] lookupRangeWithKey t_mbb1 tu_1 @?= [(t_mbb1, "a")] lookupRangeWithKey t_mbb2 tu_2 @?= [(t_mbb2, "b")] lookupRangeWithKey t_mbb3 tu_2 @?= [(t_mbb3, "c")] lookupRangeWithKey t_mbb4 tu_2 @?= [(t_mbb4, "d")] lookupRangeWithKey (MBB 1.0 1.0 7.0 3.0) tu_2 @?= [(t_mbb3, "c"), (t_mbb4, "d")] lookupRangeWithKey (MBB 0.0 0.0 1.0 1.0) tu_2 @?= [(t_mbb6, "f"), (t_mbb1, "a")] lookupRangeWithKey (MBB 0.0 0.0 7.0 4.0) tu_2 `eqList` u_2 -- todo order irrelevant lookupRangeWithKey t_mbb2 tu_3 @?= [(t_mbb2, "b")] lookupRangeWithKey t_mbb3 tu_3 @?= [(t_mbb3, "c")] lookupRangeWithKey t_mbb4 tu_3 @?= [(t_mbb4, "d")] lookupRangeWithKey t_mbb5 tu_3 @?= [(t_mbb5, "e")] lookupRangeWithKey t_mbb6 tu_3 @?= [(t_mbb6, "f")] lookupRangeWithKey t_mbb7 tu_3 `eqList` [(t_mbb7, "g"), (t_mbb5, "e"), (t_mbb3, "c")] lookupRangeWithKey t_mbb8 tu_3 `eqList` [(t_mbb8, "h"), (t_mbb2, "b")] test_lookupContainsRange :: Assertion test_lookupContainsRange = do lookupContainsRange t_mbb3 t_3 @?= ["c"] lookupContainsRange t_mbb1 tu_1 @?= ["a"] lookupContainsRange t_mbb2 tu_2 @?= ["b"] lookupContainsRange t_mbb3 tu_2 @?= ["c"] lookupContainsRange t_mbb4 tu_2 @?= ["d"] lookupContainsRange t_mbb5 tu_2 @?= ["e"] lookupContainsRange t_mbb6 tu_2 `eqList` ["f","a"] lookupContainsRange (MBB 1.0 1.0 7.0 3.0) tu_2 @?= [] lookupContainsRange (MBB 0.0 0.0 1.0 1.0) tu_2 @?= ["a"] lookupContainsRange (MBB 0.0 0.0 7.0 4.0) tu_2 @?= [] lookupContainsRange (MBB 0.5 0.5 0.5 0.5) tu_2 @?= ["a"] lookupContainsRange (MBB 0.0 1.0 0.0 1.0) tu_2 @?= ["a"] lookupContainsRange (MBB 1.0 0.0 1.0 0.0) tu_2 @?= ["a"] lookupContainsRange (MBB 1.0 1.0 1.0 1.0) tu_2 @?= ["a"] lookupContainsRange t_mbb2 tu_3 `eqList` ["b","h"] lookupContainsRange t_mbb3 tu_3 `eqList` ["c","g"] lookupContainsRange t_mbb4 tu_3 `eqList` ["d"] lookupContainsRange t_mbb5 tu_3 `eqList` ["e","g"] lookupContainsRange t_mbb6 tu_3 `eqList` ["f","a"] lookupContainsRange t_mbb7 tu_3 `eqList` ["g"] lookupContainsRange t_mbb8 tu_3 `eqList` ["h"] lookupContainsRange (MBB 4.5 2.5 4.5 2.5) tu_3 `eqList` ["g","h"] test_lookupContainsRangeWithKey :: Assertion test_lookupContainsRangeWithKey = do lookupContainsRangeWithKey t_mbb3 t_3 @?= [(t_mbb3, "c")] lookupContainsRangeWithKey t_mbb1 tu_1 @?= [(t_mbb1, "a")] lookupContainsRangeWithKey t_mbb2 tu_2 @?= [(t_mbb2, "b")] lookupContainsRangeWithKey t_mbb3 tu_2 @?= [(t_mbb3, "c")] lookupContainsRangeWithKey t_mbb4 tu_2 @?= [(t_mbb4, "d")] lookupContainsRangeWithKey t_mbb5 tu_2 @?= [(t_mbb5, "e")] lookupContainsRangeWithKey t_mbb6 tu_2 `eqList` [(t_mbb6, "f"), (t_mbb1, "a")] test_union :: Assertion test_union = do union empty empty `eqRt` (empty :: RTree ()) union tu_2 tu_1 `eqRt` tu_2 union t_1 empty `eqRt` t_1 union empty t_1 `eqRt` t_1 test_unionWith :: Assertion test_unionWith = do unionWith undefined empty empty `eqRt` (empty :: RTree ()) unionWith (++) tu_2 tu_1 `eqRt` (fromList [(t_mbb1,"aa"),(t_mbb2,"bb"),(t_mbb3,"cc"),(t_mbb4,"dd"),(t_mbb5,"e"),(t_mbb6,"f")]) -- tu_2 test_length :: Assertion test_length = do length empty @?= 0 length t_1 @?= 1 length tu_2 @?= L.length u_2 test_keys :: Assertion test_keys = do keys empty @?= [] keys t_1 @?= [t_mbb1] keys tu_2 `eqList` (fst <$> u_2) test_values :: Assertion test_values = do values empty @?= ([] :: [()]) values t_1 @?= ["a"] values tu_2 `eqList` (snd <$> u_2) test_delete :: Assertion test_delete = do let d1 = delete (MBB 3.0 3.0 4.0 4.0) tu_2 values d1 @?= ["c","f","a","b","d"] let d2 = delete (MBB 1.0 2.0 2.0 3.0) d1 values d2 @?= ["f","a","b","d"] let d3 = delete (MBB 0.0 0.0 0.0 0.0) d2 values d3 @?= ["a","b","d"] let d4 = delete (MBB 5.0 0.0 6.0 1.0) d3 values d4 @?= ["a","d"] let d5 = delete (MBB 0.0 0.0 1.0 1.0) d4 values d5 @?= ["d"] let d6 = delete (MBB 6.0 2.0 7.0 3.0) d5 values d6 @?= [] test_fromList :: Assertion test_fromList = do fromList [] `eqRt` (empty :: RTree ()) test_binary :: Assertion test_binary = do (decode $ encode $ tu_2) @?= tu_2 instance Arbitrary MBB where arbitrary = do cx <- arbitrary cy <- arbitrary h <- arbitrary `suchThat` (>=0) w <- arbitrary `suchThat` (>=0) return $ MBB (cx - w) (cy - h) (cx + w) (cy + h) shrink mbb@(MBB ulx uly brx bry) | isPointMBB mbb = [] | otherwise = [MBB (mid ulx brx) (mid uly bry) (mid ulx brx) (mid uly bry)] where mid x y = (y - x) / 2 instance Arbitrary (RTree Int) where arbitrary = do ks <- arbitrary return $ fromList (ks `zip` [1..]) shrink Empty = [] shrink Leaf{} = [Empty] shrink t = [Empty] ++ -- shrink to subterms (getChildren t) ++ -- recursively shrink subterms [createNodeWithChildren newChildred | newChildred <- shrink (getChildren t)] prop_mbb :: MBB -> Bool prop_mbb mbb = isValidMBB mbb prop_rtree :: RTree Int -> Bool prop_rtree t = isValid "prop_rtree" t -- ------------------------- {- t_p = node (mbb 6469.0 9103.0 6656.0 9721.0) [ Leaf {getmbb = (mbb 6469.0 9103.0 6469.0 9721.0), getElem = ()}, Leaf {getmbb = (mbb 6786.0 9678.0 6656.0 9651.0), getElem = ()}, Leaf {getmbb = (mbb 6593.0 9103.0 6593.0 9721.0), getElem = ()}] t_pp = Leaf {getmbb = (mbb 6531.0 9103.0 6531.0 9721.0), getElem = ()} t_ppp = union t_pp t_p -} {- mbbToPath :: MBB -> [(Double, Double)] mbbToPath (MBB ulx uly brx bry) = [(ulx, uly),(brx, uly),(brx, bry),(ulx, bry),(ulx, uly)] rtreeToPaths :: RTree a -> [[(Double, Double)]] rtreeToPaths = foldWithMBB handleLeaf handleNode [] where handleLeaf mbb _ = [mbbToPath mbb] handleNode mbb xs = [mbbToPath mbb] ++ (concat xs) plotRtree :: RTree a -> IO () plotRtree tree = do print [p20 ulx brx, p20 uly bry] print [ulx, brx, uly, bry] plotPaths [Key Nothing, XRange $ p20 ulx brx, YRange $ p20 uly bry] $ rtreeToPaths tree where (MBB ulx uly brx bry) = getMBB tree p20 l r = (l - ((r-l) / 5), r + ((r-l) / 5)) testData :: FilePath -> IO (RTree ()) testData p = do d <- lines <$> readFile p let pairs = zip (listToMBB <$> (L.map read d)) (replicate 100000000 ()) return $ fromList pairs where listToMBB :: [Double] -> MBB listToMBB [ulx, uly, brx, bry] = MBB ulx uly brx bry listToMBB xs = error $ "invalid data " ++ show xs -}