module BishBosh.Input.SearchOptions(
SearchDepth,
PreferMovesTowardsCentre,
SortOnStandardOpeningMoveFrequency,
HammingDistance,
MaybeRetireAfterNMoves,
TrapRepeatedPositions,
MaybeUseTranspositions,
Reader,
SearchOptions(
getPreferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance,
getMaybeRetireKillerMovesAfter,
getTrapRepeatedPositions,
getUsePondering,
getMaybeUseTranspositions,
getStandardOpeningOptions,
getSearchDepthByLogicalColour
),
tag,
searchDepthTag,
minimumSearchDepth,
defaultSearchDepth,
mkSearchOptions,
getSearchDepth,
maybeRetireTranspositionsAfter,
maybeMinimumTranspositionSearchDepth,
setSearchDepth,
swapSearchDepth,
recordKillerMoves
) where
import BishBosh.Data.Bool()
import BishBosh.Data.Integral()
import Control.Arrow((***))
import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm
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.Input.StandardOpeningOptions as Input.StandardOpeningOptions
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 Control.Monad.Reader
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.Map
import qualified Data.Maybe
import qualified Text.XML.HXT.Arrow.Pickle as HXT
tag :: String
tag = "searchOptions"
preferMovesTowardsCentreTag :: String
preferMovesTowardsCentreTag = "preferMovesTowardsCentre"
sortOnStandardOpeningMoveFrequencyTag :: String
sortOnStandardOpeningMoveFrequencyTag = "sortOnStandardOpeningMoveFrequency"
minimumHammingDistanceTag :: String
minimumHammingDistanceTag = "minimumHammingDistance"
retireKillerMovesAfterTag :: String
retireKillerMovesAfterTag = "retireKillerMovesAfter"
trapRepeatedPositionsTag :: String
trapRepeatedPositionsTag = "trapRepeatedPositions"
usePonderingTag :: String
usePonderingTag = "usePondering"
retireTranspositionsAfterTag :: String
retireTranspositionsAfterTag = "retireTranspositionsAfter"
minimumTranspositionSearchDepthTag :: String
minimumTranspositionSearchDepthTag = "minimumTranspositionSearchDepth"
searchDepthTag :: String
searchDepthTag = "searchDepth"
searchDepthByLogicalColourTag :: String
searchDepthByLogicalColourTag = showString searchDepthTag "ByLogicalColour"
type SearchDepth = Component.Move.NMoves
minimumSearchDepth :: SearchDepth
minimumSearchDepth = 1
defaultSearchDepth :: SearchDepth
defaultSearchDepth = 4
type PreferMovesTowardsCentre = Bool
type SortOnStandardOpeningMoveFrequency = Bool
type HammingDistance = Int
type MaybeRetireAfterNMoves = Maybe Component.Move.NMoves
type TrapRepeatedPositions = Bool
type UsePondering = Bool
type MaybeUseTranspositions = Maybe (Component.Move.NMoves, SearchDepth)
type SearchDepthByLogicalColour = Data.Map.Map Attribute.LogicalColour.LogicalColour SearchDepth
data SearchOptions = MkSearchOptions {
getPreferMovesTowardsCentre :: PreferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency :: SortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance :: Maybe HammingDistance,
getMaybeRetireKillerMovesAfter :: MaybeRetireAfterNMoves,
getTrapRepeatedPositions :: TrapRepeatedPositions,
getUsePondering :: UsePondering,
getMaybeUseTranspositions :: MaybeUseTranspositions,
getStandardOpeningOptions :: Input.StandardOpeningOptions.StandardOpeningOptions,
getSearchDepthByLogicalColour :: SearchDepthByLogicalColour
} deriving Eq
instance Control.DeepSeq.NFData SearchOptions where
rnf MkSearchOptions {
getPreferMovesTowardsCentre = preferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency = sortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm = maybeCaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance = maybeMinimumHammingDistance,
getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter,
getTrapRepeatedPositions = trapRepeatedPositions,
getUsePondering = usePondering,
getMaybeUseTranspositions = maybeUseTranspositions,
getStandardOpeningOptions = standardOpeningOptions,
getSearchDepthByLogicalColour = searchDepthByLogicalColour
} = Control.DeepSeq.rnf (
(
preferMovesTowardsCentre, sortOnStandardOpeningMoveFrequency, maybeCaptureMoveSortAlgorithm, maybeMinimumHammingDistance, maybeRetireKillerMovesAfter
), (
trapRepeatedPositions, usePondering, maybeUseTranspositions, standardOpeningOptions, searchDepthByLogicalColour
)
)
instance Show SearchOptions where
showsPrec _ MkSearchOptions {
getPreferMovesTowardsCentre = preferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency = sortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm = maybeCaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance = maybeMinimumHammingDistance,
getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter,
getTrapRepeatedPositions = trapRepeatedPositions,
getUsePondering = usePondering,
getMaybeUseTranspositions = maybeUseTranspositions,
getStandardOpeningOptions = standardOpeningOptions,
getSearchDepthByLogicalColour = searchDepthByLogicalColour
} = Text.ShowList.showsAssociationList' . Data.Maybe.maybe id (
(:) . (,) Attribute.CaptureMoveSortAlgorithm.tag . shows
) maybeCaptureMoveSortAlgorithm . Data.Maybe.maybe id (
(:) . (,) minimumHammingDistanceTag . shows
) maybeMinimumHammingDistance . Data.Maybe.maybe id (
(:) . (,) retireKillerMovesAfterTag . shows
) maybeRetireKillerMovesAfter $ Data.Maybe.maybe id (
\(retireTranspositionsAfter, minimumTranspositionSearchDepth) -> (++) [
(
preferMovesTowardsCentreTag,
shows preferMovesTowardsCentre
), (
sortOnStandardOpeningMoveFrequencyTag,
shows sortOnStandardOpeningMoveFrequency
), (
retireTranspositionsAfterTag,
shows retireTranspositionsAfter
), (
minimumTranspositionSearchDepthTag,
shows minimumTranspositionSearchDepth
)
]
) maybeUseTranspositions [
(
trapRepeatedPositionsTag,
shows trapRepeatedPositions
), (
usePonderingTag,
shows usePondering
), (
Input.StandardOpeningOptions.tag,
shows standardOpeningOptions
), (
searchDepthByLogicalColourTag,
Text.ShowList.showsAssociationList' . map (show *** shows) $ Data.Map.assocs searchDepthByLogicalColour
)
]
instance Data.Default.Default SearchOptions where
def = MkSearchOptions {
getPreferMovesTowardsCentre = True,
getSortOnStandardOpeningMoveFrequency = False,
getMaybeCaptureMoveSortAlgorithm = Nothing,
getMaybeMinimumHammingDistance = Nothing,
getMaybeRetireKillerMovesAfter = Nothing,
getTrapRepeatedPositions = True,
getUsePondering = False,
getMaybeUseTranspositions = Nothing,
getStandardOpeningOptions = Data.Default.def,
getSearchDepthByLogicalColour = Data.Map.empty
}
instance HXT.XmlPickler SearchOptions where
xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d, e, f, g, h, i, j) -> mkSearchOptions a b c d e f g h i j,
\MkSearchOptions {
getPreferMovesTowardsCentre = preferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency = sortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm = maybeCaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance = maybeMinimumHammingDistance,
getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter,
getTrapRepeatedPositions = trapRepeatedPositions,
getUsePondering = usePondering,
getMaybeUseTranspositions = maybeUseTranspositions,
getStandardOpeningOptions = standardOpeningOptions,
getSearchDepthByLogicalColour = searchDepthByLogicalColour
} -> (
preferMovesTowardsCentre,
sortOnStandardOpeningMoveFrequency,
maybeCaptureMoveSortAlgorithm,
maybeMinimumHammingDistance,
maybeRetireKillerMovesAfter,
trapRepeatedPositions,
usePondering,
maybeUseTranspositions,
standardOpeningOptions,
searchDepthByLogicalColour
)
) $ HXT.xp10Tuple (
getPreferMovesTowardsCentre def `HXT.xpDefault` HXT.xpAttr preferMovesTowardsCentreTag HXT.xpickle
) (
getSortOnStandardOpeningMoveFrequency def `HXT.xpDefault` HXT.xpAttr sortOnStandardOpeningMoveFrequencyTag HXT.xpickle
) (
HXT.xpOption HXT.xpickle
) (
HXT.xpAttrImplied minimumHammingDistanceTag HXT.xpInt
) (
HXT.xpAttrImplied retireKillerMovesAfterTag HXT.xpInt
) (
getTrapRepeatedPositions def `HXT.xpDefault` HXT.xpAttr trapRepeatedPositionsTag HXT.xpickle
) (
getUsePondering def `HXT.xpDefault` HXT.xpAttr usePonderingTag HXT.xpickle
) (
HXT.xpOption . HXT.xpElem "transpositions" $ HXT.xpAttr retireTranspositionsAfterTag HXT.xpInt `HXT.xpPair` HXT.xpAttr minimumTranspositionSearchDepthTag HXT.xpInt
) HXT.xpickle (
HXT.xpElem searchDepthByLogicalColourTag . HXT.xpWrap (
Data.Map.fromList,
Data.Map.toList
) . HXT.xpList . HXT.xpElem "byLogicalColour" $ HXT.xpickle `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpInt
) where
def = Data.Default.def
mkSearchOptions
:: PreferMovesTowardsCentre
-> SortOnStandardOpeningMoveFrequency
-> Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm
-> Maybe HammingDistance
-> MaybeRetireAfterNMoves
-> TrapRepeatedPositions
-> UsePondering
-> MaybeUseTranspositions
-> Input.StandardOpeningOptions.StandardOpeningOptions
-> SearchDepthByLogicalColour
-> SearchOptions
mkSearchOptions preferMovesTowardsCentre sortOnStandardOpeningMoveFrequency maybeCaptureMoveSortAlgorithm maybeMinimumHammingDistance maybeRetireKillerMovesAfter trapRepeatedPositions usePondering maybeUseTranspositions standardOpeningOptions searchDepthByLogicalColour
| Just minimumHammingDistance <- maybeMinimumHammingDistance
, minimumHammingDistance < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumHammingDistanceTag . Text.ShowList.showsAssociation $ shows minimumHammingDistance " must exceed zero."
| Just retireKillerMovesAfter <- maybeRetireKillerMovesAfter
, retireKillerMovesAfter < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString retireKillerMovesAfterTag . Text.ShowList.showsAssociation $ shows retireKillerMovesAfter " can't be negative."
| let nAutomatedPlayers = Data.Map.size searchDepthByLogicalColour
, usePondering && nAutomatedPlayers /= 1
= Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\tpondering is pointless unless there's an automated player who can use the unused CPU-time during a manual player's move, but there're " $ shows nAutomatedPlayers " automated players."
| Just (retireTranspositionsAfter, _) <- maybeUseTranspositions
, retireTranspositionsAfter < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString retireTranspositionsAfterTag . Text.ShowList.showsAssociation $ shows retireTranspositionsAfter " can't be negative."
| Just (_, minimumTranspositionSearchDepth) <- maybeUseTranspositions
, minimumTranspositionSearchDepth < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumTranspositionSearchDepthTag . Text.ShowList.showsAssociation $ shows minimumTranspositionSearchDepth " must exceed zero."
| Just (_, minimumTranspositionSearchDepth) <- maybeUseTranspositions
, not $ Data.Map.null searchDepthByLogicalColour
, Data.Foldable.all (
minimumTranspositionSearchDepth >
) searchDepthByLogicalColour = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumTranspositionSearchDepthTag . Text.ShowList.showsAssociation $ shows minimumTranspositionSearchDepth . showString " exceeds " . showString searchDepthTag . Text.ShowList.showsAssociation $ shows (Data.Map.toList searchDepthByLogicalColour) "."
| Data.Foldable.any (
< minimumSearchDepth
) searchDepthByLogicalColour = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" $ showString searchDepthTag " must be positive."
| otherwise = MkSearchOptions {
getPreferMovesTowardsCentre = preferMovesTowardsCentre,
getSortOnStandardOpeningMoveFrequency = sortOnStandardOpeningMoveFrequency,
getMaybeCaptureMoveSortAlgorithm = maybeCaptureMoveSortAlgorithm,
getMaybeMinimumHammingDistance = maybeMinimumHammingDistance,
getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter,
getTrapRepeatedPositions = trapRepeatedPositions,
getUsePondering = usePondering,
getMaybeUseTranspositions = maybeUseTranspositions,
getStandardOpeningOptions = standardOpeningOptions,
getSearchDepthByLogicalColour = searchDepthByLogicalColour
}
getSearchDepth :: SearchOptions -> SearchDepth
getSearchDepth MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } = Data.Maybe.fromMaybe defaultSearchDepth . Data.Maybe.listToMaybe $ Data.Map.elems searchDepthByLogicalColour
type RecordKillerMoves = Bool
recordKillerMoves :: SearchOptions -> RecordKillerMoves
recordKillerMoves MkSearchOptions { getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter } = Data.Maybe.isJust maybeRetireKillerMovesAfter
maybeRetireTranspositionsAfter :: SearchOptions -> MaybeRetireAfterNMoves
maybeRetireTranspositionsAfter MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap fst maybeUseTranspositions
maybeMinimumTranspositionSearchDepth :: SearchOptions -> Maybe SearchDepth
maybeMinimumTranspositionSearchDepth MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap snd maybeUseTranspositions
type Transformation = SearchOptions -> SearchOptions
setSearchDepth :: SearchDepth -> Transformation
setSearchDepth searchDepth searchOptions@MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour }
| searchDepth < minimumSearchDepth = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.setSearchDepth:\t" . showString searchDepthTag . Text.ShowList.showsAssociation $ shows searchDepth " must be positive."
| otherwise = searchOptions { getSearchDepthByLogicalColour = Data.Map.map (const searchDepth) searchDepthByLogicalColour }
swapSearchDepth :: Transformation
swapSearchDepth searchOptions@MkSearchOptions {
getSearchDepthByLogicalColour = searchDepthByLogicalColour
} = searchOptions {
getSearchDepthByLogicalColour = Data.Map.fromAscList . map (Control.Arrow.first Property.Opposable.getOpposite) $ Data.Map.toDescList searchDepthByLogicalColour
}
type Reader = Control.Monad.Reader.Reader SearchOptions