module BishBosh.Attribute.ColourScheme (
ColourScheme(
getDarkPieceColour,
getLightPieceColour,
getDarkSquareColour,
getLightSquareColour
),
tag,
) where
import qualified BishBosh.Attribute.PhysicalColour as Attribute.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
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"]]
data ColourScheme = MkColourScheme {
ColourScheme -> PhysicalColour
getDarkPieceColour :: Attribute.PhysicalColour.PhysicalColour,
ColourScheme -> PhysicalColour
getLightPieceColour :: Attribute.PhysicalColour.PhysicalColour,
ColourScheme -> PhysicalColour
getDarkSquareColour :: Attribute.PhysicalColour.PhysicalColour,
ColourScheme -> PhysicalColour
getLightSquareColour :: Attribute.PhysicalColour.PhysicalColour
} 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
Attribute.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
Attribute.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,
\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
)
) (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
mkColourScheme
:: Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> Attribute.PhysicalColour.PhysicalColour
-> 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.Attribute.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.Attribute.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.Attribute.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]