module Data.IFS.Timetable (
Slots,
Slot,
Event,
toCSP
) where
import Data.Hashable
import qualified Data.HashMap.Lazy as HM
import Data.IntervalMap.FingerTree
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Data.List ( nub )
import Data.Maybe ( catMaybes, fromMaybe )
import Data.Time
import Data.IFS.Types
type Slots = IS.IntSet
type Slot = Int
type Event = Int
noOverlap :: [Maybe Slot] -> Bool
noOverlap :: [Maybe Slot] -> Bool
noOverlap [Maybe Slot]
vs = [Slot] -> Slot
forall (t :: * -> *) a. Foldable t => t a -> Slot
length ([Slot] -> [Slot]
forall a. Eq a => [a] -> [a]
nub [Slot]
assigned) Slot -> Slot -> Bool
forall a. Eq a => a -> a -> Bool
== [Slot] -> Slot
forall (t :: * -> *) a. Foldable t => t a -> Slot
length [Slot]
assigned
where assigned :: [Slot]
assigned = [Maybe Slot] -> [Slot]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Slot]
vs
noConcurrentOverlap :: [Maybe Slot] -> IM.IntMap (Interval UTCTime) -> Bool
noConcurrentOverlap :: [Maybe Slot] -> IntMap (Interval UTCTime) -> Bool
noConcurrentOverlap [Maybe Slot]
vs IntMap (Interval UTCTime)
slots = (IntervalMap UTCTime (), Bool) -> Bool
forall a b. (a, b) -> b
snd ((IntervalMap UTCTime (), Bool) -> Bool)
-> (IntervalMap UTCTime (), Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ ((IntervalMap UTCTime (), Bool)
-> Slot -> (IntervalMap UTCTime (), Bool))
-> (IntervalMap UTCTime (), Bool)
-> [Slot]
-> (IntervalMap UTCTime (), Bool)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (IntervalMap UTCTime (), Bool)
-> Slot -> (IntervalMap UTCTime (), Bool)
f (IntervalMap UTCTime ()
forall v a. Ord v => IntervalMap v a
empty, Bool
True) [Slot]
vs'
where
vs' :: [Slot]
vs' = [Maybe Slot] -> [Slot]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Slot]
vs
f :: (IntervalMap UTCTime (), Bool)
-> Slot -> (IntervalMap UTCTime (), Bool)
f (IntervalMap UTCTime ()
im, Bool
False) Slot
_ = (IntervalMap UTCTime ()
im, Bool
False)
f (IntervalMap UTCTime ()
im, Bool
True) Slot
s =
let interval :: Interval UTCTime
interval = (IntMap (Interval UTCTime)
slots IntMap (Interval UTCTime) -> Slot -> Interval UTCTime
forall a. IntMap a -> Slot -> a
IM.! Slot
s) in
if ((Interval UTCTime, ()) -> Bool)
-> [(Interval UTCTime, ())] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Interval UTCTime
i,()
_) -> Interval UTCTime -> UTCTime
forall v. Interval v -> v
low Interval UTCTime
interval UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Interval UTCTime -> UTCTime
forall v. Interval v -> v
high Interval UTCTime
i Bool -> Bool -> Bool
|| Interval UTCTime -> UTCTime
forall v. Interval v -> v
high Interval UTCTime
interval UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Interval UTCTime -> UTCTime
forall v. Interval v -> v
low Interval UTCTime
i)
([(Interval UTCTime, ())] -> Bool)
-> [(Interval UTCTime, ())] -> Bool
forall a b. (a -> b) -> a -> b
$ Interval UTCTime
interval Interval UTCTime
-> IntervalMap UTCTime () -> [(Interval UTCTime, ())]
forall v a.
Ord v =>
Interval v -> IntervalMap v a -> [(Interval v, a)]
`intersections` IntervalMap UTCTime ()
im
then (Interval UTCTime
-> () -> IntervalMap UTCTime () -> IntervalMap UTCTime ()
forall v a.
Ord v =>
Interval v -> a -> IntervalMap v a -> IntervalMap v a
insert Interval UTCTime
interval () IntervalMap UTCTime ()
im, Bool
True)
else (IntervalMap UTCTime ()
im, Bool
False)
calcDomains :: (Eq person, Hashable person)
=> Slots
-> HM.HashMap Event [person]
-> HM.HashMap person Slots
-> Domains
calcDomains :: Slots -> HashMap Slot [person] -> HashMap person Slots -> Domains
calcDomains Slots
slots HashMap Slot [person]
events HashMap person Slots
unavailability =
((Domains -> Slot -> [person] -> Domains)
-> HashMap Slot [person] -> Domains)
-> HashMap Slot [person]
-> (Domains -> Slot -> [person] -> Domains)
-> Domains
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Domains -> Slot -> [person] -> Domains)
-> Domains -> HashMap Slot [person] -> Domains)
-> Domains
-> (Domains -> Slot -> [person] -> Domains)
-> HashMap Slot [person]
-> Domains
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Domains -> Slot -> [person] -> Domains)
-> Domains -> HashMap Slot [person] -> Domains
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
HM.foldlWithKey' Domains
forall a. IntMap a
IM.empty) HashMap Slot [person]
events ((Domains -> Slot -> [person] -> Domains) -> Domains)
-> (Domains -> Slot -> [person] -> Domains) -> Domains
forall a b. (a -> b) -> a -> b
$ \Domains
m Slot
event [person]
people ->
(Slots -> Domains -> Domains) -> Domains -> Slots -> Domains
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Slot -> Slots -> Domains -> Domains
forall a. Slot -> a -> IntMap a -> IntMap a
IM.insert Slot
event) Domains
m (Slots -> Domains) -> Slots -> Domains
forall a b. (a -> b) -> a -> b
$ Slots -> Slots -> Slots
IS.difference Slots
slots (Slots -> Slots) -> Slots -> Slots
forall a b. (a -> b) -> a -> b
$
let unavailable :: person -> Slots
unavailable = Slots -> Maybe Slots -> Slots
forall a. a -> Maybe a -> a
fromMaybe Slots
IS.empty (Maybe Slots -> Slots)
-> (person -> Maybe Slots) -> person -> Slots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (person -> HashMap person Slots -> Maybe Slots
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`HM.lookup` HashMap person Slots
unavailability)
in (Slots -> person -> Slots) -> Slots -> [person] -> Slots
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Slots
s person
u -> Slots
s Slots -> Slots -> Slots
`IS.union` person -> Slots
unavailable person
u) Slots
IS.empty [person]
people
flipHashmap :: (Eq a, Hashable a, Eq b, Hashable b)
=> HM.HashMap a [b]
-> HM.HashMap b [a]
flipHashmap :: HashMap a [b] -> HashMap b [a]
flipHashmap HashMap a [b]
hm = ([a] -> [a] -> [a]) -> [(b, [a])] -> HashMap b [a]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(b, [a])] -> HashMap b [a]) -> [(b, [a])] -> HashMap b [a]
forall a b. (a -> b) -> a -> b
$ HashMap a [(b, [a])] -> [(b, [a])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (HashMap a [(b, [a])] -> [(b, [a])])
-> HashMap a [(b, [a])] -> [(b, [a])]
forall a b. (a -> b) -> a -> b
$ ((a -> [b] -> [(b, [a])]) -> HashMap a [b] -> HashMap a [(b, [a])])
-> HashMap a [b]
-> (a -> [b] -> [(b, [a])])
-> HashMap a [(b, [a])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> [b] -> [(b, [a])]) -> HashMap a [b] -> HashMap a [(b, [a])]
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
HM.mapWithKey HashMap a [b]
hm ((a -> [b] -> [(b, [a])]) -> HashMap a [(b, [a])])
-> (a -> [b] -> [(b, [a])]) -> HashMap a [(b, [a])]
forall a b. (a -> b) -> a -> b
$
\a
k [b]
vs -> (b -> (b, [a])) -> [b] -> [(b, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (, [a
k]) [b]
vs
calcConstraints :: (Eq person, Hashable person)
=> IM.IntMap (Interval UTCTime)
-> HM.HashMap Event [person]
-> Constraints
calcConstraints :: IntMap (Interval UTCTime) -> HashMap Slot [person] -> Constraints
calcConstraints IntMap (Interval UTCTime)
slotMap HashMap Slot [person]
events =
let eventKeys :: [Slot]
eventKeys = HashMap Slot [person] -> [Slot]
forall k v. HashMap k v -> [k]
HM.keys HashMap Slot [person]
events
noOverlapCons :: [Slot] -> IntMap Slot -> Bool
noOverlapCons [Slot]
xs IntMap Slot
a = [Maybe Slot] -> IntMap (Interval UTCTime) -> Bool
noConcurrentOverlap [IntMap Slot
a IntMap Slot -> Slot -> Maybe Slot
forall a. IntMap a -> Slot -> Maybe a
IM.!? Slot
i | Slot
i <- [Slot]
xs] IntMap (Interval UTCTime)
slotMap
notOverlapping :: [[Slot]]
notOverlapping = ([Slot] -> Bool) -> [[Slot]] -> [[Slot]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
>Slot
1) (Slot -> Bool) -> ([Slot] -> Slot) -> [Slot] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Slot] -> Slot
forall (t :: * -> *) a. Foldable t => t a -> Slot
length) ([[Slot]] -> [[Slot]]) -> [[Slot]] -> [[Slot]]
forall a b. (a -> b) -> a -> b
$ HashMap person [Slot] -> [[Slot]]
forall k v. HashMap k v -> [v]
HM.elems (HashMap person [Slot] -> [[Slot]])
-> HashMap person [Slot] -> [[Slot]]
forall a b. (a -> b) -> a -> b
$ HashMap Slot [person] -> HashMap person [Slot]
forall a b.
(Eq a, Hashable a, Eq b, Hashable b) =>
HashMap a [b] -> HashMap b [a]
flipHashmap HashMap Slot [person]
events
in
([Slot] -> Slots
IS.fromList [Slot]
eventKeys, \IntMap Slot
a -> [Maybe Slot] -> Bool
noOverlap [IntMap Slot
a IntMap Slot -> Slot -> Maybe Slot
forall a. IntMap a -> Slot -> Maybe a
IM.!? Slot
i | Slot
i <- [Slot]
eventKeys])
(Slots, IntMap Slot -> Bool) -> Constraints -> Constraints
forall a. a -> [a] -> [a]
: ([Slot] -> (Slots, IntMap Slot -> Bool)) -> [[Slot]] -> Constraints
forall a b. (a -> b) -> [a] -> [b]
map (\[Slot]
xs -> ([Slot] -> Slots
IS.fromList [Slot]
xs, [Slot] -> IntMap Slot -> Bool
noOverlapCons [Slot]
xs)) [[Slot]]
notOverlapping
toCSP :: (Eq person, Hashable person)
=> IM.IntMap (Interval UTCTime)
-> HM.HashMap Event [person]
-> HM.HashMap person Slots
-> (Int -> Assignment -> CSPMonad r (Maybe r))
-> CSP r
toCSP :: IntMap (Interval UTCTime)
-> HashMap Slot [person]
-> HashMap person Slots
-> (Slot -> IntMap Slot -> CSPMonad r (Maybe r))
-> CSP r
toCSP IntMap (Interval UTCTime)
slotMap HashMap Slot [person]
events HashMap person Slots
unavailability Slot -> IntMap Slot -> CSPMonad r (Maybe r)
term =
let slots :: Slots
slots = IntMap (Interval UTCTime) -> Slots
forall a. IntMap a -> Slots
IM.keysSet IntMap (Interval UTCTime)
slotMap
in MkCSP :: forall r.
Domains
-> Slots
-> Constraints
-> Slot
-> (Slot -> IntMap Slot -> CSPMonad r (Maybe r))
-> CSP r
MkCSP {
cspVariables :: Slots
cspVariables = [Slot] -> Slots
IS.fromList ([Slot] -> Slots) -> [Slot] -> Slots
forall a b. (a -> b) -> a -> b
$ HashMap Slot [person] -> [Slot]
forall k v. HashMap k v -> [k]
HM.keys HashMap Slot [person]
events,
cspDomains :: Domains
cspDomains = Slots -> HashMap Slot [person] -> HashMap person Slots -> Domains
forall person.
(Eq person, Hashable person) =>
Slots -> HashMap Slot [person] -> HashMap person Slots -> Domains
calcDomains Slots
slots HashMap Slot [person]
events HashMap person Slots
unavailability,
cspConstraints :: Constraints
cspConstraints = IntMap (Interval UTCTime) -> HashMap Slot [person] -> Constraints
forall person.
(Eq person, Hashable person) =>
IntMap (Interval UTCTime) -> HashMap Slot [person] -> Constraints
calcConstraints IntMap (Interval UTCTime)
slotMap HashMap Slot [person]
events,
cspRandomCap :: Slot
cspRandomCap = Slot
10 Slot -> Slot -> Slot
forall a. Num a => a -> a -> a
* HashMap Slot [person] -> Slot
forall k v. HashMap k v -> Slot
HM.size HashMap Slot [person]
events,
cspTermination :: Slot -> IntMap Slot -> CSPMonad r (Maybe r)
cspTermination = Slot -> IntMap Slot -> CSPMonad r (Maybe r)
term
}