{-
	Copyright (C) 2018 Dr. Alistair Ward

	This file is part of BishBosh.

	BishBosh 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.

	BishBosh 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 BishBosh.  If not, see <http://www.gnu.org/licenses/>.
-}
{- |
 [@AUTHOR@]	Dr. Alistair Ward

 [@DESCRIPTION@]	Defines the physical colour used to represent each component of the board.
-}

module BishBosh.Colour.ColourScheme (
-- * Types
-- ** Data-types
	ColourScheme(
--		MkColourScheme,
		getDarkPieceColour,
		getLightPieceColour,
		getDarkSquareColour,
		getLightSquareColour
	),
-- * Constants
	tag,
--	darkSquareColourTag,
--	lightSquareColourTag,
--	darkPieceColourTag,
--	lightPieceColourTag,
-- * Functions
-- ** Constructor
--	mkColourScheme
) where

import qualified	BishBosh.Colour.PhysicalColour	as Colour.PhysicalColour
import qualified	BishBosh.Data.Exception		as Data.Exception
import qualified	BishBosh.Property.Opposable	as Property.Opposable
import qualified	BishBosh.Text.ShowList		as Text.ShowList
import qualified	Control.Arrow
import qualified	Control.DeepSeq
import qualified	Control.Exception
import qualified	Data.Default
import qualified	Text.XML.HXT.Arrow.Pickle	as HXT

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

darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag :: String
[String
darkPieceColourTag, String
darkSquareColourTag, String
lightPieceColourTag, String
lightSquareColourTag]	= [String -> ShowS
showString String
brightness ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
component String
"Colour" | String
brightness <- [String
"dark", String
"light"], String
component <- [String
"Piece", String
"Square"]] -- List-comprehension.

-- | Defines the command-line options.
data ColourScheme	= MkColourScheme {
	ColourScheme -> PhysicalColour
getDarkPieceColour	:: Colour.PhysicalColour.PhysicalColour,	-- ^ The physical colour of the dark pieces.
	ColourScheme -> PhysicalColour
getLightPieceColour	:: Colour.PhysicalColour.PhysicalColour,	-- ^ The physical colour of the light pieces.
	ColourScheme -> PhysicalColour
getDarkSquareColour	:: Colour.PhysicalColour.PhysicalColour,	-- ^ The physical colour of the dark squares of the board.
	ColourScheme -> PhysicalColour
getLightSquareColour	:: Colour.PhysicalColour.PhysicalColour		-- ^ The physical colour of the light squares of the board.
} deriving ColourScheme -> ColourScheme -> Bool
(ColourScheme -> ColourScheme -> Bool)
-> (ColourScheme -> ColourScheme -> Bool) -> Eq ColourScheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ColourScheme -> ColourScheme -> Bool
$c/= :: ColourScheme -> ColourScheme -> Bool
== :: ColourScheme -> ColourScheme -> Bool
$c== :: ColourScheme -> ColourScheme -> Bool
Eq

instance Control.DeepSeq.NFData ColourScheme where
	rnf :: ColourScheme -> ()
rnf MkColourScheme {
		getDarkPieceColour :: ColourScheme -> PhysicalColour
getDarkPieceColour	= PhysicalColour
darkPieceColour,
		getLightPieceColour :: ColourScheme -> PhysicalColour
getLightPieceColour	= PhysicalColour
lightPieceColour,
		getDarkSquareColour :: ColourScheme -> PhysicalColour
getDarkSquareColour	= PhysicalColour
darkSquareColour,
		getLightSquareColour :: ColourScheme -> PhysicalColour
getLightSquareColour	= PhysicalColour
lightSquareColour
	} = (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
-> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf (
		PhysicalColour
darkPieceColour,
		PhysicalColour
lightPieceColour,
		PhysicalColour
darkSquareColour,
		PhysicalColour
lightSquareColour
	 )

instance Show ColourScheme where
	showsPrec :: Int -> ColourScheme -> ShowS
showsPrec Int
_ MkColourScheme {
		getDarkPieceColour :: ColourScheme -> PhysicalColour
getDarkPieceColour	= PhysicalColour
darkPieceColour,
		getLightPieceColour :: ColourScheme -> PhysicalColour
getLightPieceColour	= PhysicalColour
lightPieceColour,
		getDarkSquareColour :: ColourScheme -> PhysicalColour
getDarkSquareColour	= PhysicalColour
darkSquareColour,
		getLightSquareColour :: ColourScheme -> PhysicalColour
getLightSquareColour	= PhysicalColour
lightSquareColour
	} = [(String, ShowS)] -> ShowS
Text.ShowList.showsAssociationList' ([(String, ShowS)] -> ShowS) -> [(String, ShowS)] -> ShowS
forall a b. (a -> b) -> a -> b
$ ((String, PhysicalColour) -> (String, ShowS))
-> [(String, PhysicalColour)] -> [(String, ShowS)]
forall a b. (a -> b) -> [a] -> [b]
map ((PhysicalColour -> ShowS)
-> (String, PhysicalColour) -> (String, ShowS)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Control.Arrow.second PhysicalColour -> ShowS
forall a. Show a => a -> ShowS
shows) [
		(
			String
darkPieceColourTag,
			PhysicalColour
darkPieceColour
		), (
			String
lightPieceColourTag,
			PhysicalColour
lightPieceColour
		), (
			String
darkSquareColourTag,
			PhysicalColour
darkSquareColour
		), (
			String
lightSquareColourTag,
			PhysicalColour
lightSquareColour
		)
	 ]

instance Data.Default.Default ColourScheme where
	def :: ColourScheme
def = MkColourScheme :: PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> ColourScheme
MkColourScheme {
		getDarkPieceColour :: PhysicalColour
getDarkPieceColour	= PhysicalColour
Colour.PhysicalColour.blue,
		getLightPieceColour :: PhysicalColour
getLightPieceColour	= PhysicalColour -> PhysicalColour
forall a. Opposable a => a -> a
Property.Opposable.getOpposite (PhysicalColour -> PhysicalColour)
-> PhysicalColour -> PhysicalColour
forall a b. (a -> b) -> a -> b
$ ColourScheme -> PhysicalColour
getDarkPieceColour ColourScheme
forall a. Default a => a
Data.Default.def,
		getDarkSquareColour :: PhysicalColour
getDarkSquareColour	= PhysicalColour
Colour.PhysicalColour.black,
		getLightSquareColour :: PhysicalColour
getLightSquareColour	= PhysicalColour -> PhysicalColour
forall a. Opposable a => a -> a
Property.Opposable.getOpposite (PhysicalColour -> PhysicalColour)
-> PhysicalColour -> PhysicalColour
forall a b. (a -> b) -> a -> b
$ ColourScheme -> PhysicalColour
getDarkSquareColour ColourScheme
forall a. Default a => a
Data.Default.def
	}

instance HXT.XmlPickler ColourScheme where
	xpickle :: PU ColourScheme
xpickle	= String -> PU ColourScheme -> PU ColourScheme
forall a. String -> PU a -> PU a
HXT.xpElem String
tag (PU ColourScheme -> PU ColourScheme)
-> (PU
      (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
    -> PU ColourScheme)
-> PU
     (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
-> PU ColourScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
 -> ColourScheme,
 ColourScheme
 -> (PhysicalColour, PhysicalColour, PhysicalColour,
     PhysicalColour))
-> PU
     (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
-> PU ColourScheme
forall a b. (a -> b, b -> a) -> PU a -> PU b
HXT.xpWrap (
		\(PhysicalColour
a, PhysicalColour
b, PhysicalColour
c, PhysicalColour
d) -> PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> ColourScheme
mkColourScheme PhysicalColour
a PhysicalColour
b PhysicalColour
c PhysicalColour
d,	-- Construct.
		\MkColourScheme {
			getDarkPieceColour :: ColourScheme -> PhysicalColour
getDarkPieceColour	= PhysicalColour
darkPieceColour,
			getLightPieceColour :: ColourScheme -> PhysicalColour
getLightPieceColour	= PhysicalColour
lightPieceColour,
			getDarkSquareColour :: ColourScheme -> PhysicalColour
getDarkSquareColour	= PhysicalColour
darkSquareColour,
			getLightSquareColour :: ColourScheme -> PhysicalColour
getLightSquareColour	= PhysicalColour
lightSquareColour
		} -> (
			PhysicalColour
darkPieceColour,
			PhysicalColour
lightPieceColour,
			PhysicalColour
darkSquareColour,
			PhysicalColour
lightSquareColour
		) -- Deconstruct.
	 ) (PU
   (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
 -> PU ColourScheme)
-> PU
     (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
-> PU ColourScheme
forall a b. (a -> b) -> a -> b
$ PU PhysicalColour
-> PU PhysicalColour
-> PU PhysicalColour
-> PU PhysicalColour
-> PU
     (PhysicalColour, PhysicalColour, PhysicalColour, PhysicalColour)
forall a b c d. PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)
HXT.xp4Tuple (
		ColourScheme -> PhysicalColour
getDarkPieceColour ColourScheme
def PhysicalColour -> PU PhysicalColour -> PU PhysicalColour
forall a. Eq a => a -> PU a -> PU a
`HXT.xpDefault` String -> PU PhysicalColour -> PU PhysicalColour
forall a. String -> PU a -> PU a
HXT.xpAttr String
darkPieceColourTag PU PhysicalColour
forall a. XmlPickler a => PU a
HXT.xpickle
	 ) (
		ColourScheme -> PhysicalColour
getLightPieceColour ColourScheme
def PhysicalColour -> PU PhysicalColour -> PU PhysicalColour
forall a. Eq a => a -> PU a -> PU a
`HXT.xpDefault` String -> PU PhysicalColour -> PU PhysicalColour
forall a. String -> PU a -> PU a
HXT.xpAttr String
lightPieceColourTag PU PhysicalColour
forall a. XmlPickler a => PU a
HXT.xpickle
	 ) (
		ColourScheme -> PhysicalColour
getDarkSquareColour ColourScheme
def PhysicalColour -> PU PhysicalColour -> PU PhysicalColour
forall a. Eq a => a -> PU a -> PU a
`HXT.xpDefault` String -> PU PhysicalColour -> PU PhysicalColour
forall a. String -> PU a -> PU a
HXT.xpAttr String
darkSquareColourTag PU PhysicalColour
forall a. XmlPickler a => PU a
HXT.xpickle
	 ) (
		ColourScheme -> PhysicalColour
getLightSquareColour ColourScheme
def PhysicalColour -> PU PhysicalColour -> PU PhysicalColour
forall a. Eq a => a -> PU a -> PU a
`HXT.xpDefault` String -> PU PhysicalColour -> PU PhysicalColour
forall a. String -> PU a -> PU a
HXT.xpAttr String
lightSquareColourTag PU PhysicalColour
forall a. XmlPickler a => PU a
HXT.xpickle
	 ) where
		def :: ColourScheme
		def :: ColourScheme
def	= ColourScheme
forall a. Default a => a
Data.Default.def

-- | Smart constructor.
mkColourScheme
	:: Colour.PhysicalColour.PhysicalColour	-- ^ Dark piece.
	-> Colour.PhysicalColour.PhysicalColour	-- ^ Light piece.
	-> Colour.PhysicalColour.PhysicalColour	-- ^ Dark square.
	-> Colour.PhysicalColour.PhysicalColour	-- ^ Light square.
	-> ColourScheme
mkColourScheme :: PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> ColourScheme
mkColourScheme PhysicalColour
darkPieceColour PhysicalColour
lightPieceColour PhysicalColour
darkSquareColour PhysicalColour
lightSquareColour
	| PhysicalColour
darkPieceColour PhysicalColour -> [PhysicalColour] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PhysicalColour]
bgColours		= Exception -> ColourScheme
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> ColourScheme)
-> (String -> Exception) -> String -> ColourScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkIncompatibleData (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Colour.ColourScheme.mkColourScheme:\t" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
darkPieceColourTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalColour -> ShowS
forall a. Show a => a -> ShowS
shows PhysicalColour
darkPieceColour ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" must differ from the physical colour of both squares; " (String -> ColourScheme) -> String -> ColourScheme
forall a b. (a -> b) -> a -> b
$ [PhysicalColour] -> ShowS
forall a. Show a => a -> ShowS
shows [PhysicalColour]
bgColours String
"."
	| PhysicalColour
lightPieceColour PhysicalColour -> [PhysicalColour] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PhysicalColour]
bgColours		= Exception -> ColourScheme
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> ColourScheme)
-> (String -> Exception) -> String -> ColourScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkIncompatibleData (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Colour.ColourScheme.mkColourScheme:\t" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
lightPieceColourTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PhysicalColour -> ShowS
forall a. Show a => a -> ShowS
shows PhysicalColour
lightPieceColour ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" must differ from the physical colour of both squares; " (String -> ColourScheme) -> String -> ColourScheme
forall a b. (a -> b) -> a -> b
$ [PhysicalColour] -> ShowS
forall a. Show a => a -> ShowS
shows [PhysicalColour]
bgColours String
"."
	| PhysicalColour
darkSquareColour PhysicalColour -> PhysicalColour -> Bool
forall a. Eq a => a -> a -> Bool
== PhysicalColour
lightSquareColour		= Exception -> ColourScheme
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> ColourScheme)
-> (String -> Exception) -> String -> ColourScheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkIncompatibleData (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.Colour.ColourScheme.mkColourScheme:\tthe physical colours of " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
lightSquareColourTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" & " (String -> ColourScheme) -> String -> ColourScheme
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
darkSquareColourTag String
", must differ."
	| Bool
otherwise					= MkColourScheme :: PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> PhysicalColour
-> ColourScheme
MkColourScheme {
		getDarkPieceColour :: PhysicalColour
getDarkPieceColour	= PhysicalColour
darkPieceColour,
		getLightPieceColour :: PhysicalColour
getLightPieceColour	= PhysicalColour
lightPieceColour,
		getDarkSquareColour :: PhysicalColour
getDarkSquareColour	= PhysicalColour
darkSquareColour,
		getLightSquareColour :: PhysicalColour
getLightSquareColour	= PhysicalColour
lightSquareColour
	}
	where
		bgColours :: [PhysicalColour]
bgColours	= [PhysicalColour
darkSquareColour, PhysicalColour
lightSquareColour]