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

All rights reserved.

For license and copyright information, see the file COPYRIGHT

-}

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

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances  #-}

module Data.Cardinality.CardinalityRange (
                -- * Core
                CardinalityRange_From
              , CardinalityRange_To
              , CardinalityRange
              , cardinalityRange
              , cr2Tuple
              , lazyVerfyCR
              , cFitsInCR_Proto
              , cFitsInCR
              , fitsInCR
              , fitsInCR_T
              , FirstOrSecond(..)
              , Compare2CRsError(..)
              , compare2CRs
              , crFitsInCR

              -- * Popular cardinality ranges constructors
              , crNoConstraint
              , cr0
              , cr1
              , cr0_1
              , cr0_Inf
              , cr1_Inf
              , crX
              , crXY
              ) where

import Data.Cardinality.Cardinality
import Data.EmptySet
import Data.Intersectable
import Data.NeverEmptyList
import qualified Data.Map as M
import Data.Map (Map, (!))
import Data.Word
import Data.Typeable
-- import Debug.Trace
import Control.Monad.Identity

--------------------------------------------------------------
-- * Core

type CardinalityRange_From = LazyCardinality
type CardinalityRange_To   = LazyCardinality
-- | Constructor: @'cardinalityRange' 'CardinalityRange_From' 'CardinalityRange_To'@
data CardinalityRange = CardinalityRange CardinalityRange_From CardinalityRange_To deriving (Show)

-- | @CardinalityRange@ data constructor. The range is always including it's
-- boundaries. F.e., range
-- @'CardinalityRange' ('preciseC' 1) ('preciseC' 4)@ contains
-- cardinalities [1,2,3,4].
-- First cardinality MUST always be less or equal to second one. However,
-- we do not fully guard from such type of error - we do not refine
-- @'refinableC'@, if it participates in the constriction.
cardinalityRange :: CardinalityRange_From -> CardinalityRange_To -> CardinalityRange
cardinalityRange from to =
        case lazyVerfyCR from to of
            Just False -> error $ "Cardinality range can't be constructed with lower boundary higher than lower one (" ++ show from ++ ", "++ show to ++ ")."
            _ -> CardinalityRange from to

cr2Tuple :: CardinalityRange -> (CardinalityRange_From, CardinalityRange_From)
cr2Tuple (CardinalityRange from to) = (from, to)

lazyVerfyCR :: CardinalityRange_From -> CardinalityRange_To -> Maybe Bool
lazyVerfyCR from to = lazyCompare2LCs from to >>= return . (/= GT)

-- | Root prototype for all subsequent \"FitsIn\" functions. Returns probably
-- refined cardinality and range, which is useful for reuse.
-- If returns @EQ@ then subject cardinality
-- is between boundaries (including) of cardinality range.
--
-- Uses @'almostStrictCompare2LCs'@ function.
cFitsInCR_Proto :: LazyCardinality -> CardinalityRange -> (Ordering, LazyCardinality, CardinalityRange)
cFitsInCR_Proto c (CardinalityRange lo_c hi_c) =
        let (ord1, c_2, lo_c_2) = c `almostStrictCompare2LCs` lo_c
         in case ord1 of
                LT -> (ord1, c_2, cardinalityRange lo_c_2 hi_c)
                _  -> let (ord2, c_3, hi_c_2) = c_2 `almostStrictCompare2LCs` hi_c
                          ord3 = case ord2 of { GT -> GT; _ -> EQ }
                       in (ord3, c_3, cardinalityRange lo_c_2 hi_c_2)
infixr 9 `cFitsInCR_Proto`

-- | @'LazyCardinality'@ fits in @'CardinalityRange'@?
cFitsInCR :: LazyCardinality -> CardinalityRange -> Bool
cFitsInCR c cr = fst3 (c `cFitsInCR_Proto` cr) == EQ
        where fst3 (a,_,_) = a
infixr 9 `cFitsInCR`

-- | Wrapper around @'cFitsInCR'@.
fitsInCR :: HasCard a => a -> CardinalityRange -> Bool
fitsInCR hasC cr = cardOf hasC `cFitsInCR` cr
infixr 9 `fitsInCR`

-- | Wrapper around @'cFitsInCR'@.
fitsInCR_T :: HasCardT c => c a -> CardinalityRange -> Bool
fitsInCR_T hasC cr = cardOfT hasC `cFitsInCR` cr
infixr 9 `fitsInCR_T`

-- | Used in @'Compare2CRsError'@
data FirstOrSecond = First | Second deriving (Show)
-- | Error, that may occur, when performing @'compare2CRs'@
data Compare2CRsError = LowerBoundaryAfterHigher FirstOrSecond CardinalityRange
instance Show Compare2CRsError where
        show e = "An error occurred when trying to compare 2 cardinality ranges: " ++
            case e of
                LowerBoundaryAfterHigher fs cr -> show fs ++ " cardinality range (" ++ show cr ++ ") is ill defined - lower boundary is greater then higher one."

-- | This function is made hard, but fast. It tends to make minimal amount
-- of comparisons, reusing refinements.
compare2CRs :: CardinalityRange -> CardinalityRange -> (Either Compare2CRsError (SetsFit CardinalityRange), CardinalityRange, CardinalityRange)
compare2CRs (CardinalityRange lo_cr1_0 hi_cr1_0) (CardinalityRange lo_cr2_0 hi_cr2_0) =
        let step1@(order1, hi_cr1_1, lo_cr2_1) = almostStrictCompare2LCs hi_cr1_0 lo_cr2_0 -- 1: 0 1 1 0
         in case order1 of -- traceShow ("Step 1: ", step1)
                 LT -> (Right NoIntersection, CardinalityRange lo_cr1_0 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_0)
                 EQ -> let step2@(order2, lo_cr1_1, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_0 hi_cr1_1 -- 2: 1 2 1 0
                           cr1_2 = CardinalityRange lo_cr1_1 hi_cr1_2
                           cr2_2 = CardinalityRange lo_cr2_1 hi_cr2_0
                           answ_2 err_or_fit = (err_or_fit, cr1_2, cr2_2)
                        in case order2 of -- traceShow ("Step 2: ", step2)
                               LT -> let step21@(order21, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 21: 1 2 2 1
                                         cr1_21 = CardinalityRange lo_cr1_1 hi_cr1_2
                                         cr2_21 = CardinalityRange lo_cr2_2 hi_cr2_1
                                         answ_21 err_or_fit = (err_or_fit, cr1_21, cr2_21)
                                      in answ_21 $ case order21 of
                                             EQ -> Right SecondInFirst
                                             GT -> Right $ Intersection $ CardinalityRange hi_cr1_2 lo_cr2_2
                                             LT -> Left $ LowerBoundaryAfterHigher Second cr2_21
                               GT -> answ_2 $ Left $ LowerBoundaryAfterHigher First cr1_2
                               EQ -> let step3@(order3, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0 -- 3: 1 2 2 1
                                         cr1_3 = CardinalityRange lo_cr1_1 hi_cr1_2
                                         cr2_3 = CardinalityRange lo_cr2_2 hi_cr2_1
                                         answ_3 err_or_fit = (err_or_fit, cr1_3, cr2_3)
                                      in answ_3 $ case order3 of -- traceShow ("Step 3: ", step3)
                                             LT -> Right FirstInSecond
                                             EQ -> Right EqualSets
                                             GT -> Left $ LowerBoundaryAfterHigher First cr1_3
                 GT -> let step4@(order4, lo_cr1_1, hi_cr2_1) = almostStrictCompare2LCs lo_cr1_0 hi_cr2_0  -- 4: 1 1 1 1
                        in case order4 of
                               GT -> (Right NoIntersection, CardinalityRange lo_cr1_1 hi_cr1_1, CardinalityRange lo_cr2_1 hi_cr2_1)
                               EQ -> let step5@(order5, lo_cr2_2, hi_cr2_2) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_1 -- 5: 1 1 2 2
                                         cr1_5 = CardinalityRange lo_cr1_1 hi_cr1_1
                                         cr2_5 = CardinalityRange lo_cr2_2 hi_cr2_2
                                         answ_5 err_or_fit = (err_or_fit, cr1_5, cr2_5)
                                      in case order5 of
                                             LT -> let step51@(order51, lo_cr1_2, hi_cr1_2) = almostStrictCompare2LCs lo_cr1_1 hi_cr1_1 -- 51: 2 2 2 2
                                                       cr1_51 = CardinalityRange lo_cr1_2 hi_cr1_2
                                                       cr2_51 = CardinalityRange lo_cr2_2 hi_cr2_2
                                                       answ_51 err_or_fit = (err_or_fit, cr1_51, cr2_51)
                                                    in answ_51 $ case order51 of
                                                             LT -> Left $ LowerBoundaryAfterHigher First cr1_51
                                                             EQ -> Right FirstInSecond
                                                             GT -> Right $ Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2
                                             EQ -> answ_5 $ Right SecondInFirst
                                             GT -> answ_5 $ Left $ LowerBoundaryAfterHigher Second cr2_5
                               LT -> let step6@(order6, lo_cr1_2, lo_cr2_2) = almostStrictCompare2LCs lo_cr1_1 lo_cr2_1 -- 6: 2 1 2 1
                                         step7@(order7, hi_cr1_2, hi_cr2_2) = almostStrictCompare2LCs hi_cr1_1 hi_cr2_1 -- 7: 2 2 2 2
                                         cr1_67 = CardinalityRange lo_cr1_2 hi_cr1_2
                                         cr2_67 = CardinalityRange lo_cr2_2 hi_cr2_2
                                         answ_67 _fit = (Right _fit, cr1_67, cr2_67)
                                      in answ_67 $ case (order6, order7) of
                                             (EQ, EQ) -> EqualSets
                                             (EQ, GT) -> SecondInFirst
                                             (LT, EQ) -> SecondInFirst
                                             (LT, GT) -> SecondInFirst
                                             (EQ, LT) -> FirstInSecond
                                             (GT, LT) -> FirstInSecond
                                             (GT, EQ) -> FirstInSecond
                                             (LT, LT) -> Intersection $ CardinalityRange lo_cr2_2 hi_cr1_2
                                             (GT, GT) -> Intersection $ CardinalityRange lo_cr1_2 hi_cr2_2

instance Intersectable CardinalityRange where
     setFits cr1 cr2 = case fst3 $ compare2CRs cr1 cr2 of { Right r -> r; Left e -> error $ show e }
        where
           fst3  :: (a,b,c) -> a
           fst3  (a,_,_) = a

-- | Wrapper around @'setFits'@ of typeclass @'Intersectable'@
crFitsInCR :: CardinalityRange -> CardinalityRange -> SetsFit CardinalityRange
crFitsInCR = setFits
infixr 9 `crFitsInCR`

-- * Popular cardinality ranges constructors.

-- | Same as @'cr0_Inf'@.
crNoConstraint :: CardinalityRange
-- | Only zero elements.
cr0            :: CardinalityRange
-- | Only one element.
cr1            :: CardinalityRange
-- | Zero or one element.
cr0_1          :: CardinalityRange
-- | Any count of elements.
cr0_Inf        :: CardinalityRange
-- | Any nonzero count of elements.
cr1_Inf        :: CardinalityRange
-- | Concrete count of elements.
crX            :: PreciseCardinality -> CardinalityRange
-- | A concrete range.
crXY           :: PreciseCardinality -> PreciseCardinality -> CardinalityRange

crNoConstraint = cr0_Inf
cr0            = cardinalityRange (preciseC 0) (preciseC 0)
cr1            = cardinalityRange (preciseC 1) (preciseC 1)
cr0_1          = cardinalityRange (preciseC 0) (preciseC 1)
cr0_Inf        = cardinalityRange (preciseC 0) infiniteC
cr1_Inf        = cardinalityRange (preciseC 1) infiniteC
crX          x = cardinalityRange (preciseC x) (preciseC x)
crXY       x y = cardinalityRange (preciseC x) (preciseC y)