Location.hs

{-# LANGUAGE CPP #-}
{-
	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 attributes of a /location/, in terms of its; /capacity/, /facilities/, whether it's /off-site/, & its /availability/.

	* It refers to a more general concept than a merely a /class-room/, including for example, an assembly-hall or a games-field.
-}

module WeekDaze.Data.Location(
-- * Types
-- ** Type-synonyms
	FacilityName,
	FacilityNames,
	WastedResources,
	Locus,
-- ** Data-types
	Profile(
--		MkProfile,
		getCapacity,
		getFacilityNames,
		getAvailability,
		getCampus
	),
-- * Constants
--	tag,
	capacityTag,
--	facilitiesTag,
	facilityTypeIdTag,
	facilityNameTag,
	facilityValueTag,
--	facilityTypeTableName,
	defaultFacilityNames,
-- * Functions
	calculateWaste,
	calculateRelativeWaste,
	calculateRelativeUse,
#ifdef USE_HDBC
	findFacilityNameByFacilityTypeId,
#endif
-- ** Accessors
--	getWastedCapacity,
	getWastedFacilityNames,
-- ** Constructor
	mkProfile,
-- ** Predicates
	hasFacilities,
	isSuitable
) where

import			Control.Arrow((&&&), (***))
import qualified	Control.DeepSeq
import qualified	Data.Default
import qualified	Data.Set
import			Data.Set((\\))
import qualified	Text.XML.HXT.Arrow.Pickle	as HXT
import qualified	Text.XML.HXT.DOM.Util
import qualified	ToolShed.SelfValidate
import qualified	WeekDaze.Data.Resource		as Data.Resource
import qualified	WeekDaze.Size			as Size
import qualified	WeekDaze.Temporal.Availability	as Temporal.Availability

#ifdef USE_HDBC
import qualified	Database.HDBC
import qualified	Data.IntMap
import qualified	WeekDaze.Database.Selector	as Database.Selector

-- | Used to qualify XML.
facilityTypeTableName :: Database.Selector.TableName
facilityTypeTableName	= Database.Selector.tablePrefix ++ "facilityType"

-- | Queries the database to build a map of /facilityName/s by /facilityTypeId/.
findFacilityNameByFacilityTypeId
	:: Database.HDBC.IConnection	connection
	=> connection
	-> Database.HDBC.SqlValue	-- ^ ProjectId
	-> IO (Data.IntMap.IntMap FacilityName)
findFacilityNameByFacilityTypeId connection projectIdSql	= (
	Data.IntMap.fromList . map (
		\row -> case row of
			[facilityTypeIdSql, facilityNameSql]	-> (
				either (
					error . showString "WeekDaze.Data.Location.findFacilityNameByFacilityTypeId:\tfailed to parse the value for " . shows facilityTypeIdTag . showString " read from the database; " . show
				) id $ Database.HDBC.safeFromSql facilityTypeIdSql,
				Database.HDBC.fromSql facilityNameSql
			 ) -- Pair.
			_					-> error $ "WeekDaze.Data.Location.findFacilityNameByFacilityTypeId:\tunexpected number of columns=" ++ show (length row) ++ " in row of table " ++ show facilityTypeTableName ++ "."
	)
 ) `fmap` Database.Selector.select connection [facilityTypeIdTag, facilityNameTag] [facilityTypeTableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
#endif /* USE_HDBC */

-- | Used to qualify XML.
tag :: String
tag			= "locationProfile"

-- | Used to qualify SQL & XML.
capacityTag :: String
capacityTag		= "capacity"

-- | Used to qualify XML.
facilitiesTag :: String
facilitiesTag		= "facilities"

-- | Used to qualify SQL & XML.
facilityTypeIdTag :: String
facilityTypeIdTag	= "facilityTypeId"

-- | Used to qualify SQL & XML.
facilityNameTag :: String
facilityNameTag		= "facilityName"

-- | Used to qualify XML.
facilityValueTag :: String
facilityValueTag	= "value"

{- |
	* A /subject/-specific /facility/, e.g. "desks", "musical instruments", or "goal-posts".

	* The specific string used to designate these must match those defined for /course/s.
-}
type FacilityName	= String

-- | The set of facility-names advertised by a /location/.
type FacilityNames	= Data.Set.Set FacilityName

-- | The default value for /facilityNames/.
defaultFacilityNames :: FacilityNames
defaultFacilityNames	= Data.Set.empty

-- | Aggregates the attributes of a /location/, which a generalisation of a room, since it also includes games-fields.
data Profile campus	= MkProfile {
	getCapacity		:: Size.NStudents,			-- ^ Typically the number of seats. N.B.: though the games-field has a rather ill-defined /capacity/, the changing-rooms don't.
	getFacilityNames	:: FacilityNames,			-- ^ The /location/ may advertise /facilities/ to support specific activities.
	getAvailability		:: Temporal.Availability.Availability,	-- ^ The /location/ may have a periodic /availability/.
	getCampus		:: campus				-- ^ Proximate /locations/ are grouped into /campus/es, between which intra-day migration is trivial.
} deriving (Eq, Show)

instance Show campus => ToolShed.SelfValidate.SelfValidator (Profile campus) where
	getErrors profile@MkProfile {
		getAvailability	= availability
	}
		| not $ ToolShed.SelfValidate.isValid availability	= ToolShed.SelfValidate.getErrors availability
		| otherwise						= ToolShed.SelfValidate.extractErrors [
			(getCapacity profile <= 0,	show capacityTag ++ " must exceed zero; " ++ show profile)
		]

instance Data.Resource.Resource (Profile campus) where
	getAvailability	= getAvailability

instance (
	Data.Default.Default			campus,
	Eq					campus,
	HXT.XmlPickler				campus,
	Show					campus
 ) => HXT.XmlPickler (Profile campus) where
	xpickle	= HXT.xpElem tag . HXT.xpWrap (
		Text.XML.HXT.DOM.Util.uncurry4 mkProfile,	-- Construct from a quadruple.
		\MkProfile {
			getCapacity		= capacity,
			getFacilityNames	= facilityNames,
			getAvailability		= availability,
			getCampus		= campus
		} -> (
			capacity,
			facilityNames,
			availability,
			campus
		) -- Deconstruct to a quadruple.
	 ) $ HXT.xp4Tuple (
		HXT.xpAttr capacityTag HXT.xpInt
	 ) (
		HXT.xpDefault defaultFacilityNames . HXT.xpElem facilitiesTag . HXT.xpWrap (
			Data.Set.fromList,	-- Construct from a List.
			Data.Set.toList		-- Deconstruct to a List.
		) . HXT.xpList1 {-the default is null-} . HXT.xpElem facilityNameTag $ HXT.xpTextAttr facilityValueTag {-can't be null-}
	 ) (
		HXT.xpDefault Data.Default.def HXT.xpickle	-- Availability.
	 ) (
		HXT.xpDefault Data.Default.def HXT.xpickle	-- Campus.
	 )

instance Control.DeepSeq.NFData	campus => Control.DeepSeq.NFData (Profile campus) where
	rnf (MkProfile x0 x1 x2 x3)	= Control.DeepSeq.rnf (x0, x1, x2, x3)

-- | Smart constructor.
mkProfile
	:: Show campus
	=> Size.NStudents
	-> FacilityNames
	-> Temporal.Availability.Availability
	-> campus
	-> Profile campus
mkProfile capacity facilityNames availability campus
	| ToolShed.SelfValidate.isValid profile	= profile
	| otherwise				= error $ "WeekDaze.Data.Location.mkProfile:\t" ++ ToolShed.SelfValidate.getFirstError profile ++ "."
	where
		profile	= MkProfile capacity facilityNames availability campus

{- |
	* True if the 'Profile' meets or exceeds the specified criteria.

	* Takes no account of either /availability/ or /campus/.
-}
isSuitable
	:: Size.NStudents
	-> FacilityNames
	-> Profile campus
	-> Bool
isSuitable requiredCapacity requiredFacilityNames profile	= requiredCapacity <= getCapacity profile && requiredFacilityNames `Data.Set.isSubsetOf` getFacilityNames profile

-- | True if the /location/ has some facilities.
hasFacilities :: Profile campus -> Bool
hasFacilities	= not . Data.Set.null . getFacilityNames

-- | A measure of the /capacity/ & specific /facilities/, which are available at a /location/, but are unused in some context.
type WastedResources	= (Size.NStudents, FacilityNames)

-- | Accessor.
getWastedCapacity :: WastedResources -> Size.NStudents
getWastedCapacity	= fst

-- | Accessor.
getWastedFacilityNames :: WastedResources -> FacilityNames
getWastedFacilityNames	= snd

{- |
	* Measures the excess /capacity/ & unused /facilities/, of the specified /location/.

	* All /facilities/ are considered equal.

	* CAVEAT: each /location/ must have previously passed 'isSuitable'.
-}
calculateWaste
	:: Size.NStudents	-- ^ The required /capacity/.
	-> FacilityNames	-- ^ The required /facilities/.
	-> Profile campus	-- ^ The /location/ whose /resources/ are to be compared with requirements.
	-> WastedResources
calculateWaste requiredCapacity requiredFacilities	= subtract requiredCapacity . getCapacity &&& (\\ requiredFacilities) . getFacilityNames

-- | Convert 'WastedResources' to a pair of ratios.
calculateRelativeWaste :: Fractional relativeWaste => Profile campus -> WastedResources -> (relativeWaste, relativeWaste)
calculateRelativeWaste profile wastedResources	= (
	fromIntegral (getWastedCapacity wastedResources) / fromIntegral (getCapacity profile),
	let
		nFacilities	= Data.Set.size $ getFacilityNames profile
	in if nFacilities == 0
		then 0	-- If the location hasn't any facilities, none can be wasted.
		else fromIntegral (Data.Set.size $ getWastedFacilityNames wastedResources) / fromIntegral nFacilities
 ) -- Pair.

-- | The relative extent to which /capacity/ & /facilities/ are used.
calculateRelativeUse :: Fractional relativeUse => Profile campus -> WastedResources -> (relativeUse, relativeUse)
calculateRelativeUse profile	= ((1 -) *** (1 -)) . calculateRelativeWaste profile

-- | A collection of distinct /location-ids/.
type Locus locationId	= Data.Set.Set locationId