heaps.hs

{-# Language DeriveDataTypeable, NoMonomorphismRestriction #-}
import Test.FitSpec
import Prelude hiding (null)
import qualified Data.List as L
import Data.Maybe (listToMaybe)
import Heap
import Control.Monad (unless)

instance (Ord a, Listable a) => Listable (Heap a) where
  tiers = bagCons fromList

-- a good property to assure that the above does not leave out elements is:
--
-- \xs ys =  xs `permutation` ys  <==>  fromList xs == fromList ys
--                                          `asTypeOf` (undefined :: Heap a)

instance (Ord a, Listable a) => Mutable (Heap a) where
  mutiers = mutiersEq 

instance (Ord a, Show a, Listable a) => ShowMutable (Heap a) where
  mutantS = mutantSEq

-- Alias for type (they are repeated a lot)
type Insert a    = a -> Heap a -> Heap a
type DeleteMin a = Heap a -> Heap a
type Merge a     = Heap a -> Heap a -> Heap a
type Ty a        = (Insert a, DeleteMin a, Merge a)

properties :: (Ord a, Show a, Listable a)
           => Insert a
           -> DeleteMin a
           -> Merge a
           -> [Property]
properties insert' deleteMin' merge' =
  [ property $ \x y h ->      insert' x (insert' y h) == insert' y (insert' x h) --  1
  , property $ \h x ->             null (insert' x h) == False                   --  2
  , property $ \x h ->          L.insert x (toList h) == toList (insert' x h)    --  3

  , property $ \h h1 ->                   merge' h h1 == merge' h1 h             --  4
  , property $ \h ->                     merge' h Nil == h                       --  5
  , property $ \h h1 h2 ->    merge' h (merge' h1 h2) == merge' h1 (merge' h h2) --  6
  , property $ \h -> not (null h) ==> findMin (merge' h h) == findMin h          --  7
  , property $ \h ->                null (merge' h h) == null h                  --  8
  , property $ \h h1 ->           (null h && null h1) == null (merge' h h1)      --  9

  , property $ \h h1 x ->     merge' h (insert' x h1) == insert' x (merge' h h1) -- 10
  , property $ \h -> not (null h) ==> merge' h (deleteMin' h) == deleteMin' (merge' h h) -- 11
  , property $ \x ->       deleteMin' (insert' x Nil) == Nil                     -- 12
  ]

sargs = args
  { timeout  = 0
  , nMutants = 500
  , nTests   = 500
  , names    = ["insert x h","deleteMin h","merge h h'"]
--, extraMutants = take 0 [(uncurry maxInsert,maxDeleteMin,uncurry maxMerge)] }
  }

fns :: Ord a => Ty a
fns = (insert, deleteMin, merge)

em :: (Bounded a, Ord a) => [Ty a]
em = take 3
  [ (maxInsert, maxDeleteMin, maxMerge)
  , (insert, deleteMin, crazyMerge)
  , (\i h -> Nil, deleteMin, merge)
  ]

main :: IO ()
main = do 
  as <- getArgsWith sargs
  let run f = reportWithExtra em as f (uncurry3 properties)
  case concat (extra as) of
--  "bool"  -> run (fns :: Ty Bool)
--  "bools" -> run (fns :: Ty [Bool])
    "i"     -> run (fns :: Ty Int)
    "i1"    -> run (fns :: Ty Int1)
    "i2"    -> run (fns :: Ty Int2)
    "i3"    -> run (fns :: Ty Int3)
    "w1"    -> run (fns :: Ty Word1)
    "w2"    -> run (fns :: Ty Word2)
    "w3"    -> run (fns :: Ty Word3)
    "unit"  -> run (fns :: Ty ())
    ""      -> run (fns :: Ty Word2)


maxInsert :: Ord a => a -> Heap a -> Heap a
maxInsert x h = maxMerge h (branch x Nil Nil)

maxDeleteMin :: Ord a => Heap a -> Heap a
maxDeleteMin (Branch _ _ l r) = maxMerge l r
maxDeleteMin Nil              = Nil

maxMerge :: Ord a => Heap a -> Heap a -> Heap a
maxMerge Nil h = h
maxMerge h Nil = h
maxMerge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2)
 | x1 >= x2 = branch x1 (maxMerge l1 h2) r1
 | otherwise = maxMerge h2 h1

uncurry3 :: (a->b->c->d) -> (a,b,c) -> d
uncurry3 f (x,y,z) = f x y z

crazyMerge :: (Bounded a, Ord a) => Heap a -> Heap a -> Heap a
crazyMerge Nil Nil = Nil
crazyMerge Nil h = h
crazyMerge h Nil = h
crazyMerge h h1 = insert maxBound $ merge h h1