module Data.Calendar (
module Data.Timeframe,
Event,
event,
eventSize,
erlangs,
Calendar (..),
singleton,
calendar,
insert,
(!?),
(!),
Data.Calendar.toList,
happeningAt,
coalesce,
totalDuration,
) where
import Algebra.Lattice.Levitated (Levitated (..))
import Data.Data (Typeable)
import Data.Foldable (fold)
import Data.Interval qualified as I
import Data.Interval.Layers (Layers)
import Data.Interval.Layers qualified as Layers
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Semigroup (Sum (..))
import Data.Time.Compat (NominalDiffTime, UTCTime, diffUTCTime)
import Data.Timeframe
type Event n = Layers UTCTime (Sum n)
event :: (Num n) => Timeframe -> Event n
event :: forall n. Num n => Timeframe -> Event n
event = (Timeframe -> Sum n -> Layers UTCTime (Sum n)
forall x y. Ord x => Interval x -> y -> Layers x y
`Layers.singleton` Sum n
1)
eventSize :: (Num n) => n -> Timeframe -> Event n
eventSize :: forall n. Num n => n -> Timeframe -> Event n
eventSize n
n = (Timeframe -> Sum n -> Layers UTCTime (Sum n)
forall x y. Ord x => Interval x -> y -> Layers x y
`Layers.singleton` n -> Sum n
forall a. a -> Sum a
Sum n
n)
erlangs :: (Real n) => Timeframe -> Event n -> Maybe Rational
erlangs :: forall n. Real n => Timeframe -> Event n -> Maybe Rational
erlangs Timeframe
ix Event n
e =
let diff :: UTCTime -> UTCTime -> Rational
diff = (NominalDiffTime -> Rational)
-> (UTCTime -> NominalDiffTime) -> UTCTime -> Rational
forall a b. (a -> b) -> (UTCTime -> a) -> UTCTime -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NominalDiffTime -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac ((UTCTime -> NominalDiffTime) -> UTCTime -> Rational)
-> (UTCTime -> UTCTime -> NominalDiffTime)
-> UTCTime
-> UTCTime
-> Rational
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UTCTime -> UTCTime -> NominalDiffTime)
-> UTCTime -> UTCTime -> NominalDiffTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime
in (Rational -> Rational -> Rational)
-> Maybe Rational -> Maybe Rational -> Maybe Rational
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
(/)
((UTCTime -> UTCTime -> Rational)
-> (Sum n -> Rational) -> Timeframe -> Event n -> Maybe Rational
forall x y z.
(Ord x, Ord y, Semigroup y, Num z) =>
(x -> x -> z) -> (y -> z) -> Interval x -> Layers x y -> Maybe z
Layers.integrate UTCTime -> UTCTime -> Rational
diff (n -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac (n -> Rational) -> (Sum n -> n) -> Sum n -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum n -> n
forall a. Sum a -> a
getSum) Timeframe
ix Event n
e)
((UTCTime -> UTCTime -> Rational) -> Timeframe -> Maybe Rational
forall y x.
(Ord x, Num y) =>
(x -> x -> y) -> Interval x -> Maybe y
I.measuring UTCTime -> UTCTime -> Rational
diff Timeframe
ix)
newtype Calendar ev n = Calendar {forall ev n. Calendar ev n -> Map ev (Event n)
getCalendar :: Map ev (Event n)}
deriving (Calendar ev n -> Calendar ev n -> Bool
(Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool) -> Eq (Calendar ev n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
$c== :: forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
== :: Calendar ev n -> Calendar ev n -> Bool
$c/= :: forall ev n.
(Eq ev, Eq n) =>
Calendar ev n -> Calendar ev n -> Bool
/= :: Calendar ev n -> Calendar ev n -> Bool
Eq, Eq (Calendar ev n)
Eq (Calendar ev n) =>
(Calendar ev n -> Calendar ev n -> Ordering)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Bool)
-> (Calendar ev n -> Calendar ev n -> Calendar ev n)
-> (Calendar ev n -> Calendar ev n -> Calendar ev n)
-> Ord (Calendar ev n)
Calendar ev n -> Calendar ev n -> Bool
Calendar ev n -> Calendar ev n -> Ordering
Calendar ev n -> Calendar ev n -> Calendar ev n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall ev n. (Ord ev, Ord n) => Eq (Calendar ev n)
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Ordering
forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
$ccompare :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Ordering
compare :: Calendar ev n -> Calendar ev n -> Ordering
$c< :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
< :: Calendar ev n -> Calendar ev n -> Bool
$c<= :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
<= :: Calendar ev n -> Calendar ev n -> Bool
$c> :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
> :: Calendar ev n -> Calendar ev n -> Bool
$c>= :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Bool
>= :: Calendar ev n -> Calendar ev n -> Bool
$cmax :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
max :: Calendar ev n -> Calendar ev n -> Calendar ev n
$cmin :: forall ev n.
(Ord ev, Ord n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
min :: Calendar ev n -> Calendar ev n -> Calendar ev n
Ord, Int -> Calendar ev n -> ShowS
[Calendar ev n] -> ShowS
Calendar ev n -> String
(Int -> Calendar ev n -> ShowS)
-> (Calendar ev n -> String)
-> ([Calendar ev n] -> ShowS)
-> Show (Calendar ev n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ev n. (Show ev, Show n) => Int -> Calendar ev n -> ShowS
forall ev n. (Show ev, Show n) => [Calendar ev n] -> ShowS
forall ev n. (Show ev, Show n) => Calendar ev n -> String
$cshowsPrec :: forall ev n. (Show ev, Show n) => Int -> Calendar ev n -> ShowS
showsPrec :: Int -> Calendar ev n -> ShowS
$cshow :: forall ev n. (Show ev, Show n) => Calendar ev n -> String
show :: Calendar ev n -> String
$cshowList :: forall ev n. (Show ev, Show n) => [Calendar ev n] -> ShowS
showList :: [Calendar ev n] -> ShowS
Show, Typeable)
instance (Ord ev, Ord n, Num n) => Semigroup (Calendar ev n) where
(<>) ::
(Ord ev, Ord n, Num n) => Calendar ev n -> Calendar ev n -> Calendar ev n
Calendar Map ev (Event n)
a <> :: (Ord ev, Ord n, Num n) =>
Calendar ev n -> Calendar ev n -> Calendar ev n
<> Calendar Map ev (Event n)
b = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar ((Event n -> Event n -> Event n)
-> Map ev (Event n) -> Map ev (Event n) -> Map ev (Event n)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Event n -> Event n -> Event n
forall a. Semigroup a => a -> a -> a
(<>) Map ev (Event n)
a Map ev (Event n)
b)
instance (Ord ev, Ord n, Num n) => Monoid (Calendar ev n) where
mempty :: (Ord ev, Ord n, Num n) => Calendar ev n
mempty :: (Ord ev, Ord n, Num n) => Calendar ev n
mempty = Calendar ev n
forall ev n. Calendar ev n
Data.Calendar.empty
empty :: Calendar ev n
empty :: forall ev n. Calendar ev n
empty = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar Map ev (Event n)
forall k a. Map k a
Map.empty
singleton :: (Ord ev, Ord n, Num n) => ev -> Event n -> Calendar ev n
singleton :: forall ev n.
(Ord ev, Ord n, Num n) =>
ev -> Event n -> Calendar ev n
singleton ev
ev Event n
cvg = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar (ev -> Event n -> Map ev (Event n)
forall k a. k -> a -> Map k a
Map.singleton ev
ev Event n
cvg)
calendar :: (Ord ev, Ord n, Num n) => ev -> Timeframe -> Calendar ev n
calendar :: forall ev n.
(Ord ev, Ord n, Num n) =>
ev -> Timeframe -> Calendar ev n
calendar ev
ev Timeframe
tf = ev -> Event n -> Calendar ev n
forall ev n.
(Ord ev, Ord n, Num n) =>
ev -> Event n -> Calendar ev n
singleton ev
ev (Timeframe -> Sum n -> Event n
forall x y. Ord x => Interval x -> y -> Layers x y
Layers.singleton Timeframe
tf Sum n
1)
insert ::
(Ord ev, Ord n, Num n) => ev -> Event n -> Calendar ev n -> Calendar ev n
insert :: forall ev n.
(Ord ev, Ord n, Num n) =>
ev -> Event n -> Calendar ev n -> Calendar ev n
insert ev
ev Event n
cvg (Calendar Map ev (Event n)
c) = Map ev (Event n) -> Calendar ev n
forall ev n. Map ev (Event n) -> Calendar ev n
Calendar ((Event n -> Event n -> Event n)
-> ev -> Event n -> Map ev (Event n) -> Map ev (Event n)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Event n -> Event n -> Event n
forall a. Semigroup a => a -> a -> a
(<>) ev
ev Event n
cvg Map ev (Event n)
c)
(!?) :: (Ord ev, Ord n, Num n) => Calendar ev n -> ev -> Maybe (Event n)
Calendar Map ev (Event n)
c !? :: forall ev n.
(Ord ev, Ord n, Num n) =>
Calendar ev n -> ev -> Maybe (Event n)
!? ev
ev = Map ev (Event n)
c Map ev (Event n) -> ev -> Maybe (Event n)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ev
ev
(!) :: (Ord ev, Ord n, Num n) => Calendar ev n -> ev -> Event n
Calendar Map ev (Event n)
c ! :: forall ev n.
(Ord ev, Ord n, Num n) =>
Calendar ev n -> ev -> Event n
! ev
ev = Event n -> Maybe (Event n) -> Event n
forall a. a -> Maybe a -> a
fromMaybe Event n
forall a. Monoid a => a
mempty (Map ev (Event n)
c Map ev (Event n) -> ev -> Maybe (Event n)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ev
ev)
toList ::
(Ord ev, Ord n, Num n) => Calendar ev n -> [(ev, [(Interval UTCTime, n)])]
toList :: forall ev n.
(Ord ev, Ord n, Num n) =>
Calendar ev n -> [(ev, [(Timeframe, n)])]
toList (Calendar Map ev (Event n)
c) = (Event n -> [(Timeframe, n)])
-> (ev, Event n) -> (ev, [(Timeframe, n)])
forall a b. (a -> b) -> (ev, a) -> (ev, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Timeframe, Sum n) -> (Timeframe, n))
-> [(Timeframe, Sum n)] -> [(Timeframe, n)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Sum n -> n) -> (Timeframe, Sum n) -> (Timeframe, n)
forall a b. (a -> b) -> (Timeframe, a) -> (Timeframe, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Sum n -> n
forall a. Sum a -> a
getSum) ([(Timeframe, Sum n)] -> [(Timeframe, n)])
-> (Event n -> [(Timeframe, Sum n)]) -> Event n -> [(Timeframe, n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event n -> [(Timeframe, Sum n)]
forall x y. Ord x => Layers x y -> [(Interval x, y)]
Layers.toList) ((ev, Event n) -> (ev, [(Timeframe, n)]))
-> [(ev, Event n)] -> [(ev, [(Timeframe, n)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map ev (Event n) -> [(ev, Event n)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map ev (Event n)
c
happeningAt :: (Ord ev, Ord n, Num n) => UTCTime -> Calendar ev n -> [(ev, n)]
happeningAt :: forall ev n.
(Ord ev, Ord n, Num n) =>
UTCTime -> Calendar ev n -> [(ev, n)]
happeningAt UTCTime
time (Calendar ev n -> [(ev, [(Timeframe, n)])]
forall ev n.
(Ord ev, Ord n, Num n) =>
Calendar ev n -> [(ev, [(Timeframe, n)])]
Data.Calendar.toList -> [(ev, [(Timeframe, n)])]
evs) =
[ (ev
ev, n
n)
| (ev
ev, [(Timeframe, n)]
ns) <- [(ev, [(Timeframe, n)])]
evs
, (Timeframe
_, n
n) <- ((Timeframe, n) -> Bool) -> [(Timeframe, n)] -> [(Timeframe, n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Levitated UTCTime -> Timeframe -> Bool
forall x. Ord x => Levitated x -> Interval x -> Bool
within (UTCTime -> Levitated UTCTime
forall a. a -> Levitated a
Levitate UTCTime
time) (Timeframe -> Bool)
-> ((Timeframe, n) -> Timeframe) -> (Timeframe, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Timeframe, n) -> Timeframe
forall a b. (a, b) -> a
fst) [(Timeframe, n)]
ns
]
coalesce :: (Ord ev, Ord n, Num n) => Calendar ev n -> Event n
coalesce :: forall ev n. (Ord ev, Ord n, Num n) => Calendar ev n -> Event n
coalesce (Calendar Map ev (Event n)
c) = Map ev (Event n) -> Event n
forall m. Monoid m => Map ev m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map ev (Event n)
c
totalDuration ::
forall ev n.
(Ord ev, Real n) =>
ev ->
Calendar ev n ->
Maybe NominalDiffTime
totalDuration :: forall ev n.
(Ord ev, Real n) =>
ev -> Calendar ev n -> Maybe NominalDiffTime
totalDuration ev
ev (Calendar Map ev (Event n)
c) = case Map ev (Event n)
c Map ev (Event n) -> ev -> Maybe (Event n)
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ev
ev of
Maybe (Event n)
Nothing -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0
Just Event n
is -> ((Timeframe, Sum n)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime)
-> Maybe NominalDiffTime
-> [(Timeframe, Sum n)]
-> Maybe NominalDiffTime
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Timeframe, Sum n)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just NominalDiffTime
0) (Event n -> [(Timeframe, Sum n)]
forall x y. Ord x => Layers x y -> [(Interval x, y)]
Layers.toList Event n
is)
where
f :: (Timeframe, Sum n) -> Maybe NominalDiffTime -> Maybe NominalDiffTime
f :: (Timeframe, Sum n)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
f (Timeframe, Sum n)
_ Maybe NominalDiffTime
Nothing = Maybe NominalDiffTime
forall a. Maybe a
Nothing
f (Timeframe
tf, Sum n
n) (Just NominalDiffTime
x) = case (n -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac n
n *) (NominalDiffTime -> NominalDiffTime)
-> Maybe NominalDiffTime -> Maybe NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Timeframe -> Maybe NominalDiffTime
duration Timeframe
tf of
Maybe NominalDiffTime
Nothing -> Maybe NominalDiffTime
forall a. Maybe a
Nothing
Just NominalDiffTime
y -> NominalDiffTime -> Maybe NominalDiffTime
forall a. a -> Maybe a
Just (NominalDiffTime
x NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
y)