{-# LANGUAGE CPP #-}
module WeekDaze.Model.TimetableForDay(
TimetableForDay,
Association,
Booking,
GeneralisedLessonRunlength,
GeneralisedLessonRunlengthByTimeslotId,
LessonRunlengths,
RunlengthsByTimeslotIdByLesson,
measureRunlengthAt,
boundRunlengthAt,
countRunlengthAt,
countUnallocatedTimeslots,
bisectAt,
extractAdjacentBookings,
locateUnallocatedTimeslots,
findGeneralisedLessonRunlengths,
findGeneralisedLessonRunlengthsByTimeslotId,
findSeparatedEqualLessons,
findSeparatedEqualSubjectLessons,
findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson,
measureFreePeriodCompliance,
spanRunlengthAt,
getTimeslotId,
getMaybeLesson,
getBookedLesson,
mkFreeTimetableForDay,
defineTimeslot,
isSubjectBooked,
isDefined,
xpickle
) where
import Control.Arrow((&&&), (***))
import Data.Array.IArray((//), (!))
import qualified Control.Arrow
import qualified Data.Array.IArray
import qualified Data.Foldable
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Maybe
import qualified Data.Set
import qualified Factory.Data.Interval
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.Data.List
import qualified ToolShed.Data.List.Runlength
import qualified ToolShed.Data.Pair
import qualified WeekDaze.Data.Subject as Data.Subject
import qualified WeekDaze.Model.Lesson as Model.Lesson
import qualified WeekDaze.Size as Size
import qualified WeekDaze.Temporal.FreePeriodPreference as Temporal.FreePeriodPreference
import qualified WeekDaze.Temporal.Time as Temporal.Time
tag :: String
tag = "timetableForDay"
bookingTag :: String
bookingTag = "booking"
type TimetableForDay timeslotId resourceIds level = Data.Array.IArray.Array timeslotId (Model.Lesson.GeneralisedLesson resourceIds level)
type Association timeslotId resourceIds level = (timeslotId, Model.Lesson.GeneralisedLesson resourceIds level)
getTimeslotId :: Association timeslotId resourceIds level -> timeslotId
getTimeslotId = fst
getMaybeLesson :: Association timeslotId resourceIds level -> Model.Lesson.GeneralisedLesson resourceIds level
getMaybeLesson = snd
isDefined :: Association timeslotId resourceIds level -> Bool
isDefined = Data.Maybe.isJust . getMaybeLesson
xpickle :: (
Data.Array.IArray.Ix timeslotId,
HXT.XmlPickler level,
HXT.XmlPickler resourceIds,
HXT.XmlPickler timeslotId,
Show level
) => HXT.PU (TimetableForDay timeslotId resourceIds level)
xpickle = HXT.xpElem tag . HXT.xpWrap (
uncurry Data.Array.IArray.array . (
(minimum &&& maximum) . map fst &&& id
),
Data.Array.IArray.assocs
) . HXT.xpList1 $ HXT.xpElem bookingTag HXT.xpickle
type Booking timeslotId resourceIds level = (timeslotId, Model.Lesson.Lesson resourceIds level)
getBookedTimeslotId :: Booking timeslotId resourceIds level -> timeslotId
getBookedTimeslotId = fst
getBookedLesson :: Booking timeslotId resourceIds level -> Model.Lesson.Lesson resourceIds level
getBookedLesson = snd
mkFreeTimetableForDay :: (Data.Array.IArray.Ix timeslotId, Enum timeslotId) => Factory.Data.Interval.Interval timeslotId -> TimetableForDay timeslotId resourceIds level
mkFreeTimetableForDay timeslotIdBounds = Data.Array.IArray.array timeslotIdBounds . zip (Factory.Data.Interval.toList timeslotIdBounds) $ repeat Nothing
bisectAt
:: Data.Array.IArray.Ix timeslotId
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> ([Association timeslotId resourceIds level], [Association timeslotId resourceIds level])
bisectAt timeslotId = (
dropWhile (
(>= timeslotId) . getTimeslotId
) . reverse &&& dropWhile (
(<= timeslotId) . getTimeslotId
)
) . Data.Array.IArray.assocs
extractAdjacentBookings
:: Data.Array.IArray.Ix timeslotId
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> [Booking timeslotId resourceIds level]
extractAdjacentBookings timeslotId = uncurry (++) . ToolShed.Data.Pair.mirror (
take 1 . map (Control.Arrow.second Data.Maybe.fromJust) . takeWhile isDefined
) . bisectAt timeslotId
measureRunlengthAt :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq resourceIds,
Eq level
)
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> (Factory.Data.Interval.Interval timeslotId, Size.NTimeslots)
measureRunlengthAt timeslotId timetableForDay = (
(
toEnum . (i -) *** toEnum . (i +)
) &&& succ . uncurry (+)
) . ToolShed.Data.Pair.mirror (
length . takeWhile ((== timetableForDay ! timeslotId) . getMaybeLesson)
) $ bisectAt timeslotId timetableForDay where
i = fromEnum timeslotId
boundRunlengthAt :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq resourceIds,
Eq level
)
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> Factory.Data.Interval.Interval timeslotId
boundRunlengthAt timeslotId = fst . measureRunlengthAt timeslotId
spanRunlengthAt :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq resourceIds,
Eq level
)
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> [timeslotId]
spanRunlengthAt timeslotId = uncurry enumFromTo . boundRunlengthAt timeslotId
countRunlengthAt :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq resourceIds,
Eq level
)
=> timeslotId
-> TimetableForDay timeslotId resourceIds level
-> Size.NTimeslots
countRunlengthAt timeslotId = snd . measureRunlengthAt timeslotId
isSubjectBooked :: (
#if !MIN_VERSION_array(0,5,2)
Data.Array.IArray.Ix timeslotId,
#endif /* CAVEAT: constraint unnecessary from "Data.Array.IArray-0.5.1.1" */
Eq level
) => Data.Subject.Subject level -> TimetableForDay timeslotId resourceIds level -> Bool
isSubjectBooked subject = Data.Foldable.any . Data.Maybe.maybe False $ (== subject) . Model.Lesson.getSubject
locateUnallocatedTimeslots :: Data.Array.IArray.Ix timeslotId => TimetableForDay timeslotId resourceIds level -> [timeslotId]
locateUnallocatedTimeslots timetableForDay = [
unallocatedTimeslotId |
(unallocatedTimeslotId, Nothing ) <- Data.Array.IArray.assocs timetableForDay
]
countUnallocatedTimeslots :: Data.Array.IArray.Ix timeslotId => TimetableForDay timeslotId resourceIds level -> Size.NTimeslots
countUnallocatedTimeslots = length . locateUnallocatedTimeslots
defineTimeslot
:: Data.Array.IArray.Ix timeslotId
=> Association timeslotId resourceIds level
-> TimetableForDay timeslotId resourceIds level
-> TimetableForDay timeslotId resourceIds level
defineTimeslot booking = (// [booking])
type GeneralisedLessonRunlength resourceIds level = ToolShed.Data.List.Runlength.Code (Model.Lesson.GeneralisedLesson resourceIds level)
type GeneralisedLessonRunlengths resourceIds level = [GeneralisedLessonRunlength resourceIds level]
findGeneralisedLessonRunlengths :: (
Data.Array.IArray.Ix timeslotId,
Eq resourceIds,
Eq level
) => TimetableForDay timeslotId resourceIds level -> GeneralisedLessonRunlengths resourceIds level
findGeneralisedLessonRunlengths = ToolShed.Data.List.Runlength.encode . Data.Array.IArray.elems
type GeneralisedLessonRunlengthByTimeslotId timeslotId resourceIds level = [(timeslotId, GeneralisedLessonRunlength resourceIds level)]
findGeneralisedLessonRunlengthsByTimeslotId :: (
Data.Array.IArray.Ix timeslotId,
Enum timeslotId,
Eq resourceIds,
Eq level
) => TimetableForDay timeslotId resourceIds level -> GeneralisedLessonRunlengthByTimeslotId timeslotId resourceIds level
findGeneralisedLessonRunlengthsByTimeslotId timetableForDay = init . scanr (
\runlengthCode (timeslotId, _) -> (`Temporal.Time.shift` timeslotId) . negate . ToolShed.Data.List.Runlength.getLength &&& id $ runlengthCode
) (
succ . snd $ Data.Array.IArray.bounds timetableForDay,
undefined
) $ findGeneralisedLessonRunlengths timetableForDay
type LessonRunlengths resourceIds level = [ToolShed.Data.List.Runlength.Code (Model.Lesson.Lesson resourceIds level)]
findSeparatedEqualLessonsBy :: (
Data.Array.IArray.Ix timeslotId,
Eq resourceIds,
Eq level,
Ord attribute
)
=> (Model.Lesson.Lesson resourceIds level -> attribute)
-> TimetableForDay timeslotId resourceIds level
-> LessonRunlengths resourceIds level
findSeparatedEqualLessonsBy accessor = filter (
(/= 1) . ToolShed.Data.List.Runlength.getLength
) . map (
length &&& head
) . Data.List.Extra.groupSortOn accessor . Data.Maybe.mapMaybe head . Data.List.group . Data.Array.IArray.elems
findSeparatedEqualLessons :: (
Data.Array.IArray.Ix timeslotId,
Ord resourceIds,
Ord level
) => TimetableForDay timeslotId resourceIds level -> LessonRunlengths resourceIds level
findSeparatedEqualLessons = findSeparatedEqualLessonsBy id
findSeparatedEqualSubjectLessons :: (
Data.Array.IArray.Ix timeslotId,
Eq resourceIds,
Ord level
) => TimetableForDay timeslotId resourceIds level -> LessonRunlengths resourceIds level
findSeparatedEqualSubjectLessons = findSeparatedEqualLessonsBy Model.Lesson.getSubject
type RunlengthsByTimeslotIdByLesson resourceIds level timeslotId = [(Model.Lesson.Lesson resourceIds level, [(timeslotId , Size.NTimeslots )])]
findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson :: (
Data.Array.IArray.Ix timeslotId,
Ord resourceIds,
Ord level
) => TimetableForDay timeslotId resourceIds level -> RunlengthsByTimeslotIdByLesson resourceIds level timeslotId
findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson timetableForDay = map (
\l@(
(
_,
(
_,
lesson
)
) : _
) -> (
lesson,
map (
Control.Arrow.second fst
) l
)
) . filter (
(/= 1) . length
) $ Data.List.Extra.groupSortOn (
snd . snd
) [
(startingTimeslotId, (length l, lesson)) |
l@((startingTimeslotId, Just lesson) : _) <- Data.List.groupBy (
ToolShed.Data.List.equalityBy snd
) $ Data.Array.IArray.assocs timetableForDay
]
measureFreePeriodCompliance
:: (Data.Array.IArray.Ix timeslotId, Fractional ratio)
=> Temporal.FreePeriodPreference.FreePeriodPreference
-> Data.Set.Set timeslotId
-> TimetableForDay timeslotId resourceIds level
-> ratio
measureFreePeriodCompliance freePeriodPreference meetingTimeslotIds timetableForDay
| nFreePeriods `elem` [
0,
Data.Array.IArray.rangeSize $ Data.Array.IArray.bounds timetableForDay
] = 1
| otherwise = fromIntegral nCompliantFreePeriods / fromIntegral nFreePeriods
where
nCompliantFreePeriods, nFreePeriods :: Size.NTimeslots
(nCompliantFreePeriods, nFreePeriods) = (
countConformantFreePeriods freePeriodPreference &&& length . filter id
) . map (
uncurry (&&) . ((`Data.Set.notMember` meetingTimeslotIds) *** Data.Maybe.isNothing)
) $ Data.Array.IArray.assocs timetableForDay
countConformantFreePeriods :: Temporal.FreePeriodPreference.FreePeriodPreference -> [Bool] -> Size.NTimeslots
countConformantFreePeriods freePeriodPreference' = case freePeriodPreference' of
Temporal.FreePeriodPreference.Pre -> length . takeWhile id
Temporal.FreePeriodPreference.Post -> countConformantFreePeriods Temporal.FreePeriodPreference.Pre . reverse
Temporal.FreePeriodPreference.Terminal -> uncurry (+) . (countConformantFreePeriods Temporal.FreePeriodPreference.Pre &&& countConformantFreePeriods Temporal.FreePeriodPreference.Post)