module Data.Cardinality.CardinalityRange (
CardinalityRange_From
, CardinalityRange_To
, CardinalityRange
, cardinalityRange
, cr2Tuple
, lazyVerfyCR
, cFitsInCR_Proto
, cFitsInCR
, fitsInCR
, fitsInCR_T
, FirstOrSecond(..)
, Compare2CRsError(..)
, compare2CRs
, crFitsInCR
, 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 Control.Monad.Identity
type CardinalityRange_From = LazyCardinality
type CardinalityRange_To = LazyCardinality
data CardinalityRange = CardinalityRange CardinalityRange_From CardinalityRange_To deriving (Show)
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)
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`
cFitsInCR :: LazyCardinality -> CardinalityRange -> Bool
cFitsInCR c cr = fst3 (c `cFitsInCR_Proto` cr) == EQ
where fst3 (a,_,_) = a
infixr 9 `cFitsInCR`
fitsInCR :: HasCard a => a -> CardinalityRange -> Bool
fitsInCR hasC cr = cardOf hasC `cFitsInCR` cr
infixr 9 `fitsInCR`
fitsInCR_T :: HasCardT c => c a -> CardinalityRange -> Bool
fitsInCR_T hasC cr = cardOfT hasC `cFitsInCR` cr
infixr 9 `fitsInCR_T`
data FirstOrSecond = First | Second deriving (Show)
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."
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
in case order1 of
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
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
LT -> let step21@(order21, lo_cr2_2, hi_cr2_1) = almostStrictCompare2LCs lo_cr2_1 hi_cr2_0
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
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
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
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
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
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
step7@(order7, hi_cr1_2, hi_cr2_2) = almostStrictCompare2LCs hi_cr1_1 hi_cr2_1
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
crFitsInCR :: CardinalityRange -> CardinalityRange -> SetsFit CardinalityRange
crFitsInCR = setFits
infixr 9 `crFitsInCR`
crNoConstraint :: CardinalityRange
cr0 :: CardinalityRange
cr1 :: CardinalityRange
cr0_1 :: CardinalityRange
cr0_Inf :: CardinalityRange
cr1_Inf :: CardinalityRange
crX :: PreciseCardinality -> CardinalityRange
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)