module CombinatorialOptimisation.TIM(TimeTable(TimeTable,numberOfEvents,numberOfRooms,numberOfPeople,numberOfTimeSlots,
personEventLookup, eventPersonLookup,eventRoomLookup,roomEventLookup,
eventLocation,locationEvent,personUsage,unscheduledEvents,overSchedule,
daynumberDecode,dayslotDecode,eventsInDay,singleEventInDayCounter,lastSlotOfDayCounter,
moreThanTwoEventsCounter,lastDay,lastSlotOfDay),
viewConstrainedProblem,descheduleEvent,descheduleSlot,schedule,viewTimeTableDetails,
ittcValidity,ittcObjectiveValue,timeTableDetailsAsCSV,timeTableForRoomAsCSV,
currentlyScheduledEvents,
TimeSlot,DayNumber,DaySlot,RoomNumber,EventNumber,PersonNumber,FeatureNumber,Counter
)where
import qualified Data.Array as A
import qualified Data.Map as M
import Data.List
type TimeSlot = Int
type DayNumber = Int
type DaySlot = Int
type RoomNumber = Int
type EventNumber = Int
type PersonNumber = Int
type FeatureNumber = Int
type Counter = Int
data TimeTable = TimeTable { numberOfEvents :: Int
, numberOfRooms :: Int
, numberOfPeople :: Int
, numberOfTimeSlots :: Int
, personEventLookup :: PersonNumber->[EventNumber]
, eventPersonLookup :: EventNumber->[PersonNumber]
, eventRoomLookup :: EventNumber->[RoomNumber]
, roomEventLookup :: RoomNumber->[EventNumber]
, eventLocation :: M.Map EventNumber (TimeSlot,RoomNumber)
, locationEvent :: M.Map (TimeSlot,RoomNumber) EventNumber
, personUsage :: M.Map (TimeSlot,PersonNumber) Counter
, unscheduledEvents :: [EventNumber]
, lastDay :: Int
, lastSlotOfDay :: Int
, overSchedule :: Counter
, daynumberDecode :: TimeSlot->DayNumber
, dayslotDecode :: TimeSlot->DaySlot
, eventsInDay :: M.Map (DayNumber,PersonNumber) Counter
, singleEventInDayCounter :: Counter
, lastSlotOfDayCounter :: Counter
, moreThanTwoEventsCounter :: Counter }
instance Show TimeTable where
show t = concat ["TimeTable Problem & Solution : \n",
" Validity : ",if ittcValidity t then "VALID\n" else "INVALID\n",
" Objective Function Value : ",show . ittcObjectiveValue $ t,"\n",
" Over Scheduled By : ",show . overSchedule $ t,"\n",
" Single Session In A Day Counter : ",show . singleEventInDayCounter $ t,"\n",
" Last Slot Of Day Counter : ",show . lastSlotOfDayCounter $ t,"\n",
" More Than Two Events In Succession Counter : ",show . moreThanTwoEventsCounter $ t,"\n",
" Still Unscheduled : ",show . length . unscheduledEvents $ t,"\n"]
ittcObjectiveValue :: TimeTable->Int
ittcObjectiveValue t = singleEventInDayCounter t + lastSlotOfDayCounter t + moreThanTwoEventsCounter t
ittcValidity :: TimeTable->Bool
ittcValidity t = (overSchedule t == 0) && (null (unscheduledEvents t))
viewConstrainedProblem :: TimeTable->String
viewConstrainedProblem t = concat [header,personEventHeader,personEvent,eventPersonHeader,eventPerson,eventRoomHeader,eventRoom,roomEventHeader,roomEvent]
where
header = concat [concat ["Number Of ",a,",",b,"\n"] | (a,b)<-zip ["Events","Rooms","People","Time Slots"] $ map show [numberOfEvents t,numberOfRooms t,numberOfPeople t,numberOfTimeSlots t]]
personEventHeader = "\nPerson To Event Lookup\n"
personEvent = concatMap concat ["\nPerson":(show p): (map (\l->","++show l) (personEventLookup t p)) | p<-[0 .. numberOfPeople t 1]]
eventPersonHeader = "\n\nEvent To Person Lookup\n"
eventPerson = concatMap concat ["\nEvent":(show p): (map (\l->","++show l) (eventPersonLookup t p)) | p<-[0 .. numberOfEvents t 1]]
eventRoomHeader = "\n\nEvent To Room Lookup\n"
eventRoom = concatMap concat ["\nEvent":(show p): (map (\l->","++show l) (eventRoomLookup t p)) | p<-[0 .. numberOfEvents t 1]]
roomEventHeader = "\n\nRoom To Event Lookup\n"
roomEvent = concatMap concat ["\nRoom":(show p): (map (\l->","++show l) (roomEventLookup t p)) | p<-[0 .. numberOfRooms t 1]]
viewTimeTableDetails :: TimeTable->String
viewTimeTableDetails t = unsched++locs
where
timeSlots = [0 .. numberOfTimeSlots t 1]
roomCodes = [0 .. numberOfRooms t 1]
persCodes = [0 .. numberOfPeople t 1]
unsched = "Currently Unscheduled Events : "++(concat [show x++" " |x<-unscheduledEvents t]) ++ "\n"
locs = concat [makeTimeSlotDisplay s | s<-timeSlots,somethingAllocated s]
somethingAllocated s = or [M.member (s,r) (locationEvent t) | r<-roomCodes]
personRequested s p = (M.member (s,p) (personUsage t)) && ((personUsage t) M.! (s,p) >0)
makeTimeSlotDisplay s = concat $ ["Time Slot : ",show (daynumberDecode t s,dayslotDecode t s),"\n",
makePersonUsage s]++
[" Room "++(show r)++" : "++ (show $ (locationEvent t) M.! (s,r))++"\n" | r<-roomCodes,M.member (s,r) (locationEvent t) ]
makePersonUsage s = " Persons Used : "++concat [ show p++" " | p<-persCodes,personRequested s p]++"\n"
timeTableDetailsAsCSV :: TimeTable->String
timeTableDetailsAsCSV t = concat [(timeTableForRoomAsCSV t r)++"\n\n" | r<-[0 .. numberOfRooms t 1] ]
timeTableForRoomAsCSV :: TimeTable->RoomNumber->String
timeTableForRoomAsCSV t r = header ++ (concatMap concat [["Slot ",show s]++ [checkLocation (d * mSlots + s,r) | d<-[0 .. mDays]]++["\n"] |s<-[0 .. mSlots]])
where
(days,slots) = unzip [(daynumberDecode t s,dayslotDecode t s) | s<-[0..numberOfTimeSlots t 1]]
mDays = lastDay t
mSlots = lastSlotOfDay t
checkLocation sl | M.member sl (locationEvent t) = ","++ (show $ (locationEvent t) M.! sl)
| otherwise = ","
header = ","++ concat ["Day "++(show d)++"," | d<-[0 .. mDays]]++"\n"
schedule :: TimeSlot->RoomNumber->EventNumber->TimeTable->TimeTable
schedule s r e t = if validEvent && validRoom && validSlot
then t{unscheduledEvents=newUnscheduled,eventLocation=el,locationEvent=le,personUsage=pu,overSchedule=newOverSchedule,eventsInDay=newEventsInDay,
lastSlotOfDayCounter=newLastSlot,singleEventInDayCounter=newSingleEventCounter,moreThanTwoEventsCounter = newTwoCounter}
else t
where
validEvent = M.notMember e (eventLocation t)
validRoom = elem r (eventRoomLookup t e)
validSlot = M.notMember (s,r) (locationEvent t)
day = daynumberDecode t s
dayS = dayslotDecode t s
newUnscheduled = filter (/=e) (unscheduledEvents t)
el = M.insert e (s,r) (eventLocation t)
le = M.insert (s,r) e (locationEvent t)
pu = foldl' (\c k->M.alter f (s,k) c) (personUsage t) (eventPersonLookup t e)
f Nothing = Just 1
f p = fmap (+1) p
newOverSchedule = (overSchedule t) + sum [1 | p<-eventPersonLookup t e,pu M.! (s,p) >1]
newEventsInDay = foldl' (\c p->M.alter f (day,p) c) (eventsInDay t) (eventPersonLookup t e)
newLastSlot = if dayS == lastSlotOfDay t then lastSlotOfDayCounter t + (length $ eventPersonLookup t e)
else lastSlotOfDayCounter t
newSingleEventCounter = singleEventInDayCounter t + sum [1 | p<-eventPersonLookup t e,newEventsInDay M.! (day,p) == 1]
beforeChain = before s dayS
afterChain = after (lastSlotOfDay t) s dayS
newTwoCounter = moreThanTwoEventsCounter t + (sum . (map changeInChains) $ [(findChain p beforeChain pu,findChain p afterChain pu) | p<-eventPersonLookup t e])
changeInChains :: (Int,Int)->Int
changeInChains (0,0) = 0
changeInChains (0,1) = 0
changeInChains (1,0) = 0
changeInChains (2,0) = 1
changeInChains (0,2) = 1
changeInChains (2,1) = 2
changeInChains (1,2) = 2
changeInChains _ = 3
before :: TimeSlot->DaySlot->[TimeSlot]
before _ 0 = []
before s ds = let s' = s1 in s':before s' (ds1)
after :: DaySlot->TimeSlot->DaySlot->[TimeSlot]
after l s ds | ds == l = []
| otherwise = let s' = s+1 in s' : after l s' (ds+1)
findChain :: PersonNumber->[TimeSlot]->M.Map (TimeSlot,PersonNumber) Counter->Int
findChain p slots m = length $ takeWhile (\x->M.member (x,p) m) slots
deschedule :: TimeSlot->RoomNumber->EventNumber->TimeTable->TimeTable
deschedule s r e t = t{unscheduledEvents=newUnscheduled,eventLocation=el,locationEvent=le,personUsage=pu,overSchedule=newOverSchedule,eventsInDay=newEventsInDay,
lastSlotOfDayCounter=newLastSlot,singleEventInDayCounter=newSingleEventCounter,moreThanTwoEventsCounter = newTwoCounter}
where
day = daynumberDecode t s
dayS = dayslotDecode t s
newUnscheduled = e:(unscheduledEvents t)
el = M.delete e (eventLocation t)
le = M.delete (s,r) (locationEvent t)
pu = foldl' (\c k->M.alter f (s,k) c) (personUsage t) (eventPersonLookup t e)
f Nothing = Nothing
f (Just 1) = Nothing
f (Just x) = Just (x1)
newLastSlot = if dayS == lastSlotOfDay t then lastSlotOfDayCounter t (length $ eventPersonLookup t e)
else lastSlotOfDayCounter t
newSingleEventCounter = singleEventInDayCounter t sum [1 | p<-eventPersonLookup t e,M.notMember (day,p) newEventsInDay ]
newOverSchedule = (overSchedule t) sum [1 | p<-eventPersonLookup t e,M.member (s,p) pu,pu M.! (s,p) == 1]
newEventsInDay = foldl' (\c p->M.alter f (day,p) c) (eventsInDay t) (eventPersonLookup t e)
beforeChain = before s dayS
afterChain = after (lastSlotOfDay t) s dayS
newTwoCounter = moreThanTwoEventsCounter t (sum . (map changeInChains) $ [(findChain p beforeChain pu,findChain p afterChain pu) | p<-eventPersonLookup t e])
descheduleEvent :: EventNumber->TimeTable->TimeTable
descheduleEvent e t = if validEvent then deschedule s r e t
else t
where
validEvent = M.member e (eventLocation t)
(s,r) = (eventLocation t) M.! e
descheduleSlot :: TimeSlot->RoomNumber->TimeTable->TimeTable
descheduleSlot s r t = if validSlot then deschedule s r e t
else t
where
validSlot = M.member (s,r) (locationEvent t)
e = (locationEvent t) M.! (s,r)
currentlyScheduledEvents :: TimeTable->[EventNumber]
currentlyScheduledEvents = M.keys . eventLocation