SCalendar 0.1.0.0 → 1.0.0
raw patch · 16 files changed
+1260/−778 lines, 16 filesdep +QuickCheckdep +SCalendardep +hspecdep ~basedep ~containersdep ~text
Dependencies added: QuickCheck, SCalendar, hspec
Dependency ranges changed: base, containers, text, time
Files
- LICENSE +5/−1
- SCalendar.cabal +37/−26
- libs/SCalendar/BreadCrumbs.hs +0/−60
- libs/SCalendar/DataTypes.hs +0/−49
- libs/SCalendar/Internal.hs +0/−345
- libs/SCalendar/Operations.hs +0/−297
- src/Time/SCalendar/Internal.hs +309/−0
- src/Time/SCalendar/Operations.hs +160/−0
- src/Time/SCalendar/Types.hs +215/−0
- src/Time/SCalendar/Zippers.hs +52/−0
- test/SCalendarTest/Arbitrary.hs +123/−0
- test/SCalendarTest/Constructors.hs +34/−0
- test/SCalendarTest/Helpers.hs +23/−0
- test/SCalendarTest/Internal.hs +138/−0
- test/SCalendarTest/Operations.hs +88/−0
- test/Test.hs +76/−0
LICENSE view
@@ -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
SCalendar.cabal view
@@ -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 <spulido@stackbuilders.com>+maintainer: Stack Builders <hackage@stackbuilders.com>+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
− libs/SCalendar/BreadCrumbs.hs
@@ -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 --
− libs/SCalendar/DataTypes.hs
@@ -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)
− libs/SCalendar/Internal.hs
@@ -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-
− libs/SCalendar/Operations.hs
@@ -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)- -
+ src/Time/SCalendar/Internal.hs view
@@ -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
+ src/Time/SCalendar/Operations.hs view
@@ -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)
+ src/Time/SCalendar/Types.hs view
@@ -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<Period in the+ -- SCalendar related to this Report.+ } deriving (Eq, Show)++-- | A Calendar is a recursive tree-structure whose nodes are TimePeriods representing the interval+-- of time covered by them. TimeUnits are only encountered in the leaves since they represent+-- specific days, or time units, of the Calendar. The unit of time of this Calendar library is a nominal+-- day (or 86400 seconds). Each node of a Calendar also carries additional data according to the+-- "top-nodes" algorithm: a `Q` set and a `QN` set. For more information about the meaning of these+-- sets visit: <https://en.wikipedia.org/wiki/Top-nodes_algorithm>+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
+ src/Time/SCalendar/Zippers.hs view
@@ -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, [])
+ test/SCalendarTest/Arbitrary.hs view
@@ -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)
+ test/SCalendarTest/Constructors.hs view
@@ -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')
+ test/SCalendarTest/Helpers.hs view
@@ -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)
+ test/SCalendarTest/Internal.hs view
@@ -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
+ test/SCalendarTest/Operations.hs view
@@ -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)
+ test/Test.hs view
@@ -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