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

-- | An 'Event' is a collection of 'Timeframe's that keeps track of
-- how deeply a particular interval has been overlapped.
--
-- > type Event n = Layers UTCTime (Sum n)
type Event n = Layers UTCTime (Sum n)

-- | Make a new 'Event' from a 'Timeframe' with default thickness 1.
--
-- > event = eventSize 1
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)

-- | Make an 'Event' with the given size from a 'Timeframe'.
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)

-- |
-- Measure the carried load of an 'Event' over a given 'Timeframe'.
-- In other words: how many copies of you would you need, in order to attend
-- all of the simultaneous happenings over a given span (on average)?
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)

-- | A 'Calendar' is a map from a given event type to durations.
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

-- | The empty 'Calendar'.
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

-- | Make a 'Calendar' from an 'Event'.
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)

-- | Make a 'Calendar' from a 'Timeframe'.
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 an 'Event' of the given sort into a 'Calendar'.
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)

-- |
-- Get the 'Event' corresponding to a given key,
-- or 'Nothing' if the key is not present.
(!?) :: (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

-- |
-- Get the 'Event' corresponding to a given key,
-- or 'mempty' if the key is not present.
(!) :: (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

-- |
-- What, and how many events are happening
-- at the given 'UTCTime' on this 'Calendar'?
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
  ]

-- | Consider every kind of event the same, and observe the overall 'Layers'.
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

-- | Calculate the total length of a particular event across all occurrences.
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)