{- Copyright (C) 2010 Andrejs Sisojevs 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)