SearchOptions.hs

{-
	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 configurable options related to the process of searching for the optimal move.
-}

module BishBosh.Input.SearchOptions(
-- * Types
-- ** Type-synonyms
	SearchDepth,
	PreferMovesTowardsCentre,
	SortOnStandardOpeningMoveFrequency,
	HammingDistance,
--	Transformation,
--	RecordKillerMoves,
	MaybeRetireAfterNMoves,
	TrapRepeatedPositions,
--	UsePondering,
	MaybeUseTranspositions,
--	StandardOpeningOptions,
--	SearchDepthByLogicalColour,
	Reader,
-- ** Data-types
	SearchOptions(
--		MkSearchOptions,
		getPreferMovesTowardsCentre,
		getSortOnStandardOpeningMoveFrequency,
		getMaybeCaptureMoveSortAlgorithm,
		getMaybeMinimumHammingDistance,
		getMaybeRetireKillerMovesAfter,
		getTrapRepeatedPositions,
		getUsePondering,
		getMaybeUseTranspositions,
		getStandardOpeningOptions,
		getSearchDepthByLogicalColour
	),
-- * Constants
	tag,
--	preferMovesTowardsCentreTag
--	sortOnStandardOpeningMoveFrequencyTag
--	minimumHammingDistanceTag,
--	retireKillerMovesAfterTag,
--	trapRepeatedPositionsTag,
--	usePonderingTag,
--	retireTranspositionsAfterTag,
--	minimumTranspositionSearchDepthTag,
--	standardOpeningOptionsTag,
	searchDepthTag,
--	searchDepthByLogicalColourTag
	minimumSearchDepth,
	defaultSearchDepth,
-- * Functions
-- ** Constructor
	mkSearchOptions,
-- ** Accessors
	getSearchDepth,
	maybeRetireTranspositionsAfter,
	maybeMinimumTranspositionSearchDepth,
-- ** Mutators
	setSearchDepth,
	swapSearchDepth,
-- ** Predicates
	recordKillerMoves
) where

import			BishBosh.Data.Bool()		-- For 'HXT.xpickle'.
import			BishBosh.Data.Integral()	-- For 'HXT.XmlPickler NMoves'.
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

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

-- | Used to qualify XML.
preferMovesTowardsCentreTag :: String
preferMovesTowardsCentreTag		= "preferMovesTowardsCentre"

-- | Used to qualify XML.
sortOnStandardOpeningMoveFrequencyTag :: String
sortOnStandardOpeningMoveFrequencyTag	= "sortOnStandardOpeningMoveFrequency"

-- | Used to qualify XML.
minimumHammingDistanceTag :: String
minimumHammingDistanceTag		= "minimumHammingDistance"

-- | Used to qualify XML.
retireKillerMovesAfterTag :: String
retireKillerMovesAfterTag		= "retireKillerMovesAfter"

-- | Used to qualify XML.
trapRepeatedPositionsTag :: String
trapRepeatedPositionsTag		= "trapRepeatedPositions"

-- | Used to qualify XML.
usePonderingTag :: String
usePonderingTag				= "usePondering"

-- | Used to qualify XML.
retireTranspositionsAfterTag :: String
retireTranspositionsAfterTag		= "retireTranspositionsAfter"

-- | Used to qualify XML.
minimumTranspositionSearchDepthTag :: String
minimumTranspositionSearchDepthTag	= "minimumTranspositionSearchDepth"

-- | Used to qualify XML.
searchDepthTag :: String
searchDepthTag				= "searchDepth"

-- | Used to qualify XML.
searchDepthByLogicalColourTag :: String
searchDepthByLogicalColourTag		= showString searchDepthTag "ByLogicalColour"

-- | The number of plies to search for the optimal move.
type SearchDepth	= Component.Move.NMoves

-- | The minimum permissible search-depth.
minimumSearchDepth :: SearchDepth
minimumSearchDepth	= 1

{- |
	* The default search-depth.

	* CAVEAT: this is rather arbitrary.
-}
defaultSearchDepth :: SearchDepth
defaultSearchDepth	= 4

-- | Whether to prefer moves which progress towards the centre of the board.
type PreferMovesTowardsCentre		= Bool

-- | Sort moves on the decreasing frequency of occurrence in standard openings.
type SortOnStandardOpeningMoveFrequency	= Bool

-- | The optional minimum Hamming-distance between the random numbers from which Zobrist-hashes are composed.
type HammingDistance			= Int

-- | The number of full moves (one for each player) after which to retire killer moves.
type MaybeRetireAfterNMoves		= Maybe Component.Move.NMoves

-- | Whether to short-circuit the fitness-evaluation of /position/s which have been visited before in the current /game/.
type TrapRepeatedPositions		= Bool

-- | Whether to ponder about one's next move while the opponent is thinking.
type UsePondering			= Bool

-- | The number of full moves (one for each player) after which to retire transpositions & the search-depth beneath which they aren't recorded at all.
type MaybeUseTranspositions		= Maybe (Component.Move.NMoves, SearchDepth)

-- | The depth to search for each /logical colour/.
type SearchDepthByLogicalColour		= Data.Map.Map Attribute.LogicalColour.LogicalColour SearchDepth

-- | Defines options related to searching for a move.
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	-- Manual.
	}

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,	-- Construct.
		\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
		) -- Deconstruct.
	 ) $ HXT.xp10Tuple (
		getPreferMovesTowardsCentre def `HXT.xpDefault` HXT.xpAttr preferMovesTowardsCentreTag HXT.xpickle {-Bool-}
	 ) (
		getSortOnStandardOpeningMoveFrequency def `HXT.xpDefault` HXT.xpAttr sortOnStandardOpeningMoveFrequencyTag HXT.xpickle
	 ) (
		HXT.xpOption HXT.xpickle {-CaptureMoveSortAlgorithm-}
	 ) (
		HXT.xpAttrImplied minimumHammingDistanceTag HXT.xpInt
	 ) (
		HXT.xpAttrImplied retireKillerMovesAfterTag HXT.xpInt
	 ) (
		getTrapRepeatedPositions def `HXT.xpDefault` HXT.xpAttr trapRepeatedPositionsTag HXT.xpickle {-Bool-}
	 ) (
		getUsePondering def `HXT.xpDefault` HXT.xpAttr usePonderingTag HXT.xpickle {-Bool-}
	 ) (
		HXT.xpOption . HXT.xpElem "transpositions" $ HXT.xpAttr retireTranspositionsAfterTag HXT.xpInt `HXT.xpPair` HXT.xpAttr minimumTranspositionSearchDepthTag HXT.xpInt
	 ) HXT.xpickle {-standardOpeningOptions-} (
		HXT.xpElem searchDepthByLogicalColourTag . HXT.xpWrap (
			Data.Map.fromList,	-- Construct from a List.
			Data.Map.toList		-- Deconstruct to a List.
		) . HXT.xpList {-potentially null-} . HXT.xpElem "byLogicalColour" $ HXT.xpickle {-LogicalColour-} `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpInt
	 ) where
		def	= Data.Default.def

-- | Smart constructor.
mkSearchOptions
	:: PreferMovesTowardsCentre
	-> SortOnStandardOpeningMoveFrequency
	-> Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm
	-> Maybe HammingDistance	-- ^ The optional lower bound on the Hamming-distance between the random numbers used to compose Zobrist hashes from /position/s.
	-> MaybeRetireAfterNMoves	-- ^ The number of full moves back from the current position, after which to retire killer-moves.
	-> TrapRepeatedPositions
	-> UsePondering
	-> MaybeUseTranspositions	-- ^ The number of full moves after which to retire transpositions, & the search-depth beneath which transpositions aren't recorded.
	-> 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
	}

-- | Get either player's search-depth, using a default value when none are defined.
getSearchDepth :: SearchOptions -> SearchDepth
getSearchDepth MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour }	= Data.Maybe.fromMaybe defaultSearchDepth . Data.Maybe.listToMaybe $ Data.Map.elems searchDepthByLogicalColour	-- Manual players don't have a searchDepth, so use the opponent's settings.

-- | Self-documentation.
type RecordKillerMoves	= Bool

-- | Whether killer-moves are to be recorded.
recordKillerMoves :: SearchOptions -> RecordKillerMoves
recordKillerMoves MkSearchOptions { getMaybeRetireKillerMovesAfter = maybeRetireKillerMovesAfter }	= Data.Maybe.isJust maybeRetireKillerMovesAfter

-- | When to retire transpositions.
maybeRetireTranspositionsAfter :: SearchOptions -> MaybeRetireAfterNMoves
maybeRetireTranspositionsAfter MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions }	= fmap fst maybeUseTranspositions

-- | The search-depth beneath which transpositions aren't recorded.
maybeMinimumTranspositionSearchDepth :: SearchOptions -> Maybe SearchDepth
maybeMinimumTranspositionSearchDepth MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions }	= fmap snd maybeUseTranspositions

-- | The type of a function used to transform 'SearchOptions'.
type Transformation	= SearchOptions -> SearchOptions

-- | Mutator.
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 }

-- | Swap the /logical colour/ associated with any /searchDepth/ currently assigned.
swapSearchDepth :: Transformation
swapSearchDepth searchOptions@MkSearchOptions {
	getSearchDepthByLogicalColour	= searchDepthByLogicalColour
} = searchOptions {
	getSearchDepthByLogicalColour	= Data.Map.fromAscList . map (Control.Arrow.first Property.Opposable.getOpposite) $ Data.Map.toDescList searchDepthByLogicalColour
}

-- | Self-documentation.
type Reader	= Control.Monad.Reader.Reader SearchOptions