Timetable.hs

{-
	Copyright (C) 2013-2015 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@]

	* Defines the personal /timetable/ for any week, for each /location/.

	* It contains identical information to 'StudentView.Timetable.Timetable',
	but the data has been re-indexed to present it in a form relevant to a /location/ rather than a /student/.
-}

module WeekDaze.LocationView.Timetable(
-- * Types
-- ** Type-synonyms
	Timetable,
--	Booking,
-- * Functions
-- ** Mutators
--	bookStudentViewLesson,
--	bookLocationViewLesson,
-- ** Translation
	fromStudentViewTimetable,
	toStudentViewTimetable,
	toXHtml
) where

import			Data.Map((!))
import qualified	Data.Array.IArray
import qualified	Data.Foldable
import qualified	Data.Map
import qualified	Data.Maybe
import qualified	Data.Set
import qualified	Text.XHtml.Strict
import qualified	WeekDaze.Aggregate.LocationCatalogue	as Aggregate.LocationCatalogue
import qualified	WeekDaze.Data.Course			as Data.Course
import qualified	WeekDaze.Data.Location			as Data.Location
import qualified	WeekDaze.LocationView.Lesson		as LocationView.Lesson
import qualified	WeekDaze.LocationView.LessonResourceIds	as LocationView.LessonResourceIds
import qualified	WeekDaze.Model.Lesson			as Model.Lesson
import qualified	WeekDaze.Model.Meeting			as Model.Meeting
import qualified	WeekDaze.Model.Timetable		as Model.Timetable
import qualified	WeekDaze.Model.TimetableForWeek		as Model.TimetableForWeek
import qualified	WeekDaze.StudentView.LessonResourceIds	as StudentView.LessonResourceIds
import qualified	WeekDaze.StudentView.Timetable		as StudentView.Timetable
import qualified	WeekDaze.Temporal.Time			as Temporal.Time
import qualified	WeekDaze.Text.CSS			as Text.CSS
import			Text.XHtml.Strict((+++), (<<))
import			WeekDaze.Text.XHTML()

-- | An association-list of the timetables for all /locations/.
type Timetable locationId timeslotId teacherId level	= Model.Timetable.Timetable locationId timeslotId (LocationView.LessonResourceIds.LessonResourceIds teacherId) level

{- |
	* Build a 'Timetable' by inverting a 'StudentView.Timetable.Timetable'.

	* CAVEAT: in the original 'StudentView.Timetable.Timetable', different /student-bodies/ may simultaneously reference a single /location/.
	This is normal behaviour, provided the /location/ has sufficient capacity,
	& is implemented seemlessly, as a /map/-structure with one or more /key/s referencing a /value/, containing the same /location/.

	* When inverting such a /timetable/, this many-to-one relationship becomes a one-to-many, & a single /location-id/ must now reference many /student-bodies/.
	The /map/-structure (cf. /multi-map/), can't directly accommodate multiple identical keys, with different values,
	so this is achieved by merging the /student-bodies/ into a class of /student/s.
-}
fromStudentViewTimetable :: (
	Data.Array.IArray.Ix	timeslotId,
	Enum			timeslotId,
	Eq			level,
	Eq			teacherId,
	Ord			locationId,
	Show			level,
	Show			locationId,
	Show			teacherId,
	Show			timeslotId
 )
	=> Bool							-- ^ Permit a temporary /student-body/ merger.
	-> Timetable locationId timeslotId teacherId level	-- ^ An unallocated /timetable/, supplied for efficiency.
	-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
	-> Timetable locationId timeslotId teacherId level
fromStudentViewTimetable permitTemporaryStudentBodyMerger	= Data.Map.foldrWithKey (
	\studentBody studentViewTimetableForWeek locationViewTimetable	-> snd {-timetable-} $ Data.Foldable.foldr (
		\studentViewTimetableForDay (day, locationViewTimetable')	-> (
			pred day,	-- Because of the use of 'foldr'.
			snd {-timetable-} $ Data.Foldable.foldr (
				\maybeStudentViewLesson (timeslotId, locationViewTimetable'')	-> (
					pred timeslotId,	-- Because of the use of 'foldr'.
					Data.Maybe.maybe locationViewTimetable'' (
						($ locationViewTimetable'') . bookStudentViewLesson permitTemporaryStudentBodyMerger {-partially apply-} . (,) (
							studentBody,
							Temporal.Time.mkTime day timeslotId
						) {-construct a booking-}
					) maybeStudentViewLesson
				)
			) (
				snd {-maximum timeslotId-} $ Data.Array.IArray.bounds studentViewTimetableForDay,
				locationViewTimetable'
			) studentViewTimetableForDay
		)
	) (
		snd {-maximum day-} $ Data.Array.IArray.bounds studentViewTimetableForWeek,
		locationViewTimetable
	) studentViewTimetableForWeek
 )

{- |
	* Build a 'StudentView.Timetable.Timetable', by inverting a 'Timetable'.

	* Each /lesson/ in the /timetable/ seen from the /location/'s perspective, contains a /student-class/.
	This /student-class/ must be broken into /student-bodies/, before inserting repeatedly into the required /timetable/ as seen from the /student-body/'s perpective.
-}
toStudentViewTimetable
	:: (Data.Array.IArray.Ix timeslotId, Enum timeslotId)
	=> StudentView.Timetable.Timetable timeslotId locationId teacherId level	-- ^ An unallocated /timetable/, supplied for efficiency.
	-> Timetable locationId timeslotId teacherId level
	-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
toStudentViewTimetable	= Data.Map.foldrWithKey (
	\locationId locationViewTimetableForWeek studentViewTimetable	-> snd {-timetable-} $ Data.Foldable.foldr (
		\locationViewTimetableForDay (day, studentViewTimetable')	-> (
			pred day,	-- Because of the use of 'foldr'.
			snd {-timetable-} $ Data.Foldable.foldr (
				\maybeLocationViewLesson (timeslotId, studentViewTimetable'')	-> (
					pred timeslotId,	-- Because of the use of 'foldr'.
					Data.Maybe.maybe studentViewTimetable'' (
						($ studentViewTimetable'') . bookLocationViewLesson {-partially apply-} . (,) (
							locationId,
							Temporal.Time.mkTime day timeslotId
						) {-construct a booking-}
					) maybeLocationViewLesson
				)
			) (
				snd {-maximum timeslotId-} $ Data.Array.IArray.bounds locationViewTimetableForDay,
				studentViewTimetable'
			) locationViewTimetableForDay
		)
	) (
		snd {-maximum day-} $ Data.Array.IArray.bounds locationViewTimetableForWeek,
		studentViewTimetable
	) locationViewTimetableForWeek
 )

-- | Make a 'StudentView.Timetable.Booking' in a /LocationView-timetable/.
bookStudentViewLesson :: (
	Data.Array.IArray.Ix	timeslotId,
	Eq			level,
	Eq			teacherId,
	Ord			locationId,
	Show			level,
	Show			locationId,
	Show			teacherId,
	Show			timeslotId
 )
	=> Bool									-- ^ Permit a temporary /student-body/ merger.
	-> StudentView.Timetable.Booking timeslotId locationId teacherId level	-- ^ The /coordinates/ & /lesson/ from the perspective of the /student/-view of the /timetable/.
	-> Timetable locationId timeslotId teacherId level			-- ^ The /timetable/ as seen from the /location/'s perspective.
	-> Timetable locationId timeslotId teacherId level
bookStudentViewLesson permitTemporaryStudentBodyMerger ((studentBody, time), studentViewLesson) locationViewTimetable	= Model.Timetable.defineTimeslot (
	locationViewTimetableCoordinates,
	Just studentViewLesson {
		Model.Lesson.getResourceIds	= LocationView.LessonResourceIds.mkLessonResourceIds (
			Data.Set.insert studentBody $ case Model.Timetable.getMaybeLesson locationViewTimetableCoordinates locationViewTimetable of
				Nothing	-> Data.Set.empty	-- Start a new student-class.
				Just locationViewLesson
					| and [
						permitTemporaryStudentBodyMerger,
						LocationView.LessonResourceIds.getTeacherId locationViewResourceIds == teacherId,
						Model.Lesson.getSubject locationViewLesson == Model.Lesson.getSubject studentViewLesson
					]		-> LocationView.LessonResourceIds.getStudentClass locationViewResourceIds
					| otherwise	-> error $ "WeekDaze.LocationView.Timetable.bookStudentViewLesson:\tlesson at coordinates=" ++ show locationViewTimetableCoordinates ++ " has already been booked in either a different subject or location; " ++ show (locationViewLesson, studentViewLesson) ++ "."
					where
						locationViewResourceIds	= Model.Lesson.getResourceIds locationViewLesson
		 ) teacherId
	} -- Mutate.
 ) locationViewTimetable where
	studentViewResourceIds			= Model.Lesson.getResourceIds studentViewLesson
	teacherId				= StudentView.LessonResourceIds.getTeacherId studentViewResourceIds
	locationViewTimetableCoordinates	= (StudentView.LessonResourceIds.getLocationId studentViewResourceIds, time)

-- | A /lesson/ qualified by the /coordinates/ at which it is booked.
type Booking locationId timeslotId teacherId level	= Model.Timetable.Booking locationId timeslotId (LocationView.LessonResourceIds.LessonResourceIds teacherId) level

-- | Books a /LocationView-lesson/ in a /StudentView-timetable/.
bookLocationViewLesson
	:: Data.Array.IArray.Ix timeslotId
	=> Booking locationId timeslotId teacherId level				-- ^ The /coordinates/ & /lesson/ from the perspective of the /location/-view of the /timetable/.
	-> StudentView.Timetable.Timetable timeslotId locationId teacherId level	-- ^ The /timetable/ as seen from the /student/'s perspective.
	-> StudentView.Timetable.Timetable timeslotId locationId teacherId level
bookLocationViewLesson ((locationId, time), locationViewLesson) studentViewTimetable	= Data.Set.foldr (
	Model.Timetable.defineTimeslot . flip (,) (
		Just $ LocationView.Lesson.toStudentView locationId locationViewLesson
	) . flip (,) time
 ) studentViewTimetable $ LocationView.LessonResourceIds.getStudentClass locationViewResourceIds where
	locationViewResourceIds	= Model.Lesson.getResourceIds locationViewLesson

-- | Render in /XHTML/, as a /definition-list/.
toXHtml :: (
	Data.Array.IArray.Ix	timeslotId,
	Fractional		minimumContrastRatio,
	Ord			level,
	Ord			locationId,
	Ord			minimumContrastRatio,
	Ord			teacherId,
	Show			level,
	Show			teacherId,
	Text.XHtml.Strict.HTML	campus,
	Text.XHtml.Strict.HTML	level,
	Text.XHtml.Strict.HTML	locationId,
	Text.XHtml.Strict.HTML	synchronisationId,
	Text.XHtml.Strict.HTML	teacherId,
	Text.XHtml.Strict.HTML	timeslotId
 )
	=> (locationId -> LocationView.Lesson.Lesson teacherId level -> Data.Course.Course synchronisationId level timeslotId)	-- ^ Find the /course/ to which the specified /lesson/ belongs.
	-> Aggregate.LocationCatalogue.LocationCatalogue locationId campus
	-> Model.Timetable.GenericTimetableToMarkup locationId minimumContrastRatio teacherId timeslotId (Timetable locationId timeslotId teacherId level)
toXHtml findCourseForLocationViewLesson locationCatalogue displaySupplementaryInformation meetingsByTime htmlMergeDuplicateTimeslots displayAxisLabels weekend maybeGenerateLessonColourFrom	= Text.XHtml.Strict.defList . map (
	\(locationId, timetableForWeek)	-> let
		locationProfile			= locationCatalogue ! locationId
		nUnallocatedAvailableTimeslots	= Model.TimetableForWeek.countUnallocatedAvailableTimeslots locationProfile timetableForWeek
	in (
		Text.XHtml.Strict.unordList (
			(
				Data.Location.getCampus locationProfile +++ ' ' +++ locationId
			) : if displaySupplementaryInformation
				then Data.Maybe.catMaybes [
					Just $ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
						Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
						Text.XHtml.Strict.title "The total capacity to accommodate students at this location."
					] << (
						"Capacity" +++ Text.XHtml.Strict.spaceHtml +++ '=' +++ Text.XHtml.Strict.spaceHtml +++ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
							Text.XHtml.Strict.theclass Text.CSS.numericDataCSSIdentifier
						] << Data.Location.getCapacity (locationCatalogue ! locationId)
					),
					if nUnallocatedAvailableTimeslots == 0
						then Nothing
						else Just $ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
							Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
							Text.XHtml.Strict.title "Available but unallocated time-slots, at this location."
						] << (
							"Unallocated time-slots" +++ Text.XHtml.Strict.spaceHtml +++ '=' +++ Text.XHtml.Strict.spaceHtml +++ Text.XHtml.Strict.thespan Text.XHtml.Strict.! [
								Text.XHtml.Strict.theclass Text.CSS.numericDataCSSIdentifier
							] << nUnallocatedAvailableTimeslots
						),
					let
						facilityNames	= Data.Location.getFacilityNames locationProfile
					in if Data.Set.null facilityNames
						then Nothing
						else Just $ Text.XHtml.Strict.unordList (map show $ Data.Set.toList facilityNames) Text.XHtml.Strict.! [
							Text.XHtml.Strict.theclass Text.CSS.infoCSSIdentifier,
							Text.XHtml.Strict.title "Facilities available at this location."
						]
				]
				else []
		) Text.XHtml.Strict.! [Text.XHtml.Strict.theclass Text.CSS.observerSummaryCSSIdentifier],	-- CAVEAT: xhtml only permits inline elements to be nested inside a 'dt' element, & 'ul' is a block element.
		Model.TimetableForWeek.toXHtml (
			findCourseForLocationViewLesson locationId	-- Partially apply.
		) locationProfile (
			Model.Meeting.deleteLocationId locationId meetingsByTime
		) htmlMergeDuplicateTimeslots displayAxisLabels weekend maybeGenerateLessonColourFrom timetableForWeek
	)
 ) . Data.Map.toList