{-# LANGUAGE NoMonomorphismRestriction, StandaloneDeriving #-}
{-# OPTIONS -Wall -fno-warn-orphans #-}
module Main (main) where

import Data.PurePriorityQueue.Internal

import Control.Monad (liftM2)
import qualified Data.Foldable as F
import Data.List (sort)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import qualified Data.Set as S

import Text.Show.Functions ()
import Test.Framework (testGroup, Test, defaultMain)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck

import Prelude hiding (null, filter)
import qualified Prelude


type Elem = Integer
type Prio = Int
type TestQueue = MinMaxQueue Prio Elem

data Action p v = Insert p v
                | DeleteMin
                | DeleteMax

deriving instance (Show p, Show a) => Show (MinMaxQueue p a)

instance (Arbitrary p, Arbitrary v) => Arbitrary (Action p v) where
  arbitrary = oneof [ return DeleteMin
                    , return DeleteMax
                    , liftM2 Insert arbitrary arbitrary
                    ]

instance (Ord p, Ord v, Arbitrary p, Arbitrary v) =>
         Arbitrary (MinMaxQueue p v) where
  arbitrary = do
      as <- listOf arbitrary
      return $ foldr f empty as
    where f DeleteMin    = deleteMin
          f DeleteMax    = deleteMax
          f (Insert p v) = insert p v


prop_size1 :: TestQueue -> Bool
prop_size1 m = size m >= 0
 
prop_size2 :: TestQueue -> Bool
prop_size2 m = size m >= M.size (unMinMaxQueue m)

prop_size3 :: TestQueue -> Elem -> Prio -> Bool
prop_size3 m v p = size m + 1 == size m'
  where m' = insert v p m

prop_deleteMin_size1 :: TestQueue -> Bool
prop_deleteMin_size1 m =
    if null m
    then size m' == size m 
    else size m' == size m - 1
  where m' = deleteMin m

prop_deleteMax_size1 :: TestQueue -> Bool
prop_deleteMax_size1 m =
    if null m
    then size m' == size m 
    else size m' == size m - 1
  where m' = deleteMax m

prop_size5 :: Bool
prop_size5 = size m == 0
  where m = empty :: TestQueue

prop_size6 :: TestQueue -> Bool
prop_size6 m = size m == getSum (F.foldMap (Sum . length) (unMinMaxQueue m))

prop_filter1 :: TestQueue -> Bool
prop_filter1 m = filter (const False) m == empty

prop_filter2 :: TestQueue -> Bool
prop_filter2 m = filter (const True) m == m

prop_filter3 :: TestQueue -> (Elem -> Bool) -> Bool
prop_filter3 m f = set (filter f m) `S.isSubsetOf` set m

prop_filterWithPriority1 :: TestQueue -> Bool
prop_filterWithPriority1 m = filterWithPriority (\_ _ -> False) m == empty

prop_filterWithPriority2 :: TestQueue -> Bool
prop_filterWithPriority2 m = filterWithPriority (\_ _ -> True) m == m

prop_filterWithPriority3 :: TestQueue -> (Elem -> Prio -> Bool) -> Bool
prop_filterWithPriority3 m f =
  set (filterWithPriority f m) `S.isSubsetOf` set m

set :: (Ord p, Ord a) => MinMaxQueue p a -> S.Set (a, p)
set = S.fromList . toAscList

prop_nonempty :: TestQueue -> Bool
prop_nonempty m = all (\(_,vs) -> vs /= []) (M.toList $ unMinMaxQueue m)

prop_isEmpty1 :: TestQueue -> Bool
prop_isEmpty1 m = null m == M.null (unMinMaxQueue m)

prop_split1 :: Prio -> TestQueue -> Bool
prop_split1 p m = let (lt, geq) = splitByPriority p m
                  in foldWithPriority (\p' _ acc -> p' < p && acc) True lt &&
                     foldWithPriority (\p' _ acc -> p' >= p && acc) True geq

prop_split2 :: Prio -> TestQueue -> Bool
prop_split2 p m = let (lt, geq) = splitByPriority p m
                  in size m == size lt + size geq

prop_fmap1 :: (Elem -> Elem) -> TestQueue -> Bool
prop_fmap1 f m = size (fmap f m) == size m

prop_functor1 :: TestQueue -> Bool
prop_functor1 m = fmap id m == m

prop_functor2 :: (Elem -> Elem) -> (Elem -> Elem) -> TestQueue -> Bool
prop_functor2 f g m = fmap f (fmap g m) == fmap (f . g) m

prop_monoid1 :: TestQueue -> Bool
prop_monoid1 m = m `mappend` mempty == m

prop_monoid2 :: TestQueue -> Bool
prop_monoid2 m = mempty `mappend` m == m

prop_monoid3 :: TestQueue -> TestQueue -> TestQueue -> Bool
prop_monoid3 m n o = m `mappend` (n `mappend` o) == (m `mappend` n) `mappend` o

prop_mappend1 :: TestQueue -> TestQueue -> Bool
prop_mappend1 m n =
  sort (toAscList (m `mappend` n)) == sort (toAscList m ++ toAscList n)

prop_toAscList_asc :: TestQueue -> Bool
prop_toAscList_asc = increasing . map snd . toAscList

increasing :: Ord a => [a] -> Bool
increasing []            = True
increasing [_]           = True
increasing (a : a' : as) = a <= a' && increasing (a' : as)

prop_minView1 :: TestQueue -> Bool
prop_minView1 m = case minView m of
                    Nothing          -> True
                    Just ((_,p), m') -> all (p <=) $ map snd (toAscList m')

prop_minView2 :: TestQueue -> Bool
prop_minView2 m = case minView m of
                    Nothing     -> True
                    Just (p, _) -> p `elem` toAscList m

prop_maxView1 :: TestQueue -> Bool
prop_maxView1 m = case maxView m of
                    Nothing          -> True
                    Just ((_,p), m') -> all (p >=) $ map snd (toAscList m')

prop_maxView2 :: TestQueue -> Bool
prop_maxView2 m = case maxView m of
                    Nothing     -> True
                    Just (p, _) -> p `elem` toAscList m

prop_minPriority1 :: TestQueue -> Property
prop_minPriority1 q = null q ==> isNothing (minPriority q)

prop_minPriority2 :: TestQueue -> Property
prop_minPriority2 q = not (null q) ==> correct
  where
    correct = filterWithPriority (\_ p -> p < minP) q == empty
    minP    = fromJust $ minPriority q


prop_maxPriority1 :: TestQueue -> Property
prop_maxPriority1 q = null q ==> isNothing (maxPriority q)

prop_maxPriority2 :: TestQueue -> Property
prop_maxPriority2 q = not (null q) ==> correct
  where
    correct = filterWithPriority (\_ p -> p > maxP) q == empty
    maxP    = fromJust $ maxPriority q


prop_deleteMax_mostRecent1 :: TestQueue -> Elem -> Property
prop_deleteMax_mostRecent1 q e = not (null q) ==> deleteMax q' == q
  where p  = fromJust $ maxPriority q
        q' = insert e p q

prop_deleteMin_mostRecent1 :: TestQueue -> Elem -> Property
prop_deleteMin_mostRecent1 q e = not (null q) ==> deleteMin q' == q
  where p  = fromJust $ minPriority q
        q' = insert e p q

prop_minView_mostRecent1 :: TestQueue -> Elem -> Property
prop_minView_mostRecent1 q e = not (null q) ==> mv == (e, p)
  where mv = fst $ fromJust $ minView $ insert e p q
        p  = fromJust $ minPriority q


        

tests :: [Test]
tests = [
          testGroup "MinMaxQueue invariants"
                        [
                          prop "nonempty" prop_nonempty
                        , prop "filter1" prop_filter1
                        , prop "filter2" prop_filter2
                        , prop "filter3" prop_filter3
                        , prop "filterWithPriority1" prop_filterWithPriority1
                        , prop "filterWithPriority2" prop_filterWithPriority2
                        , prop "filterWithPriority3" prop_filterWithPriority3
                        , prop "isEmpty" prop_isEmpty1
                        , prop "split1" prop_split1
                        , prop "split2" prop_split2
                        , prop "size 1" prop_size1
                        , prop "size 2" prop_size2
                        , prop "size 3" prop_size3
                        , prop "size 5" prop_size5
                        , prop "size 6" prop_size6
                        , prop "deleteMin size 1" prop_deleteMin_size1
                        , prop "deleteMax size 1" prop_deleteMax_size1
                        , prop "fmap 1" prop_fmap1
                        , prop "functor 1" prop_functor1
                        , prop "functor 2" prop_functor2
                        , prop "monoid 1" prop_monoid1
                        , prop "monoid 2" prop_monoid2
                        , prop "monoid 3" prop_monoid3
                        , prop "mappend 1" prop_mappend1
                        , prop "toAscList ascending" prop_toAscList_asc
                        , prop "minView 1" prop_minView1
                        , prop "minView 2" prop_minView2
                        , prop "maxView 1" prop_maxView1
                        , prop "maxView 2" prop_maxView2
                        , prop "most recent deleteMax" prop_deleteMax_mostRecent1
                        , prop "most recent deleteMin" prop_deleteMin_mostRecent1
                        , prop "most recent minView" prop_minView_mostRecent1
                        , prop "minPriority1" prop_minPriority1
                        , prop "minPriority2" prop_minPriority2
                        , prop "maxPriority1" prop_maxPriority1
                        , prop "maxPriority2" prop_maxPriority2
                        ]
        ]
  where prop = testProperty

main :: IO ()
main = defaultMain tests