module Test.Tests where

import Data.List (nub, sort)
import qualified Data.Set as S
import Prelude hiding (null, lookup, filter,map)
import qualified Prelude as P
import Test.QuickCheck
import Control.Applicative((<$>))

import Data.Bimap


(.:) = (.).(.)

instance (Ord a, Arbitrary a, Ord b, Arbitrary b)
    => Arbitrary (Bimap a b) where
    arbitrary = fromList `fmap` arbitrary

instance (Ord a, CoArbitrary a, Ord b, CoArbitrary b)
    => CoArbitrary (Bimap a b) where
    coarbitrary = coarbitrary . toList

-- generator for filter/partition classification functions
data FilterFunc a b = FilterFunc String (a -> b -> Bool)
instance Show (FilterFunc a b) where
    show (FilterFunc desc _) = desc
instance (Integral a, Arbitrary a, Integral b, Arbitrary b)
    => Arbitrary (FilterFunc a b) where
    arbitrary = do
        pivot <- (arbitrary :: Gen Integer)
        return $ FilterFunc
            ("(\\x y -> x - y < " ++ show pivot ++ ")")
            (\x y -> fromIntegral x - fromIntegral y < pivot)
instance (Integral a, CoArbitrary a, Integral b, CoArbitrary b)
    => CoArbitrary (FilterFunc a b) where
    coarbitrary _ gen = do
        x <- arbitrary
        coarbitrary (x :: Int) gen


-- empty bimap has zero size
prop_size_empty = size empty == 0

-- empty bimap is null
prop_null_empty = null empty

-- when converting from a list and back, each pair in the latter
-- list was originally in the former list
-- (heh, this is probably made redundant by polymorphism)
prop_fromList_toList xs =
    let xs' = toList . fromList $ xs
    in all (flip elem xs) xs'
    where
    _ = xs :: [(Int, Integer)]

-- when converting a list to a bimap, each list element either
-- ends up in the bimap, or could conceivably have been clobbered
prop_fromList_account xs = all (\x -> isMember x || notUnique x) xs
    where
    _ = xs :: [(Int, Integer)]
    bi = fromList xs
    isMember x = x `pairMember` bi
    notUnique (x, y) = 
        ((>1) . length . P.filter (== x) . P.map fst $ xs) ||
        ((>1) . length . P.filter (== y) . P.map snd $ xs)

-- a bimap created from a list is no larger than the list
prop_fromList_size xs = (size $ fromList xs) <= length xs
    where
    _ = xs :: [(Int, Integer)]

-- a monotone bimap can be reconstituted via fromAscPairList
prop_fromAscPairList_reconstitute xs = and
    [ valid bi'
    , (bi == bi')
    ]
    where
    xs' = zip (sort $ P.map fst xs) (sort $ P.map snd xs)
    bi :: Bimap Int Integer
    bi = fromList xs'
    bi' = fromAscPairList . toAscList $ bi

-- fromAscPairList will never produce an invalid bimap
prop_fromAscPairList_check xs = valid bi
    where
    xs' = zip (nub $ sort $ P.map fst xs) (nub $ sort $ P.map snd xs)
    bi :: Bimap Int Integer
    bi = fromAscPairList xs'

-- if a pair is a member of the bimap, then both elements are present
-- and associated with each other
prop_pairMember bi k v =
    ((k, v) `pairMember` bi) == and
        [ k `member`  bi
        , v `memberR` bi
        , lookup  k bi == Just v
        , lookupR v bi == Just k
        ]
    where
    _ = bi :: Bimap Int Integer

-- an inserted pair ends up in the bimap
prop_insert_member bi k v = (k, v) `pairMember` (insert k v bi)
    where
    _ = bi :: Bimap Int Integer

-- if we insert a pair with an existing value, the old value's twin
-- is no longer in the bimap
prop_clobberL bi b' =
    (not . null $ bi) && (b' `notMemberR` bi)
    ==>
    (a, b) `pairNotMember` insert a b' bi
    where
    (a, b) = head . toList $ bi :: (Int, Integer)

prop_clobberR bi a' =
    (not . null $ bi) && (a' `notMember` bi)
    ==>
    (a, b) `pairNotMember` insert a' b bi
    where
    (a, b) = head . toList $ bi :: (Int, Integer)

-- if we politely insert two members, neither of which is present,
-- then the two are successfully associated
prop_tryInsert_member bi k v = (k, v) `neitherMember` bi ==>
    pairMember (k, v) (tryInsert k v bi)
    where
    _ = bi :: Bimap Int Integer
    neitherMember (k, v) bi = k `notMember` bi && v `notMemberR` bi

-- polite insertion will never remove existing associations
prop_tryInsert_not_clobber bi k v =
    all (flip pairMember $ tryInsert k v bi) (toList bi)
    where
    _ = bi :: Bimap Int Integer

-- an arbitrary bimap is valid
prop_valid bi = valid bi
    where
    _ = bi :: Bimap Int Integer

-- if x maps to y, then y maps to x
prop_member_twin bi = flip all (toList bi) $ \(x, y) -> and
    [ (bi !  x) `memberR` bi
    , (bi !> y) `member`  bi
    ]
    where
    _ = bi :: Bimap Int Integer

-- deleting an element removes it from the map
prop_delete bi = flip all (toList bi) $ \(x, y) -> and
    [ x `notMember`  delete  x bi
    , y `notMemberR` deleteR y bi
    ]
    where
    _ = bi :: Bimap Int Integer

-- deleting an element removes its twin from the map
prop_delete_twin bi = flip all (toList bi) $ \(x, y) -> and
    [ (bi !  x) `notMemberR` delete  x bi
    , (bi !> y) `notMember`  deleteR y bi
    ]
    where
    _ = bi :: Bimap Int Integer

-- adjust and fmap are similar
prop_adjust_fmap bi a = l === r
  where
  l = lookup a $ adjust f a bi :: Maybe Integer
  r = f <$> lookup a bi
  _ = bi :: Bimap Int Integer
  f = (1-)

prop_adjustR_fmap bi b = l == r
  where
  l = lookupR b $ adjustR f b bi :: Maybe Int
  r = f <$> lookupR b bi
  _ = bi :: Bimap Int Integer
  f = (3*)

-- a singleton bimap is valid, has one association, and the two
-- given values map to each other
prop_singleton x y = let bi = singleton x y in and
    [ valid bi
    , (x, y) `pairMember` bi
    , (bi !  x) == y
    , (bi !> y) == x
    , size bi == 1
    ]
    where
    _ = (x, y) :: (Int, Integer)

-- an always-true filter makes no changes
prop_filter_true bi =
    bi == filter (curry $ const True) bi
    where
    _ = bi :: Bimap Int Integer

-- an always-false filter gives an empty result
prop_filter_false bi =
    null $ filter (curry $ const False) bi
    where
    _ = bi :: Bimap Int Integer

-- all elements of the projection satisfy the predicate, and all
-- elements of the rejection do not
prop_partition_agree bi (FilterFunc _ ff) = and
    [ all (      uncurry ff) (toList projection)
    , all (not . uncurry ff) (toList rejection)
    ]
    where
    _ = bi :: Bimap Int Integer
    (projection, rejection) = partition ff bi

-- the two halves of a partition are disjoint
prop_partition_disjoint bi (FilterFunc _ ff) =
    S.null $ S.intersection (asSet projection) (asSet rejection)
    where
    _ = bi :: Bimap Int Integer
    (projection, rejection) = partition ff bi
    asSet = S.fromList . toList

-- the two halves of a partition contain the elements of the original
-- bimap
prop_partition_union bi (FilterFunc _ ff) =
    (==) (asSet bi) $
        S.union (asSet projection) (asSet rejection)
    where
    _ = bi :: Bimap Int Integer
    (projection, rejection) = partition ff bi
    asSet = S.fromList . toList

-- the two halves of a partition agree with individual filters
prop_partition_filter bi (FilterFunc _ ff) = and
    [ projection == filter (       ff) bi
    , rejection  == filter (not .: ff) bi
    ]
    where
    _ = bi :: Bimap Int Integer
    (projection, rejection) = partition ff bi

-- partition and filter produce valid results
prop_partition_filter_valid bi (FilterFunc _ ff) = all valid
    [ projection
    , rejection
    , filter (       ff) bi
    , filter (not .: ff) bi
    ]
    where
    _ = bi :: Bimap Int Integer
    (projection, rejection) = partition ff bi

-- twist is its own inverse
prop_twist_twist bi =
    bi == (twist . twist $ bi)
    where
    _ = bi :: Bimap Int Integer

-- the property (fromList == fromAList . reverse) only holds
-- if either the left or right values are all distinct
prop_fromList_fromAList xs = and
    [ fromList  ys == fromAList rys
    , fromList rys == fromAList  ys
    ]
    where
    ys = xs `zip` [1..] :: [(Int, Integer)]
    rys = reverse ys

swap (x, y) = (y, x)

-- deleteFindMin and deleteMin agree
prop_deleteMin_is_delete bi = not (null bi) ==>
    snd (deleteFindMin bi) == deleteMin bi
    where
    _ = bi :: Bimap Int Integer

-- deleteFindMin and findMin agree
prop_deleteMin_is_find bi = not (null bi) ==>
    fst (deleteFindMin bi) == findMin bi
    where
    _ = bi :: Bimap Int Integer

-- elements removed by deleteFindMin are no longer in the bimap
prop_deleteMin_deletes bi = not (null bi) ==>
    fst (deleteFindMin bi) `pairNotMember` snd (deleteFindMin bi)
    where
    _ = bi :: Bimap Int Integer

-- findMin finds a member of the map
prop_findMin_member bi = not (null bi) ==>
    findMin bi `pairMember` bi
    where
    _ = bi :: Bimap Int Integer

-- the minimum of a singleton bimap is its contents
prop_singleton_is_findMin x y = findMin bi == (x, y)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

-- deleting the minimum of a singleton leaves it empty
prop_singleton_deleteMin_empty x y = null (deleteMin bi)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

-- the minimum of a bimap is <= all other elements
prop_findMin_is_minimal bi = all (\ (a, _) -> a >= x) lst
    where
    lst = toList bi
    _ = bi :: Bimap Int Integer
    x = fst . findMin $ bi

prop_deleteMinR_is_delete bi = not (null bi) ==>
    snd (deleteFindMinR bi) == deleteMinR bi 
    where
    _ = bi :: Bimap Int Integer

prop_deleteMinR_is_find bi = not (null bi) ==>
    fst (deleteFindMinR bi) == findMinR bi 
    where
    _ = bi :: Bimap Int Integer

prop_deleteMinR_deletes bi = not (null bi) ==>
    (swap . fst) (deleteFindMinR bi) `pairNotMember` snd (deleteFindMinR bi)
    where
    _ = bi :: Bimap Int Integer

prop_findMinR_member bi = not (null bi) ==>
    swap (findMinR bi) `pairMember` bi
    where
    _ = bi :: Bimap Int Integer
        
prop_singleton_is_findMinR x y = findMinR bi == (y, x)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_singleton_deleteMinR_empty x y = null (deleteMinR bi)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_findMinR_is_minimal bi = all (\ (_, b) -> b >= y) lst
    where
    lst = toList bi
    _ = bi :: Bimap Int Integer
    y = fst . findMinR $ bi

prop_deleteMax_is_delete bi = not (null bi) ==>
    snd (deleteFindMax bi) == deleteMax bi
    where
    _ = bi :: Bimap Int Integer

prop_deleteMax_is_find bi = not (null bi) ==>
    fst (deleteFindMax bi) == findMax bi
    where
    _ = bi :: Bimap Int Integer

prop_deleteMax_deletes bi = not (null bi) ==>
    fst (deleteFindMax bi) `pairNotMember` snd (deleteFindMax bi)
    where
    _ = bi :: Bimap Int Integer

prop_findMax_member bi = not (null bi) ==>
    findMax bi `pairMember` bi
    where
    _ = bi :: Bimap Int Integer
        
prop_singleton_is_findMax x y = findMax bi == (x, y)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_singleton_deleteMax_empty x y = null (deleteMax bi)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_findMax_is_maximal bi = all (\ (a, _) -> a <= x) lst
    where
    lst = toList bi
    _ = bi :: Bimap Int Integer
    x = fst . findMax $ bi

prop_deleteMaxR_is_delete bi = not (null bi) ==>
    snd (deleteFindMaxR bi) == deleteMaxR bi 
    where
    _ = bi :: Bimap Int Integer

prop_deleteMaxR_is_find bi = not (null bi) ==>
    fst (deleteFindMaxR bi) == findMaxR bi
    where
    _ = bi :: Bimap Int Integer

prop_deleteMaxR_deletes bi = not (null bi) ==>
    (swap . fst) (deleteFindMaxR bi) `pairNotMember` snd (deleteFindMaxR bi)
    where
    _ = bi :: Bimap Int Integer

prop_findMaxR_member bi = not (null bi) ==>
    swap (findMaxR bi) `pairMember` bi
    where
    _ = bi :: Bimap Int Integer
        
prop_singleton_is_findMaxR x y = findMaxR bi == (y, x)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_singleton_deleteMaxR_empty x y = null (deleteMaxR bi)
    where
    bi :: Bimap Int Integer
    bi = singleton x y

prop_findMaxR_is_maximal bi = all (\ (_, b) -> b <= y) lst
    where
    lst = toList bi
    _ = bi :: Bimap Int Integer
    y = fst . findMaxR $ bi

prop_deleteMin_is_valid bi = not (null bi) ==>
    valid (deleteMin bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteFindMin_is_valid bi = not (null bi) ==>
    valid (snd $ deleteFindMin bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteMinR_is_valid bi = not (null bi) ==>
    valid (deleteMinR bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteFindMinR_is_valid bi = not (null bi) ==>
    valid (snd $ deleteFindMinR bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteMax_is_valid bi = not (null bi) ==>
    valid (deleteMax bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteFindMax_is_valid bi = not (null bi) ==>
    valid (snd $ deleteFindMax bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteMaxR_is_valid bi = not (null bi) ==>
    valid (deleteMaxR bi)
    where
    _ = bi :: Bimap Int Integer

prop_deleteFindMaxR_is_valid bi = not (null bi) ==>
    valid (snd $ deleteFindMaxR bi)
    where
    _ = bi :: Bimap Int Integer

prop_map_preserve_keys bi =
    (Data.List.sort $ P.map f $ keys bi) == (keys $ map f bi)
    where
    f = (4/) -- This is an arbitrary function
    _ = bi :: Bimap Double Integer

prop_map_preserve_lookup bi v =
    (lookup (f v) $ map f bi) == (lookup v bi :: Maybe Integer)
    where
    f = (1-)
    _ = bi :: Bimap Int Integer

prop_map_preserve_right_keys bi =
    (Data.List.sort $ P.map f $ keysR bi) == (keysR $ mapR f bi)
    where
    f = (4/) -- This is an arbitrary function
    _ = bi :: Bimap Int Double

prop_map_preserve_lookupR bi v =
    (lookup v $ mapR f bi) == (f <$> lookup v bi :: Maybe Integer)
    where
    f = (1-)
    _ = bi :: Bimap Int Integer

prop_mapMonotonic_preserve_keys bi =
    (P.map f $ keys bi) == (keys $ mapMonotonic f bi)
    where
    f = (3+) -- This is an arbitrary monotonic function
    _ = bi :: Bimap Double Integer

prop_mapMonotonic_preserve_lookup bi v =
    (lookup (f v) $ mapMonotonic f bi) == (lookup v bi :: Maybe Integer)
    where
    f = (2*)
    _ = bi :: Bimap Int Integer

prop_mapMontonic_preserve_right_keys bi =
    (P.map f $ keysR bi) == (keysR $ mapMonotonicR f bi)
    where
    f = (^2) -- This is an arbitrary monotonic function
    _ = bi :: Bimap Int Double

prop_mapMonotonic_preserve_lookupR bi v =
    (lookup v $ mapMonotonicR f bi) == (f <$> lookup v bi :: Maybe Integer)
    where
    f = (1-)
    _ = bi :: Bimap Int Integer