TimetableForDay.hs

{-# LANGUAGE CPP #-}
{-
	Copyright (C) 2013-2016 Dr. Alistair Ward

	This file is part of WeekDaze.

	WeekDaze is free software: you can redistribute it and/or modify
	it under the terms of the GNU General Public License as published by
	the Free Software Foundation, either version 3 of the License, or
	(at your option) any later version.

	WeekDaze is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public License
	along with WeekDaze.  If not, see <http://www.gnu.org/licenses/>.
-}
{- |
 [@AUTHOR@]	Dr. Alistair Ward

 [@DESCRIPTION@]

	* Define the data-structure, required to hold a single day's bookings, for any /observer/-id.

	* It doesn't reference the parameters of the specific problem, or the means by which a solution is obtained.
-}

module WeekDaze.Model.TimetableForDay(
-- * Types
-- ** Type-synonyms
	TimetableForDay,
	Association,
	Booking,
	GeneralisedLessonRunlength,
	GeneralisedLessonRunlengthByTimeslotId,
--	GeneralisedLessonRunlengths,
	LessonRunlengths,
	RunlengthsByTimeslotIdByLesson,
-- * Constants
--	tag,
--	bookingTag,
-- * Functions
	measureRunlengthAt,
	boundRunlengthAt,
	countRunlengthAt,
	countUnallocatedTimeslots,
	bisectAt,
	extractAdjacentBookings,
	locateUnallocatedTimeslots,
	findGeneralisedLessonRunlengths,
	findGeneralisedLessonRunlengthsByTimeslotId,
--	findSeparatedEqualLessonsBy,
	findSeparatedEqualLessons,
	findSeparatedEqualSubjectLessons,
	findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson,
	measureFreePeriodCompliance,
	spanRunlengthAt,
-- ** Accessors
	getTimeslotId,
	getMaybeLesson,
--	getBookedTimeslotId,
	getBookedLesson,
-- ** Constructor
	mkFreeTimetableForDay,
-- ** Mutators
	defineTimeslot,
-- ** Predicates
	isSubjectBooked,
	isDefined,
-- ** Translation
	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

-- | Used to qualify XML.
tag :: String
tag		= "timetableForDay"

-- | Used to qualify XML.
bookingTag :: String
bookingTag	= "booking"

{- |
	* The ordered sequence of time-slots within a single unspecified day.

	* The sequence of time-slots are contiguous;
		/double/ /lesson/s are representated by consecutive duplicate /lesson/-definitions,
		free-/period/s are represented by 'Nothing'.

	* Each time-slot has a specific unspecified start-time & probably a constant duration; but that depends on the school, so no such assumption is made here.
-}
type TimetableForDay timeslotId resourceIds level	= Data.Array.IArray.Array timeslotId (Model.Lesson.GeneralisedLesson resourceIds level)

-- | The association on which 'TimetableForDay' is based.
type Association timeslotId resourceIds level	= (timeslotId, Model.Lesson.GeneralisedLesson resourceIds level)

-- | Accessor.
getTimeslotId :: Association timeslotId resourceIds level -> timeslotId
getTimeslotId	= fst

-- | Accessor.
getMaybeLesson :: Association timeslotId resourceIds level -> Model.Lesson.GeneralisedLesson resourceIds level
getMaybeLesson	= snd

-- | True if the /time-slot/ has been booked.
isDefined :: Association timeslotId resourceIds level -> Bool
isDefined	= Data.Maybe.isJust . getMaybeLesson

-- | Defines a pickler to convert the specified /timetable/ to, or from, XML.
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
	),				-- Construct from an association-list; since all time-slots are recorded in the XML, even when no lesson is booked, the timeslotId-bounds can be derived.
	Data.Array.IArray.assocs	-- Deconstruct to an association-list.
 ) . HXT.xpList1 {-can't be null-} $ HXT.xpElem bookingTag HXT.xpickle {-Pair-}

-- | A /lesson/ qualified by the /time-slot/ at which it is booked.
type Booking timeslotId resourceIds level	= (timeslotId, Model.Lesson.Lesson resourceIds level)

-- | Accessor.
getBookedTimeslotId :: Booking timeslotId resourceIds level -> timeslotId
getBookedTimeslotId	= fst

-- | Accessor.
getBookedLesson :: Booking timeslotId resourceIds level -> Model.Lesson.Lesson resourceIds level
getBookedLesson	= snd

-- | Constructor. Create an unallocated /timetable/, for any single day.
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

{- |
	* Bisect the association-list extracted from the 'TimetableForDay', at the specified /timeslotId/, to form two lists, those before & those after the specified /time-slot/.

	* The list of earlier /time-slot/s is reversed, as though looking backwards from the specified /time-slot/.

	* CAVEAT: the association at the specified /timeslotId/ isn't returned in either half.
-}
bisectAt
	:: Data.Array.IArray.Ix timeslotId
	=> timeslotId
	-> TimetableForDay timeslotId resourceIds level
	-> ([Association timeslotId resourceIds level], [Association timeslotId resourceIds level])
bisectAt timeslotId	= (
	dropWhile (
		(>= timeslotId) . getTimeslotId	-- Extract earlier timeslots.
	) . reverse &&& dropWhile (
		(<= timeslotId) . getTimeslotId	-- Extract later timeslots.
	)
 ) . Data.Array.IArray.assocs

{- |
	* Get any /lesson/s immediately adjacent to the specified /time-slot/.

	* The relevance is that adjacent /lesson/s can typically be replicated, to form a longer duration /lesson/,
	but duplication of a non-adjacent one, would leave an awkward gap.
-}
extractAdjacentBookings
	:: Data.Array.IArray.Ix timeslotId
	=> timeslotId
	-> TimetableForDay timeslotId resourceIds level
	-> [Booking timeslotId resourceIds level]
extractAdjacentBookings timeslotId	= uncurry (++) . ToolShed.Data.Pair.mirror (
	take 1 {-either a null or a singleton list; cf. 'head'-} . map (Control.Arrow.second Data.Maybe.fromJust) . takeWhile isDefined
 ) . bisectAt timeslotId

{- |
	* Defines the (lower & upper) bounds, & measures the span-length, of adjacent /lesson/s, equal to that referenced.

	* CAVEAT: if an undefined /time-slot/ is referenced, then the run-length of undefined /time-slot/s will be measured.
-}
measureRunlengthAt :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			resourceIds,
	Eq			level
 )
	=> timeslotId	-- ^ The identifier of the /time-slot/ at which to measure the run-length of equal /lesson/s.
	-> TimetableForDay timeslotId resourceIds level
	-> (Factory.Data.Interval.Interval timeslotId, Size.NTimeslots)
measureRunlengthAt timeslotId timetableForDay	= (
	(
		toEnum . (i -) *** toEnum . (i +)	-- Identify the minimum & maximum bounds of the runlength.
	) &&& succ {-include the specified timeslotId-} . uncurry (+)
 ) . ToolShed.Data.Pair.mirror (
	length . takeWhile ((== timetableForDay ! timeslotId) . getMaybeLesson)
 ) $ bisectAt timeslotId timetableForDay where
	i	= fromEnum timeslotId

-- | Defines the /timeslotId/-interval, delimiting the span of adjacent /lesson/s, equal to that referenced.
boundRunlengthAt :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			resourceIds,
	Eq			level
 )
	=> timeslotId	-- ^ The identifier of the /time-slot/ at which to measure the run-length of equal /lesson/s.
	-> TimetableForDay timeslotId resourceIds level
	-> Factory.Data.Interval.Interval timeslotId
boundRunlengthAt timeslotId	= fst . measureRunlengthAt timeslotId

-- | Returns the list of /timeslotId/s where /lesson/s equal to that referenced, are booked.
spanRunlengthAt :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			resourceIds,
	Eq			level
 )
	=> timeslotId	-- ^ The identifier of the /time-slot/ at which to measure the run-length of equal /lesson/s.
	-> TimetableForDay timeslotId resourceIds level
	-> [timeslotId]
spanRunlengthAt timeslotId	= uncurry enumFromTo . boundRunlengthAt timeslotId

-- | Measures the length of the span of adjacent /lesson/s, equal to that referenced.
countRunlengthAt :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			resourceIds,
	Eq			level
 )
	=> timeslotId	-- ^ The identifier of the /time-slot/ at which to measure the run-length of equal /lesson/s.
	-> TimetableForDay timeslotId resourceIds level
	-> Size.NTimeslots
countRunlengthAt timeslotId	= snd . measureRunlengthAt timeslotId

-- | True if the specified /subject/ has already been booked at any /time-slot/ in today's /timetable/.
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 {-no lesson booked-} $ (== subject) . Model.Lesson.getSubject

{- |
	* Identifies unallocated /time-slot/s.

	* CAVEAT: doesn't account for the /availability/ of the /resource/, or whether any /time-slot/s has been reserved for /meeting/s.
-}
locateUnallocatedTimeslots :: Data.Array.IArray.Ix timeslotId => TimetableForDay timeslotId resourceIds level -> [timeslotId]
locateUnallocatedTimeslots timetableForDay	= [
	unallocatedTimeslotId |
		(unallocatedTimeslotId, Nothing {-i.e. unallocated-})	<- Data.Array.IArray.assocs timetableForDay
 ] -- List-comprehension.

{- |
	* Counts the /time-slot/s which haven't been yet booked.

	* CAVEAT: doesn't account for the /availability/ of the /resource/, or whether any /time-slot/s has been reserved for /meeting/s.
-}
countUnallocatedTimeslots :: Data.Array.IArray.Ix timeslotId => TimetableForDay timeslotId resourceIds level -> Size.NTimeslots
countUnallocatedTimeslots	= length . locateUnallocatedTimeslots

-- | Define a single /lesson/ in the /timetable/.
defineTimeslot
	:: Data.Array.IArray.Ix timeslotId
	=> Association timeslotId resourceIds level
	-> TimetableForDay timeslotId resourceIds level
	-> TimetableForDay timeslotId resourceIds level
defineTimeslot booking	= (// [booking])

-- | A runlength-encoded list of generalised (i.e. potentially undefined) /lesson/.
type GeneralisedLessonRunlength resourceIds level	= ToolShed.Data.List.Runlength.Code (Model.Lesson.GeneralisedLesson resourceIds level)

-- | A runlength-encoded list of /time-slot/s.
type GeneralisedLessonRunlengths resourceIds level	= [GeneralisedLessonRunlength resourceIds level]

{- |
	* Measures run-lengths of consecutive equal generalised (i.e. potentially undefined) /lesson/s.

	* Includes consecutive unallocated /time-slot/s & trivial sequences of length one.

	* CAVEAT: the /coordinates/ of each runlength aren't explicit; see 'findGeneralisedLessonRunlengthsByTimeslotId'.
-}
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

-- | An association-list keyed by the starting /timeslotId/, of runlength-encoded generalised (i.e. potentially undefined) /lesson/s.
type GeneralisedLessonRunlengthByTimeslotId timeslotId resourceIds level	= [(timeslotId, GeneralisedLessonRunlength resourceIds level)]

-- | Calls 'findGeneralisedLessonRunlengths' & derives the /coordinates/ of the start of each runlength.
findGeneralisedLessonRunlengthsByTimeslotId :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			resourceIds,
	Eq			level
 ) => TimetableForDay timeslotId resourceIds level -> GeneralisedLessonRunlengthByTimeslotId timeslotId resourceIds level
findGeneralisedLessonRunlengthsByTimeslotId timetableForDay	= init {-drop the initial value-} . scanr (
	\runlengthCode (timeslotId, _)	-> (`Temporal.Time.shift` timeslotId) . negate . ToolShed.Data.List.Runlength.getLength	{-derive the starting timeslotId-} &&& id $ runlengthCode
 ) (
	succ . snd {-max-} $ Data.Array.IArray.bounds timetableForDay,	-- The non-existent timeslotId immediately after the last for the day.
	undefined							-- The non-existent generalised lesson at the above time-slot.
 ) $ findGeneralisedLessonRunlengths timetableForDay

-- | A runlength-encoded list of /lesson/s.
type LessonRunlengths resourceIds level	= [ToolShed.Data.List.Runlength.Code (Model.Lesson.Lesson resourceIds level)]

{- |
	* Finds separated equal (according to the attribute returned by the specified accessor) /lesson/s; separated unallocated /time-slot/s don't qualify.

	* CAVEAT: discards the /coordinates/ at which each /lesson/ was booked.
-}
findSeparatedEqualLessonsBy :: (
	Data.Array.IArray.Ix	timeslotId,
	Eq			resourceIds,
	Eq			level,
	Ord			attribute
 )
	=> (Model.Lesson.Lesson resourceIds level -> attribute)	-- ^ Accessor.
	-> TimetableForDay timeslotId resourceIds level
	-> LessonRunlengths resourceIds level
findSeparatedEqualLessonsBy accessor	= filter (
	(/= 1) . ToolShed.Data.List.Runlength.getLength	-- Select non-unique sessions.
 ) . map (
	length &&& head	-- Construct a 'ToolShed.Data.List.Runlength.Code'.
 ) . Data.List.Extra.groupSortOn accessor {-separated sessions-} . Data.Maybe.mapMaybe head {-remove consecutive equal lessons, discounting undefined time-slots-} . Data.List.group {-consecutive equal generalised lessons-} . Data.Array.IArray.elems

{- |
	* Finds separated equal /lesson/s; separated unallocated /time-slot/s don't qualify.

	* CAVEAT: discards the /coordinates/ at which each /lesson/ was booked.
-}
findSeparatedEqualLessons :: (
	Data.Array.IArray.Ix	timeslotId,
	Ord			resourceIds,
	Ord			level
 ) => TimetableForDay timeslotId resourceIds level -> LessonRunlengths resourceIds level
findSeparatedEqualLessons	= findSeparatedEqualLessonsBy id

{- |
	* Finds separated /lesson/s of equal /subject/.

	* CAVEAT: discards the /coordinates/ at which each /lesson/ was booked.
-}
findSeparatedEqualSubjectLessons :: (
	Data.Array.IArray.Ix	timeslotId,
	Eq			resourceIds,
	Ord			level
 ) => TimetableForDay timeslotId resourceIds level -> LessonRunlengths resourceIds level
findSeparatedEqualSubjectLessons	= findSeparatedEqualLessonsBy Model.Lesson.getSubject

-- | A list associated by /lesson/, of lists associated by /timeslotId/.
type RunlengthsByTimeslotIdByLesson resourceIds level timeslotId	= [(Model.Lesson.Lesson resourceIds level, [(timeslotId {-start-}, Size.NTimeslots {-runlength-})])]

{- |
	* Finds runlengths of separated equal /lesson/s; separated unallocated /time-slot/s don't qualify.

	* Returns a list associated by the common /lesson/, of lists associated by starting /timeslotId/, of runlengths.
-}
findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson :: (
	Data.Array.IArray.Ix	timeslotId,
	Ord			resourceIds,
	Ord			level
 ) => TimetableForDay timeslotId resourceIds level -> RunlengthsByTimeslotIdByLesson resourceIds level timeslotId
findSeparatedEqualLessonRunlengthsByStartingTimeslotIdByLesson timetableForDay	= map (
	\l@(
		(
			_,	-- startingTimeslotId.
			(
				_,	-- Run-length.
				lesson
			) -- Pair.
		) : _
	) -> (
		lesson,
		map (
			Control.Arrow.second fst {-runlength-}	-- Drop the common lesson, which has been factored-out.
		) l
	) -- Pair.
 ) . filter (
	(/= 1) . length	-- Select non-unique sessions.
 ) $ Data.List.Extra.groupSortOn (
	snd {-lesson-} . snd {-runlength-code-}	-- Separated equals lessons.
 ) [
	(startingTimeslotId, (length l, lesson)) |
		l@((startingTimeslotId, Just lesson) : _)	<- Data.List.groupBy (
			ToolShed.Data.List.equalityBy snd {-generalised lesson-}	-- Consecutive equal lessons.
		) $ Data.Array.IArray.assocs timetableForDay
 ] -- List-comprehension.

{- |
	Measure the ratio of those free (neither reserved for a /meeting/ nor booked with a /lesson/) /time-slot/s
	which comply with the specified preference,
	to the total number of free /time-slot/s.
-}
measureFreePeriodCompliance
	:: (Data.Array.IArray.Ix timeslotId, Fractional ratio)
	=> Temporal.FreePeriodPreference.FreePeriodPreference
	-> Data.Set.Set timeslotId	-- ^ The /timeslotId/s of meetings, for the groups of which this observer is a member.
	-> TimetableForDay timeslotId resourceIds level
	-> ratio
measureFreePeriodCompliance freePeriodPreference meetingTimeslotIds timetableForDay
	| nFreePeriods `elem` [
		0,
		Data.Array.IArray.rangeSize $ Data.Array.IArray.bounds timetableForDay
	]		= 1	-- CAVEAT: debatable.
	| 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)	-- Check it's neither reserved for a meeting nor booked with a lesson.
		 ) $ 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)