{-# LANGUAGE CPP, FlexibleContexts #-}
module WeekDaze.ProblemConfiguration.ProblemParameters(
ProblemParameters(..),
timeslotIdBoundsTag,
calculateNTimeslotsPerDay,
extractDistinctGroupMembership,
findExcessTotalWorkloadByStudentBody,
findHumanResourceIdsByGroupId,
findSynchronousMeetingsByTimeByStudentBodyMnemonic,
findSynchronousMeetingsByTimeByTeacherId,
reduceStudentBodyRegister,
removeRedundantCourses,
removePointlessGroups,
removeUnsubscribedGroups,
mergeConstraintsOnSynchronisedCourses,
disableAnyValidationInappropriateForTemporaryStudentBodyMerger,
hasAnyFreePeriodPreference,
hasVariousMinimumConsecutiveLessons
) where
import Control.Arrow((&&&), (***))
import Data.Map((!))
import Data.Set((\\))
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Monad.Writer
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Ord
import qualified Data.Set
import qualified Factory.Data.Interval
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.Data.Foldable
import qualified ToolShed.Data.List
import qualified ToolShed.Data.Pair
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Aggregate.GroupCatalogue as Aggregate.GroupCatalogue
import qualified WeekDaze.Aggregate.LocationCatalogue as Aggregate.LocationCatalogue
import qualified WeekDaze.Aggregate.StudentBody as Aggregate.StudentBody
import qualified WeekDaze.Aggregate.StudentBodyRegister as Aggregate.StudentBodyRegister
import qualified WeekDaze.Aggregate.StudentClass as Aggregate.StudentClass
import qualified WeekDaze.Aggregate.TeacherRegister as Aggregate.TeacherRegister
import qualified WeekDaze.Configuration as Configuration
import qualified WeekDaze.Data.Course as Data.Course
import qualified WeekDaze.Data.Group as Data.Group
import qualified WeekDaze.Data.HumanResource as Data.HumanResource
import qualified WeekDaze.Data.Location as Data.Location
import qualified WeekDaze.Data.Requirements as Data.Requirements
import qualified WeekDaze.Data.Resource as Data.Resource
import qualified WeekDaze.Data.Student as Data.Student
import qualified WeekDaze.Data.Subject as Data.Subject
import qualified WeekDaze.Data.Teacher as Data.Teacher
import qualified WeekDaze.ProblemConfiguration.ProblemValidationSwitches as ProblemConfiguration.ProblemValidationSwitches
import qualified WeekDaze.ProblemConfiguration.TimetableValidationSwitches as ProblemConfiguration.TimetableValidationSwitches
import qualified WeekDaze.ProblemConfiguration.ValidationSwitch as ProblemConfiguration.ValidationSwitch
import qualified WeekDaze.Size as Size
import qualified WeekDaze.Temporal.Availability as Temporal.Availability
import qualified WeekDaze.Temporal.Day as Temporal.Day
import qualified WeekDaze.Temporal.FreePeriodPreference as Temporal.FreePeriodPreference
import qualified WeekDaze.Temporal.Time as Temporal.Time
import qualified WeekDaze.Temporal.TimeslotRequest as Temporal.TimeslotRequest
import qualified WeekDaze.Temporal.Workload as Temporal.Workload
import WeekDaze.Temporal.Workload((<+>))
#ifdef USE_HDBC
#ifdef QUERY_DB_CONCURRENTLY
import qualified Control.Concurrent
#endif
import qualified Control.Monad
import qualified Database.HDBC
import qualified Data.Convertible
import qualified Data.Typeable
import qualified WeekDaze.Database.Selector as Database.Selector
instance (
#ifdef QUERY_DB_CONCURRENTLY
Control.DeepSeq.NFData campus,
Control.DeepSeq.NFData level,
Control.DeepSeq.NFData locationId,
Control.DeepSeq.NFData stream,
Control.DeepSeq.NFData synchronisationId,
Control.DeepSeq.NFData teacherId,
Control.DeepSeq.NFData teachingRatio,
Control.DeepSeq.NFData timeslotId,
#endif
Data.Convertible.Convertible Database.HDBC.SqlValue campus,
Data.Convertible.Convertible Database.HDBC.SqlValue level,
Data.Convertible.Convertible Database.HDBC.SqlValue locationId,
Data.Convertible.Convertible Database.HDBC.SqlValue stream,
Data.Convertible.Convertible Database.HDBC.SqlValue synchronisationId,
Data.Convertible.Convertible Database.HDBC.SqlValue teacherId,
Data.Convertible.Convertible Database.HDBC.SqlValue teachingRatio,
Data.Convertible.Convertible Database.HDBC.SqlValue timeslotId,
Data.Default.Default campus,
Data.Default.Default stream,
Data.Typeable.Typeable teachingRatio,
Ord level,
Ord locationId,
Ord synchronisationId,
Ord teacherId,
Ord timeslotId,
RealFrac teachingRatio,
Show campus,
Show level,
Show locationId,
Show synchronisationId,
Show timeslotId
) => Database.Selector.Selector (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId) where
fromDatabase connection projectIdSql = let
timeslotIdBoundsTableName :: Database.Selector.TableName
timeslotIdBoundsTableName = Database.Selector.tablePrefix ++ timeslotIdBoundsTag
in do
(problemValidationSwitches, timetableValidationSwitches)
#ifdef QUERY_DB_CONCURRENTLY
<- Database.Selector.fromDatabaseConcurrently connection projectIdSql
#else
<- Database.Selector.fromDatabase connection projectIdSql
#endif
timeslotIdBoundsRows <- map (
map $ Data.Maybe.fromMaybe (
error $ "WeekDaze.ProblemConfiguration.ProblemParameters.fromDatabase:\tnull " ++ show minTag ++ " or " ++ show maxTag ++ "."
) . either (
error . showString "WeekDaze.ProblemConfiguration.ProblemParameters.fromDatabase:\tfailed to parse the value for a timeslotId read from the database; " . show
) id . Database.HDBC.safeFromSql
) `fmap` Database.Selector.select connection [minTag, maxTag] [timeslotIdBoundsTableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
#ifdef QUERY_DB_CONCURRENTLY
l <- Control.Concurrent.newEmptyMVar
t <- Control.Concurrent.newEmptyMVar
s <- Control.Concurrent.newEmptyMVar
g <- Control.Concurrent.newEmptyMVar
Database.Selector.queryConcurrently Aggregate.LocationCatalogue.fromDatabase connection projectIdSql l
Database.Selector.queryConcurrently Aggregate.TeacherRegister.fromDatabase connection projectIdSql t
Database.Selector.queryConcurrently Aggregate.StudentBodyRegister.fromDatabase connection projectIdSql s
Database.Selector.queryConcurrently Aggregate.GroupCatalogue.fromDatabase connection projectIdSql g
locationCatalogue <- Control.Concurrent.takeMVar l
teacherRegister <- Control.Concurrent.takeMVar t
studentBodyRegister <- Control.Concurrent.takeMVar s
groupCatalogue <- Control.Concurrent.takeMVar g
#else
locationCatalogue <- Aggregate.LocationCatalogue.fromDatabase connection projectIdSql
teacherRegister <- Aggregate.TeacherRegister.fromDatabase connection projectIdSql
studentBodyRegister <- Aggregate.StudentBodyRegister.fromDatabase connection projectIdSql
groupCatalogue <- Aggregate.GroupCatalogue.fromDatabase connection projectIdSql
#endif
Control.Monad.when (null timeslotIdBoundsRows) . error . showString "WeekDaze.ProblemConfiguration.ProblemParameters.fromDatabase:\tzero rows were selected from table " . shows timeslotIdBoundsTableName . showString " where " . showString Database.Selector.projectIdColumnName . showChar '=' $ Database.HDBC.fromSql projectIdSql
let timeslotIdBoundsRow = head timeslotIdBoundsRows
case timeslotIdBoundsRow of
[minTimeslotId, maxTimeslotId] -> return MkProblemParameters {
getProblemValidationSwitches = problemValidationSwitches,
getTimetableValidationSwitches = timetableValidationSwitches,
getTimeslotIdBounds = (minTimeslotId, maxTimeslotId),
getLocationCatalogue = locationCatalogue,
getTeacherRegister = teacherRegister,
getStudentBodyRegister = studentBodyRegister,
getGroupCatalogue = groupCatalogue
}
_ -> error . showString "WeekDaze.ProblemConfiguration.ProblemParameters.fromDatabase:\tunexpected number of columns=" . shows (length timeslotIdBoundsRow) . showString " in row of table " $ shows timeslotIdBoundsTableName "."
#endif /* USE_HDBC */
tag :: String
tag = "problemParameters"
timeslotIdBoundsTag :: String
timeslotIdBoundsTag = "timeslotIdBounds"
groupTag :: String
groupTag = "group"
locationTag :: String
locationTag = "location"
studentBodyToProfileAssociationTag :: String
studentBodyToProfileAssociationTag = "studentBodyToProfileAssociation"
teacherTag :: String
teacherTag = "teacher"
minTag :: String
minTag = "min"
maxTag :: String
maxTag = "max"
defaultGroupCatalogue :: Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
defaultGroupCatalogue = Data.Map.empty
data ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId = MkProblemParameters {
getProblemValidationSwitches :: ProblemConfiguration.ProblemValidationSwitches.ProblemValidationSwitches,
getTimetableValidationSwitches :: ProblemConfiguration.TimetableValidationSwitches.TimetableValidationSwitches,
getTimeslotIdBounds :: Factory.Data.Interval.Interval timeslotId,
getLocationCatalogue :: Aggregate.LocationCatalogue.LocationCatalogue locationId campus,
getTeacherRegister :: Aggregate.TeacherRegister.TeacherRegister teacherId synchronisationId level timeslotId locationId teachingRatio,
getStudentBodyRegister :: Aggregate.StudentBodyRegister.StudentBodyRegister level stream teachingRatio,
getGroupCatalogue :: Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
} deriving (Eq, Show)
instance (
Data.Default.Default campus,
Data.Default.Default stream,
Eq campus,
Eq stream,
HXT.XmlPickler campus,
HXT.XmlPickler level,
HXT.XmlPickler locationId,
HXT.XmlPickler stream,
HXT.XmlPickler synchronisationId,
HXT.XmlPickler teacherId,
HXT.XmlPickler teachingRatio,
HXT.XmlPickler timeslotId,
Ord level,
Ord locationId,
Ord synchronisationId,
Ord teacherId,
Ord timeslotId,
Real teachingRatio,
Show campus,
Show level,
Show synchronisationId,
Show timeslotId
) => HXT.XmlPickler (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId) where
xpickle = HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d, e, f, g) -> MkProblemParameters a b c d e f g,
\MkProblemParameters {
getProblemValidationSwitches = problemValidationSwitches,
getTimetableValidationSwitches = timetableValidationSwitches,
getTimeslotIdBounds = timeslotIdBounds,
getLocationCatalogue = locationCatalogue,
getTeacherRegister = teacherRegister,
getStudentBodyRegister = studentBodyRegister,
getGroupCatalogue = groupCatalogue
} -> (
problemValidationSwitches,
timetableValidationSwitches,
timeslotIdBounds,
locationCatalogue,
teacherRegister,
studentBodyRegister,
groupCatalogue
)
) $ HXT.xp7Tuple (
HXT.xpDefault Data.Default.def HXT.xpickle
) (
HXT.xpDefault Data.Default.def HXT.xpickle
) (
HXT.xpElem timeslotIdBoundsTag $ HXT.xpElem minTag HXT.xpickle `HXT.xpPair` HXT.xpElem maxTag HXT.xpickle
) (
HXT.xpElem Aggregate.LocationCatalogue.tag . HXT.xpWrap (
Data.Map.fromList,
Data.Map.toList
) . HXT.xpList1 $ HXT.xpElem locationTag HXT.xpickle
) (
HXT.xpElem Aggregate.TeacherRegister.tag . HXT.xpWrap (
Data.Map.fromList,
Data.Map.toList
) . HXT.xpList1 $ HXT.xpElem teacherTag HXT.xpickle
) (
HXT.xpElem Aggregate.StudentBodyRegister.tag . HXT.xpWrap (
Data.Map.fromList,
Data.Map.toList
) . HXT.xpList1 $ HXT.xpElem studentBodyToProfileAssociationTag HXT.xpickle
) (
HXT.xpDefault defaultGroupCatalogue . HXT.xpElem Aggregate.GroupCatalogue.tag $ HXT.xpMap groupTag Data.Group.groupIdTag HXT.xpText HXT.xpickle
)
instance (
Control.DeepSeq.NFData campus,
Control.DeepSeq.NFData level,
Control.DeepSeq.NFData locationId,
Control.DeepSeq.NFData stream,
Control.DeepSeq.NFData synchronisationId,
Control.DeepSeq.NFData teacherId,
Control.DeepSeq.NFData teachingRatio,
Control.DeepSeq.NFData timeslotId
) => Control.DeepSeq.NFData (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId) where
rnf (MkProblemParameters x0 x1 x2 x3 x4 x5 x6) = Control.DeepSeq.rnf (x0, x1, x2, x3, x4, x5, x6)
calculateNTimeslotsPerDay :: Enum timeslotId => Factory.Data.Interval.Interval timeslotId -> Size.NTimeslots
calculateNTimeslotsPerDay = succ . uncurry (flip (-)) . (fromEnum *** fromEnum)
calculateStudentWorkloadBounds :: (
Ord level,
Ord synchronisationId,
Ord timeslotId
)
=> Aggregate.TeacherRegister.TeacherRegister teacherId synchronisationId level timeslotId locationId teachingRatio
-> Data.Student.Profile level stream teachingRatio
-> Data.Requirements.Requirements Temporal.Workload.Bounds
calculateStudentWorkloadBounds teacherRegister = ToolShed.Data.Pair.mirror (
Data.Foldable.foldr (
\subject -> ((Aggregate.TeacherRegister.calculateWorkloadBoundsBySubject teacherRegister ! subject) <+>)
) Temporal.Workload.unloaded
) . Data.Student.getKnowledgeRequirements
findExcessTotalWorkloadByStudentBody :: (
Enum timeslotId,
Ord level,
Ord synchronisationId,
Ord timeslotId,
RealFrac teachingRatio
) => ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId -> Data.Map.Map Aggregate.StudentBody.StudentBody Size.NTimeslots
findExcessTotalWorkloadByStudentBody problemParameters = Data.Map.filter (> 0) $ Data.Map.map (
uncurry (-) . (
(
Temporal.Workload.getMinimum . uncurry (<+>)
) . calculateStudentWorkloadBounds (
getTeacherRegister problemParameters
) &&& Data.HumanResource.getNTimeslotsPerWeekOfTeaching (
calculateNTimeslotsPerDay $ getTimeslotIdBounds problemParameters
)
)
) $ getStudentBodyRegister problemParameters
extractDistinctGroupMembership :: RealFrac teachingRatio => ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId -> Data.Group.Membership
extractDistinctGroupMembership = uncurry Data.Set.union . (Data.HumanResource.extractDistinctGroupMembership . getStudentBodyRegister &&& Data.HumanResource.extractDistinctGroupMembership . getTeacherRegister)
findSynchronousSeparateMandatoryMeetingsByTimeByHumanResourceId :: (
Data.HumanResource.HumanResource humanResource,
Ord locationId,
Ord timeslotId
)
=> Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
-> Data.Resource.ResourceMap humanResourceId humanResource
-> Data.Map.Map humanResourceId (Data.Map.Map (Temporal.Time.Time timeslotId) [(Data.Group.Id, locationId)])
findSynchronousSeparateMandatoryMeetingsByTimeByHumanResourceId groupCatalogue = Data.Map.filter (
not . Data.Map.null
) . Data.Map.map (
Data.Map.filter (
(> 1) . length . Data.List.Extra.groupSortOn snd
) . Data.Map.map (
Data.Map.toList . Data.Map.map (
Data.Maybe.fromJust . fst
) . Data.Map.filter (
uncurry (&&) . Control.Arrow.first Data.Maybe.isJust
) . Data.Map.map (
Data.Group.getMaybeLocationId &&& Data.Group.getMandatesAttendance
) . Data.Map.fromList
) . Data.Foldable.foldr (
\groupId m -> let
groupProfile = groupCatalogue ! groupId
in Data.Foldable.foldr (
Data.Map.insertWith (++) `flip` [(groupId, groupProfile)]
) m $ Data.Group.getMeetingTimes groupProfile
) Data.Map.empty . Data.HumanResource.getGroupMembership
)
findSynchronousMeetingsByTimeByHumanResourceId :: (
Data.HumanResource.HumanResource humanResource,
Ord timeslotId
)
=> Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
-> Data.Resource.ResourceMap humanResourceId humanResource
-> Data.Map.Map humanResourceId (Data.Map.Map (Temporal.Time.Time timeslotId) [Data.Group.Id])
findSynchronousMeetingsByTimeByHumanResourceId groupCatalogue = Data.Map.filter (
not . Data.Map.null
) . Data.Map.map (
Data.Map.filter (
(> 1) . length
) . Data.Foldable.foldr (
\groupId m -> Data.Foldable.foldr (
Data.Map.insertWith (++) `flip` [groupId]
) m . Data.Group.getMeetingTimes $ groupCatalogue ! groupId
) Data.Map.empty . Data.HumanResource.getGroupMembership
)
findSynchronousMeetingsByTimeByStudentBodyMnemonic :: (
Ord timeslotId,
RealFrac teachingRatio
)
=> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Data.Map.Map Aggregate.StudentBody.StudentBody (Data.Map.Map (Temporal.Time.Time timeslotId) [Data.Group.Id])
findSynchronousMeetingsByTimeByStudentBodyMnemonic = uncurry findSynchronousMeetingsByTimeByHumanResourceId . (getGroupCatalogue &&& getStudentBodyRegister)
findSynchronousMeetingsByTimeByTeacherId :: (
Ord timeslotId,
RealFrac teachingRatio
)
=> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Data.Map.Map teacherId (Data.Map.Map (Temporal.Time.Time timeslotId) [Data.Group.Id])
findSynchronousMeetingsByTimeByTeacherId = uncurry findSynchronousMeetingsByTimeByHumanResourceId . (getGroupCatalogue &&& getTeacherRegister)
findHumanResourcesOverloadedWithMeetings :: (
Data.Resource.Resource humanResource,
Data.HumanResource.HumanResource humanResource
)
=> Size.NTimeslots
-> Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
-> Data.Resource.ResourceMap humanResourceId humanResource
-> Data.Map.Map humanResourceId (Size.NTimeslots, Size.NTimeslots)
findHumanResourcesOverloadedWithMeetings nTimeslotsPerDay groupCatalogue = Data.Map.filter (
uncurry (>)
) . Data.Map.map (
countNTimeslotsPerWeekForMeetings groupCatalogue &&& Data.HumanResource.getNTimeslotsPerWeekOfNonTeaching nTimeslotsPerDay
)
findUnavailableDaysByGroupIdByHumanResourceId :: (
#if !MIN_VERSION_containers(0,5,2)
Ord timeslotId,
#endif
Data.Resource.Resource humanResource,
Data.HumanResource.HumanResource humanResource
)
=> Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
-> Data.Resource.ResourceMap humanResourceId humanResource
-> Data.Map.Map humanResourceId (Data.Map.Map Data.Group.Id (Data.Set.Set Temporal.Day.Day))
findUnavailableDaysByGroupIdByHumanResourceId groupCatalogue = Data.Map.filter (
not . Data.Map.null
) . Data.Map.map (
\humanResource -> Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
not . (`Data.Resource.isAvailableOn` humanResource)
) . Data.Set.map Temporal.Time.getDay . Data.Group.getMeetingTimes
) . Data.Map.filter Data.Group.getMandatesAttendance . Data.Map.fromList . map (
id &&& (groupCatalogue !)
) . Data.Set.toList $ Data.HumanResource.getGroupMembership humanResource
)
findHumanResourceIdsByGroupId :: (Ord teacherId, RealFrac teachingRatio)
=> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> (Aggregate.GroupCatalogue.ResourceIdsByGroupId Aggregate.StudentBody.StudentBody, Aggregate.GroupCatalogue.ResourceIdsByGroupId teacherId)
findHumanResourceIdsByGroupId = findHumanResourceIdsByGroupId' . getStudentBodyRegister &&& findHumanResourceIdsByGroupId' . getTeacherRegister where
findHumanResourceIdsByGroupId' :: (Data.HumanResource.HumanResource humanResource, Ord humanResourceId) => Data.Resource.ResourceMap humanResourceId humanResource -> Aggregate.GroupCatalogue.ResourceIdsByGroupId humanResourceId
findHumanResourceIdsByGroupId' = Data.Map.foldrWithKey (
\humanResourceId humanResource m -> Data.Foldable.foldr (
($ Data.Set.singleton humanResourceId) . Data.Map.insertWith Data.Set.union
) m $ Data.HumanResource.getGroupMembership humanResource
) Data.Map.empty
countNTimeslotsPerWeekForMeetings :: (
Data.Resource.Resource humanResource,
Data.HumanResource.HumanResource humanResource
)
=> Aggregate.GroupCatalogue.GroupCatalogue timeslotId locationId
-> humanResource
-> Size.NTimeslots
countNTimeslotsPerWeekForMeetings groupCatalogue humanResource = Data.Foldable.foldr (
(+) . Data.Set.size . Data.Set.filter (
(`Data.Resource.isAvailableOn` humanResource) . Temporal.Time.getDay
) . Data.Group.getMeetingTimes . (
groupCatalogue !
)
) 0 $ Data.HumanResource.getGroupMembership humanResource
instance (
Enum timeslotId,
Ord level,
Ord locationId,
Ord stream,
Ord synchronisationId,
Ord teacherId,
Ord timeslotId,
RealFrac teachingRatio,
Show level,
Show locationId,
Show stream,
Show synchronisationId,
Show teacherId,
Show teachingRatio,
Show timeslotId
) => ToolShed.SelfValidate.SelfValidator (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId) where
getErrors problemParameters@MkProblemParameters {
getProblemValidationSwitches = problemValidationSwitches,
getTimeslotIdBounds = timeslotIdBounds,
getLocationCatalogue = locationCatalogue,
getGroupCatalogue = groupCatalogue,
getTeacherRegister = teacherRegister,
getStudentBodyRegister = studentBodyRegister
} = ToolShed.SelfValidate.extractErrors [
(
ProblemConfiguration.ProblemValidationSwitches.getCheckTimeslotIdBounds problemValidationSwitches && nTimeslotsPerDay < 1,
show timeslotIdBoundsTag ++ " are too narrow; " ++ show timeslotIdBounds
),
(
ProblemConfiguration.ProblemValidationSwitches.getCheckNullLocationCatalogue problemValidationSwitches && Data.Map.null locationCatalogue,
show ProblemConfiguration.ProblemValidationSwitches.checkNullLocationCatalogueTag ++ ": zero locations have been defined"
), (
ProblemConfiguration.ProblemValidationSwitches.getCheckNullTeacherRegister problemValidationSwitches && Data.Map.null teacherRegister,
show ProblemConfiguration.ProblemValidationSwitches.checkNullTeacherRegisterTag ++ ": zero teachers have been defined"
), (
ProblemConfiguration.ProblemValidationSwitches.getCheckNullStudentBodyRegister problemValidationSwitches && Data.Map.null studentBodyRegister,
show ProblemConfiguration.ProblemValidationSwitches.checkNullStudentBodyRegisterTag ++ ": zero student-bodies have been defined"
), (
ProblemConfiguration.ProblemValidationSwitches.getCheckNullGroupId problemValidationSwitches && Data.Map.member "" groupCatalogue,
show ProblemConfiguration.ProblemValidationSwitches.checkNullGroupIdTag ++ ": null identifier in " ++ show Aggregate.GroupCatalogue.tag
),
let
isValid = (`Factory.Data.Interval.elem'` timeslotIdBounds)
coursesWithIllDefinedTimeslotRequests = Data.Set.filter (
\course -> case Data.Course.getTimeslotRequest course of
Temporal.TimeslotRequest.Ideally idealTimeslotId -> not $ isValid idealTimeslotId
Temporal.TimeslotRequest.Specifically specifiedTimes -> Data.Foldable.any (not . isValid . Temporal.Time.getTimeslotId) specifiedTimes
) $ Aggregate.TeacherRegister.extractDistinctCourses teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckTimeslotRequests problemValidationSwitches && not (Data.Set.null coursesWithIllDefinedTimeslotRequests),
show ProblemConfiguration.ProblemValidationSwitches.checkTimeslotRequestsTag ++ ": the timeslot-request for a course, specifies times outside permissible bounds " ++ show timeslotIdBounds ++ "; " ++ show (Data.Set.toList coursesWithIllDefinedTimeslotRequests)
),
let
coursesWithExcessiveMinimumConsecutiveDays = Data.Set.filter (
(> nTimeslotsPerDay) . Data.Course.getMinimumConsecutiveLessons
) $ Aggregate.TeacherRegister.extractDistinctCourses teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckMinimumConsecutiveLessons problemValidationSwitches && not (Data.Set.null coursesWithExcessiveMinimumConsecutiveDays),
show ProblemConfiguration.ProblemValidationSwitches.checkMinimumConsecutiveLessonsTag ++ ": the minimum consecutive lessons for a course, can't exceed the number of time-slots per day " ++ show nTimeslotsPerDay ++ "; " ++ show (Data.Set.toList coursesWithExcessiveMinimumConsecutiveDays)
),
let
excessiveLessonsPerWeekByTeacherId = Data.Map.filter (
not . null
) $ Data.Map.map (
\teacherProfile -> filter (
> Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay teacherProfile
) . map Data.Course.getRequiredLessonsPerWeek . Data.Set.toList $ Data.Teacher.getService teacherProfile
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckRequiredLessonsPerWeek problemValidationSwitches && not (Data.Map.null excessiveLessonsPerWeekByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkRequiredLessonsPerWeekTag ++ ": some teachers offer courses which individually require more lessons per week than they teach; " ++ show (Data.Map.toList excessiveLessonsPerWeekByTeacherId)
),
let
teachersOfferingMultipleCoursesPerSynchronisationId = Data.Map.filter (not . null) $ Data.Map.map (
map head . filter (
(/= 1) . length
) . ToolShed.Data.Foldable.gather . Data.Maybe.mapMaybe Data.Course.getMaybeSynchronisationId . Data.Set.toList . Data.Teacher.getService
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForMultipleCoursesPerTeacherPerSynchronisationId problemValidationSwitches && not (Data.Map.null teachersOfferingMultipleCoursesPerSynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForMultipleCoursesPerTeacherPerSynchronisationIdTag ++ ": some teachers offer multiple courses with the same synchronisationId; " ++ show (Data.Map.toList teachersOfferingMultipleCoursesPerSynchronisationId)
),
let
singletonTeachersBySynchronisationId = Data.Map.map head . Data.Map.filter ((== 1) . length) $ Data.Map.map Data.Map.keys coursesByTeacherIdBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSingletonSynchronisedCourses problemValidationSwitches && not (Data.Map.null singletonTeachersBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSingletonSynchronisedCoursesTag ++ ": some synchronisationIds, are only referenced by the relevant courses of a single teacher; " ++ show (Data.Map.toList singletonTeachersBySynchronisationId)
),
let
differentLessonsPerWeekByTeacherIdBySynchronisationId = Data.Map.filter (
(> 1) . Data.Set.size . Data.Set.fromList . Data.Map.elems
) $ Data.Map.map (
Data.Map.map Data.Course.getRequiredLessonsPerWeek
) coursesByTeacherIdBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithDifferentLessonsPerWeek problemValidationSwitches && not (Data.Map.null differentLessonsPerWeekByTeacherIdBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithDifferentLessonsPerWeekTag ++ ": some synchronised courses, require different numbers of lessons per week; " ++ show (Data.Map.toList $ Data.Map.map Data.Map.toList differentLessonsPerWeekByTeacherIdBySynchronisationId)
),
let
differentIdealTimeslotIdsBySynchronisationId = Data.Map.filter (
(> 1) . Data.Set.size
) $ Data.Map.map (
Data.Set.map Data.Maybe.fromJust . Data.Set.filter Data.Maybe.isJust . Data.Set.map (
Temporal.TimeslotRequest.getMaybeIdealTimeslotId . Data.Course.getTimeslotRequest
)
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithDifferentIdealTimeslots problemValidationSwitches && not (Data.Map.null differentIdealTimeslotIdsBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithDifferentIdealTimeslotsTag ++ ": the members of some sets of synchronised courses, have different ideal timeslot-identifiers; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList differentIdealTimeslotIdsBySynchronisationId)
),
let
excessSpecifiedTimesBySynchronisationId = Data.Map.filter (
uncurry (<)
) $ Data.Map.map (
(
minimum *** Data.Set.size . Data.Set.unions
) . unzip . Data.Set.toList . Data.Set.map (
Data.Course.getRequiredLessonsPerWeek &&& Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
)
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithExcessSpecifiedTimes problemValidationSwitches && not (Data.Map.null excessSpecifiedTimesBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithExcessSpecifiedTimesTag ++ ": some synchronised courses require fewer lessons per week, than they have specified booking-times; " ++ show (Data.Map.toList excessSpecifiedTimesBySynchronisationId)
),
let
availableVsRequiredLessonsBySynchronisationId = Data.Map.filter (
uncurry (<)
) . Data.Map.map (
Control.Arrow.first $ (* nTimeslotsPerDay) . Temporal.Availability.countDaysPerWeekAvailable
) . Data.Map.unionWith (
\(availability, requiredLessons) -> Temporal.Availability.findIntersection availability *** max requiredLessons
) (
Data.Map.mapWithKey (
\synchronisationId -> (,) (
Data.Resource.getAvailability $ Data.Map.filter (
Data.Student.requiresAnySubjectBy (
`Data.Set.member` Data.Set.map Data.Course.getSubject (
distinctCoursesBySynchronisationId ! synchronisationId
)
)
) studentBodyRegister
) . Data.Set.findMax . Data.Set.map Data.Course.getRequiredLessonsPerWeek
) distinctCoursesBySynchronisationId
) $ Data.Map.map (
Data.Resource.getAvailability . map (
teacherRegister !
) . Data.Map.keys &&& Data.Foldable.maximum . Data.Map.map Data.Course.getRequiredLessonsPerWeek
) coursesByTeacherIdBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithExcessLessonsPerWeek problemValidationSwitches && not (Data.Map.null availableVsRequiredLessonsBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithExcessLessonsPerWeekTag ++ ": the number of time-slots when the interested student-bodies & required teachers, are simultaneously available, is fewer than the required lessons of some synchronised courses; " ++ show (Data.Map.toList availableVsRequiredLessonsBySynchronisationId)
),
let
unavailableSpecifiedDaysByTeacherIdBySynchronisationId = Data.Map.filter (
not . Data.Map.null
) $ Data.Map.map (
Data.Map.filter (
not . Data.Set.null
) . Data.Map.mapWithKey (
\teacherId -> Data.Set.filter (
not . (
`Data.Resource.isAvailableOn` (teacherRegister ! teacherId)
)
) . Data.Set.map Temporal.Time.getDay . Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
)
) coursesByTeacherIdBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithUnavailableSpecifiedDays problemValidationSwitches && not (Data.Map.null unavailableSpecifiedDaysByTeacherIdBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithUnavailableSpecifiedDaysTag ++ ": some synchronised courses, specify booking-times on days when not all the required teachers are available; " ++ show (
Data.Map.toList $ Data.Map.map (
Data.Map.toList . Data.Map.map Data.Set.toList
) unavailableSpecifiedDaysByTeacherIdBySynchronisationId
)
),
let
unavailableStudentBodiesBySpecifiedDaysBySynchronisationId = Data.Map.filter (
not . Data.Map.null
) $ Data.Map.mapWithKey (
\synchronisationId -> Data.Map.filter (
not . null
) . Data.Map.fromList . map (
\day -> (
day,
Data.Map.keys $ Data.Map.filter (
uncurry (&&) . (
not . Data.Resource.isAvailableOn day &&& Data.Student.requiresAnySubjectBy (
`Data.Set.member` Data.Set.map Data.Course.getSubject (
distinctCoursesBySynchronisationId ! synchronisationId
)
)
)
) studentBodyRegister
)
) . Data.Set.toList . Data.Set.unions . map (
Data.Set.map Temporal.Time.getDay . Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
) . Data.Set.toList
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithUnavailableSpecifiedDays problemValidationSwitches && not (Data.Map.null unavailableStudentBodiesBySpecifiedDaysBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithUnavailableSpecifiedDaysTag ++ ": some synchronised courses, are requested by student-bodies who're unavailable on days when booking-times have been specified; " ++ show (
Data.Map.toList $ Data.Map.map (
Data.Map.toList . Data.Map.map (map Aggregate.StudentBody.getMnemonic)
) unavailableStudentBodiesBySpecifiedDaysBySynchronisationId
)
),
let
excessTimeslotRequestsBySynchronisationId = Data.Map.filter (
uncurry (&&) . (not . null *** not . null)
) $ Data.Map.map (
(
ToolShed.Data.List.nub' . Data.Maybe.catMaybes *** Data.Set.toList . Data.Set.unions
) . unzip . Data.Set.toList . Data.Set.map (
(
Temporal.TimeslotRequest.getMaybeIdealTimeslotId &&& Temporal.TimeslotRequest.getSpecifiedTimes
) . Data.Course.getTimeslotRequest
)
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithExcessTimeslotRequests problemValidationSwitches && not (Data.Map.null excessTimeslotRequestsBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithExcessTimeslotRequestsTag ++ ": some synchronised courses, define both ideal timeslot-Ids & specify booking-times; " ++ show (Data.Map.toList excessTimeslotRequestsBySynchronisationId)
),
let
subjectsByStudentBodyBySynchronisationId = Data.Map.filter (
not . Data.Map.null
) $ Data.Map.mapWithKey (
\synchronisationId -> Data.Map.filter (
(> 1) . Data.Set.size
) . Data.Map.map (
Data.Set.filter (
\subject -> not $ Data.Foldable.any (
Data.Foldable.any (
uncurry (&&) . (
(/= Just synchronisationId) . Data.Course.getMaybeSynchronisationId &&& (== subject) . Data.Course.getSubject
)
) . Data.Teacher.getService
) teacherRegister
)
) . Data.Map.unionsWith Data.Set.union . map (
\synchronisedCourse -> Data.Map.filter (
not . Data.Set.null
) $ Data.Map.map (
Data.Set.filter (== Data.Course.getSubject synchronisedCourse) . Data.Student.deriveAmalgamatedKnowledgeRequirement
) studentBodyRegister
) . Data.Set.toList
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForStudentsRequiringMultipleSynchronisedSubjects problemValidationSwitches && not (Data.Map.null subjectsByStudentBodyBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForStudentsRequiringMultipleSynchronisedSubjectsTag ++ ": some student-bodies require multiple subjects only offered within one set of synchronised courses; " ++ show (
Data.Map.toList $ Data.Map.map (
map (Aggregate.StudentBody.getMnemonic *** Data.Set.toList) . Data.Map.toList
) subjectsByStudentBodyBySynchronisationId
)
),
let
duplicateSubjectsByTeacherIdBySynchronisationId = Data.Map.filter (
not . Data.Set.null
) $ Data.Map.map (
Data.Set.filter (
not . Data.Map.null
) . Data.Set.map (
\synchronisedCourse -> Data.Map.map Data.Set.findMin . Data.Map.filter (
not . Data.Set.null
) $ Data.Map.map (
Data.Set.filter (
== Data.Course.getSubject synchronisedCourse
) . Data.Set.map Data.Course.getSubject . Data.Set.filter (
/= synchronisedCourse
) . Data.Teacher.getService
) teacherRegister
)
) distinctCoursesBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForAlternativesToSynchronisedCourses problemValidationSwitches && not (Data.Map.null duplicateSubjectsByTeacherIdBySynchronisationId),
show ProblemConfiguration.ProblemValidationSwitches.checkForAlternativesToSynchronisedCoursesTag ++ ": courses are offered with the same subject as synchronised ones, potentially inhibiting migration of students; " ++ show (
Data.Map.toList $ Data.Map.map (Data.Foldable.concatMap Data.Map.toList) duplicateSubjectsByTeacherIdBySynchronisationId
)
),
let
synchronisationIdsWithoutSuitableLocations = Data.Map.keys $ Data.Map.filter (
null . ToolShed.Data.List.permutationsBy (
\l r -> let
lookupResources = (teacherRegister !) *** (locationCatalogue !)
in snd l /= snd r && Data.Resource.isAvailable (
lookupResources l,
lookupResources r
)
) . map (
uncurry zip . Control.Arrow.first repeat
) . Data.Map.toList . Data.Map.mapWithKey (
\teacherId course -> Data.Map.keys $ Data.Map.filter (
uncurry (&&) . (
(
Data.Course.getRequiredFacilityNames course `Data.Set.isSubsetOf`
) . Data.Location.getFacilityNames &&& Data.Resource.isAvailable . (,,) (
teacherRegister ! teacherId
) (
Data.Map.filter (
Data.Foldable.elem (Data.Course.getSubject course) . Data.Student.deriveAmalgamatedKnowledgeRequirement
) studentBodyRegister
)
)
) locationCatalogue
)
) coursesByTeacherIdBySynchronisationId
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForSynchronisedCoursesWithoutSuitableLocations problemValidationSwitches && not (null synchronisationIdsWithoutSuitableLocations),
show ProblemConfiguration.ProblemValidationSwitches.checkForSynchronisedCoursesWithoutSuitableLocationsTag ++ ": no permutation of those locations offering the required facilities, is simultaneously available to the teachers of a synchronised course & to all interested students; " ++ show synchronisationIdsWithoutSuitableLocations
),
let
duplicateStudentIds :: [(Data.Student.Id, [Aggregate.StudentBody.Mnemonic])]
duplicateStudentIds = map (
(
\studentId -> (
studentId,
map Aggregate.StudentBody.getMnemonic . Data.Set.toList . Data.Set.filter (
(studentId `Data.Set.member`) . Aggregate.StudentBody.getStudentIds
) $ Data.Map.keysSet studentBodyRegister
)
) . head
) . filter (
(/= 1) . length
) . ToolShed.Data.Foldable.gather . concatMap (
Data.Set.toList . Aggregate.StudentBody.getStudentIds
) $ Aggregate.StudentBodyRegister.getStudentBodies studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForDuplicateStudentIds problemValidationSwitches && not (null duplicateStudentIds),
show ProblemConfiguration.ProblemValidationSwitches.checkForDuplicateStudentIdsTag ++ ": some student-identifiers exist in more than one student-body; " ++ show duplicateStudentIds
),
let
daysOnWhichStudentBodiesExceedTeachers :: Data.Map.Map Temporal.Day.Day String
daysOnWhichStudentBodiesExceedTeachers = Data.Map.map (
\(nStudentBodies, nTeachers) -> showString "number of student-bodies=" . shows nStudentBodies . showString " > number of teachers=" $ shows nTeachers ""
) . Data.Map.filter (
uncurry (>)
) . Data.Map.fromList $ map (
id &&& (
Data.Map.size . (
`Data.Resource.extractAvailableResources` studentBodyRegister
) &&& Data.Map.size . (
`Data.Resource.extractAvailableResources` teacherRegister
)
)
) Temporal.Day.range
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodiesExceedTeachers problemValidationSwitches && not (Data.Map.null daysOnWhichStudentBodiesExceedTeachers),
show ProblemConfiguration.ProblemValidationSwitches.checkIfStudentBodiesExceedTeachersTag ++ ": on some days, the number of student-bodies exceeds the number of available teachers; " ++ show (Data.Map.toList daysOnWhichStudentBodiesExceedTeachers)
),
let
availableLocationCapacitiesByStudentBody = Data.Map.filterWithKey (
\studentBody -> Data.Foldable.all (Aggregate.StudentBody.getSize studentBody >)
) $ Data.Map.map (
\studentProfile -> Data.Map.map Data.Location.getCapacity $ Data.Map.filter (
Data.Resource.isAvailable . (,) studentProfile
) locationCatalogue
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodySizeExceedsCapacityOfAllLocations problemValidationSwitches && not (Data.Map.null availableLocationCapacitiesByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkIfStudentBodySizeExceedsCapacityOfAllLocationsTag ++ ": some student-bodies can't be accommodated by the largest available location; " ++ show (
map (
(
Aggregate.StudentBody.getMnemonic &&& Aggregate.StudentBody.getSize
) *** take 1 . Data.List.sortBy (
flip $ Data.Ord.comparing snd
) . Data.Map.toList
) $ Data.Map.toList availableLocationCapacitiesByStudentBody
)
),
let
daysOnWhichStudentBodySizeExceedsCapacity :: Data.Map.Map Temporal.Day.Day String
daysOnWhichStudentBodySizeExceedsCapacity = Data.Map.map (
(
\(studentBodySize, capacity) -> showString "student-body of size=" . shows studentBodySize . showChar ' ' $ if capacity == 0
then "for which zero available locations exist"
else showString "> capacity=" $ shows capacity ""
) . head
) . Data.Map.filter (
not . null
) . Data.Map.fromList $ map (
\day -> (
day,
dropWhile (
uncurry (<=)
) $ zip (
sortByDecreasingSize . map Aggregate.StudentBody.getSize . Aggregate.StudentBodyRegister.getStudentBodies $ Data.Resource.extractAvailableResources day studentBodyRegister
) (
(++ repeat 0) . sortByDecreasingSize . Data.Map.elems . Data.Map.map Data.Location.getCapacity $ Data.Resource.extractAvailableResources day locationCatalogue
)
)
) Temporal.Day.range where
sortByDecreasingSize :: [Size.NStudents] -> [Size.NStudents]
sortByDecreasingSize = Data.List.sortBy $ flip compare
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodySizeExceedsLocationCapacity problemValidationSwitches && not (Data.Map.null daysOnWhichStudentBodySizeExceedsCapacity),
show ProblemConfiguration.ProblemValidationSwitches.checkIfStudentBodySizeExceedsLocationCapacityTag ++ ": on some days, a match between the sizes of student-bodies & the available locations, reveals inadequate capacity; " ++ show (Data.Map.toList daysOnWhichStudentBodySizeExceedsCapacity)
),
let
timeslotsCapacity, timeslotsRequired :: Size.NTimeslots
timeslotsCapacity = (
* nTimeslotsPerDay
) . Data.Foldable.sum $ Data.Map.map (
Temporal.Availability.countDaysPerWeekAvailable . Temporal.Availability.findIntersections . (
: [
Temporal.Availability.findUnions $ Data.Map.map Data.Resource.getAvailability studentBodyRegister,
Temporal.Availability.findUnions $ Data.Map.map Data.Resource.getAvailability teacherRegister
]
) . Data.Resource.getAvailability
) locationCatalogue
timeslotsRequired = Data.Foldable.sum $ Data.Map.map (
sum . map Data.Course.getRequiredLessonsPerWeek . Data.Set.toList . Data.Teacher.getService
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckLocationsAvailabilityToSupportCourses problemValidationSwitches && timeslotsRequired > timeslotsCapacity,
show ProblemConfiguration.ProblemValidationSwitches.checkLocationsAvailabilityToSupportCoursesTag ++ ": the " ++ show timeslotsRequired ++ " time-slots required to teach all the courses offered, exceeds the " ++ show timeslotsCapacity ++ " time-slots available in the configured locations"
),
let
subjectsByStudentBody = Data.Map.filter (
not . Data.Set.null
) $ Data.Map.mapWithKey (
\studentBody studentProfile -> Data.Set.filter (
\subject -> not $ Data.Foldable.any (
\teacherProfile -> Data.Foldable.any (
uncurry (&&) . (
Data.Course.isSuitable (Aggregate.StudentBody.getSize studentBody) subject &&& (
\requiredFacilityNames -> Data.Foldable.any (
\locationProfile -> all ($ locationProfile) [
(>= Aggregate.StudentBody.getSize studentBody) . Data.Location.getCapacity,
Data.Resource.isAvailable . (,,) studentProfile teacherProfile,
Data.Set.isSubsetOf requiredFacilityNames . Data.Location.getFacilityNames
]
) locationCatalogue
) . Data.Course.getRequiredFacilityNames
)
) $ Data.Teacher.getService teacherProfile
) teacherRegister
) $ Data.Student.deriveAmalgamatedKnowledgeRequirement studentProfile
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckSuitableLocationsForKnowledgeRequirements problemValidationSwitches && not (Data.Map.null subjectsByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkSuitableLocationsForKnowledgeRequirementsTag ++ ": some student-bodies require subjects for which there's no suitable location; " ++ show (
map (
Aggregate.StudentBody.getMnemonic *** Data.Set.toList
) $ Data.Map.toList subjectsByStudentBody
)
),
let
nonExistentSubjectsByStudentBody = Data.Map.filter (
not . Data.Set.null
) $ Data.Map.map (
Data.Set.filter (
`Data.Set.notMember` Aggregate.TeacherRegister.extractDistinctSubjects teacherRegister
) . Data.Student.deriveAmalgamatedKnowledgeRequirement
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckSubjectExistence problemValidationSwitches && not (Data.Map.null nonExistentSubjectsByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkSubjectExistenceTag ++ ": not all subjects required by student-bodies, are offered; " ++ show (
map (
Control.Arrow.first Aggregate.StudentBody.getMnemonic
) . Data.Map.toList $ Data.Map.map Data.Set.toList nonExistentSubjectsByStudentBody
)
),
let
nonExistentMeetingLocationIdsByGroupId = Data.Map.filter (`Data.Map.notMember` locationCatalogue) $ Data.Map.mapMaybe Data.Group.getMaybeLocationId groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForNonExistentMeetingLocationIds problemValidationSwitches && not (Data.Map.null nonExistentMeetingLocationIdsByGroupId),
show ProblemConfiguration.ProblemValidationSwitches.checkForNonExistentMeetingLocationIdsTag ++ ": not all locations required for meetings, exist; " ++ show (Data.Map.toList nonExistentMeetingLocationIdsByGroupId)
),
let
nonExistentOwnLocationIdsByTeacherId = Data.Map.filter (`Data.Map.notMember` locationCatalogue) $ Data.Map.mapMaybe Data.Teacher.getMaybeOwnLocationId teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForNonExistentOwnLocationIds problemValidationSwitches && not (Data.Map.null nonExistentOwnLocationIdsByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkForNonExistentOwnLocationIdsTag ++ ": not all personal locations claimed by teachers, exist; " ++ show (Data.Map.toList nonExistentOwnLocationIdsByTeacherId)
),
let
unsupportedCoursesByTeacherId = Data.Map.filter (not . Data.Set.null) $ Data.Map.map (
\teacherProfile -> Data.Set.filter (
\course -> not . Data.Foldable.any (
(Data.Course.getRequiredFacilityNames course `Data.Set.isSubsetOf`) . Data.Location.getFacilityNames
) $ Data.Map.filter (
Data.Resource.isAvailable . (,) teacherProfile
) locationCatalogue
) $ Data.Teacher.getService teacherProfile
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForNonExistentFacilities problemValidationSwitches && not (Data.Map.null unsupportedCoursesByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkForNonExistentFacilitiesTag ++ ": there are zero available locations, which offer all the facilities required, for @ least one of the courses offered; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList unsupportedCoursesByTeacherId)
),
let
nonExistentGroupIds :: Data.Group.Membership
nonExistentGroupIds = extractDistinctGroupMembership problemParameters \\ Data.Map.keysSet groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForNonExistentGroupIds problemValidationSwitches && not (Data.Set.null nonExistentGroupIds),
show ProblemConfiguration.ProblemValidationSwitches.checkForNonExistentGroupIdsTag ++ ": not all groups of which some student-bodies & teachers are members, exist; " ++ show (Data.Set.toList nonExistentGroupIds)
),
let
groupIdsByLocationId = Data.Map.filterWithKey (
\groupId locationId -> uncurry (+) (
(
Data.Maybe.maybe 0 Aggregate.StudentClass.getSize . Data.Map.lookup groupId *** Data.Maybe.maybe 0 Data.Set.size . Data.Map.lookup groupId
) $ findHumanResourceIdsByGroupId problemParameters
) > Data.Location.getCapacity (locationCatalogue ! locationId)
) $ Data.Map.mapMaybe Data.Group.getMaybeLocationId groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckCapacityOfLocationsForMeetings problemValidationSwitches && not (Data.Map.null groupIdsByLocationId),
show ProblemConfiguration.ProblemValidationSwitches.checkCapacityOfLocationsForMeetingsTag ++ ": some groups hold meetings in locations with inadequate capacity; " ++ show (Data.Map.toList groupIdsByLocationId)
),
let
groupIdsByLocationIdByTime = Data.Map.filter (
Data.Foldable.any $ (> 1) . length
) $ Data.Map.foldrWithKey (
\groupId groupProfile m -> Data.Maybe.maybe m (
\locationId -> Data.Foldable.foldr (
Data.Map.insertWith (
Data.Map.unionWith (++)
) `flip` Data.Map.singleton locationId [groupId]
) m $ Data.Group.getMeetingTimes groupProfile
) $ Data.Group.getMaybeLocationId groupProfile
) Data.Map.empty groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckDuplicateMeetingLocationIds problemValidationSwitches && not (Data.Map.null groupIdsByLocationIdByTime),
show ProblemConfiguration.ProblemValidationSwitches.checkDuplicateMeetingLocationIdsTag ++ ": several groups require the same location simultaneously; " ++ show (Data.Map.toList $ Data.Map.map Data.Map.toList groupIdsByLocationIdByTime)
),
let
invalidMeetingTimesByGroupId = Data.Map.filter (
Data.Foldable.any (
\time -> any ($ Temporal.Time.getTimeslotId time) [
(< Factory.Data.Interval.getMinBound timeslotIdBounds),
(> Factory.Data.Interval.getMaxBound timeslotIdBounds)
]
)
) $ Data.Map.map Data.Group.getMeetingTimes groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForInvalidMeetingTimes problemValidationSwitches && not (Data.Map.null invalidMeetingTimesByGroupId),
show ProblemConfiguration.ProblemValidationSwitches.checkForInvalidMeetingTimesTag ++ ": some groups specify meeting-times, using timeslot-identifiers which are outside permissible bounds " ++ show timeslotIdBounds ++ "; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList invalidMeetingTimesByGroupId)
),
let
daysAndLocationIdsByGroupId = Data.Map.filter (
not . Data.Set.null . fst
) . Data.Map.map (
\(meetingDays, locationId) -> (
Data.Set.filter (
not . (`Data.Resource.isAvailableOn` (locationCatalogue ! locationId))
) meetingDays,
locationId
)
) $ Data.Map.mapMaybe (
uncurry fmap . (
(,) . Data.Set.map Temporal.Time.getDay . Data.Group.getMeetingTimes &&& Data.Group.getMaybeLocationId
)
) groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckMeetingLocationsAvailability problemValidationSwitches && not (Data.Map.null daysAndLocationIdsByGroupId),
show ProblemConfiguration.ProblemValidationSwitches.checkMeetingLocationsAvailabilityTag ++ ": some groups require a location, which isn't available @ all of the specified meeting-times; " ++ show (
Data.Map.toList $ Data.Map.map (Control.Arrow.first Data.Set.toList) daysAndLocationIdsByGroupId
)
),
let
groupsWithIndependentlyAvailableMembers = filter (
Temporal.Availability.isUnavailable . Data.Resource.getAvailability . (
(`Data.HumanResource.extractGroupMembersOf` studentBodyRegister) &&& (`Data.HumanResource.extractGroupMembersOf` teacherRegister)
)
) . Data.Map.keys $ Data.Map.filter (
uncurry (&&) . (
(> 0) . Data.Group.countNTimeslotsPerWeek &&& Data.Group.getMandatesAttendance
)
) groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckSimultaneousAvailabilityOfGroupMembers problemValidationSwitches && not (null groupsWithIndependentlyAvailableMembers),
show ProblemConfiguration.ProblemValidationSwitches.checkSimultaneousAvailabilityOfGroupMembersTag ++ ": some groups which mandate attendance, can never meet because their members are never simultaneously available; " ++ show groupsWithIndependentlyAvailableMembers
),
let
unavailableDaysByGroupId :: Data.Map.Map Data.Group.Id (Data.Set.Set Temporal.Day.Day)
unavailableDaysByGroupId = Data.Map.filter (
not . Data.Set.null
) . Data.Map.mapWithKey (
\groupId -> let
memberStudents = Data.HumanResource.extractGroupMembersOf groupId studentBodyRegister
memberTeachers = Data.HumanResource.extractGroupMembersOf groupId teacherRegister
in Data.Set.filter (
\day -> (
not (Data.Map.null memberStudents) || not (Data.Map.null memberTeachers)
) && not (
any (
Temporal.Availability.isAvailableOn day
) $ map Data.Resource.getAvailability (Data.Map.elems memberStudents) ++ map Data.Resource.getAvailability (Data.Map.elems memberTeachers)
)
)
) $ Data.Map.map (
Data.Set.map Temporal.Time.getDay . Data.Group.getMeetingTimes
) groupCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckAvailabilityOfAnyGroupMember problemValidationSwitches && not (Data.Map.null unavailableDaysByGroupId),
show ProblemConfiguration.ProblemValidationSwitches.checkAvailabilityOfAnyGroupMemberTag ++ ": specific meetings of some groups can never be attended, because none of the members are available on that day; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList unavailableDaysByGroupId)
),
let
unavailableDaysByStudentBody = findUnavailableDaysByGroupIdByHumanResourceId groupCatalogue studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsAvailabilityForMandatoryMeetings problemValidationSwitches && not (Data.Map.null unavailableDaysByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsAvailabilityForMandatoryMeetingsTag ++ ": some student-bodies are unavailable for some of the meetings, of those groups mandating attendance, of which they're members; " ++ show (
Data.Map.toList $ Data.Map.map (
Data.Map.toList . Data.Map.map Data.Set.toList
) unavailableDaysByStudentBody
)
),
let
unavailableDaysByTeacherId = findUnavailableDaysByGroupIdByHumanResourceId groupCatalogue teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckTeachersAvailabilityForMandatoryMeetings problemValidationSwitches && not (Data.Map.null unavailableDaysByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkTeachersAvailabilityForMandatoryMeetingsTag ++ ": some teachers are unavailable for some of the meetings, of those groups mandating attendance, of which they're members; " ++ show (
Data.Map.toList $ Data.Map.map (
Data.Map.toList . Data.Map.map Data.Set.toList
) unavailableDaysByTeacherId
)
),
let
synchronousTimesByStudentBody = Data.Map.filter (
not . Data.Set.null
) $ Data.Map.mapWithKey (
\studentBody studentProfile -> uncurry Data.Set.intersection $ (
Data.Foldable.foldr Data.Set.union Data.Set.empty . Data.Set.map (
\subject -> Data.Foldable.foldr1 Data.Set.intersection . Data.Map.map (
Data.Foldable.foldr Data.Set.union Data.Set.empty . Data.Set.filter (
Data.Foldable.all (
(`Data.Resource.isAvailableOn` studentProfile) . Temporal.Time.getDay
)
) . Data.Set.map (
Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
)
) . Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
Data.Course.isSuitable (Aggregate.StudentBody.getSize studentBody) subject
) . Data.Teacher.getService
) $ Data.Map.filter (
Data.Resource.isAvailable . (,) studentProfile
) teacherRegister
) . Data.Student.deriveAmalgamatedKnowledgeRequirement &&& Data.Foldable.foldr (
Data.Set.union . Data.Group.getMeetingTimes . (
groupCatalogue !
)
) Data.Set.empty . Data.HumanResource.getGroupMembership
) studentProfile
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckIndependenceOfStudentTimeslotsRequestsAndMeetings problemValidationSwitches && not (Data.Map.null synchronousTimesByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkIndependenceOfStudentTimeslotsRequestsAndMeetingsTag ++ ": some student-bodies are members of groups, which meet @ times specified for all courses offering one of their knowledge-requirements; " ++ show (
map (
Control.Arrow.first Aggregate.StudentBody.getMnemonic
) . Data.Map.toList $ Data.Map.map Data.Set.toList synchronousTimesByStudentBody
)
),
let
synchronousTimesByTeacherId = Data.Map.filter (
not . Data.Set.null
) $ Data.Map.map (
uncurry Data.Set.intersection . (
Data.Teacher.findSpecifiedTimes &&& Data.Foldable.foldr (
Data.Set.union . Data.Group.getMeetingTimes . (
groupCatalogue !
)
) Data.Set.empty . Data.HumanResource.getGroupMembership
)
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckIndependenceOfTeacherTimeslotsRequestsAndMeetings problemValidationSwitches && not (Data.Map.null synchronousTimesByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkIndependenceOfTeacherTimeslotsRequestsAndMeetingsTag ++ ": some teachers are members of groups, which meet @ times specified for one of their courses; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList synchronousTimesByTeacherId)
),
let
synchronousSeparateMeetingsByTimeByTeacherId = findSynchronousSeparateMandatoryMeetingsByTimeByHumanResourceId groupCatalogue teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckTeachersForSynchronousMeetings problemValidationSwitches && not (Data.Map.null synchronousSeparateMeetingsByTimeByTeacherId),
show ProblemConfiguration.ProblemValidationSwitches.checkTeachersForSynchronousMeetingsTag ++ ": some teachers are members of groups with synchronous meeting-times, in separate locations; " ++ show (Data.Map.toList $ Data.Map.map Data.Map.toList synchronousSeparateMeetingsByTimeByTeacherId)
),
let
synchronousSeparateMeetingsByTimeByStudentBody = findSynchronousSeparateMandatoryMeetingsByTimeByHumanResourceId groupCatalogue studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsForSynchronousMeetings problemValidationSwitches && not (Data.Map.null synchronousSeparateMeetingsByTimeByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsForSynchronousMeetingsTag ++ ": some student-bodies are members of groups with synchronous meeting-times, in separate locations; " ++ show (Data.Map.toList $ Data.Map.map Data.Map.toList synchronousSeparateMeetingsByTimeByStudentBody)
),
let
teacherIds = Data.Map.keys . Data.Map.filter (
not . Data.Resource.isAvailable
) $ Data.Map.mapMaybe (
\teacherProfile -> ((,) teacherProfile . (locationCatalogue !)) `fmap` Data.Teacher.getMaybeOwnLocationId teacherProfile
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckOwnLocationsAvailability problemValidationSwitches && not (null teacherIds),
show ProblemConfiguration.ProblemValidationSwitches.checkOwnLocationsAvailabilityTag ++ ": some teachers claim a personal location, which isn't available @ any time during their working-week; " ++ show teacherIds
),
let
duplicateClaimsByLocationId = Data.Map.map (
Aggregate.TeacherRegister.getTeacherIds . fst
) . Data.Map.filter (
uncurry (&&) . (
(> 1) . Data.Map.size . fst &&& Data.Resource.isAvailable
)
) $ Data.Map.mapWithKey (
(,) . (`Data.Map.filter` teacherRegister) . Data.Teacher.inhabits
) locationCatalogue
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckDuplicateOwnLocationIds problemValidationSwitches && not (Data.Map.null duplicateClaimsByLocationId),
show ProblemConfiguration.ProblemValidationSwitches.checkDuplicateOwnLocationIdsTag ++ ": ownership of a single location, is claimed by teachers whose working-weeks aren't mutually exclusive; " ++ show (Data.Map.toList duplicateClaimsByLocationId)
),
let
teacherIdsByTime = Data.Map.filter (
(> Data.Map.size locationCatalogue) . length
) . Data.Map.foldrWithKey (
\teacherId -> flip $ Data.Foldable.foldr (
Data.Map.insertWith (++) `flip` [teacherId]
)
) Data.Map.empty $ Data.Map.map Data.Teacher.findSpecifiedTimes teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckLocationsForSynchronousSpecifiedTimes problemValidationSwitches && not (Data.Map.null teacherIdsByTime),
show ProblemConfiguration.ProblemValidationSwitches.checkLocationsForSynchronousSpecifiedTimesTag ++ ": more courses specify the same booking-time, than there are locations in which to hold them; " ++ show (Data.Map.toList teacherIdsByTime)
),
let
unavailableSubjectsByStudentBody = Data.Map.filter (not . Data.Set.null) $ Data.Map.mapWithKey (
\studentBody studentProfile -> Data.Set.filter (
\subject -> not . Data.Foldable.any (
Data.Foldable.all (
(`Data.Resource.isAvailableOn` studentProfile) . Temporal.Time.getDay
) . Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
) . Aggregate.TeacherRegister.findSuitableCourseByTeacherId (
Aggregate.StudentBody.getSize studentBody
) subject $ Data.Map.filter (
Data.Resource.isAvailable . (,) studentProfile
) teacherRegister
) $ Data.Student.deriveAmalgamatedKnowledgeRequirement studentProfile
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsAvailabilityForSpecifiedTimes problemValidationSwitches && not (Data.Map.null unavailableSubjectsByStudentBody),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsAvailabilityForSpecifiedTimesTag ++ ": some student-bodies have requested subjects, for which either there're zero suitable courses, or all suitable courses specify booking-times when they're unavailable; " ++ show (Data.Map.toList $ Data.Map.map Data.Set.toList unavailableSubjectsByStudentBody)
),
let
studentBodiesWithSynchronousTimeslotRequests :: [Aggregate.StudentBody.StudentBody]
studentBodiesWithSynchronousTimeslotRequests = Data.Map.keys . Data.Map.filter null $ Data.Map.mapWithKey (
\studentBody studentProfile -> filter (
not . Data.List.Extra.anySame . concat
) . ToolShed.Data.List.permutations . map (
\subject -> filter (
all ((`Data.Resource.isAvailableOn` studentProfile) . Temporal.Time.getDay)
) . map (
Data.Set.toList . Temporal.TimeslotRequest.getSpecifiedTimes . Data.Course.getTimeslotRequest
) . Data.Map.elems . Aggregate.TeacherRegister.findSuitableCourseByTeacherId (Aggregate.StudentBody.getSize studentBody) subject $ Data.Map.filter (
Data.Resource.isAvailable . (,) studentProfile
) teacherRegister
) . Data.Set.toList $ Data.Student.deriveAmalgamatedKnowledgeRequirement studentProfile
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckCoursesForSynchronousSpecifiedTimes problemValidationSwitches && not (null studentBodiesWithSynchronousTimeslotRequests),
show ProblemConfiguration.ProblemValidationSwitches.checkCoursesForSynchronousSpecifiedTimesTag ++ ": some student-bodies require subjects, for which either there're zero suitable courses, or present a conflict between the specified booking-times of those courses which are suitable; " ++ show studentBodiesWithSynchronousTimeslotRequests
),
let
subjectsWithInsufficientTeachers = Data.Map.filter (
uncurry (>)
) . Data.Map.mapWithKey (
\subject nClassesRequired -> (
nClassesRequired,
sum [
nTimeslotPerWeekOfTeaching `div` Data.Course.getRequiredLessonsPerWeek course |
(nTimeslotPerWeekOfTeaching, Just course) <- map (
Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay &&& Data.Teacher.lookupCourseIn subject
) $ Data.Map.elems teacherRegister
]
)
) . Data.Map.fromListWith (+) . map (
flip (,) 1
) . concatMap (
Data.Set.toList . Data.Set.unions . map Data.Student.deriveAmalgamatedKnowledgeRequirement
) $ ToolShed.Data.Foldable.gatherBy Data.Student.getStream studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckTeachingCapacityBySubject problemValidationSwitches && not (Data.Map.null subjectsWithInsufficientTeachers),
show ProblemConfiguration.ProblemValidationSwitches.checkTeachingCapacityBySubjectTag ++ ": the total demand for separate courses in some subjects exceeds that offered by teachers; " ++ show (Data.Map.toList subjectsWithInsufficientTeachers)
),
let
idleStudentBodies = Data.Map.filter (
uncurry (&&) . (
Data.Set.null . Data.Student.deriveAmalgamatedKnowledgeRequirement &&& (> 0) . Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay
)
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForIdleStudents problemValidationSwitches && not (Data.Map.null idleStudentBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkForIdleStudentsTag ++ ": some student-bodies require zero subjects, but have allocated one or more time-slots for teaching; " ++ show (Data.Map.toList idleStudentBodies)
),
let
overloadedStudentBodies = Data.Map.filter (
uncurry (&&) . (
not . Data.Set.null . Data.Student.deriveAmalgamatedKnowledgeRequirement &&& (== 0) . Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay
)
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForOverloadedStudents problemValidationSwitches && not (Data.Map.null overloadedStudentBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkForOverloadedStudentsTag ++ ": some student-bodies have allocated zero time-slots for teaching, but have requested one or more subjects; " ++ show (Data.Map.toList overloadedStudentBodies)
),
let
idleTeachers = Data.Map.filter (
uncurry (&&) . (
not . Data.Teacher.offersService &&& (> 0) . Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay
)
) teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForIdleTeachers problemValidationSwitches && not (Data.Map.null idleTeachers),
show ProblemConfiguration.ProblemValidationSwitches.checkForIdleTeachersTag ++ ": some teachers offer zero courses required by student-bodies, but have allocated one or more time-slots for teaching; " ++ show (Data.Map.toList idleTeachers)
),
let
slackStudentsBodies :: Data.Map.Map Aggregate.StudentBody.StudentBody (Size.NTimeslots, Size.NTimeslots)
slackStudentsBodies = Data.Map.filter (uncurry (<)) $ Data.Map.map (
(
Temporal.Workload.getMaximum . uncurry (<+>)
) . calculateStudentWorkloadBounds teacherRegister &&& Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsLowerWorkloadBound problemValidationSwitches && not (Data.Map.null slackStudentsBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsLowerWorkloadBoundTag ++ ": the workload associated with all subject-requirements, for some student-bodies, is insufficient to meet the tuition-time in their working-week; " ++ show (map (Control.Arrow.first Aggregate.StudentBody.getMnemonic) $ Data.Map.toList slackStudentsBodies)
),
let
overloadedStudentBodies :: Data.Map.Map Aggregate.StudentBody.StudentBody (Size.NTimeslots, Size.NTimeslots)
overloadedStudentBodies = Data.Map.filter (uncurry (>)) $ Data.Map.map (
Temporal.Workload.getMinimum . Data.Requirements.getCore . calculateStudentWorkloadBounds teacherRegister &&& Data.HumanResource.getNTimeslotsPerWeekOfTeaching nTimeslotsPerDay
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsUpperWorkloadBound problemValidationSwitches && not (Data.Map.null overloadedStudentBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsUpperWorkloadBoundTag ++ ": the workload associated with core subject-requirements, for some student-bodies, exceeds the tuition-time available in their working-week; " ++ show (map (Control.Arrow.first Aggregate.StudentBody.getMnemonic) $ Data.Map.toList overloadedStudentBodies)
),
let
overloadedStudentBodies = findHumanResourcesOverloadedWithMeetings nTimeslotsPerDay groupCatalogue studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsUpperWorkloadBound problemValidationSwitches && not (Data.Map.null overloadedStudentBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsUpperWorkloadBoundTag ++ ": the time associated with meetings, for some student-bodies, exceeds the non-teaching time available in their working-week; " ++ show (Data.Map.toList overloadedStudentBodies)
),
let
overloadedTeachers = findHumanResourcesOverloadedWithMeetings nTimeslotsPerDay groupCatalogue teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckTeachersUpperWorkloadBound problemValidationSwitches && not (Data.Map.null overloadedTeachers),
show ProblemConfiguration.ProblemValidationSwitches.checkTeachersUpperWorkloadBoundTag ++ ": the time associated with meetings, for some teachers, exceeds the non-teaching time available in their working-week; " ++ show (Data.Map.toList overloadedTeachers)
),
let
rogueStudentBodies = Data.Map.filter (
Data.Foldable.any (not . Data.Set.null)
) $ Data.Map.map (
Data.Map.filter (
(> 1) . Data.Set.size
) . Data.Map.fromListWith Data.Set.union . map (
Data.Subject.getTopic &&& Data.Set.singleton . Data.Subject.getLevel
) . Data.Set.toList . Data.Student.deriveAmalgamatedKnowledgeRequirement
) studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckStudentsForMultipleLevelsOfSameTopic problemValidationSwitches && not (Data.Map.null rogueStudentBodies),
show ProblemConfiguration.ProblemValidationSwitches.checkStudentsForMultipleLevelsOfSameTopicTag ++ ": some student-body's knowledge-requirements include more than one level of the same topic; " ++ show (
Data.Map.toList $ Data.Map.map (Data.Map.toList . Data.Map.map Data.Set.toList) rogueStudentBodies
)
),
let
studentBodiesWithUnrealisableFreePeriodPreference = extractResourceIdsWithUnrealisableFreePeriodPreference studentBodyRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForStudentsWithUnrealisableFreePeriodPreference problemValidationSwitches && not (null studentBodiesWithUnrealisableFreePeriodPreference),
show ProblemConfiguration.ProblemValidationSwitches.checkForStudentsWithUnrealisableFreePeriodPreferenceTag ++ ": the preference of some student-bodies, for the position of free time-slots, within those days on which they're available, can never be realised because of the meeting-times of groups of which they're members; " ++ show (map Aggregate.StudentBody.getMnemonic studentBodiesWithUnrealisableFreePeriodPreference)
),
let
teacherIdsWithUnrealisableFreePeriodPreference = extractResourceIdsWithUnrealisableFreePeriodPreference teacherRegister
in (
ProblemConfiguration.ProblemValidationSwitches.getCheckForTeachersWithUnrealisableFreePeriodPreference problemValidationSwitches && not (null teacherIdsWithUnrealisableFreePeriodPreference),
show ProblemConfiguration.ProblemValidationSwitches.checkForTeachersWithUnrealisableFreePeriodPreferenceTag ++ ": the preference of some teachers, for the position of free time-slots, within those days on which they're available, can never be realised because of the meeting-times of groups of which they're members; " ++ show teacherIdsWithUnrealisableFreePeriodPreference
)
] where
nTimeslotsPerDay :: Size.NTimeslots
nTimeslotsPerDay = calculateNTimeslotsPerDay timeslotIdBounds
extractResourceIdsWithUnrealisableFreePeriodPreference :: (
Data.HumanResource.HumanResource humanResource,
Data.Resource.Resource humanResource
) => Data.Resource.ResourceMap humanResourceId humanResource -> [humanResourceId]
extractResourceIdsWithUnrealisableFreePeriodPreference = Data.Map.keys . Data.Map.filter (
\profile -> let
meetingTimesByDay = Temporal.Time.categoriseByDay . Aggregate.GroupCatalogue.getMeetingTimes groupCatalogue $ Data.HumanResource.getGroupMembership profile
in Data.Foldable.all (
(
\meetingTimeslotIdSet -> case Data.Maybe.fromJust $ Data.HumanResource.getMaybeFreePeriodPreference profile of
Temporal.FreePeriodPreference.Pre -> Data.Set.member (Factory.Data.Interval.getMinBound timeslotIdBounds) meetingTimeslotIdSet
Temporal.FreePeriodPreference.Post -> all (`Data.Set.member` meetingTimeslotIdSet) $ Factory.Data.Interval.toList timeslotIdBounds
Temporal.FreePeriodPreference.Terminal -> Data.Set.member (Factory.Data.Interval.getMaxBound timeslotIdBounds) meetingTimeslotIdSet
) . Data.Maybe.fromMaybe Data.Set.empty . (`Data.Map.lookup` meetingTimesByDay)
) . Temporal.Availability.deconstruct $ Data.Resource.getAvailability profile
) . Data.Map.filter Data.HumanResource.hasFreePeriodPreference
coursesByTeacherIdBySynchronisationId = Aggregate.TeacherRegister.findCoursesByTeacherIdBySynchronisationId teacherRegister
distinctCoursesBySynchronisationId = Aggregate.TeacherRegister.findDistinctCoursesBySynchronisationId coursesByTeacherIdBySynchronisationId
reduceStudentBodyRegister :: (
Ord level,
Ord stream,
Ord teachingRatio
)
=> Aggregate.StudentClass.MnemonicSeparator
-> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Control.Monad.Writer.Writer [[Aggregate.StudentBody.StudentBody]] (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId)
reduceStudentBodyRegister mnemonicSeparator problemParameters = do
studentBodyRegister <- Aggregate.StudentBodyRegister.reduce mnemonicSeparator $ getStudentBodyRegister problemParameters
return problemParameters { getStudentBodyRegister = studentBodyRegister }
removeRedundantCourses :: (
#if !MIN_VERSION_containers(0,5,2)
Ord synchronisationId,
Ord timeslotId,
#endif
Ord level
)
=> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Control.Monad.Writer.Writer [(teacherId, Data.Subject.Knowledge level)] (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId)
removeRedundantCourses problemParameters = let
(teacherRegister, redundantServiceByTeacherId) = (
Data.Map.map fst &&& Data.Map.filter (not . Data.Set.null) . Data.Map.map snd
) . Data.Map.map (
\profile -> let
(requiredService, redundantService) = Data.Set.partition (
(`Data.Set.member` Aggregate.StudentBodyRegister.extractDistinctSubjects (getStudentBodyRegister problemParameters)) . Data.Course.getSubject
) $ Data.Teacher.getService profile
in (
profile {Data.Teacher.getService = requiredService},
redundantService
)
) $ getTeacherRegister problemParameters
in do
Control.Monad.Writer.tell . Data.Map.toList $ Data.Map.map (Data.Set.map Data.Course.getSubject) redundantServiceByTeacherId
return problemParameters {
getTeacherRegister = teacherRegister
}
removePointlessGroups
:: ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Control.Monad.Writer.Writer [Data.Group.Id] (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId)
removePointlessGroups problemParameters = let
(pointlessGroupMembership, reducedGroupCatalogue) = Control.Arrow.first Data.Map.keysSet . Data.Map.partition (
Data.Set.null . Data.Group.getMeetingTimes
) $ getGroupCatalogue problemParameters
in do
Control.Monad.Writer.tell $ Data.Set.toList pointlessGroupMembership
return problemParameters {
getGroupCatalogue = reducedGroupCatalogue,
getStudentBodyRegister = Data.Map.map (Data.Student.unsubscribe pointlessGroupMembership) $ getStudentBodyRegister problemParameters,
getTeacherRegister = Data.Map.map (Data.Teacher.unsubscribe pointlessGroupMembership) $ getTeacherRegister problemParameters
}
removeUnsubscribedGroups
:: RealFrac teachingRatio
=> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Control.Monad.Writer.Writer [Data.Group.Id] (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId)
removeUnsubscribedGroups problemParameters = let
(reducedGroupCatalogue, unsubscribedGroupCatalogue) = Data.Map.partitionWithKey (
\groupId _ -> Data.Set.member groupId . uncurry Data.Set.union $ (
Data.HumanResource.extractCombinedGroupMembership . getStudentBodyRegister &&& Data.HumanResource.extractCombinedGroupMembership . getTeacherRegister
) problemParameters
) $ getGroupCatalogue problemParameters
in do
Control.Monad.Writer.tell $ Data.Map.keys unsubscribedGroupCatalogue
return problemParameters {
getGroupCatalogue = reducedGroupCatalogue
}
mergeConstraintsOnSynchronisedCourses :: (
Ord level,
Ord synchronisationId,
Ord teacherId,
Ord timeslotId,
Show synchronisationId,
Show timeslotId
) => ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId -> ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
mergeConstraintsOnSynchronisedCourses problemParameters = problemParameters {
getTeacherRegister = Aggregate.TeacherRegister.mergeConstraintsOnSynchronisedCourses $ getTeacherRegister problemParameters
}
disableAnyValidationInappropriateForTemporaryStudentBodyMerger
:: ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId
-> Control.Monad.Writer.Writer [String] (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId)
disableAnyValidationInappropriateForTemporaryStudentBodyMerger problemParameters = foldr (
\(_, disabledSwitchTag) -> (Control.Monad.Writer.tell [disabledSwitchTag] >>)
) (
return problemParameters {
getProblemValidationSwitches = problemValidationSwitches {
ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodiesExceedTeachers = False,
ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodySizeExceedsLocationCapacity = False
}
}
) $ filter (
($ problemValidationSwitches) . fst
) [
(ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodiesExceedTeachers, ProblemConfiguration.ProblemValidationSwitches.checkIfStudentBodiesExceedTeachersTag),
(ProblemConfiguration.ProblemValidationSwitches.getCheckIfStudentBodySizeExceedsLocationCapacity, ProblemConfiguration.ProblemValidationSwitches.checkIfStudentBodySizeExceedsLocationCapacityTag)
] where
problemValidationSwitches = getProblemValidationSwitches problemParameters
hasAnyFreePeriodPreference :: RealFrac teachingRatio => ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId -> Bool
hasAnyFreePeriodPreference = uncurry (||) . (Aggregate.StudentBodyRegister.hasAnyFreePeriodPreference . getStudentBodyRegister &&& Aggregate.TeacherRegister.hasAnyFreePeriodPreference . getTeacherRegister)
hasVariousMinimumConsecutiveLessons ::
#if !MIN_VERSION_containers(0,5,2)
(
Ord level,
Ord synchronisationId,
Ord timeslotId
) =>
#endif
ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId -> Bool
hasVariousMinimumConsecutiveLessons = (> 1) . Data.Set.size . Data.Foldable.foldr (
\teacherProfile -> Data.Set.union (Data.Set.map Data.Course.getMinimumConsecutiveLessons $ Data.Teacher.getService teacherProfile)
) Data.Set.empty . getTeacherRegister
instance (
Enum timeslotId,
Ord level,
Ord synchronisationId,
Ord teacherId,
Ord timeslotId,
RealFrac teachingRatio,
Show level,
Show synchronisationId,
Show teacherId,
Show timeslotId
) => Configuration.Configuration (ProblemParameters campus level locationId stream synchronisationId teacherId teachingRatio timeslotId) where
issueWarnings problemParameters = [
msg | (True, msg) <- [
let
excessTotalWorkloadByStudentBody :: Data.Map.Map Aggregate.StudentBody.StudentBody Size.NTimeslots
excessTotalWorkloadByStudentBody = findExcessTotalWorkloadByStudentBody problemParameters
in (
not $ Data.Map.null excessTotalWorkloadByStudentBody,
"the time required for the total (core & optional) knowledge-requirements of some student-bodies, exceeds that allocated to teaching; " ++ show (
Control.Arrow.first Aggregate.StudentBody.getMnemonic `map` Data.Map.toList excessTotalWorkloadByStudentBody
)
),
let
subjectsOfferedInMultipleCoursesRequiringDifferentLessonsPerWeek = Aggregate.TeacherRegister.findSubjectsOfferedInMultipleCoursesRequiringDifferentLessonsPerWeek $ getTeacherRegister problemParameters
in (
not $ Data.Map.null subjectsOfferedInMultipleCoursesRequiringDifferentLessonsPerWeek,
"some subjects have been offered by more than one teacher, but in courses requiring a different number of lessons per week; " ++ show (
Data.Map.toList $ Data.Map.map Data.Map.toList subjectsOfferedInMultipleCoursesRequiringDifferentLessonsPerWeek
)
), (
ProblemConfiguration.ValidationSwitch.areAllOff $ getProblemValidationSwitches problemParameters,
"all problem-validation switches are off; the problem-parameters may be invalid"
), (
ProblemConfiguration.ValidationSwitch.areAllOff $ getTimetableValidationSwitches problemParameters,
"all timetable-validation switches are off; any imported timetable may be invalid"
),
let
subjectsByTeacherId = Data.Map.map (
map Data.Course.getSubject . Data.Set.toList
) . Data.Map.filter (
not . Data.Set.null
) . Data.Map.map (
Data.Set.filter (
Data.Maybe.maybe False (
null . show
) . Data.Course.getMaybeSynchronisationId
) . Data.Teacher.getService
) $ getTeacherRegister problemParameters
in (
not $ Data.Map.null subjectsByTeacherId,
"some teachers have defined courses with a null 'synchronisationId'; " ++ show (Data.Map.toList subjectsByTeacherId)
),
let
synchronousMeetingsByTimeByStudentBodyMnemonic = findSynchronousMeetingsByTimeByStudentBodyMnemonic problemParameters
in (
not $ Data.Map.null synchronousMeetingsByTimeByStudentBodyMnemonic,
"the following student-bodies have synchonous group-meetings; " ++ show (
map (Control.Arrow.first Aggregate.StudentBody.getMnemonic) . Data.Map.toList $ Data.Map.map Data.Map.toList synchronousMeetingsByTimeByStudentBodyMnemonic
)
),
let
synchronousMeetingsByTimeByTeacherId = findSynchronousMeetingsByTimeByTeacherId problemParameters
in (
not $ Data.Map.null synchronousMeetingsByTimeByTeacherId,
"the following teachers have synchonous group-meetings; " ++ show (Data.Map.toList $ Data.Map.map Data.Map.toList synchronousMeetingsByTimeByTeacherId)
),
case calculateNTimeslotsPerDay $ getTimeslotIdBounds problemParameters of
1 -> (
hasAnyFreePeriodPreference problemParameters,
"a " ++ show Temporal.FreePeriodPreference.tag ++ " is meaningless with only one time-slot per day"
)
2 -> (
let
hasTerminalFreePeriodPreference :: Data.HumanResource.HumanResource resource => Data.Resource.ResourceMap resourceId resource -> Bool
hasTerminalFreePeriodPreference = Data.Foldable.any $ (== Just Temporal.FreePeriodPreference.Terminal) . Data.HumanResource.getMaybeFreePeriodPreference
in uncurry (||) $ (
hasTerminalFreePeriodPreference . getStudentBodyRegister &&& hasTerminalFreePeriodPreference . getTeacherRegister
) problemParameters,
"'" ++ Temporal.FreePeriodPreference.tag ++ "=" ++ show Temporal.FreePeriodPreference.Terminal ++ "' is redundant when there are only two time-slots per day"
)
_ -> (False, undefined)
]
]