SCalendar (empty) → 0.1.0.0
raw patch · 7 files changed
+807/−0 lines, 7 filesdep +basedep +containersdep +textsetup-changed
Dependencies added: base, containers, text, time
Files
- LICENSE +20/−0
- SCalendar.cabal +34/−0
- Setup.hs +2/−0
- libs/SCalendar/BreadCrumbs.hs +60/−0
- libs/SCalendar/DataTypes.hs +49/−0
- libs/SCalendar/Internal.hs +345/−0
- libs/SCalendar/Operations.hs +297/−0
+ LICENSE view
@@ -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.
+ SCalendar.cabal view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ libs/SCalendar/BreadCrumbs.hs view
@@ -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 ++
+ libs/SCalendar/DataTypes.hs view
@@ -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)
+ libs/SCalendar/Internal.hs view
@@ -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+
+ libs/SCalendar/Operations.hs view
@@ -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)+ +