{-# LANGUAGE LambdaCase #-}
{-
	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 data-type which represents the logical (rather than physical) colour of /piece/s & (conceptually) of the two players.

	* N.B.: conceptually different from the logical colour of squares on the board.
-}

module BishBosh.Colour.LogicalColour(
-- * Types
-- ** Type-synonyms
	ArrayByLogicalColour,
-- ** Data-types
	LogicalColour(..),
-- * Constants
	tag,
	range,
	nDistinctLogicalColours,
-- * Functions
-- ** Constructor
	listArrayByLogicalColour,
	arrayByLogicalColour,
-- ** Predicates
	isBlack
--	isWhite
) where

import qualified	BishBosh.Property.ExtendedPositionDescription	as Property.ExtendedPositionDescription
import qualified	BishBosh.Property.FixedMembership		as Property.FixedMembership
import qualified	BishBosh.Property.ForsythEdwards		as Property.ForsythEdwards
import qualified	BishBosh.Property.Opposable			as Property.Opposable
import qualified	BishBosh.Type.Count				as Type.Count
import qualified	Control.DeepSeq
import qualified	Control.Exception
import qualified	Data.Array.IArray
import qualified	Data.List.Extra
import qualified	Text.XML.HXT.Arrow.Pickle			as HXT
import qualified	Text.XML.HXT.Arrow.Pickle.Schema

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

-- | The sum-type of /logical colour/s associated with either a piece, or (conceptually) a player.
data LogicalColour
	= Black
	| White
	deriving (
		LogicalColour
LogicalColour -> LogicalColour -> Bounded LogicalColour
forall a. a -> a -> Bounded a
maxBound :: LogicalColour
$cmaxBound :: LogicalColour
minBound :: LogicalColour
$cminBound :: LogicalColour
Bounded,
		Int -> LogicalColour
LogicalColour -> Int
LogicalColour -> [LogicalColour]
LogicalColour -> LogicalColour
LogicalColour -> LogicalColour -> [LogicalColour]
LogicalColour -> LogicalColour -> LogicalColour -> [LogicalColour]
(LogicalColour -> LogicalColour)
-> (LogicalColour -> LogicalColour)
-> (Int -> LogicalColour)
-> (LogicalColour -> Int)
-> (LogicalColour -> [LogicalColour])
-> (LogicalColour -> LogicalColour -> [LogicalColour])
-> (LogicalColour -> LogicalColour -> [LogicalColour])
-> (LogicalColour
    -> LogicalColour -> LogicalColour -> [LogicalColour])
-> Enum LogicalColour
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: LogicalColour -> LogicalColour -> LogicalColour -> [LogicalColour]
$cenumFromThenTo :: LogicalColour -> LogicalColour -> LogicalColour -> [LogicalColour]
enumFromTo :: LogicalColour -> LogicalColour -> [LogicalColour]
$cenumFromTo :: LogicalColour -> LogicalColour -> [LogicalColour]
enumFromThen :: LogicalColour -> LogicalColour -> [LogicalColour]
$cenumFromThen :: LogicalColour -> LogicalColour -> [LogicalColour]
enumFrom :: LogicalColour -> [LogicalColour]
$cenumFrom :: LogicalColour -> [LogicalColour]
fromEnum :: LogicalColour -> Int
$cfromEnum :: LogicalColour -> Int
toEnum :: Int -> LogicalColour
$ctoEnum :: Int -> LogicalColour
pred :: LogicalColour -> LogicalColour
$cpred :: LogicalColour -> LogicalColour
succ :: LogicalColour -> LogicalColour
$csucc :: LogicalColour -> LogicalColour
Enum,
		LogicalColour -> LogicalColour -> Bool
(LogicalColour -> LogicalColour -> Bool)
-> (LogicalColour -> LogicalColour -> Bool) -> Eq LogicalColour
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogicalColour -> LogicalColour -> Bool
$c/= :: LogicalColour -> LogicalColour -> Bool
== :: LogicalColour -> LogicalColour -> Bool
$c== :: LogicalColour -> LogicalColour -> Bool
Eq,
		Eq LogicalColour
Eq LogicalColour
-> (LogicalColour -> LogicalColour -> Ordering)
-> (LogicalColour -> LogicalColour -> Bool)
-> (LogicalColour -> LogicalColour -> Bool)
-> (LogicalColour -> LogicalColour -> Bool)
-> (LogicalColour -> LogicalColour -> Bool)
-> (LogicalColour -> LogicalColour -> LogicalColour)
-> (LogicalColour -> LogicalColour -> LogicalColour)
-> Ord LogicalColour
LogicalColour -> LogicalColour -> Bool
LogicalColour -> LogicalColour -> Ordering
LogicalColour -> LogicalColour -> LogicalColour
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogicalColour -> LogicalColour -> LogicalColour
$cmin :: LogicalColour -> LogicalColour -> LogicalColour
max :: LogicalColour -> LogicalColour -> LogicalColour
$cmax :: LogicalColour -> LogicalColour -> LogicalColour
>= :: LogicalColour -> LogicalColour -> Bool
$c>= :: LogicalColour -> LogicalColour -> Bool
> :: LogicalColour -> LogicalColour -> Bool
$c> :: LogicalColour -> LogicalColour -> Bool
<= :: LogicalColour -> LogicalColour -> Bool
$c<= :: LogicalColour -> LogicalColour -> Bool
< :: LogicalColour -> LogicalColour -> Bool
$c< :: LogicalColour -> LogicalColour -> Bool
compare :: LogicalColour -> LogicalColour -> Ordering
$ccompare :: LogicalColour -> LogicalColour -> Ordering
$cp1Ord :: Eq LogicalColour
Ord,
		ReadPrec [LogicalColour]
ReadPrec LogicalColour
Int -> ReadS LogicalColour
ReadS [LogicalColour]
(Int -> ReadS LogicalColour)
-> ReadS [LogicalColour]
-> ReadPrec LogicalColour
-> ReadPrec [LogicalColour]
-> Read LogicalColour
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LogicalColour]
$creadListPrec :: ReadPrec [LogicalColour]
readPrec :: ReadPrec LogicalColour
$creadPrec :: ReadPrec LogicalColour
readList :: ReadS [LogicalColour]
$creadList :: ReadS [LogicalColour]
readsPrec :: Int -> ReadS LogicalColour
$creadsPrec :: Int -> ReadS LogicalColour
Read,
		Int -> LogicalColour -> ShowS
[LogicalColour] -> ShowS
LogicalColour -> String
(Int -> LogicalColour -> ShowS)
-> (LogicalColour -> String)
-> ([LogicalColour] -> ShowS)
-> Show LogicalColour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogicalColour] -> ShowS
$cshowList :: [LogicalColour] -> ShowS
show :: LogicalColour -> String
$cshow :: LogicalColour -> String
showsPrec :: Int -> LogicalColour -> ShowS
$cshowsPrec :: Int -> LogicalColour -> ShowS
Show
	)

instance Control.DeepSeq.NFData LogicalColour where
	rnf :: LogicalColour -> ()
rnf LogicalColour
_	= ()

instance Data.Array.IArray.Ix LogicalColour where
	range :: (LogicalColour, LogicalColour) -> [LogicalColour]
range (LogicalColour
lower, LogicalColour
upper)			= Bool -> [LogicalColour] -> [LogicalColour]
forall a. (?callStack::CallStack) => Bool -> a -> a
Control.Exception.assert (LogicalColour
lower LogicalColour -> LogicalColour -> Bool
forall a. Eq a => a -> a -> Bool
== LogicalColour
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& LogicalColour
upper LogicalColour -> LogicalColour -> Bool
forall a. Eq a => a -> a -> Bool
== LogicalColour
forall a. Bounded a => a
maxBound) [LogicalColour]
range
	inRange :: (LogicalColour, LogicalColour) -> LogicalColour -> Bool
inRange (LogicalColour
lower, LogicalColour
upper) LogicalColour
logicalColour	= Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
Control.Exception.assert (LogicalColour
logicalColour LogicalColour -> LogicalColour -> Bool
forall a. Ord a => a -> a -> Bool
>= LogicalColour
lower Bool -> Bool -> Bool
&& LogicalColour
logicalColour LogicalColour -> LogicalColour -> Bool
forall a. Ord a => a -> a -> Bool
<= LogicalColour
upper) Bool
True
	index :: (LogicalColour, LogicalColour) -> LogicalColour -> Int
index (LogicalColour
lower, LogicalColour
upper)			= Bool -> Int -> Int
forall a. (?callStack::CallStack) => Bool -> a -> a
Control.Exception.assert (LogicalColour
lower LogicalColour -> LogicalColour -> Bool
forall a. Eq a => a -> a -> Bool
== LogicalColour
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
&& LogicalColour
upper LogicalColour -> LogicalColour -> Bool
forall a. Eq a => a -> a -> Bool
== LogicalColour
forall a. Bounded a => a
maxBound) (Int -> Int) -> (LogicalColour -> Int) -> LogicalColour -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogicalColour -> Int
forall a. Enum a => a -> Int
fromEnum

-- | The constant ascending range of /logical colour/s.
range :: [LogicalColour]
range :: [LogicalColour]
range	= [LogicalColour
forall a. Bounded a => a
minBound, LogicalColour
forall a. Bounded a => a
maxBound]

instance Property.FixedMembership.FixedMembership LogicalColour where
	members :: [LogicalColour]
members	= [LogicalColour]
range

-- | The constant number of distinct /logical colour/s.
nDistinctLogicalColours :: Type.Count.NLogicalColours
nDistinctLogicalColours :: Int
nDistinctLogicalColours	= Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [LogicalColour] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LogicalColour]
range

instance HXT.XmlPickler LogicalColour where
	xpickle :: PU LogicalColour
xpickle	= String -> PU LogicalColour -> PU LogicalColour
forall a. String -> PU a -> PU a
HXT.xpAttr String
tag (PU LogicalColour -> PU LogicalColour)
-> ([String] -> PU LogicalColour) -> [String] -> PU LogicalColour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> LogicalColour, LogicalColour -> String)
-> PU String -> PU LogicalColour
forall a b. (a -> b, b -> a) -> PU a -> PU b
HXT.xpWrap (String -> LogicalColour
forall a. Read a => String -> a
read, LogicalColour -> String
forall a. Show a => a -> String
show) (PU String -> PU LogicalColour)
-> ([String] -> PU String) -> [String] -> PU LogicalColour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> PU String
HXT.xpTextDT (Schema -> PU String)
-> ([String] -> Schema) -> [String] -> PU String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Schema
Text.XML.HXT.Arrow.Pickle.Schema.scEnum ([String] -> PU LogicalColour) -> [String] -> PU LogicalColour
forall a b. (a -> b) -> a -> b
$ (LogicalColour -> String) -> [LogicalColour] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map LogicalColour -> String
forall a. Show a => a -> String
show [LogicalColour]
range

instance Property.Opposable.Opposable LogicalColour where
	getOpposite :: LogicalColour -> LogicalColour
getOpposite LogicalColour
Black	= LogicalColour
White
	getOpposite LogicalColour
_		= LogicalColour
Black

instance Property.ExtendedPositionDescription.ReadsEPD LogicalColour where
	readsEPD :: ReadS LogicalColour
readsEPD String
s	= case ShowS
Data.List.Extra.trimStart String
s of
		Char
'b' : String
remainder	-> [(LogicalColour
Black, String
remainder)]
		Char
'w' : String
remainder	-> [(LogicalColour
White, String
remainder)]
		String
_		-> []

instance Property.ExtendedPositionDescription.ShowsEPD LogicalColour where
	showsEPD :: LogicalColour -> ShowS
showsEPD	= Char -> ShowS
showChar (Char -> ShowS)
-> (LogicalColour -> Char) -> LogicalColour -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
		LogicalColour
Black	-> Char
'b'
		LogicalColour
White	-> Char
'w'

instance Property.ForsythEdwards.ReadsFEN LogicalColour

instance Property.ForsythEdwards.ShowsFEN LogicalColour

-- | Whether the specified /logical colour/ is @Black@.
isBlack :: LogicalColour -> Bool
{-# INLINE isBlack #-}
isBlack :: LogicalColour -> Bool
isBlack LogicalColour
Black	= Bool
True
isBlack LogicalColour
_	= Bool
False

-- | Whether the specified /logical colour/ is @White@.
isWhite :: LogicalColour -> Bool
isWhite :: LogicalColour -> Bool
isWhite	= Bool -> Bool
not (Bool -> Bool) -> (LogicalColour -> Bool) -> LogicalColour -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogicalColour -> Bool
isBlack

-- | A boxed array indexed by /logical colour/, of arbitrary elements.
type ArrayByLogicalColour	= Data.Array.IArray.Array LogicalColour

-- | Array-constructor from an ordered list of elements.
listArrayByLogicalColour :: Data.Array.IArray.IArray a e => [e] -> a LogicalColour e
listArrayByLogicalColour :: [e] -> a LogicalColour e
listArrayByLogicalColour	= (LogicalColour, LogicalColour) -> [e] -> a LogicalColour e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
Data.Array.IArray.listArray (LogicalColour
forall a. Bounded a => a
minBound, LogicalColour
forall a. Bounded a => a
maxBound)

-- | Array-constructor from an association-list.
arrayByLogicalColour :: Data.Array.IArray.IArray a e => [(LogicalColour, e)] -> a LogicalColour e
arrayByLogicalColour :: [(LogicalColour, e)] -> a LogicalColour e
arrayByLogicalColour	= (LogicalColour, LogicalColour)
-> [(LogicalColour, e)] -> a LogicalColour e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
Data.Array.IArray.array (LogicalColour
forall a. Bounded a => a
minBound, LogicalColour
forall a. Bounded a => a
maxBound)