-- Copyright (c) 1999 Chris Okasaki.  
-- See COPYRIGHT file for terms and conditions.

-- WARNING: The Set operations (insertWith...) are not adequately tested.
-- To be thorough, they should be tested on a type where distinguishable
-- values can still be "equal", and the results should be tested to make
-- sure that the "With" function was called on the right values.

module Data.Edison.Test.Set where

import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,
                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)
import qualified Prelude
import qualified Data.List as List -- not ListSeq!
import Data.Bits
import Data.Word

import Test.QuickCheck hiding( (===) )
import Test.HUnit (Test(..))

import Data.Edison.Prelude
import Data.Edison.Coll
import Data.Edison.Test.Utils
import qualified Data.Edison.Seq.ListSeq as L

import Data.Edison.Seq.JoinList (Seq)
import qualified Data.Edison.Seq.JoinList as S

----------------------------------------------------
-- Set implementations to test

import qualified Data.Edison.Coll.UnbalancedSet as US
import qualified Data.Edison.Coll.StandardSet as SS
import qualified Data.Edison.Coll.EnumSet as ES

-------------------------------------------------------
-- A utility class to propigate class contexts down
-- to the quick check properites

class (Eq (set a), Arbitrary (set a),
       Show (set a),
       Eq a, Ord a, Num a, Integral a, Real a,
       OrdSet (set a) a) => SetTest a set | set -> a

instance SetTest Int US.Set
instance SetTest Int SS.Set

newtype SmallInt = SI Int deriving (Show,Read,Eq,Ord,Enum,Num,Integral,Real)
instance Arbitrary SmallInt where
   arbitrary = arbitrary >>= \x -> return (SI $ abs x `mod` (finiteBitSize (0::Word) - 1))

instance CoArbitrary SmallInt where
   coarbitrary (SI x) = coarbitrary x

instance SetTest SmallInt ES.Set

--------------------------------------------------------
-- List all permutations of set types to test

allSetTests :: Test
allSetTests = TestList
   [ setTests (empty :: US.Set Int)
   , setTests (empty :: SS.Set Int)
   , setTests (empty :: ES.Set SmallInt)
   , qcTest $ prop_show_read (empty :: US.Set Int)
   , qcTest $ prop_show_read (empty :: ES.Set SmallInt)
   ]


---------------------------------------------------------
-- List all the tests to run for each type

setTests set = TestLabel ("Set Test "++(instanceName set)) . TestList $
   [ qcTest $ prop_single set
   , qcTest $ prop_single set
   , qcTest $ prop_fromSeq set
   , qcTest $ prop_insert set
   , qcTest $ prop_insertSeq set
   , qcTest $ prop_union set
   , qcTest $ prop_unionSeq set
   , qcTest $ prop_delete set
   , qcTest $ prop_deleteAll set
   , qcTest $ prop_deleteSeq set
   , qcTest $ prop_null_size set            -- 10
   , qcTest $ prop_member_count set
   , qcTest $ prop_toSeq set
   , qcTest $ prop_lookup set
   , qcTest $ prop_fold set
   , qcTest $ prop_strict_fold set
   , qcTest $ prop_filter_partition set
   , qcTest $ prop_deleteMin_Max set
   , qcTest $ prop_unsafeInsertMin_Max set
   , qcTest $ prop_unsafeFromOrdSeq set
   , qcTest $ prop_unsafeAppend set        -- 20
   , qcTest $ prop_filter set
   , qcTest $ prop_partition set
   , qcTest $ prop_minView_maxView set
   , qcTest $ prop_minElem_maxElem set
   , qcTest $ prop_foldr_foldl set
   , qcTest $ prop_strict_foldr_foldl set
   , qcTest $ prop_foldr1_foldl1 set
   , qcTest $ prop_strict_foldr1_foldl1 set
   , qcTest $ prop_toOrdSeq set
   , qcTest $ prop_intersect_difference set -- 30
   , qcTest $ prop_subset_subsetEq set
   , qcTest $ prop_fromSeqWith set
   , qcTest $ prop_insertWith set
   , qcTest $ prop_insertSeqWith set
   , qcTest $ prop_unionl_unionr_unionWith set
   , qcTest $ prop_unionSeqWith set
   , qcTest $ prop_intersectWith set
   , qcTest $ prop_unsafeMapMonotonic set
   , qcTest $ prop_symmetricDifference set
   , qcTest $ prop_strict set
   ]

-----------------------------------------------------
-- Utility operations


lmerge :: Ord a => [a] -> [a] -> [a]
lmerge xs [] = xs
lmerge [] ys = ys
lmerge xs@(x:xs') ys@(y:ys')
  | x < y     = x : lmerge xs' ys
  | y < x     = y : lmerge xs ys'
  | otherwise = x : lmerge xs' ys'


nub :: Eq a => [a] -> [a]
nub (x : xs@(x' : _)) = if x==x' then nub xs else x : nub xs
nub xs = xs

sort :: Ord a => [a] -> [a]
sort = nub . List.sort

(===) :: (Eq (set a),CollX (set a) a) => set a -> set a -> Bool
(===) s1 s2 = 
    structuralInvariant s1
    &&
    structuralInvariant s2
    &&
    s1 == s2

si :: CollX (set a) a => set a -> Bool
si = structuralInvariant

---------------------------------------------------------------
-- CollX operations

prop_single :: SetTest a set => set a -> a -> Bool
prop_single set x =
    let xs = singleton x `asTypeOf` set
     in si xs
        &&
        toOrdList xs == [x]

prop_fromSeq :: SetTest a set => set a -> Seq a -> Bool
prop_fromSeq set xs =
    let s = fromSeq xs `asTypeOf` set
     in si s
        &&
        toOrdList s == sort (S.toList xs)

prop_insert :: SetTest a set => set a -> a -> set a -> Bool
prop_insert set x xs =
    let insert_x_xs = insert x xs
     in si insert_x_xs
        &&
        if member x xs then
           toOrdList insert_x_xs == toOrdList xs
        else
           toOrdList insert_x_xs == List.insert x (toOrdList xs)

prop_insertSeq :: SetTest a set => set a -> Seq a -> set a -> Bool
prop_insertSeq set xs ys =
    insertSeq xs ys === union (fromSeq xs) ys

prop_union :: SetTest a set => set a -> set a -> set a -> Bool
prop_union set xs ys =
    let xys = union xs ys
     in si xys
        &&
        toOrdList xys == lmerge (toOrdList xs) (toOrdList ys)

prop_unionSeq :: SetTest a set => set a -> Seq (set a) -> Bool
prop_unionSeq set xss =
    unionSeq xss === S.foldr union empty xss

prop_delete :: SetTest a set => set a -> a -> set a -> Bool
prop_delete set x xs =
    let delete_x_xs = delete x xs
     in si delete_x_xs
        &&
        toOrdList delete_x_xs == List.delete x (toOrdList xs)

prop_deleteAll :: SetTest a set => set a -> a -> set a -> Bool
prop_deleteAll set x xs =
    deleteAll x xs === delete x xs

prop_deleteSeq :: SetTest a set => set a -> Seq a -> set a -> Bool
prop_deleteSeq set xs ys =
    deleteSeq xs ys === S.foldr delete ys xs

prop_null_size :: SetTest a set => set a -> set a -> Bool
prop_null_size set xs =
    null xs == (size xs == 0)
    &&
    size xs == Prelude.length (toOrdList xs)

prop_member_count :: SetTest a set => set a -> a -> set a -> Bool
prop_member_count set x xs =
    mem == not (Prelude.null (Prelude.filter (== x) (toOrdList xs)))
    &&
    count x xs == (if mem then 1 else 0)
  where mem = member x xs

---------------------------------------------------------------
-- Coll operations

prop_toSeq :: SetTest a set => set a -> set a -> Bool
prop_toSeq set xs =
    List.sort (S.toList (toSeq xs)) == toOrdList xs

prop_lookup :: SetTest a set => set a -> a -> set a -> Bool
prop_lookup set x xs =
    if member x xs then
      lookup x xs == x
      &&
      lookupM x xs == Just x
      &&
      lookupWithDefault 999 x xs == x
      &&
      lookupAll x xs == Prelude.take (count x xs) (repeat x)
    else
      lookupM x xs == Nothing
      &&
      lookupWithDefault 999 x xs == 999
      &&
      lookupAll x xs == []

prop_fold :: SetTest a set => set a -> set a -> Bool
prop_fold set xs =
    List.sort (fold (:) [] xs) == toOrdList xs
    &&
    (null xs || fold1 (+) xs == sum (toOrdList xs))

prop_strict_fold :: SetTest a set => set a -> set a -> Bool
prop_strict_fold set xs =
    fold' (+) 0 xs == fold (+) 0 xs
    &&
    (null xs || fold1' (+) xs == fold1 (+) xs)

prop_filter_partition :: SetTest a set => set a -> set a -> Bool
prop_filter_partition set xs =
    let filter_p_xs = filter p xs
        filter_not_p_xs = filter (not . p) xs
     in si filter_p_xs
        &&
        si filter_not_p_xs
        &&
        toOrdList filter_p_xs == Prelude.filter p (toOrdList xs)
        &&
        partition p xs == (filter_p_xs, filter_not_p_xs)
  where p x = x `mod` 3 == 2

------------------------------------------------------------------
-- OrdCollX operations

prop_deleteMin_Max :: SetTest a set => set a -> set a -> Bool
prop_deleteMin_Max set xs =
    let deleteMin_xs = deleteMin xs
        deleteMax_xs = deleteMax xs
     in si deleteMin_xs
        &&
        si deleteMax_xs
        &&
        toOrdList (deleteMin xs) == 
                 (let l = toOrdList xs 
                   in if L.null l then L.empty else L.ltail l)
        &&
        toOrdList (deleteMax xs) ==
                 (let l = toOrdList xs
                   in if L.null l then L.empty else L.rtail l)


prop_unsafeInsertMin_Max :: SetTest a set => 
        set a -> a -> set a -> Bool
prop_unsafeInsertMin_Max set i xs =
    if null xs then
      unsafeInsertMin 0 xs === singleton 0
      &&
      unsafeInsertMax 0 xs === singleton 0
    else
      unsafeInsertMin lo (delete lo xs) === xs
      &&
      unsafeInsertMax hi (delete hi xs) === xs
  where lo = minElem xs
        hi = maxElem xs

prop_unsafeFromOrdSeq :: SetTest a set => set a -> [a] -> Bool
prop_unsafeFromOrdSeq set xs =
    unsafeFromOrdSeq (sort xs) === (fromSeq xs `asTypeOf` set)

prop_unsafeAppend :: SetTest a set => 
        set a -> a -> set a -> Bool
prop_unsafeAppend set i xs =
       union ys zs === unsafeAppend ys zs
    where (ys,zs) = partitionLE_GT i xs


prop_filter :: SetTest a set => set a -> a -> set a -> Bool
prop_filter set x xs =
    si setLT && si setLE && si setGT && si setGE
    &&
    toOrdList setLT == Prelude.filter (< x) (toOrdList xs)
    &&
    toOrdList setLE == Prelude.filter (<= x) (toOrdList xs)
    &&
    toOrdList setGT == Prelude.filter (> x) (toOrdList xs)
    &&
    toOrdList setGE == Prelude.filter (>= x) (toOrdList xs)

 where setLT = filterLT x xs
       setLE = filterLE x xs
       setGT = filterGT x xs
       setGE = filterGE x xs

prop_partition :: SetTest a set => set a -> a -> set a -> Bool
prop_partition set x xs =
    partitionLT_GE x xs == (filterLT x xs, filterGE x xs)
    &&
    partitionLE_GT x xs == (filterLE x xs, filterGT x xs)
    &&
    partitionLT_GT x xs == (filterLT x xs, filterGT x xs)

-- OrdColl operations

prop_minView_maxView :: SetTest a set => set a -> set a -> Bool
prop_minView_maxView set xs =
    minView xs == (if null xs then Nothing
                              else Just (minElem xs, deleteMin xs))
    &&
    maxView xs == (if null xs then Nothing
                              else Just (maxElem xs, deleteMax xs))

prop_minElem_maxElem :: SetTest a set => set a -> set a -> Property
prop_minElem_maxElem set xs =
    not (null xs) ==>
      minElem xs == Prelude.head (toOrdList xs)
      &&
      maxElem xs == Prelude.last (toOrdList xs)

prop_foldr_foldl :: SetTest a set => set a -> set a -> Bool
prop_foldr_foldl set xs =
    foldr (:) [] xs == toOrdList xs
    &&
    foldl (flip (:)) [] xs == Prelude.reverse (toOrdList xs)

prop_strict_foldr_foldl :: SetTest a set => set a -> set a -> Bool
prop_strict_foldr_foldl set xs =
    foldr' (+) 0 xs == foldr (+) 0 xs
    &&
    foldl' (+) 0 xs == foldl (+) 0 xs

prop_foldr1_foldl1 :: SetTest a set => set a -> set a -> Property
prop_foldr1_foldl1 set xs =
    not (null xs) ==>
      foldr1 f xs == foldr f 1333 xs
      &&
      foldl1 (flip f) xs == foldl (flip f) 1333 xs
  where f x 1333 = x
        f x y = 3*x - 7*y

prop_strict_foldr1_foldl1 :: SetTest a set => set a -> set a -> Property
prop_strict_foldr1_foldl1 set xs =
    not (null xs) ==>
       foldr1' (+) xs == foldr1 (+) xs
       &&
       foldl1' (+) xs == foldl1 (+) xs

prop_toOrdSeq :: SetTest a set => set a -> set a -> Bool
prop_toOrdSeq set xs =
    S.toList (toOrdSeq xs) == toOrdList xs

-----------------------------------------------------------------------
-- SetX operations

prop_intersect_difference :: SetTest a set => 
        set a -> set a -> set a -> Bool
prop_intersect_difference set xs ys =
    intersection xs ys === filter (\x -> member x xs) ys
    &&
    difference xs ys === filter (\x -> not (member x ys)) xs

prop_subset_subsetEq :: SetTest a set => 
        set a -> set a -> set a -> Bool
prop_subset_subsetEq set xs ys =
    properSubset xs ys == (subset xs ys && xs /= ys)
    &&
    subset xs ys == (intersection xs ys == xs)


--------------------------------------------------------------------------
-- Set operations

prop_fromSeqWith :: SetTest a set => set a -> Seq a -> Bool
prop_fromSeqWith set xs =
    fromSeqWith const xs === (fromSeq xs `asTypeOf` set)

prop_insertWith :: SetTest a set => set a -> a -> set a -> Bool
prop_insertWith set x xs =
    insertWith const x xs === insert x xs

prop_insertSeqWith :: SetTest a set => set a -> Seq a -> set a -> Bool
prop_insertSeqWith set xs ys =
    insertSeqWith const xs ys === insertSeq xs ys

prop_unionl_unionr_unionWith :: SetTest a set => 
        set a -> set a -> set a -> Bool
prop_unionl_unionr_unionWith set xs ys =
    unionl xs ys === u
    &&
    unionr xs ys === u
    &&
    unionWith const xs ys === u
  where u = union xs ys

prop_unionSeqWith :: SetTest a set => set a -> Seq (set a) -> Bool
prop_unionSeqWith set xss =
    unionSeqWith const xss === unionSeq xss

prop_intersectWith :: SetTest a set => set a -> set a -> set a -> Bool
prop_intersectWith set xs ys =
    intersectionWith const xs ys === intersection xs ys

prop_unsafeMapMonotonic :: SetTest a set => set a -> set a -> Bool
prop_unsafeMapMonotonic set xs =
   if null xs
      then True
      else let xs' = deleteMax xs 
            in toOrdList (unsafeMapMonotonic (+1) xs') == Prelude.map (+1) (toOrdList xs')

prop_show_read :: (SetTest a set,Read (set a),Show (set a)) 
               => set a -> set a -> Bool
prop_show_read set xs = xs === read (show xs)


prop_symmetricDifference :: SetTest a set => set a -> set a -> set a -> Bool
prop_symmetricDifference set xs ys =
   union (difference xs ys) (difference ys xs) === symmetricDifference xs ys

prop_strict :: SetTest a set => set a -> set a -> Bool
prop_strict set xs =
   strict xs === xs
   &&
   strictWith (+1) xs === xs
