{-
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 .
-}
{- |
[@AUTHOR@] Dr. Alistair Ward
[@DESCRIPTION@]
* Defines the fecundity of two independent instances of a particular evolution-strategy;
one composed from a /deterministic timetable-constructor/ & the other from a /random timetable-constructor/.
* It quantifies the number of candidate solutions bred at each generation of the evolution of the /timetable/.
* If the fecundity is zero, then the corresponding strategy is effectively switched-off.
-}
module WeekDaze.ExecutionConfiguration.TimetableBreederFecundity(
-- * Types
-- ** Type-synonyms
Fecundity,
-- ** Data-types
TimetableBreederFecundity(
-- MkTimetableBreederFecundity,
getDeterministicConstructorFecundity,
getRandomConstructorFecundity
),
-- * Constants
-- tag,
-- deterministicConstructorFecundityTag,
-- randomConstructorFecundityTag,
zero,
-- * Functions
-- ** Constructor
mkTimetableBreederFecundity,
-- ** Operators
(>*<)
) where
import Control.Arrow((&&&))
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
infixl 7 >*< -- Like (*).
-- | Used to qualify XML.
tag :: String
tag = "timetableBreederFecundity"
-- | Used to qualify XML.
deterministicConstructorFecundityTag :: String
deterministicConstructorFecundityTag = "deterministicConstructorFecundity"
-- | Used to qualify XML.
randomConstructorFecundityTag :: String
randomConstructorFecundityTag = "randomConstructorFecundity"
-- | The number of candidate solutions to breed in any one generation of the evolution of a /timetable/.
type Fecundity = Int
-- | Describes a pair of boolean values, which independently switch on or off.
data TimetableBreederFecundity = MkTimetableBreederFecundity {
getDeterministicConstructorFecundity :: Fecundity, -- ^ The /fecundity/ to use when breeding a /timetable/ for subsequent deterministic reconstruction.
getRandomConstructorFecundity :: Fecundity -- ^ The /fecundity/ to use when breeding a /timetable/ for subsequent random reconstruction.
} deriving Eq
instance Read TimetableBreederFecundity where
readsPrec _ = map (Control.Arrow.first $ uncurry mkTimetableBreederFecundity) . reads
instance Show TimetableBreederFecundity where
showsPrec _ = shows . (getDeterministicConstructorFecundity &&& getRandomConstructorFecundity)
instance Data.Default.Default TimetableBreederFecundity where
def = zero
instance ToolShed.SelfValidate.SelfValidator TimetableBreederFecundity where
getErrors timetableBreederFecundity = ToolShed.SelfValidate.extractErrors [
(
any ((< 0) . ($ timetableBreederFecundity)) [getDeterministicConstructorFecundity, getRandomConstructorFecundity],
"fecundity can't be negative; " ++ show timetableBreederFecundity
) -- Pair.
]
instance HXT.XmlPickler TimetableBreederFecundity where
xpickle = HXT.xpDefault defaultTimetableBreederFecundity . HXT.xpElem tag . HXT.xpWrap (
uncurry mkTimetableBreederFecundity, -- Construct from a Pair.
getDeterministicConstructorFecundity &&& getRandomConstructorFecundity -- Deconstruct to a Pair.
) $ (
getDeterministicConstructorFecundity defaultTimetableBreederFecundity `HXT.xpDefault` HXT.xpAttr deterministicConstructorFecundityTag HXT.xpInt
) `HXT.xpPair` (
getRandomConstructorFecundity defaultTimetableBreederFecundity `HXT.xpDefault` HXT.xpAttr randomConstructorFecundityTag HXT.xpInt
) where
defaultTimetableBreederFecundity = Data.Default.def
instance Control.DeepSeq.NFData TimetableBreederFecundity where
rnf = Control.DeepSeq.rnf . (getDeterministicConstructorFecundity &&& getRandomConstructorFecundity)
-- | Smart constructor.
mkTimetableBreederFecundity :: Fecundity -> Fecundity -> TimetableBreederFecundity
mkTimetableBreederFecundity deterministicConstructorFecundity randomConstructorFecundity
| ToolShed.SelfValidate.isValid fecundity = fecundity
| otherwise = error $ "WeekDaze.ExecutionConfiguration.TimetableBreederFecundity.mkTimetableBreederFecundity:\t" ++ ToolShed.SelfValidate.getFirstError fecundity ++ "."
where
fecundity = MkTimetableBreederFecundity deterministicConstructorFecundity randomConstructorFecundity
-- | Constant.
zero :: TimetableBreederFecundity
zero = mkTimetableBreederFecundity 0 0
{- |
* Combine two 'TimetableBreederFecundity's, returning the geometric mean of the individual 'Fecundity's.
* The operation is commutative; .
-}
(>*<) :: TimetableBreederFecundity -> TimetableBreederFecundity -> TimetableBreederFecundity
MkTimetableBreederFecundity dl rl >*< MkTimetableBreederFecundity dr rr = mkTimetableBreederFecundity (round $ getGeometricMean dl dr) (round $ getGeometricMean rl rr) where
getGeometricMean :: Fecundity -> Fecundity -> Double
getGeometricMean x y = sqrt . fromIntegral $ x * y