--------------------------------------------------------------------------------
-- 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 vs = length (nub assigned) == length assigned
    where assigned = catMaybes 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 vs slots = snd $ foldl f (empty, True) vs'
    where
        vs' = catMaybes vs
        
        f (im, False) _ = (im, False)
        f (im, True) s =
            let interval = (slots IM.! s) in
            if all (\(i,_) -> low interval == high i || high interval == low i)
                $ interval `intersections` im
            then (insert interval () im, True)
            else (im, 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 events unavailability =
    -- generate map of domains for every event
    flip (flip HM.foldlWithKey' IM.empty) events $ \m event people ->
        -- add domain for this event - all slots where no one is busy
        flip (IM.insert event) m $ IS.difference slots $
            -- generate all slots where any member is unavailable
            let unavailable = fromMaybe IS.empty . (`HM.lookup` unavailability)
            in foldl (\s u -> s `IS.union` unavailable u) IS.empty 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 hm = HM.fromListWith (++) $ concat $ flip HM.mapWithKey hm $
    \k vs -> map (, [k]) 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 slotMap events =
    let eventKeys = HM.keys events
        noOverlapCons xs a = noConcurrentOverlap [a IM.!? i | i <- xs] slotMap
        notOverlapping = filter ((>1) . length) $ HM.elems $ flipHashmap events
    in -- prevent duplicate slot usage
       (IS.fromList eventKeys, \a -> noOverlap [a IM.!? i | i <- eventKeys])
       -- prevent the same person being allocated to multple places at the same
       -- time
       : map (\xs -> (IS.fromList xs, noOverlapCons xs)) 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 slotMap events unavailability term =
    let slots = IM.keysSet slotMap
    in MkCSP {
        -- variables are the events
        cspVariables = IS.fromList $ HM.keys events,
        -- domains are the slots the events may be assigned to
        cspDomains = calcDomains slots events unavailability,
        -- constraints prevent several events being assigned to the same slot
        -- and people being assigned to 2 places at once
        cspConstraints = calcConstraints slotMap events,
        -- iterate a maximum of 10 times the number of events before switching
        -- to random variable selection
        cspRandomCap = 10 * HM.size events,
        -- use the provided termination condition
        cspTermination = term
    }

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