diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,8 @@ -Copyright (c) 2016 Sebastian Pulido Gomez +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 diff --git a/SCalendar.cabal b/SCalendar.cabal --- a/SCalendar.cabal +++ b/SCalendar.cabal @@ -1,34 +1,45 @@ name: SCalendar -version: 0.1.0.0 -synopsis: Library for managing calendars and resource availability. -description: This is a library for handling calendars and resource availability based on the "top-nodes algorithm" and set operations. -homepage: https://github.com/sebasHack/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 -author: Sebastian Pulido Gomez -maintainer: sebastian0092@gmail.com --- copyright: -category: Calendar +copyright: 2017 Stack Builders Inc. +author: Sebastian Pulido Gómez +maintainer: Stack Builders +category: Time build-type: Simple --- extra-source-files: cabal-version: >=1.10 -source-repository head - type: git - location: https://github.com/sebasHack/SCalendar.git - library - exposed-modules: SCalendar.Operations, - SCalendar.BreadCrumbs, - SCalendar.DataTypes, - SCalendar.Internal - - -- other-modules: - -- other-extensions: - build-depends: base >= 4.8 && < 4.9, - containers, - time, - text >= 1.2.2.1 - - hs-source-dirs: libs + 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/libs/SCalendar/BreadCrumbs.hs b/libs/SCalendar/BreadCrumbs.hs deleted file mode 100644 --- a/libs/SCalendar/BreadCrumbs.hs +++ /dev/null @@ -1,60 +0,0 @@ -module SCalendar.BreadCrumbs where - -import Control.Monad -import SCalendar.DataTypes -import qualified Data.Set as S -import qualified Data.Time as TM -import qualified Data.Text as T - - --- BreadCrumbs to move around the calendar -- - -data Crumb = LeftCrumb (From, To) Q QN Calendar - | RightCrumb (From, To) Q QN Calendar - deriving Eq - - -instance Show Crumb where - show c = "crumb" - - -type Breadcrumbs = [Crumb] - - - -type CalendarZipper = (Calendar, Breadcrumbs) - - - -goLeft :: CalendarZipper -> Maybe CalendarZipper -goLeft (Node (from, to) q qn left right, bs) = - Just (left, LeftCrumb (from, to) q qn right : bs) -goLeft (TimeUnit _ _ _, _) = Nothing -goLeft (Empty _, _) = Nothing - - - -goRight :: CalendarZipper -> Maybe CalendarZipper -goRight(Node (from, to) q qn left right, bs) = - Just (right, RightCrumb (from, to) q qn left : bs) -goRight (TimeUnit _ _ _, _) = Nothing -goRight (Empty _, _) = 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 - - diff --git a/libs/SCalendar/DataTypes.hs b/libs/SCalendar/DataTypes.hs deleted file mode 100644 --- a/libs/SCalendar/DataTypes.hs +++ /dev/null @@ -1,49 +0,0 @@ -module SCalendar.DataTypes where - -import Control.Monad -import qualified Data.Set as S -import qualified Data.Time as TM -import qualified Data.Text as T - - -type NumDays = Int -type Quantity = Int -type FirstDay = TM.UTCTime -type CurrentDay = TM.UTCTime -type TotalUnits = S.Set T.Text - -type From = TM.UTCTime -type To = TM.UTCTime -type Unit = TM.UTCTime -type Q = S.Set T.Text -- Q(Node) = U(Q(LeftChild), Q(RightChild)) U QN(Node) -type QN = S.Set T.Text -- QN(Node) = reserved elements for all reservations having this node as top-node -type QMax = S.Set T.Text -- QMax = Q + U(QN of parent nodes up to the root node) -type SQMax = S.Set T.Text -- The union of all qmax's in a list. -type Remaining = S.Set T.Text -- the difference between TotalUnits and SQMax - - -data Reservation = Reservation (S.Set T.Text) (From, To) -- A Reservation must specify which elements will be reserved. - deriving (Eq, Show) - - - -data Cancellation = Cancellation (S.Set T.Text) (From, To) - deriving (Eq, Show) - - - -data Report = Report (From, To) TotalUnits SQMax Remaining - deriving (Eq, Show) - - - -data Calendar = TimeUnit Unit Q QN - | Empty (From, To) - | Node (From, To) Q QN Calendar Calendar - deriving (Eq, Show) - - --- This data type represents the fact that a calendar must be attached to a number of available units, --- that is, a set of identifiers together with a Calendar. -data SCalendar = SCalendar TotalUnits Calendar - deriving (Show, Eq) diff --git a/libs/SCalendar/Internal.hs b/libs/SCalendar/Internal.hs deleted file mode 100644 --- a/libs/SCalendar/Internal.hs +++ /dev/null @@ -1,345 +0,0 @@ -module SCalendar.Internal where - -import Control.Monad -import SCalendar.BreadCrumbs -import SCalendar.DataTypes -import qualified Data.Set as S -import qualified Data.Time as TM -import qualified Data.Text as T - - --- UTILITY FUNCTIONS -- - --- Given a calendar, this function returns the number of days of this calendar. -calendarSize :: Calendar -> Int -calendarSize (Node (from, to ) _ _ _ _) - = 1 + round (TM.diffUTCTime to from / 86400) -calendarSize node = 0 - --- Safely return the head of a list. -maybeHead :: [a] -> Maybe a -maybeHead [] = Nothing -maybeHead (x:xs) = Just x - - --- Find the first power of 2 that is equal or greater than n -powerOfTwo :: Int -> Int -powerOfTwo n = - go n 0 - where - go d i - | 2^i >= d = i - | otherwise = go d (i+1) - - --- Given an interval,this function determines if it is included in another interval. -isIncluded :: (From, To) -> (From, To) -> Bool -isIncluded (from, to) (from', to') = - from' <= from && from <= to' && from' <= to && to <= to' && from <= to - - -{- - This is a helper function to validate some important facts about an interval (from, to) and a calendar: - - from <= to - - A Calendar which is just a TimeUnit is not valid. - - An Empty Leaf of a Calendar is not valid. - - If the interval is not included in the period of the root node of a calendar, then that interval - is not valid. --} -intervalFitsCalendar :: (From, To) - -> Calendar - -> Maybe () -intervalFitsCalendar (from, to) _ - | not (from <= to) = Nothing -intervalFitsCalendar _ (TimeUnit _ _ _) = Nothing -intervalFitsCalendar _ (Empty _) = Nothing -intervalFitsCalendar interval (Node period _ _ _ _) - | not $ isIncluded interval period = Nothing - | otherwise = Just () - - - --- Given a node this function returns the interval that that node represents -getInterval :: Calendar -> (From, To) -getInterval (TimeUnit unit _ _) = (unit, unit) -getInterval (Node (from, to) _ _ _ _) = (from, to) -getInterval (Empty (from, to)) = (from, to) - - --- Like getInterval, but gets the interval from a zipper. -getZipInterval :: CalendarZipper -> (From, To) -getZipInterval (node, _) = getInterval node - - - --- Get the Q set from a node. -getQ :: CalendarZipper -> Q -getQ (Empty _, _) = S.empty -getQ (TimeUnit _ q _, _) = q -getQ (Node _ q _ _ _, _) = q - - --- Get the QN set from a node. -getQN :: CalendarZipper -> QN -getQN (Empty _, _) = S.empty -getQN (TimeUnit _ _ qn, _) = qn -getQN (Node _ _ qn _ _, _) = qn - - --- Given a node this function returns the QMax For that node. --- QMax = Q + U(QN of parent nodes up to the root node) -getQMax :: CalendarZipper -> Maybe (S.Set T.Text) -getQMax (node, []) = Just $ getQ (node, []) -getQMax zipper = do - parent <- goUp zipper - go parent (getQ zipper) - where - go (node, []) sum = do - let qn = getQN (node, []) - return $ S.union sum qn - go zipper sum = do - let qn = getQN zipper - parent <- goUp zipper - go parent $ S.union sum qn - - --- END OF UTILITY FUNCTIONS -- - - - --- Given a period of time and a calendar, this function finds the leftMost top-node of that interval. --- an empty leaf is not considered a top-most node. -leftMostTopNode :: (From, To) - -> Calendar - -> Maybe CalendarZipper -leftMostTopNode interval calendar = do - maybeBarrier <- intervalFitsCalendar interval calendar - result <- ltmNode interval (calendar, []) - maybeHead result - where - ltmNode _ (Empty _, _) = Just [] - ltmNode (lower, upper) (TimeUnit t q qn, bs) - | lower == t && t <= upper = Just [(TimeUnit t q qn, bs)] - | otherwise = Just [] - ltmNode (lower,upper) node = do - (lChild, bsl) <- goLeft node - (rChild, bsr) <- goRight node - let (Node (from, to) q qn left right, bs) = node - case lower == from && to <= upper of - True -> Just [node] - False -> do - let (fromL, toL) = getInterval lChild - (fromR, toR) = getInterval rChild - lAnswer <- if lower <= toL - then ltmNode (lower,upper) (lChild, bsl) - else Just [] - rAnswer <- if lower >= fromR - then ltmNode (lower,upper) (rChild, bsr) - else Just [] - return $ concat [lAnswer, rAnswer] - - - - --- Given a period of time and a calendar, this function finds the rightMost top-node of that interval. --- An empty leaf is not considered a top-most node. -rightMostTopNode :: (From, To) - -> Calendar - -> Maybe CalendarZipper -rightMostTopNode interval calendar = do - maybeBarrier <- intervalFitsCalendar interval calendar - result <- rtmNode interval (calendar, []) - maybeHead result - where - -- There's no rightmost top-node if it is supposed to be in an empty leaf. - rtmNode _ (Empty _, _) = Just [] - rtmNode (lower, upper) (TimeUnit t q qn, bs) - | upper == t && t >= lower = Just [(TimeUnit t q qn, bs)] - | otherwise = Just [] - rtmNode (lower,upper) node = do - (lChild, bsl) <- goLeft node - (rChild, bsr) <- goRight node - let (Node (from, to) q qn left right, bs) = node - case upper == to && from >= lower of - True -> Just [node] - False -> do - let (fromL, toL) = getInterval lChild - (fromR, toR) = getInterval rChild - lAnswer <- if upper <= toL - then rtmNode (lower,upper) (lChild, bsl) - else Just [] - rAnswer <- if upper >= fromR - then rtmNode (lower,upper) (rChild, bsr) - else Just [] - return $ concat [lAnswer, rAnswer] - - - - --- Given two nodes this function finds the common parent node of those nodes, if it exists. --- The result is only valid if the two nodes (and their breadcrumbs) come from the same calendar. -commonParent :: CalendarZipper - -> CalendarZipper - -> Maybe CalendarZipper -commonParent zipper1 zipper2 = do - let (node1, bs1) = zipper1 - (node2, bs2) = zipper2 - bs1Length = length bs1 - bs2Length = length bs2 - let interval1 = getInterval node1 - interval2 = getInterval node2 - case bs1Length == bs2Length of - True -> if interval1 == interval2 - then Just zipper1 - else do - zipper1' <- goUp zipper1 - zipper2' <- goUp zipper2 - commonParent zipper1' zipper2' - False -> - case bs1Length < bs2Length of - True -> do - zipper2' <- goUp zipper2 - commonParent zipper1 zipper2' - False -> do - zipper1' <- goUp zipper1 - commonParent zipper1' zipper2 - - - --- Given a period of time and a calendar, this function returns the topmost nodes of that period of time --- in the calendar. Empty leaves are not consider to be top-most nodes. --- Note that this function returns at least the rightmost top-node in case it is found but the leftmost-top node --- is not found. This is only for convinience, since having at least the rightmost top-node is useful. - -topMostNodes :: (From, To) - -> Calendar - -> Maybe [CalendarZipper] -topMostNodes (lower, upper) calendar = do - rtNode <- rightMostTopNode (lower, upper) calendar - let (fromR, toR) = getZipInterval rtNode - case (fromR, toR) == (lower, upper) of - True -> Just [rtNode] - False -> do - let leftMost = leftMostTopNode (lower, upper) calendar - case leftMost of - Nothing -> return [rtNode] - Just ltNode -> do - let (fromL, toL) = getZipInterval ltNode - parent <- commonParent ltNode rtNode - answer <- goDownTree (lower, upper) (fromL, toL) (fromR, toR) parent - let tmNodes = ltNode : rtNode : answer - return tmNodes - where - goDownTree :: (From, To) - -> (From, To) - -> (From, To) - -> CalendarZipper -> Maybe [CalendarZipper] - goDownTree _ _ _ (Empty _, _) = Just [] - goDownTree period leftMost rightMost (TimeUnit t q qn, bs) = - case isIncluded (t,t) period of - True -> if (t, t) == rightMost || (t, t) == leftMost - then Just [] - else Just [(TimeUnit t q qn, bs)] - False -> Just [] - goDownTree period leftMost rightMost node = do - let (Node (from, to) _ _ _ _, bs) = node - case isIncluded (from, to) period of - True -> if (from, to) == rightMost || (from, to) == leftMost - then Just [] - else Just [node] - False -> do - lChild <- goLeft node - rChild <- goRight node - lAnswer <- goDownTree period leftMost rightMost lChild - rAnswer <- goDownTree period leftMost rightMost rChild - return $ concat [lAnswer, rAnswer] - - - - --- This function receives a Node (point in a Calendar) and returns a new Node (up to the root node) with --- Q updated. That is, this function updates the Q all over the tree. Q = U(Q(leftChild), Q(rightChild), QN) -updateQ :: CalendarZipper -> Maybe CalendarZipper -updateQ (node, []) = Just (node, []) -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 (S.unions [lQ, rQ, qn]) qn left right, bs) - - - - --- Given a period of time and a Calendar, this function takes you to the node that represents that period, --- if it exists. -goToNode :: (From, To) -> Calendar -> Maybe CalendarZipper -goToNode interval calendar = do - result <- go interval (calendar, []) - maybeHead result - where - go (lower, upper) (Empty (from, to), bs) - | (lower, upper) == (from, to) = Just [(Empty (from, to), bs)] - | otherwise = Just [] - go (lower, upper) (TimeUnit t q qn, bs) - | (lower, upper) == (t,t) = Just [(TimeUnit t q qn, bs)] - | otherwise = Just [] - go (lower, upper) node = do - let (Node (from, to) _ _ _ _, bs) = node - case (lower, upper) == (from, to) of - True -> Just [node] - False -> do - (lChild, bsl) <- goLeft node - (rChild, bsr) <- goRight node - let (fromL, toL) = getInterval lChild - (fromR, toR) = getInterval rChild - lAnswer <- if lower >= fromR - then Just [] - else go (lower,upper) (lChild, bsl) - rAnswer <- if upper <= toL - then Just [] - else go (lower,upper) (rChild, bsr) - return $ concat [lAnswer, rAnswer] - - - - --- This is a helper function both for reserve period and deleteUnitsFromReservation. This function --- takes a list of topMostNodes intervals, a set of units to be reserved, a calendar, and an binary operation over --- sets (union or difference). The binary operation determines the way that each node will be updated: union for --- reservations and difference for deleting from a previous reservation. -updateCalendar :: [(From, To)] - -> S.Set T.Text - -> Calendar - -> (S.Set T.Text -> S.Set T.Text -> Maybe (S.Set T.Text)) - -> Maybe Calendar -updateCalendar _ _ (Empty _) _ = Nothing -updateCalendar [] _ cal _ = Just cal -updateCalendar (period:ps) elts cal f = do - updatedRoot <- updateQandQN elts period cal - updateCalendar ps elts updatedRoot f - where - update s (Empty period, bs) = do - updateQ (Empty period, bs) -- make sure to update Q all over the tree. - update s (TimeUnit unit q qn, bs) = do - newQ <- f q s - newQN <- f qn s - let zipper = (TimeUnit unit newQ newQN, bs) - updateQ zipper -- make sure to update Q all over the tree. - update s (Node period q qn left right, bs) = do - newQ <- f q s - newQN <- f qn s - let zipper = (Node period newQ newQN left right, bs) - updateQ zipper -- make sure to update Q all over the tree. - updateQandQN :: S.Set T.Text - -> (From, To) - -> Calendar - -> Maybe Calendar - updateQandQN set (from, to) cal = do - zipper <- goToNode (from, to) cal - updatedZip <- update set zipper - (root, _) <- upToRoot updatedZip - return root - diff --git a/libs/SCalendar/Operations.hs b/libs/SCalendar/Operations.hs deleted file mode 100644 --- a/libs/SCalendar/Operations.hs +++ /dev/null @@ -1,297 +0,0 @@ -module SCalendar.Operations where - -import Control.Monad -import SCalendar.BreadCrumbs -import SCalendar.DataTypes -import SCalendar.Internal -import qualified Data.Set as S -import qualified Data.Time as TM -import qualified Data.Text as T - - - --- basic calendar constructor: It takes a FirstDay (UTCTime) and the size of the calendar (NumDays) --- and returns a Calendar whose size is the first power of 2 which is equal or greater that the --- number of days we want. - -createCalendar :: FirstDay -> NumDays -> Maybe Calendar -createCalendar fstDay numDays - | numDays <= 1 = Nothing - | otherwise = Just $ go fstDay power - where - oneDay = 86400 :: TM.NominalDiffTime - power = powerOfTwo numDays - go from factor - | parentDist == 0 = (TimeUnit from S.empty S.empty) - | otherwise = Node (from, TM.addUTCTime (oneDay * parentDist) from) - S.empty - S.empty - (go from (factor - 1)) - (go (TM.addUTCTime (oneDay * childDist) from) (factor - 1)) - where - parentDist = (2^factor) - 1 - childDist = 2^(factor - 1) - - - --- This is like createCalendar, but this function attaches a set of Identifiers to the Calendar. -createSCalendar :: FirstDay -> NumDays -> S.Set T.Text -> Maybe SCalendar -createSCalendar _ _ tUnits - | null tUnits = Nothing -createSCalendar fstDay numDays tUnits = do - calendar <- createCalendar fstDay numDays - return $ SCalendar tUnits calendar - - - --- Given a calendar of size 2^n, this function augments that calendar k times, that is, 2^(n+k). The new --- calendar is properly updated. -augmentCalendar :: SCalendar -> Int -> Maybe SCalendar -augmentCalendar _ k - | k <= 0 = Nothing -augmentCalendar (SCalendar _ (TimeUnit _ _ _)) _ = Nothing -augmentCalendar (SCalendar _ (Empty _)) _ = Nothing -augmentCalendar (SCalendar totalUnits calendar) k = do - let (from, to) = getInterval calendar - newSize = (calendarSize calendar) * (2^k) - -- Create a bigger calendar with a space for our - -- smaller calendar. - largerCal <- createCalendar from newSize - (slot, bs) <- goToNode (from, to) largerCal - -- put the smaller calendar in the slot and update the larger calendar. - updatedCal <- updateQ (calendar, bs) - (root, []) <- upToRoot updatedCal - return $ SCalendar totalUnits root - - - - --- Given an interval, an amount of units to be reserved, the number of available units --- and a calendar this function determines if that period of time and quantity are available --- in that calendar. - -isQuantityAvailable :: Quantity - -> (From, To) - -> SCalendar - -> Bool -isQuantityAvailable quant interval (SCalendar totalUnits _) - | S.null totalUnits = False - | quant <= 0 = False - | quant > S.size totalUnits = False -isQuantityAvailable quant interval (SCalendar totalUnits calendar) = - let result = do - maybeBarrier <- intervalFitsCalendar interval calendar - checkAv interval quant totalUnits (calendar, []) - in if result == Nothing || result == Just [] then False else True - where - barrier bool = if bool == False then Nothing else Just () - checkAv :: (From, To) - -> Quantity - -> TotalUnits - -> CalendarZipper -> Maybe [()] - checkAv _ _ _ (Empty _, _) = Nothing -- A period that includes an empty leaf is not available. - checkAv _ qt units (TimeUnit t q qn, bs) = do - qMax <- getQMax (TimeUnit t q qn, bs) - let avUnits = S.size (S.difference units qMax) - if qt <= avUnits then Just [()] else Nothing - checkAv (lower,upper) qt units node = do - let (Node (from, to) q qn left right, bs) = node - qMax <- getQMax node - let avUnits = S.size (S.difference units qMax) - -- Propagate a Nothing if conditions are not met - maybeBarrier <- barrier $ qt <= avUnits || (not $ isIncluded (from, to) (lower, upper)) - (lChild, bsl) <- goLeft node - (rChild, bsr) <- goRight node - let (fromL, toL) = getInterval lChild - (fromR, toR) = getInterval rChild - lAnswer <- if lower >= fromR - then Just [] - else checkAv (lower,upper) qt units (lChild, bsl) - rAnswer <- if upper <= toL - then Just [] - else checkAv (lower,upper) qt units (rChild, bsr) - return $ concat [lAnswer, rAnswer] - - - --- Given a Reservation, and a SCalendar this function determines if that reservation is --- available in that calendar. -isReservAvailable :: Reservation - -> SCalendar - -> Bool -isReservAvailable (Reservation resUnits _) (SCalendar totalUnits _) - | S.null totalUnits = False - | not $ S.isSubsetOf resUnits totalUnits = False -isReservAvailable (Reservation resUnits interval) (SCalendar totalUnits calendar) = - let result = do - maybeBarrier <- intervalFitsCalendar interval calendar - checkAv (Reservation resUnits interval) totalUnits (calendar, []) - in if result == Nothing || result == Just [] then False else True - where - barrier bool = if bool == False then Just () else Nothing - checkAv :: Reservation - -> TotalUnits - -> CalendarZipper -> Maybe [()] - checkAv _ _ (Empty _, _) = Nothing -- A period that includes an empty leaf is not available. - checkAv (Reservation rUnits _) units (TimeUnit t q qn, bs) = do - qMax <- getQMax (TimeUnit t q qn, bs) - let avUnits = S.difference units qMax - isSubset = S.isSubsetOf rUnits avUnits - if isSubset then Just [()] else Nothing - checkAv (Reservation rUnits (lower, upper)) units node = do - qMax <- getQMax node - let (Node (from, to) q qn left right, bs) = node - avUnits = S.difference units qMax - isSubset = S.isSubsetOf rUnits avUnits - -- If rUnits is not a subset of avUnits and (from, to) - -- is included in (lower, upper), then there's - -- no availability. Thus propagate a Nothing - maybeBarrier <- barrier $ (not isSubset) && (isIncluded (from, to) (lower, upper)) - (lChild, bsl) <- goLeft node - (rChild, bsr) <- goRight node - let (fromL, toL) = getInterval lChild - (fromR, toR) = getInterval rChild - lAnswer <- if lower >= fromR - then Just [] - else checkAv (Reservation rUnits (lower, upper)) units (lChild, bsl) - rAnswer <- if upper <= toL - then Just [] - else checkAv (Reservation rUnits (lower, upper)) units (rChild, bsr) - return $ concat [lAnswer, rAnswer] - - - --- reservePeriod_ inserts reservations into a calendar without any constraint. This function is good to make historials, --- because you may want to insert reservations which are not included in the current TotalUnits of a Bookable. -reservePeriod_ :: Reservation - -> Calendar - -> Maybe Calendar -reservePeriod_ (Reservation set (cIn, cOut)) calendar = do - tmNodes <- topMostNodes (cIn, cOut) calendar - let tmIntervals = fmap getZipInterval tmNodes - updatedCalendar <- updateCalendar tmIntervals set calendar (\x y -> Just $ S.union x y) - return updatedCalendar - - - - --- This is like reservePeriod_ but reserves many periods at once. -reserveManyPeriods_ :: [Reservation] - -> Calendar - -> Maybe Calendar -reserveManyPeriods_ [] calendar = Just calendar -reserveManyPeriods_ (reservation:rs) calendar = do - updatedCalendar <- makeReservation reservation calendar - reserveManyPeriods_ rs updatedCalendar - where - makeReservation res cal - | maybeCalendar == Nothing = Just cal - | otherwise = maybeCalendar - where maybeCalendar = reservePeriod_ res cal - - - - --- Given a period of time, a set of units to be reserved, and a SCalendar --- this function returns a new Calendar with a a reservation over that period of time if it is available. --- The Calendar returned by this function is a root Node. -reservePeriod :: Reservation - -> SCalendar - -> Maybe SCalendar -reservePeriod reservation uCalendar - | not $ isReservAvailable reservation uCalendar = Nothing -reservePeriod reservation (SCalendar totalUnits calendar) = do - updatedCalendar <- reservePeriod_ reservation calendar - return $ SCalendar totalUnits updatedCalendar - - - --- This function is like reservePeriod, but instead of making one reservation at a time, it takes a list of reservations. --- This function will return a calendar only with the ones that pass the isReservAvailable test. Take into account that --- reservations will be inserted in the tree in the order they are in the input list. So, if a reservation conflicts with --- the ones that have been alredy inserted, it will not be included in the tree. -reserveManyPeriods :: [Reservation] - -> SCalendar - -> Maybe SCalendar -reserveManyPeriods [] calendar = Just calendar -reserveManyPeriods (reservation:rs) calendar = do - updatedCalendar <- makeReservation reservation calendar - reserveManyPeriods rs updatedCalendar - where - makeReservation res uCal - | maybeCalendar == Nothing = Just uCal - | otherwise = maybeCalendar - where maybeCalendar = reservePeriod res uCal - - - - --- This operation takes a Cancellation and returns a new calendar with that Cancellation --- subtracted from the top-nodes of that Cancellation (Q is therefore updated all over the tree). --- Be careful with this operation: Two reservations might have the same top nodes, so you --- must have a way to keep track which elements belong to one reservation and to the other one. --- For example, you can have all reservations stored in a data base, and before deleting units from --- a given reservation you must make sure that you are not going to delete more than there have been --- reserved until now. Also, make sure that when you delete a reservation, you must record that --- deletion in your data base. --- Note also that deleting units from a tree does not prevent you from deleting from a reservation --- that has never been made. For example, if you have previously reserved n units for (2,7), that --- reservation will be affected if you delete from a period of time like (2,5). That's why whenever you --- subtract units from a tree, you must be certain that the period of time has been previously reserved. --- Another thing to note is that you must be careful not to delete units from reservations that in --- your system have an ongoing status, that is, they are happening now and have not finished yet. --- Finally, you should not want to delete units from reservations that have already elpased. --- That makes no sense. --- In conclusion, if you are going to use this operation for cancellations, use it only in the case that --- a reservation has not started yet. --- See that you cannot delete more units than QN, that is, if (size unitsToDelete) > (size QN(node)), a --- Nothing will be propagated. -cancelPeriod :: Cancellation - -> Calendar - -> Maybe Calendar -cancelPeriod (Cancellation set (cIn, cOut)) calendar = do - -- To delete from a previous reservation, we must know its top-nodes. - tmNodes <- topMostNodes (cIn, cOut) calendar - let tmIntervals = fmap getZipInterval tmNodes - cancellation <- updateCalendar tmIntervals set calendar diff - return cancellation - where - diff x y - | not $ S.isSubsetOf y x = Nothing - | otherwise = Just ( S.difference x y) - - - - - --- This is like cancelPeriod but cancels many periods at once. -cancelManyPeriods :: [Cancellation] - -> Calendar - -> Maybe Calendar -cancelManyPeriods [] calendar = Just calendar -cancelManyPeriods (cancellation:cs) calendar = do - updatedCalendar <- makeCancellation cancellation calendar - cancelManyPeriods cs updatedCalendar - where - makeCancellation canc cal - | maybeCalendar == Nothing = Just cal - | otherwise = maybeCalendar - where maybeCalendar = cancelPeriod canc cal - - - - - - --- Given a period of time and a Calendar, this function returns a Report which summarizes --- important data about that period of time. --- Report = preiod totalUnits unitsReserved remainingUnits. -periodReport :: (From, To) -> SCalendar -> Maybe Report -periodReport period (SCalendar totalUnits calendar) = do - maybeBarrier <- intervalFitsCalendar period calendar - tmNodes <- topMostNodes period calendar - qMaxs <- mapM getQMax tmNodes - let sQMax = S.unions qMaxs - return $ Report period totalUnits sQMax (S.difference totalUnits sQMax) - - 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