diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Sebastian Pulido Gomez + +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/SCalendar.cabal b/SCalendar.cabal new file mode 100644 --- /dev/null +++ b/SCalendar.cabal @@ -0,0 +1,34 @@ +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 +license: MIT +license-file: LICENSE +author: Sebastian Pulido Gomez +maintainer: sebastian0092@gmail.com +-- copyright: +category: Calendar +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 + default-language: Haskell2010 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/libs/SCalendar/BreadCrumbs.hs b/libs/SCalendar/BreadCrumbs.hs new file mode 100644 --- /dev/null +++ b/libs/SCalendar/BreadCrumbs.hs @@ -0,0 +1,60 @@ +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 new file mode 100644 --- /dev/null +++ b/libs/SCalendar/DataTypes.hs @@ -0,0 +1,49 @@ +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 new file mode 100644 --- /dev/null +++ b/libs/SCalendar/Internal.hs @@ -0,0 +1,345 @@ +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 new file mode 100644 --- /dev/null +++ b/libs/SCalendar/Operations.hs @@ -0,0 +1,297 @@ +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) + +