module BishBosh.State.TurnsByLogicalColour(
TurnsByLogicalColour(
getNPlies
),
inferNextLogicalColour,
countPlies,
dereference,
fromAssocs,
update,
prepend
) where
import Control.Arrow((&&&), (***))
import Data.Array.IArray((!), (//))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Property.Reflectable as Property.Reflectable
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.List.Extra
data TurnsByLogicalColour turn = MkTurnsByLogicalColour {
getTurnsByLogicalColour :: Attribute.LogicalColour.ByLogicalColour [turn],
getNPlies :: Component.Move.NPlies
}
instance Eq turn => Eq (TurnsByLogicalColour turn) where
MkTurnsByLogicalColour { getTurnsByLogicalColour = aL } == MkTurnsByLogicalColour { getTurnsByLogicalColour = aR } = aL == aR
instance (Read turn, Show turn) => Read (TurnsByLogicalColour turn) where
readsPrec _ s = Control.Arrow.first fromAssocs `map` reads s
instance Show turn => Show (TurnsByLogicalColour turn) where
showsPrec _ MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = shows $ Data.Array.IArray.assocs byLogicalColour
instance Control.DeepSeq.NFData turn => Control.DeepSeq.NFData (TurnsByLogicalColour turn) where
rnf MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour
instance Data.Default.Default (TurnsByLogicalColour turn) where
def = MkTurnsByLogicalColour {
getTurnsByLogicalColour = Attribute.LogicalColour.listArrayByLogicalColour $ repeat [],
getNPlies = 0
}
instance Property.Empty.Empty (TurnsByLogicalColour turn) where
empty = Data.Default.def
instance Property.Null.Null (TurnsByLogicalColour turn) where
isNull MkTurnsByLogicalColour { getNPlies = 0 } = True
isNull _ = False
instance Property.Reflectable.ReflectableOnX turn => Property.Reflectable.ReflectableOnX (TurnsByLogicalColour turn) where
reflectOnX turnsByLogicalColour@MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = turnsByLogicalColour {
getTurnsByLogicalColour = Data.Array.IArray.array (minBound, maxBound) . map (
Property.Opposable.getOpposite *** map Property.Reflectable.reflectOnX
) $ Data.Array.IArray.assocs byLogicalColour
}
fromAssocs :: Show turn => [(Attribute.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn
fromAssocs assocs
| length assocs /= Attribute.LogicalColour.nDistinctLogicalColours = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tboth logical colours must be defined; " $ shows assocs "."
| Data.List.Extra.anySame $ map fst assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tduplicates specified; " $ shows assocs "."
| (> 1) . abs . uncurry (-) $ (
length . (! Attribute.LogicalColour.White) &&& length . (! Attribute.LogicalColour.Black)
) byLogicalColour = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tany difference in the number of turns taken by each player, can't exceed one " $ shows assocs "."
| otherwise = turnsByLogicalColour
where
byLogicalColour = Data.Array.IArray.array (minBound, maxBound) assocs
turnsByLogicalColour = MkTurnsByLogicalColour {
getTurnsByLogicalColour = byLogicalColour,
getNPlies = countPlies turnsByLogicalColour
}
inferNextLogicalColour :: TurnsByLogicalColour turn -> Attribute.LogicalColour.LogicalColour
inferNextLogicalColour MkTurnsByLogicalColour { getNPlies = nPlies }
| even nPlies = Attribute.LogicalColour.White
| otherwise = Attribute.LogicalColour.Black
countPlies :: TurnsByLogicalColour turn -> Component.Move.NPlies
countPlies MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 byLogicalColour
dereference :: Attribute.LogicalColour.LogicalColour -> TurnsByLogicalColour turn -> [turn]
dereference logicalColour MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = byLogicalColour ! logicalColour
update :: TurnsByLogicalColour turn -> [(Attribute.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn
update MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } assocs = turnsByLogicalColour where
turnsByLogicalColour = MkTurnsByLogicalColour {
getTurnsByLogicalColour = byLogicalColour // assocs,
getNPlies = countPlies turnsByLogicalColour
}
type Transformation turn = TurnsByLogicalColour turn -> TurnsByLogicalColour turn
prepend :: Attribute.LogicalColour.LogicalColour -> turn -> Transformation turn
prepend logicalColour turn MkTurnsByLogicalColour {
getTurnsByLogicalColour = byLogicalColour,
getNPlies = nPlies
} = MkTurnsByLogicalColour {
getTurnsByLogicalColour = byLogicalColour // [
(
logicalColour,
turn : byLogicalColour ! logicalColour
)
],
getNPlies = succ nPlies
}