weekdaze-0.0.0.1: src-lib/WeekDaze/ExecutionConfiguration/EvolutionStrategies.hs
{-# LANGUAGE CPP, FlexibleContexts #-}
{-
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 extent to which various strategies are applied in an attempt to evolve the /timetable/.
-}
module WeekDaze.ExecutionConfiguration.EvolutionStrategies(
-- * Types
-- ** Type-synonyms
-- Mutator,
-- ** Data-types
EvolutionStrategies(..),
-- * Constants
-- tag,
synchronisedCourseMutationTag,
synchronisedCourseByDayMutationTag,
excessRunlengthMutationTag,
homogeneousStudentViewLessonMutationTag,
incompleteCourseMutationTag,
randomLessonMutationTag,
singletonStudentClassMutationTag,
splitSessionMutationTag,
studentBodyCombinationMutationTag,
studentViewTimetableForDayMutationTag,
studentViewTimetableForWeekMutationTag,
synchronousLessonMutationTag,
-- randomLessonMutationNTrialsTag,
-- randomLessonMutationNTimeslotsTag,
-- studentViewTimetableForDayMutationNDaysTag,
-- studentViewTimetableForWeekMutationNTrialsTag,
-- studentViewTimetableForWeekMutationNTimeslotsTag,
fecundityDecayRatioTag,
minimumPopulationDiversityRatioTag,
nInitialScoutsTag,
-- * Functions
-- ** Mutators
zeroSynchronisedCourseMutationFecundity,
zeroSynchronisedCourseByDayMutationFecundity,
zeroExcessRunlengthMutationFecundity,
-- zeroHomogeneousStudentViewLessonMutationFecundity,
-- zeroIncompleteCourseMutationFecundity,
-- zeroRandomLessonMutationFecundity,
zeroSingletonStudentClassMutationFecundity,
zeroSplitSessionMutationFecundity,
zeroStudentBodyCombinationMutationFecundity,
-- zeroStudentViewTimetableForDayMutationFecundity,
-- zeroStudentViewTimetableForWeekMutationFecundity,
-- zeroSynchronousLessonMutationFecundity,
-- ** Predicates
areAllZero
) where
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Data.Maybe
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
import qualified WeekDaze.ExecutionConfiguration.TimetableBreederFecundity as ExecutionConfiguration.TimetableBreederFecundity
import qualified WeekDaze.Size as Size
import qualified WeekDaze.Temporal.Day as Temporal.Day
#ifdef USE_HDBC
import Control.Arrow((&&&))
import qualified Database.HDBC
import qualified Data.Convertible
import qualified Data.Typeable
import qualified WeekDaze.Database.Selector as Database.Selector
instance (
Data.Convertible.Convertible Database.HDBC.SqlValue fecundityDecayRatio, -- Flexible context.
Data.Convertible.Convertible Database.HDBC.SqlValue populationDiversityRatio, -- Flexible context.
Data.Typeable.Typeable fecundityDecayRatio,
Data.Typeable.Typeable populationDiversityRatio,
RealFrac fecundityDecayRatio,
RealFrac populationDiversityRatio
) => Database.Selector.Selector (EvolutionStrategies fecundityDecayRatio populationDiversityRatio) where
fromDatabase connection projectIdSql = let
tableName :: Database.Selector.TableName
tableName = Database.Selector.tablePrefix ++ tag
in do
strategiesRows <- Database.Selector.select connection [
"synchronisedCourseMutationDeterministicCTor",
"synchronisedCourseMutationRandomCTor",
"synchronisedCourseByDayMutationDeterministicCTor",
"synchronisedCourseByDayMutationRandomCTor",
"excessRunlengthMutationDeterministicCTor",
"excessRunlengthMutationRandomCTor",
"homogeneousStudentViewLessonMutationDeterministicCTor",
"homogeneousStudentViewLessonMutationRandomCTor",
"incompleteCourseMutationDeterministicCTor",
"incompleteCourseMutationRandomCTor",
"randomLessonMutationDeterministicCTor",
"randomLessonMutationRandomCTor",
"singletonStudentClassMutationDeterministicCTor",
"singletonStudentClassMutationRandomCTor",
"splitSessionMutationDeterministicCTor",
"splitSessionMutationRandomCTor",
"studentBodyCombinationMutationDeterministicCTor",
"studentBodyCombinationMutationRandomCTor",
"studentViewTimetableForDayMutationDeterministicCTor",
"studentViewTimetableForDayMutationRandomCTor",
"studentViewTimetableForWeekMutationDeterministicCTor",
"studentViewTimetableForWeekMutationRandomCTor",
"synchronousLessonMutationDeterministicCTor",
"synchronousLessonMutationRandomCTor",
randomLessonMutationNTrialsTag,
randomLessonMutationNTimeslotsTag,
studentViewTimetableForDayMutationNDaysTag,
studentViewTimetableForWeekMutationNTrialsTag,
studentViewTimetableForWeekMutationNTimeslotsTag,
fecundityDecayRatioTag,
minimumPopulationDiversityRatioTag,
nInitialScoutsTag
] [tableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
return {-to IO-Monad-} $ case strategiesRows of
[] -> Data.Default.def
[strategiesRow] -> case strategiesRow of
[
synchronisedCourseMutationDeterministicConstructorFecunditySql,
synchronisedCourseMutationRandomConstructorFecunditySql,
synchronisedCourseByDayMutationDeterministicConstructorFecunditySql,
synchronisedCourseByDayMutationRandomConstructorFecunditySql,
excessRunlengthMutationDeterministicConstructorFecunditySql,
excessRunlengthMutationRandomConstructorFecunditySql,
homogeneousStudentViewLessonMutationDeterministicConstructorFecunditySql,
homogeneousStudentViewLessonMutationRandomConstructorFecunditySql,
incompleteCourseMutationDeterministicConstructorFecunditySql,
incompleteCourseMutationRandomConstructorFecunditySql,
randomLessonMutationDeterministicConstructorFecunditySql,
randomLessonMutationRandomConstructorFecunditySql,
singletonStudentClassMutationDeterministicConstructorFecunditySql,
singletonStudentClassMutationRandomConstructorFecunditySql,
splitSessionMutationDeterministicConstructorFecunditySql,
splitSessionMutationRandomConstructorFecunditySql,
studentBodyCombinationMutationDeterministicConstructorFecunditySql,
studentBodyCombinationMutationRandomConstructorFecunditySql,
studentViewTimetableForDayMutationDeterministicConstructorFecunditySql,
studentViewTimetableForDayMutationRandomConstructorFecunditySql,
studentViewTimetableForWeekMutationDeterministicConstructorFecunditySql,
studentViewTimetableForWeekMutationRandomConstructorFecunditySql,
synchronousLessonMutationDeterministicConstructorFecunditySql,
synchronousLessonMutationRandomConstructorFecunditySql,
randomLessonMutationNTrialsSql,
randomLessonMutationNTimeslotsSql,
studentViewTimetableForDayMutationNDaysSql,
studentViewTimetableForWeekMutationNTrialsSql,
studentViewTimetableForWeekMutationNTimeslotsSql,
fecundityDecayRatioSql,
minimumPopulationDiversityRatioSql,
nInitialScoutsSql
] -> let
mkTimetableBreederFecundity x y = ExecutionConfiguration.TimetableBreederFecundity.mkTimetableBreederFecundity (
Data.Maybe.fromMaybe defaultDeterministicFecundity . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase.mkTimetableBreederFecundity:\tfailed to parse the value for the 'deterministic fecundity' read from the database; " . show
) id $ Database.HDBC.safeFromSql x
) (
Data.Maybe.fromMaybe defaultRandomFecundity . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase.mkTimetableBreederFecundity:\tfailed to parse the value for the 'random fecundity' read from the database; " . show
) id $ Database.HDBC.safeFromSql y
) where
(defaultDeterministicFecundity, defaultRandomFecundity) = ExecutionConfiguration.TimetableBreederFecundity.getDeterministicConstructorFecundity &&& ExecutionConfiguration.TimetableBreederFecundity.getRandomConstructorFecundity $ Data.Default.def
def = Data.Default.def
in MkEvolutionStrategies {
getSynchronisedCourseMutationFecundity = mkTimetableBreederFecundity synchronisedCourseMutationDeterministicConstructorFecunditySql synchronisedCourseMutationRandomConstructorFecunditySql,
getSynchronisedCourseByDayMutationFecundity = mkTimetableBreederFecundity synchronisedCourseByDayMutationDeterministicConstructorFecunditySql synchronisedCourseByDayMutationRandomConstructorFecunditySql,
getExcessRunlengthMutationFecundity = mkTimetableBreederFecundity excessRunlengthMutationDeterministicConstructorFecunditySql excessRunlengthMutationRandomConstructorFecunditySql,
getHomogeneousStudentViewLessonMutationFecundity = mkTimetableBreederFecundity homogeneousStudentViewLessonMutationDeterministicConstructorFecunditySql homogeneousStudentViewLessonMutationRandomConstructorFecunditySql,
getIncompleteCourseMutationFecundity = mkTimetableBreederFecundity incompleteCourseMutationDeterministicConstructorFecunditySql incompleteCourseMutationRandomConstructorFecunditySql,
getRandomLessonMutationFecundity = mkTimetableBreederFecundity randomLessonMutationDeterministicConstructorFecunditySql randomLessonMutationRandomConstructorFecunditySql,
getSingletonStudentClassMutationFecundity = mkTimetableBreederFecundity singletonStudentClassMutationDeterministicConstructorFecunditySql singletonStudentClassMutationRandomConstructorFecunditySql,
getSplitSessionMutationFecundity = mkTimetableBreederFecundity splitSessionMutationDeterministicConstructorFecunditySql splitSessionMutationRandomConstructorFecunditySql,
getStudentBodyCombinationMutationFecundity = mkTimetableBreederFecundity studentBodyCombinationMutationDeterministicConstructorFecunditySql studentBodyCombinationMutationRandomConstructorFecunditySql,
getStudentViewTimetableForDayMutationFecundity = mkTimetableBreederFecundity studentViewTimetableForDayMutationDeterministicConstructorFecunditySql studentViewTimetableForDayMutationRandomConstructorFecunditySql,
getStudentViewTimetableForWeekMutationFecundity = mkTimetableBreederFecundity studentViewTimetableForWeekMutationDeterministicConstructorFecunditySql studentViewTimetableForWeekMutationRandomConstructorFecunditySql,
getSynchronousLessonMutationFecundity = mkTimetableBreederFecundity synchronousLessonMutationDeterministicConstructorFecunditySql synchronousLessonMutationRandomConstructorFecunditySql,
getRandomLessonMutationNTrials = Data.Maybe.fromMaybe (getRandomLessonMutationNTrials def) . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows randomLessonMutationNTrialsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql randomLessonMutationNTrialsSql,
getRandomLessonMutationNTimeslots = Data.Maybe.fromMaybe (getRandomLessonMutationNTimeslots def) . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows randomLessonMutationNTimeslotsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql randomLessonMutationNTimeslotsSql,
getStudentViewTimetableForDayMutationMaybeNDays = either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows studentViewTimetableForDayMutationNDaysTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql studentViewTimetableForDayMutationNDaysSql, -- Returns 'Nothing' for SqlNull.
getStudentViewTimetableForWeekMutationNTrials = Data.Maybe.fromMaybe (getStudentViewTimetableForWeekMutationNTrials def) . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows studentViewTimetableForWeekMutationNTrialsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql studentViewTimetableForWeekMutationNTrialsSql,
getStudentViewTimetableForWeekMutationNTimeslots = Data.Maybe.fromMaybe (getStudentViewTimetableForWeekMutationNTimeslots def) . either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows studentViewTimetableForWeekMutationNTimeslotsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql studentViewTimetableForWeekMutationNTimeslotsSql,
getFecundityDecayRatio = Database.Selector.fromSqlFractional (getFecundityDecayRatio def) fecundityDecayRatioSql,
getMinimumPopulationDiversityRatio = Database.Selector.fromSqlFractional (getMinimumPopulationDiversityRatio def) minimumPopulationDiversityRatioSql,
getMaybeNInitialScouts = either (
error . showString "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tfailed to parse the value for " . shows nInitialScoutsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql nInitialScoutsSql -- Returns 'Nothing' for SqlNull.
}
_ -> error $ "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tunexpected number of columns=" ++ show (length strategiesRow) ++ " in row of table " ++ show tableName ++ "."
_ -> error $ "WeekDaze.ExecutionConfiguration.EvolutionStrategies.fromDatabase:\tunexpected number of rows=" ++ show (length strategiesRows) ++ " selected from table " ++ show tableName ++ "."
#endif /* USE_HDBC */
-- | Used to qualify XML.
tag :: String
tag = "evolutionStrategies"
-- | Used to qualify XML.
synchronisedCourseMutationTag :: String
synchronisedCourseMutationTag = "synchronisedCourseMutation"
-- | Used to qualify XML.
synchronisedCourseByDayMutationTag :: String
synchronisedCourseByDayMutationTag = "synchronisedCourseByDayMutation"
-- | Used to qualify XML.
excessRunlengthMutationTag :: String
excessRunlengthMutationTag = "excessRunlengthMutation"
-- | Used to qualify XML.
homogeneousStudentViewLessonMutationTag :: String
homogeneousStudentViewLessonMutationTag = "homogeneousStudentViewLessonMutation"
-- | Used to qualify XML.
incompleteCourseMutationTag :: String
incompleteCourseMutationTag = "incompleteCourseMutation"
-- | Used to qualify XML.
randomLessonMutationTag :: String
randomLessonMutationTag = "randomLessonMutation"
-- | Used to qualify XML.
singletonStudentClassMutationTag :: String
singletonStudentClassMutationTag = "singletonStudentClassMutation"
-- | Used to qualify XML.
splitSessionMutationTag :: String
splitSessionMutationTag = "splitSessionMutation"
-- | Used to qualify XML.
studentBodyCombinationMutationTag :: String
studentBodyCombinationMutationTag = "studentBodyCombinationMutation"
-- | Used to qualify XML.
studentViewTimetableForDayMutationTag :: String
studentViewTimetableForDayMutationTag = "studentViewTimetableForDayMutation"
-- | Used to qualify XML.
studentViewTimetableForWeekMutationTag :: String
studentViewTimetableForWeekMutationTag = "studentViewTimetableForWeekMutation"
-- | Used to qualify XML.
synchronousLessonMutationTag :: String
synchronousLessonMutationTag = "synchronousLessonMutation"
-- | Used to qualify SQL & XML.
randomLessonMutationNTrialsTag :: String
randomLessonMutationNTrialsTag = "randomLessonMutationNTrials"
-- | Used to qualify SQL & XML.
randomLessonMutationNTimeslotsTag :: String
randomLessonMutationNTimeslotsTag = "randomLessonMutationNTimeslots"
-- | Used to qualify SQL & XML.
studentViewTimetableForDayMutationNDaysTag :: String
studentViewTimetableForDayMutationNDaysTag = "studentViewTimetableForDayMutationNDays"
-- | Used to qualify SQL & XML.
studentViewTimetableForWeekMutationNTrialsTag :: String
studentViewTimetableForWeekMutationNTrialsTag = "studentViewTimetableForWeekMutationNTrials"
-- | Used to qualify SQL & XML.
studentViewTimetableForWeekMutationNTimeslotsTag :: String
studentViewTimetableForWeekMutationNTimeslotsTag = "studentViewTimetableForWeekMutationNTimeslots"
-- | Used to qualify XML.
fecundityDecayRatioTag :: String
fecundityDecayRatioTag = "fecundityDecayRatio"
-- | Used to qualify XML.
minimumPopulationDiversityRatioTag :: String
minimumPopulationDiversityRatioTag = "minimumPopulationDiversityRatio"
-- | Used to qualify XML.
nInitialScoutsTag :: String
nInitialScoutsTag = "nInitialScouts"
-- | Defines the various strategies used to evolve the /timetable/.
data EvolutionStrategies fecundityDecayRatio populationDiversityRatio = MkEvolutionStrategies {
getSynchronisedCourseMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking the /lesson/s of /synchronised course/s, before (deterministically, randomly) reconstructing.
getSynchronisedCourseByDayMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking synchronous groups of /lesson/s for /synchronised course/s, before (deterministically, randomly) reconstructing.
getExcessRunlengthMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking the terminal /lesson/s of excessive runlengths, before (deterministically, randomly) reconstructing.
getHomogeneousStudentViewLessonMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking groups of homogeneous /student-view lesson/s, before (deterministically, randomly) reconstructing.
getIncompleteCourseMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking all the /lesson/s for incomplete /course/s, in the /timetable/ for each /student/, before (deterministically, randomly) reconstructing.
getRandomLessonMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking random /lesson/s from the /timetable/, before (deterministically, randomly) reconstructing.
getSingletonStudentClassMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking /lesson/s whose /student-classes/ have been composed from a single /student-body/, before (deterministically, randomly) reconstructing.
getSplitSessionMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking runlengths of /lesson/s which occur in split sessions within a /day/, before (deterministically, randomly) reconstructing.
getStudentBodyCombinationMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking /lesson/s for a /course/, whose /student-classes/ have been composed from more than one combination of /student-bodies/, before (deterministically, randomly) reconstructing.
getStudentViewTimetableForDayMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking a whole day, from each /studentViewTimetableForWeek/ in isolation, before (deterministically, randomly) reconstructing.
getStudentViewTimetableForWeekMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking a small number of randomly selected /lesson/s, from each /studentViewTimetableForWeek/ in isolation, before (deterministically, randomly) reconstructing.
getSynchronousLessonMutationFecundity :: ExecutionConfiguration.TimetableBreederFecundity.TimetableBreederFecundity, -- ^ Whether to attempt to evolve the /timetable/, by unbooking groups of synchronous of heterogeneous /lesson/s.
getRandomLessonMutationNTrials :: Int, -- ^ The number of random trials to perform in 'getRandomLessonMutationFecundity'.
getRandomLessonMutationNTimeslots :: Size.NTimeslots, -- ^ The number of /time-slot/s to randomly unbook in 'getRandomLessonMutationFecundity'.
getStudentViewTimetableForDayMutationMaybeNDays :: Maybe Size.NDays, -- ^ The optional number of /day/s to unbook in 'getStudentViewTimetableForDayMutationFecundity'; if 'Nothing' then all possible values are tried.
getStudentViewTimetableForWeekMutationNTrials :: Int, -- ^ The number of random trials to perform in 'getStudentViewTimetableForWeekMutationFecundity'.
getStudentViewTimetableForWeekMutationNTimeslots :: Size.NTimeslots, -- ^ The number of /time-slot/s to randomly unbook in 'getStudentViewTimetableForWeekMutationFecundity'.
getFecundityDecayRatio :: fecundityDecayRatio, -- ^ The factor (in the closed unit-interval) by which the /fecundity/ of the breeding-program for future generations, is multiplied (& therefore reduced), when the /population-diversity ratio/ falls beneath 'getMinimumPopulationDiversityRatio'.
getMinimumPopulationDiversityRatio :: populationDiversityRatio, -- ^ The /population-diversity ratio/ (in the closed unit-interval), beneath which a reduction in the /fecundity/ of the breeding-program for future generations, by a factor of 'getFecundityDecayRatio', is triggered.
getMaybeNInitialScouts :: Maybe Size.NTimetables -- ^ The initial number of candidates to select from each generation in the evolution of the /timetable/; if 'Nothing' then all candidates measuring equal best & better than their parent, will be selected.
} deriving (Eq, Show)
instance (Fractional fecundityDecayRatio, Fractional populationDiversityRatio) => Data.Default.Default (EvolutionStrategies fecundityDecayRatio populationDiversityRatio) where
def = MkEvolutionStrategies {
getSynchronisedCourseMutationFecundity = Data.Default.def,
getSynchronisedCourseByDayMutationFecundity = Data.Default.def,
getExcessRunlengthMutationFecundity = Data.Default.def,
getHomogeneousStudentViewLessonMutationFecundity = Data.Default.def,
getIncompleteCourseMutationFecundity = Data.Default.def,
getRandomLessonMutationFecundity = Data.Default.def,
getSingletonStudentClassMutationFecundity = Data.Default.def,
getSplitSessionMutationFecundity = Data.Default.def,
getStudentBodyCombinationMutationFecundity = Data.Default.def,
getStudentViewTimetableForDayMutationFecundity = Data.Default.def,
getStudentViewTimetableForWeekMutationFecundity = Data.Default.def,
getSynchronousLessonMutationFecundity = Data.Default.def,
getRandomLessonMutationNTrials = 256,
getRandomLessonMutationNTimeslots = 3, -- Empirically found to be approximately optimal; though 4 may be better when the strategy is used in isolation.
getStudentViewTimetableForDayMutationMaybeNDays = Nothing, -- Try all valid values for the number of days.
getStudentViewTimetableForWeekMutationNTrials = 16, -- When multiplied by the number of student-bodies, should be approximately the required fecundity.
getStudentViewTimetableForWeekMutationNTimeslots = 4, -- Empirically found to be approximately optimal.
getFecundityDecayRatio = recip 2, -- Rather arbitrarily.
getMinimumPopulationDiversityRatio = recip 2, -- Rather arbitrarily.
getMaybeNInitialScouts = Nothing -- Select all candidates until the quality drops.
}
instance (
Fractional fecundityDecayRatio,
Fractional populationDiversityRatio,
HXT.XmlPickler fecundityDecayRatio,
HXT.XmlPickler populationDiversityRatio,
Ord fecundityDecayRatio,
Ord populationDiversityRatio,
Show fecundityDecayRatio,
Show populationDiversityRatio
) => HXT.XmlPickler (EvolutionStrategies fecundityDecayRatio populationDiversityRatio) where
xpickle = HXT.xpDefault defaultEvolutionStrategies . HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) -> let
evolutionStrategies = MkEvolutionStrategies a b c d e f g h i j k l m n o p q r s t -- Construct from a tuple.
in if ToolShed.SelfValidate.isValid evolutionStrategies
then evolutionStrategies
else error $ "WeekDaze.ExecutionConfiguration.EvolutionStrategies.xpickle:\t" ++ ToolShed.SelfValidate.getFirstError evolutionStrategies ++ ".",
\MkEvolutionStrategies {
getSynchronisedCourseMutationFecundity = synchronisedCourseMutationFecundity,
getSynchronisedCourseByDayMutationFecundity = synchronisedCourseByDayMutationFecundity,
getExcessRunlengthMutationFecundity = excessRunlengthMutationFecundity,
getHomogeneousStudentViewLessonMutationFecundity = homogeneousStudentViewLessonMutationFecundity,
getIncompleteCourseMutationFecundity = incompleteCourseMutationFecundity,
getRandomLessonMutationFecundity = randomLessonMutationFecundity,
getSingletonStudentClassMutationFecundity = singletonStudentClassMutationFecundity,
getSplitSessionMutationFecundity = splitSessionMutationFecundity,
getStudentBodyCombinationMutationFecundity = studentBodyCombinationMutationFecundity,
getStudentViewTimetableForDayMutationFecundity = studentViewTimetableForDayMutationFecundity,
getStudentViewTimetableForWeekMutationFecundity = studentViewTimetableForWeekMutationFecundity,
getSynchronousLessonMutationFecundity = synchronousLessonMutationFecundity,
getRandomLessonMutationNTrials = randomLessonMutationNTrials,
getRandomLessonMutationNTimeslots = randomLessonMutationNTimeslots,
getStudentViewTimetableForDayMutationMaybeNDays = studentViewTimetableForDayMutationMaybeNDays,
getStudentViewTimetableForWeekMutationNTrials = studentViewTimetableForWeekMutationNTrials,
getStudentViewTimetableForWeekMutationNTimeslots = studentViewTimetableForWeekMutationNTimeslots,
getFecundityDecayRatio = fecundityDecayRatio,
getMinimumPopulationDiversityRatio = minimumPopulationDiversityRatio,
getMaybeNInitialScouts = maybeNInitialScouts
} -> (
synchronisedCourseMutationFecundity,
synchronisedCourseByDayMutationFecundity,
excessRunlengthMutationFecundity,
homogeneousStudentViewLessonMutationFecundity,
incompleteCourseMutationFecundity,
randomLessonMutationFecundity,
singletonStudentClassMutationFecundity,
splitSessionMutationFecundity,
studentBodyCombinationMutationFecundity,
studentViewTimetableForDayMutationFecundity,
studentViewTimetableForWeekMutationFecundity,
synchronousLessonMutationFecundity,
randomLessonMutationNTrials,
randomLessonMutationNTimeslots,
studentViewTimetableForDayMutationMaybeNDays,
studentViewTimetableForWeekMutationNTrials,
studentViewTimetableForWeekMutationNTimeslots,
fecundityDecayRatio,
minimumPopulationDiversityRatio,
maybeNInitialScouts
) -- Deconstruct to a tuple.
) $ HXT.xp20Tuple (
HXT.xpElem synchronisedCourseMutationTag HXT.xpickle
) (
HXT.xpElem synchronisedCourseByDayMutationTag HXT.xpickle
) (
HXT.xpElem excessRunlengthMutationTag HXT.xpickle
) (
HXT.xpElem homogeneousStudentViewLessonMutationTag HXT.xpickle
) (
HXT.xpElem incompleteCourseMutationTag HXT.xpickle
) (
HXT.xpElem randomLessonMutationTag HXT.xpickle
) (
HXT.xpElem singletonStudentClassMutationTag HXT.xpickle
) (
HXT.xpElem splitSessionMutationTag HXT.xpickle
) (
HXT.xpElem studentBodyCombinationMutationTag HXT.xpickle
) (
HXT.xpElem studentViewTimetableForDayMutationTag HXT.xpickle
) (
HXT.xpElem studentViewTimetableForWeekMutationTag HXT.xpickle
) (
HXT.xpElem synchronousLessonMutationTag HXT.xpickle
) (
HXT.xpDefault (getRandomLessonMutationNTrials defaultEvolutionStrategies) $ HXT.xpAttr randomLessonMutationNTrialsTag HXT.xpInt
) (
HXT.xpDefault (getRandomLessonMutationNTimeslots defaultEvolutionStrategies) $ HXT.xpAttr randomLessonMutationNTimeslotsTag HXT.xpInt
) (
HXT.xpOption $ HXT.xpAttr studentViewTimetableForDayMutationNDaysTag HXT.xpInt
) (
HXT.xpDefault (getStudentViewTimetableForWeekMutationNTrials defaultEvolutionStrategies) $ HXT.xpAttr studentViewTimetableForWeekMutationNTrialsTag HXT.xpInt
) (
HXT.xpDefault (getStudentViewTimetableForWeekMutationNTimeslots defaultEvolutionStrategies) $ HXT.xpAttr studentViewTimetableForWeekMutationNTimeslotsTag HXT.xpInt
) (
getFecundityDecayRatio defaultEvolutionStrategies `HXT.xpDefault` HXT.xpAttr fecundityDecayRatioTag HXT.xpickle
) (
getMinimumPopulationDiversityRatio defaultEvolutionStrategies `HXT.xpDefault` HXT.xpAttr minimumPopulationDiversityRatioTag HXT.xpickle
) (
HXT.xpOption $ HXT.xpAttr nInitialScoutsTag HXT.xpInt
) where
defaultEvolutionStrategies = Data.Default.def
instance (
Num fecundityDecayRatio,
Num populationDiversityRatio,
Ord fecundityDecayRatio,
Ord populationDiversityRatio,
Show fecundityDecayRatio,
Show populationDiversityRatio
) => ToolShed.SelfValidate.SelfValidator (EvolutionStrategies fecundityDecayRatio populationDiversityRatio) where
getErrors evolutionStrategies = ToolShed.SelfValidate.extractErrors [
(
getRandomLessonMutationNTrials evolutionStrategies < 0,
show randomLessonMutationNTrialsTag ++ " can't be negative; " ++ show evolutionStrategies
), (
getRandomLessonMutationNTimeslots evolutionStrategies < 0,
show randomLessonMutationNTimeslotsTag ++ " can't be negative; " ++ show evolutionStrategies
), (
Data.Maybe.maybe False {-NDays unspecified-} (
\nDays -> any ($ nDays) [(< 0), (> Temporal.Day.nDaysPerWeek)]
) $ getStudentViewTimetableForDayMutationMaybeNDays evolutionStrategies,
show studentViewTimetableForDayMutationNDaysTag ++ " (where specified) must be in the closed interval [0, " ++ show Temporal.Day.nDaysPerWeek ++ "]; " ++ show evolutionStrategies
), (
getStudentViewTimetableForWeekMutationNTrials evolutionStrategies < 0,
show studentViewTimetableForWeekMutationNTrialsTag ++ " can't be negative; " ++ show evolutionStrategies
), (
getStudentViewTimetableForWeekMutationNTimeslots evolutionStrategies < 0,
show studentViewTimetableForWeekMutationNTimeslotsTag ++ " can't be negative; " ++ show evolutionStrategies
), (
any ($ getFecundityDecayRatio evolutionStrategies) [(< 0), (> 1)],
show fecundityDecayRatioTag ++ " must be within the closed unit-interval; " ++ show evolutionStrategies
), (
any ($ getMinimumPopulationDiversityRatio evolutionStrategies) [(< 0), (> 1)],
show minimumPopulationDiversityRatioTag ++ " must be within the closed unit-interval; " ++ show evolutionStrategies
), (
Data.Maybe.maybe False {-NInitialScouts unspecified-} (< 1) $ getMaybeNInitialScouts evolutionStrategies,
show nInitialScoutsTag ++ " can't be fewer than one"
)
]
instance (
Control.DeepSeq.NFData fecundityDecayRatio,
Control.DeepSeq.NFData populationDiversityRatio
) => Control.DeepSeq.NFData (EvolutionStrategies fecundityDecayRatio populationDiversityRatio) where
rnf MkEvolutionStrategies {
getSynchronisedCourseMutationFecundity = synchronisedCourseMutationFecundity,
getSynchronisedCourseByDayMutationFecundity = synchronisedCourseByDayMutationFecundity,
getExcessRunlengthMutationFecundity = excessRunlengthMutationFecundity,
getHomogeneousStudentViewLessonMutationFecundity = homogeneousStudentViewLessonMutationFecundity,
getIncompleteCourseMutationFecundity = incompleteCourseMutationFecundity,
getRandomLessonMutationFecundity = randomLessonMutationFecundity,
getSingletonStudentClassMutationFecundity = singletonStudentClassMutationFecundity,
getSplitSessionMutationFecundity = splitSessionMutationFecundity,
getStudentBodyCombinationMutationFecundity = studentBodyCombinationMutationFecundity,
getStudentViewTimetableForDayMutationFecundity = studentViewTimetableForDayMutationFecundity,
getStudentViewTimetableForWeekMutationFecundity = studentViewTimetableForWeekMutationFecundity,
getSynchronousLessonMutationFecundity = synchronousLessonMutationFecundity,
getRandomLessonMutationNTrials = randomLessonMutationNTrials,
getRandomLessonMutationNTimeslots = randomLessonMutationNTimeslots,
getStudentViewTimetableForDayMutationMaybeNDays = studentViewTimetableForDayMutationMaybeNDays,
getStudentViewTimetableForWeekMutationNTrials = studentViewTimetableForWeekMutationNTrials,
getStudentViewTimetableForWeekMutationNTimeslots = studentViewTimetableForWeekMutationNTimeslots,
getFecundityDecayRatio = fecundityDecayRatio,
getMinimumPopulationDiversityRatio = minimumPopulationDiversityRatio,
getMaybeNInitialScouts = maybeNInitialScouts
} = Control.DeepSeq.rnf (
[
synchronisedCourseMutationFecundity,
synchronisedCourseByDayMutationFecundity,
excessRunlengthMutationFecundity,
homogeneousStudentViewLessonMutationFecundity,
incompleteCourseMutationFecundity,
randomLessonMutationFecundity,
singletonStudentClassMutationFecundity,
splitSessionMutationFecundity,
studentBodyCombinationMutationFecundity,
studentViewTimetableForDayMutationFecundity,
studentViewTimetableForWeekMutationFecundity,
synchronousLessonMutationFecundity
],
randomLessonMutationNTrials,
randomLessonMutationNTimeslots,
studentViewTimetableForDayMutationMaybeNDays,
studentViewTimetableForWeekMutationNTrials,
studentViewTimetableForWeekMutationNTimeslots,
fecundityDecayRatio,
minimumPopulationDiversityRatio,
maybeNInitialScouts
)
-- | The type of any function which mutates an evolution-strategies.
type Mutator fecundityDecayRatio populationDiversityRatio = EvolutionStrategies fecundityDecayRatio populationDiversityRatio -> EvolutionStrategies fecundityDecayRatio populationDiversityRatio
-- Mutator.
zeroSynchronisedCourseMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroSynchronisedCourseMutationFecundity evolutionStrategies = evolutionStrategies {
getSynchronisedCourseMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroSynchronisedCourseByDayMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroSynchronisedCourseByDayMutationFecundity evolutionStrategies = evolutionStrategies {
getSynchronisedCourseByDayMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroExcessRunlengthMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroExcessRunlengthMutationFecundity evolutionStrategies = evolutionStrategies {
getExcessRunlengthMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroHomogeneousStudentViewLessonMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroHomogeneousStudentViewLessonMutationFecundity evolutionStrategies = evolutionStrategies {
getHomogeneousStudentViewLessonMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroIncompleteCourseMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroIncompleteCourseMutationFecundity evolutionStrategies = evolutionStrategies {
getIncompleteCourseMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroRandomLessonMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroRandomLessonMutationFecundity evolutionStrategies = evolutionStrategies {
getRandomLessonMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroSingletonStudentClassMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroSingletonStudentClassMutationFecundity evolutionStrategies = evolutionStrategies {
getSingletonStudentClassMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroSplitSessionMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroSplitSessionMutationFecundity evolutionStrategies = evolutionStrategies {
getSplitSessionMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroStudentBodyCombinationMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroStudentBodyCombinationMutationFecundity evolutionStrategies = evolutionStrategies {
getStudentBodyCombinationMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroStudentViewTimetableForDayMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroStudentViewTimetableForDayMutationFecundity evolutionStrategies = evolutionStrategies {
getStudentViewTimetableForDayMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroStudentViewTimetableForWeekMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroStudentViewTimetableForWeekMutationFecundity evolutionStrategies = evolutionStrategies {
getStudentViewTimetableForWeekMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- Mutator.
zeroSynchronousLessonMutationFecundity :: Mutator fecundityDecayRatio populationDiversityRatio
zeroSynchronousLessonMutationFecundity evolutionStrategies = evolutionStrategies {
getSynchronousLessonMutationFecundity = ExecutionConfiguration.TimetableBreederFecundity.zero
}
-- True when all /fecundities/ are zero.
areAllZero :: EvolutionStrategies fecundityDecayRatio populationDiversityRatio -> Bool
areAllZero evolutionStrategies = all (
(== ExecutionConfiguration.TimetableBreederFecundity.zero) . ($ evolutionStrategies)
) [
getSynchronisedCourseMutationFecundity,
getSynchronisedCourseByDayMutationFecundity,
getExcessRunlengthMutationFecundity,
getHomogeneousStudentViewLessonMutationFecundity,
getIncompleteCourseMutationFecundity,
getRandomLessonMutationFecundity,
getSingletonStudentClassMutationFecundity,
getSplitSessionMutationFecundity,
getStudentBodyCombinationMutationFecundity,
getStudentViewTimetableForDayMutationFecundity,
getStudentViewTimetableForWeekMutationFecundity,
getSynchronousLessonMutationFecundity
]