diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +LICENSE + +The MIT License + +Copyright (c) 2017 Sebastian Pulido Gomez and Stack Builders Inc. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/scalendar.cabal b/scalendar.cabal new file mode 100644 --- /dev/null +++ b/scalendar.cabal @@ -0,0 +1,45 @@ +name: scalendar +version: 1.0.0 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 +synopsis: This is a library for handling calendars and resource availability + based on the "top-nodes algorithm" and set operations. +homepage: https://github.com/stackbuilders/scalendar +license: MIT +license-file: LICENSE +copyright: 2017 Stack Builders Inc. +author: Sebastian Pulido Gómez +maintainer: Stack Builders +category: Time +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Time.SCalendar.Operations + , Time.SCalendar.Zippers + , Time.SCalendar.Types + , Time.SCalendar.Internal + build-depends: base >= 4.8 && < 5 + , containers >= 0.5.7.1 && < 0.6 + , time >= 1.5 && < 2 + , text >= 1.2.0.0 && < 2 + default-language: Haskell2010 + +test-suite scalendar-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: SCalendarTest.Internal + , SCalendarTest.Operations + , SCalendarTest.Arbitrary + , SCalendarTest.Helpers + , SCalendarTest.Constructors + main-is: Test.hs + build-depends: base + , scalendar + , hspec >= 2.4.2 && < 3.0 + , QuickCheck >= 2.9.2 && < 3.0 + , time + , containers + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 diff --git a/src/Time/SCalendar/Internal.hs b/src/Time/SCalendar/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Time/SCalendar/Internal.hs @@ -0,0 +1,309 @@ +module Time.SCalendar.Internal + ( getInterval + , daysBetween + , goToNode + , updateQ + , intervalFitsCalendar + , checkQuantAvailability + , checkReservAvailability + , updateCalendar + , topMostNodes + , leftMostTopNode + , rightMostTopNode + , commonParent + , getZipInterval + , getQMax + ) where + + +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Set (Set, union, unions, size, difference, isSubsetOf) +import Data.Maybe (listToMaybe, maybe) +import Control.Monad (guard) +import Time.SCalendar.Zippers +import Time.SCalendar.Types +import qualified Data.Time as TM (diffUTCTime) + + +daysBetween :: UTCTime -> UTCTime -> Int +daysBetween from to = 1 + round (TM.diffUTCTime to from / oneDay) + +intervalFitsCalendar :: TimePeriod -> Calendar -> Bool +intervalFitsCalendar interval1 (Node interval2 _ _ _ _) = + isIncluded (toTimeUnit interval1) (toTimeUnit interval2) +intervalFitsCalendar _ _ = False + +getInterval :: Calendar -> TimePeriod +getInterval (Unit unit _ _) = unit +getInterval (Node interval _ _ _ _) = toTimeUnit interval + +getZipInterval :: CalendarZipper -> TimePeriod +getZipInterval (node, _) = (toTimeUnit . getInterval) node + +getQ :: CalendarZipper -> Set Text +getQ (Unit _ q _, _) = q +getQ (Node _ q _ _ _, _) = q + +getQN :: CalendarZipper -> Set Text +getQN (Unit _ _ qn, _) = qn +getQN (Node _ _ qn _ _, _) = qn + +getQMax :: CalendarZipper -> Maybe (Set Text) +getQMax zipper@(_, []) = Just $ getQ zipper +getQMax zipper = do + parent <- goUp zipper + go parent (getQ zipper) + where + go zipper@(_, []) sum = do + let qn = getQN zipper + return $ union sum qn + go zipper sum = do + let qn = getQN zipper + parent <- goUp zipper + go parent $ union sum qn + +leftMostTopNode :: TimePeriod + -> Calendar + -> Maybe CalendarZipper +leftMostTopNode interval calendar = do + guard $ intervalFitsCalendar interval calendar + result <- ltmNode (getFrom interval, getTo interval) (toZipper calendar) + listToMaybe result + where + ltmNode (lower, upper) zipper@(Unit t _ _, _) + | lower == getFrom t && getFrom t <= upper = Just [zipper] + | otherwise = Just [] + ltmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do + let (from, to) = (getFrom t, getTo t) + (lChild, bsl) <- goLeft node + (rChild, bsr) <- goRight node + if lower == from && to <= upper + then Just [node] + else do + let toL = (getTo . getInterval) lChild + fromR = (getFrom . getInterval) rChild + lAnswer <- + if lower <= toL + then ltmNode i (lChild, bsl) + else Just [] + rAnswer <- + if lower >= fromR + then ltmNode i (rChild, bsr) + else Just [] + return $ lAnswer ++ rAnswer + +rightMostTopNode :: TimePeriod + -> Calendar + -> Maybe CalendarZipper +rightMostTopNode interval calendar = do + guard $ intervalFitsCalendar interval calendar + result <- rtmNode (getFrom interval, getTo interval) (toZipper calendar) + listToMaybe result + where + rtmNode (lower, upper) zipper@(Unit t _ _, _) + | upper == getFrom t && getFrom t >= lower = Just [zipper] + | otherwise = Just [] + rtmNode i@(lower, upper) node@(Node t _ _ _ _, _) = do + let (from, to) = (getFrom t, getTo t) + (lChild, bsl) <- goLeft node + (rChild, bsr) <- goRight node + if upper == to && from >= lower + then Just [node] + else do + let toL = (getTo . getInterval) lChild + fromR = (getFrom . getInterval) rChild + lAnswer <- + if upper <= toL + then rtmNode i (lChild, bsl) + else Just [] + rAnswer <- + if upper >= fromR + then rtmNode i (rChild, bsr) + else Just [] + return $ lAnswer ++ rAnswer + +commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper +commonParent zipper1@(node1, bs1) zipper2@(node2, bs2) = do + let bs1Length = length bs1 + bs2Length = length bs2 + interval1 = getInterval node1 + interval2 = getInterval node2 + case bs1Length `compare` bs2Length of + LT -> do + zipper2' <- goUp zipper2 + commonParent zipper1 zipper2' + EQ -> + if interval1 == interval2 + then Just zipper1 + else do + zipper1' <- goUp zipper1 + zipper2' <- goUp zipper2 + commonParent zipper1' zipper2' + GT -> do + zipper1' <- goUp zipper1 + commonParent zipper1' zipper2 + +topMostNodes :: TimePeriod + -> Calendar + -> Maybe [CalendarZipper] +topMostNodes interval calendar = do + rtNode <- rightMostTopNode (toTimeUnit interval) calendar + let intervalR = getZipInterval rtNode + if intervalR == interval + then return [rtNode] + else do + ltNode <- leftMostTopNode interval calendar + let intervalL = getZipInterval ltNode + parent <- commonParent ltNode rtNode + answer <- goDownTree (toTimeUnit interval) intervalL intervalR parent + return $ ltNode : rtNode : answer + where + goDownTree period leftMost rightMost zipper@(Unit t _ _, _) = + if isIncluded t period + then if t == rightMost || t == leftMost + then Just [] + else Just [zipper] + else Just [] + goDownTree period leftMost rightMost node@(Node t _ _ _ _, _) = + if isIncluded t period + then if t == rightMost || t == leftMost + then Just [] + else Just [node] + else do + lChild <- goLeft node + rChild <- goRight node + lAnswer <- goDownTree period leftMost rightMost lChild + rAnswer <- goDownTree period leftMost rightMost rChild + return $ lAnswer ++ rAnswer + +updateQ :: CalendarZipper -> Maybe CalendarZipper +updateQ zipper@(node, []) = Just zipper +updateQ zipper = do + parent <- goUp zipper + lChild <- goLeft parent + rChild <- goRight parent + let (Node period q qn left right, bs) = parent + lQ = getQ lChild + rQ = getQ rChild + updateQ (Node period (unions [lQ, rQ, qn]) qn left right, bs) + +goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper +goToNode interval calendar = do + result <- go (toTimeUnit interval) (toZipper calendar) + listToMaybe result + where + go interval zipper@(Unit t _ _, _) + | interval == t = Just [zipper] + | otherwise = Just [] + go interval node@(Node t _ _ _ _, bs) = + if interval == t + then Just [node] + else do + (lChild, bsl) <- goLeft node + (rChild, bsr) <- goRight node + let (lower, upper) = (getFrom interval, getTo interval) + toL = (getTo . getInterval) lChild + fromR = (getFrom . getInterval) rChild + lAnswer <- if lower >= fromR + then Just [] + else go interval (lChild, bsl) + rAnswer <- if upper <= toL + then Just [] + else go interval (rChild, bsr) + return $ lAnswer ++ rAnswer + +updateCalendar :: [TimePeriod] + -> Set Text + -> Calendar + -> (Set Text -> Set Text -> Maybe (Set Text)) + -> Maybe Calendar +updateCalendar [] _ cal _ = Just cal +updateCalendar (interval:ins) elts cal f = do + updatedRoot <- updateQandQN elts (toTimeUnit interval) cal + updateCalendar ins elts updatedRoot f + where + update s (Unit unit q qn, bs) = do + newQ <- f q s + newQN <- f qn s + let zipper = (Unit unit newQ newQN, bs) + updateQ zipper + update s (Node interval q qn left right, bs) = do + newQ <- f q s + newQN <- f qn s + let zipper = (Node interval newQ newQN left right, bs) + updateQ zipper + + updateQandQN set interval cal = do + zipper <- goToNode interval cal + updatedZip <- update set zipper + (root, _) <- upToRoot updatedZip + return root + +checkQuantAvailability :: TimePeriod + -> Int + -> Set Text + -> CalendarZipper + -> Bool +checkQuantAvailability interval qt units zipper = + maybe False (not . null) $ checkAvailability interval qt units zipper + where + checkAvailability _ qt units zipper@(Unit {}, _) = do + qMax <- getQMax zipper + let avUnits = size (difference units qMax) + if qt <= avUnits + then Just [()] + else Nothing + checkAvailability interval qt units node@(Node t _ _ _ _, _) = do + qMax <- getQMax node + let avUnits = size (difference units qMax) + guard $ qt <= avUnits || not (isIncluded t interval) + (lChild, bsl) <- goLeft node + (rChild, bsr) <- goRight node + let (lower, upper) = (getFrom interval, getTo interval) + toL = (getTo . getInterval) lChild + fromR = (getFrom . getInterval) rChild + lAnswer <- + if lower >= fromR + then Just [] + else checkAvailability interval qt units (lChild, bsl) + rAnswer <- + if upper <= toL + then Just [] + else checkAvailability interval qt units (rChild, bsr) + return $ lAnswer ++ rAnswer + +checkReservAvailability :: Reservation + -> Set Text + -> CalendarZipper + -> Bool +checkReservAvailability reservation units zipper = + maybe False (not . null) $ checkAvailability reservation units zipper + where + checkAvailability reservation units zipper@(Unit {}, _) = do + qMax <- getQMax zipper + let avUnits = difference units qMax + isSubset = isSubsetOf (reservUnits reservation) avUnits + if isSubset + then Just [()] + else Nothing + checkAvailability reservation units node@(Node t _ _ _ _, _) = do + qMax <- getQMax node + let interval = (toTimeUnit . reservPeriod) reservation + avUnits = difference units qMax + isSubset = isSubsetOf (reservUnits reservation) avUnits + guard $ isSubset || not (isIncluded t interval) + (lChild, bsl) <- goLeft node + (rChild, bsr) <- goRight node + let (lower, upper) = (getFrom interval, getTo interval) + toL = (getTo . getInterval) lChild + fromR = (getFrom . getInterval) rChild + lAnswer <- + if lower >= fromR + then Just [] + else checkAvailability reservation units (lChild, bsl) + rAnswer <- + if upper <= toL + then Just [] + else checkAvailability reservation units (rChild, bsr) + return $ lAnswer ++ rAnswer diff --git a/src/Time/SCalendar/Operations.hs b/src/Time/SCalendar/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Time/SCalendar/Operations.hs @@ -0,0 +1,160 @@ +module Time.SCalendar.Operations + ( augmentCalendar + , isQuantityAvailable + , isReservAvailable + , reservePeriod' + , reservePeriod + , reserveManyPeriods + , reserveManyPeriods' + , cancelPeriod + , cancelManyPeriods + , periodReport + ) where + + +import Data.Maybe (isNothing) +import Time.SCalendar.Zippers +import Time.SCalendar.Types +import Data.Time (UTCTime(..), toGregorian) +import Control.Monad (guard) +import Time.SCalendar.Internal +import qualified Data.Set as S ( null + , size + , difference + , isSubsetOf + , union + , unions ) + +-- | Given an SCalendar of size 2^n, this function increases its size k times, that is, +-- 2^(n+k). The new SCalendar is properly updated up to its root so that it will render +-- the same results as the previous one. For example, given an SCalendar `c` of size 2^5=32, +-- 'augmentCalendar c 3' would produce a new SCalendar of size 2^(5+3)=256. +augmentCalendar :: SCalendar -- ^ SCalendar to be augmented. + -> Int -- ^ Number of times by which the SCalendar will be augmented. + -> Maybe SCalendar +augmentCalendar _ k + | k <= 0 = Nothing +augmentCalendar scal k = do + let interval = getInterval $ calendar scal + (from, to) = (getFrom interval, getTo interval) + (UTCTime gregDay _) = from + (year, month, day) = toGregorian gregDay + newSize = daysBetween from to * (2^k) + largerCal <- createCalendar year month day newSize + (_, bs) <- goToNode interval largerCal + updatedCal <- updateQ (calendar scal, bs) + (root, _) <- upToRoot updatedCal + return $ SCalendar (calUnits scal) root + +-- | Given a quantity, this function determines if it is available in a TimePeriod for a +-- specific SCalendar. Thus, it does not take into account the particular resources whose +-- availability wants to be determined: it is only concerned with the availabilty of a quantity +-- in a specific SCalendar. +isQuantityAvailable :: Int -- ^ Quantity of resources. + -> TimePeriod -- ^ TimePeriod over which we want to determine the availability of + -- the quantity. + -> SCalendar -- ^ SCalendar over which we want to determine the availability of + -- the quantity in a Given TimePeriod. + -> Bool +isQuantityAvailable quant interval scal + | S.null (calUnits scal) = False + | quant <= 0 = False + | quant > S.size (calUnits scal) = False + | not $ intervalFitsCalendar interval (calendar scal) = False + | otherwise = checkQuantAvailability (toTimeUnit interval) quant (calUnits scal) (calendar scal, []) + +-- | Given a Reservation, this function determines if it is available in a SCalendar. A +-- Reservation is the product of a set of identifiers which point to reservable resources +-- and a TimePeriod over which those resources are to be reserved. Thus, this function +-- checks if that particular set of resources is available for a TimePeriod in the given SCalendar. +isReservAvailable :: Reservation -> SCalendar -> Bool +isReservAvailable reservation scal + | S.null (calUnits scal) = False + | not $ S.isSubsetOf (reservUnits reservation) (calUnits scal) = False + | not $ intervalFitsCalendar (reservPeriod reservation) (calendar scal) = False + | otherwise = checkReservAvailability reservation (calUnits scal) (calendar scal, []) + +-- | This function introduces a new Reservation in a Calendar. Note that since no availability check +-- is performed before introducing the Reservation, here we use a plain Calendar. Thus this function +-- is useful to introduce Reservations without any constraint, but that's why it must be used carefully +-- since information can be lost due to the usage of the union set-operation to update the Q and QN sets +-- in the Calendar. +reservePeriod' :: Reservation -> Calendar -> Maybe Calendar +reservePeriod' reservation calendar = do + let interval = (toTimeUnit . reservPeriod) reservation + tmNodes <- topMostNodes interval calendar + let tmIntervals = fmap getZipInterval tmNodes + updateCalendar tmIntervals (reservUnits reservation) calendar (\x y -> Just $ S.union x y) + +-- | This function is like reservePeriod' but adds a list of Reservations without any availabilty check. +reserveManyPeriods' :: [Reservation] -> Calendar -> Maybe Calendar +reserveManyPeriods' [] calendar = Just calendar +reserveManyPeriods' (reservation:rs) calendar = do + updatedCalendar <- addReservation reservation calendar + reserveManyPeriods' rs updatedCalendar + where + addReservation res cal + | isNothing maybeCalendar = Just cal + | otherwise = maybeCalendar + where maybeCalendar = reservePeriod' res cal + +-- | This function introduces a new Reservation in a SCalendar applying an availability check. This means +-- that if the reservation conflicts with others already made in the SCalendar, it will no be introduced. +-- Thus this function takes into account the set of reservable identifiers for the SCalendar to calculate +-- the subset of available ones and introduce the Reservation if possible. +reservePeriod :: Reservation -> SCalendar -> Maybe SCalendar +reservePeriod reservation scalendar + | not $ isReservAvailable reservation scalendar = Nothing +reservePeriod reservation scal = do + updatedCalendar <- reservePeriod' reservation (calendar scal) + return $ SCalendar (calUnits scal) updatedCalendar + +-- | This function is like reservePeriod but introduces several Reservations at once. It is important to note +-- that if a Reservation in the list conflicts with others already made in the SCalendar, it will be excluded. +-- Thus the order of the Reservations in the list matters, since if one Reservation passes the availability check +-- but the next one does not, then latter will be excluded. +reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar +reserveManyPeriods [] calendar = Just calendar +reserveManyPeriods (reservation:rs) calendar = do + updatedCalendar <- addReservation reservation calendar + reserveManyPeriods rs updatedCalendar + where + addReservation res uCal + | isNothing maybeCalendar = Just uCal + | otherwise = maybeCalendar + where maybeCalendar = reservePeriod res uCal + +-- | This function removes reserved identifiers in a Calendar according to the Set of identifiers and TimePeriod +-- specified in the Cancellation. Thus a Cancellation only affects the nodes whose upper or lower bounds are +-- included in the TimePeriod of the Cancellation. +cancelPeriod :: Cancellation -> Calendar -> Maybe Calendar +cancelPeriod cancellation calendar = do + tmNodes <- topMostNodes (cancPeriod cancellation) calendar + let tmIntervals = fmap getZipInterval tmNodes + updateCalendar tmIntervals (cancUnits cancellation) calendar diff + where + diff x y + | not $ S.isSubsetOf y x = Nothing + | otherwise = Just (S.difference x y) + +-- | This is like cancelPeriod but performs several Cancellations at once. +cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar +cancelManyPeriods [] calendar = Just calendar +cancelManyPeriods (cancellation:cs) calendar = do + updatedCalendar <- addCancellation cancellation calendar + cancelManyPeriods cs updatedCalendar + where + addCancellation canc cal + | isNothing maybeCalendar = Just cal + | otherwise = maybeCalendar + where maybeCalendar = cancelPeriod canc cal + +-- | Given a TimePeriod and a SCalendar, this function returns a Report which summarizes important +-- data about the reserved and available identifiers in that SCalendar. +periodReport :: TimePeriod -> SCalendar -> Maybe Report +periodReport interval scal = do + guard $ intervalFitsCalendar interval (calendar scal) + tmNodes <- topMostNodes (toTimeUnit interval) (calendar scal) + qMaxs <- mapM getQMax tmNodes + let sQMax = S.unions qMaxs + return $ Report interval (calUnits scal) sQMax (S.difference (calUnits scal) sQMax) diff --git a/src/Time/SCalendar/Types.hs b/src/Time/SCalendar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Time/SCalendar/Types.hs @@ -0,0 +1,215 @@ +module Time.SCalendar.Types + ( TimePeriod(..) + , Reservation(..) + , Cancellation(..) + , SCalendar(..) + , Calendar(..) + , Report(..) + , isIncluded + , getFrom + , getTo + , toTimeUnit + , makeTimePeriod + , makeReservation + , makeCancellation + , createCalendar + , createSCalendar + , oneDay + , powerOfTwo + ) where + + +import Data.Time ( UTCTime(..) + , NominalDiffTime + , addUTCTime + , fromGregorianValid ) +import Data.Text (Text) +import Data.Set (Set) +import qualified Data.Set as S (empty) + + +-- | This data type is either a TimeInterval of the form (start-date, end-date) +-- or a TimeUnit which, in this case, is a nominal day. The time unit of this calendar +-- library is a nominal day, that is, 86400 seconds. TimeIntervals as well as +-- TimeUnits are stored as UTCTime so that it is easy to transform results to local +-- time or store results in databases as timestamps. +data TimePeriod = + TimeInterval UTCTime UTCTime -- ^ TimeIntervals represent the number of days that a node + -- in a calendar covers from a start-date up to an end-date. + | TimeUnit UTCTime -- ^ TimeUnits are only encountered in the leaves of a calendar and represent + -- a specific day of the calendar. + deriving (Eq, Show) + +-- | Check if a time-period `t1` is included in a time-period `t2`. Note that neither a +-- TimeUnit can be included in another TimeUnit nor a TimeInterval can be included +-- in a TimeUnit. If two TimeIntervals are equal they are said to be included in +-- one another. +isIncluded :: TimePeriod -> TimePeriod -> Bool +isIncluded (TimeUnit _) (TimeUnit _) = False +isIncluded (TimeUnit t) (TimeInterval from to) = from <= t && t <= to +isIncluded (TimeInterval _ _) (TimeUnit _) = False +isIncluded (TimeInterval ifrom ito) (TimeInterval ofrom oto) + = and [ ofrom <= ifrom, ifrom <= oto, ofrom <= ito, ito <= oto, ifrom <= ito ] + +-- | Getter function to get the UTCTime start-date from a TimePeriod. For a TimeUnit +-- the start-sate and the end-date are equal. +getFrom :: TimePeriod -> UTCTime +getFrom (TimeUnit t) = t +getFrom (TimeInterval from _) = from + +-- | Getter function to fet the UTCTime end-date from a TimePeriod. Again, for a TimeUnit +-- the start-sate and the end-date are equal. +getTo :: TimePeriod -> UTCTime +getTo (TimeUnit t) = t +getTo (TimeInterval _ to) = to + +-- | This function transforms a TimeInterval into a TimeUnit in case that the start-date and +-- end-date of that TimeInterval are equal. +toTimeUnit :: TimePeriod -> TimePeriod +toTimeUnit i@(TimeUnit _) = i +toTimeUnit i@(TimeInterval t1 t2) + | t1 == t2 = TimeUnit t1 + | otherwise = i + +-- | A Reservation is the product of a set of identifiers and a TimePeriod over which the +-- resources identified by the set will be reserved. +data Reservation = Reservation + { reservUnits :: Set Text -- ^ Set of identifiers which point to reservable resources. + , reservPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be reserved. + } deriving (Eq, Show) + +-- | A Cancellation is the product of a set of identifiers which point to resources previously +-- reserved in a Calendar and a TimePeriod over which those resources were reserved. +data Cancellation = Cancellation + { cancUnits :: Set Text -- ^ Set of identifiers which point to resources to be cancelled. + , cancPeriod :: TimePeriod -- ^ TimePeriod over which the resources will be cancelled. + } deriving (Eq, Show) + +-- | A Report represents a summary of important facts related to an SCalendar. +data Report = Report + { reportPeriod :: TimePeriod -- ^ The TimePeriod which the report covers. + , totalUnits :: Set Text -- ^ The set of total identifiers reservable in the SCalendar this Report belongs to. + , reservedUnits :: Set Text -- ^ The set of total identifiers which have been reserved in a TimePeriod in + -- the SCalendar related to this Report. + , remainingUnits :: Set Text -- ^ The set of total identifiers which are still available in a Time +data Calendar = + Unit TimePeriod (Set Text) (Set Text) + | Node TimePeriod (Set Text) (Set Text) Calendar Calendar + deriving (Eq, Show) + +-- | An SCalendar is the product of a set of identifiers, which point to a set of available resources, +-- and a Calendar. +data SCalendar = SCalendar + { calUnits :: Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by + -- the root node of the Calendar. + , calendar :: Calendar -- ^ Calendar which covers the complete period of time over which a set of + -- resources can be reserved. + } deriving (Eq, Show) + + +-- | Given a year, a month and a day this function creates a time period which covers the specified +-- number of days. +makeTimePeriod :: Integer -- ^ Year. + -> Int -- ^ Month. + -> Int -- ^ Day. + -> Int -- ^ Number of days covered by TimePeriod. + -> Maybe TimePeriod +makeTimePeriod _ _ _ numDays + | numDays < 0 = Nothing +makeTimePeriod year month day numDays = do + gregDay <- fromGregorianValid year month day + let from = UTCTime gregDay 0 + to = (fromIntegral numDays * oneDay) `addUTCTime` from + return $ if numDays == 0 + then TimeUnit from + else TimeInterval from to + +-- | Given a TimePeriod and a set of identifiers this function creates a reservation. +makeReservation :: TimePeriod -- ^ TimePeriod which the rerservation will cover. + -> Set Text -- ^ Set of identifiers which point to the resources to be reserved from an SCalendar. + -> Maybe Reservation +makeReservation period units + | null units = Nothing + | not $ isValidInterval period' = Nothing + | otherwise = Just $ Reservation units period' + where + period' = toTimeUnit period + +-- | Given a TimePeriod and a set of identifiers this function creates a cancellation. +makeCancellation :: TimePeriod -- ^ TimePeriod which the cancellation will cover. + -> Set Text -- ^ Set of identifiers which point to the resources to be cancelled from an SCalendar. + -> Maybe Cancellation +makeCancellation period units + | null units = Nothing + | not $ isValidInterval period' = Nothing + | otherwise = Just $ Cancellation units period' + where + period' = toTimeUnit period + +-- | Given a year, a month, and a day this function creates a Calendar which covers the specified +-- number of days. The TimePeriod in the root node of a Calendar does not exactly span the +-- number of days specified in the function, but a number of days which is a power of 2 and +-- which is greater than or equal to the number of days specified. +createCalendar :: Integer -- ^ Year. + -> Int -- ^ Month. + -> Int -- ^ Day. + -> Int -- ^ Number of days covered by the Calendar. + -> Maybe Calendar +createCalendar year month day numDays + | numDays <= 1 = Nothing + | otherwise = do + gregDay <- fromGregorianValid year month day + let fstDay = UTCTime gregDay 0 + return $ go fstDay power + where + power = powerOfTwo numDays + go from factor + | parentDist == 0 = Unit (TimeUnit from) S.empty S.empty + | otherwise = + Node (TimeInterval from ((oneDay * parentDist) `addUTCTime` from)) + S.empty + S.empty + (go from (factor - 1)) + (go ((oneDay * childDist) `addUTCTime` from) (factor - 1)) + where + parentDist = (2^factor) - 1 + childDist = 2^(factor - 1) + +-- | This constructor additionally attaches a set of identifiers, which point to the available resources of the +-- calendar. Thus, this function creates an SCalendar which is basically a Calendar with a set of resources which +-- can be reserved over the period of time determined by the root node of the Calendar. +createSCalendar :: Integer -- ^ Year. + -> Int -- ^ Month. + -> Int -- ^ Day. + -> Int -- ^ Number of days covered by the Calendar. + -> Set Text -- ^ Set of resources which can be reserved for the TimePeriod covered by + -- the root node of the Calendar. + -> Maybe SCalendar +createSCalendar _ _ _ _ tUnits + | null tUnits = Nothing +createSCalendar year month day numDays tUnits = do + calendar <- createCalendar year month day numDays + return $ SCalendar tUnits calendar + + +-- HELPER FUNCTIONS +isValidInterval :: TimePeriod -> Bool +isValidInterval (TimeUnit _) = True +isValidInterval (TimeInterval from to) = from < to + +powerOfTwo :: Int -> Int +powerOfTwo n = + let power = ceiling $ logBase 2 (fromIntegral $ abs n) + in if power > 1 then power else 2 + +oneDay :: NominalDiffTime +oneDay = 86400 diff --git a/src/Time/SCalendar/Zippers.hs b/src/Time/SCalendar/Zippers.hs new file mode 100644 --- /dev/null +++ b/src/Time/SCalendar/Zippers.hs @@ -0,0 +1,52 @@ +module Time.SCalendar.Zippers + ( CalendarZipper + , goUp + , goLeft + , goRight + , upToRoot + , toZipper + ) where + + +import Data.Set (Set) +import Data.Text (Text) +import Time.SCalendar.Types (Calendar(..), TimePeriod) + + +data Crumb = LeftCrumb TimePeriod (Set Text) (Set Text) Calendar + | RightCrumb TimePeriod (Set Text) (Set Text) Calendar + deriving Eq + +instance Show Crumb where + show LeftCrumb{} = "LeftCrumb" + show RightCrumb{} = "RightCrumb" + +type Breadcrumbs = [Crumb] +type CalendarZipper = (Calendar, Breadcrumbs) + + +goLeft :: CalendarZipper -> Maybe CalendarZipper +goLeft (Node interval q qn left right, bs) = + Just (left, LeftCrumb interval q qn right : bs) +goLeft (Unit{}, _) = Nothing + +goRight :: CalendarZipper -> Maybe CalendarZipper +goRight (Node interval q qn left right, bs) = + Just (right, RightCrumb interval q qn left : bs) +goRight (Unit{}, _) = Nothing + +goUp :: CalendarZipper -> Maybe CalendarZipper +goUp (calendar, LeftCrumb interval q qn right : bs) + = Just (Node interval q qn calendar right, bs) +goUp (calendar, RightCrumb interval q qn left : bs) + = Just (Node interval q qn left calendar, bs) +goUp (_, []) = Nothing + +upToRoot :: CalendarZipper -> Maybe CalendarZipper +upToRoot (node, []) = Just (node, []) +upToRoot zipper = do + parent <- goUp zipper + upToRoot parent + +toZipper :: Calendar -> CalendarZipper +toZipper calendar = (calendar, []) diff --git a/test/SCalendarTest/Arbitrary.hs b/test/SCalendarTest/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/SCalendarTest/Arbitrary.hs @@ -0,0 +1,123 @@ +module SCalendarTest.Arbitrary where + + +import Test.QuickCheck.Arbitrary +import SCalendarTest.Helpers (testIdentifiers, startDay) +import Control.Monad (replicateM, guard) +import Data.Set (Set) +import Data.Maybe (fromMaybe, fromJust) +import Data.Text (Text) +import qualified Data.Set as S (fromList) +import Time.SCalendar.Types ( Calendar(..) + , Reservation + , TimePeriod + , createCalendar + , makeTimePeriod + , makeReservation + , getFrom + , getTo ) +import Time.SCalendar.Zippers ( CalendarZipper + , goRight + , goLeft ) +import Time.SCalendar.Internal ( getZipInterval + , getInterval + , daysBetween + , intervalFitsCalendar ) +import Test.QuickCheck.Gen (choose, sized, vectorOf) + + +-- | Convinient type for Intervals which fit a Calendar +data CalendarReservations = CalReservs Calendar [Reservation] + +newtype Identifier = Identifier Text + deriving (Eq, Ord) + +newtype Identifiers = Identifiers (Set Identifier) + +data RandomZippers = RandomZippers CalendarZipper CalendarZipper + + +-- | Arbitrary-size calendars +instance Arbitrary Calendar where + arbitrary = do + let (year, month, day) = startDay + -- ^ Random size calendars up to 512 days + -- and starting from 1970 + size <- choose (2, 9) + return $ fromJust $ createCalendar year month day size + +-- | Arbitrary instance for time Intervals +instance Arbitrary TimePeriod where + arbitrary = do + numDays <- choose (1, 27) + return $ fromJust $ makeTimePeriod 1970 1 1 numDays +-- | -- + + +-- | Arbitrary instance for a single Identifier +instance Arbitrary Identifier where + arbitrary = do + i <- choose (0, 99) + return $ Identifier $ testIdentifiers !! i + +instance Show Identifier where + show (Identifier i) = show i +-- | -- + + +-- | Arbitrary instance for CalendarReservations +instance Arbitrary CalendarReservations where + arbitrary = do + calendar <- arbitrary + n <- choose (1, 50) + reservs <- replicateM n $ getSuitableInterval calendar + return $ CalReservs calendar reservs + where + buildReserv interval = sized $ \n -> do + k <- choose (1, abs $ n + 1) + identifiers <- vectorOf k arbitrary + return $ fromJust $ makeReservation interval (S.fromList $ (\(Identifier t) -> t) <$> identifiers) + -- ^ -- + getSuitableInterval cal = do + interval <- arbitrary + maybe (getSuitableInterval cal) + (const $ buildReserv interval) + (guard $ intervalFitsCalendar interval cal) + +instance Show CalendarReservations where + show (CalReservs calendar reservs) = + "Calendar root: " ++ show (getInterval calendar) ++ + " , " ++ + "Reservations: " ++ show reservs +-- | -- + + +-- | Arbitrary pair of Zippers belonging to the same calendar +instance Arbitrary RandomZippers where + arbitrary = do + calendar <- arbitrary + let depth = getDepth calendar + zip1Depth <- choose (0, depth) + zip2Depth <- choose (0, depth) + let root = (calendar, []) + maybeZippers = do + zip1 <- goDown (Just root) zip1Depth + zip2 <- goDown (Just root) zip2Depth + return $ RandomZippers zip1 zip2 + return $ fromMaybe (RandomZippers root root) maybeZippers + where + getDepth :: Calendar -> Int + getDepth cal = round $ + let interval = getInterval cal + in logBase 2 (fromIntegral $ daysBetween (getFrom interval) (getTo interval)) + -- ^ -- + pickBranch zipper n + | n `mod` 2 == 0 = goRight zipper + | otherwise = goLeft zipper + -- ^ -- + goDown maybeZipper 0 = maybeZipper + goDown maybeZipper i = + maybeZipper >>= (\zipper -> goDown (pickBranch zipper i) (i-1)) + +instance Show RandomZippers where + show (RandomZippers zip1 zip2) = show (getZipInterval zip1, getZipInterval zip2) diff --git a/test/SCalendarTest/Constructors.hs b/test/SCalendarTest/Constructors.hs new file mode 100644 --- /dev/null +++ b/test/SCalendarTest/Constructors.hs @@ -0,0 +1,34 @@ +module SCalendarTest.Constructors where + + +import Time.SCalendar.Operations (augmentCalendar) +import SCalendarTest.Helpers (startDay) +import Data.Maybe (fromMaybe) +import Time.SCalendar.Internal ( daysBetween + , getInterval ) +import Time.SCalendar.Types ( SCalendar(..) + , powerOfTwo + , createCalendar + , getFrom + , getTo ) +import qualified Data.Set as S (empty) + + +calendarSizePowerOfTwo :: Int -> Bool +calendarSizePowerOfTwo n = fromMaybe False $ do + let (year, month, day) = startDay + size = if n > 1 then n else abs n + 2 + calendar <- createCalendar year month day size + let i = getInterval calendar + return $ daysBetween (getFrom i) (getTo i) == 2 ^ powerOfTwo size + +augmentedCalendarPowerOfKPlusN :: Int -> Int -> Bool +augmentedCalendarPowerOfKPlusN n k = fromMaybe False $ do + let (year, month, day) = startDay + n' = powerOfTwo n + k' = powerOfTwo k + calendar <- createCalendar year month day n' + (SCalendar _ calendar') <- augmentCalendar (SCalendar S.empty calendar) k' + let i = getInterval calendar + j = getInterval calendar' + return $ daysBetween (getFrom j) (getTo j) == daysBetween (getFrom i) (getTo i) * (2 ^ k') diff --git a/test/SCalendarTest/Helpers.hs b/test/SCalendarTest/Helpers.hs new file mode 100644 --- /dev/null +++ b/test/SCalendarTest/Helpers.hs @@ -0,0 +1,23 @@ +module SCalendarTest.Helpers + ( getUTCdayNum + , testIdentifiers + , startDay + ) where + + +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Calendar (toGregorian) +import Data.Text (Text) +import qualified Data.Text as T (pack) + + +testIdentifiers :: [Text] +testIdentifiers = T.pack <$> (show <$> [1.. 100]) + +getUTCdayNum :: UTCTime -> Int +getUTCdayNum (UTCTime day _) = + let (_, _, num) = toGregorian day + in num + +startDay :: (Integer, Int, Int) +startDay = (1970, 1, 1) diff --git a/test/SCalendarTest/Internal.hs b/test/SCalendarTest/Internal.hs new file mode 100644 --- /dev/null +++ b/test/SCalendarTest/Internal.hs @@ -0,0 +1,138 @@ +module SCalendarTest.Internal where + + +import Data.List (elem) +import Data.Maybe (isJust, fromMaybe) +import Data.Time (UTCTime(..), toGregorian, diffUTCTime ) +import SCalendarTest.Helpers (getUTCdayNum) +import Time.SCalendar.Types ( Calendar(..) + , Reservation(..) + , TimePeriod + , getFrom + , getTo + , isIncluded + , powerOfTwo + , oneDay + , makeTimePeriod ) +import Time.SCalendar.Zippers (goUp) +import SCalendarTest.Arbitrary (RandomZippers(..), CalendarReservations(..)) +import Time.SCalendar.Internal ( goToNode + , leftMostTopNode + , rightMostTopNode + , topMostNodes + , getZipInterval + , commonParent ) + + +alwaysGreateOrEqualThanN :: Int -> Bool +alwaysGreateOrEqualThanN n = 2^ powerOfTwo n >= n + +eqIntervalsIfIncludeEachOther :: TimePeriod -> TimePeriod -> Bool +eqIntervalsIfIncludeEachOther i j + | isIncluded i j && isIncluded j i = i1 == j1 && i2 == j2 + | isIncluded i j = not $ isIncluded j i + | isIncluded j i = not $ isIncluded i j + | not (isIncluded i j) && not (isIncluded j i) && wellFormed = i1 < j2 || j1 < i2 + | otherwise = not wellFormed + where + (i1, i2) = (getFrom i, getTo i) + (j1, j2) = (getFrom j, getTo j) + wellFormed = i1 <= i2 && j1 <= j2 + +returnsTargetZipper :: Calendar -> TimePeriod -> Bool +returnsTargetZipper calendar interval = + let maybeCalendar = fst <$> goToNode interval calendar + in maybe (ifNothing calendar) checkTarget maybeCalendar + where + checkTarget (Unit unit _ _) = unit == interval + checkTarget (Node interval' _ _ _ _) = interval' == interval + -- ^ -- + ifNothing (Node interval' _ _ _ _) = + not $ isIncluded interval interval' && ((getUTCdayNum . getFrom) interval) `mod` 2 == 0 + ifNothing _ = False + +isLeftMostTopNode :: CalendarReservations -> Bool +isLeftMostTopNode (CalReservs _ []) = False +isLeftMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do + i2 <- getZipInterval <$> leftMostTopNode i1 calendar + return $ getFrom i2 == getFrom i1 && + if getTo i2 == getTo i1 + then (getFrom i1, getTo i1) == (getFrom i2, getTo i2) + else getTo i2 < getTo i1 + where + i1 = reservPeriod reserv + +isRightMostTopNode :: CalendarReservations -> Bool +isRightMostTopNode (CalReservs _ []) = False +isRightMostTopNode (CalReservs calendar (reserv:_)) = fromMaybe False $ do + i2 <- getZipInterval <$> rightMostTopNode i1 calendar + return $ getTo i2 == getTo i1 && + if getFrom i2 == getFrom i1 + then (getFrom i1, getTo i1) == (getFrom i2, getTo i2) + else getFrom i2 > getFrom i1 + where + i1 = reservPeriod reserv + +returnsCommonParent :: RandomZippers -> Bool +returnsCommonParent (RandomZippers zip1 zip2) = fromMaybe False $ do + parent <- commonParent zip1 zip2 + let c1 = getZipInterval zip1 + c2 = getZipInterval zip2 + p= getZipInterval parent + return $ getFrom p <= getFrom c1 && + getFrom p <= getFrom c2 && + getTo p >= getTo c1 && + getTo p >= getTo c2 + +leftMostAndRightMostInTopMost :: CalendarReservations -> Bool +leftMostAndRightMostInTopMost (CalReservs _ []) = False +leftMostAndRightMostInTopMost (CalReservs calendar (reserv:_)) = fromMaybe False $ do + ltmInterval <- getZipInterval <$> leftMostTopNode interval calendar + rtmInterval <- getZipInterval <$> rightMostTopNode interval calendar + topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) + return $ (ltmInterval `elem` topMostIntervals) && (rtmInterval `elem` topMostIntervals) + where + interval = reservPeriod reserv + +outerMostNodesIncludeIntermediate :: CalendarReservations -> Bool +outerMostNodesIncludeIntermediate (CalReservs _ []) = False +outerMostNodesIncludeIntermediate (CalReservs calendar (reserv:_)) = fromMaybe False $ do + from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar + to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar + topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) + -- ^ Each intermediate interval must be included in the leftmost and rightmost ones + let numDays = round $ diffUTCTime to' from' / oneDay + (UTCTime gregDay _) = from' + (year, month, day) = toGregorian gregDay + timePeriod <- makeTimePeriod year month day numDays + return $ all (`isIncluded` timePeriod) topMostIntervals || timePeriod `elem` topMostIntervals + where + interval = reservPeriod reserv + +ifOnlyOneTopNodeItEqualsInterval :: CalendarReservations -> Bool +ifOnlyOneTopNodeItEqualsInterval (CalReservs _ []) = False +ifOnlyOneTopNodeItEqualsInterval (CalReservs calendar (reserv:_)) = fromMaybe False $ do + topMostIntervals <- (fmap . fmap) getZipInterval (topMostNodes interval calendar) + if length topMostIntervals == 1 + then return $ head topMostIntervals == interval + else return True + where + interval = reservPeriod reserv + +parentOfTopNodesNotIncluded :: CalendarReservations -> Bool +parentOfTopNodesNotIncluded (CalReservs _ []) = False +parentOfTopNodesNotIncluded (CalReservs calendar (reserv:_)) = fromMaybe False $ do + from' <- (getFrom . getZipInterval) <$> leftMostTopNode interval calendar + to' <- (getTo . getZipInterval) <$> rightMostTopNode interval calendar + tmNodes <- topMostNodes interval calendar + parentIntervals <- (fmap . fmap) getZipInterval + (sequence $ filter isJust (goUp <$> tmNodes)) + let numDays = round $ diffUTCTime to' from' / oneDay + (UTCTime gregDay _) = from' + (year, month, day) = toGregorian gregDay + timePeriod <- makeTimePeriod year month day numDays + return $ all (`notIncluded` timePeriod) parentIntervals + where + notIncluded i1 i2 = not $ isIncluded i1 i2 + -- ^ -- + interval = reservPeriod reserv diff --git a/test/SCalendarTest/Operations.hs b/test/SCalendarTest/Operations.hs new file mode 100644 --- /dev/null +++ b/test/SCalendarTest/Operations.hs @@ -0,0 +1,88 @@ +module SCalendarTest.Operations where + + +import Time.SCalendar.Operations ( reserveManyPeriods + , reservePeriod' + , cancelManyPeriods + , isQuantityAvailable, + isReservAvailable ) +import SCalendarTest.Helpers (getUTCdayNum, testIdentifiers) +import SCalendarTest.Arbitrary (CalendarReservations(..)) +import Data.Maybe (isJust, fromMaybe) +import Time.SCalendar.Internal ( goToNode + , getQMax + , getZipInterval ) +import Time.SCalendar.Zippers (goLeft, goRight, goUp) +import Time.SCalendar.Types ( Calendar(..) + , SCalendar(..) + , Reservation(..) + , getFrom + , getTo + , makeCancellation ) +import qualified Data.Set as S (isSubsetOf, fromList, size) + + +symmetricalIntervalLength :: Calendar -> Bool +symmetricalIntervalLength calendar = + fromMaybe False (checkSimmetry calZipper) + where + calZipper = (calendar, []) + -- ^ -- + checkSimmetry (Unit{}, _) = Just True + checkSimmetry zipper = do + leftChild <- goLeft zipper + rightChild <- goRight zipper + let i1 = getZipInterval leftChild + i2 = getZipInterval rightChild + intervalSymmetry = getUTCdayNum (getTo i1) - getUTCdayNum (getFrom i1) + == getUTCdayNum (getTo i2) - getUTCdayNum (getFrom i2) + return $ intervalSymmetry && + fromMaybe False (checkSimmetry leftChild) && + fromMaybe False (checkSimmetry rightChild) + +qMaxOfParentIncludedInChildren :: CalendarReservations -> Bool +qMaxOfParentIncludedInChildren (CalReservs calendar reservs) = fromMaybe False $ do + (SCalendar _ calendar') <- reserveManyPeriods reservs (SCalendar (S.fromList testIdentifiers) calendar) + checks <- sequence $ filter isJust (checkQmax calendar' . reservPeriod <$> reservs) + return $ and checks + where + checkQmax cal interval = do + zipper <- goToNode interval cal + zipParent <- goUp zipper + zipLChild <- goLeft zipper + qMax <- getQMax zipper + qMaxParent <- getQMax zipParent + qMaxLChild <- getQMax zipLChild + return $ qMaxParent `S.isSubsetOf` qMax && + qMax `S.isSubsetOf` qMaxLChild + +quantityNotAvailableAfterReservation :: CalendarReservations -> Bool +quantityNotAvailableAfterReservation (CalReservs _ []) = False +quantityNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do + calendar' <- reservePeriod' reserv calendar + return $ not $ + isQuantityAvailable (totalUnits - S.size (reservUnits reserv) + 1) + (reservPeriod reserv) + (SCalendar (S.fromList testIdentifiers) calendar') + where + totalUnits = length testIdentifiers + +periodNotAvailableAfterReservation :: CalendarReservations -> Bool +periodNotAvailableAfterReservation (CalReservs _ []) = False +periodNotAvailableAfterReservation (CalReservs calendar (reserv:_)) = fromMaybe False $ do + calendar' <- reservePeriod' reserv calendar + return $ not $ + isReservAvailable reserv (SCalendar (S.fromList testIdentifiers) calendar') && + S.size (reservUnits reserv) > 0 + +reservAvailableAfterCancellation :: CalendarReservations -> Bool +reservAvailableAfterCancellation (CalReservs _ []) = False +reservAvailableAfterCancellation (CalReservs calendar reservs) = fromMaybe False $ do + (SCalendar _ calendar') <- reserveManyPeriods reservs + (SCalendar (S.fromList testIdentifiers) calendar) + cancellations <- mapM reservToCanc reservs + calendar'' <- cancelManyPeriods cancellations calendar' + return $ and $ + flip isReservAvailable (SCalendar (S.fromList testIdentifiers) calendar'') <$> reservs + where + reservToCanc reserv = makeCancellation (reservPeriod reserv) (reservUnits reserv) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,76 @@ +module Main where + + +import Test.Hspec +import Test.QuickCheck.Property (property) +import SCalendarTest.Internal ( alwaysGreateOrEqualThanN + , eqIntervalsIfIncludeEachOther + , returnsTargetZipper + , isLeftMostTopNode + , isRightMostTopNode + , returnsCommonParent + , leftMostAndRightMostInTopMost + , outerMostNodesIncludeIntermediate + , ifOnlyOneTopNodeItEqualsInterval + , parentOfTopNodesNotIncluded ) +import SCalendarTest.Operations ( symmetricalIntervalLength + , qMaxOfParentIncludedInChildren + , quantityNotAvailableAfterReservation + , periodNotAvailableAfterReservation + , reservAvailableAfterCancellation ) +import SCalendarTest.Constructors (calendarSizePowerOfTwo, augmentedCalendarPowerOfKPlusN) + + +main :: IO () +main = + hspec $ do + describe "powerOftwo :: Int -> Int" $ do + it "always returns a power of 2 greater or equal than its argument" $ do + property alwaysGreateOrEqualThanN + describe "isIncluded :: isIncluded :: TimePeriod -> TimePeriod -> Bool" $ do + it "determines if the first interval is included in the second one" $ do + property eqIntervalsIfIncludeEachOther + describe "createCalendar :: createCalendar :: FirstDay -> NumDays -> Maybe Calendar" $ do + it "creates a calendar with a number of days 2^(powerOftwo NumDays)" $ do + property calendarSizePowerOfTwo + it "creates a calendar with symmetric intervals" $ do + property symmetricalIntervalLength + describe "augmentCalendar :: SCalendar -> Int -> Maybe SCalendar" $ do + it "always creates a calendar augmented k times the power of the original size" $ do + property augmentedCalendarPowerOfKPlusN + describe "goToNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do + it "goes to the node with interval (From, To) in the calendar" $ do + property returnsTargetZipper + describe "leftMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do + it "returns a Zipper with a valid left-most interval" $ do + property isLeftMostTopNode + describe "rightMostTopNode :: TimePeriod -> Calendar -> Maybe CalendarZipper" $ do + it "returns a Zipper with a valid right-most interval" $ do + property isRightMostTopNode + describe "commonParent :: CalendarZipper -> CalendarZipper -> Maybe CalendarZipper" $ do + it "returns a Zipper which is a common parent node of its arguments" $ do + property returnsCommonParent + describe "topMostNodes :: TimePeriod -> Calendar -> Maybe [CalendarZipper]" $ do + it "returns a list of topmost-nodes *including* the rightmost and the leftmost ones" $ do + property leftMostAndRightMostInTopMost + it "returns a list of topmost-nodes *included* in the rightmost and the leftmost ones" $ do + property outerMostNodesIncludeIntermediate + it "returns a list of topmost-nodes with no parent included in (From, To)" $ do + property parentOfTopNodesNotIncluded + context "when there is only one topmost-node" $ do + it "must return an interval equal to (From, To)" $ do + property ifOnlyOneTopNodeItEqualsInterval + describe "reserveManyPeriods :: [Reservation] -> SCalendar -> Maybe SCalendar" $ do + it "returns a Calendar which satisfies that QMax of parent node is included in QMax of left child" $ do + property qMaxOfParentIncludedInChildren + describe "isQuantityAvailable :: Quantity -> TimePeriod -> SCalendar -> Bool" $ do + it "determines if a quantity is available after a reservation" $ do + property quantityNotAvailableAfterReservation + describe "isReservAvailable :: Reservation -> SCalendar -> Bool" $ do + context "when a node has already been reserved" $ do + it "returns false for the same reservation in that node" $ do + property periodNotAvailableAfterReservation + describe "cancelManyPeriods :: [Cancellation] -> Calendar -> Maybe Calendar" $ do + context "when a reservation in a node is cancelled" $ do + it "becomes again availabale" $ do + property reservAvailableAfterCancellation