--------------------------------------------------------------------------------
-- Iterative Forward Search                                                   --
--------------------------------------------------------------------------------
-- This source code is licensed under the terms found in the LICENSE file in  --
-- the root directory of this source tree.                                    --
--------------------------------------------------------------------------------

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` @vs@ ensures that no `Just` values in @vs@ are the same
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` @vs slots@ ensures that the assigned values (the Just
-- values) in @vs@ do not overlap. @slots@ is used to fetch the interval for
-- each slot
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` @slots events unavailability@ creates the domain for each
-- event by finding all the slots where any member of the event is unavailable
-- and setting the domain to all slots except these
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 =
    -- generate map of domains for every event
    ((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 ->
        -- add domain for this event - all slots where no one is busy
        (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
$
            -- generate all slots where any member is unavailable
            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` @hm@ converts the hashmap of lists of type `b` with key `a`
-- to a hashmap indexed on values of `b` linked to lists of `a`
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` @slots slotMap events@ creates the constraints which stop
-- the same slot being used by 2 events, and the same person being assigned to 2
-- places at once
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 -- prevent duplicate slot usage
       ([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])
       -- prevent the same person being allocated to multple places at the same
       -- time
       (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` @slots events unavailability termination@ creates a CSP that
-- timetables the events in @events@ such that everyones availability is
-- respected and no one is timetabled to 2 events simultaneously. In this CSP
-- the events are the variables, and the slots are the values.
-- 
-- Slots are identified by integers, and must be supplied with a time interval,
-- and events are also identifed by intergers, and must be supplied as with a
-- list of all people in the event. People can be represented by anything with
-- a `Hashable` and an `Eq` instance, and @unavailability@ can be used to
-- specify the slots where a person is unavailable.
--
-- Finally a termination condition must be provided. This is as defined in
-- "Data.IFS.Types"
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 {
        -- variables are the events
        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,
        -- domains are the slots the events may be assigned to
        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,
        -- constraints prevent several events being assigned to the same slot
        -- and people being assigned to 2 places at once
        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,
        -- iterate a maximum of 10 times the number of events before switching
        -- to random variable selection
        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,
        -- use the provided termination condition
        cspTermination :: Slot -> IntMap Slot -> CSPMonad r (Maybe r)
cspTermination = Slot -> IntMap Slot -> CSPMonad r (Maybe r)
term
    }

--------------------------------------------------------------------------------