{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
module IntervalAlgebraSpec
  ( spec
  ) where

import           Data.Either                    ( isRight )
import           Data.Fixed                     ( Pico )
import           Data.Maybe                     ( fromJust
                                                , isJust
                                                , isNothing
                                                )
import           Data.Set                       ( Set
                                                , disjointUnion
                                                , fromList
                                                , member
                                                )
import           Data.Time                     as DT
                                                ( Day(..)
                                                , DiffTime
                                                , NominalDiffTime
                                                , UTCTime(..)
                                                , fromGregorian
                                                , picosecondsToDiffTime
                                                , secondsToDiffTime
                                                )
import           GHC.Real                       ( Rational(..)
                                                , Real(..)
                                                )
import           IntervalAlgebra               as IA
import           IntervalAlgebra.Arbitrary      ( )
import           Test.Hspec                     ( Spec
                                                , describe
                                                , hspec
                                                , it
                                                , shouldBe
                                                )
import           Test.Hspec.QuickCheck          ( modifyMaxDiscardRatio
                                                , modifyMaxSuccess
                                                )
import           Test.QuickCheck                ( (===)
                                                , (==>)
                                                , Arbitrary(arbitrary)
                                                , Gen(..)
                                                , Property
                                                , Testable(property)
                                                , generate
                                                , quickCheck
                                                )

mkIntrvl :: Int -> Int -> Interval Int
mkIntrvl = beginerval

prop_expandl_end
  :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property
prop_expandl_end d i = end (expandl d i) === end i


prop_expandr_begin
  :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property
prop_expandr_begin d i = begin (expandr d i) === begin i

-- | The relation between x and z should be an element of the set of the
--   composed relations between x y and between y z.
prop_compose :: Ord a => Interval a -> Interval a -> Interval a -> Property
prop_compose x y z =
  member (relate x z) (compose (relate x y) (relate y z)) === True

-- | If two intervals are disjoint and not meeting, then there should be a gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_gap_exists :: Ord a => Interval a -> Interval a -> Property
prop_combinable_gap_exists x y =
  (before <|> after) x y ==> isJust ((><) (min x y) (max x y))

-- | If two intervals are not disjoint or meeting, then there should be NO gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_nogap_exists :: Ord a => Interval a -> Interval a -> Property
prop_combinable_nogap_exists x y =
  (predicate $ complement $ fromList [Before, After]) x y
    ==> isNothing ((><) (min x y) (max x y))


spec :: Spec
spec = do
  describe "Basic Interval unit tests of typeclass and creation methods" $ do
    it "equality works"
      $          beginerval 6 (1 :: Int)
      ==         beginerval 6 1
      `shouldBe` True
    it "equality works"
      $          beginerval 0    (1 :: Int)
      ==         beginerval (-1) 1
      `shouldBe` True
    it "equality works"
      $          enderval 1 (2 :: Int)
      ==         beginerval 1 1
      `shouldBe` True
    it "not equality works"
      $          enderval 5 (2 :: Int)
      /=         beginerval 1 1
      `shouldBe` True

    it "beginervalMoment duration is moment"
      $          duration (beginervalMoment (-13 :: Int))
      `shouldBe` (moment @Int)
    it "endervalMoment duration is moment"
      $          duration (endervalMoment (26 :: Int))
      `shouldBe` (moment @Int)

    it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left
      (IA.ParseErrorInterval "0<=10")
    it "parsing fails on bad inputs" $ parseInterval 0 0 `shouldBe` Left
      (IA.ParseErrorInterval "0<=0")
    it "parsing works on good inputs" $ parseInterval 0 10 `shouldBe` Right
      (beginerval 10 (0 :: Int))

    it "show displays intervals as expected"
      $          show (beginerval 10 (0 :: Int))
      `shouldBe` "(0, 10)"

    -- NOTE toEnum (fromGregorian 1858 11 17) is 0,
    -- since that date is the origin in the modified
    -- Julian calendar.
    it "fromEnumInterval converts Interval Day"
      $          fromEnumInterval (beginerval 0 (fromGregorian 1858 11 17))
      `shouldBe` beginerval 0 0

    it "(0, 2) <= (1, 3) is True"
      $          beginerval 2 (0 :: Int)
      <=         beginerval 2 1
      `shouldBe` True

    it "(1, 2) < (0, 3) is True"
      $          beginerval 2 (1 :: Int)
      <          beginerval 3 0
      `shouldBe` False
    it "(0, 2) < (1, 3) is True"
      $          beginerval 2 (0 :: Int)
      <          beginerval 2 1
      `shouldBe` True
    it "(0, 2) < (0, 3) is True"
      $          beginerval 2 (0 :: Int)
      <          beginerval 3 0
      `shouldBe` True

  describe "Basic IntervalRelation unit tests" $ do
    it "equality of IntervalRelations" $ Before == Before `shouldBe` True
    it "equality of IntervalRelations" $ Before /= After `shouldBe` True

    it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before
    it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After

    it "show Before is Before" $ show Before `shouldBe` "Before"

  describe "Relate unit tests" $ do
    it "relate before"
      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 2)
      `shouldBe` Before
    it "relate after"
      $          relate (beginerval 1 (2 :: Int)) (beginerval 1 0)
      `shouldBe` After
    it "relate meets"
      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 1)
      `shouldBe` Meets
    it "relate metBy"
      $          relate (beginerval 1 (1 :: Int)) (beginerval 1 0)
      `shouldBe` MetBy
    it "relate overlaps"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 2)
      `shouldBe` Overlaps
    it "relate overlappedBy"
      $          relate (beginerval 5 (2 :: Int)) (beginerval 3 0)
      `shouldBe` OverlappedBy
    it "relate starts"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 0)
      `shouldBe` Starts
    it "relate startedBy"
      $          relate (beginerval 5 (0 :: Int)) (beginerval 3 0)
      `shouldBe` StartedBy
    it "relate finishes"
      $          relate (enderval 3 (0 :: Int)) (enderval 5 0)
      `shouldBe` Finishes
    it "relate finishedBy"
      $          relate (enderval 5 (0 :: Int)) (enderval 3 0)
      `shouldBe` FinishedBy
    it "relate during"
      $          relate (beginerval 1 (1 :: Int)) (beginerval 3 0)
      `shouldBe` During
    it "relate Contains"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 1 1)
      `shouldBe` Contains

  describe "IntervalRelation algebraic operations" $ do
    it "converse of Before is After"
      $          converse (fromList [Before])
      `shouldBe` fromList [After]

    it "union of IntervalRelations"
      $          union (fromList [Before]) (fromList [After])
      `shouldBe` fromList [Before, After]
    it "intersection of IntervalRelations"
      $          intersection (fromList [Before]) (fromList [After])
      `shouldBe` fromList []

  describe "IntervalSizeable tests" $ do
    it "moment is 1" $ moment @Int `shouldBe` 1
    it "expandl doesn't change end" $ property (prop_expandl_end @Int)
    it "expandr doesn't change begin" $ property (prop_expandr_begin @Int)
    it "expand 0 5 Interval (0, 1) should be Interval (0, 6)"
      $          expand 0 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (0 :: Int)
    it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)"
      $          expand 5 0 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (-5 :: Int)
    it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)"
      $          expand 5 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (11 :: Int) (-5 :: Int)
    it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)"
      $          expand (-1) 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (0 :: Int)
    it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)"
      $          expand 5 (-5) (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (-5 :: Int)
    it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)"
      $          expand (moment @Int) 0 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (2 :: Int) (-1 :: Int)

    it "beginerval 2 10 should be Interval (10, 12)"
      $          Right (beginerval (2 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (12 :: Int)
    it "beginerval 0 10 should be Interval (10, 11)"
      $          Right (beginerval (0 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (11 :: Int)
    it "beginerval -2 10 should be Interval (10, 11)"
      $          Right (beginerval (-2 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (11 :: Int)
    it "enderval 2 10 should be Interval (8, 10)"
      $          Right (enderval (2 :: Int) 10)
      `shouldBe` parseInterval (8 :: Int) (10 :: Int)
    it "enderval 0 10 should be Interval (9, 10)"
      $          Right (enderval (0 :: Int) 10)
      `shouldBe` parseInterval (9 :: Int) (10 :: Int)
    it "enderval -2 10 should be Interval (9, 10)"
      $          Right (enderval (-2 :: Int) 10)
      `shouldBe` parseInterval (9 :: Int) (10 :: Int)

    it "shiftFromBegin can convert Interval Int to Interval Int"
      $          shiftFromBegin (beginerval 2 (4 :: Int)) (beginerval 2 10)
      `shouldBe` beginerval 2 6 -- (6, 8)

    it "shiftFromEnd can convert Interval Int to Interval Int"
      $          shiftFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10)
      `shouldBe` beginerval 2 4 -- (4, 6)

    it "shiftFromBegin can convert Interval Day to Interval Integer"
      $          shiftFromBegin (beginerval 2 (fromGregorian 2001 1 1))
                                (beginerval 2 (fromGregorian 2001 1 10))
      `shouldBe` beginerval 2 9 -- (9, 11)

    it "shiftFromEnd can convert Interval Day to Interval Integer"
      $          shiftFromEnd (beginerval 2 (fromGregorian 2001 1 1))
                              (beginerval 2 (fromGregorian 2001 1 10))
      `shouldBe` beginerval 2 7 -- (7, 9)

    it "momentize works"
      $          momentize (beginerval 2 (fromGregorian 2001 1 1))
      `shouldBe` beginerval 1 (fromGregorian 2001 1 1)


  describe "Intervallic tests" $
    --  modifyMaxSuccess (*10000) $
                                 do
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1))
      `shouldBe` True
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0)
      `shouldBe` True
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1))
      `shouldBe` False
    it "disjoint x y same as explicit union of predicates"
      $          disjoint (mkIntrvl 2 0) (mkIntrvl 2 3)
      `shouldBe` (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0)
                                                        (mkIntrvl 2 3)
    it "within x y same as explicit union of predicates"
      $          within (mkIntrvl 2 3) (mkIntrvl 2 3)
      `shouldBe` (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3)
                                                             (mkIntrvl 2 3)
    it "prop_compose holds" $ property (prop_compose @Int)

  describe "IntervalCombinable tests" $ do
    it "join non-meeting intervals is Nothing"
      $          beginerval 2 (0 :: Int)
      .+.        beginerval 6 5
      `shouldBe` Nothing
    it "join meeting intervals is Just _"
      $          beginerval 2 (0 :: Int)
      .+.        beginerval 6 2
      `shouldBe` Just (beginerval 8 0)

    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @Int)
    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @Day)
    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @UTCTime)

    it "gap of nondisjoint, nonmeeting intervals should be nothing"
      $ property (prop_combinable_nogap_exists @Int)
    it "gap of nondisjoint, nonmeeting intervals should be nothing"
      $ property (prop_combinable_nogap_exists @Day)

  describe "Interval Algebra relation unit tests for synonyms" $ do
    it "(0, 2) precedes (10, 12)"
      $          beginerval 2 (0 :: Int)
      `precedes` beginerval 2 10
      `shouldBe` True
    it "precedes matches before"
      $          beginerval 10 (0 :: Int)
      `precedes` beginerval 1  11
      `shouldBe` beginerval 10 (0 :: Int)
      `before`   beginerval 1  11
    it "(10, 12) precededBy (0, 2)"
      $          precededBy (beginerval 2 10) (beginerval 2 (0 :: Int))
      `shouldBe` True
    it "precededBy matches after"
      $          precededBy (beginerval 1 11) (beginerval 10 (0 :: Int))
      `shouldBe` after (beginerval 1 11) (beginerval 10 (0 :: Int))
    it "concur matches notDdisjoint"
      $          concur (beginerval 1 11) (beginerval 10 (0 :: Int))
      `shouldBe` notDisjoint (beginerval 1 11) (beginerval 10 (0 :: Int))
    it "concur matches notDisjoint"
      $          concur (beginerval 1 0) (beginerval 10 (0 :: Int))
      `shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int))