TimetableBreederFecundity.hs

{-
	Copyright (C) 2013-2015 Dr. Alistair Ward

	This file is part of WeekDaze.

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

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

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

 [@DESCRIPTION@]

	* Defines the 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; <https://en.wikipedia.org/wiki/Commutative_property>.
-}
(>*<) :: 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