Cardinality-0.2: examples/CardinalityRangeCompareTest.hs

{-
Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>

All rights reserved.

For license and copyright information, see the file COPYRIGHT

-}

--------------------------------------------------------------------------
--------------------------------------------------------------------------

import Data.Cardinality
import Data.Intersectable
import Data.Map
import Control.Monad

compare2CRs_testSet :: [(SetsFit CardinalityRange, (CardinalityRange, CardinalityRange))]
compare2CRs_testSet =
        [
          (EqualSets, (crXY 5 10, crXY 5 10))
        , (EqualSets, (crX 5, crX 5))

        , (NoIntersection, (crXY 5 10, crXY 2 4))
        , (NoIntersection, (crXY 5 10, crXY 11 15))

        , (SecondInFirst, (crXY 5 10, crX 10))
        , (SecondInFirst, (crXY 5 10, crX 5))
        , (SecondInFirst, (crXY 5 10, crXY 5 7))
        , (SecondInFirst, (crXY 5 10, crXY 7 10))
        , (SecondInFirst, (crXY 5 10, crXY 6 8))

        , (FirstInSecond, (crX 10, crXY 5 10))
        , (FirstInSecond, (crX 5, crXY 5 10))
        , (FirstInSecond, (crXY 5 7, crXY 5 10))
        , (FirstInSecond, (crXY 7 10, crXY 5 10))
        , (FirstInSecond, (crXY 6 8, crXY 5 10))

        , (Intersection $ crXY 8 10, (crXY 5 10, crXY 8 13))
        , (Intersection $ crXY 5 8, (crXY 2 8, crXY 5 10))
        ]

compare2CRs_test :: (String -> IO ()) -> IO ()
compare2CRs_test _putStrLn = flip mapM_ (zip [1..] compare2CRs_testSet)
        (\ (idx, (correct_answer, (cr1, cr2))) ->
                let (answ, cr1_2, c2_2) = compare2CRs cr1 cr2
                    wrapped_correct_answer :: Either Compare2CRsError (SetsFit CardinalityRange)
                    wrapped_correct_answer = Right correct_answer
                 in case (show answ) == (show wrapped_correct_answer) of
                        True  -> _putStrLn (show idx ++ ") OK")
                        False -> _putStrLn (show idx ++ ") " ++ show answ ++ " /= " ++ show correct_answer)
        )

main = compare2CRs_test putStrLn