diff --git a/bishbosh.cabal b/bishbosh.cabal --- a/bishbosh.cabal +++ b/bishbosh.cabal @@ -16,7 +16,7 @@ -- along with BishBosh. If not, see . Name: bishbosh -Version: 0.1.2.0 +Version: 0.1.3.0 Copyright: (C) 2018 Dr. Alistair Ward License: GPL-3.0-or-later License-file: LICENSE @@ -79,6 +79,7 @@ Default: False -- Whether, to wrap common types in 'newtype' for increased type-safety. CAVEAT: there's a ~10% performance-penalty. +-- CAVEAT: partly incompatible with 'narrownumbers'. flag newtypewrappers Description: Wrap common types in newtype for increased type-safety. Manual: True @@ -92,7 +93,8 @@ Description: Link with package "polyparse" when available, rather than "parsec". Default: True --- Whether to use precise (rational) types rather than floating-point. CAVEAT: incompatible with 'narrownumbers'. +-- Whether to use precise (rational) types rather than floating-point. +-- CAVEAT: conceptually incompatible with 'narrownumbers'. flag precision Description: Use precise numerical types. CAVEAT: this is incompatible with either 'unboxedarrays' or 'narrownumbers'. Manual: True @@ -105,7 +107,7 @@ Default: True -- Whether to use unboxed arrays where possible. --- CAVEAT: incompatble with the flag 'precision'. +-- CAVEAT: incompatible with the flag 'precision', & to some extent 'newtypewrappers'. flag unboxedarrays Description: Use unboxed arrays. Manual: True @@ -170,19 +172,18 @@ Hs-source-dirs: src-lib Exposed-modules: - BishBosh.Attribute.ANSIColourCode BishBosh.Attribute.CaptureMoveSortAlgorithm - BishBosh.Attribute.ColourScheme - BishBosh.Attribute.Direction - BishBosh.Attribute.LogicalColour - BishBosh.Attribute.LogicalColourOfSquare BishBosh.Attribute.MoveType - BishBosh.Attribute.PhysicalColour BishBosh.Attribute.Rank BishBosh.Cartesian.Abscissa BishBosh.Cartesian.Coordinates BishBosh.Cartesian.Ordinate BishBosh.Cartesian.Vector + BishBosh.Colour.ANSIColourCode + BishBosh.Colour.ColourScheme + BishBosh.Colour.LogicalColour + BishBosh.Colour.LogicalColourOfSquare + BishBosh.Colour.PhysicalColour BishBosh.Component.Accountant BishBosh.Component.CastlingMove BishBosh.Component.EitherQualifiedMove @@ -207,6 +208,11 @@ BishBosh.Data.Num BishBosh.Data.Ratio BishBosh.Data.RoseTree + BishBosh.Direction.Diagonal + BishBosh.Direction.Direction + BishBosh.Direction.Horizontal + BishBosh.Direction.Parallel + BishBosh.Direction.Vertical BishBosh.Evaluation.Fitness BishBosh.Evaluation.PositionHashQuantifiedGameTree BishBosh.Evaluation.QuantifiedGame @@ -275,6 +281,7 @@ BishBosh.StateProperty.Hashable BishBosh.StateProperty.Mutator BishBosh.StateProperty.Seeker + BishBosh.StateProperty.View BishBosh.State.TurnsByLogicalColour BishBosh.Text.AutoComplete BishBosh.Text.Case @@ -370,9 +377,6 @@ if flag(threaded) GHC-options: -threaded - if flag(unboxedarrays) && !flag(precision) - CPP-Options: -DUSE_UNBOXED_ARRAYS - -- N.B.: The Haskell package 'unix' may be available on MS-Windows, but building it will probably be laborious. if flag(unix) Other-modules: BishBosh.Concurrent.SignalHandlers @@ -403,11 +407,10 @@ Autogen-modules: Paths_bishbosh Other-modules: - BishBosh.Test.HUnit.Attribute.Direction - BishBosh.Test.HUnit.Attribute.LogicalColour BishBosh.Test.HUnit.Attribute.Rank BishBosh.Test.HUnit.Cartesian.Coordinates BishBosh.Test.HUnit.Cartesian.Vector + BishBosh.Test.HUnit.Colour.LogicalColour BishBosh.Test.HUnit.Component.CastlingMove BishBosh.Test.HUnit.Component.Move BishBosh.Test.HUnit.Component.Piece @@ -415,6 +418,7 @@ BishBosh.Test.HUnit.ContextualNotation.PGN BishBosh.Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic + BishBosh.Test.HUnit.Direction.Direction BishBosh.Test.HUnit.Evaluation.Fitness BishBosh.Test.HUnit.Input.Options BishBosh.Test.HUnit.Model.Game @@ -441,12 +445,11 @@ Other-modules: BishBosh.Test.QuickCheck.Attribute.CaptureMoveSortAlgorithm - BishBosh.Test.QuickCheck.Attribute.Direction - BishBosh.Test.QuickCheck.Attribute.LogicalColour BishBosh.Test.QuickCheck.Attribute.MoveType BishBosh.Test.QuickCheck.Attribute.Rank BishBosh.Test.QuickCheck.Cartesian.Coordinates BishBosh.Test.QuickCheck.Cartesian.Vector + BishBosh.Test.QuickCheck.Colour.LogicalColour BishBosh.Test.QuickCheck.Component.Move BishBosh.Test.QuickCheck.Component.Piece BishBosh.Test.QuickCheck.Component.QualifiedMove @@ -459,6 +462,7 @@ BishBosh.Test.QuickCheck.ContextualNotation.StandardAlgebraic BishBosh.Test.QuickCheck.Data.Foldable BishBosh.Test.QuickCheck.Data.Integral + BishBosh.Test.QuickCheck.Direction.Direction BishBosh.Test.QuickCheck.Evaluation.PositionHashQuantifiedGameTree BishBosh.Test.QuickCheck.Input.CECPFeatures BishBosh.Test.QuickCheck.Input.CECPOptions @@ -496,12 +500,15 @@ BishBosh.Test.QuickCheck.State.Position BishBosh.Test.QuickCheck.StateProperty.Censor BishBosh.Test.QuickCheck.StateProperty.Hashable + BishBosh.Test.QuickCheck.StateProperty.Mutator BishBosh.Test.QuickCheck.StateProperty.Seeker + BishBosh.Test.QuickCheck.StateProperty.View BishBosh.Test.QuickCheck.State.TurnsByLogicalColour BishBosh.Test.QuickCheck.Text.Encoding BishBosh.Test.QuickCheck.Time.StopWatch BishBosh.Test.QuickCheck.Type.Count BishBosh.Test.QuickCheck.Type.Length + BishBosh.Test.QuickCheck.Type.Mass BishBosh.Test.QuickCheck.UI.Command BishBosh.Test.QuickCheck.UI.PrintObject BishBosh.Test.QuickCheck.UI.ReportObject diff --git a/bishbosh.spec b/bishbosh.spec --- a/bishbosh.spec +++ b/bishbosh.spec @@ -24,7 +24,7 @@ Summary: BishBosh is a chess-game. Name: bishbosh -Version: 0.1.2.0 +Version: 0.1.3.0 Release: 1 License: GPLv3 # From '/usr/share/doc/packages/rpm/GROUPS'. diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -27,7 +27,7 @@ ## 0.0.0.8 * Corrected the parsing of FEN when an Enpassant-destination defined on file **b** was erroneously interpreted as a bishop in the previous **CastleableRooks** field. -* Added parent class **BishBosh.Property.ExtendedPositionDescription.EPD** for **Property.ForsythEdwards.FEN**, for which the latter typically has a default implementation of both methods. +* Added parent type-class **BishBosh.Property.ExtendedPositionDescription.EPD** for **Property.ForsythEdwards.FEN**, for which the latter typically has a default implementation of both methods. ## 0.1.0.0 ### Bug-fixes: @@ -68,10 +68,10 @@ **Component.CastlingMove** | Forked from module **Component.Move**. **Data.Enum** | Currently single-function. **Data.Foldable** | Currently single-function. -**Property.FixedMembership** | Defines a class to which sum-types can conform. +**Property.FixedMembership** | Defines a type-class to which sum-types can conform. **StateProperty.Censor** | Relocated from directory **State/**. -**StateProperty.Mutator** | defines a class to express the dual implementations within **State.Board**. -**StateProperty.Seeker** | defines a class to express the dual implementations within **State.Board**. +**StateProperty.Mutator** | defines a type-class to express the dual implementations within **State.Board**. +**StateProperty.Seeker** | defines a type-class to express the dual implementations within **State.Board**. **Text.Case** | Forked from **Text.ShowList** to contain case-related operations. **Text.Prefix** | Forked from **Text.ShowList** to define the constant prefixes of log-messages. ----------------------------------------- @@ -96,11 +96,11 @@ **BishBosh.Time.GameClock** | Contains two **BishBosh.Time.StopWatch**es to enable module **Duel.Process.Intermediary** to measure the time used by each player. **BishBosh.Property.Switchable** | Exports a type-class, which both **BishBosh.Time.StopWatch** & **BishBosh.Time.GameClock** implement, to expose their functionality. **BishBosh.Property.SelfValidating** | Exports a type-class, which both **BishBosh.Time.GameClock** & **Duel.Data.Options** implement, to validate themselves. -**BishBosh.Type.Countable** | Defines newtypes to enhance type-safety, replacing type-synonyms for **Int**. There is a performance-degradation, so this enhancement can be disabled using a new cabal-flag. +**BishBosh.Type.Countable** | Defines *newtype*s to enhance type-safety, replacing type-synonyms for **Int**. There is a performance-degradation, so this enhancement can be disabled using a new cabal-flag. **BishBosh.Type.Crypto** | Self-documentation. -**BishBosh.Type.Length** | Replaced the polymorphic type-parameters **row** & **column** with newtypes to enhance type-safety. +**BishBosh.Type.Length** | Replaced the polymorphic type-parameters **row** & **column** with *newtype*s to enhance type-safety. **BishBosh.Type.Mass** | Self-documentation. -**BishBosh.Metric.RankValue** | Replaced the polymorphic type-parameter **rankValue**, with a newtype & a smart-constructor to guard permissible bounds. +**BishBosh.Metric.RankValue** | Replaced the polymorphic type-parameter **rankValue**, with a *newtype* & a smart-constructor to guard permissible bounds. ### Duel: * Added command-line option **--verifyConfiguration**, to request that the mutual compatibility of the two configuration-files be verified before forwarding each to a forked instance of **bishbosh**. @@ -110,7 +110,7 @@ * Refactored functions **BishBosh.ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition**, **BishBosh.Model.MoveFrequency.insertMoves** & **BishBosh.Model.GameTree.toMoveFrequency**. * Evaluation-criteria: + Moved **BishBosh.Attribute.**{**CriterionValue**, **CriterionWeight**, **WeightedMeanAndCriterionValues**} to a new directory **Metric/** - + Implemented classes [**Num**, **Fractional**, **Real**] for data-types **BishBosh.Metric.**{**CriterionValue.CriterionValue**, **CriterionWeight.CriterionWeight**}, nullifying the requirement for exports. + + Implemented type-classes [**Num**, **Fractional**, **Real**] for data-types **BishBosh.Metric.**{**CriterionValue.CriterionValue**, **CriterionWeight.CriterionWeight**}, nullifying the requirement for exports. + Replaced the pointless polymorphic payloads in data-types **BishBosh.Metric.**{**CriterionValue.CriterionValue**, **CriterionWeight.CriterionWeight**, **WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues**} with concrete types. * Moved **BishBosh.Attribute.RankValues** to **BishBosh.Input**. * Checked that (with the possible exception of the King) the Queen is configured as the most valuable rank. @@ -134,7 +134,7 @@ + Amended **BishBosh.Evaluation.Fitness.measurePieceSquareValueIncrementally** to forward Castling moves to **measurePieceSquareValue**. + Polymorphism: * Replaced the polymorphic type **distance** in **BishBosh.Component.Vector**, with two concrete types **BishBosh.Type.Length.[XY]**. Removed the type **BishBosh.Type.Length.Distance**. - * Replaced the polymorphic type-parameters **x** & **y** with newtypes to: + * Replaced the polymorphic type-parameters **x** & **y** with *newtype*s to: + eliminate the fragile **RULE** pragmas required to switch to memoised function-implementations for specific type-parameters, + eliminate chains of **SPECIALISE** pragmas down the call-stack to hot-spots. + allow external calls from [**Text.ParserCombinators.Poly.Lazy.runParser**, **Text.ParserCombinators.Parsec.parse**], to access specialised implementations (see previous items), @@ -145,4 +145,20 @@ + Added type **BishBosh.Type.Count.NCoordinates** for use by function **BishBosh.Cartesian.Coordinates.nSquares**. + Added a method **BishBosh.StateProperty.Seeker.countPawnsByFileByLogicalColour** including a default implementation, & relocated the implementation from module **BishBosh.State.CoordinatesByRankByLogicalColour**. + Added a type-class **BishBosh.Component.Account.Accountant**, with a single method used to sum piece-square values; thus permiting a common interface between the implementations in **BishBosh.State.CoordinatesByRankByLogicalColour** & **BishBosh.State.MaybePieceByCoordinates**. + +## 0.1.3.0 +* Efficiency: + + Replaced the polymorphic type-parameter **pieceSquareValue** with a *newtype*, to then implement *unboxed* arrays without cluttering interfaces with type-constraint **Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue**; performance-improvement was regrettably insignificant. + + Added some strictness to **BishBosh.Board.{exposesKing, movePiece, sumPieceSquareValueByLogicalColour}** & **BishBosh.Game.applyQualifiedMove**. + + Added function **BishBosh.Cartesian.Coordinates.applyAlongDirectionsFrom** to reduce sequential indexing by direction when extrapolating in all directions; deployed in new functions **BishBosh.State.MaybePieceByCoordinates.{findBlockingPieces, findAttackerInDirections}** + + Refactored function **BishBosh.Cartesian.Vector.toMaybeDirection** to eliminate call to **BishBosh.Property.Orientated.isStraight**. + + Refactored function **BishBosh.Component.Piece.canMoveBetween** to remove **let**-binding. + + Refactored function **BishBosh.State.EnPassantAbscissa.mkMaybeEnPassantAbscissa** to reduce calls to **BishBosh.State.MaybePieceByCoordinates.{findAttackerInDirection, findBlockingPiece}**. +* Structural: + + Added method **BishBosh.StateProperty.Mutator.movePiece** & implemented whole type-class in module **BishBosh.State.CoordinatesByRankByLogicalColour**. + + Implemented type-class **BishBosh.Property.SelfValidating.SelfValidating** in modules **BishBosh.State.{MaybePieceByCoordinates, CoordinatesByRankByLogicalColour, Board}**. + + Created a new type-class **BishBosh.StateProperty.View.View** (implemented in **BishBosh.State.{MaybePieceByCoordinates, CoordinatesByRankByLogicalColour}**), to abstract construction of a view & translation between views. + + Rewrote module **BishBosh.Attribute.Direction** to remove the 9th invalid state from the data-structure, & to express the division between *parallel* & *diagonal* instances; which degraded performance slightly. Added new methods to class **BishBosh.Property.Orientated.Orientated**. + + Relocated colour-related modules from **BishBosh/Attribute/** to **BishBosh/Colour/**. + + Re-ordered the parameters of functions which access record-structures, to make the record the first parameter; cf. those that mutate the record-structure, which receive it last. diff --git a/makefile b/makefile --- a/makefile +++ b/makefile @@ -53,33 +53,37 @@ test: @for FLAG in -polyparse newtypewrappers narrownumbers unboxedarrays -hxtrelaxng -threaded precision; do\ echo $${FLAG};\ - stack '$@' --flag="$(PACKAGE_NAME):$${FLAG}" $(GHC_OPTIONS) || break;\ + stack '$@' --flag="$(PACKAGE_NAME):$${FLAG}" $(GHC_OPTIONS) '$(PACKAGE_NAME):test:hunit-tests' '$(PACKAGE_NAME):test:quickcheck-tests' || break;\ done # Compile with random CPP-flags & run the test-suites. randomTest: FLAGS=$$(shuf --echo -- hxtrelaxng narrownumbers newtypewrappers polyparse precision threaded unboxedarrays | head --lines=3 | sed -e '1s/^/-/' -e 's/\(.*\)/--flag=$(PACKAGE_NAME):\1/');\ echo $${FLAGS};\ - stack test $${FLAGS} $(GHC_OPTIONS) + stack test $${FLAGS} $(GHC_OPTIONS) '$(PACKAGE_NAME):test:hunit-tests' '$(PACKAGE_NAME):test:quickcheck-tests' # Profile a single-threaded build, to access entry-counts. prof: - @stack install --profile --flag='bishbosh:-threaded' $(GHC_OPTIONS); - sleep 16; # Let the test-machine reach a quiescent state. + @stack install --profile --flag='$(PACKAGE_NAME):-threaded' $(GHC_OPTIONS) '$(PACKAGE_NAME):exe:$(PACKAGE_NAME)'; + sleep 32; # Let the test-machine reach a quiescent state. @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_$@.xml' +RTS -p -RTS # Profile. profN2: - @stack install --profile $(GHC_OPTIONS); + @stack install --profile $(GHC_OPTIONS) '$(PACKAGE_NAME):exe:$(PACKAGE_NAME)'; @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_prof.xml' +RTS -p -N2 -RTS -# Install this product. -$(BIN_DIR)/$(PACKAGE_NAME) $(BIN_DIR)/duel: - @stack install $(GHC_OPTIONS) +# Install 'bishbosh'. +$(BIN_DIR)/$(PACKAGE_NAME): + @stack install $(GHC_OPTIONS) '$(PACKAGE_NAME):exe:$(PACKAGE_NAME)' # Run the installed application as an xboard-engine. xboard: $(BIN_DIR)/$(PACKAGE_NAME) - @$@ -fcp '$(PACKAGE_NAME) -i "config/CECP/$(PACKAGE_NAME)_black.xml" +RTS -N2 -RTS' + @$@ -fcp '$(PACKAGE_NAME) -i 'config/CECP/$(PACKAGE_NAME)_black.xml' +RTS -N2 -RTS' + +# Install 'duel'. +$(BIN_DIR)/duel: $(BIN_DIR)/$(PACKAGE_NAME) + @stack install $(GHC_OPTIONS) '$(PACKAGE_NAME):exe:duel' # Start a battle. duel: $(BIN_DIR)/duel diff --git a/src-exe/BishBosh/Play.hs b/src-exe/BishBosh/Play.hs --- a/src-exe/BishBosh/Play.hs +++ b/src-exe/BishBosh/Play.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -58,10 +57,8 @@ import qualified BishBosh.State.PlayState as State.PlayState import qualified BishBosh.Text.ShowColouredPrefix as Text.ShowColouredPrefix import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Mass as Type.Mass import qualified BishBosh.UI.CECP as UI.CECP import qualified BishBosh.UI.Raw as UI.Raw -import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad import qualified Data.Bits @@ -72,37 +69,19 @@ import qualified System.Random import System.FilePath(()) -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | Plays the game according to the specified configuration. play :: ( - Control.DeepSeq.NFData pieceSquareValue, -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.FiniteBits positionHash, - Fractional pieceSquareValue, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - System.Random.Random positionHash, - System.Random.RandomGen randomGen + Data.Bits.FiniteBits positionHash, + Ord positionHash, + System.Random.Random positionHash, + System.Random.RandomGen randomGen ) => Input.Verbosity.Verbosity -> randomGen - -> Input.Options.Options pieceSquareValue + -> Input.Options.Options -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -- ^ Standard openings. - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) -{-# SPECIALISE play - :: System.Random.RandomGen randomGen - => Input.Verbosity.Verbosity - -> randomGen - -> Input.Options.Options Type.Mass.PieceSquareValue - -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest - -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) - #-} + -> IO (State.PlayState.PlayState positionHash) +{-# SPECIALISE play :: Input.Verbosity.Verbosity -> System.Random.StdGen -> Input.Options.Options -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> IO (State.PlayState.PlayState Type.Crypto.PositionHash) #-} play verbosity randomGen options qualifiedMoveForest = Data.Maybe.maybe ( return {-to IO-monad-} Data.Default.def {-game-} ) ( diff --git a/src-exe/BishBosh/State/PlayState.hs b/src-exe/BishBosh/State/PlayState.hs --- a/src-exe/BishBosh/State/PlayState.hs +++ b/src-exe/BishBosh/State/PlayState.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -82,40 +81,30 @@ import qualified Data.Ord import qualified Factory.Math.Statistics -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | The type threaded through the sequence of /game/s during play. -data PlayState pieceSquareValue positionHash = MkPlayState { +data PlayState positionHash = MkPlayState { getCriterionValues :: [[Metric.CriterionValue.CriterionValue]], -- ^ The /criterion-value/s accumulated during the game. getZobrist :: Component.Zobrist.Zobrist positionHash, -- ^ The constant hash-codes used to construct position-hashes. getMoveFrequency :: Model.GameTree.MoveFrequency, -- ^ The constant frequency of moves extracted from file. getSearchState :: Search.SearchState.SearchState positionHash, - getOptions :: Input.Options.Options pieceSquareValue, -- ^ The constant options by which the game is configured. + getOptions :: Input.Options.Options, -- ^ The constant options by which the game is configured. getMaybeApplicationTerminationReason :: Maybe State.ApplicationTerminationReason.ApplicationTerminationReason -- ^ Whether the game has terminated. } -- | Constructor. -initialise :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Real pieceSquareValue - ) - => Input.Options.Options pieceSquareValue +initialise + :: Data.Bits.Bits positionHash + => Input.Options.Options -> Component.Zobrist.Zobrist positionHash -> Model.GameTree.MoveFrequency -> Model.Game.Game - -> PlayState pieceSquareValue positionHash + -> PlayState positionHash {-# SPECIALISE initialise - :: Input.Options.Options Type.Mass.PieceSquareValue + :: Input.Options.Options -> Component.Zobrist.Zobrist Type.Crypto.PositionHash -> Model.GameTree.MoveFrequency -> Model.Game.Game - -> PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash + -> PlayState Type.Crypto.PositionHash #-} initialise options zobrist moveFrequency game = MkPlayState { getCriterionValues = [], @@ -129,27 +118,21 @@ } -- | Accessor. -getGame :: PlayState pieceSquareValue positionHash -> Model.Game.Game +getGame :: PlayState positionHash -> Model.Game.Game getGame MkPlayState { getSearchState = searchState } = Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame $ Search.SearchState.getPositionHashQuantifiedGameTree searchState -- | The type of a function used to transform a 'PlayState'. -type Transformation pieceSquareValue positionHash = PlayState pieceSquareValue positionHash -> PlayState pieceSquareValue positionHash +type Transformation positionHash = PlayState positionHash -> PlayState positionHash -- | Mutator. -setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash -> Transformation pieceSquareValue positionHash +setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash -> Transformation positionHash setPositionHashQuantifiedGameTree positionHashQuantifiedGameTree playState@MkPlayState { getSearchState = searchState } = playState { getSearchState = searchState { Search.SearchState.getPositionHashQuantifiedGameTree = positionHashQuantifiedGameTree } } -- | Reconstruct the /positionHashQuantifiedGameTree/ (in the /searchState/), with the apex set to the specified game. -reconstructPositionHashQuantifiedGameTree :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Real pieceSquareValue - ) => Model.Game.Game -> Transformation pieceSquareValue positionHash +reconstructPositionHashQuantifiedGameTree :: Data.Bits.Bits positionHash => Model.Game.Game -> Transformation positionHash +{-# SPECIALISE reconstructPositionHashQuantifiedGameTree :: Model.Game.Game -> Transformation Type.Crypto.PositionHash #-} reconstructPositionHashQuantifiedGameTree game playState@MkPlayState { getZobrist = zobrist, getMoveFrequency = moveFrequency, @@ -161,14 +144,8 @@ ) playState -- | Reset to the initial state. -resetPositionHashQuantifiedGameTree :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Real pieceSquareValue - ) => Transformation pieceSquareValue positionHash +resetPositionHashQuantifiedGameTree :: Data.Bits.Bits positionHash => Transformation positionHash +{-# SPECIALISE resetPositionHashQuantifiedGameTree :: Transformation Type.Crypto.PositionHash #-} resetPositionHashQuantifiedGameTree playState = reconstructPositionHashQuantifiedGameTree Data.Default.def playState { getCriterionValues = [], getMaybeApplicationTerminationReason = Nothing @@ -178,14 +155,14 @@ updateWithAutomaticMove :: [Metric.CriterionValue.CriterionValue] -> Search.SearchState.SearchState positionHash - -> Transformation pieceSquareValue positionHash + -> Transformation positionHash updateWithAutomaticMove criterionValues searchState playState = playState { getCriterionValues = criterionValues : getCriterionValues playState, getSearchState = searchState } -- | Mutator. -updateWithManualMove :: Model.Game.Game -> Transformation pieceSquareValue positionHash +updateWithManualMove :: Model.Game.Game -> Transformation positionHash updateWithManualMove game playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.State.PlayState.updateWithManualMove:\tEvaluation.PositionHashQuantifiedGameTree.reduce failed." @@ -205,7 +182,7 @@ Floating standardDeviation, Fractional mean ) - => PlayState pieceSquareValue positionHash + => PlayState positionHash -> [(mean, standardDeviation)] calculateCriterionValueStatistics MkPlayState { getCriterionValues = criterionValues } = map ( ( @@ -216,7 +193,7 @@ ) $ Data.List.transpose criterionValues -- | Resignation by the player who currently holds the choice of move. -resign :: Transformation pieceSquareValue positionHash +resign :: Transformation positionHash resign playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Evaluation.PositionHashQuantifiedGameTree.resign $ Search.SearchState.getPositionHashQuantifiedGameTree searchState ) playState @@ -224,7 +201,7 @@ -- | Given a string from which either a /move/ can't be parsed or the one that can is illegal, returns the closest matches amongst the currently available /move/s. suggestCorrections :: String -- ^ Move-string. - -> PlayState pieceSquareValue positionHash + -> PlayState positionHash -> [String] -- ^ Suggested corrections. suggestCorrections moveString playState@MkPlayState { getOptions = options } | Model.Game.isTerminated game = [] @@ -236,12 +213,12 @@ -- | Whether the game in the first /play-state/ has more plies than that in the second. hasMorePlies - :: PlayState pieceSquareValue positionHash - -> PlayState pieceSquareValue positionHash + :: PlayState positionHash + -> PlayState positionHash -> Bool hasMorePlies playState playState' = Data.Ord.comparing (State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour . getGame) playState playState' == GT -- | Whether the user has requested application-termination, or the configured maximum number of turns has been reached. -hasApplicationTerminationBeenRequested :: PlayState pieceSquareValue positionHash -> Bool +hasApplicationTerminationBeenRequested :: PlayState positionHash -> Bool hasApplicationTerminationBeenRequested MkPlayState { getMaybeApplicationTerminationReason = maybeApplicationTerminationReason } = Data.Maybe.isJust maybeApplicationTerminationReason diff --git a/src-exe/BishBosh/UI/CECP.hs b/src-exe/BishBosh/UI/CECP.hs --- a/src-exe/BishBosh/UI/CECP.hs +++ b/src-exe/BishBosh/UI/CECP.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -106,10 +106,6 @@ import qualified System.Random import qualified ToolShed.System.Random -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | Used in output to prefix hints. hintTag :: String hintTag = "Hint:" @@ -169,7 +165,7 @@ showsThinking :: Property.ShowFloat.ShowFloat stoppedWatch => Type.Count.NPlies -- ^ Search-depth. - -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue + -> Input.EvaluationOptions.EvaluationOptions -> Type.Mass.WeightedMean -> stoppedWatch -> Type.Count.NPositions -- ^ Nodes searched. @@ -179,7 +175,7 @@ shows searchDepth, shows . (round :: Type.Mass.RankValue -> Int) $ 100 {-centi-Pawns-} * ( uncurry (/) . ( - Input.RankValues.calculateMaximumTotalValue &&& realToFrac . Input.RankValues.findRankValue Attribute.Rank.Pawn + Input.RankValues.calculateMaximumTotalValue &&& realToFrac . (`Input.RankValues.findRankValue` Attribute.Rank.Pawn) ) $ Input.EvaluationOptions.getRankValues evaluationOptions ) * realToFrac weightedMean, Property.ShowFloat.showsFloat (shows . (round :: Double -> Int) . (* 100)) stoppedWatch, @@ -191,31 +187,17 @@ * Since the user can also request roll-back to an earlier game before then requesting a new move, a new game is returned rather than just the requested move. -} -readMove :: forall pieceSquareValue positionHash randomGen. ( - Control.DeepSeq.NFData pieceSquareValue, -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - System.Random.RandomGen randomGen +readMove :: forall positionHash randomGen. ( + Data.Bits.Bits positionHash, + Ord positionHash, + System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) -{-# SPECIALISE readMove - :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash - -> randomGen - -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash - -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) - #-} + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) +{-# SPECIALISE readMove :: ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> System.Random.StdGen -> Time.StopWatch.StopWatch -> State.PlayState.PlayState Type.Crypto.PositionHash -> IO (State.PlayState.PlayState Type.Crypto.PositionHash) #-} readMove positionHashQualifiedMoveTree randomGen = slave where slave runningWatch playState = let (game, options) = State.PlayState.getGame &&& State.PlayState.getOptions $ playState @@ -235,7 +217,7 @@ \cecpOptions -> let displaySAN = Input.CECPOptions.getDisplaySAN cecpOptions - onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState positionHash) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -253,7 +235,7 @@ ) ( flip (ContextualNotation.StandardAlgebraic.showTurn explicitEnpassant) game ) . Model.Game.maybeLastTurn $ Evaluation.QuantifiedGame.getGame quantifiedGame - else Notation.MoveNotation.showNotation moveNotation $ Evaluation.QuantifiedGame.getLastTurn (quantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame) + else Notation.MoveNotation.showNotation moveNotation $ Evaluation.QuantifiedGame.getLastTurn quantifiedGame _ -> Control.Exception.throwIO . Data.Exception.mkRequestFailure . showString "BishBosh.UI.CECP.readMove.slave.onCommand:\tunexpectedly failed to find any moves; " $ shows game "." -- CAVEAT: the game should have been terminated. ) ( \(qualifiedMove, _) -> putStrLn . showString hintTag . showChar ' ' $ if displaySAN @@ -261,7 +243,7 @@ else Notation.MoveNotation.showNotation moveNotation qualifiedMove ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen ( Input.StandardOpeningOptions.getPreferVictories . Input.SearchOptions.getStandardOpeningOptions $ searchOptions - ) tryToMatchSwitches game positionHashQualifiedMoveTree + ) tryToMatchSwitches positionHashQualifiedMoveTree game return {-to IO-monad-} playState -- N.B.: though one could merely call "eventLoop", a new random-generator is desirable in case an alternative hint is requested. onCommand (UI.Command.Print printObject) = do @@ -274,22 +256,19 @@ Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowPrefix.showsPrefixInfo "quitting on request." return {-to IO-monad-} playState { State.PlayState.getMaybeApplicationTerminationReason = Just State.ApplicationTerminationReason.byRequest } - onCommand (UI.Command.Report reportObject) = do + onCommand (UI.Command.Report reportObject) = let + showMoves :: Notation.MoveNotation.ShowNotation a => [a] -> ShowS + showMoves = Text.ShowList.showsFormattedList' (Notation.MoveNotation.showsNotation moveNotation) + in do putStrLn . tellUser =<< ( case reportObject of - UI.ReportObject.AvailableMoves -> return {-to IO-monad-} . ($ ".") . Text.ShowList.showsFormattedList ( - showChar '|' - ) ( - Notation.MoveNotation.showsNotation moveNotation - ) . Model.Game.findQualifiedMovesAvailableToNextPlayer + UI.ReportObject.AvailableMoves -> return {-to IO-monad-} . ($ ".") . showMoves . Model.Game.findQualifiedMovesAvailableToNextPlayer UI.ReportObject.Board -> return {-to IO-monad-} . show . Model.Game.getBoard UI.ReportObject.EPD -> return {-to IO-monad-} . Property.ExtendedPositionDescription.showEPD UI.ReportObject.FEN -> return {-to IO-monad-} . Property.ForsythEdwards.showFEN UI.ReportObject.Game -> return {-to IO-monad-} . show UI.ReportObject.MaxPositionInstances -> return {-to IO-monad-} . show . State.InstancesByPosition.findMaximumInstances . Model.Game.getInstancesByPosition - UI.ReportObject.Moves -> return {-to IO-monad-} . ($ "") . Text.ShowList.showsFormattedList' ( - Notation.MoveNotation.showsNotation moveNotation - ) . Model.Game.listTurnsChronologically + UI.ReportObject.Moves -> return {-to IO-monad-} . ($ ".") . showMoves . Model.Game.listTurnsChronologically UI.ReportObject.PGN -> fmap ($ ".") . ContextualNotation.PGN.showsGame UI.ReportObject.ReversiblePlyCount -> return {-to IO-monad-} . show . State.InstancesByPosition.countConsecutiveRepeatablePlies . Model.Game.getInstancesByPosition ) game @@ -320,7 +299,7 @@ } } onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState positionHash) rollBack nPlies | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = return {-to IO-monad-} $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState | otherwise = onCommand UI.Command.Restart @@ -386,7 +365,7 @@ return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash) + eventLoop :: IO (State.PlayState.PlayState positionHash) eventLoop = getLine >>= \line -> do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "received \"" $ showString line "\"." @@ -434,7 +413,7 @@ [(name, _result)] -> showString ":\t" . showString name _ -> id ) "" - ) $ ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches game positionHashQualifiedMoveTree + ) $ ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches positionHashQualifiedMoveTree game eventLoop "computer" -> eventLoop -- No action required. @@ -973,10 +952,10 @@ maybePaused = Input.CECPOptions.getMaybePaused cecpOptions - moveCommand :: String -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + moveCommand :: String -> IO (State.PlayState.PlayState positionHash) moveCommand moveString = case Notation.MoveNotation.readsQualifiedMove moveNotation moveString of [(eitherQualifiedMove, "")] - | Just errorMessage <- Model.Game.validateEitherQualifiedMove eitherQualifiedMove game -> do + | Just errorMessage <- Model.Game.validateEitherQualifiedMove game eitherQualifiedMove -> do Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixError . shows moveString . showString " is illegal; " $ shows errorMessage "." putStrLn $ mkIllegalMoveMessage errorMessage moveString @@ -996,7 +975,7 @@ ) $ Model.Game.maybeLastTurn game' ) . showString " was requested after " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." - case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition game' positionHashQualifiedMoveTree of + case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition positionHashQualifiedMoveTree game' of [] -> return () onymousQualifiedMoves -> System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "matches archived game(s):" $ ContextualNotation.QualifiedMoveForest.showsNames ( Input.IOOptions.getMaybeMaximumPGNNames ioOptions @@ -1023,29 +1002,16 @@ ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall pieceSquareValue positionHash randomGen. ( - Control.DeepSeq.NFData pieceSquareValue, -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - System.Random.RandomGen randomGen +takeTurns :: forall positionHash randomGen. ( + Data.Bits.Bits positionHash, + Ord positionHash, + System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) -{-# SPECIALISE takeTurns - :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash - -> randomGen - -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash - -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) - #-} + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) +{-# SPECIALISE takeTurns :: ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> System.Random.StdGen -> State.PlayState.PlayState Type.Crypto.PositionHash -> IO (State.PlayState.PlayState Type.Crypto.PositionHash) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = do mVar <- Control.Concurrent.newEmptyMVar @@ -1066,8 +1032,8 @@ :: Maybe (Concurrent.Pondering.Pondering Component.Move.Move) -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) slave maybePondering maybeMaximumPlies ~(randomGen' : randomGens) playState' = let (game', (searchOptions', uiOptions')) = State.PlayState.getGame &&& (Input.Options.getSearchOptions &&& Input.IOOptions.getUIOptions . Input.Options.getIOOptions) . State.PlayState.getOptions $ playState' -- Deconstruct. (ponderMode, isPostMode) = const ( @@ -1083,7 +1049,7 @@ do playState'' <- readMove positionHashQualifiedMoveTree randomGen' runningWatch playState' -- Read the user's command or move. - (,) playState'' `fmap` ( + (,) playState'' <$> ( if playState' `State.PlayState.hasMorePlies` playState'' then {-rolled-back-} Data.Maybe.maybe ( return {-to IO-monad-} Nothing @@ -1165,7 +1131,7 @@ State.PlayState.updateWithAutomaticMove ( Metric.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) searchState' playState' - ) `fmap` if ponderMode && Input.SearchOptions.getUsePondering searchOptions + ) <$> if ponderMode && Input.SearchOptions.getUsePondering searchOptions then case continuation of quantifiedGame' {-1st move after ours in optimal move-sequence-} : _ -> fmap Just . ( \positionHashQuantifiedGameTree'' -> Concurrent.Pondering.ponder ( @@ -1213,7 +1179,7 @@ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' ) ( Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions - ) game' positionHashQualifiedMoveTree -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. + ) positionHashQualifiedMoveTree game' -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. ) ( if Input.UIOptions.isCECPManualMode uiOptions' then Nothing diff --git a/src-exe/BishBosh/UI/Raw.hs b/src-exe/BishBosh/UI/Raw.hs --- a/src-exe/BishBosh/UI/Raw.hs +++ b/src-exe/BishBosh/UI/Raw.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -68,7 +68,6 @@ import qualified BishBosh.Time.StopWatch as Time.StopWatch import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Mass as Type.Mass import qualified BishBosh.UI.Command as UI.Command import qualified BishBosh.UI.PrintObject as UI.PrintObject import qualified BishBosh.UI.ReportObject as UI.ReportObject @@ -88,40 +87,22 @@ import qualified System.Random import qualified ToolShed.System.Random -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - {- | * Reads a command-sequence from the user, terminating in either a request to move or to exit the game. * Since the user can also request roll-back to an earlier game before then requesting a new move, a new game is returned rather than just the requested move. -} -readMove :: forall pieceSquareValue positionHash randomGen. ( - Control.DeepSeq.NFData pieceSquareValue, -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - System.Random.RandomGen randomGen +readMove :: forall positionHash randomGen. ( + Data.Bits.Bits positionHash, + Ord positionHash, + System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) -{-# SPECIALISE readMove - :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash - -> randomGen - -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash - -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) - #-} + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) +{-# SPECIALISE readMove :: ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> System.Random.StdGen -> Time.StopWatch.StopWatch -> State.PlayState.PlayState Type.Crypto.PositionHash -> IO (State.PlayState.PlayState Type.Crypto.PositionHash) #-} readMove positionHashQualifiedMoveTree randomGen runningWatch playState = let (game, options) = State.PlayState.getGame &&& State.PlayState.getOptions $ playState (searchOptions, ioOptions) = Input.Options.getSearchOptions &&& Input.Options.getIOOptions $ options @@ -137,7 +118,9 @@ in ( \nativeUIOptions -> let show2D :: Model.Game.Game -> String - show2D = State.MaybePieceByCoordinates.show2D ( + show2D g = State.MaybePieceByCoordinates.show2D ( + State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard g + ) ( snd {-columns-} $ Input.NativeUIOptions.getBoardMagnification nativeUIOptions ) ( Input.NativeUIOptions.getColourScheme nativeUIOptions @@ -145,9 +128,9 @@ Input.NativeUIOptions.getDepictFigurine nativeUIOptions ) ( Notation.MoveNotation.getOrigin moveNotation - ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard + ) - onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState positionHash) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -173,7 +156,7 @@ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen ) ( Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions - ) game positionHashQualifiedMoveTree + ) positionHashQualifiedMoveTree game return {-to IO-monad-} playState -- N.B.: though one could merely call "eventLoop", a new random-generator is desirable in case an alternative hint is requested. onCommand (UI.Command.Print printObject) = do @@ -186,21 +169,18 @@ Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowColouredPrefix.showsPrefixInfo "quitting on request." return {-to IO-monad-} playState { State.PlayState.getMaybeApplicationTerminationReason = Just State.ApplicationTerminationReason.byRequest } - onCommand (UI.Command.Report reportObject) = do + onCommand (UI.Command.Report reportObject) = let + showMoves :: Notation.MoveNotation.ShowNotation a => [a] -> ShowS + showMoves = Text.ShowList.showsFormattedList' (Notation.MoveNotation.showsNotation moveNotation) + in do ($ game) $ case reportObject of - UI.ReportObject.AvailableMoves -> putStrLn . ($ ".") . Text.ShowList.showsFormattedList ( - showChar '|' - ) ( - Notation.MoveNotation.showsNotation moveNotation - ) . Model.Game.findQualifiedMovesAvailableToNextPlayer + UI.ReportObject.AvailableMoves -> putStrLn . ($ ".") . showMoves . Model.Game.findQualifiedMovesAvailableToNextPlayer UI.ReportObject.Board -> putStrLn . show2D UI.ReportObject.EPD -> putStrLn . Property.ExtendedPositionDescription.showEPD UI.ReportObject.FEN -> putStrLn . Property.ForsythEdwards.showFEN UI.ReportObject.Game -> print UI.ReportObject.MaxPositionInstances -> print . State.InstancesByPosition.findMaximumInstances . Model.Game.getInstancesByPosition - UI.ReportObject.Moves -> putStrLn . ($ "") . Text.ShowList.showsFormattedList' ( - Notation.MoveNotation.showsNotation moveNotation - ) . Model.Game.listTurnsChronologically + UI.ReportObject.Moves -> putStrLn . ($ ".") . showMoves . Model.Game.listTurnsChronologically UI.ReportObject.PGN -> putStrLn . ($ ".") <=< ContextualNotation.PGN.showsGame UI.ReportObject.ReversiblePlyCount -> print . State.InstancesByPosition.countConsecutiveRepeatablePlies . Model.Game.getInstancesByPosition @@ -216,7 +196,7 @@ return {-to IO-monad-} $ State.PlayState.resetPositionHashQuantifiedGameTree playState onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState positionHash) rollBack nPlies | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = do Control.Monad.when (verbosity == maxBound) . putStrLn $ show2D game' @@ -288,7 +268,7 @@ return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash) + eventLoop :: IO (State.PlayState.PlayState positionHash) eventLoop = getLine >>= \line -> case Data.List.Extra.trim line of "?" -> onCommand $ UI.Command.Print UI.PrintObject.Help ':' : s -> ( @@ -310,7 +290,7 @@ corrections = State.PlayState.suggestCorrections s playState in case Notation.MoveNotation.readsQualifiedMove moveNotation s of [(eitherQualifiedMove, "")] - | Just errorMessage <- Model.Game.validateEitherQualifiedMove eitherQualifiedMove game -> do + | Just errorMessage <- Model.Game.validateEitherQualifiedMove game eitherQualifiedMove -> do System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixError . shows s . showString " is illegal; " $ shows errorMessage "." Control.Monad.unless (null corrections) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "did you mean " $ shows corrections " ?" @@ -330,7 +310,7 @@ ) $ Model.Game.maybeLastTurn game' ) . showString " was requested after " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." - case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition game' positionHashQualifiedMoveTree of + case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition positionHashQualifiedMoveTree game' of [] -> return {-to IO-monad-} () onymousQualifiedMoves -> System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "matches archived game(s):" $ ContextualNotation.QualifiedMoveForest.showsNames maybeMaximumPGNNames ( concatMap ( @@ -359,29 +339,16 @@ ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall pieceSquareValue positionHash randomGen. ( - Control.DeepSeq.NFData pieceSquareValue, -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - System.Random.RandomGen randomGen +takeTurns :: forall positionHash randomGen. ( + Data.Bits.Bits positionHash, + Ord positionHash, + System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) -{-# SPECIALISE takeTurns - :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash - -> randomGen - -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash - -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) - #-} + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) +{-# SPECIALISE takeTurns :: ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> System.Random.StdGen -> State.PlayState.PlayState Type.Crypto.PositionHash -> IO (State.PlayState.PlayState Type.Crypto.PositionHash) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = let options = State.PlayState.getOptions playState @@ -398,7 +365,9 @@ let show2D :: Model.Game.Game -> String - show2D = State.MaybePieceByCoordinates.show2D ( + show2D game = State.MaybePieceByCoordinates.show2D ( + State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game + ) ( snd {-columns-} $ Input.NativeUIOptions.getBoardMagnification nativeUIOptions ) ( Input.NativeUIOptions.getColourScheme nativeUIOptions @@ -406,14 +375,14 @@ Input.NativeUIOptions.getDepictFigurine nativeUIOptions ) ( Notation.MoveNotation.getOrigin moveNotation - ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard + ) slave :: Maybe (Concurrent.Pondering.Pondering Component.Move.Move) -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState pieceSquareValue positionHash - -> IO (State.PlayState.PlayState pieceSquareValue positionHash) + -> State.PlayState.PlayState positionHash + -> IO (State.PlayState.PlayState positionHash) slave maybePondering maybeMaximumPlies ~(randomGen' : randomGens) playState' = let (game', searchOptions') = State.PlayState.getGame &&& Input.Options.getSearchOptions . State.PlayState.getOptions $ playState' -- Deconstruct. in Data.Maybe.maybe ( @@ -424,7 +393,7 @@ do playState'' <- readMove positionHashQualifiedMoveTree randomGen' runningWatch playState' -- Block reading a command-sequence terminating in a move from a manual player. - (,) playState'' `fmap` ( + (,) playState'' <$> ( if playState' `State.PlayState.hasMorePlies` playState'' then {-rolled-back-} Data.Maybe.maybe ( return {-to IO-monad-} Nothing @@ -444,7 +413,10 @@ ) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowColouredPrefix.showsPrefixInfo "failed to find any suitable archived move." let - search ss = Control.Monad.Reader.runReader (Search.Search.search searchDepth' ss) searchOptions' + search ss = Control.Monad.Reader.runReader ( + Search.Search.search searchDepth' ss + ) searchOptions' + searchResult = search $ State.PlayState.getSearchState playState' Data.Maybe.maybe ( @@ -492,7 +464,7 @@ State.PlayState.updateWithAutomaticMove ( Metric.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) searchState' playState' - ) `fmap` if Input.SearchOptions.getUsePondering searchOptions + ) <$> if Input.SearchOptions.getUsePondering searchOptions then case continuation of quantifiedGame' {-1st move after ours in optimal move-sequence-} : _ -> fmap Just . ( \positionHashQuantifiedGameTree'' -> Concurrent.Pondering.ponder ( @@ -538,7 +510,7 @@ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' ) ( Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions - ) game' positionHashQualifiedMoveTree -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. + ) positionHashQualifiedMoveTree game' -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. ) ( Model.Game.getNextLogicalColour game' `Map.lookup` Input.SearchOptions.getSearchDepthByLogicalColour searchOptions' -- Determinate whether the next player is manual. ) >>= ( diff --git a/src-exe/Duel/Data/Options.hs b/src-exe/Duel/Data/Options.hs --- a/src-exe/Duel/Data/Options.hs +++ b/src-exe/Duel/Data/Options.hs @@ -46,13 +46,13 @@ appendInputConfigFilePath ) where -import qualified Control.Exception -import qualified Data.Default -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.Verbosity as Input.Verbosity import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.Type.Count as Type.Count +import qualified Control.Exception +import qualified Data.Default import qualified System.FilePath -- | Container for all command-line options. @@ -77,7 +77,7 @@ instance Property.SelfValidating.SelfValidating Options where findInvalidity = Property.SelfValidating.findErrors [ - ((/= Attribute.LogicalColour.nDistinctLogicalColours) . fromIntegral . length . getInputConfigFilePaths, "There must be exactly one configuration file for White & one for Black.") + ((/= Colour.LogicalColour.nDistinctLogicalColours) . fromIntegral . length . getInputConfigFilePaths, "There must be exactly one configuration file for White & one for Black.") ] -- | Mutator. @@ -109,7 +109,7 @@ appendInputConfigFilePath s options | fromIntegral ( length inputConfigFilePaths - ) == Attribute.LogicalColour.nDistinctLogicalColours = Control.Exception.throw . Data.Exception.mkRedundantData . showString "Duel.Data.Options:\texactly " . shows Attribute.LogicalColour.nDistinctLogicalColours . showString " file-paths are required:\t" $ shows inputConfigFilePaths "." + ) == Colour.LogicalColour.nDistinctLogicalColours = Control.Exception.throw . Data.Exception.mkRedundantData . showString "Duel.Data.Options:\texactly " . shows Colour.LogicalColour.nDistinctLogicalColours . showString " file-paths are required:\t" $ shows inputConfigFilePaths "." | otherwise = options { getInputConfigFilePaths = s : inputConfigFilePaths } where inputConfigFilePaths = getInputConfigFilePaths options diff --git a/src-exe/Duel/Process/Intermediary.hs b/src-exe/Duel/Process/Intermediary.hs --- a/src-exe/Duel/Process/Intermediary.hs +++ b/src-exe/Duel/Process/Intermediary.hs @@ -44,7 +44,7 @@ import Control.Arrow((&&&), (|||)) import Control.Category((>>>)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.CommandLineOption as Input.CommandLineOption import qualified BishBosh.Input.IOOptions as Input.IOOptions @@ -62,7 +62,6 @@ import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Time.GameClock as Time.GameClock import qualified BishBosh.Type.Count as Type.Count -import qualified BishBosh.Type.Mass as Type.Mass import qualified BishBosh.UI.Command as UI.Command import qualified BishBosh.UI.ReportObject as UI.ReportObject import qualified Control.Exception @@ -118,9 +117,9 @@ -- | Read either a move or a game-termination reason from the specified handle. readMove :: Input.Verbosity.Verbosity - -> Type.Count.NSeconds -- ^ Read-timout. - -> Attribute.LogicalColour.LogicalColour -- ^ Whose turn it is. - -> System.IO.Handle -- ^ Output handle from which data should be read. + -> Type.Count.NSeconds -- ^ Read-timout. + -> Colour.LogicalColour.LogicalColour -- ^ Whose turn it is. + -> System.IO.Handle -- ^ Output handle from which data should be read. -> IO (Either Rule.GameTerminationReason.GameTerminationReason MoveNotation) readMove verbosity readTimeout logicalColour stdOut = do Control.Monad.when (verbosity == maxBound) . IO.Logger.printInfo . showString "Waiting " . ( @@ -150,10 +149,10 @@ -- | Read either a move from the first handle & write it to the second. copyMove :: Input.Verbosity.Verbosity - -> Type.Count.NSeconds -- ^ Read-timout. - -> Attribute.LogicalColour.LogicalColour -- ^ Whose turn it is. - -> System.IO.Handle -- ^ Output handle from which move should be read. - -> System.IO.Handle -- ^ Input handle to which move should be forwarded. + -> Type.Count.NSeconds -- ^ Read-timout. + -> Colour.LogicalColour.LogicalColour -- ^ Whose turn it is. + -> System.IO.Handle -- ^ Output handle from which move should be read. + -> System.IO.Handle -- ^ Input handle to which move should be forwarded. -> IO (Maybe Rule.GameTerminationReason.GameTerminationReason) copyMove verbosity readTimeout logicalColour stdOut stdIn = do readMove verbosity readTimeout logicalColour stdOut >>= return {-to IO-monad-} . Just ||| ( @@ -331,9 +330,7 @@ ] configFilePath >>> HXT.arr ( \inputOptions -> ( - Input.SearchOptions.identifyAutomatedPlayers $ Input.Options.getSearchOptions ( - inputOptions :: Input.Options.Options Type.Mass.PieceSquareValue -- Arbitrary concrete type. - ), + Input.SearchOptions.identifyAutomatedPlayers $ Input.Options.getSearchOptions inputOptions, Input.UIOptions.getMoveNotation . Input.IOOptions.getUIOptions $ Input.Options.getIOOptions inputOptions, null . Input.IOOptions.getPGNOptionsList $ Input.Options.getIOOptions inputOptions ) diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -90,12 +90,9 @@ #endif #ifdef USE_UNIX -import qualified BishBosh.Concurrent.SignalHandlers as Concurrent.SignalHandlers +import qualified BishBosh.Concurrent.SignalHandlers as Concurrent.SignalHandlers #endif --- Define concrete types to resolve the underlying polymorphic functions. -type Options = Input.Options.Options Type.Mass.PieceSquareValue - writeXMLToFile :: HXT.XmlPickler pickleable => System.FilePath.FilePath -- ^ Destination. @@ -152,7 +149,7 @@ optDescrList :: [ G.OptDescr ( Maybe (Input.CommandLineOption.Flag, Maybe String {-optional value-}), -- Record command-line specifications. - Input.CommandLineOption.CommandLineOption Options -- Defines the action to take on receipt of a command-line option. + Input.CommandLineOption.CommandLineOption Input.Options.Options -- Defines the action to take on receipt of a command-line option. ) -- Pair. ] optDescrList = [ @@ -235,12 +232,12 @@ defaultRandomSeed = 0 -- Unary options-mutators. - setPrintMoveTree, setVerbosity, setOutputConfigFilePath :: String -> Input.CategorisedCommandLineOptions.OptionsMutator Options + setPrintMoveTree, setVerbosity, setOutputConfigFilePath :: String -> Input.CategorisedCommandLineOptions.OptionsMutator Input.Options.Options setPrintMoveTree = Input.Options.setMaybePrintMoveTree . Just . Input.CommandLineOption.readArg setVerbosity = Input.Options.setVerbosity . Input.CommandLineOption.readArg setOutputConfigFilePath = Input.Options.setMaybeOutputConfigFilePath . Just - setRandomSeed :: Maybe String -> Input.CategorisedCommandLineOptions.OptionsMutator Options + setRandomSeed :: Maybe String -> Input.CategorisedCommandLineOptions.OptionsMutator Input.Options.Options setRandomSeed = Input.Options.setMaybeRandomSeed . Just . Data.Maybe.maybe defaultRandomSeed Input.CommandLineOption.readBoundedIntegral -- Nullary I/O-actions. @@ -259,14 +256,14 @@ showsVersion :: Data.Version.Version -> ShowS showsVersion = foldr (.) id . Data.List.intersperse (showChar '.') . map shows . Data.Version.versionBranch - checkPickler = Control.Monad.void . HXT.runX $ HXT.constA (Data.Default.def :: Options) >>> HXT.checkPickler HXT.xpickle + checkPickler = Control.Monad.void . HXT.runX $ HXT.constA (Data.Default.def :: Input.Options.Options) >>> HXT.checkPickler HXT.xpickle generateDTD :: Maybe String -> Input.CategorisedCommandLineOptions.IOAction - generateDTD hxtTraceLevel = Control.Monad.void . HXT.runX $ HXT.constA (undefined :: Options) >>> HXT.xpickleWriteDTD HXT.xpickle [ + generateDTD hxtTraceLevel = Control.Monad.void . HXT.runX $ HXT.constA (undefined :: Input.Options.Options) >>> HXT.xpickleWriteDTD HXT.xpickle [ HXT.withTrace $ Data.Maybe.maybe 0 Input.CommandLineOption.readBoundedIntegral hxtTraceLevel -- Valid values in closed interval [0, 4] ] "-" {-stdout-} -- CAVEAT: this DTD requires manual correction of defaulted attributes, which are erroneously defined as 'REQUIRED' rather than 'IMPLIED'. - formatPieceSquareTableForGNUPlot :: Input.CategorisedCommandLineOptions.ContextualIOAction Options + formatPieceSquareTableForGNUPlot :: Input.CategorisedCommandLineOptions.ContextualIOAction Input.Options.Options formatPieceSquareTableForGNUPlot options = Data.Maybe.maybe ( Control.Exception.throwIO $ Data.Exception.mkNullDatum "the piece-square table is undefined." ) ( @@ -275,17 +272,17 @@ \gamePhase -> showChar Component.PieceSquareByCoordinatesByRank.gnuPlotComment . showString gamePhase . showString "-game:\n" ) ["Opening", "End"] ) $ map ( - \selector -> Component.PieceSquareByCoordinatesByRank.formatForGNUPlot ( + \selector -> Component.PieceSquareByCoordinatesByRank.formatForGNUPlot pieceSquareByCoordinatesByRank ( Property.ShowFloat.showsFloatToN' ( Input.UIOptions.getNDecimalDigits . Input.IOOptions.getUIOptions $ Input.Options.getIOOptions options -- PieceSquareValue formatter. ) . ( - realToFrac :: Type.Mass.PieceSquareValue -> Input.PieceSquareTable.IOFormat -- N.B.: required when compiled with 'USE_PRECISION'. + realToFrac :: Type.Mass.PieceSquareValue -> Input.PieceSquareTable.IOFormat ) ) ( showChar '\t' -- Column-delimiter. ) ( ! selector Component.PieceSquareByCoordinatesByRank.nPiecesBounds -- Select from interpolated values. - ) pieceSquareByCoordinatesByRank + ) ) [snd, fst] ) . Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank $ Input.Options.getEvaluationOptions options @@ -332,9 +329,9 @@ hxtTraceLevel :: Int hxtTraceLevel = fromEnum preVerbosity `min` 2 {-CAVEAT: HXT trace-levels 3 & 4 are too verbose-} - processInputOptions :: Options -> IO Options + processInputOptions :: Input.Options.Options -> IO Input.Options.Options processInputOptions options = let - options' :: Options + options' :: Input.Options.Options options' = ( \o -> ( if Data.Maybe.isNothing . Input.IOOptions.getMaybePersistence $ Input.Options.getIOOptions o @@ -428,7 +425,7 @@ ) ( \absolutePGNDatabaseFilePath -> either ( Control.Exception.throw . Data.Exception.mkParseFailure - ) id `fmap` ContextualNotation.PGNDatabase.parseIO absolutePGNDatabaseFilePath ( + ) id <$> ContextualNotation.PGNDatabase.parseIO absolutePGNDatabaseFilePath ( Input.PGNOptions.getMaybeDecompressor pgnOptions ) ( Input.PGNOptions.getIsStrictlySequential pgnOptions @@ -449,7 +446,7 @@ ) Property.Empty.empty {-QualifiedMoveForest-} (Input.IOOptions.getPGNOptionsList ioOptions) let - maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) + maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Type.Crypto.PositionHash) in Control.Monad.when ( verbosity /= minBound && Data.Maybe.isJust maybeApplicationTerminationReason ) . System.IO.hPutStrLn System.IO.stderr . showsInfoPrefix . showString "application terminated " $ shows (Data.Maybe.fromJust maybeApplicationTerminationReason) "." diff --git a/src-lib/BishBosh/Attribute/ANSIColourCode.hs b/src-lib/BishBosh/Attribute/ANSIColourCode.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/ANSIColourCode.hs +++ /dev/null @@ -1,76 +0,0 @@ -{- - Copyright (C) 2021 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Defines the encoding of colours for rendering on a terminal; . --} - -module BishBosh.Attribute.ANSIColourCode( --- * Types --- ** Type-synonyms --- ANSIColourCode(), --- IsBold, - GraphicsRendition, --- * Functions - selectGraphicsRendition, - bracket, --- ** Constructors - mkFgColourCode, - mkBgColourCode -) where - -import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour -import qualified Data.Default - --- | A colour-code as used by terminal-emulators. -newtype ANSIColourCode = MkANSIColourCode { - deconstruct :: Int -} - -instance Show ANSIColourCode where - showsPrec precedence MkANSIColourCode { deconstruct = i } = showsPrec precedence i - -instance Data.Default.Default ANSIColourCode where - def = MkANSIColourCode 0 - --- | The font-weight of a character. -type IsBold = Bool - --- | An escape-sequence used to control a terminal. -type GraphicsRendition = String - --- | Constructor: offset the specified colour-code, so that it applies to the foreground. -mkFgColourCode :: Attribute.PhysicalColour.PhysicalColour -> ANSIColourCode -mkFgColourCode = MkANSIColourCode . (+ 30) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} - --- | Constructor: offset the specified colour-code, so that it applies to the background. -mkBgColourCode :: Attribute.PhysicalColour.PhysicalColour -> ANSIColourCode -mkBgColourCode = MkANSIColourCode . (+ 40) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} - --- | Generate the escape-sequence required to change a terminal to the specified physical colour. -selectGraphicsRendition :: IsBold -> ANSIColourCode -> GraphicsRendition -selectGraphicsRendition isBold parameter = showString "\x1b[" . shows parameter $ (if isBold then showString ";1" else id) "m" - --- | Render the specified string according to instructions, then revert to the default. -bracket :: GraphicsRendition -> String -> ShowS -bracket graphicsRendition s = showString graphicsRendition . showString s . showString ( - selectGraphicsRendition False Data.Default.def - ) - diff --git a/src-lib/BishBosh/Attribute/ColourScheme.hs b/src-lib/BishBosh/Attribute/ColourScheme.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/ColourScheme.hs +++ /dev/null @@ -1,159 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Defines the physical colour used to represent each component of the board. --} - -module BishBosh.Attribute.ColourScheme ( --- * Types --- ** Data-types - ColourScheme( --- MkColourScheme, - getDarkPieceColour, - getLightPieceColour, - getDarkSquareColour, - getLightSquareColour - ), --- * Constants - tag, --- darkSquareColourTag, --- lightSquareColourTag, --- darkPieceColourTag, --- lightPieceColourTag, --- * Functions --- ** Constructor --- mkColourScheme -) 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 - --- | Used to qualify XML. -tag :: String -tag = "colourScheme" - -darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag :: String -[darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag] = [showString brightness $ showString component "Colour" | brightness <- ["dark", "light"], component <- ["Piece", "Square"]] -- List-comprehension. - --- | Defines the command-line options. -data ColourScheme = MkColourScheme { - getDarkPieceColour :: Attribute.PhysicalColour.PhysicalColour, -- ^ The physical colour of the dark pieces. - getLightPieceColour :: Attribute.PhysicalColour.PhysicalColour, -- ^ The physical colour of the light pieces. - getDarkSquareColour :: Attribute.PhysicalColour.PhysicalColour, -- ^ The physical colour of the dark squares of the board. - getLightSquareColour :: Attribute.PhysicalColour.PhysicalColour -- ^ The physical colour of the light squares of the board. -} deriving Eq - -instance Control.DeepSeq.NFData ColourScheme where - rnf MkColourScheme { - getDarkPieceColour = darkPieceColour, - getLightPieceColour = lightPieceColour, - getDarkSquareColour = darkSquareColour, - getLightSquareColour = lightSquareColour - } = Control.DeepSeq.rnf ( - darkPieceColour, - lightPieceColour, - darkSquareColour, - lightSquareColour - ) - -instance Show ColourScheme where - showsPrec _ MkColourScheme { - getDarkPieceColour = darkPieceColour, - getLightPieceColour = lightPieceColour, - getDarkSquareColour = darkSquareColour, - getLightSquareColour = lightSquareColour - } = Text.ShowList.showsAssociationList' $ map (Control.Arrow.second shows) [ - ( - darkPieceColourTag, - darkPieceColour - ), ( - lightPieceColourTag, - lightPieceColour - ), ( - darkSquareColourTag, - darkSquareColour - ), ( - lightSquareColourTag, - lightSquareColour - ) - ] - -instance Data.Default.Default ColourScheme where - def = MkColourScheme { - getDarkPieceColour = Attribute.PhysicalColour.blue, - getLightPieceColour = Property.Opposable.getOpposite $ getDarkPieceColour Data.Default.def, - getDarkSquareColour = Attribute.PhysicalColour.black, - getLightSquareColour = Property.Opposable.getOpposite $ getDarkSquareColour Data.Default.def - } - -instance HXT.XmlPickler ColourScheme where - xpickle = HXT.xpElem tag . HXT.xpWrap ( - \(a, b, c, d) -> mkColourScheme a b c d, -- Construct. - \MkColourScheme { - getDarkPieceColour = darkPieceColour, - getLightPieceColour = lightPieceColour, - getDarkSquareColour = darkSquareColour, - getLightSquareColour = lightSquareColour - } -> ( - darkPieceColour, - lightPieceColour, - darkSquareColour, - lightSquareColour - ) -- Deconstruct. - ) $ HXT.xp4Tuple ( - getDarkPieceColour def `HXT.xpDefault` HXT.xpAttr darkPieceColourTag HXT.xpickle - ) ( - getLightPieceColour def `HXT.xpDefault` HXT.xpAttr lightPieceColourTag HXT.xpickle - ) ( - getDarkSquareColour def `HXT.xpDefault` HXT.xpAttr darkSquareColourTag HXT.xpickle - ) ( - getLightSquareColour def `HXT.xpDefault` HXT.xpAttr lightSquareColourTag HXT.xpickle - ) where - def :: ColourScheme - def = Data.Default.def - --- | Smart constructor. -mkColourScheme - :: Attribute.PhysicalColour.PhysicalColour -- ^ Dark piece. - -> Attribute.PhysicalColour.PhysicalColour -- ^ Light piece. - -> Attribute.PhysicalColour.PhysicalColour -- ^ Dark square. - -> Attribute.PhysicalColour.PhysicalColour -- ^ Light square. - -> ColourScheme -mkColourScheme darkPieceColour lightPieceColour darkSquareColour lightSquareColour - | darkPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\t" . showString darkPieceColourTag . Text.ShowList.showsAssociation . shows darkPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "." - | lightPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\t" . showString lightPieceColourTag . Text.ShowList.showsAssociation . shows lightPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "." - | darkSquareColour == lightSquareColour = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Attribute.ColourScheme.mkColourScheme:\tthe physical colours of " . shows lightSquareColourTag . showString " & " $ shows darkSquareColourTag ", must differ." - | otherwise = MkColourScheme { - getDarkPieceColour = darkPieceColour, - getLightPieceColour = lightPieceColour, - getDarkSquareColour = darkSquareColour, - getLightSquareColour = lightSquareColour - } - where - bgColours = [darkSquareColour, lightSquareColour] - diff --git a/src-lib/BishBosh/Attribute/Direction.hs b/src-lib/BishBosh/Attribute/Direction.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/Direction.hs +++ /dev/null @@ -1,265 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] - - * Describes a /direction/ in two parts; the sense of change in the /x/-coordinate & the sense of change in the /y/-coordinate. - - * The IO-format uses a more concise & familiar format based on 8 points of the compass. - - * CAVEAT: this separation of /direction/ into orthogonal components is driven by the typical use-case, - but requires that one guards against accidental construction of a degenerate 9th /direction/ which defines a change in neither direction. --} - -module BishBosh.Attribute.Direction( --- * Types --- ** Type-synonyms - ArrayByDirection, --- ** Data-types - Direction( --- MkDirection, - getXDirection, - getYDirection - ), --- * Constants - nw, - n, - ne, - w, - e, - sw, - s, - se, - tag, - nDistinctDirections, - parallels, - diagonals, --- range, - opposites, --- * Functions --- getOpposite, - advanceDirection, - attackDirectionsForPawn, - listArrayByDirection, --- ** Constructor - mkDirection, --- ** Predicates - areAligned -) where - -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Property.Reflectable as Property.Reflectable -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 = "direction" - --- | Constant direction. -nw :: Direction -nw = MkDirection LT GT - --- | Constant direction. -n :: Direction -n = MkDirection EQ GT - --- | Constant direction. -ne :: Direction -ne = MkDirection GT GT - --- | Constant direction. -w :: Direction -w = MkDirection LT EQ - --- | Constant direction. -e :: Direction -e = MkDirection GT EQ - --- | Constant direction. -sw :: Direction -sw = MkDirection LT LT - --- | Constant direction. -s :: Direction -s = MkDirection EQ LT - --- | Constant direction. -se :: Direction -se = MkDirection GT LT - --- | Define a /direction/ by the sense of change to /x/ & /y/ coordinates. -data Direction = MkDirection { - getXDirection :: ! Ordering, -- ^ The sense of the change in the /x/-coordinate. - getYDirection :: ! Ordering -- ^ The sense of the change in the /y/-coordinate. -} deriving (Eq, Ord) - -instance Bounded Direction where - minBound = sw - maxBound = ne - -instance Control.DeepSeq.NFData Direction where - rnf MkDirection { - getXDirection = xDirection, - getYDirection = yDirection - } = xDirection `seq` yDirection `seq` () - -instance Show Direction where - showsPrec _ MkDirection { - getXDirection = xDirection, - getYDirection = yDirection - } = ( - case yDirection of - LT -> showChar 'S' - EQ -> id - GT -> showChar 'N' - ) . ( - case xDirection of - LT -> showChar 'W' - EQ -> id - GT -> showChar 'E' - ) - -instance Read Direction where - readsPrec _ ss = let - s' = Data.List.Extra.trimStart ss - in case Data.List.Extra.upper s' of - 'S' : remainder -> case remainder of - 'W' : _ -> [(sw, drop 2 s')] - 'E' : _ -> [(se, drop 2 s')] - _ -> [(s, tail s')] - 'N' : remainder -> case remainder of - 'W' : _ -> [(nw, drop 2 s')] - 'E' : _ -> [(ne, drop 2 s')] - _ -> [(n, tail s')] - 'W' : _ -> [(w, tail s')] - 'E' : _ -> [(e, tail s')] - _ -> [] -- No parse. - -instance Property.Opposable.Opposable Direction where - getOpposite MkDirection { - getXDirection = xDirection, - getYDirection = yDirection - } = MkDirection { - getXDirection = Property.Opposable.getOpposite xDirection, - getYDirection = Property.Opposable.getOpposite yDirection - } - -instance Property.Orientated.Orientated Direction where - isDiagonal MkDirection { getXDirection = xDirection, getYDirection = yDirection } = xDirection /= EQ && yDirection /= EQ - isParallel MkDirection { getXDirection = xDirection, getYDirection = yDirection } = xDirection == EQ || yDirection == EQ - isStraight = const True - -instance Property.Reflectable.ReflectableOnX Direction where - reflectOnX direction@MkDirection { getYDirection = yDirection } = direction { - getYDirection = Property.Opposable.getOpposite yDirection - } - -instance Property.Reflectable.ReflectableOnY Direction where - reflectOnY direction@MkDirection { getXDirection = xDirection } = direction { - getXDirection = Property.Opposable.getOpposite xDirection - } - -instance HXT.XmlPickler Direction where - xpickle = HXT.xpWrap (read, show) . HXT.xpAttr tag . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range - -instance Data.Array.IArray.Ix Direction where - range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) Property.FixedMembership.members - inRange (lower, upper) _ = Control.Exception.assert (lower == minBound && upper == maxBound) True - index (lower, upper) (MkDirection xDirection yDirection) = Control.Exception.assert (lower == minBound && upper == maxBound) $ case xDirection of - LT -> case yDirection of - LT -> 0 - EQ -> 1 - GT -> 2 - EQ -> case yDirection of - LT -> 3 - EQ -> Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Attribute.Direction.index:\tundefined direction." - GT -> 4 - GT -> case yDirection of - LT -> 5 - EQ -> 6 - GT -> 7 - --- | The ordered /direction/s in which /royalty/ can move. -range :: [Direction] -range = [sw, w, nw, s, n, se, e, ne] - -instance Property.FixedMembership.FixedMembership Direction where - members = range - --- | Smart constructor. -mkDirection - :: Ordering -- ^ The sense of the change in the /x/-coordinate. - -> Ordering -- ^ The sense of the change in the /y/-coordinate. - -> Direction -mkDirection EQ EQ = Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Attribute.Direction.mkDirection:\till-defined." -mkDirection xDirection yDirection = MkDirection xDirection yDirection - --- | The ordered /direction/s in which a @Rook@ can move. -parallels :: [Direction] -parallels = [w, s, n, e] - --- | The ordered /direction/s in which a @Bishop@ can move. -diagonals :: [Direction] -diagonals = [sw, nw, se, ne] - --- | The constant number of distinct /direction/s. -nDistinctDirections :: Type.Count.NDirections -nDistinctDirections = fromIntegral $ length range - -{- | - * Returns a list of /direction/s, each paired with its anti-parallel. - - * CAVEAT: each /direction/ only appears once in the list, on an arbitrary side of a pair. --} -opposites :: [(Direction, Direction)] -opposites = map (id &&& Property.Opposable.getOpposite) [sw, w, nw, s] - --- | The /y/-direction in which a @Pawn@ of the specified /logical colour/ advances. -advanceDirection :: Attribute.LogicalColour.LogicalColour -> Ordering -advanceDirection Attribute.LogicalColour.Black = LT -- Black moves down. -advanceDirection _ = GT -- White moves up. - --- | The /direction/s in which a @Pawn@ can attack. -attackDirectionsForPawn :: Attribute.LogicalColour.LogicalColour -> [Direction] -attackDirectionsForPawn logicalColour = map (`MkDirection` advanceDirection logicalColour) [LT, GT] - --- | Whether the two /direction/s specified, are either parallel or anti-parallel. -areAligned :: Direction -> Direction -> Bool -areAligned direction = uncurry (||) . ((== direction) &&& (== Property.Opposable.getOpposite direction)) - --- | A boxed array indexed by /direction/, of arbitrary elements. -type ArrayByDirection = Data.Array.IArray.Array {-Boxed-} Direction - --- | Array-constructor. -listArrayByDirection :: Data.Array.IArray.IArray a e => [e] -> a Direction e -listArrayByDirection = Data.Array.IArray.listArray (minBound, maxBound) - diff --git a/src-lib/BishBosh/Attribute/LogicalColour.hs b/src-lib/BishBosh/Attribute/LogicalColour.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/LogicalColour.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# 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 . --} -{- | - [@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.Attribute.LogicalColour( --- * Types --- ** Type-synonyms - ArrayByLogicalColour, - UArrayByLogicalColour, --- ** 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.Array.Unboxed -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 = "logicalColour" - --- | The sum-type of /logical colour/s associated with either a piece, or (conceptually) a player. -data LogicalColour - = Black - | White - deriving ( - Bounded, - Enum, - Eq, - Ord, - Read, - Show - ) - -instance Control.DeepSeq.NFData LogicalColour where - rnf _ = () - -instance Data.Array.IArray.Ix LogicalColour where - range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) range - inRange (lower, upper) logicalColour = Control.Exception.assert (logicalColour >= lower && logicalColour <= upper) True - index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . fromEnum - --- | The constant ascending range of /logical colour/s. -range :: [LogicalColour] -range = [minBound, maxBound] - -instance Property.FixedMembership.FixedMembership LogicalColour where - members = range - --- | The constant number of distinct /logical colour/s. -nDistinctLogicalColours :: Type.Count.NLogicalColours -nDistinctLogicalColours = fromIntegral $ length range - -instance HXT.XmlPickler LogicalColour where - xpickle = HXT.xpAttr tag . HXT.xpWrap (read, show) . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range - -instance Property.Opposable.Opposable LogicalColour where - getOpposite Black = White - getOpposite _ = Black - -instance Property.ExtendedPositionDescription.ReadsEPD LogicalColour where - readsEPD s = case Data.List.Extra.trimStart s of - 'b' : remainder -> [(Black, remainder)] - 'w' : remainder -> [(White, remainder)] - _ -> [] - -instance Property.ExtendedPositionDescription.ShowsEPD LogicalColour where - showsEPD = showChar . \case - Black -> 'b' - White -> 'w' - -instance Property.ForsythEdwards.ReadsFEN LogicalColour - -instance Property.ForsythEdwards.ShowsFEN LogicalColour - --- | Whether the specified /logical colour/ is @Black@. -isBlack :: LogicalColour -> Bool -{-# INLINE isBlack #-} -isBlack Black = True -isBlack _ = False - --- | Whether the specified /logical colour/ is @White@. -isWhite :: LogicalColour -> Bool -isWhite = not . isBlack - --- | A boxed array indexed by /logical colour/, of arbitrary elements. -type ArrayByLogicalColour = Data.Array.IArray.Array LogicalColour - --- | An unboxed array indexed by /logical colour/, of fixed-size values. -type UArrayByLogicalColour = Data.Array.Unboxed.UArray LogicalColour - --- | Array-constructor from an ordered list of elements. -listArrayByLogicalColour :: Data.Array.IArray.IArray a e => [e] -> a LogicalColour e -listArrayByLogicalColour = Data.Array.IArray.listArray (minBound, maxBound) - --- | Array-constructor from an association-list. -arrayByLogicalColour :: Data.Array.IArray.IArray a e => [(LogicalColour, e)] -> a LogicalColour e -arrayByLogicalColour = Data.Array.IArray.array (minBound, maxBound) - diff --git a/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs b/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] - - * Defines the data-type which represents the logical (rather than physical) colour of the squares on a chess-board. - - * N.B.: conceptually different from the logical colour of pieces. --} - -module BishBosh.Attribute.LogicalColourOfSquare( --- * Types --- ** Data-type - LogicalColourOfSquare(), --- * Constants - black, - white, --- * Functions --- ** Predicate - isBlack -) where - -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour - --- | The logical colour of a square of the board, cf. of a piece or (conceptually) of a player. -newtype LogicalColourOfSquare = MkLogicalColourOfSquare { - deconstruct :: Attribute.LogicalColour.LogicalColour -} deriving (Eq, Bounded) - --- | Constant. -black :: LogicalColourOfSquare -black = MkLogicalColourOfSquare Attribute.LogicalColour.Black - --- | Constant. -white :: LogicalColourOfSquare -white = MkLogicalColourOfSquare Attribute.LogicalColour.White - --- | Whether the specified /logical colour/ is @Black@. -isBlack :: LogicalColourOfSquare -> Bool -isBlack MkLogicalColourOfSquare { deconstruct = logicalColour } = Attribute.LogicalColour.isBlack logicalColour - diff --git a/src-lib/BishBosh/Attribute/MoveType.hs b/src-lib/BishBosh/Attribute/MoveType.hs --- a/src-lib/BishBosh/Attribute/MoveType.hs +++ b/src-lib/BishBosh/Attribute/MoveType.hs @@ -45,7 +45,6 @@ -- ** Predicates isCastle, isEnPassant, --- isNormal, isCapture, isPromotion, isQuiet, @@ -53,7 +52,8 @@ isAcyclic, -- ** Query getMaybeExplicitlyTakenRank, - getMaybeImplicitlyTakenRank + getMaybeImplicitlyTakenRank, + getMaybePromotedRank ) where import qualified BishBosh.Attribute.Rank as Attribute.Rank @@ -210,11 +210,6 @@ isEnPassant EnPassant = True isEnPassant _ = False --- | Whether the /move/ was neither @EnPassant@ nor @Castle@. -isNormal :: MoveType -> Bool -isNormal (Normal _ _) = True -isNormal _ = False - -- | Whether a piece was captured, including @Pawn@s taken En-passant. isCapture :: MoveType -> Bool {-# INLINE isCapture #-} @@ -223,8 +218,7 @@ -- | Whether the /move/ includes @Pawn@-promotion. isPromotion :: MoveType -> Bool -isPromotion Normal { getMaybePromotionRank = Just _ } = True -isPromotion _ = False +isPromotion = Data.Maybe.isJust . getMaybePromotedRank -- | . isQuiet :: MoveType -> Bool @@ -248,11 +242,7 @@ * CAVEAT: one can't infer from a negative result that the move can be repeated, since the mover may have been a @Pawn@. -} isAcyclic :: MoveType -> Bool -isAcyclic Normal { - getMaybeTakenRank = Nothing, - getMaybePromotionRank = Nothing -} = False -isAcyclic _ = True +isAcyclic = not . isSimple -- Neither capture, promotion, castling nor en-passant can be repeated. -- | Query whether a /piece/ was explicitly taken, excluding @Pawn@s taken En-passant. getMaybeExplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank @@ -263,6 +253,11 @@ getMaybeImplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank getMaybeImplicitlyTakenRank EnPassant = Just Attribute.Rank.Pawn getMaybeImplicitlyTakenRank moveType = getMaybeExplicitlyTakenRank moveType + +-- | Query the rank to which a piece was promoted. +getMaybePromotedRank :: MoveType -> Maybe Attribute.Rank.Rank +getMaybePromotedRank Normal { getMaybePromotionRank = maybePromotionRank } = maybePromotionRank +getMaybePromotedRank _ = Nothing -- | Returns the mutator required to adjust the number of pieces after a move. nPiecesMutator :: Enum nPieces => MoveType -> (nPieces -> nPieces) diff --git a/src-lib/BishBosh/Attribute/PhysicalColour.hs b/src-lib/BishBosh/Attribute/PhysicalColour.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/PhysicalColour.hs +++ /dev/null @@ -1,119 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] - - * Defines the data-type which represents the physical (rather than logical) colour of the /board/ & of /piece/s. - - * The number of physical colours used to represent the /board/ & /piece/s can be greater than the two /logical colour/s required, - but is limited in practice, since the terminal (optionally) used to render the image, typically can't cope with with a large number. --} - -module BishBosh.Attribute.PhysicalColour( --- * Types --- ** Data-types - PhysicalColour(), --- * Constants --- range, - black, - red, - green, - yellow, - blue, - magenta, - cyan, - white -) where - -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified Control.DeepSeq -import qualified Text.XML.HXT.Arrow.Pickle as HXT -import qualified Text.XML.HXT.Arrow.Pickle.Schema - -{- | - * Defines the sum-type of physical colours which can typically be rendered by a terminal. - - * CAVEAT: the constructor-order both facilitates conversion to an ANSI Colour-code & the derivation of the complementary colour. --} -data PhysicalColour - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - deriving (Enum, Eq, Read, Show) - -instance Control.DeepSeq.NFData PhysicalColour where - rnf _ = () - -instance Bounded PhysicalColour where - minBound = black - maxBound = white - -instance HXT.XmlPickler PhysicalColour where - xpickle = HXT.xpWrap (read, show) . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range - -instance Property.Opposable.Opposable PhysicalColour where - getOpposite physicalColour = toEnum $ fromEnum (maxBound :: PhysicalColour) - fromEnum physicalColour -- N.B. the complementary colour - --- | The constant complete range of values. -range :: [PhysicalColour] -range = [minBound .. maxBound] - -instance Property.FixedMembership.FixedMembership PhysicalColour where - members = range - --- | Constant. -black :: PhysicalColour -black = Black - --- | Constant. -red :: PhysicalColour -red = Red - --- | Constant. -green :: PhysicalColour -green = Green - --- | Constant. -yellow :: PhysicalColour -yellow = Yellow - --- | Constant. -blue :: PhysicalColour -blue = Blue - --- | Constant. -magenta :: PhysicalColour -magenta = Magenta - --- | Constant. -cyan :: PhysicalColour -cyan = Cyan - --- | Constant. -white :: PhysicalColour -white = White - diff --git a/src-lib/BishBosh/Attribute/Rank.hs b/src-lib/BishBosh/Attribute/Rank.hs --- a/src-lib/BishBosh/Attribute/Rank.hs +++ b/src-lib/BishBosh/Attribute/Rank.hs @@ -31,7 +31,6 @@ -- ** Type-synonyms EvaluateRank, ArrayByRank, - UArrayByRank, -- ** Data-types Rank(..), -- * Constants @@ -64,7 +63,6 @@ import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray -import qualified Data.Array.Unboxed import qualified Data.Char import qualified Data.List import qualified Data.Ord @@ -208,9 +206,6 @@ -- | A boxed array indexed by /rank/, of arbitrary values. type ArrayByRank = Data.Array.IArray.Array Rank - --- | An unboxed array indexed by /rank/, of fixed-size values. -type UArrayByRank = Data.Array.Unboxed.UArray Rank -- | Array-constructor from an ordered list of elements. listArrayByRank :: Data.Array.IArray.IArray a e => [e] -> a Rank e diff --git a/src-lib/BishBosh/Cartesian/Coordinates.hs b/src-lib/BishBosh/Cartesian/Coordinates.hs --- a/src-lib/BishBosh/Cartesian/Coordinates.hs +++ b/src-lib/BishBosh/Cartesian/Coordinates.hs @@ -34,7 +34,9 @@ -- ** Type-synonyms -- Transformation, ArrayByCoordinates, --- UArrayByCoordinates, +#ifdef USE_UNBOXED_ARRAYS + UArrayByCoordinates, +#endif -- * Constants tag, topLeft, @@ -45,6 +47,7 @@ -- * Functions -- extrapolate', extrapolate, + applyAlongDirectionsFrom, interpolate, getLogicalColourOfSquare, kingsStartingCoordinates, @@ -61,12 +64,9 @@ -- maybeAdvance, retreat, maybeRetreat, --- rotate, -- ** Constructors mkCoordinates, mkMaybeCoordinates, --- toIx, - fromIx, mkRelativeCoordinates, listArrayByCoordinates, arrayByCoordinates, @@ -79,32 +79,35 @@ import Control.Arrow((&&&), (***)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.LogicalColourOfSquare as Attribute.LogicalColourOfSquare -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.Property.Rotatable as Property.Rotatable -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Type.Count as Type.Count -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Colour.LogicalColourOfSquare as Colour.LogicalColourOfSquare +import qualified BishBosh.Direction.Direction as Direction.Direction +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Property.Rotatable as Property.Rotatable +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray -import qualified Data.Array.Unboxed import qualified Data.Foldable import qualified Data.List -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Data.Maybe #ifdef USE_PARALLEL import qualified Control.Parallel.Strategies #endif +#ifdef USE_UNBOXED_ARRAYS +import qualified Data.Array.Unboxed +#endif + -- | Used to qualify XML. tag :: String tag = "coordinates" @@ -115,22 +118,6 @@ getY :: ! Type.Length.Y -- ^ Ordinate. } deriving Eq -instance Control.DeepSeq.NFData Coordinates where - rnf MkCoordinates { getX = x, getY = y } = Control.DeepSeq.rnf (x, y) - -instance Show Coordinates where - showsPrec precedence MkCoordinates { getX = x, getY = y } = showsPrec precedence (x, y) - -instance Read Coordinates where - readsPrec precedence s = [ - (coordinates, remainder) | - ((x, y), remainder) <- readsPrec precedence s, - coordinates <- Data.Maybe.maybeToList $ mkMaybeCoordinates x y - ] -- List-comprehension. - -instance Ord Coordinates where - MkCoordinates { getX = x, getY = y } `compare` MkCoordinates { getX = x', getY = y' } = (y, x) `compare` (y', x') -- N.B.: x is less significant than y, as required by the implementation of 'Data.Array.IArray.Ix.inRange'. - instance Bounded Coordinates where minBound = MkCoordinates { getX = Cartesian.Abscissa.xMin, @@ -141,11 +128,48 @@ getY = Cartesian.Ordinate.yMax } -- Top Right. +instance Control.DeepSeq.NFData Coordinates where + rnf MkCoordinates { getX = x, getY = y } = Control.DeepSeq.rnf (x, y) + instance Data.Array.IArray.Ix Coordinates where range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) Property.FixedMembership.members inRange (lower, upper) coordinates = Control.Exception.assert (coordinates >= lower && coordinates <= upper) True - index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . toIx + index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . fromEnum +instance Enum Coordinates where + toEnum = ( + \(y, x) -> MkCoordinates { + getX = Cartesian.Abscissa.fromIx x, + getY = Cartesian.Ordinate.fromIx y + } + ) . (`divMod` fromIntegral Cartesian.Abscissa.xLength) + + fromEnum MkCoordinates { + getX = x, + getY = y + } = fromIntegral Cartesian.Abscissa.xLength * Cartesian.Ordinate.toIx y + Cartesian.Abscissa.toIx x + +instance Ord Coordinates where + MkCoordinates { getX = x, getY = y } `compare` MkCoordinates { getX = x', getY = y' } = (y, x) `compare` (y', x') -- N.B.: x is less significant than y, as required by the implementation of 'Data.Array.IArray.Ix.inRange'. + +instance Show Coordinates where + showsPrec precedence MkCoordinates { getX = x, getY = y } = showsPrec precedence (x, y) + +instance Read Coordinates where + readsPrec precedence s = [ + (coordinates, remainder) | + (Just coordinates, remainder) <- Control.Arrow.first (uncurry mkMaybeCoordinates) `map` readsPrec precedence s + ] -- List-comprehension. + +instance Property.Opposable.Opposable Coordinates where + getOpposite MkCoordinates { + getX = x, + getY = y + } = MkCoordinates { + getX = Cartesian.Abscissa.reflect x, + getY = Cartesian.Ordinate.reflect y + } + instance Property.Reflectable.ReflectableOnX Coordinates where reflectOnX coordinates@MkCoordinates { getY = y } = coordinates { getY = Cartesian.Ordinate.reflect y } @@ -153,9 +177,21 @@ reflectOnY coordinates@MkCoordinates { getX = x } = coordinates { getX = Cartesian.Abscissa.reflect x } instance Property.Rotatable.Rotatable Coordinates where - rotate90 = rotate Attribute.Direction.w - rotate180 = rotate Attribute.Direction.s - rotate270 = rotate Attribute.Direction.e + rotate90 MkCoordinates { + getX = x, + getY = y + } = MkCoordinates { + getX = fromIntegral $! Cartesian.Ordinate.reflect y, + getY = fromIntegral x + } -- +90 degrees, i.e. anti-clockwise. + rotate180 = Property.Opposable.getOpposite + rotate270 MkCoordinates { + getX = x, + getY = y + } = MkCoordinates { + getX = fromIntegral y, + getY = fromIntegral $! Cartesian.Abscissa.reflect x + } -- -90 degrees, i.e. clockwise. -- | Constant. topLeft :: Coordinates @@ -208,32 +244,15 @@ | inBounds x y = Just MkCoordinates { getX = x, getY = y } | otherwise = Nothing --- | Convert to an array-index. -toIx :: Coordinates -> Int -toIx MkCoordinates { - getX = x, - getY = y -} = fromIntegral Cartesian.Abscissa.xLength * Cartesian.Ordinate.toIx y + Cartesian.Abscissa.toIx x - -{- | - * Construct from the specified array-index. - - * CAVEAT: assumes that the array is indexed by the whole range of /coordinates/. --} -fromIx :: Int -> Coordinates -fromIx = ( - \(y, x) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx x, - getY = Cartesian.Ordinate.fromIx y - } - ) . (`divMod` fromIntegral Cartesian.Abscissa.xLength) +-- | The type of a function which changes one set of /coordinates/ to another. +type Transformation = Coordinates -> Coordinates {- | * Translate the specified /coordinates/ using the specified mapping. * CAVEAT: the caller must ensure that the results are legal. -} -translate :: ((Type.Length.X, Type.Length.Y) -> (Type.Length.X, Type.Length.Y)) -> Coordinates -> Coordinates +translate :: ((Type.Length.X, Type.Length.Y) -> (Type.Length.X, Type.Length.Y)) -> Transformation translate transformation MkCoordinates { getX = x, getY = y @@ -259,7 +278,7 @@ :: (Type.Length.X -> Type.Length.X) -- ^ Translation. -> Coordinates -> Maybe Coordinates -maybeTranslateX transformation coordinates@MkCoordinates { getX = x } = (\x' -> coordinates { getX = x' }) `fmap` Cartesian.Abscissa.maybeTranslate transformation x +maybeTranslateX transformation coordinates@MkCoordinates { getX = x } = (\x' -> coordinates { getX = x' }) <$> Cartesian.Abscissa.maybeTranslate transformation x {- | * Translate the specified ordinate. @@ -274,7 +293,7 @@ :: (Type.Length.Y -> Type.Length.Y) -- ^ Translation. -> Coordinates -> Maybe Coordinates -maybeTranslateY transformation coordinates@MkCoordinates { getY = y } = (\y' -> coordinates { getY = y' }) `fmap` Cartesian.Ordinate.maybeTranslate transformation y +maybeTranslateY transformation coordinates@MkCoordinates { getY = y } = (\y' -> coordinates { getY = y' }) <$> Cartesian.Ordinate.maybeTranslate transformation y {- | * Construct /coordinates/ relative to 'minBound'. @@ -290,18 +309,18 @@ * CAVEAT: the caller must ensure that the results are legal. -} advance - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. + :: Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. -> Transformation -advance logicalColour = translateY $ if Attribute.LogicalColour.isBlack logicalColour +advance logicalColour = translateY $ if Colour.LogicalColour.isBlack logicalColour then pred else succ -- | Where legal, move one step towards the opponent. maybeAdvance - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. + :: Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. -> Coordinates -- ^ The location from which to advanced. -> Maybe Coordinates -maybeAdvance logicalColour = maybeTranslateY $ if Attribute.LogicalColour.isBlack logicalColour +maybeAdvance logicalColour = maybeTranslateY $ if Colour.LogicalColour.isBlack logicalColour then pred else succ @@ -311,13 +330,13 @@ * CAVEAT: the caller must ensure that the results are legal. -} retreat - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. + :: Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. -> Transformation retreat = advance . Property.Opposable.getOpposite -- | Where legal, move one step away from the opponent. maybeRetreat - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. + :: Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. -> Coordinates -- ^ The location from which to retreat. -> Maybe Coordinates maybeRetreat = maybeAdvance . Property.Opposable.getOpposite @@ -328,24 +347,41 @@ -- | Generates a line of /coordinates/, starting just after the specified source & proceeding in the specified /direction/ to the edge of the board. extrapolate' - :: Attribute.Direction.Direction -- ^ The direction in which to proceed. - -> Coordinates -- ^ The point from which to start. + :: Coordinates -- ^ The point from which to start. + -> Direction.Direction.Direction -- ^ The direction in which to proceed. -> [Coordinates] -extrapolate' direction MkCoordinates { +extrapolate' MkCoordinates { getX = x, getY = y -} = zipWith MkCoordinates ( - case Attribute.Direction.getXDirection direction of - GT -> [succ x .. Cartesian.Abscissa.xMax] - LT -> let startX = pred x in startX `seq` [startX, pred startX .. Cartesian.Abscissa.xMin] - EQ -> repeat x - ) ( - case Attribute.Direction.getYDirection direction of - GT -> [succ y .. Cartesian.Ordinate.yMax] - LT -> let startY = pred y in startY `seq` [startY, pred startY .. Cartesian.Ordinate.yMin] - EQ -> repeat y - ) +} direction = uncurry (zipWith MkCoordinates) $ if Property.Orientated.isParallel direction + then if Property.Orientated.isVertical direction + then doVertical + else doHorizontal + else doDiagonal + where + xIncreasing, xDecreasing :: [Type.Length.X] + xIncreasing = [succ x .. Cartesian.Abscissa.xMax] + xDecreasing = let startX = pred x in startX `seq` [startX, pred startX .. Cartesian.Abscissa.xMin] + yIncreasing, yDecreasing :: [Type.Length.Y] + yIncreasing = [succ y .. Cartesian.Ordinate.yMax] + yDecreasing = let startY = pred y in startY `seq` [startY, pred startY .. Cartesian.Ordinate.yMin] + + doVertical, doHorizontal, doDiagonal :: ([Type.Length.X], [Type.Length.Y]) + doVertical = ( + repeat x, + if direction == Direction.Direction.s then yDecreasing else yIncreasing + ) -- Pair. + doHorizontal = ( + if direction == Direction.Direction.w then xDecreasing else xIncreasing, + repeat y + ) -- Pair. + doDiagonal + | direction == Direction.Direction.sw = (xDecreasing, yDecreasing) + | direction == Direction.Direction.se = (xIncreasing, yDecreasing) + | direction == Direction.Direction.nw = (xDecreasing, yIncreasing) + | otherwise {-NE-} = (xIncreasing, yIncreasing) + {- | * Generates a line of /coordinates/, starting just after the specified source & proceeding in the specified /direction/ to the edge of the board. @@ -353,22 +389,34 @@ In consequence, it is typically automatically avoided using a rewrite-rule to lookup an array of the results from all possible calls. -} extrapolate - :: Attribute.Direction.Direction -- ^ The direction in which to proceed. - -> Coordinates -- ^ The point from which to start. + :: Coordinates -- ^ The point from which to start. + -> Direction.Direction.Direction -- ^ The direction in which to proceed. -> [Coordinates] -extrapolate direction coordinates = extrapolationsByDirectionByCoordinates ! coordinates ! direction +extrapolate coordinates direction = extrapolationsByDirectionByCoordinates ! coordinates ! direction -- | The constant lists of /coordinates/, extrapolated from every /coordinate/ in the /board/, in every /direction/. -extrapolationsByDirectionByCoordinates :: ArrayByCoordinates (Attribute.Direction.ArrayByDirection [Coordinates]) +extrapolationsByDirectionByCoordinates :: ArrayByCoordinates (Direction.Direction.ArrayByDirection [Coordinates]) extrapolationsByDirectionByCoordinates = listArrayByCoordinates #ifdef USE_PARALLEL . Control.Parallel.Strategies.withStrategy (Control.Parallel.Strategies.parList Control.Parallel.Strategies.rdeepseq) #endif $ map ( - \coordinates -> Attribute.Direction.listArrayByDirection $ map (`extrapolate'` coordinates) Property.FixedMembership.members - ) Property.FixedMembership.members + \coordinates -> Direction.Direction.listArrayByDirection $ extrapolate' coordinates `map` Property.FixedMembership.members {-direction-} + ) Property.FixedMembership.members {-coordinates-} --- | The list of /coordinates/, between every permutation of source & valid destination on the /board/. +-- | Apply the specified function to each line of /coordinates/ extrapolated from the specified central hub, in each of the specified /direction/s. +applyAlongDirectionsFrom + :: ([Coordinates] -> [a]) -- ^ Individually map each straight line of coordinates extrapolated from the central hub. + -> Coordinates -- ^ The central hub from which to extrapolate. + -> Maybe [Direction.Direction.Direction] -- ^ The directions in which to extrapolate; 'Nothing' implies omnidirectional. + -> [a] +applyAlongDirectionsFrom f from = Data.Maybe.maybe ( + Data.Foldable.foldMap f $ extrapolationsByDirectionByCoordinates ! from -- Traverse all directions from this coordinate, without repeatedly converting direction to an array-index. + ) ( + concatMap $ f . (extrapolationsByDirectionByCoordinates ! from !) + ) + +-- | The constant lists of /coordinates/, between every permutation of source & valid destination on the /board/. interpolationsByDestinationBySource :: ArrayByCoordinates (Map.Map Coordinates [Coordinates]) interpolationsByDestinationBySource = Data.Array.IArray.amap ( Map.fromList . map ( @@ -386,40 +434,7 @@ interpolate :: Coordinates -> Coordinates -> [Coordinates] interpolate coordinatesSource coordinatesDestination = interpolationsByDestinationBySource ! coordinatesSource Map.! coordinatesDestination --- | The type of a function which changes one set of /coordinates/ to another. -type Transformation = Coordinates -> Coordinates - {- | - * Rotates the specified /coordinates/, so that the @Black@ pieces start on the specified side of the board; a /direction/ of @N@ involves no change. - - * CAVEAT: one can only request an integral multiple of 90 degrees. --} -rotate :: Attribute.Direction.Direction -> Transformation -rotate direction coordinates@MkCoordinates { - getX = x, - getY = y -} = case Attribute.Direction.getXDirection &&& Attribute.Direction.getYDirection $ direction of - (EQ, GT) -> coordinates - (LT, EQ) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx yDistance', - getY = Cartesian.Ordinate.fromIx xDistance - } -- +90 degrees, i.e. anti-clockwise. - (EQ, LT) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx xDistance', - getY = Cartesian.Ordinate.fromIx yDistance' - } -- 180 degrees. - (GT, EQ) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx yDistance, - getY = Cartesian.Ordinate.fromIx xDistance' - } -- -90 degrees, i.e. clockwise. - _ -> Control.Exception.throw . Data.Exception.mkRequestFailure . showString "BishBosh.Cartesian.Coordinates.rotate:\tunable to rotate to direction" . Text.ShowList.showsAssociation $ shows direction "." - where - xDistance = Cartesian.Abscissa.toIx x - yDistance = Cartesian.Ordinate.toIx y - xDistance' = fromIntegral (pred Cartesian.Abscissa.xLength) - xDistance - yDistance' = fromIntegral (pred Cartesian.Ordinate.yLength) - yDistance - -{- | * Measures the signed distance between source & destination /coordinates/. * N.B.: this isn't the /irrational/ distance a rational crow would fly, but rather the integral /x/ & /y/ components of that path. @@ -439,42 +454,44 @@ } = (x' - x, y' - y) -- | The /logical colour/ of the specified square. -getLogicalColourOfSquare :: Coordinates -> Attribute.LogicalColourOfSquare.LogicalColourOfSquare +getLogicalColourOfSquare :: Coordinates -> Colour.LogicalColourOfSquare.LogicalColourOfSquare getLogicalColourOfSquare coordinates | uncurry (==) . ( even *** even - ) $ measureDistance minBound coordinates = Attribute.LogicalColourOfSquare.black - | otherwise = Attribute.LogicalColourOfSquare.white + ) $ measureDistance minBound coordinates = Colour.LogicalColourOfSquare.black + | otherwise = Colour.LogicalColourOfSquare.white -- | Whether the specified squares have the same /logical colour/. areSquaresIsochromatic :: [Coordinates] -> Bool areSquaresIsochromatic = uncurry (||) . (all (== minBound) &&& all (== maxBound)) . map getLogicalColourOfSquare -- | The conventional starting /coordinates/ for the @King@ of the specified /logical colour/. -kingsStartingCoordinates :: Attribute.LogicalColour.LogicalColour -> Coordinates +kingsStartingCoordinates :: Colour.LogicalColour.LogicalColour -> Coordinates kingsStartingCoordinates logicalColour = MkCoordinates { getX = Cartesian.Abscissa.kingsFile, getY = Cartesian.Ordinate.firstRank logicalColour } -- | The conventional starting /coordinates/ for each @Rook@. -rooksStartingCoordinates :: Attribute.LogicalColour.LogicalColour -> [Coordinates] -rooksStartingCoordinates Attribute.LogicalColour.Black = [topLeft, maxBound] +rooksStartingCoordinates :: Colour.LogicalColour.LogicalColour -> [Coordinates] +rooksStartingCoordinates Colour.LogicalColour.Black = [topLeft, maxBound] rooksStartingCoordinates _ = [minBound, bottomRight] -- | Whether the specified /coordinates/ are where a @Pawn@ of the specified /logical colour/ starts. -isPawnsFirstRank :: Attribute.LogicalColour.LogicalColour -> Coordinates -> Bool -isPawnsFirstRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.pawnsFirstRank logicalColour +isPawnsFirstRank :: Coordinates -> Colour.LogicalColour.LogicalColour -> Bool +isPawnsFirstRank MkCoordinates { getY = y } = (== y) . Cartesian.Ordinate.pawnsFirstRank -- | Whether a @Pawn@ is currently on the appropriate /rank/ to take an opponent's @Pawn@ /en-passant/. -isEnPassantRank :: Attribute.LogicalColour.LogicalColour -> Coordinates -> Bool -isEnPassantRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.enPassantRank logicalColour +isEnPassantRank :: Coordinates -> Colour.LogicalColour.LogicalColour -> Bool +isEnPassantRank MkCoordinates { getY = y } = (== y) . Cartesian.Ordinate.enPassantRank -- | A boxed array indexed by /coordinates/, of arbitrary elements. type ArrayByCoordinates = Data.Array.IArray.Array Coordinates +#ifdef USE_UNBOXED_ARRAYS -- | An unboxed array indexed by /coordinates/, of fixed-size elements. type UArrayByCoordinates = Data.Array.Unboxed.UArray Coordinates +#endif -- | Array-constructor from an ordered list of elements. listArrayByCoordinates :: Data.Array.IArray.IArray a e => [e] -> a Coordinates e diff --git a/src-lib/BishBosh/Cartesian/Ordinate.hs b/src-lib/BishBosh/Cartesian/Ordinate.hs --- a/src-lib/BishBosh/Cartesian/Ordinate.hs +++ b/src-lib/BishBosh/Cartesian/Ordinate.hs @@ -49,10 +49,10 @@ inBounds ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception -- | The constant length of the /y/-axis. @@ -79,24 +79,24 @@ fromIx = (+ yMin) . fromIntegral -- | The /rank/ from which /piece/s conventionally start. -firstRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y -firstRank Attribute.LogicalColour.Black = yMax +firstRank :: Colour.LogicalColour.LogicalColour -> Type.Length.Y +firstRank Colour.LogicalColour.Black = yMax firstRank _ = yMin -- | The final /rank/; i.e. the one on which a @Pawn@ is promoted. -lastRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y +lastRank :: Colour.LogicalColour.LogicalColour -> Type.Length.Y lastRank = firstRank . Property.Opposable.getOpposite -- | The /rank/ from which @Pawn@s conventionally start. -pawnsFirstRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y +pawnsFirstRank :: Colour.LogicalColour.LogicalColour -> Type.Length.Y {-# INLINE pawnsFirstRank #-} -pawnsFirstRank Attribute.LogicalColour.Black = pred yMax +pawnsFirstRank Colour.LogicalColour.Black = pred yMax pawnsFirstRank _ = succ yMin -- | The /rank/ from which a @Pawn@ may capture /en-passant/. -enPassantRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y +enPassantRank :: Colour.LogicalColour.LogicalColour -> Type.Length.Y {-# INLINE enPassantRank #-} -enPassantRank Attribute.LogicalColour.Black = fromIx 3 +enPassantRank Colour.LogicalColour.Black = fromIx 3 enPassantRank _ = fromIx 4 -- | Reflects about the mid-point of the axis. diff --git a/src-lib/BishBosh/Cartesian/Vector.hs b/src-lib/BishBosh/Cartesian/Vector.hs --- a/src-lib/BishBosh/Cartesian/Vector.hs +++ b/src-lib/BishBosh/Cartesian/Vector.hs @@ -41,23 +41,23 @@ measureDistance, -- ** Predicates -- hasDistance, - isDiagonal, - isParallel, - isStraight, isPawnAttack, isKnightsMove, isKingsMove, matchesPawnDoubleAdvance ) where -import Control.Arrow((&&&), (***)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Type.Length as Type.Length +import Control.Arrow((***)) +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Direction.Direction as Direction.Direction +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq +import qualified Control.Exception -- | The distance between two /coordinates/. data Vector = MkVector { @@ -78,9 +78,19 @@ } = MkVector (negate xDistance) (negate yDistance) instance Property.Orientated.Orientated Vector where - isDiagonal = isDiagonal - isParallel = isParallel + isVertical MkVector { getXDistance = xDistance } = xDistance == 0 + isHorizontal MkVector { getYDistance = yDistance } = yDistance == 0 + + isParallel MkVector { getXDistance = 0 } = True + isParallel MkVector { getYDistance = 0 } = True + isParallel _ = False + + isDiagonal MkVector { + getXDistance = xDistance, + getYDistance = yDistance + } = abs xDistance == fromIntegral (abs yDistance) + -- | Whether the vector has a non-zero length (or a well-defined direction). hasDistance :: Type.Length.X -> Type.Length.Y -> Bool hasDistance 0 0 = False @@ -93,36 +103,17 @@ -> Vector measureDistance source destination = uncurry MkVector $ Cartesian.Coordinates.measureDistance source destination --- | Whether the specified /vector/ is at 45 degrees to an edge of the board, i.e. any move a @Bishop@ could make. -isDiagonal :: Vector -> Bool -{-# INLINE isDiagonal #-} -isDiagonal MkVector { - getXDistance = xDistance, - getYDistance = yDistance -} = fromEnum (abs xDistance) == fromEnum (abs yDistance) - --- | Whether the specified /vector/ is parallel to an edge of the board, i.e. any move a @Rook@ could make. -isParallel :: Vector -> Bool -{-# INLINE isParallel #-} -isParallel MkVector { getXDistance = 0 } = True -isParallel MkVector { getYDistance = 0 } = True -isParallel _ = False - --- | Whether the specified /vector/ is either parallel or at 45 degrees to an edge of the board, i.e. any move a @Queen@ could make. -isStraight :: Vector -> Bool -isStraight = uncurry (||) . (isParallel &&& isDiagonal) - {- | * The list of attack-vectors for a @Pawn@. * N.B.: the @Pawn@'s ability to advance without taking, isn't dealt with here. -} -attackVectorsForPawn :: Attribute.LogicalColour.LogicalColour -> [Vector] +attackVectorsForPawn :: Colour.LogicalColour.LogicalColour -> [Vector] attackVectorsForPawn logicalColour = [ MkVector { getXDistance = x, getYDistance = ( - if Attribute.LogicalColour.isBlack logicalColour + if Colour.LogicalColour.isBlack logicalColour then negate -- Black moves down. else id -- White moves up. ) 1 @@ -155,12 +146,12 @@ * CAVEAT: if the move started at the first rank, then it can't be a @Pawn@, but that's beyond the scope of this module (since a /Vector/ doesn't define absolute /coordinate/s). -} -isPawnAttack :: Attribute.LogicalColour.LogicalColour -> Vector -> Bool +isPawnAttack :: Vector -> Colour.LogicalColour.LogicalColour -> Bool {-# INLINE isPawnAttack #-} -isPawnAttack logicalColour MkVector { +isPawnAttack MkVector { getXDistance = xDistance, getYDistance = yDistance -} = abs xDistance == 1 && yDistance == if Attribute.LogicalColour.isBlack logicalColour +} logicalColour = abs xDistance == 1 && yDistance == if Colour.LogicalColour.isBlack logicalColour then negate 1 else 1 @@ -189,34 +180,54 @@ * CAVEAT: passing this test doesn't guarantee that it is a @Pawn@'s double-advance move, since the move may not relate to a @Pawn@, or could be invalid. -} -matchesPawnDoubleAdvance :: Attribute.LogicalColour.LogicalColour -> Vector -> Bool -matchesPawnDoubleAdvance logicalColour MkVector { +matchesPawnDoubleAdvance :: Vector -> Colour.LogicalColour.LogicalColour -> Bool +matchesPawnDoubleAdvance MkVector { getXDistance = 0, getYDistance = yDistance -} = yDistance == if Attribute.LogicalColour.isBlack logicalColour then negate 2 else 2 +} logicalColour = yDistance == if Colour.LogicalColour.isBlack logicalColour then negate 2 else 2 matchesPawnDoubleAdvance _ _ = False -- | Translate the specified /coordinates/ by the specified /vector/. -translate :: Cartesian.Coordinates.Coordinates -> Vector -> Cartesian.Coordinates.Coordinates -translate coordinates MkVector { +translate :: Vector -> Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates +translate MkVector { getXDistance = xDistance, getYDistance = yDistance -} = Cartesian.Coordinates.translate ((+ xDistance) *** (+ yDistance)) coordinates +} = Cartesian.Coordinates.translate $ (+ xDistance) *** (+ yDistance) -- | Where legal, translate the specified /coordinates/ by the specified /vector/. -maybeTranslate :: Cartesian.Coordinates.Coordinates -> Vector -> Maybe Cartesian.Coordinates.Coordinates -maybeTranslate coordinates MkVector { +maybeTranslate :: Vector -> Cartesian.Coordinates.Coordinates -> Maybe Cartesian.Coordinates.Coordinates +maybeTranslate MkVector { getXDistance = xDistance, getYDistance = yDistance -} = Cartesian.Coordinates.maybeTranslate ((+ xDistance) *** (+ yDistance)) coordinates +} = Cartesian.Coordinates.maybeTranslate $ (+ xDistance) *** (+ yDistance) {- | * Where possible, converts the specified /vector/ into a /direction/. * @Nothing@ is returned for those /vector/s which don't translate into a legal /direction/ (e.g. a @Knight@'s move). -} -toMaybeDirection :: Vector -> Maybe Attribute.Direction.Direction -toMaybeDirection vector@(MkVector xDistance yDistance) - | isStraight vector = Just $ Attribute.Direction.mkDirection (xDistance `compare` 0) (yDistance `compare` 0) - | otherwise = Nothing +toMaybeDirection :: Vector -> Maybe Direction.Direction.Direction +toMaybeDirection vector@(MkVector xDistance yDistance) = case (xDistance `compare` 0, yDistance `compare` 0) of + (LT, ySense) -> case ySense of + LT + | xDistance == yDistance' -> Just Direction.Direction.sw + | otherwise -> Nothing + EQ -> Just Direction.Direction.w + GT + | negate xDistance == yDistance' -> Just Direction.Direction.nw + | otherwise -> Nothing + (EQ, ySense) -> Just $ case ySense of + LT -> Direction.Direction.s + EQ -> Control.Exception.throw . Data.Exception.mkRequestFailure . showString "BishBosh.Cartesian.Vector.toMaybeDirection:\tundefined direction" . Text.ShowList.showsAssociation $ shows vector "." + GT -> Direction.Direction.n + (GT, ySense) -> case ySense of + LT + | xDistance == negate yDistance' -> Just Direction.Direction.se + | otherwise -> Nothing + EQ -> Just Direction.Direction.e + GT + | xDistance == yDistance' -> Just Direction.Direction.ne + | otherwise -> Nothing + where + yDistance' = fromIntegral yDistance diff --git a/src-lib/BishBosh/Colour/ANSIColourCode.hs b/src-lib/BishBosh/Colour/ANSIColourCode.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Colour/ANSIColourCode.hs @@ -0,0 +1,76 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines the encoding of colours for rendering on a terminal; . +-} + +module BishBosh.Colour.ANSIColourCode( +-- * Types +-- ** Type-synonyms +-- ANSIColourCode(), +-- IsBold, + GraphicsRendition, +-- * Functions + selectGraphicsRendition, + bracket, +-- ** Constructors + mkFgColourCode, + mkBgColourCode +) where + +import qualified BishBosh.Colour.PhysicalColour as Colour.PhysicalColour +import qualified Data.Default + +-- | A colour-code as used by terminal-emulators. +newtype ANSIColourCode = MkANSIColourCode { + deconstruct :: Int +} + +instance Show ANSIColourCode where + showsPrec precedence MkANSIColourCode { deconstruct = i } = showsPrec precedence i + +instance Data.Default.Default ANSIColourCode where + def = MkANSIColourCode 0 + +-- | The font-weight of a character. +type IsBold = Bool + +-- | An escape-sequence used to control a terminal. +type GraphicsRendition = String + +-- | Constructor: offset the specified colour-code, so that it applies to the foreground. +mkFgColourCode :: Colour.PhysicalColour.PhysicalColour -> ANSIColourCode +mkFgColourCode = MkANSIColourCode . (+ 30) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} + +-- | Constructor: offset the specified colour-code, so that it applies to the background. +mkBgColourCode :: Colour.PhysicalColour.PhysicalColour -> ANSIColourCode +mkBgColourCode = MkANSIColourCode . (+ 40) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} + +-- | Generate the escape-sequence required to change a terminal to the specified physical colour. +selectGraphicsRendition :: IsBold -> ANSIColourCode -> GraphicsRendition +selectGraphicsRendition isBold parameter = showString "\x1b[" . shows parameter $ (if isBold then showString ";1" else id) "m" + +-- | Render the specified string according to instructions, then revert to the default. +bracket :: GraphicsRendition -> String -> ShowS +bracket graphicsRendition s = showString graphicsRendition . showString s . showString ( + selectGraphicsRendition False Data.Default.def + ) + diff --git a/src-lib/BishBosh/Colour/ColourScheme.hs b/src-lib/BishBosh/Colour/ColourScheme.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Colour/ColourScheme.hs @@ -0,0 +1,159 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines the physical colour used to represent each component of the board. +-} + +module BishBosh.Colour.ColourScheme ( +-- * Types +-- ** Data-types + ColourScheme( +-- MkColourScheme, + getDarkPieceColour, + getLightPieceColour, + getDarkSquareColour, + getLightSquareColour + ), +-- * Constants + tag, +-- darkSquareColourTag, +-- lightSquareColourTag, +-- darkPieceColourTag, +-- lightPieceColourTag, +-- * Functions +-- ** Constructor +-- mkColourScheme +) where + +import qualified BishBosh.Colour.PhysicalColour as Colour.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 + +-- | Used to qualify XML. +tag :: String +tag = "colourScheme" + +darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag :: String +[darkPieceColourTag, darkSquareColourTag, lightPieceColourTag, lightSquareColourTag] = [showString brightness $ showString component "Colour" | brightness <- ["dark", "light"], component <- ["Piece", "Square"]] -- List-comprehension. + +-- | Defines the command-line options. +data ColourScheme = MkColourScheme { + getDarkPieceColour :: Colour.PhysicalColour.PhysicalColour, -- ^ The physical colour of the dark pieces. + getLightPieceColour :: Colour.PhysicalColour.PhysicalColour, -- ^ The physical colour of the light pieces. + getDarkSquareColour :: Colour.PhysicalColour.PhysicalColour, -- ^ The physical colour of the dark squares of the board. + getLightSquareColour :: Colour.PhysicalColour.PhysicalColour -- ^ The physical colour of the light squares of the board. +} deriving Eq + +instance Control.DeepSeq.NFData ColourScheme where + rnf MkColourScheme { + getDarkPieceColour = darkPieceColour, + getLightPieceColour = lightPieceColour, + getDarkSquareColour = darkSquareColour, + getLightSquareColour = lightSquareColour + } = Control.DeepSeq.rnf ( + darkPieceColour, + lightPieceColour, + darkSquareColour, + lightSquareColour + ) + +instance Show ColourScheme where + showsPrec _ MkColourScheme { + getDarkPieceColour = darkPieceColour, + getLightPieceColour = lightPieceColour, + getDarkSquareColour = darkSquareColour, + getLightSquareColour = lightSquareColour + } = Text.ShowList.showsAssociationList' $ map (Control.Arrow.second shows) [ + ( + darkPieceColourTag, + darkPieceColour + ), ( + lightPieceColourTag, + lightPieceColour + ), ( + darkSquareColourTag, + darkSquareColour + ), ( + lightSquareColourTag, + lightSquareColour + ) + ] + +instance Data.Default.Default ColourScheme where + def = MkColourScheme { + getDarkPieceColour = Colour.PhysicalColour.blue, + getLightPieceColour = Property.Opposable.getOpposite $ getDarkPieceColour Data.Default.def, + getDarkSquareColour = Colour.PhysicalColour.black, + getLightSquareColour = Property.Opposable.getOpposite $ getDarkSquareColour Data.Default.def + } + +instance HXT.XmlPickler ColourScheme where + xpickle = HXT.xpElem tag . HXT.xpWrap ( + \(a, b, c, d) -> mkColourScheme a b c d, -- Construct. + \MkColourScheme { + getDarkPieceColour = darkPieceColour, + getLightPieceColour = lightPieceColour, + getDarkSquareColour = darkSquareColour, + getLightSquareColour = lightSquareColour + } -> ( + darkPieceColour, + lightPieceColour, + darkSquareColour, + lightSquareColour + ) -- Deconstruct. + ) $ HXT.xp4Tuple ( + getDarkPieceColour def `HXT.xpDefault` HXT.xpAttr darkPieceColourTag HXT.xpickle + ) ( + getLightPieceColour def `HXT.xpDefault` HXT.xpAttr lightPieceColourTag HXT.xpickle + ) ( + getDarkSquareColour def `HXT.xpDefault` HXT.xpAttr darkSquareColourTag HXT.xpickle + ) ( + getLightSquareColour def `HXT.xpDefault` HXT.xpAttr lightSquareColourTag HXT.xpickle + ) where + def :: ColourScheme + def = Data.Default.def + +-- | Smart constructor. +mkColourScheme + :: Colour.PhysicalColour.PhysicalColour -- ^ Dark piece. + -> Colour.PhysicalColour.PhysicalColour -- ^ Light piece. + -> Colour.PhysicalColour.PhysicalColour -- ^ Dark square. + -> Colour.PhysicalColour.PhysicalColour -- ^ Light square. + -> ColourScheme +mkColourScheme darkPieceColour lightPieceColour darkSquareColour lightSquareColour + | darkPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Colour.ColourScheme.mkColourScheme:\t" . showString darkPieceColourTag . Text.ShowList.showsAssociation . shows darkPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "." + | lightPieceColour `elem` bgColours = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Colour.ColourScheme.mkColourScheme:\t" . showString lightPieceColourTag . Text.ShowList.showsAssociation . shows lightPieceColour . showString " must differ from the physical colour of both squares; " $ shows bgColours "." + | darkSquareColour == lightSquareColour = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Colour.ColourScheme.mkColourScheme:\tthe physical colours of " . shows lightSquareColourTag . showString " & " $ shows darkSquareColourTag ", must differ." + | otherwise = MkColourScheme { + getDarkPieceColour = darkPieceColour, + getLightPieceColour = lightPieceColour, + getDarkSquareColour = darkSquareColour, + getLightSquareColour = lightSquareColour + } + where + bgColours = [darkSquareColour, lightSquareColour] + diff --git a/src-lib/BishBosh/Colour/LogicalColour.hs b/src-lib/BishBosh/Colour/LogicalColour.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Colour/LogicalColour.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, 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 . +-} +{- | + [@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, +#ifdef USE_UNBOXED_ARRAYS + UArrayByLogicalColour, +#endif +-- ** 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 + +#ifdef USE_UNBOXED_ARRAYS +import qualified Data.Array.Unboxed +#endif + +-- | Used to qualify XML. +tag :: String +tag = "logicalColour" + +-- | The sum-type of /logical colour/s associated with either a piece, or (conceptually) a player. +data LogicalColour + = Black + | White + deriving ( + Bounded, + Enum, + Eq, + Ord, + Read, + Show + ) + +instance Control.DeepSeq.NFData LogicalColour where + rnf _ = () + +instance Data.Array.IArray.Ix LogicalColour where + range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) range + inRange (lower, upper) logicalColour = Control.Exception.assert (logicalColour >= lower && logicalColour <= upper) True + index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . fromEnum + +-- | The constant ascending range of /logical colour/s. +range :: [LogicalColour] +range = [minBound, maxBound] + +instance Property.FixedMembership.FixedMembership LogicalColour where + members = range + +-- | The constant number of distinct /logical colour/s. +nDistinctLogicalColours :: Type.Count.NLogicalColours +nDistinctLogicalColours = fromIntegral $ length range + +instance HXT.XmlPickler LogicalColour where + xpickle = HXT.xpAttr tag . HXT.xpWrap (read, show) . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range + +instance Property.Opposable.Opposable LogicalColour where + getOpposite Black = White + getOpposite _ = Black + +instance Property.ExtendedPositionDescription.ReadsEPD LogicalColour where + readsEPD s = case Data.List.Extra.trimStart s of + 'b' : remainder -> [(Black, remainder)] + 'w' : remainder -> [(White, remainder)] + _ -> [] + +instance Property.ExtendedPositionDescription.ShowsEPD LogicalColour where + showsEPD = showChar . \case + Black -> 'b' + White -> 'w' + +instance Property.ForsythEdwards.ReadsFEN LogicalColour + +instance Property.ForsythEdwards.ShowsFEN LogicalColour + +-- | Whether the specified /logical colour/ is @Black@. +isBlack :: LogicalColour -> Bool +{-# INLINE isBlack #-} +isBlack Black = True +isBlack _ = False + +-- | Whether the specified /logical colour/ is @White@. +isWhite :: LogicalColour -> Bool +isWhite = not . isBlack + +-- | A boxed array indexed by /logical colour/, of arbitrary elements. +type ArrayByLogicalColour = Data.Array.IArray.Array LogicalColour + +#ifdef USE_UNBOXED_ARRAYS +-- | An unboxed array indexed by /logical colour/, of fixed-size values. +type UArrayByLogicalColour = Data.Array.Unboxed.UArray LogicalColour +#endif + +-- | Array-constructor from an ordered list of elements. +listArrayByLogicalColour :: Data.Array.IArray.IArray a e => [e] -> a LogicalColour e +listArrayByLogicalColour = Data.Array.IArray.listArray (minBound, maxBound) + +-- | Array-constructor from an association-list. +arrayByLogicalColour :: Data.Array.IArray.IArray a e => [(LogicalColour, e)] -> a LogicalColour e +arrayByLogicalColour = Data.Array.IArray.array (minBound, maxBound) + diff --git a/src-lib/BishBosh/Colour/LogicalColourOfSquare.hs b/src-lib/BishBosh/Colour/LogicalColourOfSquare.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Colour/LogicalColourOfSquare.hs @@ -0,0 +1,59 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Defines the data-type which represents the logical (rather than physical) colour of the squares on a chess-board. + + * N.B.: conceptually different from the logical colour of pieces. +-} + +module BishBosh.Colour.LogicalColourOfSquare( +-- * Types +-- ** Data-type + LogicalColourOfSquare(), +-- * Constants + black, + white, +-- * Functions +-- ** Predicate + isBlack +) where + +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour + +-- | The logical colour of a square of the board, cf. of a piece or (conceptually) of a player. +newtype LogicalColourOfSquare = MkLogicalColourOfSquare { + deconstruct :: Colour.LogicalColour.LogicalColour +} deriving (Eq, Bounded) + +-- | Constant. +black :: LogicalColourOfSquare +black = MkLogicalColourOfSquare Colour.LogicalColour.Black + +-- | Constant. +white :: LogicalColourOfSquare +white = MkLogicalColourOfSquare Colour.LogicalColour.White + +-- | Whether the specified /logical colour/ is @Black@. +isBlack :: LogicalColourOfSquare -> Bool +isBlack MkLogicalColourOfSquare { deconstruct = logicalColour } = Colour.LogicalColour.isBlack logicalColour + diff --git a/src-lib/BishBosh/Colour/PhysicalColour.hs b/src-lib/BishBosh/Colour/PhysicalColour.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Colour/PhysicalColour.hs @@ -0,0 +1,119 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Defines the data-type which represents the physical (rather than logical) colour of the /board/ & of /piece/s. + + * The number of physical colours used to represent the /board/ & /piece/s can be greater than the two /logical colour/s required, + but is limited in practice, since the terminal (optionally) used to render the image, typically can't cope with with a large number. +-} + +module BishBosh.Colour.PhysicalColour( +-- * Types +-- ** Data-types + PhysicalColour(), +-- * Constants +-- range, + black, + red, + green, + yellow, + blue, + magenta, + cyan, + white +) where + +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified Control.DeepSeq +import qualified Text.XML.HXT.Arrow.Pickle as HXT +import qualified Text.XML.HXT.Arrow.Pickle.Schema + +{- | + * Defines the sum-type of physical colours which can typically be rendered by a terminal. + + * CAVEAT: the constructor-order both facilitates conversion to an ANSI Colour-code & the derivation of the complementary colour. +-} +data PhysicalColour + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Enum, Eq, Read, Show) + +instance Control.DeepSeq.NFData PhysicalColour where + rnf _ = () + +instance Bounded PhysicalColour where + minBound = black + maxBound = white + +instance HXT.XmlPickler PhysicalColour where + xpickle = HXT.xpWrap (read, show) . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range + +instance Property.Opposable.Opposable PhysicalColour where + getOpposite physicalColour = toEnum $ fromEnum (maxBound :: PhysicalColour) - fromEnum physicalColour -- N.B. the complementary colour + +-- | The constant complete range of values. +range :: [PhysicalColour] +range = [minBound .. maxBound] + +instance Property.FixedMembership.FixedMembership PhysicalColour where + members = range + +-- | Constant. +black :: PhysicalColour +black = Black + +-- | Constant. +red :: PhysicalColour +red = Red + +-- | Constant. +green :: PhysicalColour +green = Green + +-- | Constant. +yellow :: PhysicalColour +yellow = Yellow + +-- | Constant. +blue :: PhysicalColour +blue = Blue + +-- | Constant. +magenta :: PhysicalColour +magenta = Magenta + +-- | Constant. +cyan :: PhysicalColour +cyan = Cyan + +-- | Constant. +white :: PhysicalColour +white = White + diff --git a/src-lib/BishBosh/Component/Accountant.hs b/src-lib/BishBosh/Component/Accountant.hs --- a/src-lib/BishBosh/Component/Accountant.hs +++ b/src-lib/BishBosh/Component/Accountant.hs @@ -23,20 +23,20 @@ -} module BishBosh.Component.Accountant( --- * Type-classes +-- * Type-class Accountant(..) ) where import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Mass as Type.Mass -- | An interface which may be implemented by data which can total piece-square values. class Accountant accountant where -- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side. sumPieceSquareValueByLogicalColour - :: Num pieceSquareValue - => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue - -> Type.Count.NPieces -- ^ The number of pieces (of any logical colour or rank) remaining on the board; used to gauge progress through the game. + :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank -> accountant - -> [pieceSquareValue] + -> Type.Count.NPieces -- ^ The number of pieces (of any logical colour or rank) remaining on the board; used to gauge progress through the game. + -> [Type.Mass.Base] -- CAVEAT: can't return '[Type.Mass.PieceSquareValue]' because it's bounded. diff --git a/src-lib/BishBosh/Component/CastlingMove.hs b/src-lib/BishBosh/Component/CastlingMove.hs --- a/src-lib/BishBosh/Component/CastlingMove.hs +++ b/src-lib/BishBosh/Component/CastlingMove.hs @@ -43,9 +43,9 @@ import Control.Arrow((&&&)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.FixedMembership as Property.FixedMembership @@ -64,7 +64,7 @@ kingsMoveLength = 2 -- | Define all possible castling-moves for the specified /logical colour/. -defineCastlingMoves :: Attribute.LogicalColour.LogicalColour -> [CastlingMove] +defineCastlingMoves :: Colour.LogicalColour.LogicalColour -> [CastlingMove] defineCastlingMoves logicalColour = [ MkCastlingMove { getMoveType = Attribute.MoveType.longCastle, @@ -81,24 +81,24 @@ } ] where isBlack :: Bool - isBlack = Attribute.LogicalColour.isBlack logicalColour + isBlack = Colour.LogicalColour.isBlack logicalColour kingsMove translation = uncurry ($) . (Component.Move.mkMove &&& Cartesian.Coordinates.translateX translation) $ Cartesian.Coordinates.kingsStartingCoordinates logicalColour -- | Defines by /logical colour/, the constant list of all possible castling-moves. -castlingMovesByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [CastlingMove] -castlingMovesByLogicalColour = Attribute.LogicalColour.listArrayByLogicalColour $ map defineCastlingMoves Property.FixedMembership.members +castlingMovesByLogicalColour :: Colour.LogicalColour.ArrayByLogicalColour [CastlingMove] +castlingMovesByLogicalColour = Colour.LogicalColour.listArrayByLogicalColour $ map defineCastlingMoves Property.FixedMembership.members {- | * Accessor. * CAVEAT: the moves are returned in unspecified order. -} -getCastlingMoves :: Attribute.LogicalColour.LogicalColour -> [CastlingMove] +getCastlingMoves :: Colour.LogicalColour.LogicalColour -> [CastlingMove] getCastlingMoves = (castlingMovesByLogicalColour !) -- | Break-down the two castling-moves for the specified /logical colour/ into a long & a short castling-move. -getLongAndShortMoves :: Attribute.LogicalColour.LogicalColour -> (CastlingMove, CastlingMove) +getLongAndShortMoves :: Colour.LogicalColour.LogicalColour -> (CastlingMove, CastlingMove) getLongAndShortMoves logicalColour | [longCastlingMove, shortCastlingMove] <- getCastlingMoves logicalColour = (longCastlingMove, shortCastlingMove) | otherwise = Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.Component.CastlingMove.getLongAndShortMoves:\tunexpected list-length." diff --git a/src-lib/BishBosh/Component/Move.hs b/src-lib/BishBosh/Component/Move.hs --- a/src-lib/BishBosh/Component/Move.hs +++ b/src-lib/BishBosh/Component/Move.hs @@ -46,13 +46,14 @@ isPawnDoubleAdvance ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.Type.Count as Type.Count +import Control.Arrow((&&&)) +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -77,8 +78,8 @@ } deriving Eq instance Ord Move where - move@MkMove { getSource = source } `compare` move'@MkMove { getSource = source' } = case source `compare` source' of - EQ -> Data.Ord.comparing getDestination move move' + l'@MkMove { getSource = l } `compare` r'@MkMove { getSource = r } = case l `compare` r of + EQ -> Data.Ord.comparing getDestination l' r' ordering -> ordering instance Control.DeepSeq.NFData Move where @@ -106,8 +107,17 @@ } instance Property.Orientated.Orientated Move where + isVertical MkMove { + getSource = source, + getDestination = destination + } = Cartesian.Coordinates.getX source == Cartesian.Coordinates.getX destination + + isHorizontal MkMove { + getSource = source, + getDestination = destination + } = Cartesian.Coordinates.getY source == Cartesian.Coordinates.getY destination + isDiagonal = Property.Orientated.isDiagonal . measureDistance - isParallel = Property.Orientated.isParallel . measureDistance instance Property.Reflectable.ReflectableOnX Move where reflectOnX MkMove { @@ -159,10 +169,12 @@ but passing only guarantees that it is, if it was a @Pawn@ which moved & that the /move/ is valid. -} isPawnDoubleAdvance - :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side whose move is referenced. - -> Move + :: Move + -> Colour.LogicalColour.LogicalColour -- ^ Defines the side whose move is referenced. -> Bool -isPawnDoubleAdvance logicalColour move@MkMove { getSource = source } = Cartesian.Coordinates.isPawnsFirstRank logicalColour source && Cartesian.Vector.matchesPawnDoubleAdvance logicalColour ( - measureDistance move +isPawnDoubleAdvance move@MkMove { getSource = source } = uncurry (&&) . ( + Cartesian.Coordinates.isPawnsFirstRank source &&& Cartesian.Vector.matchesPawnDoubleAdvance ( + measureDistance move + ) ) diff --git a/src-lib/BishBosh/Component/Piece.hs b/src-lib/BishBosh/Component/Piece.hs --- a/src-lib/BishBosh/Component/Piece.hs +++ b/src-lib/BishBosh/Component/Piece.hs @@ -72,24 +72,25 @@ isKnight, -- isBishop, -- isRook, --- isQueen, + isQueen, isKing, isPawnPromotion ) where import Control.Arrow((&&&), (***)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Direction.Direction as Direction.Direction 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.Property.Orientated as Property.Orientated import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception @@ -116,7 +117,7 @@ -- | A Chess-piece has a /logical colour/ & a /rank/. data Piece = MkPiece { - getLogicalColour :: Attribute.LogicalColour.LogicalColour, + getLogicalColour :: Colour.LogicalColour.LogicalColour, getRank :: Attribute.Rank.Rank } deriving (Bounded, Eq, Ord) @@ -149,8 +150,8 @@ c : remainder -> ( MkPiece ( if Data.Char.isUpper c - then Attribute.LogicalColour.White - else Attribute.LogicalColour.Black + then Colour.LogicalColour.White + else Colour.LogicalColour.Black ) *** const remainder ) `map` reads [c] _ -> [] -- No parse. @@ -195,31 +196,31 @@ members = range -- | Constructor. -mkPiece :: Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank -> Piece +mkPiece :: Colour.LogicalColour.LogicalColour -> Attribute.Rank.Rank -> Piece mkPiece = MkPiece -- | Constructor. -mkPawn :: Attribute.LogicalColour.LogicalColour -> Piece +mkPawn :: Colour.LogicalColour.LogicalColour -> Piece mkPawn = (`MkPiece` Attribute.Rank.Pawn) -- | Constructor. -mkRook :: Attribute.LogicalColour.LogicalColour -> Piece +mkRook :: Colour.LogicalColour.LogicalColour -> Piece mkRook = (`MkPiece` Attribute.Rank.Rook) -- | Constructor. -mkKnight :: Attribute.LogicalColour.LogicalColour -> Piece +mkKnight :: Colour.LogicalColour.LogicalColour -> Piece mkKnight = (`MkPiece` Attribute.Rank.Knight) -- | Constructor. -mkBishop:: Attribute.LogicalColour.LogicalColour -> Piece +mkBishop:: Colour.LogicalColour.LogicalColour -> Piece mkBishop = (`MkPiece` Attribute.Rank.Bishop) -- | Constructor. -mkQueen :: Attribute.LogicalColour.LogicalColour -> Piece +mkQueen :: Colour.LogicalColour.LogicalColour -> Piece mkQueen = (`MkPiece` Attribute.Rank.Queen) -- | Constructor. -mkKing :: Attribute.LogicalColour.LogicalColour -> Piece +mkKing :: Colour.LogicalColour.LogicalColour -> Piece mkKing = (`MkPiece` Attribute.Rank.King) -- | Changes the specified /piece/ to the specified /rank/ leaving its /logical colour/ unchanged. @@ -230,15 +231,15 @@ | otherwise = piece { getRank = newRank } -- | The structure of a container of arbitrary data, indexed by /logicalColour/ & some /rank/s. -type ByRankByLogicalColour element = Attribute.LogicalColour.ArrayByLogicalColour (Map.Map Attribute.Rank.Rank element) +type ByRankByLogicalColour element = Colour.LogicalColour.ArrayByLogicalColour (Map.Map Attribute.Rank.Rank element) -- | Constructor of a certain shape of container, but with arbitrary contents. mkByRankByLogicalColour :: #ifdef USE_PARALLEL Control.DeepSeq.NFData element => #endif - [Attribute.Rank.Rank] -> (Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank -> element) -> ByRankByLogicalColour element -mkByRankByLogicalColour ranks mkElement = Attribute.LogicalColour.listArrayByLogicalColour + [Attribute.Rank.Rank] -> (Colour.LogicalColour.LogicalColour -> Attribute.Rank.Rank -> element) -> ByRankByLogicalColour element +mkByRankByLogicalColour ranks mkElement = Colour.LogicalColour.listArrayByLogicalColour #ifdef USE_PARALLEL . Control.Parallel.Strategies.withStrategy (Control.Parallel.Strategies.parList Control.Parallel.Strategies.rdeepseq) #endif @@ -265,14 +266,14 @@ -- | Calls 'attackVectorsByRankByLogicalColour' to find the destinations which the specified /piece/ can attack from the specified position. findAttackDestinations' - :: Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. - -> Piece + :: Piece + -> Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. -> [Cartesian.Coordinates.Coordinates] -- ^ The destinations which can be attacked. -findAttackDestinations' source MkPiece { +findAttackDestinations' MkPiece { getLogicalColour = logicalColour, getRank = rank -} = Data.Maybe.mapMaybe ( - Cartesian.Vector.maybeTranslate source +} source = Data.Maybe.mapMaybe ( + `Cartesian.Vector.maybeTranslate` source ) ( attackVectorsByRankByLogicalColour ! logicalColour Map.! rank ) @@ -286,40 +287,40 @@ -} attackDestinationsByCoordinatesByRankByLogicalColour :: AttackDestinationsByCoordinatesByRankByLogicalColour attackDestinationsByCoordinatesByRankByLogicalColour = mkByRankByLogicalColour Attribute.Rank.fixedAttackRange $ \logicalColour rank -> Cartesian.Coordinates.listArrayByCoordinates $ map ( - `findAttackDestinations'` mkPiece logicalColour rank + findAttackDestinations' $! mkPiece logicalColour rank ) Property.FixedMembership.members -- | Find the destinations which the specified /piece/ can attack from the specified position. findAttackDestinations - :: Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. - -> Piece + :: Piece + -> Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. -> [Cartesian.Coordinates.Coordinates] -- ^ The destinations which can be attacked. -findAttackDestinations coordinates MkPiece { +findAttackDestinations MkPiece { getLogicalColour = logicalColour, getRank = rank -} = attackDestinationsByCoordinatesByRankByLogicalColour ! logicalColour Map.! rank ! coordinates +} coordinates = attackDestinationsByCoordinatesByRankByLogicalColour ! logicalColour Map.! rank ! coordinates -- The constant /direction/s of the straight lines along which each type of /piece/ can attack. {- | - * Find the constant /direction/s of the straight lines along which each type of /piece/ can attack. + * The constant /direction/s of the straight lines along which each type of /piece/ can attack. * CAVEAT: not defined for a @Knight@. -} -attackDirectionsByRankByLogicalColour :: ByRankByLogicalColour [Attribute.Direction.Direction] +attackDirectionsByRankByLogicalColour :: ByRankByLogicalColour [Direction.Direction.Direction] attackDirectionsByRankByLogicalColour = mkByRankByLogicalColour Attribute.Rank.earthBound $ \logicalColour -> \case - Attribute.Rank.Pawn -> Attribute.Direction.attackDirectionsForPawn logicalColour - Attribute.Rank.Bishop -> Attribute.Direction.diagonals - Attribute.Rank.Rook -> Attribute.Direction.parallels - _ {-royalty-} -> Property.FixedMembership.members + Attribute.Rank.Pawn -> Direction.Direction.attackDirectionsForPawn logicalColour + Attribute.Rank.Bishop -> Direction.Direction.diagonals + Attribute.Rank.Rook -> Direction.Direction.parallels + _ {-royalty-} -> Property.FixedMembership.members {-directions-} {- | * Get the constant /direction/s of the straight lines along which the specified /piece/ can attack. * CAVEAT: not defined for a @Knight@. -} -getAttackDirections :: Piece -> [Attribute.Direction.Direction] +getAttackDirections :: Piece -> [Direction.Direction.Direction] getAttackDirections MkPiece { getLogicalColour = logicalColour, getRank = rank @@ -341,15 +342,13 @@ -> Bool canAttackAlong source destination piece = ( case getRank piece of - Attribute.Rank.Pawn -> Cartesian.Vector.isPawnAttack $ getLogicalColour piece + Attribute.Rank.Pawn -> (`Cartesian.Vector.isPawnAttack` getLogicalColour piece) Attribute.Rank.Knight -> Cartesian.Vector.isKnightsMove - Attribute.Rank.Bishop -> Cartesian.Vector.isDiagonal - Attribute.Rank.Rook -> Cartesian.Vector.isParallel - Attribute.Rank.Queen -> Cartesian.Vector.isStraight + Attribute.Rank.Bishop -> Property.Orientated.isDiagonal + Attribute.Rank.Rook -> Property.Orientated.isParallel + Attribute.Rank.Queen -> Property.Orientated.isStraight Attribute.Rank.King -> Cartesian.Vector.isKingsMove - ) ( - Cartesian.Vector.measureDistance source destination - ) + ) $! Cartesian.Vector.measureDistance source destination {- | * Whether the specified /piece/ can move between the specified /coordinates/. @@ -357,47 +356,52 @@ * N.B.: can't detect any blocking pieces. -} canMoveBetween - :: Cartesian.Coordinates.Coordinates -- ^ Source. + :: Piece + -> Cartesian.Coordinates.Coordinates -- ^ Source. -> Cartesian.Coordinates.Coordinates -- ^ Destination. - -> Piece -> Bool -canMoveBetween source destination piece = ( +canMoveBetween piece source destination = ( case getRank piece of - Attribute.Rank.Pawn -> \distance -> let + Attribute.Rank.Pawn -> let logicalColour = getLogicalColour piece - in Cartesian.Vector.isPawnAttack logicalColour distance || Cartesian.Vector.getXDistance distance == 0 && ( - let - y' = ( - if Attribute.LogicalColour.isBlack logicalColour - then negate - else id - ) $ Cartesian.Vector.getYDistance distance - in y' == 1 || Cartesian.Coordinates.isPawnsFirstRank logicalColour source && y' == 2 + in uncurry (||) . ( + (`Cartesian.Vector.isPawnAttack` logicalColour) &&& ( + uncurry (&&) . ( + (== 0) . Cartesian.Vector.getXDistance &&& ( + \case + 1 -> True + 2 -> Cartesian.Coordinates.isPawnsFirstRank source logicalColour + _ -> False + ) . ( + if Colour.LogicalColour.isBlack logicalColour + then negate + else id + ) . Cartesian.Vector.getYDistance + ) + ) ) Attribute.Rank.Knight -> Cartesian.Vector.isKnightsMove - Attribute.Rank.Bishop -> Cartesian.Vector.isDiagonal - Attribute.Rank.Rook -> Cartesian.Vector.isParallel - Attribute.Rank.Queen -> Cartesian.Vector.isStraight + Attribute.Rank.Bishop -> Property.Orientated.isDiagonal + Attribute.Rank.Rook -> Property.Orientated.isParallel + Attribute.Rank.Queen -> Property.Orientated.isStraight Attribute.Rank.King -> Cartesian.Vector.isKingsMove - ) ( - Cartesian.Vector.measureDistance source destination - ) + ) $! Cartesian.Vector.measureDistance source destination -- | Whether a move qualifies for @Pawn@-promotion. isPawnPromotion - :: Cartesian.Coordinates.Coordinates -- ^ Destination. - -> Piece + :: Piece + -> Cartesian.Coordinates.Coordinates -- ^ Destination. -> Bool -isPawnPromotion destination MkPiece { +isPawnPromotion MkPiece { getLogicalColour = logicalColour, getRank = Attribute.Rank.Pawn -} = Cartesian.Ordinate.lastRank logicalColour == Cartesian.Coordinates.getY destination +} destination = Cartesian.Ordinate.lastRank logicalColour == Cartesian.Coordinates.getY destination isPawnPromotion _ _ = False -- | Whether the specified /piece/ is @Black@. {-# INLINE isBlack #-} isBlack :: Piece -> Bool -isBlack MkPiece { getLogicalColour = Attribute.LogicalColour.Black } = True +isBlack MkPiece { getLogicalColour = Colour.LogicalColour.Black } = True isBlack _ = False -- | Whether the specified /piece/s have the same /logical colour/. diff --git a/src-lib/BishBosh/Component/PieceSquareByCoordinatesByRank.hs b/src-lib/BishBosh/Component/PieceSquareByCoordinatesByRank.hs --- a/src-lib/BishBosh/Component/PieceSquareByCoordinatesByRank.hs +++ b/src-lib/BishBosh/Component/PieceSquareByCoordinatesByRank.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -45,76 +46,97 @@ import Control.Arrow((&&&), (|||)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.DeepSeq import qualified Data.Array.IArray import qualified Data.Foldable import qualified Data.List +#if defined(USE_UNBOXED_ARRAYS) && !(defined(USE_NEWTYPE_WRAPPERS) || defined(USE_PRECISION)) +#define UNBOX +import qualified Data.Array.Unboxed +#endif + -- | The piece-square value may vary as the game progresses. -type PieceSquareValueByNPieces pieceSquareValue = Data.Array.IArray.Array Type.Count.NPieces pieceSquareValue +type PieceSquareValueByNPieces = +#ifdef UNBOX + Data.Array.Unboxed.UArray +#else + Data.Array.IArray.Array +#endif + Type.Count.NPieces Type.Mass.PieceSquareValue -- | The bounds of the number of pieces on the board, at the end-game & opening-game respectively. nPiecesBounds :: (Type.Count.NPieces, Type.Count.NPieces) nPiecesBounds = ( 3 {-minimum sufficient material-}, - fromIntegral Attribute.LogicalColour.nDistinctLogicalColours * Component.Piece.nPiecesPerSide + fromIntegral Colour.LogicalColour.nDistinctLogicalColours * Component.Piece.nPiecesPerSide ) -- | Self-documentation. -type EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue = Either ( - Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue -- Uninterpolated. +type EitherPieceSquareValueByNPiecesByCoordinates = Either ( +#ifdef UNBOX + Cartesian.Coordinates.UArrayByCoordinates +#else + Cartesian.Coordinates.ArrayByCoordinates +#endif + Type.Mass.PieceSquareValue -- Uninterpolated. ) ( - Cartesian.Coordinates.ArrayByCoordinates (PieceSquareValueByNPieces pieceSquareValue) -- Interpolated. + Cartesian.Coordinates.ArrayByCoordinates PieceSquareValueByNPieces -- Interpolated. ) -- | The value for each type of /piece/ of occupying each coordinate, at each stage in the lifetime of the game. -newtype PieceSquareByCoordinatesByRank pieceSquareValue = MkPieceSquareByCoordinatesByRank { - deconstruct :: Attribute.Rank.ArrayByRank (EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue) +newtype PieceSquareByCoordinatesByRank = MkPieceSquareByCoordinatesByRank { + deconstruct :: Attribute.Rank.ArrayByRank EitherPieceSquareValueByNPiecesByCoordinates } deriving (Eq, Show) -instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (PieceSquareByCoordinatesByRank pieceSquareValue) where - rnf MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = Control.DeepSeq.rnf byRank +instance Control.DeepSeq.NFData PieceSquareByCoordinatesByRank where + rnf +#ifdef UNBOX + _ = () +#else + MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = Control.DeepSeq.rnf byRank +#endif -- | Constructor. mkPieceSquareByCoordinatesByRank - :: (Attribute.Rank.Rank -> EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue) -- ^ Convert a /rank/ into either (a /pieceSquareValue/ or a /pieceSquareValue/ which linearly varies with the number of /piece/s remaining) by /coordinates/. - -> PieceSquareByCoordinatesByRank pieceSquareValue + :: (Attribute.Rank.Rank -> EitherPieceSquareValueByNPiecesByCoordinates) -- ^ Convert a /rank/ into either (a /pieceSquareValue/ or a /pieceSquareValue/ which linearly varies with the number of /piece/s remaining) by /coordinates/. + -> PieceSquareByCoordinatesByRank mkPieceSquareByCoordinatesByRank = MkPieceSquareByCoordinatesByRank . Attribute.Rank.listArrayByRank . (`map` Property.FixedMembership.members) -- | Find the piece-square value, at a stage in the game's lifetime defined by the total number of pieces remaining, for the specified /rank/ & /coordinates/. findPieceSquareValue - :: PieceSquareByCoordinatesByRank pieceSquareValue - -> Type.Count.NPieces -- ^ The progress through the game. - -> Attribute.LogicalColour.LogicalColour -- ^ The /piece/'s /logical colour/. - -> Attribute.Rank.Rank -- ^ The /piece/'s /rank/. - -> Cartesian.Coordinates.Coordinates -- ^ The /piece/'s location. - -> pieceSquareValue + :: PieceSquareByCoordinatesByRank + -> Type.Count.NPieces -- ^ The progress through the game. + -> Colour.LogicalColour.LogicalColour -- ^ The /piece/'s /logical colour/. + -> Attribute.Rank.Rank -- ^ The /piece/'s /rank/. + -> Cartesian.Coordinates.Coordinates -- ^ The /piece/'s location. + -> Type.Mass.PieceSquareValue findPieceSquareValue MkPieceSquareByCoordinatesByRank { deconstruct = byRank } nPieces logicalColour rank = ( (!) ||| ( \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) ) $ byRank ! rank - ) . if Attribute.LogicalColour.isBlack logicalColour + ) . if Colour.LogicalColour.isBlack logicalColour then Property.Reflectable.reflectOnX else id -- | Given the bounds over which two piece-square values vary as the game progresses from opening to end, return linearly interpolated values for all stages. interpolatePieceSquareValues - :: Fractional pieceSquareValue - => pieceSquareValue -- ^ Opening-game. - -> pieceSquareValue -- ^ End-game. - -> PieceSquareValueByNPieces pieceSquareValue + :: Type.Mass.PieceSquareValue -- ^ Opening-game. + -> Type.Mass.PieceSquareValue -- ^ End-game. + -> PieceSquareValueByNPieces interpolatePieceSquareValues openingGame endGame = Data.Array.IArray.listArray nPiecesBounds . map ( - uncurry (+) . ( - (* openingGame) &&& (* endGame) . (1 -) + fromRational . uncurry (+) . ( + (* toRational openingGame) &&& (* toRational endGame) . (1 -) ) . ( / fromIntegral ( uncurry subtract nPiecesBounds -- N.B.: this can't reasonably be zero. @@ -130,12 +152,12 @@ -- | Format the data for input to __GNUPlot__. formatForGNUPlot - :: (pieceSquareValue -> ShowS) -- ^ Format a /pieceSquareValue/. - -> ShowS -- ^ The column-delimiter. - -> (PieceSquareValueByNPieces pieceSquareValue -> pieceSquareValue) -- ^ Select one /pieceSquareValue/ from interpolated values. - -> PieceSquareByCoordinatesByRank pieceSquareValue + :: PieceSquareByCoordinatesByRank + -> (Type.Mass.PieceSquareValue -> ShowS) -- ^ Format a /pieceSquareValue/. + -> ShowS -- ^ The column-delimiter. + -> (PieceSquareValueByNPieces -> Type.Mass.PieceSquareValue) -- ^ Select one /PieceSquareValue/ from interpolated values. -> ShowS -formatForGNUPlot pieceSquareValueFormatter columnDelimiter selector MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = ( +formatForGNUPlot MkPieceSquareByCoordinatesByRank { deconstruct = byRank } pieceSquareValueFormatter columnDelimiter selector = ( showsRow ( showChar gnuPlotComment . showChar 'x' : showChar 'y' : map shows Attribute.Rank.range -- Header comment. ) . @@ -152,7 +174,7 @@ ) id . zip ( Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates] ) . Data.List.transpose . map ( - Data.Foldable.toList ||| map selector {-select one pieceSquareValue from interpolated values-} . Data.Foldable.toList {-ByCoordinates-} + Data.Array.IArray.elems ||| map selector {-select one PieceSquareValue from interpolated values-} . Data.Foldable.toList {-ByCoordinates-} ) $ Data.Foldable.toList {-ByRank-} byRank where terminateRow = showChar '\n' showsRow = Text.ShowList.showsDelimitedList columnDelimiter id terminateRow diff --git a/src-lib/BishBosh/Component/QualifiedMove.hs b/src-lib/BishBosh/Component/QualifiedMove.hs --- a/src-lib/BishBosh/Component/QualifiedMove.hs +++ b/src-lib/BishBosh/Component/QualifiedMove.hs @@ -24,6 +24,8 @@ module BishBosh.Component.QualifiedMove( -- * Types +-- * Type-synonyms + QualifiedMoveSequence, -- ** Data-types QualifiedMove( -- MkQualifiedMove, @@ -68,4 +70,7 @@ -- | Constructor. mkQualifiedMove :: Component.Move.Move -> Attribute.MoveType.MoveType -> QualifiedMove mkQualifiedMove = MkQualifiedMove + +-- | A sequence of QualifiedMoves applied to a game. +type QualifiedMoveSequence = [QualifiedMove] diff --git a/src-lib/BishBosh/Component/Turn.hs b/src-lib/BishBosh/Component/Turn.hs --- a/src-lib/BishBosh/Component/Turn.hs +++ b/src-lib/BishBosh/Component/Turn.hs @@ -42,9 +42,9 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Property.Reflectable as Property.Reflectable @@ -116,13 +116,13 @@ -- | Whether the /turn/ represents a @Pawn@'s initial two-square advance. isPawnDoubleAdvance - :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side whose /turn/ is referenced. - -> Turn + :: Turn + -> Colour.LogicalColour.LogicalColour -- ^ Defines the side whose /turn/ is referenced. -> Bool -isPawnDoubleAdvance logicalColour MkTurn { +isPawnDoubleAdvance MkTurn { getRank = Attribute.Rank.Pawn, getQualifiedMove = qualifiedMove -} = Component.Move.isPawnDoubleAdvance logicalColour (Component.QualifiedMove.getMove qualifiedMove) && Component.QualifiedMove.getMoveType qualifiedMove == Data.Default.def +} logicalColour = Component.Move.isPawnDoubleAdvance (Component.QualifiedMove.getMove qualifiedMove) logicalColour && Component.QualifiedMove.getMoveType qualifiedMove == Data.Default.def isPawnDoubleAdvance _ _ = False -- | Forwards the request to 'Attribute.Rank.compareByLVA'. diff --git a/src-lib/BishBosh/Component/Zobrist.hs b/src-lib/BishBosh/Component/Zobrist.hs --- a/src-lib/BishBosh/Component/Zobrist.hs +++ b/src-lib/BishBosh/Component/Zobrist.hs @@ -51,12 +51,12 @@ import Control.Arrow((***)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Bits @@ -66,15 +66,15 @@ import qualified ToolShed.System.Random -- | Used as an index into 'getRandomByCoordinatesByRankByLogicalColour'. -type Index = (Attribute.LogicalColour.LogicalColour, Attribute.Rank.Rank, Cartesian.Coordinates.Coordinates) +type Index = (Colour.LogicalColour.LogicalColour, Attribute.Rank.Rank, Cartesian.Coordinates.Coordinates) -- | The random numbers used to generate a hash, which almost uniquely represent a /position/. data Zobrist positionHash = MkZobrist { - getRandomForBlacksMove :: positionHash, -- ^ Defines a random number to apply when the next move is @Black@'s. - getRandomByCoordinatesByRankByLogicalColour :: Data.Array.IArray.Array {-Boxed-} Index positionHash, -- ^ Defines random numbers to represent all combinations of each piece at each coordinate; though @Pawn@s can't exist on the terminal ranks. N.B.: regrettably the array can't be unboxed, because 'Data.Array.Unboxed.UArray' isn't 'Foldable'; cf. 'Data.Array.IArray.Array'. + getRandomForBlacksMove :: positionHash, -- ^ Defines a random number to apply when the next move is @Black@'s. + getRandomByCoordinatesByRankByLogicalColour :: Data.Array.IArray.Array {-Boxed-} Index positionHash, -- ^ Defines random numbers to represent all combinations of each piece at each coordinate; though @Pawn@s can't exist on the terminal ranks. N.B.: regrettably the array can't be unboxed, because 'Data.Array.Unboxed.UArray' isn't 'Foldable'; cf. 'Data.Array.IArray.Array'. - getRandomByCastleableRooksXByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [(Type.Length.X, positionHash)], -- ^ Defines random numbers to represent all combinations of castleable @Rook@s. - getRandomByEnPassantAbscissa :: Data.Array.IArray.Array Type.Length.X positionHash -- ^ Defines random numbers to represent any file on which capture en-passant might be available. + getRandomByCastleableRooksXByLogicalColour :: Colour.LogicalColour.ArrayByLogicalColour [(Type.Length.X, positionHash)], -- ^ Defines random numbers to represent all combinations of castleable @Rook@s. + getRandomByEnPassantAbscissa :: Data.Array.IArray.Array Type.Length.X positionHash -- ^ Defines random numbers to represent any file on which capture en-passant might be available. } deriving Show instance Foldable Zobrist where @@ -133,7 +133,7 @@ ) . System.Random.split ) *** ( ( - Attribute.LogicalColour.listArrayByLogicalColour . map ( + Colour.LogicalColour.listArrayByLogicalColour . map ( zip [Cartesian.Abscissa.xMin, Cartesian.Abscissa.xMax] . System.Random.randoms ) . ToolShed.System.Random.randomGens *** Cartesian.Abscissa.listArrayByAbscissa . System.Random.randoms ) . System.Random.split @@ -147,18 +147,18 @@ } -- | Dereferences 'getRandomByCoordinatesByRankByLogicalColour' using the specified index. -dereferenceRandomByCoordinatesByRankByLogicalColour :: Index -> Zobrist positionHash -> positionHash -dereferenceRandomByCoordinatesByRankByLogicalColour index MkZobrist { getRandomByCoordinatesByRankByLogicalColour = randomByCoordinatesByRankByLogicalColour } = randomByCoordinatesByRankByLogicalColour ! index +dereferenceRandomByCoordinatesByRankByLogicalColour :: Zobrist positionHash -> Index -> positionHash +dereferenceRandomByCoordinatesByRankByLogicalColour MkZobrist { getRandomByCoordinatesByRankByLogicalColour = randomByCoordinatesByRankByLogicalColour } = (randomByCoordinatesByRankByLogicalColour !) -- | Dereferences 'getRandomByCastleableRooksXByLogicalColour' using the specified abscissa. dereferenceRandomByCastleableRooksXByLogicalColour - :: Attribute.LogicalColour.LogicalColour + :: Zobrist positionHash + -> Colour.LogicalColour.LogicalColour -> Type.Length.X - -> Zobrist positionHash -> Maybe positionHash -- ^ The existence of a result depends on whether there remain any Rooks which can castle. -dereferenceRandomByCastleableRooksXByLogicalColour logicalColour x MkZobrist { getRandomByCastleableRooksXByLogicalColour = randomByCastleableRooksXByLogicalColour } = lookup x $ randomByCastleableRooksXByLogicalColour ! logicalColour +dereferenceRandomByCastleableRooksXByLogicalColour MkZobrist { getRandomByCastleableRooksXByLogicalColour = randomByCastleableRooksXByLogicalColour } logicalColour x = lookup x $ randomByCastleableRooksXByLogicalColour ! logicalColour -- | Dereferences 'getRandomByEnPassantAbscissa' using the specified abscissa. -dereferenceRandomByEnPassantAbscissa :: Type.Length.X -> Zobrist positionHash -> positionHash -dereferenceRandomByEnPassantAbscissa x MkZobrist { getRandomByEnPassantAbscissa = randomByEnPassantAbscissa } = randomByEnPassantAbscissa ! x +dereferenceRandomByEnPassantAbscissa :: Zobrist positionHash -> Type.Length.X -> positionHash +dereferenceRandomByEnPassantAbscissa MkZobrist { getRandomByEnPassantAbscissa = randomByEnPassantAbscissa } = (randomByEnPassantAbscissa !) diff --git a/src-lib/BishBosh/ContextualNotation/PGN.hs b/src-lib/BishBosh/ContextualNotation/PGN.hs --- a/src-lib/BishBosh/ContextualNotation/PGN.hs +++ b/src-lib/BishBosh/ContextualNotation/PGN.hs @@ -72,7 +72,7 @@ ) where import Control.Arrow((&&&), (***)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.ContextualNotation.PGNComment as ContextualNotation.PGNComment import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Data.Exception as Data.Exception @@ -475,7 +475,7 @@ expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game in do moveNumber <- ( - if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game + if Colour.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game then fmap (Data.Maybe.fromMaybe expectedMoveNumber) . Control.Applicative.optional else id ) moveNumberParser @@ -514,7 +514,7 @@ expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game in do moveNumber <- ( - if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game + if Colour.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game then fmap (Data.Maybe.fromMaybe expectedMoveNumber) . Control.Applicative.optional else id ) moveNumberParser diff --git a/src-lib/BishBosh/ContextualNotation/PositionHashQualifiedMoveTree.hs b/src-lib/BishBosh/ContextualNotation/PositionHashQualifiedMoveTree.hs --- a/src-lib/BishBosh/ContextualNotation/PositionHashQualifiedMoveTree.hs +++ b/src-lib/BishBosh/ContextualNotation/PositionHashQualifiedMoveTree.hs @@ -39,6 +39,7 @@ PositionHashQualifiedMoveTree(), -- * Functions -- onymiseQualifiedMove, +-- colourFlipper, -- findNextOnymousQualifiedMovesForGame, findNextOnymousQualifiedMovesForPosition, -- findNextJoiningOnymousQualifiedMovesFromPosition, @@ -53,8 +54,8 @@ ) where import Control.Arrow((&&&), (***)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn @@ -77,6 +78,7 @@ import qualified Data.List.Extra import qualified Data.Maybe import qualified Data.Tree +import qualified Data.Tuple import qualified System.Random import qualified ToolShed.System.Random @@ -101,7 +103,7 @@ getHasAnyVictories :: Bool -- ^ Whether a victory has been recorded for any game in the tree; which won't be the case if it was constructed from a PGN-database containing standard-openings. } --- | Augment the specified /qualified-move forest/ with a /Zobrist-hash/ of the /position/ & include the default initial game at the apex. +-- | Constructor: augment the specified /qualified-move forest/ with a /Zobrist-hash/ of the /position/ & include the default initial game at the apex. fromQualifiedMoveForest :: Data.Bits.Bits positionHash => Bool -- ^ IncrementalEvaluation. @@ -122,7 +124,7 @@ ) tree } where initialGame = Data.Default.def - initialPositionHash = StateProperty.Hashable.hash initialGame zobrist + initialPositionHash = StateProperty.Hashable.hash zobrist initialGame tree = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel initialPositionHash Nothing, Data.Tree.subForest = map ( @@ -143,7 +145,7 @@ Data.Tree.rootLabel = label@(qualifiedMove, _), Data.Tree.subForest = qualifiedMoveForest' } = Data.Tree.Node { - Data.Tree.rootLabel = MkNodeLabel (StateProperty.Hashable.hash game' zobrist) $ Just label, -- Hash the game after applying the move. + Data.Tree.rootLabel = MkNodeLabel (StateProperty.Hashable.hash zobrist game') $ Just label, -- Hash the game after applying the move. Data.Tree.subForest = map (slave game') qualifiedMoveForest' -- Recurse. } where game' = Model.Game.applyQualifiedMove qualifiedMove game @@ -161,8 +163,8 @@ * CAVEAT: a negative result doesn't imply that convergence is possible, since other factors may prevent it. -} -cantConverge :: Model.Game.Game -> PositionHashQualifiedMoveTree positionHash -> Bool -cantConverge game MkPositionHashQualifiedMoveTree { getMinimumPieces = minimumPieces } = State.Board.getNPieces (Model.Game.getBoard game) < minimumPieces +cantConverge :: PositionHashQualifiedMoveTree positionHash -> Model.Game.Game -> Bool +cantConverge MkPositionHashQualifiedMoveTree { getMinimumPieces = minimumPieces } = (< minimumPieces) . State.Board.getNPieces . Model.Game.getBoard -- | A /qualified move/ annotated by the name & ultimate /result/, of each /game/ from which it could have originated. type OnymousQualifiedMove = (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.OnymousResult]) @@ -178,13 +180,14 @@ ) . Data.Tree.flatten -- | The type of a function used to locate a match in the tree. -type FindMatch positionHash = Model.Game.Game -> PositionHashQualifiedMoveTree positionHash -> [OnymousQualifiedMove] +type FindMatch positionHash = PositionHashQualifiedMoveTree positionHash -> Model.Game.Game -> [OnymousQualifiedMove] -- | For any exactly matching /game/ in the tree, return the subsequent /qualifiedMove/s. findNextOnymousQualifiedMovesForGame :: FindMatch positionHash -findNextOnymousQualifiedMovesForGame requiredGame = slave ( +findNextOnymousQualifiedMovesForGame MkPositionHashQualifiedMoveTree { getTree = tree } requiredGame = slave ( Model.Game.listTurnsChronologically requiredGame - ) . Data.Tree.subForest {-remove the apex which lacks a founding move-} . getTree where + ) $ Data.Tree.subForest {-remove the apex which lacks a founding move-} tree where + slave :: [Component.Turn.Turn] -> [Tree positionHash] -> [OnymousQualifiedMove] slave (turn : remainingTurns) = Data.Maybe.maybe [] {-match-failure-} ( slave remainingTurns . Data.Tree.subForest -- Recurse. ) . Data.List.find ( @@ -204,43 +207,41 @@ * CAVEAT: a null list can result from either match-failure, or a match with the final /move/ of a /game/. -} findNextOnymousQualifiedMovesForPosition :: Data.Bits.Bits positionHash => FindMatch positionHash -{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch Type.Crypto.PositionHash #-} -findNextOnymousQualifiedMovesForPosition requiredGame positionHashQualifiedMoveTree - | cantConverge requiredGame positionHashQualifiedMoveTree = [] -- The game we're required to match has fewer pieces than any defined in the tree. - | otherwise = slave nPiecesDiffByLogicalColour $ getTree positionHashQualifiedMoveTree +findNextOnymousQualifiedMovesForPosition positionHashQualifiedMoveTree requiredGame + | cantConverge positionHashQualifiedMoveTree requiredGame = [] -- The game we're required to match has fewer pieces than any defined in the tree. + | otherwise = slave ( + ( + uncurry (***) . (id &&& id) $ (Component.Piece.nPiecesPerSide -) -- Find the number of pieces at the apex of the tree, in excess of the requiredGame, to be taken before a match can be found. + ) . StateProperty.Censor.countPiecesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard $ requiredGame + ) $ getTree positionHashQualifiedMoveTree where - nPiecesDiffByLogicalColour :: (Type.Count.NPieces, Type.Count.NPieces) - (requiredPositionHash, nPiecesDiffByLogicalColour) = (`StateProperty.Hashable.hash` getZobrist positionHashQualifiedMoveTree) &&& ( - uncurry (***) . (id &&& id) $ (Component.Piece.nPiecesPerSide -) -- Find the excess pieces on either side, to be taken before a match can be found. - ) . StateProperty.Censor.countPiecesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard $ requiredGame - - slave (nPiecesDiffOpponent, nPiecesDiffMover) Data.Tree.Node { + slave nPiecesDiff Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash }, Data.Tree.subForest = forest } = ( - case nPiecesDiffMover `compare` 0 of -- N.B. equivalent to 'signum' to slightly better performance. - GT -> id -- This node can't match, but there may be a match further down the tree. + case snd {-mover-} nPiecesDiff `compare` 0 of -- N.B. equivalent to 'signum' to slightly better performance. + GT -> id -- This node can't match, but there may be a match further down the tree. EQ - | positionHash == requiredPositionHash -> (map onymiseQualifiedMove forest ++) -- The position matches, so one can select any move from the forest. - | otherwise -> id -- This node doesn't match, but there may be a match further down the tree. - _ -> const [] -- Terminate the recursion, since from here down the tree, the mover has insufficient pieces to match the required game. + | positionHash == StateProperty.Hashable.hash ( + getZobrist positionHashQualifiedMoveTree + ) requiredGame -> (map onymiseQualifiedMove forest ++) -- The position matches, so one can select any move from the forest. + | otherwise -> id -- This node doesn't match, but there may be a match further down the tree. + _ -> const [] -- Terminate the recursion, since from here down the tree, the mover has insufficient pieces to match the required game. ) $ concatMap ( \node@Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just (qualifiedMove, _) } } -> slave ( - nPiecesDiffMover, - ( + Data.Tuple.swap $ ( if Attribute.MoveType.isCapture $! Component.QualifiedMove.getMoveType qualifiedMove - then pred + then Control.Arrow.first pred -- Decrement opponent's piece-count. else id - ) nPiecesDiffOpponent - ) {-swap pair-} node -- Recurse. + ) nPiecesDiff + ) node -- Recurse. ) forest -- | Finds any single /move/s which can join the current /position/ with a member of the forest. findNextJoiningOnymousQualifiedMovesFromPosition :: Data.Bits.Bits positionHash => FindMatch positionHash -{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch Type.Crypto.PositionHash #-} -findNextJoiningOnymousQualifiedMovesFromPosition game positionHashQualifiedMoveTree +findNextJoiningOnymousQualifiedMovesFromPosition positionHashQualifiedMoveTree game | Model.Game.isTerminated game = [] | otherwise = [ Control.Arrow.second (concatMap snd {-[OnymousResult]-}) movePair | -- Discard the opponent's matching move, but cite the names of archived games it reached. @@ -251,7 +252,7 @@ ) . #endif map ( - id &&& (`findNextOnymousQualifiedMovesForPosition` positionHashQualifiedMoveTree) . (`Model.Game.applyQualifiedMove` game) -- Apply this player's move. + id &&& findNextOnymousQualifiedMovesForPosition positionHashQualifiedMoveTree . (`Model.Game.applyQualifiedMove` game) -- Apply this player's move. ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game ] -- List-comprehension. @@ -270,6 +271,14 @@ -- | Whether from all matching positions extracted from the tree, to prefer moves which result in a greater probability of victory, for the player who has the next move. type PreferVictories = Bool +-- | Transform an arbitrary match-function to operate on the colour-flipped game. +colourFlipper :: FindMatch positionHash -> FindMatch positionHash +colourFlipper findMatch positionHashQualifiedMoveTree = map ( + Property.Reflectable.reflectOnX {-reflect matching moves back into the original domain-} *** map ( + Control.Arrow.first $ showString "Colour-flipped:\t" + ) + ) . findMatch positionHashQualifiedMoveTree . Property.Reflectable.reflectOnX + {- | * Calls 'findNextOnymousQualifiedMovesForGame' to find an exact match for the current /game/ in the tree. @@ -287,32 +296,23 @@ :: Data.Bits.Bits positionHash => MatchSwitches -> FindMatch positionHash -{-# SPECIALISE findNextOnymousQualifiedMoves :: MatchSwitches -> FindMatch Type.Crypto.PositionHash #-} -findNextOnymousQualifiedMoves (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) game positionHashQualifiedMoveTree - | cantConverge game positionHashQualifiedMoveTree = [] -- The specified game is smaller than any defined in the tree. +findNextOnymousQualifiedMoves (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) positionHashQualifiedMoveTree game + | cantConverge positionHashQualifiedMoveTree game = [] -- The specified game is smaller than any defined in the tree. | otherwise = Data.Maybe.fromMaybe [] . Data.List.find ( not . null -- Accept the results from the first match-function which returns any. ) $ ( if tryToMatchMoves - then (findNextOnymousQualifiedMovesForGame game positionHashQualifiedMoveTree :) + then (findNextOnymousQualifiedMovesForGame positionHashQualifiedMoveTree game :) else id ) [ - colourFlipper findMatch game positionHashQualifiedMoveTree | + transformation findMatch positionHashQualifiedMoveTree game | findMatch <- findNextOnymousQualifiedMovesForPosition : [findNextJoiningOnymousQualifiedMovesFromPosition | tryToMatchViaJoiningMove] {-list-comprehension-}, - colourFlipper <- id : [ - \findMatch' game' -> map ( - Property.Reflectable.reflectOnX {-reflect matching moves back into the original domain-} *** map ( - Control.Arrow.first $ showString "Colour-flipped:\t" - ) - ) . findMatch' ( - Property.Reflectable.reflectOnX game' - ) | tryToMatchColourFlippedPosition - ] -- Transform an arbitrary match-function to operate on either the original or the colour-flipped game. + transformation <- id : [colourFlipper | tryToMatchColourFlippedPosition] -- Transform an arbitrary match-function to operate on either the original or the colour-flipped game. ] -- List-comprehension. -- | Shortlist matching moves extracted from the tree, prefering those after which the player who makes it, has the greatest recorded incidence of victory. shortListMostVictorious - :: Attribute.LogicalColour.LogicalColour -- ^ The player who is next to move. + :: Colour.LogicalColour.LogicalColour -- ^ The player who is next to move. -> [OnymousQualifiedMove] -> [OnymousQualifiedMove] shortListMostVictorious nextLogicalColour = last {-highest scoring group-} . Data.List.Extra.groupSortOn ( @@ -331,19 +331,10 @@ => randomGen -> PreferVictories -> MatchSwitches - -> Model.Game.Game -> PositionHashQualifiedMoveTree positionHash - -> Maybe (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.Name]) -{-# SPECIALISE maybeRandomlySelectOnymousQualifiedMove - :: System.Random.RandomGen randomGen - => randomGen - -> PreferVictories - -> MatchSwitches -> Model.Game.Game - -> PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> Maybe (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.Name]) - #-} -maybeRandomlySelectOnymousQualifiedMove randomGen preferVictories matchSwitches game positionHashQualifiedMoveTree = case findNextOnymousQualifiedMoves matchSwitches game positionHashQualifiedMoveTree of +maybeRandomlySelectOnymousQualifiedMove randomGen preferVictories matchSwitches positionHashQualifiedMoveTree game = case findNextOnymousQualifiedMoves matchSwitches positionHashQualifiedMoveTree game of [] -> Nothing onymousQualifiedMoves -> fmap ( Control.Arrow.second $ Data.List.nub . map fst {-Name-} diff --git a/src-lib/BishBosh/ContextualNotation/QualifiedMoveForest.hs b/src-lib/BishBosh/ContextualNotation/QualifiedMoveForest.hs --- a/src-lib/BishBosh/ContextualNotation/QualifiedMoveForest.hs +++ b/src-lib/BishBosh/ContextualNotation/QualifiedMoveForest.hs @@ -151,8 +151,8 @@ mkCompositeIdentifier = unwords . map snd {-value-} . ContextualNotation.PGN.getIdentificationTagPairs merge - :: OnymousResult -- ^ The name of this move-sequence, & the result. - -> [Component.QualifiedMove.QualifiedMove] -- ^ A chronological sequence of /qualified move/s. + :: OnymousResult -- ^ The name of this move-sequence, & the result. + -> Component.QualifiedMove.QualifiedMoveSequence -- ^ A chronological sequence of /qualified move/s. -> [QualifiedMoveTree] -> [QualifiedMoveTree] merge onymousResult qualifiedMoves@(qualifiedMove : remainingQualifiedMoves) forest = case span ( @@ -172,7 +172,7 @@ _ {-no match-} -> mkLinkedList onymousResult qualifiedMoves : forest merge _ [] forest = forest - mkLinkedList :: OnymousResult -> [Component.QualifiedMove.QualifiedMove] -> QualifiedMoveTree + mkLinkedList :: OnymousResult -> Component.QualifiedMove.QualifiedMoveSequence -> QualifiedMoveTree mkLinkedList onymousResult ~(qualifiedMove : remainingQualifiedMoves) | null remainingQualifiedMoves = Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove, Just onymousResult), @@ -198,6 +198,7 @@ findMinimumPieces = slave ( 2 * Component.Piece.nPiecesPerSide -- CAVEAT: assuming a conventional starting position. ) . deconstruct where + slave :: Type.Count.NPieces -> [QualifiedMoveTree] -> Type.Count.NPieces slave nPieces [] = nPieces slave nPieces forest = minimum $ map ( \Data.Tree.Node { @@ -211,6 +212,7 @@ -- | Count the number of /game/s & distinct /positions/. count :: QualifiedMoveForest -> (Type.Count.NGames, Type.Count.NPositions) count = slave . deconstruct where + slave :: [QualifiedMoveTree] -> (Type.Count.NGames, Type.Count.NPositions) slave = Data.List.foldl' ( \(nGames, nPositions) Data.Tree.Node { Data.Tree.rootLabel = (_, maybeOnymousResult), @@ -238,6 +240,7 @@ } where initialGame = Data.Default.def + slave :: Model.Game.Game -> QualifiedMoveTree -> Model.GameTree.BareGameTree slave game Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove, _), Data.Tree.subForest = qualifiedMoveForest' diff --git a/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs b/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs --- a/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs +++ b/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs @@ -157,7 +157,7 @@ -> Model.Game.Game -- ^ The /game/ prior to application of the specified /turn/. -> ShowS showsTurn explicitEnPassant turn game - | Just sourceRank <- fmap Component.Piece.getRank . State.MaybePieceByCoordinates.dereference source $ State.Board.getMaybePieceByCoordinates board = ( + | Just sourceRank <- Component.Piece.getRank <$> State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) source = ( if sourceRank == Attribute.Rank.Pawn then ( if isCapture @@ -175,9 +175,9 @@ then shortCastleToken else longCastleToken _ {-not a castling-} -> showsRank sourceRank . ( - case Data.List.delete source {-search for alternatives-} $ State.Board.findAttacksBy ( + case Data.List.delete source {-search for alternatives-} $ State.Board.findAttacksBy board ( Component.Piece.mkPiece (Model.Game.getNextLogicalColour game) sourceRank - ) destination board of + ) destination of [] -> id -- There're aren't any pieces of this rank which can perform this move. coordinates -> case any ( (== Cartesian.Coordinates.getX source) . Cartesian.Coordinates.getX @@ -206,7 +206,7 @@ isEnPassant, isCapture :: Bool isEnPassant = Attribute.MoveType.isEnPassant moveType - isCapture = State.MaybePieceByCoordinates.isOccupied destination (State.Board.getMaybePieceByCoordinates board) || isEnPassant + isCapture = State.MaybePieceByCoordinates.isOccupied (State.Board.getMaybePieceByCoordinates board) destination || isEnPassant showsRank :: Attribute.Rank.Rank -> ShowS showsRank rank = showChar $ fromRank rank @@ -290,7 +290,7 @@ nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour board = Model.Game.getBoard game - getMaybePiece = (`State.MaybePieceByCoordinates.dereference` State.Board.getMaybePieceByCoordinates board) + getMaybePiece = State.MaybePieceByCoordinates.dereference $ State.Board.getMaybePieceByCoordinates board getMaybeRank = fmap Component.Piece.getRank . getMaybePiece in do qualifiedMove <- Text.Poly.spaces >> Poly.oneOf' [ @@ -303,7 +303,7 @@ piece :: Component.Piece.Piece piece = Component.Piece.mkPiece nextLogicalColour rank - findAttacksBy destination = State.Board.findAttacksBy piece destination board + findAttacksBy destination = State.Board.findAttacksBy board piece destination if rank == Attribute.Rank.Pawn then let @@ -378,7 +378,7 @@ show &&& return {-to Parser-monad-} $ qualifiedMove | source <- sourceCandidates,-- Attempt to resolve the ambiguity by playing subsequent moves. let qualifiedMove = Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination, - Model.Game.isValidQualifiedMove qualifiedMove game + Model.Game.isValidQualifiedMove game qualifiedMove ] -- List-comprehension. in Poly.oneOf' [ ( @@ -431,16 +431,18 @@ _ <- Control.Applicative.optional (Poly.satisfyMsg (`elem` [checkFlag, checkMateFlag]) "Check") >> Control.Applicative.optional moveSuffixAnnotationParser - fmap fromQualifiedMove $ if validateMoves - then Data.Maybe.maybe (return {-to Parser-monad-} qualifiedMove) (Poly.failBad . showString "failed: ") $ Model.Game.validateQualifiedMove qualifiedMove game - else return {-to Parser-monad-} qualifiedMove + fromQualifiedMove `fmap` ( + if validateMoves + then Data.Maybe.maybe (return {-to Parser-monad-} qualifiedMove) (Poly.failBad . showString "failed: ") . Model.Game.validateQualifiedMove game + else return {-to Parser-monad-} + ) qualifiedMove #else /* Parsec */ -> Parsec.Parser StandardAlgebraic parser explicitEnPassant validateMoves game = let nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour board = Model.Game.getBoard game - getMaybePiece = (`State.MaybePieceByCoordinates.dereference` State.Board.getMaybePieceByCoordinates board) + getMaybePiece = State.MaybePieceByCoordinates.dereference $ State.Board.getMaybePieceByCoordinates board getMaybeRank = fmap Component.Piece.getRank . getMaybePiece in do qualifiedMove <- Parsec.spaces >> Parsec.choice [ @@ -451,7 +453,7 @@ piece :: Component.Piece.Piece piece = Component.Piece.mkPiece nextLogicalColour rank - findAttacksBy destination = State.Board.findAttacksBy piece destination board + findAttacksBy destination = State.Board.findAttacksBy board piece destination if rank == Attribute.Rank.Pawn then let @@ -506,7 +508,7 @@ Parsec.try $ return {-to ParsecT-monad-} qualifiedMove | source <- sourceCandidates,-- Attempt to resolve the ambiguity by playing subsequent moves. let qualifiedMove = Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination, - Model.Game.isValidQualifiedMove qualifiedMove game + Model.Game.isValidQualifiedMove game qualifiedMove ] -- List-comprehension. in Parsec.choice [ Parsec.try $ do -- N.B. this scenario occurs when there are identical pieces on both the same row & the same column, as the intended attacker; i.e. after a promotion. @@ -553,9 +555,11 @@ _ <- Parsec.optional (Parsec.oneOf [checkFlag, checkMateFlag] "Check") >> Parsec.optional moveSuffixAnnotationParser - fromQualifiedMove <$> if validateMoves - then Data.Maybe.maybe (return {-to ParsecT-monad-} qualifiedMove) (fail . showString "Failed: ") $ Model.Game.validateQualifiedMove qualifiedMove game - else return {-to ParsecT-monad-} qualifiedMove + fromQualifiedMove <$> ( + if validateMoves + then Data.Maybe.maybe (return {-to ParsecT-monad-} qualifiedMove) (fail . showString "Failed: ") . Model.Game.validateQualifiedMove game + else return {-to ParsecT-monad-} + ) qualifiedMove #endif -- | Represent a /rank/ in SAN. diff --git a/src-lib/BishBosh/Data/RoseTree.hs b/src-lib/BishBosh/Data/RoseTree.hs --- a/src-lib/BishBosh/Data/RoseTree.hs +++ b/src-lib/BishBosh/Data/RoseTree.hs @@ -35,6 +35,7 @@ -- ** Mutators promote, reduce, + prune, mapForest ) where @@ -77,7 +78,7 @@ \Data.Tree.Node { Data.Tree.rootLabel = rootLabel, Data.Tree.subForest = subForest - } -> (rootLabel :) `fmap` slave subForest remainingData {-recurse-} + } -> (rootLabel :) <$> slave subForest remainingData {-recurse-} ) slave _ _ = Just [] @@ -97,7 +98,7 @@ \forest'' -> match { Data.Tree.subForest = forest'' } : mismatches ++ remainingNodes - ) `fmap` slave remainingData forest' -- Recurse. + ) <$> slave remainingData forest' -- Recurse. _ -> Nothing -- Match-failure. slave _ forest = Just forest -- Data exhausted => Terminate normally. @@ -110,6 +111,18 @@ -- | The type of a function which changes the structure (but not the type) of the specified tree. type Transformation a = Data.Tree.Tree a -> Data.Tree.Tree a + +-- | Remove branches after the specified depth. +prune :: Int -> Transformation a +prune depth tree@Data.Tree.Node { Data.Tree.subForest = forest } + | depth < 0 = error "BishBosh.Data.RoseTree.prune:\tdepth can't be negative." + | otherwise = tree { + Data.Tree.subForest = if depth == 0 + then [] + else map ( + prune $ pred depth -- Recurse. + ) forest + } {- | * Apply an arbitrary mapping to all subForests; cf. 'fmap' which applies an arbitrary function to all 'Data.Tree.rootLabel's. diff --git a/src-lib/BishBosh/Direction/Diagonal.hs b/src-lib/BishBosh/Direction/Diagonal.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Direction/Diagonal.hs @@ -0,0 +1,114 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Describes the directional components of a diagonal line. +-} + +module BishBosh.Direction.Diagonal( +-- * Types +-- ** Data-types + Diagonal() +) where + +import Control.Arrow((***)) +import qualified BishBosh.Direction.Horizontal as Direction.Horizontal +import qualified BishBosh.Direction.Vertical as Direction.Vertical +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified Control.DeepSeq +import qualified Data.List.Extra + +-- | Directions at 45 degress to all edges of the board; those in which a Bishop can move. +data Diagonal = MkDiagonal { + getVertical :: Direction.Vertical.Vertical, -- ^ The vertical component of the diagonal. + getHorizontal :: Direction.Horizontal.Horizontal -- ^ The horizontal component of the diagonal. +} deriving (Eq, Ord) + +instance Control.DeepSeq.NFData Diagonal where + rnf MkDiagonal { + getVertical = _, + getHorizontal = _ + } = () + +instance Enum Diagonal where + fromEnum MkDiagonal { + getVertical = v, + getHorizontal = h + } = fromIntegral Direction.Vertical.nVerticals * fromEnum v + fromEnum h + + toEnum i = uncurry MkDiagonal . (toEnum *** toEnum) $! i `divMod` fromIntegral Direction.Vertical.nVerticals + +instance Show Diagonal where + showsPrec precedence MkDiagonal { + getVertical = v, + getHorizontal = h + } = showsPrec precedence v . showsPrec precedence h + +instance Read Diagonal where + readsPrec precedence s = case readsPrec precedence $ Data.List.Extra.trimStart s of + [(vertical, s')] -> case readsPrec precedence s' of + [(horizontal, s'')] -> [ + ( + MkDiagonal { + getVertical = vertical, + getHorizontal = horizontal + }, + s'' + ) -- Pair. + ] -- Singleton. + _ -> [] -- No parse. + _ -> [] -- No parse. + +instance Property.FixedMembership.FixedMembership Diagonal where + members = map MkDiagonal Property.FixedMembership.members {-vertical-} <*> Property.FixedMembership.members {-horizontal-} + +instance Property.Opposable.Opposable Diagonal where + getOpposite MkDiagonal { + getVertical = v, + getHorizontal = h + } = MkDiagonal { + getVertical = Property.Opposable.getOpposite v, + getHorizontal = Property.Opposable.getOpposite h + } + +instance Property.Orientated.Orientated Diagonal where + isParallel = const False + isDiagonal = const True + isStraight = const True + +instance Property.Reflectable.ReflectableOnX Diagonal where + reflectOnX diagonal@MkDiagonal { + getVertical = v + } = diagonal { + getVertical = Property.Reflectable.reflectOnX v + } + +instance Property.Reflectable.ReflectableOnY Diagonal where + reflectOnY diagonal@MkDiagonal { + getHorizontal = h + } = diagonal { + getHorizontal = Property.Reflectable.reflectOnY h + } + diff --git a/src-lib/BishBosh/Direction/Direction.hs b/src-lib/BishBosh/Direction/Direction.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Direction/Direction.hs @@ -0,0 +1,180 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Describes a /direction/. + + * The resolution of the measure is merely sufficient for Chess-moves. + + * The IO-format is based on 8 points of the compass. +-} + +module BishBosh.Direction.Direction( +-- * Types +-- ** Type-synonyms + ArrayByDirection, +-- ** Data-types + Direction(), +-- * Constants + parallels, + s, + n, + w, + e, + diagonals, + sw, + se, + nw, + ne, + opposites, +-- * Functions + attackDirectionsForPawn, + listArrayByDirection, +-- ** Predicates + areAligned +) where + +import Control.Arrow((&&&), (|||), (+++)) +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Direction.Diagonal as Direction.Diagonal +import qualified BishBosh.Direction.Parallel as Direction.Parallel +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Property.Rotatable as Property.Rotatable +import qualified Control.DeepSeq +import qualified Data.Array.IArray +import qualified Data.List.Extra + +-- | Define the /direction/ in which a piece moves relative to the board's edges. +newtype Direction = MkDirection (Either Direction.Parallel.Parallel Direction.Diagonal.Diagonal) deriving (Eq, Ord) + +instance Control.DeepSeq.NFData Direction where + rnf (MkDirection d) = Control.DeepSeq.rnf ||| Control.DeepSeq.rnf $ d + +instance Show Direction where + showsPrec precedence (MkDirection d) = showsPrec precedence ||| showsPrec precedence $ d + +instance Read Direction where + readsPrec precedence string = let + s' = Data.List.Extra.trimStart string + in case readsPrec precedence s' of + [(diagonal, s'')] -> [(MkDirection $ Right diagonal, s'')] + _ -> case readsPrec precedence s' of + [(parallel, s'')] -> [(MkDirection $ Left parallel, s'')] + _ -> [] -- No parse. + +instance Property.Opposable.Opposable Direction where + getOpposite (MkDirection d) = MkDirection $ (Property.Opposable.getOpposite +++ Property.Opposable.getOpposite) d + +instance Property.Orientated.Orientated Direction where + isVertical (MkDirection (Left p)) = Property.Orientated.isVertical p + isVertical _ = False + + isHorizontal (MkDirection (Left p)) = Property.Orientated.isHorizontal p + isHorizontal _ = False + + isParallel (MkDirection (Left _)) = True + isParallel _ = False + + isDiagonal (MkDirection (Right _)) = True + isDiagonal _ = False + + isStraight = const True + +instance Property.Reflectable.ReflectableOnX Direction where + reflectOnX (MkDirection d) = MkDirection $ (Property.Reflectable.reflectOnX +++ Property.Reflectable.reflectOnX) d + +instance Property.Reflectable.ReflectableOnY Direction where + reflectOnY (MkDirection d) = MkDirection $ (Property.Reflectable.reflectOnY +++ Property.Reflectable.reflectOnY) d + +instance Property.Rotatable.Rotatable Direction where + rotate90 direction + | Property.Orientated.isParallel direction = rotateParallel + | otherwise = rotateDiagonal + where + rotateParallel + | Property.Orientated.isVertical direction = rotateVertical + | otherwise = rotateHorizontal + where + rotateVertical + | direction == s = e + | otherwise {-n-} = w + + rotateHorizontal + | direction == w = s + | otherwise {-e-} = n + rotateDiagonal + | direction == sw = se + | direction == se = ne + | direction == nw = sw + | otherwise {-ne-} = nw + + rotate180 = Property.Opposable.getOpposite + +instance Property.FixedMembership.FixedMembership Direction where + members = parallels ++ diagonals + +instance Bounded Direction where + minBound = head Property.FixedMembership.members + maxBound = last Property.FixedMembership.members + +instance Data.Array.IArray.Ix Direction where + range _ = Property.FixedMembership.members + inRange _ _ = True + index _ (MkDirection d) = fromEnum ||| (+ fromIntegral Direction.Parallel.nParallels) . fromEnum $ d + +-- | Constant directions. +parallels :: [Direction] +s, n, w, e :: Direction +parallels@[s, n, w, e] = map (MkDirection . Left) Property.FixedMembership.members {-parallels-} + +-- | Constant directions. +diagonals :: [Direction] +sw, se, nw, ne :: Direction +diagonals@[sw, se, nw, ne] = map (MkDirection . Right) Property.FixedMembership.members + +{- | + * Returns a list of /direction/s, each paired with its anti-parallel. + + * CAVEAT: each /direction/ only appears once in the list, on an arbitrary side of a pair. +-} +opposites :: [(Direction, Direction)] +opposites = map (id &&& Property.Opposable.getOpposite) [n, ne, e, se] + +-- | The /direction/s in which a @Pawn@ can attack. +attackDirectionsForPawn :: Colour.LogicalColour.LogicalColour -> [Direction] +attackDirectionsForPawn Colour.LogicalColour.Black = [sw, se] +attackDirectionsForPawn _ = [nw, ne] + +-- | Whether the two /direction/s specified, are either parallel or anti-parallel. +areAligned :: Direction -> Direction -> Bool +areAligned l = uncurry (||) . ((== l) &&& (== l) . Property.Opposable.getOpposite) + +-- | A boxed array indexed by /direction/, of arbitrary elements. +type ArrayByDirection = Data.Array.IArray.Array {-Boxed-} Direction + +-- | Array-constructor. +listArrayByDirection :: Data.Array.IArray.IArray a e => [e] -> a Direction e +listArrayByDirection = Data.Array.IArray.listArray (minBound, maxBound) + diff --git a/src-lib/BishBosh/Direction/Horizontal.hs b/src-lib/BishBosh/Direction/Horizontal.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Direction/Horizontal.hs @@ -0,0 +1,66 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Describes the direction of a rank of the board. +-} + +module BishBosh.Direction.Horizontal( +-- * Types +-- ** Data-types + Horizontal(), +-- * Constants +-- range, + nHorizontals +) where + +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Count as Type.Count + +-- | The sum-type of orientations of all lines of constant rank. +data Horizontal = W | E deriving (Enum, Eq, Ord, Show) + +instance Read Horizontal where + readsPrec _ ('W' : s) = [(W, s)] + readsPrec _ ('E' : s) = [(E, s)] + readsPrec _ _ = [] -- No parse. + +instance Property.FixedMembership.FixedMembership Horizontal where + members = range + +instance Property.Opposable.Opposable Horizontal where + getOpposite W = E + getOpposite E = W + +instance Property.Reflectable.ReflectableOnY Horizontal where + reflectOnY = Property.Opposable.getOpposite + +-- | Constant range of values. +range :: [Horizontal] +range = [ toEnum 0 .. ] + +-- | The number of verticals directions. +nHorizontals :: Type.Count.NDirections +nHorizontals = fromIntegral $ length range + diff --git a/src-lib/BishBosh/Direction/Parallel.hs b/src-lib/BishBosh/Direction/Parallel.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Direction/Parallel.hs @@ -0,0 +1,104 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Describes the directional components of a line parallel to an edge of the board. +-} + +module BishBosh.Direction.Parallel( +-- * Types +-- ** Data-types + Parallel(), +-- * Constants +-- range, + nParallels +) where + +import Control.Arrow((|||), (+++)) +import qualified BishBosh.Direction.Horizontal as Direction.Horizontal +import qualified BishBosh.Direction.Vertical as Direction.Vertical +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Count as Type.Count +import qualified Control.DeepSeq +import qualified Data.List.Extra + +-- | Directions parallel to two edges of the board; those in which a Rook can move. +newtype Parallel = MkParallel (Either Direction.Vertical.Vertical Direction.Horizontal.Horizontal) deriving (Eq, Ord) + +instance Control.DeepSeq.NFData Parallel where + rnf (MkParallel p) = Control.DeepSeq.rwhnf ||| Control.DeepSeq.rwhnf $ p + +instance Enum Parallel where + fromEnum (MkParallel p) = fromEnum ||| (+ fromIntegral Direction.Vertical.nVerticals) . fromEnum $ p + + toEnum i = MkParallel $! case i `divMod` fromIntegral Direction.Vertical.nVerticals of + (0, remainder) -> Left $! toEnum remainder + (~1, remainder) -> Right $! toEnum remainder + +instance Show Parallel where + showsPrec precedence (MkParallel p) = showsPrec precedence ||| showsPrec precedence $ p + +instance Read Parallel where + readsPrec precedence s = let + s' = Data.List.Extra.trimStart s + in case readsPrec precedence s' of + [(vertical, s'')] -> [(MkParallel $ Left vertical, s'')] + _ -> case readsPrec precedence s' of + [(horizontal, s'')] -> [(MkParallel $ Right horizontal, s'')] + _ -> [] -- No parse. + +instance Property.FixedMembership.FixedMembership Parallel where + members = range + +instance Property.Opposable.Opposable Parallel where + getOpposite (MkParallel p) = MkParallel $ (Property.Opposable.getOpposite +++ Property.Opposable.getOpposite) p + +instance Property.Orientated.Orientated Parallel where + isVertical (MkParallel (Left _)) = True + isVertical _ = False + + isHorizontal (MkParallel (Right _)) = True + isHorizontal _ = False + + isParallel = const True + + isDiagonal = const False + + isStraight = const True + +instance Property.Reflectable.ReflectableOnX Parallel where + reflectOnX (MkParallel p) = MkParallel $ (Property.Reflectable.reflectOnX +++ id) p + +instance Property.Reflectable.ReflectableOnY Parallel where + reflectOnY (MkParallel p) = MkParallel $ (id +++ Property.Reflectable.reflectOnY) p + +-- | Constant range of values. +range :: [Parallel] +range = take (fromIntegral $ Direction.Vertical.nVerticals + Direction.Horizontal.nHorizontals) [ toEnum 0 .. ] + +-- | The number of verticals directions. +nParallels :: Type.Count.NDirections +nParallels = fromIntegral $ length range + diff --git a/src-lib/BishBosh/Direction/Vertical.hs b/src-lib/BishBosh/Direction/Vertical.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Direction/Vertical.hs @@ -0,0 +1,66 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Describes the direction of a file of the board. +-} + +module BishBosh.Direction.Vertical( +-- * Types +-- ** Data-types + Vertical(), +-- * Constants +-- verticals, + nVerticals +) where + +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Count as Type.Count + +-- | The sum-type of orientations of all lines of constant file. +data Vertical = S | N deriving (Enum, Eq, Ord, Show) + +instance Read Vertical where + readsPrec _ ('S' : s) = [(S, s)] + readsPrec _ ('N' : s) = [(N, s)] + readsPrec _ _ = [] -- No parse. + +instance Property.FixedMembership.FixedMembership Vertical where + members = verticals + +instance Property.Opposable.Opposable Vertical where + getOpposite S = N + getOpposite N = S + +instance Property.Reflectable.ReflectableOnX Vertical where + reflectOnX = Property.Opposable.getOpposite + +-- | Constant range of values. +verticals :: [Vertical] +verticals = [ toEnum 0 .. ] + +-- | The number of verticals directions. +nVerticals :: Type.Count.NDirections +nVerticals = fromIntegral $ length verticals + diff --git a/src-lib/BishBosh/Evaluation/Fitness.hs b/src-lib/BishBosh/Evaluation/Fitness.hs --- a/src-lib/BishBosh/Evaluation/Fitness.hs +++ b/src-lib/BishBosh/Evaluation/Fitness.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -34,8 +33,8 @@ -- maximumDestinations, maximumDefended, -- * Functions - measurePieceSquareValue, - measurePieceSquareValueIncrementally, + measurePieceSquareValueDifference, + measurePieceSquareValueDifferenceIncrementally, measureValueOfMaterial, -- measureValueOfMobility, measureValueOfCastlingPotential, @@ -49,11 +48,11 @@ import Control.Applicative((<|>)) import Control.Arrow((&&&)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank @@ -78,49 +77,34 @@ import qualified Data.Map.Strict as Map import qualified Data.Maybe -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - --- | Measures the piece-square value from the perspective of the last player to move. -measurePieceSquareValue :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Num pieceSquareValue - ) - => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue +-- | Measures the difference in piece-square value between players, from the perspective of the last player to move. +measurePieceSquareValueDifference + :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank -> Model.Game.Game - -> pieceSquareValue -{-# SPECIALISE measurePieceSquareValue :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue -> Model.Game.Game -> Type.Mass.PieceSquareValue #-} -measurePieceSquareValue pieceSquareByCoordinatesByRank game = ( - if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game + -> Type.Mass.Base +measurePieceSquareValueDifference pieceSquareByCoordinatesByRank game = ( + if Colour.LogicalColour.isBlack $! Model.Game.getNextLogicalColour game then id - else negate -- Represent the piece-square value from Black's perspective. - ) $ whitesPieceSquareValue - blacksPieceSquareValue where + else negate -- Represent the piece-square value difference from Black's perspective. + ) $! whitesPieceSquareValue - blacksPieceSquareValue where [blacksPieceSquareValue, whitesPieceSquareValue] = Data.Array.IArray.elems . State.Board.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank $ Model.Game.getBoard game {- | - * Measures the piece-square value from the perspective of the last player to move. + * Measures the difference in piece-square value between players, from the perspective of the last player to move. * The previous value is provided, to enable calculation by difference. - * N.B.: because of diminishing returns, the piece-square value for everything but quiet moves is calculated from scratch. + * N.B.: because of diminishing returns, the piece-square value for everything but simple moves is calculated from scratch. -} -measurePieceSquareValueIncrementally :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Num pieceSquareValue - ) - => pieceSquareValue -- ^ The value before the last move was applied, & therefore also from the perspective of the previous player. - -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue +measurePieceSquareValueDifferenceIncrementally + :: Type.Mass.Base -- ^ The difference between players in the piece-square value, before the last move was applied & therefore also from the perspective of the previous player. + -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank -> Model.Game.Game - -> pieceSquareValue -{-# SPECIALISE measurePieceSquareValueIncrementally :: Type.Mass.PieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue -> Model.Game.Game -> Type.Mass.PieceSquareValue #-} -measurePieceSquareValueIncrementally previousPieceSquareValue pieceSquareByCoordinatesByRank game - | Attribute.MoveType.isSimple $ Component.QualifiedMove.getMoveType qualifiedMove = let - findPieceSquareValue = uncurry ( + -> Type.Mass.Base +measurePieceSquareValueDifferenceIncrementally previousPieceSquareValueDifference pieceSquareByCoordinatesByRank game + | Attribute.MoveType.isSimple $! Component.QualifiedMove.getMoveType qualifiedMove = let + findPieceSquareValue :: Cartesian.Coordinates.Coordinates -> Type.Mass.Base + findPieceSquareValue = realToFrac . uncurry ( Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank ) ( State.Board.getNPieces {- N.B.: no capture occurred-} . Model.Game.getBoard &&& Property.Opposable.getOpposite . Model.Game.getNextLogicalColour $ game {-the last player to move-} @@ -129,8 +113,8 @@ ) in uncurry (-) ( findPieceSquareValue . Component.Move.getDestination &&& findPieceSquareValue . Component.Move.getSource $ Component.QualifiedMove.getMove qualifiedMove - ) - previousPieceSquareValue {-from the previous player's perspective-} - | otherwise = measurePieceSquareValue pieceSquareByCoordinatesByRank game -- N.B.: though non-simple (Castling, En-passant, promotion) can be calculated, the returns don't justify the effort. + ) - previousPieceSquareValueDifference {-from the previous player's perspective-} + | otherwise = measurePieceSquareValueDifference pieceSquareByCoordinatesByRank game -- N.B.: though non-simple (Castling, En-passant, promotion) can be calculated, the returns don't justify the effort. where Just turn = Model.Game.maybeLastTurn game qualifiedMove = Component.Turn.getQualifiedMove turn @@ -144,14 +128,14 @@ measureValueOfMaterial rankValues maximumTotalRankValue game = realToFrac . ( / maximumTotalRankValue -- Normalise. ) . ( - if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game + if Colour.LogicalColour.isBlack $! Model.Game.getNextLogicalColour game then id -- White just moved. else negate -- Black just moved. ) . Data.List.foldl' ( \acc (rank, nPiecesDifference) -> if nPiecesDifference == 0 then acc -- Avoid calling 'Input.RankValues.findRankValue'. else acc + realToFrac ( - Input.RankValues.findRankValue rank rankValues + Input.RankValues.findRankValue rankValues rank ) * fromIntegral nPiecesDifference ) 0 . Data.Array.IArray.assocs . State.Board.getNPiecesDifferenceByRank {-which arbitrarily counts White pieces as positive & Black as negative-} $ Model.Game.getBoard game @@ -178,20 +162,20 @@ measureValueOfMobility :: Model.Game.Game -> Metric.CriterionValue.CriterionValue measureValueOfMobility game = realToFrac . uncurry (-) . ( measureConstriction &&& measureConstriction . Property.Opposable.getOpposite {-recent mover-} - ) $ Model.Game.getNextLogicalColour game where - measureConstriction :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue - measureConstriction logicalColour = recip . fromIntegral {-NPlies-} . succ {-avoid divide-by-zero-} $ Model.Game.countPliesAvailableTo logicalColour game + ) $! Model.Game.getNextLogicalColour game where + measureConstriction :: Colour.LogicalColour.LogicalColour -> Type.Mass.CriterionValue + measureConstriction logicalColour = recip . fromIntegral {-NPlies-} . succ {-avoid divide-by-zero-} $ Model.Game.countPliesAvailableTo game logicalColour -- | Measure the arithmetic difference between the potential to /Castle/, on either side. measureValueOfCastlingPotential :: Model.Game.Game -> Metric.CriterionValue.CriterionValue measureValueOfCastlingPotential game = realToFrac . uncurry (-) . ( castlingPotential . Property.Opposable.getOpposite {-recent mover-} &&& castlingPotential ) $ Model.Game.getNextLogicalColour game where - castlingPotential :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue + castlingPotential :: Colour.LogicalColour.LogicalColour -> Type.Mass.CriterionValue castlingPotential = Data.Maybe.maybe 1 {-have Castled-} ( (/ 2) . fromIntegral . length - ) . ( - `State.CastleableRooksByLogicalColour.locateForLogicalColour` Model.Game.getCastleableRooksByLogicalColour game + ) . State.CastleableRooksByLogicalColour.locateForLogicalColour ( + Model.Game.getCastleableRooksByLogicalColour game ) {- | @@ -209,7 +193,7 @@ ) . fromIntegral {-NPieces-} . uncurry (-) . ( countDoubledPawns &&& countDoubledPawns . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where - countDoubledPawns :: Attribute.LogicalColour.LogicalColour -> Type.Count.NPieces + countDoubledPawns :: Colour.LogicalColour.LogicalColour -> Type.Count.NPieces countDoubledPawns logicalColour = uncurry (-) . ( Data.Foldable.foldl' (+) 0 &&& fromIntegral . Data.Foldable.length {-one Pawn can't be considered to be doubled, so substract one Pawn per column-} ) $ State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour @@ -227,7 +211,7 @@ ) . fromIntegral {-NPieces-} . uncurry (-) . ( countIsolatedPawns &&& countIsolatedPawns . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where - countIsolatedPawns :: Attribute.LogicalColour.LogicalColour -> Type.Count.NPieces + countIsolatedPawns :: Colour.LogicalColour.LogicalColour -> Type.Count.NPieces countIsolatedPawns logicalColour = Map.foldlWithKey' ( \acc x nPawns -> if (`Map.member` nPawnsByFile) `any` Cartesian.Abscissa.getAdjacents x then acc -- This file has at least one neighbouring Pawn which can (if at a suitable rank) be used to protect any of those in this file. @@ -242,7 +226,7 @@ ) . uncurry (-) . ( valuePassedPawns . Property.Opposable.getOpposite {-recent mover-} &&& valuePassedPawns ) $ Model.Game.getNextLogicalColour game where - valuePassedPawns :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue + valuePassedPawns :: Colour.LogicalColour.LogicalColour -> Type.Mass.CriterionValue valuePassedPawns logicalColour = Data.List.foldl' ( \acc -> (acc +) . recip {-value increases exponentially as distance to promotion decreases-} . fromIntegral . abs . subtract ( Cartesian.Ordinate.lastRank logicalColour @@ -298,19 +282,12 @@ * Many possible criteria aren't measured because they're, either currently or imminently, represented by those that are, typically by 'measureValueOfMaterial'. -} -evaluateFitness :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Fractional pieceSquareValue, - Real pieceSquareValue - ) - => Maybe pieceSquareValue -- ^ An optional value for the specified game. +evaluateFitness + :: Maybe Type.Mass.Base -- ^ An optional piece-square value difference for the specified game. -> Model.Game.Game - -> Input.EvaluationOptions.Reader pieceSquareValue Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues -{-# SPECIALISE evaluateFitness :: Maybe Type.Mass.PieceSquareValue -> Model.Game.Game -> Input.EvaluationOptions.Reader Type.Mass.PieceSquareValue Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues #-} -evaluateFitness maybePieceSquareValue game - | Just gameTerminationReason <- Model.Game.getMaybeTerminationReason game = return {-to Reader-monad-} $ Metric.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues ( + -> Input.EvaluationOptions.Reader Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues +evaluateFitness maybePieceSquareValueDifference game + | Just gameTerminationReason <- Model.Game.getMaybeTerminationReason game = return {-to Reader-monad-} $! Metric.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues ( if Rule.GameTerminationReason.isCheckMate gameTerminationReason then 1 -- The last player to move, has won. else 0 -- A draw. @@ -320,14 +297,14 @@ rankValuePair <- Control.Monad.Reader.asks $ Input.EvaluationOptions.getRankValues &&& Input.EvaluationOptions.getMaximumTotalRankValue maybePieceSquareByCoordinatesByRank <- Control.Monad.Reader.asks Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank - return {-to Reader-monad-} $ Input.CriteriaWeights.calculateWeightedMean criteriaWeights ( + return {-to Reader-monad-} $! Input.CriteriaWeights.calculateWeightedMean criteriaWeights ( uncurry measureValueOfMaterial rankValuePair game ) ( measureValueOfMobility game ) ( Data.Maybe.maybe 0 ( - realToFrac . (/ fromIntegral Component.Piece.nPiecesPerSide) - ) $ maybePieceSquareValue <|> fmap (`measurePieceSquareValue` game) maybePieceSquareByCoordinatesByRank + realToFrac . (/ fromIntegral Component.Piece.nPiecesPerSide) -- Normalise. + ) $ maybePieceSquareValueDifference <|> fmap (`measurePieceSquareValueDifference` game) maybePieceSquareByCoordinatesByRank ) ( measureValueOfCastlingPotential game ) ( diff --git a/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs b/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs --- a/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs +++ b/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -51,8 +50,8 @@ reduce, traceRoute, resign, - traceMatchingMoves, - promoteMatchingMoves, + traceMatchingMoveSequence, + promoteMatchingMoveSequence, sortNonCaptureMoves, -- ** Accessors getRootQuantifiedGame', @@ -83,17 +82,12 @@ import qualified BishBosh.Property.Null as Property.Null import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.Monad.Reader import qualified Data.Bits import qualified Data.Maybe import qualified Data.Tree -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | Define a node in the tree to contain the hash of a /game/ & an evaluation of the fitness of that /game/. data NodeLabel positionHash = MkNodeLabel { getPositionHash :: positionHash, -- ^ The hash of the /game/ contained in 'getQuantifiedGame'. @@ -129,7 +123,7 @@ } deriving Eq instance Property.Arboreal.Prunable (PositionHashQuantifiedGameTree positionHash) where - prune depth MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree $ Property.Arboreal.prune depth barePositionHashQuantifiedGameTree + prune depth MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree $ Data.RoseTree.prune depth barePositionHashQuantifiedGameTree instance Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree positionHash) where showsNotationFloat moveNotation showsDouble MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = showString $ ( @@ -144,22 +138,16 @@ fromBarePositionHashQuantifiedGameTree = MkPositionHashQuantifiedGameTree -- | Constructor. -mkPositionHashQuantifiedGameTree :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Real pieceSquareValue - ) - => Input.EvaluationOptions.EvaluationOptions pieceSquareValue +mkPositionHashQuantifiedGameTree + :: Data.Bits.Bits positionHash + => Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Component.Zobrist.Zobrist positionHash -> Model.GameTree.MoveFrequency -> Model.Game.Game -- ^ The current state of the /game/. -> PositionHashQuantifiedGameTree positionHash {-# SPECIALISE mkPositionHashQuantifiedGameTree - :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue + :: Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Component.Zobrist.Zobrist Type.Crypto.PositionHash -> Model.GameTree.MoveFrequency @@ -169,11 +157,11 @@ mkPositionHashQuantifiedGameTree evaluationOptions searchOptions zobrist moveFrequency seedGame = MkPositionHashQuantifiedGameTree ( if Input.EvaluationOptions.getIncrementalEvaluation evaluationOptions then let - apexPositionHash = StateProperty.Hashable.hash seedGame zobrist + apexPositionHash = StateProperty.Hashable.hash zobrist seedGame in Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel apexPositionHash $ Control.Monad.Reader.runReader ( Evaluation.QuantifiedGame.fromGame Nothing seedGame - ) evaluationOptions, -- Neither the previous positionHash nor the previous pieceSquareValue, are available to support incremental construction. + ) evaluationOptions, -- Neither the previous positionHash nor the previous pieceSquareValueDifference, are available to support incremental construction. Data.Tree.subForest = map ( Data.Maybe.maybe ( let @@ -190,33 +178,31 @@ in slave ) ( \pieceSquareByCoordinatesByRank -> let - slave pieceSquareValue positionHash game Data.Tree.Node { + slave pieceSquareValueDifference positionHash game Data.Tree.Node { Data.Tree.rootLabel = game', Data.Tree.subForest = gameForest' } = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel positionHash' $ Control.Monad.Reader.runReader ( - Evaluation.QuantifiedGame.fromGame (Just pieceSquareValue') game' + Evaluation.QuantifiedGame.fromGame (Just pieceSquareValueDifference') game' ) evaluationOptions, - Data.Tree.subForest = map (slave pieceSquareValue' positionHash' game') gameForest' -- Recurse. + Data.Tree.subForest = map (slave pieceSquareValueDifference' positionHash' game') gameForest' -- Recurse. } where - pieceSquareValue' = Evaluation.Fitness.measurePieceSquareValueIncrementally pieceSquareValue pieceSquareByCoordinatesByRank game' - positionHash' = Model.Game.updateIncrementalPositionHash game positionHash game' zobrist - in slave $ Evaluation.Fitness.measurePieceSquareValue pieceSquareByCoordinatesByRank seedGame + pieceSquareValueDifference' = Evaluation.Fitness.measurePieceSquareValueDifferenceIncrementally pieceSquareValueDifference pieceSquareByCoordinatesByRank game' + positionHash' = Model.Game.updateIncrementalPositionHash game positionHash game' zobrist + in slave $ Evaluation.Fitness.measurePieceSquareValueDifference pieceSquareByCoordinatesByRank seedGame ) ( Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions ) apexPositionHash seedGame ) $ Data.Tree.subForest bareGameTree } - else fmap ( - uncurry MkNodeLabel . ( - (`StateProperty.Hashable.hash` zobrist) &&& (`Control.Monad.Reader.runReader` evaluationOptions) . Evaluation.QuantifiedGame.fromGame Nothing - ) - ) bareGameTree + else uncurry MkNodeLabel . ( + StateProperty.Hashable.hash zobrist &&& (`Control.Monad.Reader.runReader` evaluationOptions) . Evaluation.QuantifiedGame.fromGame Nothing + ) <$> bareGameTree ) where bareGameTree = Model.GameTree.deconstruct . Model.GameTree.sortGameTree ( Input.SearchOptions.getMaybeCaptureMoveSortAlgorithm searchOptions ) ( - `Input.RankValues.findRankValue` Input.EvaluationOptions.getRankValues evaluationOptions + Input.RankValues.findRankValue $ Input.EvaluationOptions.getRankValues evaluationOptions ) moveFrequency $ Model.GameTree.fromGame seedGame -- | Accessor. @@ -240,7 +226,7 @@ :: Data.RoseTree.IsMatch (NodeLabel positionHash) -> PositionHashQuantifiedGameTree positionHash -> Maybe (PositionHashQuantifiedGameTree positionHash) -reduce isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree `fmap` Data.RoseTree.reduce isMatch barePositionHashQuantifiedGameTree +reduce isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree <$> Data.RoseTree.reduce isMatch barePositionHashQuantifiedGameTree -- | Forward request. traceRoute @@ -251,11 +237,11 @@ traceRoute isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute isMatch barePositionHashQuantifiedGameTree -- | Follow the specified move-sequence down the /positionHashQuantifiedGameTree/. -traceMatchingMoves +traceMatchingMoveSequence :: PositionHashQuantifiedGameTree positionHash - -> [Component.QualifiedMove.QualifiedMove] + -> Component.QualifiedMove.QualifiedMoveSequence -> Maybe [NodeLabel positionHash] -- ^ Returns 'Nothing', on failure to match a move. -traceMatchingMoves MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute equalsLastQualifiedMove barePositionHashQuantifiedGameTree +traceMatchingMoveSequence MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute equalsLastQualifiedMove barePositionHashQuantifiedGameTree -- | Amend the apex-game to reflect the resignation of the next player. resign :: PositionHashQuantifiedGameTree positionHash -> PositionHashQuantifiedGameTree positionHash @@ -277,11 +263,11 @@ * N.B.: this can be used to dynamically re-order the forest when a transposition is detected. -} -promoteMatchingMoves - :: [Component.QualifiedMove.QualifiedMove] -- ^ The list of qualifiedMoves, which should be promoted at successively deeper levels in the tree. +promoteMatchingMoveSequence + :: Component.QualifiedMove.QualifiedMoveSequence -- ^ The list of qualifiedMoves, which should be promoted at successively deeper levels in the tree. -> Forest positionHash - -> Maybe (Forest positionHash) -- ^ Returns 'Nothing' on failure to match a move. -promoteMatchingMoves = Data.RoseTree.promote equalsLastQualifiedMove + -> Maybe (Forest positionHash) -- ^ Returns 'Nothing' on failure to match a move. +promoteMatchingMoveSequence = Data.RoseTree.promote equalsLastQualifiedMove {- | * Sorts the forest, starting just after any initial capture-moves. diff --git a/src-lib/BishBosh/Evaluation/QuantifiedGame.hs b/src-lib/BishBosh/Evaluation/QuantifiedGame.hs --- a/src-lib/BishBosh/Evaluation/QuantifiedGame.hs +++ b/src-lib/BishBosh/Evaluation/QuantifiedGame.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -40,7 +39,6 @@ -- * Constants unboundedInterval, -- * Functions - compareFitness, -- ** Accessors getFitness, -- ** Constructors @@ -50,7 +48,10 @@ getLatestTurns, -- ** Mutators negateFitness, - negateInterval + negateInterval, +-- ** Predicates + (<=>), + (===) ) where import Control.Arrow((&&&)) @@ -71,10 +72,6 @@ import qualified Data.Maybe import qualified Data.Ord -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | The selected /game/ & the criteria against which it was quantified. data QuantifiedGame = MkQuantifiedGame { getGame :: Model.Game.Game, -- ^ The /game/ resulting from a sequence of /turn/s. @@ -98,18 +95,28 @@ getFitness :: QuantifiedGame -> Type.Mass.WeightedMean getFitness MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Metric.WeightedMeanAndCriterionValues.getWeightedMean weightedMeanAndCriterionValues +-- | Space-ship operator, like in Perl. +(<=>) :: QuantifiedGame -> QuantifiedGame -> Ordering +(<=>) = Data.Ord.comparing getFitness + +infix 4 <=> -- Same as (>). + +{- | + * Whether the games have taken the same move-sequences, & as such have the same position. + + * CAVEAT: the games won't be identical if they started from different positions, but by some fluke managed to make the same sequence of moves. +-} +(===) :: QuantifiedGame -> QuantifiedGame -> Bool +lhs === rhs = uncurry (==) . (($ lhs) &&& ($ rhs)) $ Model.Game.getTurnsByLogicalColour . getGame + +infix 4 === -- Same as (==). + -- | Constructor. -fromGame :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Fractional pieceSquareValue, - Real pieceSquareValue - ) - => Maybe pieceSquareValue -- ^ The value for the specified game. - -> Model.Game.Game -- ^ The current state of the /game/. - -> Input.EvaluationOptions.Reader pieceSquareValue QuantifiedGame -fromGame maybePieceSquareValue game = MkQuantifiedGame game `fmap` Evaluation.Fitness.evaluateFitness maybePieceSquareValue game +fromGame + :: Maybe Type.Mass.Base -- ^ The piece-square value difference for the specified game. + -> Model.Game.Game -- ^ The current state of the /game/. + -> Input.EvaluationOptions.Reader QuantifiedGame +fromGame maybePieceSquareValueDifference game = MkQuantifiedGame game <$> Evaluation.Fitness.evaluateFitness maybePieceSquareValueDifference game -- | Retrieve the /turn/ used to generate the selected /game/. getLastTurn :: QuantifiedGame -> Component.Turn.Turn @@ -127,10 +134,6 @@ -- | Represent the /fitness/ of the /game/ resulting from a future /move/ by the opponent, from the perspective of the current player. negateFitness :: QuantifiedGame -> QuantifiedGame negateFitness quantifiedGame@MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = quantifiedGame { getWeightedMeanAndCriterionValues = Metric.WeightedMeanAndCriterionValues.negateWeightedMean weightedMeanAndCriterionValues } - --- | Compares fitness. -compareFitness :: QuantifiedGame -> QuantifiedGame -> Ordering -compareFitness = Data.Ord.comparing getFitness {- | * The open interval in which to search for better solutions. diff --git a/src-lib/BishBosh/Input/CommandLineOption.hs b/src-lib/BishBosh/Input/CommandLineOption.hs --- a/src-lib/BishBosh/Input/CommandLineOption.hs +++ b/src-lib/BishBosh/Input/CommandLineOption.hs @@ -111,6 +111,7 @@ -> [String] -- ^ The command-line arguments to search. -> [String] -- ^ The matching argument-values. getArgs flags = slave where + slave :: [String] -> [String] slave [] = [] slave (x : xs) | x `elem` flags = case xs of diff --git a/src-lib/BishBosh/Input/EvaluationOptions.hs b/src-lib/BishBosh/Input/EvaluationOptions.hs --- a/src-lib/BishBosh/Input/EvaluationOptions.hs +++ b/src-lib/BishBosh/Input/EvaluationOptions.hs @@ -69,6 +69,7 @@ import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad.Reader +import qualified Data.Array.IArray import qualified Data.Default import qualified Data.Foldable import qualified Data.Maybe @@ -94,21 +95,19 @@ type IncrementalEvaluation = Bool -- | A pair of piece-square tables representing the opening & end-games respectively. -type PieceSquareTablePair pieceSquareValue = (Input.PieceSquareTable.PieceSquareTable pieceSquareValue, Input.PieceSquareTable.PieceSquareTable pieceSquareValue) +type PieceSquareTablePair = (Input.PieceSquareTable.PieceSquareTable, Input.PieceSquareTable.PieceSquareTable) -- | Defines the options related to the automatic selection of /move/s. -data EvaluationOptions pieceSquareValue = MkEvaluationOptions { - getRankValues :: Input.RankValues.RankValues, -- ^ The static value associated with each /piece/'s /rank/. - getMaximumTotalRankValue :: Type.Mass.RankValue, -- ^ Used to normalise the total value of pieces. Derived from 'getRankValues'. - getCriteriaWeights :: Input.CriteriaWeights.CriteriaWeights, -- ^ The weights applied to each of the heterogeneous criterion-values used to select a /move/. - getIncrementalEvaluation :: IncrementalEvaluation, -- ^ Whether to generate position-hashes & evaluate the piece-square value, from the previous value or from scratch. - getMaybePieceSquareTablePair :: Maybe (PieceSquareTablePair pieceSquareValue), -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. - getMaybePieceSquareByCoordinatesByRank :: Maybe ( - Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue - ) -- ^ The optional value for each rank of /piece/, when occupying each coordinate, at each phase of the game. +data EvaluationOptions = MkEvaluationOptions { + getRankValues :: Input.RankValues.RankValues, -- ^ The static value associated with each /piece/'s /rank/. + getMaximumTotalRankValue :: Type.Mass.RankValue, -- ^ Used to normalise the total value of pieces. Derived from 'getRankValues'. + getCriteriaWeights :: Input.CriteriaWeights.CriteriaWeights, -- ^ The weights applied to each of the heterogeneous criterion-values used to select a /move/. + getIncrementalEvaluation :: IncrementalEvaluation, -- ^ Whether to generate position-hashes & evaluate the piece-square value, from the previous value or from scratch. + getMaybePieceSquareTablePair :: Maybe PieceSquareTablePair, -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. + getMaybePieceSquareByCoordinatesByRank :: Maybe Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank -- ^ The optional value for each rank of /piece/, when occupying each coordinate, at each phase of the game. } deriving (Eq, Show) -instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (EvaluationOptions pieceSquareValue) where +instance Control.DeepSeq.NFData EvaluationOptions where rnf MkEvaluationOptions { -- getRankValues = rankValues, getMaximumTotalRankValue = maximumTotalValue, @@ -118,7 +117,7 @@ getMaybePieceSquareByCoordinatesByRank = maybePieceSquareByCoordinatesByRank } = Control.DeepSeq.rnf (maximumTotalValue, criteriaWeights, incrementalEvaluation, maybePieceSquareByCoordinatesByRank) -instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (EvaluationOptions pieceSquareValue) where +instance Property.ShowFloat.ShowFloat EvaluationOptions where showsFloat fromDouble MkEvaluationOptions { getRankValues = rankValues, -- getMaximumTotalRankValue = maximumTotalValue, @@ -146,7 +145,7 @@ ] ) maybePieceSquareTablePair -instance Data.Default.Default (EvaluationOptions pieceSquareValue) where +instance Data.Default.Default EvaluationOptions where def = MkEvaluationOptions { getRankValues = rankValues, getMaximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues, @@ -157,12 +156,7 @@ } where rankValues = Data.Default.def -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Real pieceSquareValue, - Show pieceSquareValue - ) => HXT.XmlPickler (EvaluationOptions pieceSquareValue) where +instance HXT.XmlPickler EvaluationOptions where xpickle = HXT.xpDefault def . HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d) -> mkEvaluationOptions a b c d, -- Construct. \MkEvaluationOptions { @@ -184,27 +178,26 @@ def = Data.Default.def -- | Convert a /PieceSquareTablePair/ to a single linearly interpolated array. -fromPieceSquareTablePair :: Fractional pieceSquareValue => PieceSquareTablePair pieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue +fromPieceSquareTablePair :: PieceSquareTablePair -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank fromPieceSquareTablePair pieceSquareTablePair = Component.PieceSquareByCoordinatesByRank.mkPieceSquareByCoordinatesByRank $ \rank -> ( - \(openingGamePieceSquareValuesByCoordinates, maybeEndGamePieceSquareValuesByCoordinates) -> Data.Maybe.maybe ( - Left openingGamePieceSquareValuesByCoordinates + \(openingGamePieceSquareValueByCoordinates, maybeEndGamePieceSquareValueByCoordinates) -> Data.Maybe.maybe ( + Left openingGamePieceSquareValueByCoordinates ) ( Right . Cartesian.Coordinates.listArrayByCoordinates . zipWith Component.PieceSquareByCoordinatesByRank.interpolatePieceSquareValues ( - Data.Foldable.toList openingGamePieceSquareValuesByCoordinates - ) . Data.Foldable.toList - ) maybeEndGamePieceSquareValuesByCoordinates + Data.Array.IArray.elems openingGamePieceSquareValueByCoordinates + ) . Data.Array.IArray.elems + ) maybeEndGamePieceSquareValueByCoordinates ) $ ( Data.Maybe.fromJust {-values for the openingGame must be specified-} . Input.PieceSquareTable.dereference rank *** Input.PieceSquareTable.dereference rank ) pieceSquareTablePair -- | Smart constructor. mkEvaluationOptions - :: Fractional pieceSquareValue - => Input.RankValues.RankValues -- ^ The static value associated with each /piece/'s /rank/. - -> Input.CriteriaWeights.CriteriaWeights -- ^ The weights applied to the values of the criteria used to select a /move/. + :: Input.RankValues.RankValues -- ^ The static value associated with each /piece/'s /rank/. + -> Input.CriteriaWeights.CriteriaWeights -- ^ The weights applied to the values of the criteria used to select a /move/. -> IncrementalEvaluation - -> Maybe (PieceSquareTablePair pieceSquareValue) -- ^ The value to each type of piece, of each square, during normal play & the end-game. - -> EvaluationOptions pieceSquareValue + -> Maybe PieceSquareTablePair -- ^ The value to each type of piece, of each square, during normal play & the end-game. + -> EvaluationOptions mkEvaluationOptions rankValues criteriaWeights incrementalEvaluation maybePieceSquareTablePair | Just (pieceSquareTable, _) <- maybePieceSquareTablePair , let undefinedRanks = Input.PieceSquareTable.findUndefinedRanks pieceSquareTable @@ -220,10 +213,10 @@ getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, getMaybePieceSquareTablePair = maybePieceSquareTablePair, - getMaybePieceSquareByCoordinatesByRank = fromPieceSquareTablePair `fmap` maybePieceSquareTablePair -- Infer. + getMaybePieceSquareByCoordinatesByRank = fromPieceSquareTablePair <$> maybePieceSquareTablePair -- Infer. } where maximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues -- | Self-documentation. -type Reader pieceSquareValue = Control.Monad.Reader.Reader (EvaluationOptions pieceSquareValue) +type Reader = Control.Monad.Reader.Reader EvaluationOptions diff --git a/src-lib/BishBosh/Input/NativeUIOptions.hs b/src-lib/BishBosh/Input/NativeUIOptions.hs --- a/src-lib/BishBosh/Input/NativeUIOptions.hs +++ b/src-lib/BishBosh/Input/NativeUIOptions.hs @@ -46,7 +46,7 @@ import BishBosh.Data.Bool() import Control.Arrow((***)) -import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme +import qualified BishBosh.Colour.ColourScheme as Colour.ColourScheme import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Type.Length as Type.Length @@ -84,7 +84,7 @@ -- | Constructor. data NativeUIOptions = MkNativeUIOptions { getBoardMagnification :: ScreenCoordinates, -- ^ The factor by which the dimensions of the board are stretched when displayed. - getColourScheme :: Attribute.ColourScheme.ColourScheme, + getColourScheme :: Colour.ColourScheme.ColourScheme, getDepictFigurine :: DepictFigurine -- ^ Whether to a depict pieces using Unicode figurines. } deriving Eq @@ -109,7 +109,7 @@ boardMagnificationTag, showsPrec precision boardMagnification ), ( - Attribute.ColourScheme.tag, + Colour.ColourScheme.tag, showsPrec precision colourScheme ), ( depictFigurineTag, @@ -150,7 +150,7 @@ -- | Smart constructor. mkNativeUIOptions :: ScreenCoordinates -- ^ The factor by which the dimensions of the board are stretched when displayed. - -> Attribute.ColourScheme.ColourScheme + -> Colour.ColourScheme.ColourScheme -> DepictFigurine -> NativeUIOptions mkNativeUIOptions boardMagnification colourScheme depictFigurine diff --git a/src-lib/BishBosh/Input/Options.hs b/src-lib/BishBosh/Input/Options.hs --- a/src-lib/BishBosh/Input/Options.hs +++ b/src-lib/BishBosh/Input/Options.hs @@ -93,15 +93,15 @@ type RandomSeed = Int -- | Defines the application's options. -data Options pieceSquareValue = MkOptions { - getMaybeMaximumPlies :: Maybe Type.Count.NPlies, -- ^ The maximum number of plies before the game is terminated; required for profiling the application. - getMaybeRandomSeed :: Maybe RandomSeed, -- ^ Optionally seed the pseudo-random number-generator to produce a repeatable sequence. - getEvaluationOptions :: Input.EvaluationOptions.EvaluationOptions pieceSquareValue, -- ^ The single set of options by which all automated /move/s are evaluated. - getSearchOptions :: Input.SearchOptions.SearchOptions, -- ^ The options by which to automatically select /move/s. - getIOOptions :: Input.IOOptions.IOOptions -- ^ The /ioOptions/ by which to receive commands & present results. +data Options = MkOptions { + getMaybeMaximumPlies :: Maybe Type.Count.NPlies, -- ^ The maximum number of plies before the game is terminated; required for profiling the application. + getMaybeRandomSeed :: Maybe RandomSeed, -- ^ Optionally seed the pseudo-random number-generator to produce a repeatable sequence. + getEvaluationOptions :: Input.EvaluationOptions.EvaluationOptions, -- ^ The single set of options by which all automated /move/s are evaluated. + getSearchOptions :: Input.SearchOptions.SearchOptions, -- ^ The options by which to automatically select /move/s. + getIOOptions :: Input.IOOptions.IOOptions -- ^ The /ioOptions/ by which to receive commands & present results. } deriving (Eq, Show) -instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (Options pieceSquareValue) where +instance Control.DeepSeq.NFData Options where rnf MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -110,7 +110,7 @@ getIOOptions = ioOptions } = Control.DeepSeq.rnf (maybeMaximumPlies, maybeRandomSeed, evaluationOptions, searchOptions, ioOptions) -instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (Options pieceSquareValue) where +instance Property.ShowFloat.ShowFloat Options where showsFloat fromDouble MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -134,7 +134,7 @@ ) ] -instance Data.Default.Default (Options pieceSquareValue) where +instance Data.Default.Default Options where def = MkOptions { getMaybeMaximumPlies = Nothing, getMaybeRandomSeed = Nothing, @@ -143,12 +143,7 @@ getIOOptions = Data.Default.def } -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Real pieceSquareValue, - Show pieceSquareValue - ) => HXT.XmlPickler (Options pieceSquareValue) where +instance HXT.XmlPickler Options where xpickle = HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d, e) -> mkOptions a b c d e, -- Construct. \MkOptions { @@ -174,10 +169,10 @@ mkOptions :: Maybe Type.Count.NPlies -- ^ The maximum number of plies before the game is terminated; required for profiling the application. -> Maybe RandomSeed -- ^ Optionally seed the pseudo-random number-generator to produce a repeatable sequence. - -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue + -> Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Input.IOOptions.IOOptions - -> Options pieceSquareValue + -> Options mkOptions maybeMaximumPlies maybeRandomSeed evaluationOptions searchOptions ioOptions | Just maximumPlies <- maybeMaximumPlies , maximumPlies <= 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.Options.mkOptions:\t" . showString maximumPliesTag . Text.ShowList.showsAssociation $ shows maximumPlies " must exceed zero." @@ -193,22 +188,22 @@ } -- | The type of a function used to transform 'Options'. -type Transformation pieceSquareValue = Options pieceSquareValue -> Options pieceSquareValue +type Transformation = Options -> Options -- | Mutator. -setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation pieceSquareValue +setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation setMaybeOutputConfigFilePath maybeOutputConfigFilePath options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybeOutputConfigFilePath maybeOutputConfigFilePath ioOptions } -- | Mutator. -setMaybeRandomSeed :: Maybe RandomSeed -> Transformation pieceSquareValue +setMaybeRandomSeed :: Maybe RandomSeed -> Transformation setMaybeRandomSeed maybeRandomSeed options = options { getMaybeRandomSeed = maybeRandomSeed } -- | Mutator. -setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation pieceSquareValue +setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation setMaybePersistence maybePersistence options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = ioOptions { Input.IOOptions.getMaybePersistence = maybePersistence @@ -216,25 +211,25 @@ } -- | Mutator. -setVerbosity :: Input.Verbosity.Verbosity -> Transformation pieceSquareValue +setVerbosity :: Input.Verbosity.Verbosity -> Transformation setVerbosity verbosity options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setVerbosity verbosity ioOptions } -- | Mutator. -setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation pieceSquareValue +setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions ioOptions } -- | Mutator. -setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation pieceSquareValue +setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation setMaybePrintMoveTree maybePrintMoveTree options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybePrintMoveTree maybePrintMoveTree ioOptions } -- | Mutator. -swapSearchDepth :: Transformation pieceSquareValue +swapSearchDepth :: Transformation swapSearchDepth options@MkOptions { getSearchOptions = searchOptions } = options { getSearchOptions = Input.SearchOptions.swapSearchDepth searchOptions } diff --git a/src-lib/BishBosh/Input/PieceSquareTable.hs b/src-lib/BishBosh/Input/PieceSquareTable.hs --- a/src-lib/BishBosh/Input/PieceSquareTable.hs +++ b/src-lib/BishBosh/Input/PieceSquareTable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -40,6 +41,7 @@ -- ** Type-synonyms -- Normalise, -- ReflectOnY, +-- PieceSquareValueByCoordinates, IOFormat, Assocs, -- ** Data-types @@ -61,7 +63,7 @@ -- ** Constructors mkPieceSquareTable, -- ** Predicates - inClosedUnitInterval +-- inClosedUnitInterval ) where import BishBosh.Data.Bool() -- HXT.XmlPickler. @@ -77,10 +79,11 @@ import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Text.Case as Text.Case import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.Exception +import qualified Data.Array.IArray import qualified Data.Default -import qualified Data.Foldable import qualified Data.Map.Strict as Map import qualified Data.Set import qualified Text.XML.HXT.Arrow.Pickle as HXT @@ -103,20 +106,27 @@ -- | Type-synonym. type ReflectOnY = Bool +-- | Self-documentation. +type PieceSquareValueByCoordinates = +#if defined(USE_UNBOXED_ARRAYS) && !(defined(USE_NEWTYPE_WRAPPERS) || defined(USE_PRECISION)) + Cartesian.Coordinates.UArrayByCoordinates +#else + Cartesian.Coordinates.ArrayByCoordinates +#endif + Type.Mass.PieceSquareValue + -- | Defines the value for each type of piece, of occupying each square. -data PieceSquareTable pieceSquareValue = MkPieceSquareTable { - getNormalise :: Normalise, -- ^ Whether to map the specified values into the closed unit-interval. CAVEAT: incompatible with RelaxNG, the specification for which already constrains values to the unit-interval. - getReflectOnY :: ReflectOnY, -- ^ Whether values for the RHS of the board should be inferred by reflection about the y-axis. - getPieceSquareValueByCoordinatesByRank :: Map.Map Attribute.Rank.Rank ( - Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue - ) -- ^ N.B.: on the assumption that the values for Black pieces are the reflection of those for White, merely the /rank/ of each /piece/ need be defined. +data PieceSquareTable = MkPieceSquareTable { + getNormalise :: Normalise, -- ^ Whether to map the specified values into the closed unit-interval. CAVEAT: incompatible with RelaxNG, the specification for which already constrains values to the unit-interval. + getReflectOnY :: ReflectOnY, -- ^ Whether values for the RHS of the board should be inferred by reflection about the y-axis. + getPieceSquareValueByCoordinatesByRank :: Map.Map Attribute.Rank.Rank PieceSquareValueByCoordinates -- ^ N.B.: on the assumption that the values for Black pieces are the reflection of those for White, merely the /rank/ of each /piece/ need be defined. } deriving (Eq, Show) -instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (PieceSquareTable pieceSquareValue) where +instance Property.ShowFloat.ShowFloat PieceSquareTable where showsFloat fromDouble MkPieceSquareTable { getNormalise = normalise, getReflectOnY = reflectOnY, - getPieceSquareValueByCoordinatesByRank = byRank + getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Text.ShowList.showsAssociationList Text.ShowList.showsSeparator $ ( normaliseTag, shows normalise @@ -130,12 +140,12 @@ if reflectOnY then unmirror else id - ) . Data.Foldable.toList + ) . Data.Array.IArray.elems ) ( - Map.toList byRank + Map.toList pieceSquareValueByCoordinatesByRank ) -instance Data.Default.Default (PieceSquareTable pieceSquareValue) where +instance Data.Default.Default PieceSquareTable where def = MkPieceSquareTable { getNormalise = False, getReflectOnY = True, @@ -145,28 +155,23 @@ -- | The format of the values when read or written. type IOFormat = Double -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Real pieceSquareValue, - Show pieceSquareValue - ) => HXT.XmlPickler (PieceSquareTable pieceSquareValue) where +instance HXT.XmlPickler PieceSquareTable where xpickle = HXT.xpWrap ( \(a, b, c) -> mkPieceSquareTable a b c, -- Construct. \MkPieceSquareTable { getNormalise = normalise, getReflectOnY = reflectOnY, - getPieceSquareValueByCoordinatesByRank = byRank + getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } -> ( normalise, reflectOnY, Map.toList $ Map.map ( - ( + map realToFrac . ( if reflectOnY then unmirror else id - ) . Data.Foldable.toList - ) byRank + ) . Data.Array.IArray.elems + ) pieceSquareValueByCoordinatesByRank ) -- Deconstruct to tuple. ) . HXT.xpTriple ( getNormalise Data.Default.def `HXT.xpDefault` HXT.xpAttr normaliseTag HXT.xpickle {-Bool-} @@ -177,11 +182,13 @@ showString "by" $ Text.Case.toUpperInitial Attribute.Rank.tag ) $ HXT.xpickle {-rank-} `HXT.xpPair` HXT.xpWrap ( \s -> [ - realToFrac (pieceSquareValue :: IOFormat) | + (realToFrac :: IOFormat -> Type.Mass.Base) pieceSquareValue | word <- words s, (pieceSquareValue, "") <- reads word ], -- List-comprehension. - unwords . map (show . (\pieceSquareValue -> realToFrac pieceSquareValue :: IOFormat)) + unwords . map ( + show . (realToFrac :: Type.Mass.Base -> IOFormat) + ) -- Deconstruct. ) ( HXT.xpTextAttr . showString "by" $ Text.Case.toUpperInitial Cartesian.Coordinates.tag ) @@ -191,26 +198,20 @@ type Assocs rank pieceSquareValue = [(rank, [pieceSquareValue])] -- | Map the range of values onto the Closed Unit Interval. -normaliseToUnitInterval - :: (Fractional pieceSquareValue, Ord pieceSquareValue) - => Assocs rank pieceSquareValue - -> Assocs rank pieceSquareValue +normaliseToUnitInterval :: (Fractional pieceSquareValueIn, Real pieceSquareValueIn, Fractional pieceSquareValueOut) => Assocs rank pieceSquareValueIn -> Assocs rank pieceSquareValueOut normaliseToUnitInterval [] = [] normaliseToUnitInterval assocs | range == 0 = Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Input.PieceSquareTable.normaliseToUnitInterval:\tthe specified piece-square values are identical." | otherwise = map ( - Control.Arrow.second $ map ((/ range) . subtract minimum') + Control.Arrow.second $ map (realToFrac . (/ range) . subtract minimum') ) assocs where bounds@(minimum', _) = minimum &&& maximum $ concatMap snd assocs -- Analyse the range of values. range = uncurry subtract bounds -- | Check that the range of values is in the Closed Unit Interval. -inClosedUnitInterval - :: (Num pieceSquareValue, Ord pieceSquareValue) - => Assocs rank pieceSquareValue - -> Bool -inClosedUnitInterval = all $ all Data.Num.inClosedUnitInterval . snd {-[pieceSquareValue]-} +inClosedUnitInterval :: (Num pieceSquareValue, Ord pieceSquareValue) => Assocs rank pieceSquareValue -> Bool +inClosedUnitInterval = all $ all Data.Num.inClosedUnitInterval . snd {-[PieceSquareValue]-} -- | Generates a mirror-symmetric RHS, to build a complete description. mirror :: Show pieceSquareValue => [pieceSquareValue] -> [pieceSquareValue] @@ -225,18 +226,14 @@ unmirror pieceSquareValues = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.PieceSquareTable.unmirror:\tthe number of piece-square values must be a multiple of " . shows (Cartesian.Abscissa.xLength `div` 2) . showString "; " $ shows pieceSquareValues "." -- | Smart constructor. -mkPieceSquareTable :: ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Show pieceSquareValue - ) - => Normalise -- ^ Whether to normalise the specified values into the closed unit interval. +mkPieceSquareTable + :: Normalise -- ^ Whether to normalise the specified values into the closed unit interval. -> ReflectOnY -- ^ Whether values for the RHS of the board are inferred by reflection about the y-axis. - -> Assocs Attribute.Rank.Rank pieceSquareValue - -> PieceSquareTable pieceSquareValue + -> Assocs Attribute.Rank.Rank Type.Mass.Base + -> PieceSquareTable mkPieceSquareTable normalise reflectOnY assocs | any ( - (/= nValuesRequired) . fromIntegral . length . snd {-pieceSquareValues-} + (/= nValuesRequired) . fromIntegral . length . snd {-PieceSquareValues-} ) assocs = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\texactly " . shows nValuesRequired . showString " values must be defined for each type of piece; " $ shows assocs "." | not $ null duplicateRanks = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\tranks must be distinct; " $ shows duplicateRanks "." | not $ normalise || inClosedUnitInterval assocs = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\tall values must be within the closed unit-interval [0,1]; " $ shows assocs "." @@ -252,7 +249,7 @@ ) $ ( if normalise then normaliseToUnitInterval - else id + else map (Control.Arrow.second $ map realToFrac) ) assocs } where @@ -265,13 +262,10 @@ ) Cartesian.Coordinates.nSquares -- | Identify any /rank/ lacking a definition. -findUndefinedRanks :: PieceSquareTable pieceSquareValue -> Data.Set.Set Attribute.Rank.Rank +findUndefinedRanks :: PieceSquareTable -> Data.Set.Set Attribute.Rank.Rank findUndefinedRanks MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Data.Set.fromAscList Property.FixedMembership.members `Data.Set.difference` Map.keysSet pieceSquareValueByCoordinatesByRank -- | Lookup the values for all /coordinates/, corresponding to the specified /rank/. -dereference - :: Attribute.Rank.Rank - -> PieceSquareTable pieceSquareValue - -> Maybe (Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue) +dereference :: Attribute.Rank.Rank -> PieceSquareTable -> Maybe PieceSquareValueByCoordinates dereference rank MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Map.lookup rank pieceSquareValueByCoordinatesByRank diff --git a/src-lib/BishBosh/Input/RankValues.hs b/src-lib/BishBosh/Input/RankValues.hs --- a/src-lib/BishBosh/Input/RankValues.hs +++ b/src-lib/BishBosh/Input/RankValues.hs @@ -116,8 +116,8 @@ byRank = Attribute.Rank.arrayByRank assocs -- | Query. -findRankValue :: Attribute.Rank.Rank -> RankValues -> Metric.RankValue.RankValue -findRankValue rank (MkRankValues byRank) = byRank ! rank +findRankValue :: RankValues -> Attribute.Rank.Rank -> Metric.RankValue.RankValue +findRankValue (MkRankValues byRank) = (byRank !) {- | * The maximum total rank-value one side can have. diff --git a/src-lib/BishBosh/Input/SearchOptions.hs b/src-lib/BishBosh/Input/SearchOptions.hs --- a/src-lib/BishBosh/Input/SearchOptions.hs +++ b/src-lib/BishBosh/Input/SearchOptions.hs @@ -81,7 +81,7 @@ import BishBosh.Data.Bool() -- For 'HXT.xpickle'. import Control.Arrow((***)) import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Data.Foldable import qualified BishBosh.Input.StandardOpeningOptions as Input.StandardOpeningOptions @@ -137,7 +137,7 @@ -- | Used to qualify XML. searchDepthByLogicalColourTag :: String -searchDepthByLogicalColourTag = showString searchDepthTag . showString "By" $ Text.Case.toUpperInitial Attribute.LogicalColour.tag +searchDepthByLogicalColourTag = showString searchDepthTag . showString "By" $ Text.Case.toUpperInitial Colour.LogicalColour.tag -- | The constant minimum permissible search-depth. minimumSearchDepth :: Type.Count.NPlies @@ -170,7 +170,7 @@ type MaybeUseTranspositions = Maybe (Type.Count.NMoves, Type.Count.NPlies) -- | The depth to search for each /logical colour/. -type SearchDepthByLogicalColour = Map.Map Attribute.LogicalColour.LogicalColour Type.Count.NPlies +type SearchDepthByLogicalColour = Map.Map Colour.LogicalColour.LogicalColour Type.Count.NPlies -- | Defines options related to searching for a move. data SearchOptions = MkSearchOptions { @@ -308,11 +308,11 @@ duplicateLogicalColours = BishBosh.Data.Foldable.findDuplicates $ map fst {-logicalColour-} l in if null duplicateLogicalColours then l - else Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.SearchOptions.xpickle:\t" . showString Attribute.LogicalColour.tag . showString "s must be distinct; " $ shows duplicateLogicalColours "." + else Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.SearchOptions.xpickle:\t" . showString Colour.LogicalColour.tag . showString "s must be distinct; " $ shows duplicateLogicalColours "." ), -- Construct from a List. Map.toList -- Deconstruct to an association-list. ) . HXT.xpList {-potentially null-} . HXT.xpElem ( - showString "by" $ Text.Case.toUpperInitial Attribute.LogicalColour.tag + showString "by" $ Text.Case.toUpperInitial Colour.LogicalColour.tag ) $ HXT.xpickle {-LogicalColour-} `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpickle {-NPlies-} ) where def = Data.Default.def @@ -330,14 +330,14 @@ -> SearchDepthByLogicalColour -> SearchOptions mkSearchOptions sortOnStandardOpeningMoveFrequency maybeCaptureMoveSortAlgorithm maybeMinimumHammingDistance maybeRetireKillerMovesAfter trapRepeatedPositions usePondering maybeUseTranspositions standardOpeningOptions searchDepthByLogicalColour - | Just minimumHammingDistance <- maybeMinimumHammingDistance + | 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 + | 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.Foldable.length 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 + | 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." @@ -398,7 +398,7 @@ } -- | Extract those /logical colour/s for which a search-depth has been defined, which implies that the corresponding player is automated. -identifyAutomatedPlayers :: SearchOptions -> [Attribute.LogicalColour.LogicalColour] +identifyAutomatedPlayers :: SearchOptions -> [Colour.LogicalColour.LogicalColour] identifyAutomatedPlayers MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } = Map.keys searchDepthByLogicalColour diff --git a/src-lib/BishBosh/Input/UIOptions.hs b/src-lib/BishBosh/Input/UIOptions.hs --- a/src-lib/BishBosh/Input/UIOptions.hs +++ b/src-lib/BishBosh/Input/UIOptions.hs @@ -213,12 +213,12 @@ -- | Mutator. updateCECPFeature :: Input.CECPFeatures.Feature -> Transformation updateCECPFeature feature uiOptions@MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = uiOptions { - getEitherNativeUIOrCECPOptions = Input.CECPOptions.updateFeature feature `fmap` eitherNativeUIOrCECPOptions + getEitherNativeUIOrCECPOptions = Input.CECPOptions.updateFeature feature <$> eitherNativeUIOrCECPOptions } -- | Mutator. deleteCECPFeature :: Input.CECPFeatures.Feature -> Transformation deleteCECPFeature feature uiOptions@MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = uiOptions { - getEitherNativeUIOrCECPOptions = Input.CECPOptions.deleteFeature feature `fmap` eitherNativeUIOrCECPOptions + getEitherNativeUIOrCECPOptions = Input.CECPOptions.deleteFeature feature <$> eitherNativeUIOrCECPOptions } diff --git a/src-lib/BishBosh/Metric/CriterionValue.hs b/src-lib/BishBosh/Metric/CriterionValue.hs --- a/src-lib/BishBosh/Metric/CriterionValue.hs +++ b/src-lib/BishBosh/Metric/CriterionValue.hs @@ -53,15 +53,15 @@ showsPrec precedence (MkCriterionValue criterionValue) = showsPrec precedence criterionValue instance Num CriterionValue where - MkCriterionValue l + MkCriterionValue r = mkCriterionValue $ l + r - MkCriterionValue l * MkCriterionValue r = MkCriterionValue $ l * r - abs (MkCriterionValue criterionValue) = MkCriterionValue $ abs criterionValue - signum (MkCriterionValue criterionValue) = MkCriterionValue $ signum criterionValue + MkCriterionValue l + MkCriterionValue r = mkCriterionValue $! l + r + MkCriterionValue l * MkCriterionValue r = MkCriterionValue $! l * r + abs (MkCriterionValue criterionValue) = MkCriterionValue $! abs criterionValue + signum (MkCriterionValue criterionValue) = MkCriterionValue $! signum criterionValue fromInteger = mkCriterionValue . fromInteger - negate (MkCriterionValue criterionValue) = MkCriterionValue $ negate criterionValue + negate (MkCriterionValue criterionValue) = MkCriterionValue $! negate criterionValue instance Fractional CriterionValue where - MkCriterionValue l / MkCriterionValue r = mkCriterionValue $ l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. + MkCriterionValue l / MkCriterionValue r = mkCriterionValue $! l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. fromRational = mkCriterionValue . fromRational instance Real CriterionValue where diff --git a/src-lib/BishBosh/Metric/CriterionWeight.hs b/src-lib/BishBosh/Metric/CriterionWeight.hs --- a/src-lib/BishBosh/Metric/CriterionWeight.hs +++ b/src-lib/BishBosh/Metric/CriterionWeight.hs @@ -61,15 +61,15 @@ showsPrec precedence (MkCriterionWeight criterionWeight) = showsPrec precedence criterionWeight instance Num CriterionWeight where - MkCriterionWeight l + MkCriterionWeight r = mkCriterionWeight $ l + r - MkCriterionWeight l * MkCriterionWeight r = MkCriterionWeight $ l * r - abs (MkCriterionWeight criterionWeight) = MkCriterionWeight $ abs criterionWeight -- N.B.: if the operand is valid, then this is equivalent to 'id'. - signum (MkCriterionWeight criterionWeight) = MkCriterionWeight $ signum criterionWeight + MkCriterionWeight l + MkCriterionWeight r = mkCriterionWeight $! l + r + MkCriterionWeight l * MkCriterionWeight r = MkCriterionWeight $! l * r + abs (MkCriterionWeight criterionWeight) = MkCriterionWeight $! abs criterionWeight -- N.B.: if the operand is valid, then this is equivalent to 'id'. + signum (MkCriterionWeight criterionWeight) = MkCriterionWeight $! signum criterionWeight fromInteger = mkCriterionWeight . fromInteger - negate (MkCriterionWeight criterionWeight) = mkCriterionWeight $ negate criterionWeight -- CAVEAT: only valid for '0'. + negate (MkCriterionWeight criterionWeight) = mkCriterionWeight $! negate criterionWeight -- CAVEAT: only valid for '0'. instance Fractional CriterionWeight where - MkCriterionWeight l / MkCriterionWeight r = mkCriterionWeight $ l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. + MkCriterionWeight l / MkCriterionWeight r = mkCriterionWeight $! l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. fromRational = mkCriterionWeight . fromRational instance Real CriterionWeight where diff --git a/src-lib/BishBosh/Metric/RankValue.hs b/src-lib/BishBosh/Metric/RankValue.hs --- a/src-lib/BishBosh/Metric/RankValue.hs +++ b/src-lib/BishBosh/Metric/RankValue.hs @@ -66,18 +66,18 @@ readsPrec precision = map (Control.Arrow.first mkRankValue) . readsPrec precision . Data.List.Extra.trimStart instance Property.ShowFloat.ShowFloat RankValue where - showsFloat fromDouble MkRankValue { deconstruct = rankValue } = fromDouble $ realToFrac rankValue + showsFloat fromDouble MkRankValue { deconstruct = rankValue } = fromDouble $! realToFrac rankValue instance Num RankValue where - MkRankValue { deconstruct = l } + MkRankValue { deconstruct = r } = mkRankValue $ l + r - MkRankValue { deconstruct = l } * MkRankValue { deconstruct = r } = MkRankValue $ l * r - abs MkRankValue { deconstruct = rankValue } = MkRankValue $ abs rankValue -- N.B.: if the operand is valid, then this is equivalent to 'id'. - signum MkRankValue { deconstruct = rankValue } = MkRankValue $ signum rankValue + MkRankValue { deconstruct = l } + MkRankValue { deconstruct = r } = mkRankValue $! l + r + MkRankValue { deconstruct = l } * MkRankValue { deconstruct = r } = MkRankValue $! l * r + abs MkRankValue { deconstruct = rankValue } = MkRankValue $! abs rankValue -- N.B.: if the operand is valid, then this is equivalent to 'id'. + signum MkRankValue { deconstruct = rankValue } = MkRankValue $! signum rankValue fromInteger = mkRankValue . fromInteger - negate MkRankValue { deconstruct = rankValue } = mkRankValue $ negate rankValue -- CAVEAT: only valid for '0'. + negate MkRankValue { deconstruct = rankValue } = mkRankValue $! negate rankValue -- CAVEAT: only valid for '0'. instance Fractional RankValue where - MkRankValue { deconstruct = l } / MkRankValue { deconstruct = r } = mkRankValue $ l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. + MkRankValue { deconstruct = l } / MkRankValue { deconstruct = r } = mkRankValue $! l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. fromRational = mkRankValue . fromRational instance Real RankValue where @@ -87,7 +87,7 @@ rnf MkRankValue { deconstruct = rankValue } = Control.DeepSeq.rnf rankValue instance HXT.XmlPickler RankValue where - xpickle = HXT.xpWrap (mkRankValue, deconstruct) $ HXT.xpAttr tag HXT.xpickle + xpickle = HXT.xpWrap (mkRankValue, deconstruct) $! HXT.xpAttr tag HXT.xpickle -- | Smart constructor. mkRankValue :: Type.Mass.RankValue -> RankValue diff --git a/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs b/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs --- a/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs +++ b/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs @@ -76,7 +76,7 @@ getWeightedMean = weightedMean, getCriterionValues = criterionValues } = Text.ShowList.showsAssociationList' [ - (weightedMeanTag, fromDouble $ realToFrac weightedMean), + (weightedMeanTag, fromDouble $! realToFrac weightedMean), (criterionValuesTag, Text.ShowList.showsFormattedList' (fromDouble . realToFrac) criterionValues) ] diff --git a/src-lib/BishBosh/Model/Game.hs b/src-lib/BishBosh/Model/Game.hs --- a/src-lib/BishBosh/Model/Game.hs +++ b/src-lib/BishBosh/Model/Game.hs @@ -88,12 +88,12 @@ ) where import Control.Arrow((&&&), (***), (|||)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.CastlingMove as Component.CastlingMove import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove import qualified BishBosh.Component.Move as Component.Move @@ -172,7 +172,7 @@ sortAvailableQualifiedMoves = Map.map . Data.List.sortBy $ Data.Ord.comparing fst {-destination-} -- | The /move/s available to both players. -type AvailableQualifiedMovesByLogicalColour = Map.Map Attribute.LogicalColour.LogicalColour AvailableQualifiedMoves +type AvailableQualifiedMovesByLogicalColour = Map.Map Colour.LogicalColour.LogicalColour AvailableQualifiedMoves {- | * The first three fields represent the state of the /game/. @@ -182,11 +182,11 @@ * For efficiency the list of available /move/s is stored. -} data Game = MkGame { - getNextLogicalColour :: Attribute.LogicalColour.LogicalColour, -- ^ N.B.: can be derived from 'getTurnsByLogicalColour', unless 'Property.Reflectable.reflectOnX' has been called. + getNextLogicalColour :: Colour.LogicalColour.LogicalColour, -- ^ N.B.: can be derived from 'getTurnsByLogicalColour', unless 'Property.Reflectable.reflectOnX' has been called. getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, -- ^ Those @Rook@s which can still participate in castling. getBoard :: State.Board.Board, -- ^ The current state of the /board/. getTurnsByLogicalColour :: State.CastleableRooksByLogicalColour.TurnsByLogicalColour, -- ^ Successive /move/s & any /piece/ taken, recorded by player. - getMaybeChecked :: Maybe Attribute.LogicalColour.LogicalColour, -- ^ The player (if any), whose currently /checked/; which will typically be 'getNextLogicalColour', but 'listQualifiedMovesAvailableTo' can be called for either player. + getMaybeChecked :: Maybe Colour.LogicalColour.LogicalColour, -- ^ The player (if any), whose currently /checked/; which will typically be 'getNextLogicalColour', but 'listQualifiedMovesAvailableTo' can be called for either player. getInstancesByPosition :: InstancesByPosition, -- ^ The number of instances of various positions since the last unrepeatable move. getAvailableQualifiedMovesByLogicalColour :: AvailableQualifiedMovesByLogicalColour, -- ^ The /move/s available to each player. Since this is merely required for efficiency, it needn't have an entry for both players; & typically doesn't when checked, since radical pruning would otherwise be required. CAVEAT: doesn't account for game-termination. getMaybeTerminationReason :: Maybe Rule.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. @@ -283,11 +283,11 @@ instance Data.Default.Default Game where def = ( - mkGame Attribute.LogicalColour.White Data.Default.def {-castleableRooksByLogicalColour-} Data.Default.def {-board-} Data.Default.def {-turnsByLogicalColour-} + mkGame Colour.LogicalColour.White Data.Default.def {-castleableRooksByLogicalColour-} Data.Default.def {-board-} Data.Default.def {-turnsByLogicalColour-} ) { getMaybeChecked = Nothing, getAvailableQualifiedMovesByLogicalColour = Map.fromAscList $ map ( - id &&& (`mkAvailableQualifiedMovesFor` Data.Default.def {-game-}) + id &&& mkAvailableQualifiedMovesFor Data.Default.def {-game-} ) Property.FixedMembership.members } @@ -335,7 +335,7 @@ Property.ExtendedPositionDescription.showsEPD nextLogicalColour, -- 2. Active colour. Property.ExtendedPositionDescription.showsEPD castleableRooksByLogicalColour, -- 3. Castling availability. Data.Maybe.maybe Property.ExtendedPositionDescription.showsNullField ( - \turn -> if Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) turn + \turn -> if Component.Turn.isPawnDoubleAdvance turn $ Property.Opposable.getOpposite nextLogicalColour then Notation.MoveNotation.showsNotation Data.Default.def {-Smith is the same as the required Algebraic notation in this limited role-} . Cartesian.Coordinates.advance nextLogicalColour . Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove turn else Property.ExtendedPositionDescription.showsNullField ) $ maybeLastTurn game -- 4. En-passant target square. CAVEAT: in contrast to X-EPD, this is required even when there's no opposing Pawn in a suitable position to take en-passant. @@ -357,7 +357,7 @@ } = Text.ShowList.showsDelimitedList Property.ExtendedPositionDescription.showsSeparator id id [ Property.ExtendedPositionDescription.showsEPD game, shows $ State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition, -- 5. Half move clock. - shows . succ {-the full-move counter starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference Attribute.LogicalColour.Black turnsByLogicalColour -- 6. Full move counter. + shows . succ {-the full-move counter starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference turnsByLogicalColour Colour.LogicalColour.Black -- 6. Full move counter. ] instance Property.Empty.Empty Game where @@ -396,34 +396,32 @@ } instance StateProperty.Hashable.Hashable Game where - listRandoms game@MkGame { + listRandoms zobrist game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board - } zobrist = ( - if Attribute.LogicalColour.isBlack nextLogicalColour + } = ( + if Colour.LogicalColour.isBlack nextLogicalColour then (Component.Zobrist.getRandomForBlacksMove zobrist :) else id - ) . Data.Maybe.maybe id ( - (++) . (`StateProperty.Hashable.listRandoms` zobrist) - ) ( + ) $ StateProperty.Hashable.listRandoms zobrist ( maybeLastTurn game >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa nextLogicalColour ( State.Board.getMaybePieceByCoordinates board - ) - ) $ StateProperty.Hashable.listRandoms castleableRooksByLogicalColour zobrist ++ StateProperty.Hashable.listRandoms board zobrist + ), + castleableRooksByLogicalColour, + board + ) -- Triple. -- | Smart constructor. mkGame - :: Attribute.LogicalColour.LogicalColour -- ^ The player who is required to move next. + :: Colour.LogicalColour.LogicalColour -- ^ The player who is required to move next. -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> State.Board.Board -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour -> Game mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour | not . StateProperty.Censor.hasBothKings $ State.Board.getCoordinatesByRankByLogicalColour board = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tboth Kings must exist; " $ shows board "." - | State.Board.isKingChecked ( - Property.Opposable.getOpposite nextLogicalColour - ) board = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tthe player who last moved, is still checked; " $ shows board "." + | State.Board.isKingChecked board $ Property.Opposable.getOpposite nextLogicalColour = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tthe player who last moved, is still checked; " $ shows board "." | otherwise = game where game = MkGame { @@ -431,10 +429,10 @@ getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, getTurnsByLogicalColour = turnsByLogicalColour, - getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board) Property.FixedMembership.members, + getMaybeChecked = Data.List.find (State.Board.isKingChecked board) Property.FixedMembership.members, getInstancesByPosition = State.InstancesByPosition.mkSingleton $ mkPosition game, getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ - (logicalColour, mkAvailableQualifiedMovesFor logicalColour game) | + (logicalColour, mkAvailableQualifiedMovesFor game logicalColour) | logicalColour <- Property.FixedMembership.members, getMaybeChecked game /= Just logicalColour -- Define the available qualified moves for unchecked players only. ], -- List-comprehension. @@ -451,7 +449,7 @@ * There're zero previous turns. -} fromBoard :: State.Board.Board -> Game -fromBoard board = mkGame Attribute.LogicalColour.White ( +fromBoard board = mkGame Colour.LogicalColour.White ( State.CastleableRooksByLogicalColour.fromBoard board ) board Property.Empty.empty {-TurnsByLogicalColour-} @@ -461,8 +459,8 @@ getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour } = uncurry ToolShed.Data.List.interleave $ ( - State.TurnsByLogicalColour.dereference (Property.Opposable.getOpposite nextLogicalColour) &&& State.TurnsByLogicalColour.dereference nextLogicalColour - ) turnsByLogicalColour + State.TurnsByLogicalColour.dereference turnsByLogicalColour . Property.Opposable.getOpposite &&& State.TurnsByLogicalColour.dereference turnsByLogicalColour + ) nextLogicalColour -- | Gets the sequence of /turn/s in the order they occured. listTurnsChronologically :: Game -> [Component.Turn.Turn] @@ -473,9 +471,7 @@ maybeLastTurn MkGame { getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour -} = Data.Maybe.listToMaybe $ State.TurnsByLogicalColour.dereference ( - Property.Opposable.getOpposite nextLogicalColour - ) turnsByLogicalColour +} = Data.Maybe.listToMaybe . State.TurnsByLogicalColour.dereference turnsByLogicalColour $ Property.Opposable.getOpposite nextLogicalColour {- | * Returns the castling /move/s currently available to the @King@ of the specified /logical colour/. @@ -484,26 +480,28 @@ * CAVEAT: this is a performance-hotspot; refactor => re-profile. -} -findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game -> [Component.QualifiedMove.QualifiedMove] -findAvailableCastlingMoves logicalColour MkGame { +findAvailableCastlingMoves :: Game -> Colour.LogicalColour.LogicalColour -> [Component.QualifiedMove.QualifiedMove] +findAvailableCastlingMoves MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, getMaybeChecked = maybeChecked -} +} logicalColour | Just checkedLogicalColour <- maybeChecked , checkedLogicalColour == logicalColour = [] -- One can't Castle out of check. - | Just rooksStartingXs <- State.CastleableRooksByLogicalColour.locateForLogicalColour logicalColour castleableRooksByLogicalColour = [ + | Just rooksStartingXs <- State.CastleableRooksByLogicalColour.locateForLogicalColour castleableRooksByLogicalColour logicalColour = [ Component.QualifiedMove.mkQualifiedMove castlingKingsMove $ Component.CastlingMove.getMoveType castlingMove | x <- rooksStartingXs, castlingMove <- Component.CastlingMove.getCastlingMoves logicalColour, let castlingRooksSource = Component.Move.getSource $ Component.CastlingMove.getRooksMove castlingMove, Cartesian.Coordinates.getX castlingRooksSource == x, State.MaybePieceByCoordinates.isClear ( + State.Board.getMaybePieceByCoordinates board + ) ( Cartesian.Coordinates.kingsStartingCoordinates logicalColour - ) castlingRooksSource $ State.Board.getMaybePieceByCoordinates board, + ) castlingRooksSource, let castlingKingsMove = Component.CastlingMove.getKingsMove castlingMove, all ( - null . ($ board) . State.Board.findAttackersOf logicalColour + null . State.Board.findAttackersOf board logicalColour ) $ Component.Move.interpolate castlingKingsMove -- The King mustn't be checked anywhere alongs its route. ] {-list-comprehension-} | otherwise = [] {-have already Castled-} @@ -515,7 +513,7 @@ -> [Maybe Attribute.Rank.Rank] {-# INLINE listMaybePromotionRanks #-} listMaybePromotionRanks destination piece - | Component.Piece.isPawnPromotion destination piece = map Just Attribute.Rank.promotionProspects + | Component.Piece.isPawnPromotion piece destination = map Just Attribute.Rank.promotionProspects | otherwise = [Nothing] -- | The type of a function which transforms a /game/. @@ -541,10 +539,10 @@ } = Control.Exception.assert ( not $ isTerminated game -- CAVEAT: otherwise any resignation will be overwritten. ) game' where - ((move, moveType), sourceRank) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Component.Turn.getQualifiedMove &&& Component.Turn.getRank $ turn -- Deconstruct. + ((move, moveType), sourceRank) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Component.Turn.getQualifiedMove &&& Component.Turn.getRank $! turn -- Deconstruct. (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. - opponentsLogicalColour :: Attribute.LogicalColour.LogicalColour + opponentsLogicalColour :: Colour.LogicalColour.LogicalColour opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour inferredRooksMove = Data.Maybe.maybe ( @@ -566,9 +564,10 @@ getCastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.takeTurn nextLogicalColour turn castleableRooksByLogicalColour, getBoard = board', getTurnsByLogicalColour = State.TurnsByLogicalColour.prepend nextLogicalColour turn turnsByLogicalColour, - getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board') [opponentsLogicalColour], + getMaybeChecked = Data.List.find (State.Board.isKingChecked board') [opponentsLogicalColour], getInstancesByPosition = State.InstancesByPosition.insertPosition (Component.Turn.getIsRepeatableMove turn) (mkPosition game') instancesByPosition, getAvailableQualifiedMovesByLogicalColour = let + moveEndpoints :: [Cartesian.Coordinates.Coordinates] moveEndpoints = ( case moveType of Attribute.MoveType.Castle _ -> (++) [ @@ -579,10 +578,12 @@ _ -> id ) [source, destination] + kingsByCoordinates :: [Component.Piece.LocatedPiece] kingsByCoordinates = map ( - (`State.CoordinatesByRankByLogicalColour.getKingsCoordinates` State.Board.getCoordinatesByRankByLogicalColour board') &&& Component.Piece.mkKing + State.CoordinatesByRankByLogicalColour.getKingsCoordinates (State.Board.getCoordinatesByRankByLogicalColour board') &&& Component.Piece.mkKing ) Property.FixedMembership.members + affected, affected' :: [Component.Piece.LocatedPiece] (affected, affected') = ( Data.List.nub . (:) ( destination, @@ -591,33 +592,30 @@ ) . Data.List.partition ( (== nextLogicalColour) . Component.Piece.getLogicalColour . snd {-piece-} ) . ( - if Component.Turn.isPawnDoubleAdvance nextLogicalColour turn + if Component.Turn.isPawnDoubleAdvance turn nextLogicalColour then (++) [ (pawnCoordinates, oppositePiece) | let oppositePiece = Component.Piece.mkPiece opponentsLogicalColour sourceRank, pawnCoordinates <- Cartesian.Coordinates.getAdjacents destination, - State.MaybePieceByCoordinates.dereference pawnCoordinates (State.Board.getMaybePieceByCoordinates board) == Just oppositePiece -- Find any opposing Pawn which can capture En-passant. + State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) pawnCoordinates == Just oppositePiece -- Find any opposing Pawn which can capture En-passant. ] {-list-comprehension-} else id ) $ kingsByCoordinates {-moves available to either King may be constrained or liberated, even if misaligned with move-endpoints-} ++ [ (knightsCoordinates, Component.Piece.mkKnight knightsColour) | knightsColour <- Property.FixedMembership.members, -- The moves for one's own Knights may be have been blocked by a friendly piece occupying an end-point, whereas the moves for opposing Knights will have a new move-type. - moveEndpoint <- moveEndpoints, - knightsCoordinates <- StateProperty.Seeker.findProximateKnights knightsColour moveEndpoint board' + knightsCoordinates <- concatMap (StateProperty.Seeker.findProximateKnights board' knightsColour) moveEndpoints ] {-list-comprehension-} ++ ( if sourceRank == Attribute.Rank.King - then [ - (blockingCoordinates, blockingPiece) | - (kingsCoordinates, _) <- kingsByCoordinates, - direction <- Property.FixedMembership.members, - (blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findBlockingPiece direction kingsCoordinates maybePieceByCoordinates' - ] -- List-comprehension. Re-evaluate the moves available to all pieces aligned with a King. + then concatMap ( + flip ( + State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' + ) Nothing {-omni-directional-} . fst {-coordinates-} + ) kingsByCoordinates -- Re-evaluate the moves available to all pieces aligned with a King. else [ (blockingCoordinates, blockingPiece) | (kingsCoordinates, _) <- kingsByCoordinates, - moveEndpoint <- moveEndpoints, - direction <- Data.Maybe.maybeToList . Cartesian.Vector.toMaybeDirection $ Cartesian.Vector.measureDistance kingsCoordinates moveEndpoint, -- N.B. null when the King isn't aligned with any move-endpoint. - let findBlockingPieceFrom coordinates = State.MaybePieceByCoordinates.findBlockingPiece direction coordinates maybePieceByCoordinates', + direction <- Data.Maybe.mapMaybe (Cartesian.Vector.toMaybeDirection . Cartesian.Vector.measureDistance kingsCoordinates) moveEndpoints, -- N.B. null when the King isn't aligned with any move-endpoint. + let findBlockingPieceFrom = flip (State.MaybePieceByCoordinates.findBlockingPiece maybePieceByCoordinates') direction, (blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ ( \pair@(coordinates, _) -> if coordinates /= destination then Just pair @@ -627,28 +625,30 @@ ) =<< findBlockingPieceFrom kingsCoordinates ] -- List-comprehension. Re-evaluate the moves available to all pieces aligned with a King & a move-endpoint. ) ++ [ - (coordinates, affectedPiece) | - moveEndpoint <- moveEndpoints, - direction <- Property.FixedMembership.members, - (coordinates, affectedPiece) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findBlockingPiece direction moveEndpoint maybePieceByCoordinates', - coordinates /= destination, -- Added above. - not . uncurry (||) $ (Component.Piece.isKnight &&& Component.Piece.isKing) affectedPiece, -- Added above. - Component.Piece.canMoveBetween coordinates moveEndpoint affectedPiece + locatedAffectedPiece | + moveEndpoint <- moveEndpoints, + locatedAffectedPiece <- filter ( + not . uncurry (||) . ( + (== destination) *** uncurry (||) . ( + Component.Piece.isKnight &&& Component.Piece.isKing + ) -- Added above. + ) + ) $ State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' moveEndpoint Nothing {-omni-directional-}, + uncurry (flip Component.Piece.canMoveBetween) locatedAffectedPiece moveEndpoint ] -- List-comprehension. Re-evaluate the moves available to all pieces, which either could move to the source, or can now move to the destination, of the requested move. + insertMovesFrom :: AvailableQualifiedMoves -> [Component.Piece.LocatedPiece] -> AvailableQualifiedMoves insertMovesFrom = foldr $ \(source', piece') -> let logicalColour = Component.Piece.getLogicalColour piece' - isSafeDestination destination' = not $ State.Board.exposesKing logicalColour (Component.Move.mkMove source' destination') board' + isSafeDestination destination' = not . State.Board.exposesKing board' logicalColour $ Component.Move.mkMove source' destination' in case [ (destination', Attribute.MoveType.EnPassant) | - Cartesian.Coordinates.isEnPassantRank logicalColour source', + Cartesian.Coordinates.isEnPassantRank source' logicalColour, Component.Piece.isPawn piece', - destination' <- Component.Piece.findAttackDestinations source' piece', - State.MaybePieceByCoordinates.isVacant destination' maybePieceByCoordinates', + destination' <- Component.Piece.findAttackDestinations piece' source', + State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates' destination', uncurry (&&) . ( - (== Just (Property.Opposable.getOpposite piece')) . ( - `State.MaybePieceByCoordinates.dereference` maybePieceByCoordinates' - ) &&& (== move) . Component.Move.mkMove (Cartesian.Coordinates.advance logicalColour destination') + (== Just (Property.Opposable.getOpposite piece')) . State.MaybePieceByCoordinates.dereference maybePieceByCoordinates' &&& (== move) . Component.Move.mkMove (Cartesian.Coordinates.advance logicalColour destination') ) $ Cartesian.Coordinates.retreat logicalColour destination', -- Did an opposing Pawn just double-advance to the expected position ? isSafeDestination destination' ] {-list-comprehension-} ++ [ @@ -656,7 +656,7 @@ destination', Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank ) | - (destination', maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor source' piece' maybePieceByCoordinates', + (destination', maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates' source' piece', maybeTakenRank /= Just Attribute.Rank.King, -- This move can never be made; the option will either be immediately removed or check-mate declared. isSafeDestination destination', maybePromotionRank <- listMaybePromotionRanks destination' piece' @@ -664,7 +664,8 @@ [] -> Map.delete source' -- There're zero moves from here. qualifiedDestinations -> Map.insert source' qualifiedDestinations -- Overwrite any existing moves. - insertCastlingMoves logicalColour = case findAvailableCastlingMoves logicalColour game' of + insertCastlingMoves :: Colour.LogicalColour.LogicalColour -> AvailableQualifiedMoves -> AvailableQualifiedMoves + insertCastlingMoves logicalColour = case findAvailableCastlingMoves game' logicalColour of [] -> id validCastlingMoves -> uncurry ( Map.insertWith (++) @@ -676,30 +677,32 @@ in ( \availableQualifiedMovesByLogicalColour' -> ( case (Map.member opponentsLogicalColour availableQualifiedMovesByLogicalColour', Data.Maybe.isJust $ getMaybeChecked game') of - (True, True) -> Map.delete opponentsLogicalColour -- Many changes result from the King being checked. - (True, _) -> Map.adjust ( - insertCastlingMoves opponentsLogicalColour . ( - `insertMovesFrom` affected' -- Reconstruct any moves for affected pieces. - ) . ( - if Attribute.MoveType.isEnPassant moveType - then Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination - else id - ) . Map.delete destination -- Delete the moves originally available to any taken piece. - ) opponentsLogicalColour - (_, True) -> id -- We neither want an entry in the map, nor is there one. - _ -> Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor opponentsLogicalColour game' -- Reconstruct. + (True, isChecked) + | isChecked -> Map.delete opponentsLogicalColour -- Many changes result from the King being checked. + | otherwise -> Map.adjust ( + insertCastlingMoves opponentsLogicalColour . ( + `insertMovesFrom` affected' -- Reconstruct any moves for affected pieces. + ) . ( + if Attribute.MoveType.isEnPassant moveType + then Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination + else id + ) . Map.delete destination -- Delete the moves originally available to any taken piece. + ) opponentsLogicalColour + (_, isChecked) + | isChecked -> id -- We neither want an entry in the map, nor is there one. + | otherwise -> Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor game' opponentsLogicalColour -- Reconstruct. ) availableQualifiedMovesByLogicalColour' ) $ ( if Data.Maybe.maybe True {-not a member-} ( \availableQualifiedMoves -> sourceRank == Attribute.Rank.King || Data.Maybe.maybe False {-zero previous turns-} ( - Component.Turn.isPawnDoubleAdvance opponentsLogicalColour + `Component.Turn.isPawnDoubleAdvance` opponentsLogicalColour ) ( maybeLastTurn game -- I.E. one's opponent. ) {-only required for efficiency-} && Data.Foldable.any ( any $ Attribute.MoveType.isEnPassant . snd {-moveType-} ) availableQualifiedMoves ) $ Map.lookup nextLogicalColour availableQualifiedMovesByLogicalColour - then Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor nextLogicalColour game' -- Reconstruct. + then Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor game' nextLogicalColour -- Reconstruct. else Map.adjust ( insertCastlingMoves nextLogicalColour . ( `insertMovesFrom` affected -- Reconstruct any moves for affected pieces. @@ -712,8 +715,8 @@ -- | Construct a /turn/ & relay the request to 'takeTurn'. applyQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Transformation applyQualifiedMove qualifiedMove game@MkGame { getBoard = board } - | Just piece <- State.MaybePieceByCoordinates.dereference (Component.Move.getSource move) $ State.Board.getMaybePieceByCoordinates board - = takeTurn (Component.Turn.mkTurn qualifiedMove $ Component.Piece.getRank piece) game + | Just piece <- State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) $! Component.Move.getSource move + = takeTurn (Component.Turn.mkTurn qualifiedMove $! Component.Piece.getRank piece) game | otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Model.Game.applyQualifiedMove:\tthere isn't a piece at the source of " . shows move . showString "; " $ shows game "." where move = Component.QualifiedMove.getMove qualifiedMove @@ -722,7 +725,7 @@ applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove -> Transformation applyEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } = applyQualifiedMove ( Component.QualifiedMove.mkQualifiedMove move . ( - ($ State.Board.getMaybePieceByCoordinates board) . State.MaybePieceByCoordinates.inferMoveType move ||| id + State.MaybePieceByCoordinates.inferMoveType (State.Board.getMaybePieceByCoordinates board) move ||| id ) $ Component.EitherQualifiedMove.getPromotionRankOrMoveType eitherQualifiedMove ) game where move = Component.EitherQualifiedMove.getMove eitherQualifiedMove @@ -743,7 +746,7 @@ datum, showString "board" . Text.ShowList.showsAssociation . shows (getBoard game) . showString " (" $ shows errorMessage ")" ) -- Pair. - ) $ validateEitherQualifiedMove eitherQualifiedMove game + ) $ validateEitherQualifiedMove game eitherQualifiedMove ) $ moveConstructor datum ) ) . Right @@ -754,18 +757,18 @@ * N.B.: it is considered valid to take a @King@, one just never has the opportunity, since the game terminates the move before. -} validateQualifiedMove - :: Component.QualifiedMove.QualifiedMove - -> Game -- ^ Prior to playing the /qualified move/. + :: Game -- ^ Prior to playing the /qualified move/. + -> Component.QualifiedMove.QualifiedMove -> Maybe String -- ^ Error-message. -validateQualifiedMove qualifiedMove game@MkGame { +validateQualifiedMove game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, getMaybeChecked = maybeChecked, getMaybeTerminationReason = maybeTerminationReason -} = Control.Exception.assert ( +} qualifiedMove = Control.Exception.assert ( StateProperty.Censor.hasBothKings ( State.Board.getCoordinatesByRankByLogicalColour board - ) && maybeChecked == Data.List.find (`State.Board.isKingChecked` board) Property.FixedMembership.members + ) && maybeChecked == Data.List.find (State.Board.isKingChecked board) Property.FixedMembership.members ) $ Data.Maybe.maybe ( Data.Maybe.maybe ( Just "there isn't a piece at the specified source-coordinates" -- N.B.: this is also caught by 'validateEitherQualifiedMove'. @@ -796,19 +799,19 @@ ( case Component.Piece.getRank sourcePiece of Attribute.Rank.Pawn - | destination `elem` Component.Piece.findAttackDestinations source sourcePiece -> Data.Maybe.maybe ( + | destination `elem` Component.Piece.findAttackDestinations sourcePiece source -> Data.Maybe.maybe ( let opponentsCoordinates = Cartesian.Coordinates.retreat sourceLogicalColour destination opponentsPawn = Property.Opposable.getOpposite sourcePiece in [ ( - not $ Cartesian.Coordinates.isEnPassantRank sourceLogicalColour source, + not $ Cartesian.Coordinates.isEnPassantRank source sourceLogicalColour, showString "one can't take a '" $ shows opponentsPawn "' en-passant, from this rank" ), ( - State.MaybePieceByCoordinates.isOccupied destination maybePieceByCoordinates, + State.MaybePieceByCoordinates.isOccupied maybePieceByCoordinates destination, showString "taking a '" $ shows opponentsPawn "' en-passant, requires a move to a vacant square" ), ( - State.MaybePieceByCoordinates.dereference opponentsCoordinates maybePieceByCoordinates /= Just opponentsPawn, + State.MaybePieceByCoordinates.dereference maybePieceByCoordinates opponentsCoordinates /= Just opponentsPawn, shows "en-passant" . showString " requires a '" $ shows opponentsPawn "' to be taken" ), ( Data.Maybe.maybe True {-zero previous turns-} ( @@ -827,14 +830,14 @@ "it may only have a sideways component during attack" ) : ( case ( - if Attribute.LogicalColour.isBlack sourceLogicalColour + if Colour.LogicalColour.isBlack sourceLogicalColour then negate else id ) $ Cartesian.Vector.getYDistance distance of 1 -> id 2 -> (++) [ ( - not $ Cartesian.Coordinates.isPawnsFirstRank sourceLogicalColour source, + not $ Cartesian.Coordinates.isPawnsFirstRank source sourceLogicalColour, "it only has the option to advance two squares on its first move" ), ( isObstructed, @@ -899,10 +902,10 @@ ( \rooksSource -> [ ( - not . State.CastleableRooksByLogicalColour.canCastleWith sourceLogicalColour rooksSource $ getCastleableRooksByLogicalColour game, + not $ State.CastleableRooksByLogicalColour.canCastleWith (getCastleableRooksByLogicalColour game) sourceLogicalColour rooksSource, showString "it has either already castled or lost the right to castle with the implied '" $ shows (Component.Piece.mkRook sourceLogicalColour) "'" ), ( - State.MaybePieceByCoordinates.isObstructed source rooksSource maybePieceByCoordinates, + State.MaybePieceByCoordinates.isObstructed maybePieceByCoordinates source rooksSource, "it can't castle through an obstruction" ) ] @@ -918,7 +921,7 @@ "it can't castle out of check" ), ( not . all ( - null . ($ board) . State.Board.findAttackersOf sourceLogicalColour + null . State.Board.findAttackersOf board sourceLogicalColour ) $ Component.Move.interpolate move, -- The King mustn't pass through check when moving from source to destination (inclusive); a long castle still permits the square right of the Rook to be checked. "it can't castle through check" ) @@ -930,57 +933,57 @@ else showString "your '" . shows (Component.Piece.mkKing sourceLogicalColour) . showChar '\'' ) $ if maybeChecked == Just sourceLogicalColour then ( - State.Board.isKingChecked sourceLogicalColour $ State.Board.movePiece move (Just moveType) board, -- CAVEAT: don't perform an unvalidated move at the Game-level. + State.Board.isKingChecked (State.Board.movePiece move (Just moveType) board) sourceLogicalColour, -- CAVEAT: don't perform an unvalidated move at the Game-level. " remains checked" ) -- Pair. else ( - State.Board.exposesKing sourceLogicalColour move board, + State.Board.exposesKing board sourceLogicalColour move, " would become exposed" ) -- Pair. ] -- Post-move tests on one's King. ) - ) $ State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates + ) $ State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source ) ( Just . show -- The game has been terminated, so there aren't any valid moves. ) maybeTerminationReason where (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board - maybeDestinationPiece = State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates -- Query. + maybeDestinationPiece = State.MaybePieceByCoordinates.dereference maybePieceByCoordinates destination -- Query. distance = Component.Move.measureDistance move isObstructed :: Bool - isObstructed = State.MaybePieceByCoordinates.isObstructed source destination maybePieceByCoordinates + isObstructed = State.MaybePieceByCoordinates.isObstructed maybePieceByCoordinates source destination -- | Validates the /move-type/ then forwards the request to 'validateQualifiedMove'. validateEitherQualifiedMove - :: Component.EitherQualifiedMove.EitherQualifiedMove - -> Game -- ^ Prior to playing the /move/. + :: Game -- ^ Prior to playing the /move/. + -> Component.EitherQualifiedMove.EitherQualifiedMove -> Maybe String -- ^ Error-message. -validateEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } - | State.MaybePieceByCoordinates.isVacant ( +validateEitherQualifiedMove game@MkGame { getBoard = board } eitherQualifiedMove + | State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates ( Component.Move.getSource move - ) maybePieceByCoordinates = Just "there isn't a piece at the specified source-coordinates" -- Guard the call to 'State.MaybePieceByCoordinates.inferMoveType'. + ) = Just "there isn't a piece at the specified source-coordinates" -- Guard the call to 'State.MaybePieceByCoordinates.inferMoveType'. | Right moveType <- promotionRankOrMoveType , moveType /= inferredMoveType = Just . showString "the implied " . showString Attribute.MoveType.tag . Text.ShowList.showsAssociation . shows moveType . showString " /= " $ show inferredMoveType - | otherwise = validateQualifiedMove (Component.QualifiedMove.mkQualifiedMove move inferredMoveType) game + | otherwise = validateQualifiedMove game $ Component.QualifiedMove.mkQualifiedMove move inferredMoveType where (move, promotionRankOrMoveType) = Component.EitherQualifiedMove.getMove &&& Component.EitherQualifiedMove.getPromotionRankOrMoveType $ eitherQualifiedMove maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board inferredMoveType :: Attribute.MoveType.MoveType - inferredMoveType = State.MaybePieceByCoordinates.inferMoveType move ( - id ||| Attribute.Rank.getMaybePromotionRank $ promotionRankOrMoveType -- Discard any move-type. - ) maybePieceByCoordinates + inferredMoveType = State.MaybePieceByCoordinates.inferMoveType maybePieceByCoordinates move $ ( + id ||| Attribute.Rank.getMaybePromotionRank + ) promotionRankOrMoveType -- Discard any move-type. -- | Whether the specified /QualifiedMove/ is valid. -isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Game -> Bool -isValidQualifiedMove qualifiedMove = Data.Maybe.isNothing . validateQualifiedMove qualifiedMove +isValidQualifiedMove :: Game -> Component.QualifiedMove.QualifiedMove -> Bool +isValidQualifiedMove game = Data.Maybe.isNothing . validateQualifiedMove game -- | Whether the specified /EitherQualifiedMove/ is valid. -isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove -> Game -> Bool -isValidEitherQualifiedMove eitherQualifiedMove = Data.Maybe.isNothing . validateEitherQualifiedMove eitherQualifiedMove +isValidEitherQualifiedMove :: Game -> Component.EitherQualifiedMove.EitherQualifiedMove -> Bool +isValidEitherQualifiedMove game = Data.Maybe.isNothing . validateEitherQualifiedMove game {- | * Roll-back the specified /game/ until the start, returning each previous /game/ paired with the /ply/ which was then made. @@ -996,7 +999,7 @@ getInstancesByPosition = instancesByPosition } -> let previousColour = Property.Opposable.getOpposite nextLogicalColour - in case State.TurnsByLogicalColour.dereference previousColour turnsByLogicalColour of + in case State.TurnsByLogicalColour.dereference turnsByLogicalColour previousColour of turn : previousTurns -> let (move, moveType) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) $ Component.Turn.getQualifiedMove turn -- Deconstruct. destination = Component.Move.getDestination move -- Deconstruct. @@ -1006,10 +1009,10 @@ getTurnsByLogicalColour = turnsByLogicalColour', getMaybeChecked = maybeChecked' } = game { - getNextLogicalColour = previousColour, - getCastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour turnsByLogicalColour', - getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board') [previousColour], - getBoard = ( + getNextLogicalColour = previousColour, + getCastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour turnsByLogicalColour', + getMaybeChecked = Data.List.find (State.Board.isKingChecked board') [previousColour], + getBoard = ( case moveType of Attribute.MoveType.Castle isShort -> State.Board.movePiece ( uncurry Component.Move.mkMove $ ( @@ -1033,16 +1036,16 @@ ) ( Attribute.MoveType.getMaybeExplicitlyTakenRank moveType -- Reconstruct any piece taken (except en-passant), inferring the logical colour. ) $ State.Board.movePiece (Property.Opposable.getOpposite move) Nothing {-MoveType-} board, -- N.B.: operate directly on the board to avoid creating a new Turn in the Game-structure. - getTurnsByLogicalColour = State.TurnsByLogicalColour.update turnsByLogicalColour [(previousColour, previousTurns)], - getInstancesByPosition = if Component.Turn.getIsRepeatableMove turn + getTurnsByLogicalColour = State.TurnsByLogicalColour.update [(previousColour, previousTurns)] turnsByLogicalColour, + getInstancesByPosition = if Component.Turn.getIsRepeatableMove turn then State.InstancesByPosition.deletePosition (mkPosition game) instancesByPosition else mkInstancesByPosition game', -- Reconstruct the map prior to the unrepeatable move. getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ - (logicalColour, mkAvailableQualifiedMovesFor logicalColour game') | + id &&& mkAvailableQualifiedMovesFor game' $ logicalColour | logicalColour <- Property.FixedMembership.members, maybeChecked' /= Just logicalColour ], -- List-comprehension. - getMaybeTerminationReason = Nothing + getMaybeTerminationReason = Nothing } in Just ((game', turn), game') _ -> Nothing @@ -1054,23 +1057,23 @@ * CAVEAT: to avoid an infinite loop, this doesn't check whether the game has already terminated. -} listQualifiedMovesAvailableTo - :: Attribute.LogicalColour.LogicalColour -- ^ Define the player for whom the moves are required. - -> Game + :: Game + -> Colour.LogicalColour.LogicalColour -- ^ Define the player for whom the moves are required. -> [Component.QualifiedMove.QualifiedMove] -listQualifiedMovesAvailableTo logicalColour game@MkGame { +listQualifiedMovesAvailableTo game@MkGame { getBoard = board, getMaybeChecked = maybeChecked -} +} logicalColour | maybeChecked == Just logicalColour = let - kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour + kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates coordinatesByRankByLogicalColour logicalColour in [ Component.QualifiedMove.mkQualifiedMove move moveType | - (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor kingsCoordinates (Component.Piece.mkKing logicalColour) maybePieceByCoordinates, + (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates kingsCoordinates $ Component.Piece.mkKing logicalColour, let move = Component.Move.mkMove kingsCoordinates destination moveType = Attribute.MoveType.mkNormalMoveType maybeTakenRank Nothing {-promotion-rank-}, - null . State.Board.findAttackersOf logicalColour destination $ State.Board.movePiece move (Just moveType) board -- Avoid moving the King into another check. CAVEAT: one can't merely use 'Board.exposesKing' since that assumes that one isn't already checked. - ] {-list-comprehension-} ++ case State.Board.findAttackersOf logicalColour kingsCoordinates board of + null $ State.Board.findAttackersOf (State.Board.movePiece move (Just moveType) board) logicalColour destination -- Avoid moving the King into another check. CAVEAT: one can't merely use 'Board.exposesKing' since that assumes that one isn't already checked. + ] {-list-comprehension-} ++ case State.Board.findAttackersOf board logicalColour kingsCoordinates of [(checkedFrom, checkedByRank)] -> Control.Exception.assert (checkedByRank /= Attribute.Rank.King) . filter isSafeQualifiedMove $ ( if checkedByRank == Attribute.Rank.Pawn then Data.Maybe.maybe [] {-CAVEAT: this can occur if the game has just been read from FEN-} ( @@ -1082,9 +1085,9 @@ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source $ Cartesian.Coordinates.advance logicalColour lastDestination -- Construct a move which takes the attacker. ) Attribute.MoveType.enPassant | - Component.Move.isPawnDoubleAdvance opponentsLogicalColour lastMove, + Component.Move.isPawnDoubleAdvance lastMove opponentsLogicalColour, source <- Cartesian.Coordinates.getAdjacents lastDestination, - State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates == Just pawn + State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source == Just pawn ] -- List-comprehension. ) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove ) $ maybeLastTurn game -- The King is checked by a Pawn, which must also have been the last piece to move. @@ -1093,7 +1096,7 @@ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source checkedFrom -- Construct a move which takes the attacker. ) $ Attribute.MoveType.mkNormalMoveType (Just checkedByRank) maybePromotionRank | - (source, attackersRank) <- State.Board.findAttackersOf opponentsLogicalColour checkedFrom board, -- See if the attacker can be taken (excluding en-passant). + (source, attackersRank) <- State.Board.findAttackersOf board opponentsLogicalColour checkedFrom, -- See if the attacker can be taken (excluding en-passant). attackersRank /= Attribute.Rank.King, -- The King can take its attacker, but it's already addressed above. maybePromotionRank <- listMaybePromotionRanks checkedFrom {-destination-} $ Component.Piece.mkPiece logicalColour attackersRank ] {-list-comprehension-} ++ [ @@ -1103,26 +1106,26 @@ checkedByRank /= Attribute.Rank.Knight, -- A Knight can't be blocked. rank <- Attribute.Rank.expendable, -- Find pieces that might be able to block the checking piece. let piece = Component.Piece.mkPiece logicalColour rank, - source <- State.CoordinatesByRankByLogicalColour.dereference logicalColour rank coordinatesByRankByLogicalColour, -- Find the source of a potential blocking move. - (destination, Nothing) <- State.MaybePieceByCoordinates.listDestinationsFor source piece maybePieceByCoordinates, -- The blocker must move to an empty square, otherwise the checker was already blocked. + source <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour rank, -- Find the source of a potential blocking move. + (destination, Nothing) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source piece, -- The blocker must move to an empty square, otherwise the checker was already blocked. Control.Exception.assert (checkedFrom /= kingsCoordinates) . elem destination . init {-drop King's location-} $ Cartesian.Coordinates.interpolate checkedFrom kingsCoordinates, maybePromotionRank <- listMaybePromotionRanks destination piece ] -- List-comprehension. attackers -> Control.Exception.assert ( length attackers == 2 -- Triple-check isn't possible. ) [] -- If checked by more than one piece, then the King must be moved; see options above. - | otherwise {-not checked-} = findAvailableCastlingMoves logicalColour game ++ filter isSafeQualifiedMove ( + | otherwise {-not checked-} = findAvailableCastlingMoves game logicalColour ++ filter isSafeQualifiedMove ( [ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source destination ) Attribute.MoveType.enPassant | let pawn = Component.Piece.mkPawn logicalColour, - source <- State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour, - Cartesian.Coordinates.isEnPassantRank logicalColour source, - destination <- Component.Piece.findAttackDestinations source pawn, - State.MaybePieceByCoordinates.isVacant destination maybePieceByCoordinates, + source <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour Attribute.Rank.Pawn, + Cartesian.Coordinates.isEnPassantRank source logicalColour, + destination <- Component.Piece.findAttackDestinations pawn source, + State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates destination, let opponentsCoordinates = Cartesian.Coordinates.retreat logicalColour destination, - State.MaybePieceByCoordinates.dereference opponentsCoordinates maybePieceByCoordinates == Just (Property.Opposable.getOpposite pawn), + State.MaybePieceByCoordinates.dereference maybePieceByCoordinates opponentsCoordinates == Just (Property.Opposable.getOpposite pawn), Data.Maybe.maybe False {-zero previous turns-} ( uncurry (&&) . ( (== opponentsCoordinates) . Component.Move.getDestination &&& ( @@ -1134,8 +1137,8 @@ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source destination ) $ Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank | - (source, piece) <- State.CoordinatesByRankByLogicalColour.findPiecesOfColour logicalColour coordinatesByRankByLogicalColour, - (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor source piece maybePieceByCoordinates, + (source, piece) <- State.CoordinatesByRankByLogicalColour.findPiecesOfColour coordinatesByRankByLogicalColour logicalColour, + (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source piece, maybeTakenRank /= Just Attribute.Rank.King, -- This move can never be made; the option will either be immediately removed or check-mate declared. maybePromotionRank <- listMaybePromotionRanks destination piece ] -- List-comprehension. @@ -1143,11 +1146,11 @@ where opponentsLogicalColour = Property.Opposable.getOpposite logicalColour (maybePieceByCoordinates, coordinatesByRankByLogicalColour) = State.Board.getMaybePieceByCoordinates &&& State.Board.getCoordinatesByRankByLogicalColour $ board - isSafeQualifiedMove qualifiedMove = not $ State.Board.exposesKing logicalColour (Component.QualifiedMove.getMove qualifiedMove) board + isSafeQualifiedMove qualifiedMove = not . State.Board.exposesKing board logicalColour $ Component.QualifiedMove.getMove qualifiedMove -- | Construct 'AvailableQualifiedMoves' for the player of the specified /logical colour/. -mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game -> AvailableQualifiedMoves -mkAvailableQualifiedMovesFor logicalColour = foldr {-maintains destination-order-} ( +mkAvailableQualifiedMovesFor :: Game -> Colour.LogicalColour.LogicalColour -> AvailableQualifiedMoves +mkAvailableQualifiedMovesFor game = foldr {-maintains destination-order-} ( \qualifiedMove -> let move = Component.QualifiedMove.getMove qualifiedMove in Map.insertWith (++) ( @@ -1158,7 +1161,7 @@ Component.QualifiedMove.getMoveType qualifiedMove ) -- Pair. ] {-singleton-} - ) Property.Empty.empty . listQualifiedMovesAvailableTo logicalColour + ) Property.Empty.empty . listQualifiedMovesAvailableTo game {- | * Retrieve the recorded value, or generate the list of /move/s available to the player of the specified /logical colour/. @@ -1166,31 +1169,31 @@ * CAVEAT: doesn't account for game-termination. -} findQualifiedMovesAvailableTo - :: Attribute.LogicalColour.LogicalColour - -> Game + :: Game + -> Colour.LogicalColour.LogicalColour -> [Component.QualifiedMove.QualifiedMove] -findQualifiedMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } +findQualifiedMovesAvailableTo game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } logicalColour | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [ Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType | (source, qualifiedDestinations) <- Map.toList availableQualifiedMoves, (destination, moveType) <- qualifiedDestinations ] -- List-comprehension. - | otherwise = listQualifiedMovesAvailableTo logicalColour game -- Generate the list of moves for this player. + | otherwise = listQualifiedMovesAvailableTo game logicalColour -- Generate the list of moves for this player. -- | Count the number of plies available to the specified player. -countPliesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game -> Type.Count.NPlies -countPliesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } +countPliesAvailableTo :: Game -> Colour.LogicalColour.LogicalColour -> Type.Count.NPlies +countPliesAvailableTo game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } logicalColour | isTerminated game = 0 | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour -- N.B.: 'findQualifiedMovesAvailableToNextPlayer' unnecessarily constructs a list. = fromIntegral $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves - | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo logicalColour game + | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo game logicalColour -- | Retrieve the recorded value, or generate the list of /move/s available to the next player. findQualifiedMovesAvailableToNextPlayer :: Game -> [Component.QualifiedMove.QualifiedMove] -findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo nextLogicalColour game +findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo game nextLogicalColour -- | Let the specified player resign. -resignationBy :: Attribute.LogicalColour.LogicalColour -> Transformation +resignationBy :: Colour.LogicalColour.LogicalColour -> Transformation resignationBy logicalColour game | isTerminated game = game -- Already terminated. | otherwise = game { @@ -1225,7 +1228,7 @@ } | haveZeroMoves , Just logicalColour <- getMaybeChecked game = Just $ Rule.GameTerminationReason.mkCheckMate logicalColour - | otherwise = fmap Rule.GameTerminationReason.mkDraw maybeDrawReason + | otherwise = Rule.GameTerminationReason.mkDraw <$> maybeDrawReason where haveZeroMoves :: Bool haveZeroMoves = null $ findQualifiedMovesAvailableToNextPlayer game @@ -1296,7 +1299,7 @@ (castleableRooksByLogicalColour, castleableRooksByLogicalColour') = ($ game) &&& ($ game') $ getCastleableRooksByLogicalColour in if isCastle || castleableRooksByLogicalColour /= castleableRooksByLogicalColour' then ( - State.CastleableRooksByLogicalColour.listIncrementalRandoms castleableRooksByLogicalColour castleableRooksByLogicalColour' zobrist ++ + State.CastleableRooksByLogicalColour.listIncrementalRandoms zobrist castleableRooksByLogicalColour castleableRooksByLogicalColour' ++ ) -- Section. else id ) $ [ @@ -1308,9 +1311,9 @@ State.Board.getMaybePieceByCoordinates $ getBoard g ) -- CAVEAT: accounts for any change to the En-passant option, rather than the act of taking En-passant. ) [game, game'], - random <- StateProperty.Hashable.listRandoms enPassantAbscissa zobrist + random <- StateProperty.Hashable.listRandoms zobrist enPassantAbscissa ] {-list-comprehension-} ++ Component.Zobrist.getRandomForBlacksMove zobrist : [ - Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (lastLogicalColour, rankAccessor turn, coordinatesAccessor move) zobrist | + Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (lastLogicalColour, rankAccessor turn, coordinatesAccessor move) | (rankAccessor, coordinatesAccessor) <- zip [Component.Turn.getRank, (`Data.Maybe.fromMaybe` Attribute.Rank.getMaybePromotionRank moveType) . Component.Turn.getRank] coordinatesAccessors ] {-list-comprehension-} where lastLogicalColour = getNextLogicalColour game @@ -1322,9 +1325,9 @@ coordinatesAccessors = [Component.Move.getSource, Component.Move.getDestination] randomsFromMoveType - | Just rank <- Attribute.MoveType.getMaybeExplicitlyTakenRank moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (nextLogicalColour, rank, destination) zobrist] -- Singleton. + | Just rank <- Attribute.MoveType.getMaybeExplicitlyTakenRank moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (nextLogicalColour, rank, destination)] -- Singleton. | isCastle = map ( - \coordinatesAccessor -> Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour ( + \coordinatesAccessor -> Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist ( lastLogicalColour, Attribute.Rank.Rook, Data.Maybe.maybe ( @@ -1334,9 +1337,9 @@ ) . Data.List.find ( (== move) . Component.CastlingMove.getKingsMove ) $ Component.CastlingMove.getCastlingMoves lastLogicalColour - ) zobrist + ) ) coordinatesAccessors - | Attribute.MoveType.isEnPassant moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (nextLogicalColour, Attribute.Rank.Pawn, Cartesian.Coordinates.advance nextLogicalColour destination) zobrist] -- Singleton. + | Attribute.MoveType.isEnPassant moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (nextLogicalColour, Attribute.Rank.Pawn, Cartesian.Coordinates.advance nextLogicalColour destination)] -- Singleton. | otherwise = [] where nextLogicalColour = getNextLogicalColour game' diff --git a/src-lib/BishBosh/Model/GameTree.hs b/src-lib/BishBosh/Model/GameTree.hs --- a/src-lib/BishBosh/Model/GameTree.hs +++ b/src-lib/BishBosh/Model/GameTree.hs @@ -30,7 +30,7 @@ module BishBosh.Model.GameTree( -- * Types -- ** Type-synonyms --- BareGameTree, + BareGameTree, MoveFrequency, -- Transformation, -- ** Data-types @@ -57,6 +57,7 @@ import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn @@ -113,7 +114,7 @@ getMaybeImplicitlyTakenRank :: Model.Game.Game -> Maybe Attribute.Rank.Rank getMaybeImplicitlyTakenRank game' = Attribute.MoveType.getMaybeImplicitlyTakenRank . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove =<< Model.Game.maybeLastTurn game' --- slave :: BareGameTree -> Attribute.Rank.Rank -> Type.Mass.RankValue + slave :: BareGameTree -> Attribute.Rank.Rank -> Type.Mass.RankValue slave node'@Data.Tree.Node { Data.Tree.subForest = forest' } = max 0 {-this player shouldn't progress the battle-} . subtract ( case filter ( ( @@ -148,7 +149,7 @@ def = fromGame Data.Default.def instance Property.Arboreal.Prunable GameTree where - prune depth MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Property.Arboreal.prune depth bareGameTree + prune depth MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Data.RoseTree.prune depth bareGameTree instance Notation.MoveNotation.ShowNotation GameTree where showsNotation moveNotation MkGameTree { @@ -185,11 +186,11 @@ * N.B.: some of the /game-state/s may have identical positions, reached by different sequences of /move/s. -} countGames :: Property.Arboreal.Depth -> Type.Count.NGames -countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree) +countGames depth = Data.RoseTree.countTerminalNodes . Data.RoseTree.prune depth . deconstruct $ (Data.Default.def :: GameTree) -- | Counts the number of possible positions in chess, down to the specified depth. N.B.: some of these may be transpositions. countPositions :: Property.Arboreal.Depth -> Type.Count.NPositions -countPositions depth = fromIntegral . pred {-the apex is constructed without moving-} . Data.Foldable.length . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree) +countPositions depth = fromIntegral . pred {-the apex is constructed without moving-} . Data.Foldable.length . Data.RoseTree.prune depth . deconstruct $ (Data.Default.def :: GameTree) -- | Trace the route down the tree which matches the specified list of turns. traceRoute @@ -241,6 +242,7 @@ -} toMoveFrequency :: GameTree -> MoveFrequency toMoveFrequency MkGameTree { deconstruct = bareGameTree } = slave maxBound {-logicalColour-} Property.Empty.empty {-MoveFrequency-} bareGameTree where + slave :: Colour.LogicalColour.LogicalColour -> MoveFrequency -> BareGameTree -> MoveFrequency slave _ moveFrequency Data.Tree.Node { Data.Tree.subForest = [] } = moveFrequency slave logicalColour moveFrequency Data.Tree.Node { Data.Tree.subForest = forest } = Data.List.foldl' ( slave {-recurse-} $ Property.Opposable.getOpposite logicalColour diff --git a/src-lib/BishBosh/Model/MoveFrequency.hs b/src-lib/BishBosh/Model/MoveFrequency.hs --- a/src-lib/BishBosh/Model/MoveFrequency.hs +++ b/src-lib/BishBosh/Model/MoveFrequency.hs @@ -43,15 +43,15 @@ import Control.Arrow((&&&)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Property.Empty as Property.Empty -import qualified BishBosh.Property.Null as Property.Null -import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.Type.Count as Type.Count import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import qualified Data.Ord {- | @@ -59,7 +59,7 @@ * CAVEAT: the /move-type/ isn't recorded. -} -type InstancesByMoveByRankByLogicalColour move = Attribute.LogicalColour.ArrayByLogicalColour ( +type InstancesByMoveByRankByLogicalColour move = Colour.LogicalColour.ArrayByLogicalColour ( Attribute.Rank.ArrayByRank ( Map.Map move Type.Count.NPlies ) @@ -71,7 +71,7 @@ } deriving Eq instance Property.Empty.Empty (MoveFrequency move) where - empty = MkMoveFrequency . Attribute.LogicalColour.listArrayByLogicalColour . repeat . Attribute.Rank.listArrayByRank $ repeat Property.Empty.empty + empty = MkMoveFrequency . Colour.LogicalColour.listArrayByLogicalColour . repeat . Attribute.Rank.listArrayByRank $ repeat Property.Empty.empty instance Property.Null.Null (MoveFrequency move) where isNull MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.all (Data.Foldable.all Data.Foldable.null) instancesByMoveByRankByLogicalColour @@ -104,10 +104,10 @@ -} insertMoves :: Ord move - => Attribute.LogicalColour.LogicalColour -- ^ References the player who is required to make any one of the specified moves. - -> GetRankAndMove a move -- ^ How to extract the required /rank/ & /move/ from a datum. + => Colour.LogicalColour.LogicalColour -- ^ References the player who is required to make any one of the specified moves. + -> GetRankAndMove a move -- ^ How to extract the required /rank/ & /move/ from a datum. -> MoveFrequency move - -> [a] -- ^ The data from each of which, /rank/ & /move/ can be extracted. + -> [a] -- ^ The data from each of which, /rank/ & /move/ can be extracted. -> MoveFrequency move insertMoves logicalColour getRankAndMove MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = MkMoveFrequency . ( instancesByMoveByRankByLogicalColour // @@ -139,10 +139,10 @@ -} sortByDescendingMoveFrequency :: Ord move - => Attribute.LogicalColour.LogicalColour -- ^ References the player who is required to make any one of the specified moves. - -> GetRankAndMove a move -- ^ How to extract the required /rank/ & /move/ from a datum. + => Colour.LogicalColour.LogicalColour -- ^ References the player who is required to make any one of the specified moves. + -> GetRankAndMove a move -- ^ How to extract the required /rank/ & /move/ from a datum. -> MoveFrequency move - -> [a] -- ^ The data from each of which, /rank/ & /move/ can be extracted. + -> [a] -- ^ The data from each of which, /rank/ & /move/ can be extracted. -> [a] {-# INLINE sortByDescendingMoveFrequency #-} sortByDescendingMoveFrequency logicalColour getRankAndMove MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.List.sortOn $ negate {-most frequent first-} . ( diff --git a/src-lib/BishBosh/Model/PositionHashTree.hs b/src-lib/BishBosh/Model/PositionHashTree.hs --- a/src-lib/BishBosh/Model/PositionHashTree.hs +++ b/src-lib/BishBosh/Model/PositionHashTree.hs @@ -71,7 +71,7 @@ => Component.Zobrist.Zobrist positionHash -> Model.GameTree.GameTree -> PositionHashTree positionHash -mkPositionHashTree zobrist = MkPositionHashTree . fmap (`StateProperty.Hashable.hash` zobrist) . Model.GameTree.deconstruct +mkPositionHashTree zobrist = MkPositionHashTree . fmap (StateProperty.Hashable.hash zobrist) . Model.GameTree.deconstruct -- | Count the number of distinct positions, irrespective of the sequence of moves taken to reach that terminal state. countDistinctPositions @@ -84,6 +84,7 @@ | depth < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Component.PositionHashTree.countDistinctPositions:\tdepth" . Text.ShowList.showsAssociation $ shows depth "must be positive" | otherwise = fromIntegral . Data.Set.size $ slave depth barePositionHashTree where + slave :: Ord positionHash => Property.Arboreal.Depth -> BarePositionHashTree positionHash -> Data.Set.Set positionHash slave 0 Data.Tree.Node { Data.Tree.rootLabel = hash } = Data.Set.singleton hash -- Having reached the maximum depth, include this game's hash. slave _ Data.Tree.Node { Data.Tree.rootLabel = hash, diff --git a/src-lib/BishBosh/Property/Arboreal.hs b/src-lib/BishBosh/Property/Arboreal.hs --- a/src-lib/BishBosh/Property/Arboreal.hs +++ b/src-lib/BishBosh/Property/Arboreal.hs @@ -31,23 +31,10 @@ Depth ) where -import qualified Data.Tree - -- | A distance down the tree. type Depth = Int -- | An interface which tree-like data can support. class Prunable tree where prune :: Depth -> tree -> tree -- ^ Remove branches after the specified depth. - -instance Prunable (Data.Tree.Tree a) where - prune depth tree@Data.Tree.Node { Data.Tree.subForest = forest } - | depth < 0 = error "BishBosh.Property.Arboreal.prune:\tdepth can't be negative." - | otherwise = tree { - Data.Tree.subForest = if depth == 0 - then [] - else map ( - prune $ pred depth -- Recurse. - ) forest - } diff --git a/src-lib/BishBosh/Property/Orientated.hs b/src-lib/BishBosh/Property/Orientated.hs --- a/src-lib/BishBosh/Property/Orientated.hs +++ b/src-lib/BishBosh/Property/Orientated.hs @@ -27,13 +27,33 @@ Orientated(..) ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) --- | An interface for vector-like data. +{- | + * An interface for vector-like data. + + * CAVEAT: the default implementations are mutually dependent, & could result in infinite recursion. +-} class Orientated a where - isDiagonal :: a -> Bool -- ^ Whether it is diagonal wrt the edges of the board. + isVertical :: a -> Bool -- ^ Whether the datum is aligned with a file of the board. + isVertical = uncurry (&&) . (isParallel &&& not . isHorizontal) -- Default implementation. + + isHorizontal :: a -> Bool -- ^ Whether the datum is aligned with a rank of the board. + isHorizontal = uncurry (&&) . (isParallel &&& not . isVertical) -- Default implementation. + isParallel :: a -> Bool -- ^ Whether it is parallel to an edge of the board. + isParallel = uncurry (||) . (isVertical &&& isHorizontal) -- Default implementation. + isDiagonal :: a -> Bool -- ^ Whether it is diagonal (45 degrees) wrt the edges of the board. + isDiagonal = uncurry (&&) . (isStraight &&& not . isParallel) -- Default implementation. + isStraight :: a -> Bool - isStraight = uncurry (||) . (isParallel &&& isDiagonal) -- Default implementation. + isStraight = uncurry (||) . (isParallel &&& isDiagonal) -- Default implementation. + +instance (Orientated l, Orientated r) => Orientated (Either l r) where + isVertical = isVertical ||| isVertical + isHorizontal = isHorizontal ||| isHorizontal + isDiagonal = isDiagonal ||| isDiagonal + isParallel = isParallel ||| isParallel + isStraight = isStraight ||| isStraight diff --git a/src-lib/BishBosh/Property/Rotatable.hs b/src-lib/BishBosh/Property/Rotatable.hs --- a/src-lib/BishBosh/Property/Rotatable.hs +++ b/src-lib/BishBosh/Property/Rotatable.hs @@ -37,9 +37,11 @@ -- | An interface which data which can be transformed by rotation, may implement. class (Property.Reflectable.ReflectableOnX a, Property.Reflectable.ReflectableOnY a) => Rotatable a where rotate90 :: a -> a -- ^ Rotate anticlockwise by 90 degrees, so that @N@ becomes @W@. + rotate90 = rotate270 . rotate180 rotate180 :: a -> a -- ^ Rotate by 180 degrees. - rotate180 = Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnY -- CAVEAT: perhaps not the most efficient implementation. + rotate180 = Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnY -- CAVEAT: perhaps not the most efficient implementation. rotate270 :: a -> a -- ^ Rotate clockwise by 90 degrees, so that @N@ becomes @E@. + rotate270 = rotate90 . rotate180 diff --git a/src-lib/BishBosh/Property/SelfValidating.hs b/src-lib/BishBosh/Property/SelfValidating.hs --- a/src-lib/BishBosh/Property/SelfValidating.hs +++ b/src-lib/BishBosh/Property/SelfValidating.hs @@ -32,6 +32,8 @@ isInvalid ) where +import Control.Arrow((***)) + {- | * This class serves data-types which must preserve compatibility beyond that which can be guarded by a smart-constructor. @@ -42,6 +44,9 @@ instance SelfValidating a => SelfValidating [a] where findInvalidity = concatMap findInvalidity + +instance (SelfValidating a, SelfValidating b) => SelfValidating (a, b) where + findInvalidity = uncurry (++) . (findInvalidity *** findInvalidity) -- | Predicate. isValid :: SelfValidating a => a -> Bool diff --git a/src-lib/BishBosh/Rule/GameTerminationReason.hs b/src-lib/BishBosh/Rule/GameTerminationReason.hs --- a/src-lib/BishBosh/Rule/GameTerminationReason.hs +++ b/src-lib/BishBosh/Rule/GameTerminationReason.hs @@ -46,7 +46,7 @@ isStaleMate ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Rule.DrawReason as Rule.DrawReason @@ -55,8 +55,8 @@ -- | The sum-type of ways in which a game can legally be terminated. data GameTerminationReason - = CheckMateOf Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /check-mated/ player. - | ResignationBy Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player who resigned. + = CheckMateOf Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /check-mated/ player. + | ResignationBy Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player who resigned. | Draw Rule.DrawReason.DrawReason deriving (Eq, Ord, Read, Show) @@ -81,11 +81,11 @@ Draw _ -> Nothing -- | Constructor. -mkCheckMate :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason +mkCheckMate :: Colour.LogicalColour.LogicalColour -> GameTerminationReason mkCheckMate = CheckMateOf -- | Constructor. -mkResignation :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason +mkResignation :: Colour.LogicalColour.LogicalColour -> GameTerminationReason mkResignation = ResignationBy -- | Constructor. @@ -93,7 +93,7 @@ mkDraw = Draw -- | Whether the game was won by the specified player. -isCheckMateBy :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason -> Bool +isCheckMateBy :: Colour.LogicalColour.LogicalColour -> GameTerminationReason -> Bool isCheckMateBy logicalColour (CheckMateOf logicalColour') = logicalColour /= logicalColour' isCheckMateBy _ _ = False diff --git a/src-lib/BishBosh/Rule/Result.hs b/src-lib/BishBosh/Rule/Result.hs --- a/src-lib/BishBosh/Rule/Result.hs +++ b/src-lib/BishBosh/Rule/Result.hs @@ -38,7 +38,7 @@ isDraw ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Opposable as Property.Opposable import qualified Control.DeepSeq @@ -46,7 +46,7 @@ -- | The sum-type of ways in which a game can legally be terminated. data Result - = VictoryBy Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the victor. + = VictoryBy Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the victor. | Draw deriving Eq @@ -59,7 +59,7 @@ showsPrec _ = ( \(showsWhiteResult, showsBlackResult) -> showsWhiteResult . showChar '-' . showsBlackResult ) . \case - VictoryBy Attribute.LogicalColour.Black -> (lose, win) + VictoryBy Colour.LogicalColour.Black -> (lose, win) VictoryBy _ -> (win, lose) _ -> (draw, draw) where @@ -69,8 +69,8 @@ instance Read Result where readsPrec _ s = case Data.List.Extra.trimStart s of - '0' : '-' : '1' : remainder -> [(VictoryBy Attribute.LogicalColour.Black, remainder)] - '1' : '-' : '0' : remainder -> [(VictoryBy Attribute.LogicalColour.White, remainder)] + '0' : '-' : '1' : remainder -> [(VictoryBy Colour.LogicalColour.Black, remainder)] + '1' : '-' : '0' : remainder -> [(VictoryBy Colour.LogicalColour.White, remainder)] '1' : '/' : '2' : '-' : '1' : '/' : '2' : remainder -> [(Draw, remainder)] _ -> [] -- No Parse. @@ -82,7 +82,7 @@ members = Draw : map VictoryBy Property.FixedMembership.members -- | Constructor. -mkResult :: Maybe Attribute.LogicalColour.LogicalColour -> Result +mkResult :: Maybe Colour.LogicalColour.LogicalColour -> Result mkResult (Just logicalColour) = VictoryBy logicalColour mkResult _ = Draw @@ -92,7 +92,7 @@ isDraw _ = False -- | Find any winner. -findMaybeVictor :: Result -> Maybe Attribute.LogicalColour.LogicalColour +findMaybeVictor :: Result -> Maybe Colour.LogicalColour.LogicalColour findMaybeVictor (VictoryBy logicalColour) = Just logicalColour findMaybeVictor _ = Nothing diff --git a/src-lib/BishBosh/Search/AlphaBeta.hs b/src-lib/BishBosh/Search/AlphaBeta.hs --- a/src-lib/BishBosh/Search/AlphaBeta.hs +++ b/src-lib/BishBosh/Search/AlphaBeta.hs @@ -44,7 +44,7 @@ -- addNPositionsToResult ) where -import BishBosh.Model.Game((=~)) +import BishBosh.Evaluation.QuantifiedGame((<=>), (===)) import Control.Applicative((<|>)) import Control.Arrow((&&&)) import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -73,7 +73,7 @@ -- | The type returned by 'negaMax'. data Result positionHash = MkResult { - getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData positionHash, -- ^ Killer moves & transpositions. + getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData positionHash, -- ^ Killer moves & Transpositions. getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame, getNPositionsEvaluated :: Type.Count.NPositions -- ^ The total number of nodes analysed, before making the selection. } @@ -117,7 +117,7 @@ -> Search.TranspositionValue.TranspositionValue Component.QualifiedMove.QualifiedMove -> Evaluation.QuantifiedGame.QuantifiedGame findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree transpositionValue = Data.Maybe.maybe ( - Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.AlphaBeta.findTranspositionTerminalQuantifiedGame:\tEvaluation.PositionHashQuantifiedGameTree.traceMatchingMoves failed; " . shows transpositionValue . showString ":\n" $ ( + Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.AlphaBeta.findTranspositionTerminalQuantifiedGame:\tEvaluation.PositionHashQuantifiedGameTree.traceMatchingMoveSequence failed; " . shows transpositionValue . showString ":\n" $ ( Notation.MoveNotation.showsNotationFloatToNDecimals Data.Default.def {-move-notation-} 3 {-decimal digits-} $ Property.Arboreal.prune (fromIntegral inferredSearchDepth) positionHashQuantifiedGameTree ) "" ) ( @@ -126,7 +126,7 @@ then Evaluation.QuantifiedGame.negateFitness -- The opponent made the last move in the list, & therefore defined the fitness. else id ) . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame . last - ) . Evaluation.PositionHashQuantifiedGameTree.traceMatchingMoves positionHashQuantifiedGameTree $ Search.TranspositionValue.getQualifiedMoves transpositionValue where + ) . Evaluation.PositionHashQuantifiedGameTree.traceMatchingMoveSequence positionHashQuantifiedGameTree $ Search.TranspositionValue.getQualifiedMoves transpositionValue where inferredSearchDepth = Search.TranspositionValue.inferSearchDepth transpositionValue -- | Record a qualifiedMove-sequence in the transposition-table. @@ -147,7 +147,7 @@ * /alpha/ is the minimum fitness of which the maximising player is assured. - * /beta/ is the maximum fitness of which the minimising player is assured. + * /beta/ is the maximum fitness which the minimising player will tolerate. -} negaMax :: Ord positionHash @@ -162,13 +162,8 @@ let getNPlies = State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour -- Abbreviate. -{- - descend - :: Evaluation.QuantifiedGame.OpenInterval - -> Type.Count.NPlies - -> Search.SearchState.SearchState positionHash - -> Result positionHash --} + + descend :: Ord positionHash => Evaluation.QuantifiedGame.OpenInterval -> Type.Count.NPlies -> Search.SearchState.SearchState positionHash -> Result positionHash descend (maybeAlphaQuantifiedGame, maybeBetaQuantifiedGame) searchDepth searchState | searchDepth == 0 || Model.Game.isTerminated game = MkResult { getDynamicMoveData = dynamicMoveData, @@ -178,9 +173,10 @@ | useTranspositions , Just transpositionValue <- Search.Transpositions.find positionHash $ Search.DynamicMoveData.getTranspositions dynamicMoveData -- Look for a previously encountered position with a matching positionHash. , let +-- selectMaxUsingTranspositions :: Result positionHash selectMaxUsingTranspositions = selectMaxWithSorter $ Data.Maybe.fromMaybe ( - Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.AlphaBeta.negaMax.descend:\tEvaluation.PositionHashQuantifiedGameTree.promoteMatchingMoves failed; " $ shows transpositionValue "." -- N.B.: perhaps because of hash-collision. - ) . Evaluation.PositionHashQuantifiedGameTree.promoteMatchingMoves ( + Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.AlphaBeta.negaMax.descend:\tEvaluation.PositionHashQuantifiedGameTree.promoteMatchingMoveSequence failed; " $ shows transpositionValue "." -- N.B.: perhaps because of hash-collision. + ) . Evaluation.PositionHashQuantifiedGameTree.promoteMatchingMoveSequence ( Search.TranspositionValue.getQualifiedMoves transpositionValue ) -- For efficiency, promote moves in the positionHashQuantifiedGameTree, using the knowledge in the transposition. = if Search.TranspositionValue.inferSearchDepth transpositionValue < searchDepth @@ -194,13 +190,13 @@ getNPositionsEvaluated = 0 } else Data.Maybe.maybe selectMaxUsingTranspositions ( - \betaQuantifiedGame -> if Evaluation.QuantifiedGame.compareFitness transposedQuantifiedGame betaQuantifiedGame == LT + \betaQuantifiedGame -> if uncurry (<) $ (($ transposedQuantifiedGame) &&& ($ betaQuantifiedGame)) Evaluation.QuantifiedGame.getFitness then selectMaxUsingTranspositions else MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = Control.Exception.assert (betaQuantifiedGame == getQuantifiedGame selectMaxUsingTranspositions) betaQuantifiedGame, getNPositionsEvaluated = 0 - } + } -- Beta-cutoff. ) maybeBetaQuantifiedGame | otherwise = selectMaxWithSorter id where @@ -211,6 +207,7 @@ game = Evaluation.QuantifiedGame.getGame quantifiedGame -- Prior to application of any move from the forest. (nPlies, nDistinctPositions) = getNPlies &&& State.InstancesByPosition.getNDistinctPositions . Model.Game.getInstancesByPosition $ game -- Count the distinct positions since the last irreversible move. +-- selectMaxWithSorter :: (Evaluation.PositionHashQuantifiedGameTree.Forest positionHash -> Evaluation.PositionHashQuantifiedGameTree.Forest positionHash) -> Result positionHash selectMaxWithSorter forestSorter = selectMax dynamicMoveData maybeAlphaQuantifiedGame . forestSorter . ( if recordKillerMoves then Evaluation.PositionHashQuantifiedGameTree.sortNonCaptureMoves ( @@ -222,47 +219,35 @@ ) -- Dynamically advance the evaluation of killer-moves, to just after the statically sorted capture-moves. else id ) . Data.Tree.subForest $ Evaluation.PositionHashQuantifiedGameTree.deconstruct positionHashQuantifiedGameTree -{- - selectMax - :: Search.DynamicMoveData.DynamicMoveData positionHash - -> Maybe Evaluation.QuantifiedGame.QuantifiedGame - -> [Evaluation.PositionHashQuantifiedGameTree.BarePositionHashQuantifiedGameTree positionHash] - -> Result positionHash --} + +-- selectMax :: Search.DynamicMoveData.DynamicMoveData positionHash -> Maybe Evaluation.QuantifiedGame.QuantifiedGame -> Evaluation.PositionHashQuantifiedGameTree.Forest positionHash -> Result positionHash selectMax dynamicMoveData' maybeAlphaQuantifiedGame' (node : remainingNodes) | trapRepeatedPositions - , nDistinctPositions >= fromIntegral State.InstancesByPosition.leastCyclicPlies -- CAVEAT: accounting for the typically (except when its the initial position) unrepeatable first distinct position. + , nDistinctPositions >= fromIntegral State.InstancesByPosition.leastCyclicPlies -- CAVEAT: accounting for the typically (except the initial position) unrepeatable first distinct position. , State.InstancesByPosition.getNDistinctPositions ( Model.Game.getInstancesByPosition . Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame' node -- If the size hasn't increased, then the recently added position must have already been a member; (size == 1) during successive unrepeatable moves also, but that exception is caught above. - ) == nDistinctPositions = selectMax dynamicMoveData' ( + ) == nDistinctPositions = selectMax dynamicMoveData' ( maybeAlphaQuantifiedGame' <|> Just quantifiedGame'' -- CAVEAT: guard against exhausting all nodes without defining alpha. - ) remainingNodes -- Skip this node & recurse through the remaining moves at this depth. + ) remainingNodes -- Skip this repetitive node & recurse through the remaining nodes at this depth. | Just betaQuantifiedGame <- maybeBetaQuantifiedGame -- Beta-cutoff can't occur until beta has been defined. - , let fitnessComparedWithBeta = Evaluation.QuantifiedGame.compareFitness quantifiedGame'' betaQuantifiedGame + , let fitnessComparedWithBeta = quantifiedGame'' <=> betaQuantifiedGame , fitnessComparedWithBeta /= LT = result'' { - getDynamicMoveData = let - game'' = Evaluation.QuantifiedGame.getGame quantifiedGame'' - in ( + getDynamicMoveData = ( if recordKillerMoves && not ( - fitnessComparedWithBeta == EQ && game'' =~ Evaluation.QuantifiedGame.getGame betaQuantifiedGame -- CAVEAT: betaQuantifiedGame was copied in selectMaxWithSorters terminal case, from one of the open-interval's boundaries. + fitnessComparedWithBeta == EQ && quantifiedGame'' === betaQuantifiedGame -- betaQuantifiedGame was copied in the terminal case of 'selectMax', from one of the open-interval's boundaries. ) -- Confirm that betaQuantifiedGame is beneath the current node. - then updateKillerMoves game'' + then updateKillerMoves $ Evaluation.QuantifiedGame.getGame quantifiedGame'' else id ) dynamicMoveData'', getQuantifiedGame = betaQuantifiedGame } -- Beta-cutoff; the solution-space is either zero or negative. - | otherwise = addNPositionsToResult ( - getNPositionsEvaluated result'' - ) $ let + | otherwise = let isFitter = Data.Maybe.maybe True {-alpha is undefined => anything qualifies-} ( - \alphaQuantifiedGame -> case quantifiedGame'' `Evaluation.QuantifiedGame.compareFitness` alphaQuantifiedGame of - LT -> False - GT -> True - EQ -> uncurry (<) . ( - ($ quantifiedGame'') &&& ($ alphaQuantifiedGame) - ) $ getNPlies . Evaluation.QuantifiedGame.getGame -- Prefer a shorter move-sequence. + \alphaQuantifiedGame -> uncurry (>) $ (($ quantifiedGame'') &&& ($ alphaQuantifiedGame)) Evaluation.QuantifiedGame.getFitness ) maybeAlphaQuantifiedGame' - in selectMax ( + in addNPositionsToResult ( + getNPositionsEvaluated result'' + ) $ selectMax ( ( if useTranspositions && isFitter then updateTranspositions False {-isOptimal-} nPlies positionHash {-the hash of the game before the first move in the sequence-} ( @@ -272,7 +257,7 @@ ) dynamicMoveData'' ) ( if isFitter - then Just quantifiedGame'' -- Replace the alpha solution (i.e. the lower acceptable solution-bound). + then Just quantifiedGame'' -- Increase the alpha solution (i.e. the lower acceptable solution-bound). else maybeAlphaQuantifiedGame' ) remainingNodes -- Recurse through the remaining moves at this depth. where diff --git a/src-lib/BishBosh/Search/KillerMoves.hs b/src-lib/BishBosh/Search/KillerMoves.hs --- a/src-lib/BishBosh/Search/KillerMoves.hs +++ b/src-lib/BishBosh/Search/KillerMoves.hs @@ -37,15 +37,15 @@ import Control.Arrow((&&&)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Property.Empty as Property.Empty -import qualified BishBosh.Search.EphemeralData as Search.EphemeralData -import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Search.EphemeralData as Search.EphemeralData +import qualified BishBosh.Type.Count as Type.Count import qualified Data.Array.IArray import qualified Data.Foldable -import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntMap.Strict as IntMap import qualified Data.List -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Data.Maybe {- | @@ -54,7 +54,7 @@ a key containing the killer-move, & the logical colour of the player making the move. -} -type NInstancesByNPliesByKeyByLogicalColour killerMoveKey = Attribute.LogicalColour.ArrayByLogicalColour ( +type NInstancesByNPliesByKeyByLogicalColour killerMoveKey = Colour.LogicalColour.ArrayByLogicalColour ( Map.Map killerMoveKey ( IntMap.IntMap Type.Count.NPlies {-NInstances-} -- CAVEAT: 'Int' is used to represent the number of plies into the game (in order to utilise 'IntMap') though it ought to be NPlies also. ) @@ -66,7 +66,7 @@ } instance Property.Empty.Empty (KillerMoves killerMoveKey) where - empty = MkKillerMoves . Attribute.LogicalColour.listArrayByLogicalColour $ repeat Property.Empty.empty + empty = MkKillerMoves . Colour.LogicalColour.listArrayByLogicalColour $ repeat Property.Empty.empty instance Search.EphemeralData.EphemeralData (KillerMoves killerMoveKey) where getSize MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = fromIntegral $ Data.Foldable.foldl' ( @@ -100,14 +100,14 @@ ) . ( nInstancesByNPliesByKeyByLogicalColour ! ) $ if even nPlies - then Attribute.LogicalColour.Black - else Attribute.LogicalColour.White -- White makes the first move. + then Colour.LogicalColour.Black + else Colour.LogicalColour.White -- White makes the first move. ] -- Singleton. -- | Sorts an arbitrary list using the History-heuristic; . sortByHistoryHeuristic :: Ord killerMoveKey - => Attribute.LogicalColour.LogicalColour + => Colour.LogicalColour.LogicalColour -> (a -> killerMoveKey) -- ^ Key-constructor. -> KillerMoves killerMoveKey -> [a] diff --git a/src-lib/BishBosh/State/Board.hs b/src-lib/BishBosh/State/Board.hs --- a/src-lib/BishBosh/State/Board.hs +++ b/src-lib/BishBosh/State/Board.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -67,29 +67,31 @@ import Control.Arrow((&&&), (***), (|||)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Direction.Direction as Direction.Direction import qualified BishBosh.Property.Empty as Property.Empty 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.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.StateProperty.View as StateProperty.View import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow @@ -101,17 +103,12 @@ import qualified Data.List import qualified Data.Map.Strict as Map import qualified Data.Maybe -import qualified ToolShed.Data.List -#ifdef USE_UNBOXED_ARRAYS -import qualified Data.Array.Unboxed -#endif - -- | The type of a function which transforms a /board/. type Transformation = Board -> Board -- | The number of defenders for each /piece/, belonging to each side. -type NDefendersByCoordinatesByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour (Map.Map Cartesian.Coordinates.Coordinates Type.Count.NPieces) +type NDefendersByCoordinatesByLogicalColour = Colour.LogicalColour.ArrayByLogicalColour (Map.Map Cartesian.Coordinates.Coordinates Type.Count.NPieces) {- | * The board is modelled as two alternative structures representing the same data, but indexed by either /coordinates/ or /piece/. @@ -180,22 +177,39 @@ reflectOnY MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ Property.Reflectable.reflectOnY maybePieceByCoordinates instance StateProperty.Hashable.Hashable Board where - listRandoms MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Hashable.listRandoms coordinatesByRankByLogicalColour + listRandoms zobrist MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Hashable.listRandoms zobrist coordinatesByRankByLogicalColour -- Forward. instance StateProperty.Mutator.Mutator Board where - defineCoordinates maybePiece coordinates MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ StateProperty.Mutator.defineCoordinates maybePiece coordinates maybePieceByCoordinates + defineCoordinates maybePiece coordinates MkBoard { + getMaybePieceByCoordinates = maybePieceByCoordinates + } = fromMaybePieceByCoordinates $ StateProperty.Mutator.defineCoordinates maybePiece coordinates maybePieceByCoordinates + movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkBoard { + getMaybePieceByCoordinates = maybePieceByCoordinates + } = fromMaybePieceByCoordinates $ StateProperty.Mutator.movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank maybePieceByCoordinates + instance StateProperty.Seeker.Seeker Board where - findProximateKnights logicalColour coordinates MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.findProximateKnights logicalColour coordinates coordinatesByRankByLogicalColour -- Forward the request. - findPieces predicate MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.findPieces predicate coordinatesByRankByLogicalColour -- Forward the request. - countPawnsByFileByLogicalColour MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour -- Forward the request. + findProximateKnights MkBoard { + getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour + } = StateProperty.Seeker.findProximateKnights coordinatesByRankByLogicalColour -- Forward the request. + findPieces predicate MkBoard { + getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour + } = StateProperty.Seeker.findPieces predicate coordinatesByRankByLogicalColour -- Forward the request. + + countPawnsByFileByLogicalColour MkBoard { + getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour + } = StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour -- Forward the request. + +instance Property.SelfValidating.SelfValidating Board where + findInvalidity = Property.SelfValidating.findInvalidity . (getMaybePieceByCoordinates &&& getCoordinatesByRankByLogicalColour) + -- | Constructor. fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates -> Board fromMaybePieceByCoordinates maybePieceByCoordinates = board where board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates, - getCoordinatesByRankByLogicalColour = State.CoordinatesByRankByLogicalColour.fromMaybePieceByCoordinates maybePieceByCoordinates, -- Infer. + getCoordinatesByRankByLogicalColour = StateProperty.View.translate maybePieceByCoordinates, -- Infer. getNDefendersByCoordinatesByLogicalColour = countDefendersByCoordinatesByLogicalColour board, -- Infer. getNPiecesDifferenceByRank = StateProperty.Censor.countPieceDifferenceByRank coordinatesByRankByLogicalColour, -- Infer. getNPawnsByFileByLogicalColour = StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour, -- Infer. @@ -221,60 +235,58 @@ getNPiecesDifferenceByRank = nPiecesDifferenceByRank, getNPieces = nPieces } - | Just sourcePiece <- State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates = let + | Just sourcePiece <- State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source = let oppositePiece = Property.Opposable.getOpposite sourcePiece - (logicalColour, opponentsLogicalColour) = ($ sourcePiece) &&& ($ oppositePiece) $ Component.Piece.getLogicalColour + (logicalColour, opponentsLogicalColour) = ($! sourcePiece) &&& ($! oppositePiece) $ Component.Piece.getLogicalColour moveType :: Attribute.MoveType.MoveType moveType -- CAVEAT: one can't call 'State.MaybePieceByCoordinates.inferMoveType', since that performs some move-validation, & therefore exceeds the remit of this module. | Just explicitMoveType <- maybeMoveType = explicitMoveType - | State.MaybePieceByCoordinates.isEnPassantMove move maybePieceByCoordinates = Attribute.MoveType.enPassant -- N.B.: if this move is valid, then one's opponent must have just double-advanced an adjacent Pawn. + | State.MaybePieceByCoordinates.isEnPassantMove maybePieceByCoordinates move = Attribute.MoveType.enPassant -- N.B.: if this move is valid, then one's opponent must have just double-advanced an adjacent Pawn. | otherwise = Attribute.MoveType.mkNormalMoveType ( - Component.Piece.getRank <$> State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates - ) $ if Component.Piece.isPawnPromotion destination sourcePiece + Component.Piece.getRank <$> State.MaybePieceByCoordinates.dereference maybePieceByCoordinates destination + ) $ if Component.Piece.isPawnPromotion sourcePiece destination then Just Attribute.Rank.defaultPromotionRank else Nothing -- Derive the required values from moveType. - (maybePromotionRank, maybeExplicitlyTakenRank) = Attribute.Rank.getMaybePromotionRank &&& Attribute.MoveType.getMaybeExplicitlyTakenRank $ moveType -- Deconstruct. + (maybePromotionRank, maybeExplicitlyTakenRank) = Attribute.Rank.getMaybePromotionRank &&& Attribute.MoveType.getMaybeExplicitlyTakenRank $! moveType -- Deconstruct. destinationPiece = Data.Maybe.maybe id Component.Piece.promote maybePromotionRank sourcePiece wasPawnTakenExplicitly = maybeExplicitlyTakenRank == Just Attribute.Rank.Pawn + eitherPassingPawnsDestinationOrMaybeTakenRank :: Either Cartesian.Coordinates.Coordinates (Maybe Attribute.Rank.Rank) eitherPassingPawnsDestinationOrMaybeTakenRank | Attribute.MoveType.isEnPassant moveType = Left $ Cartesian.Coordinates.retreat logicalColour destination | otherwise = Right maybeExplicitlyTakenRank + eitherPassingPawnsDestinationOrMaybeTakenPiece :: Either Cartesian.Coordinates.Coordinates (Maybe Component.Piece.Piece) eitherPassingPawnsDestinationOrMaybeTakenPiece = fmap (Component.Piece.mkPiece opponentsLogicalColour) <$> eitherPassingPawnsDestinationOrMaybeTakenRank + movePiece' :: StateProperty.Mutator.Mutator mutator => mutator -> mutator + movePiece' = StateProperty.Mutator.movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank + board'@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates' } = MkBoard { - getMaybePieceByCoordinates = State.MaybePieceByCoordinates.movePiece move destinationPiece ( - Just ||| const Nothing $ eitherPassingPawnsDestinationOrMaybeTakenRank - ) maybePieceByCoordinates, - getCoordinatesByRankByLogicalColour = State.CoordinatesByRankByLogicalColour.movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank coordinatesByRankByLogicalColour, + getMaybePieceByCoordinates = movePiece' maybePieceByCoordinates, + getCoordinatesByRankByLogicalColour = movePiece' coordinatesByRankByLogicalColour, getNDefendersByCoordinatesByLogicalColour = ( - \(nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates) -> Attribute.LogicalColour.listArrayByLogicalColour [nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates] + \(nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates) -> Colour.LogicalColour.listArrayByLogicalColour [nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates] ) . foldr ( \(affectedCoordinates, affectedPiece) -> if Component.Piece.isKing affectedPiece then id -- N.B.: defence of the King is irrelevant, since one can't get to a position where it can be taken. else let logicalColour' = Component.Piece.getLogicalColour affectedPiece in ( - if Attribute.LogicalColour.isBlack logicalColour' + if Colour.LogicalColour.isBlack logicalColour' then Control.Arrow.first else Control.Arrow.second - ) . Map.insert affectedCoordinates {-overwrite-} . fromIntegral . length $ findAttackersOf ( + ) . Map.insert affectedCoordinates {-overwrite-} . fromIntegral . length $! findAttackersOf board' ( Property.Opposable.getOpposite logicalColour' -- Investigate an attack on the affected coordinates by the affected piece's own logical colour, i.e. defence. - ) affectedCoordinates board' + ) affectedCoordinates ) ( - (! Attribute.LogicalColour.Black) &&& (! Attribute.LogicalColour.White) $ nDefendersByCoordinatesByLogicalColour // ( + (! Colour.LogicalColour.Black) &&& (! Colour.LogicalColour.White) $ nDefendersByCoordinatesByLogicalColour // ( let nDefendersByCoordinates = nDefendersByCoordinatesByLogicalColour ! opponentsLogicalColour - in ( - \passingPawnsDestination -> (:) ( - opponentsLogicalColour, - Map.delete passingPawnsDestination nDefendersByCoordinates -- This Pawn has been taken. - ) - ) ||| ( + in (:) . (,) opponentsLogicalColour . (`Map.delete` nDefendersByCoordinates) {-Pawn has been taken-} ||| ( \maybeExplicitlyTakenRank' -> if Data.Maybe.isJust maybeExplicitlyTakenRank' then (:) ( opponentsLogicalColour, @@ -283,50 +295,47 @@ else id ) $ eitherPassingPawnsDestinationOrMaybeTakenRank ) [ - ( - logicalColour, - Map.delete source $ nDefendersByCoordinatesByLogicalColour ! logicalColour -- This piece has been moved. - ) -- Pair. + id &&& Map.delete source . (nDefendersByCoordinatesByLogicalColour !) $ logicalColour -- This piece has been moved. ] -- Singleton. ) . Data.List.nubBy ( - ToolShed.Data.List.equalityBy fst {-coordinates-} + \l r -> fst l == fst r -- Compare coordinates. ) $ [ (affectedCoordinates, affectedPiece) | (knightsCoordinates, knight) <- (source, sourcePiece) : (,) destination `map` (destinationPiece : (const [] ||| Data.Maybe.maybeToList) eitherPassingPawnsDestinationOrMaybeTakenPiece), Component.Piece.isKnight knight, - Just affectedCoordinates <- Cartesian.Vector.maybeTranslate knightsCoordinates `map` Cartesian.Vector.attackVectorsForKnight, - affectedPiece <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.dereference affectedCoordinates maybePieceByCoordinates', + affectedCoordinates <- Data.Maybe.mapMaybe (`Cartesian.Vector.maybeTranslate` knightsCoordinates) Cartesian.Vector.attackVectorsForKnight, + affectedPiece <- Data.Maybe.maybeToList $! State.MaybePieceByCoordinates.dereference maybePieceByCoordinates' affectedCoordinates, Component.Piece.isFriend knight affectedPiece ] {-list-comprehension-} ++ [ (blockingCoordinates, blockingPiece) | passingPawnsDestination <- return {-to List-monad-} ||| const [] $ eitherPassingPawnsDestinationOrMaybeTakenRank, - (direction, antiParallelDirection) <- Attribute.Direction.opposites, - (blockingCoordinates, blockingPiece) <- case ($ direction) &&& ($ antiParallelDirection) $ ($ maybePieceByCoordinates') . (`State.MaybePieceByCoordinates.findBlockingPiece` passingPawnsDestination) of - (Just cp, Just cp') -> [ - cp | - let isDefendedBy from = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp), - isDefendedBy passingPawnsDestination oppositePiece || uncurry isDefendedBy cp' + (direction, antiParallelDirection) <- Direction.Direction.opposites, + (blockingCoordinates, blockingPiece) <- case State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' passingPawnsDestination $ Just [direction, antiParallelDirection] of + [cp, cp'] -> [ + cp | uncurry (||) . ( + ($ (passingPawnsDestination, oppositePiece)) &&& ($ cp') + ) $ \(from, piece) -> uncurry (&&) $ uncurry (&&&) ( + Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp + ) piece ] {-list-comprehension-} ++ [ - cp' | - let isDefendedBy from = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp'), - isDefendedBy passingPawnsDestination oppositePiece || uncurry isDefendedBy cp - ] -- List-comprehension. - (Just cp, _) -> [ - cp | - uncurry (&&) $ uncurry (&&&) (Component.Piece.canAttackAlong passingPawnsDestination *** Component.Piece.isFriend $ cp) oppositePiece - ] -- List-comprehension. - (_, Just cp') -> [ - cp' | - uncurry (&&) $ uncurry (&&&) (Component.Piece.canAttackAlong passingPawnsDestination *** Component.Piece.isFriend $ cp') oppositePiece + cp' | uncurry (||) . ( + ($ (passingPawnsDestination, oppositePiece)) &&& ($ cp) + ) $ \(from, piece) -> uncurry (&&) $ uncurry (&&&) ( + Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp' + ) piece ] -- List-comprehension. - _ -> [] + locatedPieces -> filter ( + \locatedPiece -> uncurry (&&) $ uncurry (&&&) ( + Component.Piece.canAttackAlong passingPawnsDestination *** Component.Piece.isFriend $ locatedPiece + ) oppositePiece + ) locatedPieces ] {-list-comprehension-} ++ (destination, destinationPiece) : [ (blockingCoordinates, blockingPiece) | let maybeExplicitlyTakenPiece = const Nothing ||| id $ eitherPassingPawnsDestinationOrMaybeTakenPiece, - (direction, antiParallelDirection) <- Attribute.Direction.opposites, + (direction, antiParallelDirection) <- Direction.Direction.opposites, (coordinates, piece) <- [(source, sourcePiece), (destination, destinationPiece)], - (blockingCoordinates, blockingPiece) <- case ($ direction) &&& ($ antiParallelDirection) $ ($ maybePieceByCoordinates') . (`State.MaybePieceByCoordinates.findBlockingPiece` coordinates) of - (Just cp, Just cp') -> [ + (blockingCoordinates, blockingPiece) <- case State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' coordinates $ Just [direction, antiParallelDirection] of + [cp, cp'] -> [ cp | let isDefendedBy from = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp), isDefendedBy coordinates piece || coordinates == destination && Data.Maybe.maybe False (isDefendedBy destination) maybeExplicitlyTakenPiece || uncurry isDefendedBy cp' @@ -335,20 +344,14 @@ let isDefendedBy from = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong from *** Component.Piece.isFriend $ cp'), isDefendedBy coordinates piece || coordinates == destination && Data.Maybe.maybe False (isDefendedBy destination) maybeExplicitlyTakenPiece || uncurry isDefendedBy cp ] -- List-comprehension. - (Just cp, _) -> [ - cp | - let isDefendedBy = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong coordinates *** Component.Piece.isFriend $ cp), - isDefendedBy piece || coordinates == destination && Data.Maybe.maybe False isDefendedBy maybeExplicitlyTakenPiece - ] -- List-comprehension. - (_, Just cp') -> [ - cp' | - let isDefendedBy = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong coordinates *** Component.Piece.isFriend $ cp'), - isDefendedBy piece || coordinates == destination && Data.Maybe.maybe False isDefendedBy maybeExplicitlyTakenPiece - ] -- List-comprehension. - _ -> [] + locatedPieces -> filter ( + \locatedPiece -> let + isDefendedBy = uncurry (&&) . uncurry (&&&) (Component.Piece.canAttackAlong coordinates *** Component.Piece.isFriend $ locatedPiece) + in isDefendedBy piece || coordinates == destination && Data.Maybe.maybe False isDefendedBy maybeExplicitlyTakenPiece + ) locatedPieces ], -- List-comprehension. Define any pieces whose defence may be affected by the move. getNPiecesDifferenceByRank = Data.Array.IArray.accum ( - if Attribute.LogicalColour.isBlack logicalColour + if Colour.LogicalColour.isBlack logicalColour then (-) -- Since White pieces are arbitrarily counted as positive, negate the adjustment if the current player is Black. else (+) ) nPiecesDifferenceByRank $ if Attribute.MoveType.isEnPassant moveType @@ -379,39 +382,23 @@ in board' | otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.State.Board.movePiece:\tno piece exists at " . shows source . showString "; " $ shows board "." where - (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. + (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $! move -- Deconstruct. -- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side, at a stage in the game's life-span defined by the total number of pieces remaining. -sumPieceSquareValueByLogicalColour :: ( -#ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). -#endif - Num pieceSquareValue - ) - => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue - -> Board - -> -#ifdef USE_UNBOXED_ARRAYS - Attribute.LogicalColour.UArrayByLogicalColour -#else - Attribute.LogicalColour.ArrayByLogicalColour -#endif - pieceSquareValue -{-# SPECIALISE sumPieceSquareValueByLogicalColour - :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue +sumPieceSquareValueByLogicalColour + :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank -> Board -> -#ifdef USE_UNBOXED_ARRAYS - Attribute.LogicalColour.UArrayByLogicalColour +#if defined(USE_UNBOXED_ARRAYS) && !defined(USE_PRECISION) + Colour.LogicalColour.UArrayByLogicalColour #else - Attribute.LogicalColour.ArrayByLogicalColour + Colour.LogicalColour.ArrayByLogicalColour #endif - Type.Mass.PieceSquareValue - #-} + Type.Mass.Base -- ^ Sum of PieceSquareValues. sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, getNPieces = nPieces -} = Attribute.LogicalColour.listArrayByLogicalColour $ Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces coordinatesByRankByLogicalColour +} = Colour.LogicalColour.listArrayByLogicalColour $ Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank coordinatesByRankByLogicalColour nPieces {- | * Lists the source-/coordinates/ from which the referenced destination can be attacked. @@ -425,16 +412,14 @@ * CAVEAT: can't detect an en-passant attack, since this depends both on whether the previous move was a double advance & that the defender is a @Pawn@. -} findAttackersOf - :: Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. + :: Board + -> Colour.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. -> Cartesian.Coordinates.Coordinates -- ^ The defender's location. - -> Board -> [(Cartesian.Coordinates.Coordinates, Attribute.Rank.Rank)] -- ^ The locations from which the specified square can be attacked by the opposite /logical colour/. -findAttackersOf destinationLogicalColour destination board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = [ +findAttackersOf board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } destinationLogicalColour destination = [ (coordinates, Attribute.Rank.Knight) | - coordinates <- StateProperty.Seeker.findProximateKnights (Property.Opposable.getOpposite destinationLogicalColour) destination board - ] {-list-comprehension-} ++ Data.Maybe.mapMaybe ( - \directionFromDestination -> State.MaybePieceByCoordinates.findAttackerInDirection destinationLogicalColour directionFromDestination destination maybePieceByCoordinates - ) Property.FixedMembership.members + coordinates <- StateProperty.Seeker.findProximateKnights board (Property.Opposable.getOpposite destinationLogicalColour) destination + ] {-list-comprehension-} ++ State.MaybePieceByCoordinates.findAttackerInDirections maybePieceByCoordinates destinationLogicalColour destination Nothing {-omni-directional-} {- | * Lists the source-/coordinates/ from which the referenced destination can be attacked by the specified type of /piece/. @@ -444,15 +429,15 @@ * CAVEAT: can't detect an en-passant attack, since this depends both on whether the previous move was a double advance & that the defender is a @Pawn@. -} findAttacksBy - :: Component.Piece.Piece -- ^ The type of attacker. + :: Board + -> Component.Piece.Piece -- ^ The type of attacker. -> Cartesian.Coordinates.Coordinates -- ^ The defender's location. - -> Board -> [Cartesian.Coordinates.Coordinates] -- ^ The sources from which the specified attacker could strike. -findAttacksBy piece destination board - | rank == Attribute.Rank.Knight = StateProperty.Seeker.findProximateKnights logicalColour destination board +findAttacksBy board piece destination + | rank == Attribute.Rank.Knight = StateProperty.Seeker.findProximateKnights board logicalColour destination | otherwise = filter ( - \source -> source /= destination && Component.Piece.canAttackAlong source destination piece && State.MaybePieceByCoordinates.isClear source destination (getMaybePieceByCoordinates board) - ) . State.CoordinatesByRankByLogicalColour.dereference logicalColour rank $ getCoordinatesByRankByLogicalColour board + \source -> source /= destination && Component.Piece.canAttackAlong source destination piece && State.MaybePieceByCoordinates.isClear (getMaybePieceByCoordinates board) source destination + ) $ State.CoordinatesByRankByLogicalColour.dereference (getCoordinatesByRankByLogicalColour board) logicalColour rank where (logicalColour, rank) = Component.Piece.getLogicalColour &&& Component.Piece.getRank $ piece @@ -464,10 +449,12 @@ * CAVEAT: assumes there's exactly one @King@ of the specified /logical colour/. -} isKingChecked - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ in question. - -> Board + :: Board + -> Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ in question. -> Bool -isKingChecked logicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = not . null $ findAttackersOf logicalColour (State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour) board +isKingChecked board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = not . null . uncurry ($!) . ( + findAttackersOf board &&& State.CoordinatesByRankByLogicalColour.getKingsCoordinates coordinatesByRankByLogicalColour + ) {- | * Whether one's own @King@ has become exposed in the proposed /board/. @@ -477,42 +464,42 @@ * CAVEAT: this function is a performance-hotspot. -} exposesKing - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player proposing to move. - -> Component.Move.Move -- ^ The /move/. - -> Board -- ^ The original /board/, i.e. prior to the /move/. + :: Board -- ^ The original /board/, i.e. prior to the /move/. + -> Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player proposing to move. + -> Component.Move.Move -- ^ The /move/. -> Bool -exposesKing logicalColour move board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } - | source == kingsCoordinates = not . null $ findAttackersOf logicalColour (Component.Move.getDestination move) board -- CAVEAT: expensive, since all directions from the King may have to be explored. - | Just directionFromKing <- Cartesian.Vector.toMaybeDirection $ Cartesian.Vector.measureDistance kingsCoordinates source -- Confirm that one's own King is on a straight line with the start of the move. +exposesKing board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } logicalColour move + | source == kingsCoordinates = not . null . findAttackersOf board logicalColour $! Component.Move.getDestination move -- CAVEAT: expensive, since all directions from the King may have to be explored. + | Just directionFromKing <- Cartesian.Vector.toMaybeDirection $! Cartesian.Vector.measureDistance kingsCoordinates source -- Check whether one's own King is on a straight line with the start of the move. , let maybePieceByCoordinates = getMaybePieceByCoordinates board - , State.MaybePieceByCoordinates.isClear kingsCoordinates source maybePieceByCoordinates -- Confirm that the straight line from one's own King to the start of the move, is clear. + , State.MaybePieceByCoordinates.isClear maybePieceByCoordinates kingsCoordinates source -- Check whether the straight line from one's own King to the start of the move, is clear. , Data.Maybe.maybe True {-Knight's move-} ( - not . Attribute.Direction.areAligned directionFromKing -- The blocking piece has revealed any attacker. - ) . Cartesian.Vector.toMaybeDirection $ Component.Move.measureDistance move - , Just (_, attackersRank) <- State.MaybePieceByCoordinates.findAttackerInDirection logicalColour directionFromKing source maybePieceByCoordinates -- Confirm the existence of an obscured attacker. - = attackersRank `notElem` Attribute.Rank.plodders -- Confirm sufficient range to bridge the vacated space. - | otherwise = False + not . Direction.Direction.areAligned directionFromKing -- The blocking piece has revealed any attacker. + ) . Cartesian.Vector.toMaybeDirection $! Component.Move.measureDistance move + , Just (_, attackersRank) <- State.MaybePieceByCoordinates.findAttackerInDirection maybePieceByCoordinates logicalColour source directionFromKing -- Confirm the existence of an obscured attacker. + = attackersRank `notElem` Attribute.Rank.plodders -- Check the attacker's strike-range is sufficient to bridge the vacated space. + | otherwise = False where source = Component.Move.getSource move - kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour + kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates coordinatesByRankByLogicalColour logicalColour -- | Count the number of defenders of each /piece/ on the /board/. countDefendersByCoordinatesByLogicalColour :: Board -> NDefendersByCoordinatesByLogicalColour -countDefendersByCoordinatesByLogicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour [ +countDefendersByCoordinatesByLogicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = Colour.LogicalColour.listArrayByLogicalColour [ Map.fromList [ ( coordinates, - fromIntegral . length $ findAttackersOf ( + fromIntegral . length $ findAttackersOf board ( Property.Opposable.getOpposite logicalColour -- Investigate an attack on these coordinates by one's own logical colour. - ) coordinates board + ) coordinates ) | rank <- Attribute.Rank.expendable, -- CAVEAT: there's no point defending one's own King. - coordinates <- State.CoordinatesByRankByLogicalColour.dereference logicalColour rank coordinatesByRankByLogicalColour + coordinates <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour rank ] {-list-comprehension-} | logicalColour <- Property.FixedMembership.members ] -- List-comprehension. -- | Collapses 'NDefendersByCoordinatesByLogicalColour' into the total number of defenders on either side. -summariseNDefendersByLogicalColour :: Board -> Attribute.LogicalColour.ArrayByLogicalColour Type.Count.NPieces +summariseNDefendersByLogicalColour :: Board -> Colour.LogicalColour.ArrayByLogicalColour Type.Count.NPieces summariseNDefendersByLogicalColour MkBoard { getNDefendersByCoordinatesByLogicalColour = nDefendersByCoordinatesByLogicalColour } = Data.Array.IArray.amap ( Data.Foldable.foldl' (+) 0 -- CAVEAT: 'Data.Foldable.sum' is too slow. ) nDefendersByCoordinatesByLogicalColour diff --git a/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs b/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs --- a/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs +++ b/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs @@ -54,12 +54,12 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -93,18 +93,18 @@ * N.B.: both the outer list (indexed by logical colour) & the inner list of abscissae, are kept ordered, otherwise the derived instance of 'Eq' would be unpredictable. -} -type AbscissaeByLogicalColour = [(Attribute.LogicalColour.LogicalColour, [Type.Length.X])] +type AbscissaeByLogicalColour = [(Colour.LogicalColour.LogicalColour, [Type.Length.X])] -- | Ensure a predictable order, to facilitate '(==)'. sortByLogicalColour :: AbscissaeByLogicalColour -> AbscissaeByLogicalColour sortByLogicalColour = Data.List.sortBy $ Data.Ord.comparing fst {-logicalColour-} -- | Update to account for the specified player castling. -castle :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour +castle :: Colour.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour castle logicalColour = filter $ (/= logicalColour) . fst {-logicalColour-} -- N.B.: if 'Data.List.deleteBy' took a simple predicate, it would have been ideal. -- | Update to account for the specified player losing the right to castle. -relinquishCastlingRights :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour +relinquishCastlingRights :: Colour.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour relinquishCastlingRights logicalColour = map $ \pair@(logicalColour', _) -> ( if logicalColour' == logicalColour then Control.Arrow.second $ const [] @@ -113,7 +113,7 @@ -- | Remove the right to castle, from the referenced @Rook@. removeX - :: Attribute.LogicalColour.LogicalColour + :: Colour.LogicalColour.LogicalColour -> Type.Length.X -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour @@ -125,11 +125,11 @@ -- | Predicate. canCastleWith' - :: Attribute.LogicalColour.LogicalColour + :: AbscissaeByLogicalColour + -> Colour.LogicalColour.LogicalColour -> Type.Length.X -- ^ @Rook@'s abscissa. - -> AbscissaeByLogicalColour -> Bool -canCastleWith' logicalColour x = Data.Maybe.maybe False {-has castled-} (elem x) . lookup logicalColour +canCastleWith' abscissaeByLogicalColour logicalColour x = Data.Maybe.maybe False {-has castled-} (elem x) $ lookup logicalColour abscissaeByLogicalColour -- | For the players of each /logical colour/, identifies the abscissae of those @Rook@s which can still participate in castling (when other constraints are removed). newtype CastleableRooksByLogicalColour = MkCastleableRooksByLogicalColour { @@ -197,9 +197,9 @@ (.) . Property.ExtendedPositionDescription.showsEPD ) id [ pieceConstructor logicalColour | - logicalColour <- [Attribute.LogicalColour.White, Attribute.LogicalColour.Black], -- N.B.: the order is standardised. + logicalColour <- [Colour.LogicalColour.White, Colour.LogicalColour.Black], -- N.B.: the order is standardised. (rooksX, pieceConstructor) <- [(Cartesian.Abscissa.xMax, Component.Piece.mkKing), (Cartesian.Abscissa.xMin, Component.Piece.mkQueen)], -- N.B.: the order is defined as King-side (short) before Queen-side (long), which is also alphabetical. - canCastleWith' logicalColour rooksX assocs + canCastleWith' assocs logicalColour rooksX ] -- List-comprehension. instance Property.ForsythEdwards.ReadsFEN CastleableRooksByLogicalColour @@ -208,8 +208,8 @@ -- | Get the list of random numbers required to represent the current castling potential. instance StateProperty.Hashable.Hashable CastleableRooksByLogicalColour where - listRandoms MkCastleableRooksByLogicalColour { getAssocs = assocs } zobrist = Data.Maybe.catMaybes [ - Component.Zobrist.dereferenceRandomByCastleableRooksXByLogicalColour logicalColour x zobrist | + listRandoms zobrist MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.catMaybes [ + Component.Zobrist.dereferenceRandomByCastleableRooksXByLogicalColour zobrist logicalColour x | logicalColour <- Property.FixedMembership.members, x <- Data.Maybe.fromMaybe [] $ lookup logicalColour assocs ] -- List-comprehension. @@ -234,8 +234,8 @@ fromBoard :: State.Board.Board -> CastleableRooksByLogicalColour fromBoard board | any ( - \logicalColour -> hasCastled logicalColour castleableRooksByLogicalColour && all ( - `elem` State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour + \logicalColour -> hasCastled castleableRooksByLogicalColour logicalColour && all ( + `elem` State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour Attribute.Rank.Pawn ) [ Cartesian.Coordinates.mkCoordinates x ( Cartesian.Ordinate.pawnsFirstRank logicalColour @@ -252,8 +252,8 @@ logicalColour, [ Cartesian.Coordinates.getX rooksCoordinates | - State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour == Cartesian.Coordinates.kingsStartingCoordinates logicalColour, - rooksCoordinates <- State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Rook coordinatesByRankByLogicalColour, + uncurry (==) $ (State.CoordinatesByRankByLogicalColour.getKingsCoordinates coordinatesByRankByLogicalColour &&& Cartesian.Coordinates.kingsStartingCoordinates) logicalColour, + rooksCoordinates <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour Attribute.Rank.Rook, rooksCoordinates `elem` Cartesian.Coordinates.rooksStartingCoordinates logicalColour ] -- List-comprehension. ) -- Pair. @@ -266,7 +266,7 @@ fromTurnsByLogicalColour :: TurnsByLogicalColour -> CastleableRooksByLogicalColour fromTurnsByLogicalColour turnsByLogicalColour = MkCastleableRooksByLogicalColour $ foldr ( \logicalColour -> let - turns = State.TurnsByLogicalColour.dereference logicalColour turnsByLogicalColour + turns = State.TurnsByLogicalColour.dereference turnsByLogicalColour logicalColour in if any (Attribute.MoveType.isCastle . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove) turns then id -- Have Castled. else (:) ( @@ -275,7 +275,7 @@ Cartesian.Coordinates.getX coordinates | not $ haveMovedFrom (Cartesian.Coordinates.kingsStartingCoordinates logicalColour) turns, coordinates <- Cartesian.Coordinates.rooksStartingCoordinates logicalColour, - not $ haveMovedFrom coordinates turns || haveMovedTo coordinates (State.TurnsByLogicalColour.dereference (Property.Opposable.getOpposite logicalColour) turnsByLogicalColour) + not $ haveMovedFrom coordinates turns || haveMovedTo coordinates (State.TurnsByLogicalColour.dereference turnsByLogicalColour $ Property.Opposable.getOpposite logicalColour) ] -- List-comprehension. ) -- Pair. ) [] Property.FixedMembership.members where @@ -284,33 +284,33 @@ haveMovedTo coordinates = any $ (== coordinates) . Component.Move.getDestination . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove -- | Predicate. -hasCastled :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Bool -hasCastled logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = all ((/= logicalColour) . fst) assocs +hasCastled :: CastleableRooksByLogicalColour -> Colour.LogicalColour.LogicalColour -> Bool +hasCastled MkCastleableRooksByLogicalColour { getAssocs = assocs } logicalColour = all ((/= logicalColour) . fst) assocs -- | Predicate. -canCastle :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Bool -canCastle logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False {-has castled-} (not . null) $ lookup logicalColour assocs +canCastle :: CastleableRooksByLogicalColour -> Colour.LogicalColour.LogicalColour -> Bool +canCastle MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False {-has castled-} (not . null) . (`lookup` assocs) -- | Infer the @Rook@'s ordinate from the /piece/'s /logical colour/. -inferRooksOrdinate :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y +inferRooksOrdinate :: Colour.LogicalColour.LogicalColour -> Type.Length.Y inferRooksOrdinate logicalColour - | Attribute.LogicalColour.isBlack logicalColour = Cartesian.Ordinate.yMax + | Colour.LogicalColour.isBlack logicalColour = Cartesian.Ordinate.yMax | otherwise = Cartesian.Ordinate.yMin -- | Predicate. canCastleWith - :: Attribute.LogicalColour.LogicalColour + :: CastleableRooksByLogicalColour + -> Colour.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -- ^ @Rook@'s coordinates. - -> CastleableRooksByLogicalColour -> Bool -canCastleWith logicalColour rookSource MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False {-has castled-} ( +canCastleWith MkCastleableRooksByLogicalColour { getAssocs = assocs } logicalColour rookSource = Data.Maybe.maybe False {-has castled-} ( any $ (== rookSource) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate logicalColour) ) $ lookup logicalColour assocs -- | Find the abscissae of all @Rook@s of the specified /logical colour/, which can still participate in castling. -locateForLogicalColour :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Maybe [Type.Length.X] +locateForLogicalColour :: CastleableRooksByLogicalColour -> Colour.LogicalColour.LogicalColour -> Maybe [Type.Length.X] {-# INLINE locateForLogicalColour #-} -locateForLogicalColour logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = lookup logicalColour assocs +locateForLogicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = (`lookup` assocs) -- | Self-documentation. type Transformation = CastleableRooksByLogicalColour -> CastleableRooksByLogicalColour @@ -329,7 +329,7 @@ -- | Update with the latest /turn/. takeTurn - :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side who took the specified turn. + :: Colour.LogicalColour.LogicalColour -- ^ Defines the side who took the specified turn. -> Component.Turn.Turn -> Transformation takeTurn logicalColour turn MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ ( @@ -381,7 +381,7 @@ -> CastleableRooksByLogicalColour -> Bool cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour' = any ( - \logicalColour -> case ($ castleableRooksByLogicalColour) &&& ($ castleableRooksByLogicalColour') $ locateForLogicalColour logicalColour of + \logicalColour -> case ($ castleableRooksByLogicalColour) &&& ($ castleableRooksByLogicalColour') $ (`locateForLogicalColour` logicalColour) of (Just [], Nothing) -> True (Nothing, Just []) -> True _ -> False @@ -389,13 +389,9 @@ -- | Generate the additional random-numbers required to correct the hash resulting from a change to the castleable @Rook@s. listIncrementalRandoms - :: CastleableRooksByLogicalColour -- ^ The old value. + :: Component.Zobrist.Zobrist random + -> CastleableRooksByLogicalColour -- ^ The old value. -> CastleableRooksByLogicalColour -- ^ The new value. - -> Component.Zobrist.Zobrist random -> [random] -listIncrementalRandoms castleableRooksByLogicalColour castleableRooksByLogicalColour' zobrist = [ - random | - hashable <- [castleableRooksByLogicalColour, castleableRooksByLogicalColour'], - random <- StateProperty.Hashable.listRandoms hashable zobrist - ] -- List-comprehension. +listIncrementalRandoms zobrist castleableRooksByLogicalColour castleableRooksByLogicalColour' = StateProperty.Hashable.listRandoms zobrist [castleableRooksByLogicalColour, castleableRooksByLogicalColour'] diff --git a/src-lib/BishBosh/State/CoordinatesByRankByLogicalColour.hs b/src-lib/BishBosh/State/CoordinatesByRankByLogicalColour.hs --- a/src-lib/BishBosh/State/CoordinatesByRankByLogicalColour.hs +++ b/src-lib/BishBosh/State/CoordinatesByRankByLogicalColour.hs @@ -30,6 +30,7 @@ -- * Types -- ** Type-synonyms -- CoordinatesByRank, + BareCoordinatesByRankByLogicalColour, CoordinatesByLogicalColour, -- Transformation, -- ** Data-types @@ -38,6 +39,7 @@ deconstruct ), -- * Functions +-- advanceDirection, findPassedPawnCoordinatesByLogicalColour, findPiecesOfColour, assocs, @@ -45,22 +47,20 @@ -- ** Accessors getKingsCoordinates, dereference, --- ** Constructor - fromMaybePieceByCoordinates, -- ** Mutators --- deleteCoordinates, - movePiece, +-- deleteCoordinatesFromRank, +-- mapCoordinates, +-- purgeCoordinates, sortCoordinates ) where import Control.Arrow((&&&), (|||)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece @@ -69,36 +69,41 @@ import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable +import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.StateProperty.View as StateProperty.View import qualified Control.Arrow import qualified Control.DeepSeq -import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Foldable import qualified Data.List +import qualified Data.List.Extra import qualified Data.Map.Strict as Map import qualified Data.Maybe -- | The /coordinate/s of all the pieces of one /rank/. type CoordinatesByRank = Attribute.Rank.ArrayByRank [Cartesian.Coordinates.Coordinates] +-- | The /coordinate/s of all the pieces of one /rank/, for both logical colours. +type BareCoordinatesByRankByLogicalColour = Colour.LogicalColour.ArrayByLogicalColour CoordinatesByRank + {- | * This structure allows one to determine the set of /coordinates/ where a type of /piece/ is located. * CAVEAT: the list of /coordinates/ is unordered, so test for equality using @ deconstruct . sortCoordinates @. -} newtype CoordinatesByRankByLogicalColour = MkCoordinatesByRankByLogicalColour { - deconstruct :: Attribute.LogicalColour.ArrayByLogicalColour CoordinatesByRank + deconstruct :: BareCoordinatesByRankByLogicalColour } instance Control.DeepSeq.NFData CoordinatesByRankByLogicalColour where rnf MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour instance StateProperty.Censor.Censor CoordinatesByRankByLogicalColour where - countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Attribute.LogicalColour.Black) &&& ($ Attribute.LogicalColour.White) $ Data.List.foldl' (\acc -> (+ acc) . fromIntegral . length) 0 . (byLogicalColour !) + countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Colour.LogicalColour.Black) &&& ($ Colour.LogicalColour.White) $ Data.List.foldl' (\acc -> (+ acc) . fromIntegral . length) 0 . (byLogicalColour !) countPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.foldl' ( Data.List.foldl' $ \acc -> (+ acc) . fromIntegral . length @@ -107,7 +112,7 @@ countPieceDifferenceByRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.Rank.listArrayByRank . uncurry ( zipWith (-) ) . ( - ($ Attribute.LogicalColour.White) &&& ($ Attribute.LogicalColour.Black) + ($ Colour.LogicalColour.White) &&& ($ Colour.LogicalColour.Black) ) $ map (fromIntegral . length) . Data.Foldable.toList . (byLogicalColour !) hasInsufficientMaterial MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.all ( @@ -127,23 +132,67 @@ bishops = blackBishops ++ whiteBishops - hasBothKings MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = not $ Data.Foldable.any (null . (! Attribute.Rank.King)) byLogicalColour -- CAVEAT: true for more than one King per side also. + hasBothKings MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.all ((== 1) . length . (! Attribute.Rank.King)) byLogicalColour -- CAVEAT: false for more than one King per side also. instance StateProperty.Hashable.Hashable CoordinatesByRankByLogicalColour where - listRandoms MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } zobrist = [ - Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (logicalColour, rank, coordinates) zobrist | + listRandoms zobrist MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [ + Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (logicalColour, rank, coordinates) | (logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour, (rank, coordinatesList) <- Data.Array.IArray.assocs byRank, coordinates <- coordinatesList ] -- List-comprehension. +instance StateProperty.Mutator.Mutator CoordinatesByRankByLogicalColour where + defineCoordinates maybePiece coordinates = MkCoordinatesByRankByLogicalColour . ( + \byLogicalColour -> Data.Maybe.maybe byLogicalColour ( + \piece -> let + logicalColour = Component.Piece.getLogicalColour piece + byRank = byLogicalColour ! logicalColour + in byLogicalColour // [ + ( + logicalColour, + byRank // [ + id &&& (coordinates :) . (byRank !) $ Component.Piece.getRank piece -- Prepend. + ] -- Singleton. + ) -- Pair. + ] -- Singleton. + ) maybePiece + ) . deconstruct . purgeCoordinates coordinates + + movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkCoordinatesByRankByLogicalColour { + deconstruct = byLogicalColour + } = MkCoordinatesByRankByLogicalColour $ byLogicalColour // ( + (:) . (`deleteOpponentsCoordinates` Attribute.Rank.Pawn) ||| Data.Maybe.maybe id {-quiet move-} ( + (:) . deleteOpponentsCoordinates destination + ) $ eitherPassingPawnsDestinationOrMaybeTakenRank + ) [ + let + byRank = byLogicalColour ! logicalColour + in ( + logicalColour, + byRank // Data.Maybe.maybe ( + return {-to List-monad-} . Control.Arrow.second (destination :) -- Add the destination to the mover. + ) ( + \promotionRank -> (:) ( + promotionRank, + destination : byRank ! promotionRank -- Add the destination to the mover's promoted rank. + ) . return {-to List-monad-} + ) maybePromotionRank ( + id &&& Data.List.delete (Component.Move.getSource move) . (byRank !) $ Component.Piece.getRank sourcePiece + ) + ) -- Pair. + ] where + destination = Component.Move.getDestination move + logicalColour = Component.Piece.getLogicalColour sourcePiece + deleteOpponentsCoordinates coordinates rank = id &&& deleteCoordinatesFromRank coordinates rank . (byLogicalColour !) $ Property.Opposable.getOpposite logicalColour + {- | * Find any @Knight@s of the specified /logical colour/, in attack-range around the specified /coordinates/. * CAVEAT: nothing is said about whether any /piece/ at the specified /coordinates/ belongs to the opponent, as one might expect. -} instance StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour {-CAVEAT: MultiParamTypeClasses-} where - findProximateKnights logicalColour destination MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = filter ( + findProximateKnights MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } logicalColour destination = filter ( \source -> source /= destination {-guard against attempting to constructing a null vector-} && Cartesian.Vector.isKnightsMove ( Cartesian.Vector.measureDistance source destination ) @@ -164,36 +213,46 @@ ) Property.Empty.empty . (! Attribute.Rank.Pawn) ) byLogicalColour +instance StateProperty.View.View CoordinatesByRankByLogicalColour where + fromAssocs = MkCoordinatesByRankByLogicalColour . Data.Array.IArray.accumArray ( + flip const -- Replace the default. + ) ( + Attribute.Rank.listArrayByRank $ repeat [] -- Default. + ) (minBound, maxBound) . map ( + Control.Arrow.second $ Data.Array.IArray.accumArray (++) [] {-default-} (minBound, maxBound) . Data.List.Extra.groupSort {-by Rank-} -- Construct the ArrayByRank. + ) . Data.List.Extra.groupSort {-by LogicalColour-} . map ( + \(coordinates, piece) -> (Component.Piece.getLogicalColour piece, (Component.Piece.getRank piece, coordinates)) -- Reorder the components. + ) + instance Component.Accountant.Accountant CoordinatesByRankByLogicalColour where - sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = map ( + sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } nPieces = map ( \(logicalColour, byRank) -> Data.List.foldl' ( \acc (rank, coordinatesList) -> Data.List.foldl' ( - \acc' -> (+ acc') . Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour rank + \acc' -> (+ acc') . realToFrac . Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour rank ) acc coordinatesList ) 0 $ Data.Array.IArray.assocs byRank ) $ Data.Array.IArray.assocs byLogicalColour --- | Constructor. -fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates -> CoordinatesByRankByLogicalColour -fromMaybePieceByCoordinates maybePieceByCoordinates = MkCoordinatesByRankByLogicalColour . ( - \(b, w) -> Attribute.LogicalColour.listArrayByLogicalColour $ map ( - Data.Array.IArray.accumArray (++) [] (minBound, maxBound) . map (Control.Arrow.first Component.Piece.getRank) - ) [b, w] - ) $ Data.List.partition ( - Component.Piece.isBlack . fst {-piece-} - ) [ - (piece, [coordinates]) | - (coordinates, piece) <- StateProperty.Seeker.findAllPieces maybePieceByCoordinates - ] -- List-comprehension. +instance Property.SelfValidating.SelfValidating CoordinatesByRankByLogicalColour where + findInvalidity selfValidator = concatMap ($ selfValidator) [ + StateProperty.Censor.findInvalidity, + StateProperty.Seeker.findInvalidity, + Property.SelfValidating.findErrors [ + ( + not . all ((== 1) . length) . Data.List.group . Data.List.sort . listCoordinates, + "there can't be any duplicate coordinates regardless of logical colour or ranks." + ) + ] + ] -- | Dereference the array. dereference - :: Attribute.LogicalColour.LogicalColour + :: CoordinatesByRankByLogicalColour + -> Colour.LogicalColour.LogicalColour -> Attribute.Rank.Rank - -> CoordinatesByRankByLogicalColour -> [Cartesian.Coordinates.Coordinates] {-# INLINE dereference #-} -dereference logicalColour rank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = byLogicalColour ! logicalColour ! rank +dereference MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } logicalColour rank = byLogicalColour ! logicalColour ! rank -- | Build an association-list. assocs :: CoordinatesByRankByLogicalColour -> [(Component.Piece.Piece, [Cartesian.Coordinates.Coordinates])] @@ -214,35 +273,40 @@ -- | Get the /coordinates/ of the @King@ of the specified /logical colour/. getKingsCoordinates - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ to find. - -> CoordinatesByRankByLogicalColour + :: CoordinatesByRankByLogicalColour + -> Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ to find. -> Cartesian.Coordinates.Coordinates {-# INLINE getKingsCoordinates #-} -getKingsCoordinates logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.Exception.assert (not $ null coordinates) $ head coordinates {-there should be exactly one-} where - coordinates = byLogicalColour ! logicalColour ! Attribute.Rank.King +getKingsCoordinates MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } logicalColour = coordinates where + [coordinates] = byLogicalColour ! logicalColour ! Attribute.Rank.King -- CAVEAT: there should be exactly one. -- | Locate all /piece/s of the specified /logical colour/. findPiecesOfColour - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/s to find. - -> CoordinatesByRankByLogicalColour + :: CoordinatesByRankByLogicalColour + -> Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/s to find. -> [Component.Piece.LocatedPiece] -findPiecesOfColour logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [ +findPiecesOfColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } logicalColour = [ (coordinates, Component.Piece.mkPiece logicalColour rank) | (rank, coordinatesList) <- Data.Array.IArray.assocs $ byLogicalColour ! logicalColour, coordinates <- coordinatesList ] -- List-comprehension. +-- | The /y/-direction in which a @Pawn@ of the specified /logical colour/ advances. +advanceDirection :: Colour.LogicalColour.LogicalColour -> Ordering +advanceDirection Colour.LogicalColour.Black = LT -- Black moves down. +advanceDirection _ = GT + -- | A list of /coordinates/ for each /logical colour/. -type CoordinatesByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour [Cartesian.Coordinates.Coordinates] +type CoordinatesByLogicalColour = Colour.LogicalColour.ArrayByLogicalColour [Cartesian.Coordinates.Coordinates] -- | For each /logical colour/, find the /coordinates/ of any passed @Pawn@s (). findPassedPawnCoordinatesByLogicalColour :: CoordinatesByRankByLogicalColour -> CoordinatesByLogicalColour -findPassedPawnCoordinatesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour $ map ( +findPassedPawnCoordinatesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Colour.LogicalColour.listArrayByLogicalColour $ map ( \logicalColour -> let opponentsLogicalColour = Property.Opposable.getOpposite logicalColour opposingPawnYByX = Data.List.foldl' ( \m coordinates -> uncurry ( - Map.insertWith $ if Attribute.LogicalColour.isBlack opponentsLogicalColour + Map.insertWith $ if Colour.LogicalColour.isBlack opponentsLogicalColour then max else min ) {-only compare with the least advanced opposing Pawn in each file-} ( @@ -253,7 +317,7 @@ \coordinates -> all ( Data.Maybe.maybe True {-absence of opposition doesn't impede advance-} ( ( - /= Attribute.Direction.advanceDirection logicalColour -- Either equal or backwards is OK. + /= advanceDirection logicalColour -- Either equal or backwards is OK. ) . ( {-opponent-} `compare` Cartesian.Coordinates.getY coordinates ) -- As a Pawn advances, it becomes "Passed" when the y-distance to the least advanced adjacent opposing Pawn, is either equal or backwards. @@ -265,50 +329,26 @@ ) Property.FixedMembership.members where findPawns = (! Attribute.Rank.Pawn) . (byLogicalColour !) --- | Self-documentation. -type Transformation = CoordinatesByRankByLogicalColour -> CoordinatesByRankByLogicalColour - -- | Remove the specified /coordinates/ from those recorded for the specified /rank/. -deleteCoordinates +deleteCoordinatesFromRank :: Cartesian.Coordinates.Coordinates -> Attribute.Rank.Rank -> CoordinatesByRank -> CoordinatesByRank -deleteCoordinates coordinates rank byRank = byRank // [(rank, Data.List.delete coordinates $ byRank ! rank)] +deleteCoordinatesFromRank coordinates rank byRank = byRank // [id &&& Data.List.delete coordinates . (byRank !) $ rank] --- | Adjust the array to reflect a new /move/. -movePiece - :: Component.Move.Move - -> Component.Piece.Piece -- ^ The piece which moved. - -> Maybe Attribute.Rank.Rank -- ^ The (possibly promoted) rank to place at the destination. - -> Either Cartesian.Coordinates.Coordinates (Maybe Attribute.Rank.Rank) -- ^ Either the destination of any passed @Pawn@, or the /rank/ of any /piece/ taken. - -> Transformation -movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ byLogicalColour // ( - (:) . (`deleteOpponentsCoordinates` Attribute.Rank.Pawn) ||| Data.Maybe.maybe id {-quiet move-} ( - (:) . deleteOpponentsCoordinates destination - ) $ eitherPassingPawnsDestinationOrMaybeTakenRank - ) [ - let - byRank = byLogicalColour ! logicalColour - in ( - logicalColour, - byRank // Data.Maybe.maybe ( - return {-to List-monad-} . Control.Arrow.second (destination :) -- Add the destination to the mover. - ) ( - \promotionRank -> (:) ( - promotionRank, - destination : byRank ! promotionRank -- Add the destination to the mover's promoted rank. - ) . return {-to List-monad-} - ) maybePromotionRank ( - id &&& Data.List.delete (Component.Move.getSource move) . (byRank !) $ Component.Piece.getRank sourcePiece - ) - ) -- Pair. - ] where - destination = Component.Move.getDestination move - logicalColour = Component.Piece.getLogicalColour sourcePiece - deleteOpponentsCoordinates coordinates rank = id &&& deleteCoordinates coordinates rank . (byLogicalColour !) $ Property.Opposable.getOpposite logicalColour +-- | Self-documentation. +type Transformation = CoordinatesByRankByLogicalColour -> CoordinatesByRankByLogicalColour +-- | Map the coordinate-lists. +mapCoordinates :: ([Cartesian.Coordinates.Coordinates] -> [Cartesian.Coordinates.Coordinates]) -> Transformation +mapCoordinates f MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ Data.Array.IArray.amap (Data.Array.IArray.amap f) byLogicalColour + +-- | Purge the specified /coordinates/ regardless of the /rank/ or /logical colour/ of any incumbent piece. +purgeCoordinates :: Cartesian.Coordinates.Coordinates -> Transformation +purgeCoordinates coordinates = mapCoordinates $ Data.List.delete coordinates + -- | Independently sort each list of /coordinates/. sortCoordinates :: Transformation -sortCoordinates MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ Data.Array.IArray.amap (Data.Array.IArray.amap Data.List.sort) byLogicalColour +sortCoordinates = mapCoordinates Data.List.sort diff --git a/src-lib/BishBosh/State/EnPassantAbscissa.hs b/src-lib/BishBosh/State/EnPassantAbscissa.hs --- a/src-lib/BishBosh/State/EnPassantAbscissa.hs +++ b/src-lib/BishBosh/State/EnPassantAbscissa.hs @@ -31,9 +31,9 @@ mkMaybeEnPassantAbscissa ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -56,28 +56,31 @@ rnf MkEnPassantAbscissa { getAbscissa = x } = Control.DeepSeq.rnf x instance StateProperty.Hashable.Hashable EnPassantAbscissa where - listRandoms MkEnPassantAbscissa { getAbscissa = x } = return {-to List-monad-} . Component.Zobrist.dereferenceRandomByEnPassantAbscissa x + listRandoms zobrist MkEnPassantAbscissa { getAbscissa = x } = return {-to List-monad-} $! Component.Zobrist.dereferenceRandomByEnPassantAbscissa zobrist x -- | Constructor. mkMaybeEnPassantAbscissa - :: Attribute.LogicalColour.LogicalColour -- ^ The player who moves next, & who may have an En-passant capture-option. + :: Colour.LogicalColour.LogicalColour -- ^ The player who moves next, & who may have an En-passant capture-option. -> State.MaybePieceByCoordinates.MaybePieceByCoordinates - -> Component.Turn.Turn -- ^ The last /turn/ taken. + -> Component.Turn.Turn -- ^ The last /turn/ taken. -> Maybe EnPassantAbscissa mkMaybeEnPassantAbscissa nextLogicalColour maybePieceByCoordinates lastTurn - | Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) lastTurn - , let lastMoveDestination = Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove lastTurn + | Component.Turn.isPawnDoubleAdvance lastTurn $! Property.Opposable.getOpposite nextLogicalColour + , let lastMoveDestination = Component.Move.getDestination . Component.QualifiedMove.getMove $! Component.Turn.getQualifiedMove lastTurn , not $ null [ - passedPawn | - adjacentCoordinates <- Cartesian.Coordinates.getAdjacents lastMoveDestination, - Component.Piece.mkKing nextLogicalColour {- Will I expose my King ? -} `notElem` [ - blockingPiece | - threatDirection <- Property.FixedMembership.members, -- Consider all directions. - (_, attackerRank) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findAttackerInDirection nextLogicalColour threatDirection adjacentCoordinates maybePieceByCoordinates, -- Find discovered attacks. - attackerRank `notElem` Attribute.Rank.fixedAttackRange, -- Any viable attack through the vacated square must be long-range. - (_, blockingPiece) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findBlockingPiece (Property.Opposable.getOpposite threatDirection) adjacentCoordinates maybePieceByCoordinates -- Find any discovered attack. - ], -- Confirm that the En-passant capture doesn't expose my King. - passedPawn <- filter (== Component.Piece.mkPawn nextLogicalColour) . Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.dereference adjacentCoordinates maybePieceByCoordinates - ] = Just . MkEnPassantAbscissa $ Cartesian.Coordinates.getX lastMoveDestination - | otherwise = Nothing + adjacentPawnCoordinates | + adjacentPawnCoordinates <- filter ( + (== Just (Component.Piece.mkPawn nextLogicalColour)) . State.MaybePieceByCoordinates.dereference maybePieceByCoordinates -- Confirm the existence of an enemy Pawn. + ) $ Cartesian.Coordinates.getAdjacents lastMoveDestination, -- Find locations from which a Pawn may mount an attack en-passant. + all ( + \(direction, rank) -> rank `elem` Attribute.Rank.plodders || ( + /= Just (Component.Piece.mkKing nextLogicalColour) -- Confirm that my King doesn't become checked. + ) ( + fmap snd {-piece-} . State.MaybePieceByCoordinates.findBlockingPiece maybePieceByCoordinates adjacentPawnCoordinates $ Property.Opposable.getOpposite direction -- Check whether there's a piece in the opposite direction through the vacated square. + ) + ) $ Data.Maybe.mapMaybe ( + \direction -> (,) direction . snd {-rank-} <$> State.MaybePieceByCoordinates.findAttackerInDirection maybePieceByCoordinates nextLogicalColour adjacentPawnCoordinates direction -- Identify attacks passing through the square vacated by the attacking Pawn; the square occupied by the double advanced Pawn, wasn't an issue before it advanced, so it isn't if taken. + ) Property.FixedMembership.members -- Consider all directions. + ] {-list-comprehension-} = Just . MkEnPassantAbscissa $ Cartesian.Coordinates.getX lastMoveDestination + | otherwise = Nothing diff --git a/src-lib/BishBosh/State/MaybePieceByCoordinates.hs b/src-lib/BishBosh/State/MaybePieceByCoordinates.hs --- a/src-lib/BishBosh/State/MaybePieceByCoordinates.hs +++ b/src-lib/BishBosh/State/MaybePieceByCoordinates.hs @@ -31,14 +31,14 @@ module BishBosh.State.MaybePieceByCoordinates( -- * Types --- ** Type-synonyms --- Transformation, -- ** Data-types MaybePieceByCoordinates(), -- * Functions inferMoveType, findBlockingPiece, + findBlockingPieces, findAttackerInDirection, + findAttackerInDirections, listDestinationsFor, -- listToRaster, -- shows2D, @@ -46,8 +46,6 @@ -- ** Accessors dereference, -- getPieces, --- ** Mutators - movePiece, -- ** Predicates isVacant, isOccupied, @@ -57,20 +55,19 @@ ) where import Control.Applicative((<|>)) -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&), (***), (|||)) import Control.Category((>>>)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.ANSIColourCode as Attribute.ANSIColourCode -import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.LogicalColourOfSquare as Attribute.LogicalColourOfSquare import qualified BishBosh.Attribute.MoveType as Attribute.MoveType -import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Colour.ANSIColourCode as Colour.ANSIColourCode +import qualified BishBosh.Colour.ColourScheme as Colour.ColourScheme +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Colour.LogicalColourOfSquare as Colour.LogicalColourOfSquare +import qualified BishBosh.Colour.PhysicalColour as Colour.PhysicalColour import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.CastlingMove as Component.CastlingMove import qualified BishBosh.Component.Move as Component.Move @@ -78,6 +75,7 @@ import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Direction.Direction as Direction.Direction import qualified BishBosh.Notation.Figurine as Notation.Figurine import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription @@ -86,10 +84,12 @@ import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Orientated as Property.Orientated import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.StateProperty.View as StateProperty.View import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow @@ -110,13 +110,14 @@ * N.B.: this could be implemented using 'Data.Vector.Vector', which being indexed by 'Int' is no longer polymorphic & permits many unsafe operations; but the result is no faster. -} newtype MaybePieceByCoordinates = MkMaybePieceByCoordinates { - deconstruct :: Cartesian.Coordinates.ArrayByCoordinates ( - Maybe Component.Piece.Piece -- Each square optionally contains a piece. - ) + deconstruct :: Cartesian.Coordinates.ArrayByCoordinates (Maybe Component.Piece.Piece) -- ^ Each square optionally contains a piece. } deriving (Eq, Ord) --- | Used to separate the /ranks/ of the /board/ as represented by the IO-format . --- | Chops a list into a 2-D list. +{- | + * Used to separate the /ranks/ of the /board/ as represented by the IO-format . + + * Chops a list into a 2-D list. +-} listToRaster :: [a] -> [[a]] listToRaster = Data.List.Extra.chunksOf $ fromIntegral Cartesian.Abscissa.xLength {-CAVEAT: this also depends on the raster-order-} @@ -167,17 +168,17 @@ instance Property.ForsythEdwards.ShowsFEN MaybePieceByCoordinates instance Data.Default.Default MaybePieceByCoordinates where - def = Property.ForsythEdwards.readFEN . Data.List.intercalate [Property.ExtendedPositionDescription.rankSeparator] $ map ($ Attribute.LogicalColour.Black) [ + def = Property.ForsythEdwards.readFEN . Data.List.intercalate [Property.ExtendedPositionDescription.rankSeparator] $ map ($ Colour.LogicalColour.Black) [ showNobility, showPawnRow - ] ++ replicate 4 "8" ++ map ($ Attribute.LogicalColour.White) [ + ] ++ replicate 4 "8" ++ map ($ Colour.LogicalColour.White) [ showPawnRow, showNobility ] where showPieces :: [Component.Piece.Piece] -> String showPieces = concatMap Property.ForsythEdwards.showFEN - showPawnRow, showNobility :: Attribute.LogicalColour.LogicalColour -> String + showPawnRow, showNobility :: Colour.LogicalColour.LogicalColour -> String showPawnRow logicalColour = showPieces . replicate (fromIntegral Cartesian.Abscissa.xLength) $ Component.Piece.mkPawn logicalColour showNobility logicalColour = showPieces $ map (Component.Piece.mkPiece logicalColour) Attribute.Rank.nobility @@ -197,13 +198,9 @@ instance StateProperty.Censor.Censor MaybePieceByCoordinates where countPiecesByLogicalColour = Data.List.foldl' ( - \acc piece -> let - acc'@(nBlack, nWhite) = ( - if Component.Piece.isBlack piece - then Control.Arrow.first - else Control.Arrow.second - ) succ acc - in nBlack `seq` nWhite `seq` acc' + \(nBlack, nWhite) piece -> if Component.Piece.isBlack piece + then let nBlack' = succ nBlack in nBlack' `seq` (nBlack', nWhite) + else let nWhite' = succ nWhite in nWhite' `seq` (nBlack, nWhite') ) (0, 0) . getPieces countPieces = fromIntegral . length . getPieces @@ -244,16 +241,32 @@ _ -> False instance StateProperty.Hashable.Hashable MaybePieceByCoordinates where - listRandoms MkMaybePieceByCoordinates { deconstruct = byCoordinates } zobrist = [ - Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (Component.Piece.getLogicalColour piece, Component.Piece.getRank piece, coordinates) zobrist | + listRandoms zobrist MkMaybePieceByCoordinates { deconstruct = byCoordinates } = [ + Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist $ uncurry (,,) (Component.Piece.getLogicalColour &&& Component.Piece.getRank $ piece) coordinates | (coordinates, Just piece) <- Data.Array.IArray.assocs byCoordinates ] -- List-comprehension. instance StateProperty.Mutator.Mutator MaybePieceByCoordinates where - defineCoordinates maybePiece coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( + defineCoordinates maybePiece coordinates MkMaybePieceByCoordinates { + deconstruct = byCoordinates + } = Control.Exception.assert ( Data.Maybe.isJust maybePiece || Data.Maybe.isJust (byCoordinates ! coordinates) ) . MkMaybePieceByCoordinates $ byCoordinates // [(coordinates, maybePiece)] + movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkMaybePieceByCoordinates { + deconstruct = byCoordinates + } = MkMaybePieceByCoordinates $ byCoordinates // ( + (:) . flip (,) Nothing {-take en-passant-} ||| const id $ eitherPassingPawnsDestinationOrMaybeTakenRank + ) [ + ( + Component.Move.getSource move, + Nothing -- Remove the piece from the source. + ), ( + Component.Move.getDestination move, + Just $ Data.Maybe.maybe id Component.Piece.promote maybePromotionRank sourcePiece -- Place the piece at the destination, removing any opposing incumbent as a side-effect. + ) + ] + {- | * Find any @Knight@s of the specified /logical colour/, in attack-range around the specified /coordinates/. @@ -262,9 +275,9 @@ * CAVEAT: less efficient than 'State.CoordinatesByRankByLogicalColour.findProximateKnights'. -} instance StateProperty.Seeker.Seeker MaybePieceByCoordinates where - findProximateKnights logicalColour destination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = filter ( + findProximateKnights MkMaybePieceByCoordinates { deconstruct = byCoordinates } logicalColour destination = filter ( (== Just knight) . (byCoordinates !) - ) $ Component.Piece.findAttackDestinations destination knight where + ) $ Component.Piece.findAttackDestinations knight destination where knight = Component.Piece.mkKnight logicalColour findPieces predicate MkMaybePieceByCoordinates { deconstruct = byCoordinates } = [ @@ -273,41 +286,44 @@ predicate piece ] -- List-comprehension. +instance StateProperty.View.View MaybePieceByCoordinates where + fromAssocs = MkMaybePieceByCoordinates . Data.Array.IArray.accumArray (flip const) Nothing {-default-} (minBound, maxBound) . map (Control.Arrow.second Just) + instance Component.Accountant.Accountant MaybePieceByCoordinates where - sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces = ( + sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank maybePieceByCoordinates nPieces = ( \(b, w) -> [b, w] ) . Data.List.foldl' ( \(b, w) (coordinates, piece) -> let logicalColour = Component.Piece.getLogicalColour piece - pieceSquareValue = Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour (Component.Piece.getRank piece) coordinates - in if Attribute.LogicalColour.isBlack logicalColour + pieceSquareValue = realToFrac $! Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour (Component.Piece.getRank piece) coordinates + in if Colour.LogicalColour.isBlack logicalColour then let b' = b + pieceSquareValue in b' `seq` (b', w) else let w' = w + pieceSquareValue in w' `seq` (b, w') - ) (0, 0) . StateProperty.Seeker.findAllPieces + ) (0, 0) $ StateProperty.Seeker.findAllPieces maybePieceByCoordinates +instance Property.SelfValidating.SelfValidating MaybePieceByCoordinates where + findInvalidity = uncurry (++) . (StateProperty.Censor.findInvalidity &&& StateProperty.Seeker.findInvalidity) + -- | Dereference the array. -dereference - :: Cartesian.Coordinates.Coordinates - -> MaybePieceByCoordinates - -> Maybe Component.Piece.Piece +dereference :: MaybePieceByCoordinates -> Cartesian.Coordinates.Coordinates -> Maybe Component.Piece.Piece {-# INLINE dereference #-} -dereference coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = byCoordinates ! coordinates +dereference MkMaybePieceByCoordinates { deconstruct = byCoordinates } = (byCoordinates !) -- | Infer the type of the specified /move/. inferMoveType - :: Component.Move.Move + :: MaybePieceByCoordinates + -> Component.Move.Move -> Maybe Attribute.Rank.Rank -- ^ The /rank/ to which a @Pawn@ should be promoted; defaulting to @Queen@. - -> MaybePieceByCoordinates -> Attribute.MoveType.MoveType -inferMoveType move maybePromotionRank maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } +inferMoveType maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } move maybePromotionRank | Just sourcePiece <- byCoordinates ! Component.Move.getSource move = Data.Maybe.maybe ( - if isEnPassantMove move maybePieceByCoordinates + if isEnPassantMove maybePieceByCoordinates move then Attribute.MoveType.enPassant -- N.B.: if this move is valid, then one's opponent must have just double advanced an adjacent Pawn. else let destination = Component.Move.getDestination move in Attribute.MoveType.mkNormalMoveType ( - fmap Component.Piece.getRank $ byCoordinates ! destination -- Record the rank of any piece which was taken; the logical colour is inferred to be the opposite of 'sourcePiece'. - ) $ if Component.Piece.isPawnPromotion destination sourcePiece + Component.Piece.getRank <$> byCoordinates ! destination -- Record the rank of any piece which was taken; the logical colour is inferred to be the opposite of 'sourcePiece'. + ) $ if Component.Piece.isPawnPromotion sourcePiece destination then maybePromotionRank <|> Just Attribute.Rank.defaultPromotionRank else Nothing ) Component.CastlingMove.getMoveType $ if Component.Piece.isKing sourcePiece @@ -331,17 +347,18 @@ * CAVEAT: doesn't typically check whether anything (let alone the specified /piece/) exists at the specified source-/coordinates/. -} listDestinationsFor - :: Cartesian.Coordinates.Coordinates -- ^ The source for which destinations are required. + :: MaybePieceByCoordinates + -> Cartesian.Coordinates.Coordinates -- ^ The source for which destinations are required. -> Component.Piece.Piece -- ^ The /piece/ at the specified source. - -> MaybePieceByCoordinates -> [(Cartesian.Coordinates.Coordinates, Maybe Attribute.Rank.Rank)] -- ^ The destination & the rank of any piece taken. -listDestinationsFor source piece maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( +listDestinationsFor maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } source piece = Control.Exception.assert ( byCoordinates ! source == Just piece ) $ if Component.Piece.getRank piece `elem` Attribute.Rank.fixedAttackRange then {-P,N,K-} let + findAttackDestinations :: (Maybe Component.Piece.Piece -> Bool) -> [(Cartesian.Coordinates.Coordinates, Maybe Attribute.Rank.Rank)] findAttackDestinations predicate = [ - (destination, fmap Component.Piece.getRank maybeDestinationPiece) | - destination <- Component.Piece.findAttackDestinations source piece, + (destination, Component.Piece.getRank <$> maybeDestinationPiece) | + destination <- Component.Piece.findAttackDestinations piece source, let maybeDestinationPiece = byCoordinates ! destination, predicate maybeDestinationPiece ] -- List-comprehension. @@ -353,57 +370,56 @@ advance = Cartesian.Coordinates.advance logicalColour advancedLocation = advance source - in if isVacant advancedLocation maybePieceByCoordinates + in if isVacant maybePieceByCoordinates advancedLocation then map ( flip (,) Nothing -- N.B.: a Pawn can only take diagonally. ) $ advancedLocation : [ doubleAdvancedLocation | - Cartesian.Coordinates.isPawnsFirstRank logicalColour source, + Cartesian.Coordinates.isPawnsFirstRank source logicalColour, let doubleAdvancedLocation = advance advancedLocation, - isVacant doubleAdvancedLocation maybePieceByCoordinates + isVacant maybePieceByCoordinates doubleAdvancedLocation ] -- List-comprehension. else [] -- The path immediately ahead is blocked. else {-N,K-} findAttackDestinations . Data.Maybe.maybe True {-unoccupied-} $ (/= logicalColour) . Component.Piece.getLogicalColour else {-R,B,Q-} let + takeUntil :: [Cartesian.Coordinates.Coordinates] -> [(Cartesian.Coordinates.Coordinates, Maybe Attribute.Rank.Rank)] takeUntil (destination : remainder) - | Just blockingPiece <- byCoordinates ! destination = [ + | Just blockingPiece <- byCoordinates ! destination = [ ( destination, Just $ Component.Piece.getRank blockingPiece ) | Component.Piece.getLogicalColour blockingPiece /= logicalColour ] -- List-comprehension. - | otherwise = (destination, Nothing) : takeUntil remainder -- Recurse. - takeUntil _ = [] - in [ - pairs | - direction <- Component.Piece.getAttackDirections piece, - pairs <- takeUntil $ Cartesian.Coordinates.extrapolate direction source - ] -- List-comprehension. + | otherwise = (destination, Nothing) : takeUntil remainder -- Recurse. + takeUntil _ = [] + in Cartesian.Coordinates.applyAlongDirectionsFrom takeUntil source $ if Component.Piece.isQueen piece + then Nothing -- i.e. all directions. + else Just $ Component.Piece.getAttackDirections piece where logicalColour = Component.Piece.getLogicalColour piece -- | Show the /board/ in two dimensions, with /x/ & /y/ indexes. shows2D - :: Type.Length.Column -- ^ The column-magnification. - -> Attribute.ColourScheme.ColourScheme + :: MaybePieceByCoordinates + -> Type.Length.Column -- ^ The column-magnification. + -> Colour.ColourScheme.ColourScheme -> Bool -- ^ Whether to depict pieces as Unicode figurines. -> (Type.Length.X, Type.Length.Y) -- ^ The origin from which axes are labelled. - -> MaybePieceByCoordinates - -> ShowS -- ^ Output suitable for display on a terminal. -shows2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) MkMaybePieceByCoordinates { deconstruct = byCoordinates } = ( + -> ShowS -- ^ Output suitable for display on a terminal. +shows2D MkMaybePieceByCoordinates { deconstruct = byCoordinates } boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) = ( foldr ( \(y, pairs) showsRow -> showsRow . showString axisGraphicsRendition . showChar y . foldr ( \(coordinates, c) acc' -> showString ( - Attribute.ANSIColourCode.selectGraphicsRendition False {-isBold-} . Attribute.ANSIColourCode.mkBgColourCode $ ( - if Attribute.LogicalColourOfSquare.isBlack $ Cartesian.Coordinates.getLogicalColourOfSquare coordinates - then Attribute.ColourScheme.getDarkSquareColour - else Attribute.ColourScheme.getLightSquareColour + Colour.ANSIColourCode.selectGraphicsRendition False {-isBold-} . Colour.ANSIColourCode.mkBgColourCode $ ( + if Colour.LogicalColourOfSquare.isBlack $ Cartesian.Coordinates.getLogicalColourOfSquare coordinates + then Colour.ColourScheme.getDarkSquareColour + else Colour.ColourScheme.getLightSquareColour ) colourScheme ) . showString ( - Attribute.ANSIColourCode.selectGraphicsRendition True {-isBold-} . Attribute.ANSIColourCode.mkFgColourCode $ ( + Colour.ANSIColourCode.selectGraphicsRendition True {-isBold-} . Colour.ANSIColourCode.mkFgColourCode $ ( if Data.Char.isLower c {-Black-} - then Attribute.ColourScheme.getDarkPieceColour - else Attribute.ColourScheme.getLightPieceColour + then Colour.ColourScheme.getDarkPieceColour + else Colour.ColourScheme.getLightPieceColour ) colourScheme ) . let showPadding = showString (fromIntegral (pred boardColumnMagnification) `replicate` ' ') @@ -425,73 +441,102 @@ fromIntegral Cartesian.Abscissa.xLength ) . enumFrom . Data.Char.chr $ fromIntegral xOrigin ) where - axisGraphicsRendition :: Attribute.ANSIColourCode.GraphicsRendition - axisGraphicsRendition = Attribute.ANSIColourCode.selectGraphicsRendition True {-isBold-} $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.green + axisGraphicsRendition :: Colour.ANSIColourCode.GraphicsRendition + axisGraphicsRendition = Colour.ANSIColourCode.selectGraphicsRendition True {-isBold-} $ Colour.ANSIColourCode.mkFgColourCode Colour.PhysicalColour.green showsReset :: ShowS - showsReset = showString $ Attribute.ANSIColourCode.selectGraphicsRendition False Data.Default.def + showsReset = showString $ Colour.ANSIColourCode.selectGraphicsRendition False Data.Default.def -- | Show the board using a two-dimensional representation. show2D - :: Type.Length.Column -- ^ The column-magnification. - -> Attribute.ColourScheme.ColourScheme + :: MaybePieceByCoordinates + -> Type.Length.Column -- ^ The column-magnification. + -> Colour.ColourScheme.ColourScheme -> Bool -- ^ Whether to depict figurines. -> (Type.Length.X, Type.Length.Y) -- ^ The origin from which axes are labelled. - -> MaybePieceByCoordinates - -> String -- ^ The output suitable for display on a terminal. -show2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) maybePieceByCoordinates = shows2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) maybePieceByCoordinates "" + -> String -- ^ The output suitable for display on a terminal. +show2D maybePieceByCoordinates boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) = shows2D maybePieceByCoordinates boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) "" -- | Extract the pieces from the board, discarding their coordinates. getPieces :: MaybePieceByCoordinates -> [Component.Piece.Piece] getPieces MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.catMaybes $ Data.Foldable.toList byCoordinates {- | - * Find the first /piece/ of either /logical colour/, encountered along a straight line in the specified /direction/, from just after the specified /coordinates/. + * Find the first /piece/ of either /logical colour/, encountered in the specified /direction/, from just after the specified /coordinates/. * CAVEAT: this is a performance-hotspot. -} findBlockingPiece - :: Attribute.Direction.Direction -- ^ The direction in which to search. + :: MaybePieceByCoordinates -> Cartesian.Coordinates.Coordinates -- ^ The starting point. - -> MaybePieceByCoordinates - -> Maybe Component.Piece.LocatedPiece -findBlockingPiece direction source MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.listToMaybe [ - (coordinates, piece) | - (coordinates, Just piece) <- map (id &&& (byCoordinates !)) $ Cartesian.Coordinates.extrapolate direction source - ] -- List-comprehension. + -> Direction.Direction.Direction -- ^ The direction in which to search. + -> Maybe Component.Piece.LocatedPiece -- ^ Any blocking piece. +findBlockingPiece MkMaybePieceByCoordinates { deconstruct = byCoordinates } source = slave . Cartesian.Coordinates.extrapolate source where + slave :: [Cartesian.Coordinates.Coordinates] -> Maybe Component.Piece.LocatedPiece + slave (coordinates : remainder) + | Just blockingPiece <- byCoordinates ! coordinates = Just (coordinates, blockingPiece) -- Terminate with success. + | otherwise = slave remainder -- Recurse. + slave _ = Nothing -- Terminate with failure. {- | - * Find the /coordinates/ of any attacker who can strike the specified /coordinates/, in a straight line along the specified /direction/ (as seen by the target). + * Find the first /piece/ of either /logical colour/, encountered in each of the specified /direction/s, from just after the specified /coordinates/. + * N.B.: one could call 'findBlockingPiece' for each /direction/, but this function exploits optimisations available when all /direction/s are required. +-} +findBlockingPieces + :: MaybePieceByCoordinates + -> Cartesian.Coordinates.Coordinates -- ^ The starting point. + -> Maybe [Direction.Direction.Direction] -- ^ The directions in which to search; 'Nothing' implies omni-directional. + -> [Component.Piece.LocatedPiece] -- ^ Blocking pieces in non-specific directions. +findBlockingPieces MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Cartesian.Coordinates.applyAlongDirectionsFrom slave where + slave :: [Cartesian.Coordinates.Coordinates] -> [Component.Piece.LocatedPiece] + slave (coordinates : remainder) + | Just blockingPiece <- byCoordinates ! coordinates = [(coordinates, blockingPiece)] -- Terminate with success. + | otherwise = slave remainder -- Recurse. + slave _ = [] -- Terminate with failure. + +{- | + * Find the /coordinates/ of any attacker who can strike the specified /coordinates/, from the specified /direction/ (as seen by the target). + * N.B.: there no requirement for there to actually be a /piece/ to attack at the specified target. -} findAttackerInDirection - :: Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. - -> Attribute.Direction.Direction -- ^ The /direction/ from the /coordinates/ of concern; the opposite /direction/ from which an attacker might strike. + :: MaybePieceByCoordinates + -> Colour.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. -> Cartesian.Coordinates.Coordinates -- ^ The defender's square. - -> MaybePieceByCoordinates + -> Direction.Direction.Direction -- ^ The /direction/ from the /coordinates/ of concern; the opposite /direction/ from which an attacker might strike. -> Maybe (Cartesian.Coordinates.Coordinates, Attribute.Rank.Rank) -- ^ Any opposing /piece/ which can attack the specified square from the specified /direction/. -findAttackerInDirection destinationLogicalColour direction destination = (=<<) ( +findAttackerInDirection maybePieceByCoordinates destinationLogicalColour destination direction = findBlockingPiece maybePieceByCoordinates destination direction >>= \(source, sourcePiece) -> if Component.Piece.getLogicalColour sourcePiece /= destinationLogicalColour && Component.Piece.canAttackAlong source destination sourcePiece + then Just (source, Component.Piece.getRank sourcePiece) + else Nothing + +{- | + * Find the /coordinates/ of any attacker who can strike the specified /coordinates/, from the specified /direction/s (as seen by the target). + + * N.B.: one could call 'findAttackerInDirection' for each /direction/, but this function exploits optimisations available when all /direction/s are required. +-} +findAttackerInDirections + :: MaybePieceByCoordinates + -> Colour.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. + -> Cartesian.Coordinates.Coordinates -- ^ The defender's square. + -> Maybe [Direction.Direction.Direction] -- ^ The /direction/s from the /coordinates/ of concern; the opposite /direction/ from which an attacker might strike; 'Nothing' implies omni-directional. + -> [(Cartesian.Coordinates.Coordinates, Attribute.Rank.Rank)] -- ^ Any opposing /piece/s which can attack the specified square from the specified /direction/s. +findAttackerInDirections maybePieceByCoordinates destinationLogicalColour destination = Data.Maybe.mapMaybe ( \(source, sourcePiece) -> if Component.Piece.getLogicalColour sourcePiece /= destinationLogicalColour && Component.Piece.canAttackAlong source destination sourcePiece then Just (source, Component.Piece.getRank sourcePiece) else Nothing - ) . findBlockingPiece direction destination + ) . findBlockingPieces maybePieceByCoordinates destination -- | Whether the specified /coordinates/ are unoccupied. -isVacant - :: Cartesian.Coordinates.Coordinates - -> MaybePieceByCoordinates - -> Bool +isVacant :: MaybePieceByCoordinates -> Cartesian.Coordinates.Coordinates -> Bool {-# INLINE isVacant #-} -isVacant coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.isNothing $ byCoordinates ! coordinates +isVacant MkMaybePieceByCoordinates { deconstruct = byCoordinates } coordinates + | Nothing <- byCoordinates ! coordinates = True + | otherwise = False -- | Whether the specified /coordinates/ are occupied. -isOccupied - :: Cartesian.Coordinates.Coordinates - -> MaybePieceByCoordinates - -> Bool -{-# INLINE isOccupied #-} -isOccupied coordinates = not . isVacant coordinates +isOccupied :: MaybePieceByCoordinates -> Cartesian.Coordinates.Coordinates -> Bool +isOccupied maybePieceByCoordinates = not . isVacant maybePieceByCoordinates {- | * Whether the open interval (source, destination) is unobstructed. @@ -501,22 +546,21 @@ * N.B.: the specified end-points are uninspected. -} isClear - :: Cartesian.Coordinates.Coordinates -- ^ Source. + :: MaybePieceByCoordinates + -> Cartesian.Coordinates.Coordinates -- ^ Source. -> Cartesian.Coordinates.Coordinates -- ^ Destination. - -> MaybePieceByCoordinates -> Bool -{-# INLINABLE isClear #-} -- N.B.: required to ensure specialisation of 'Cartesian.Coordinates.interpolate'. -isClear source destination maybePieceByCoordinates = Control.Exception.assert ( +isClear maybePieceByCoordinates source destination = Control.Exception.assert ( source /= destination && Property.Orientated.isStraight (Component.Move.mkMove source destination) - ) . all (`isVacant` maybePieceByCoordinates) . init {-discard the destination-} $ Cartesian.Coordinates.interpolate source destination + ) . all (isVacant maybePieceByCoordinates) . init {-discard the destination-} $ Cartesian.Coordinates.interpolate source destination -- | Whether there's a blockage between a /piece/ presumed to exist at the specified source, & a /piece/ presumed to exist @ the specified destination. isObstructed - :: Cartesian.Coordinates.Coordinates -- ^ Source. + :: MaybePieceByCoordinates + -> Cartesian.Coordinates.Coordinates -- ^ Source. -> Cartesian.Coordinates.Coordinates -- ^ Destination. - -> MaybePieceByCoordinates -> Bool -isObstructed source destination = not . isClear source destination +isObstructed maybePieceByCoordinates source = not . isClear maybePieceByCoordinates source {- | * Whether the specified /move/ matches the rules for /en-passant/. @@ -524,40 +568,12 @@ * CAVEAT: assumes that the /move/ is valid; otherwise one would also need to confirm that the opponent's @Pawn@ had just double-advanced into the appropriate position. -} -isEnPassantMove - :: Component.Move.Move - -> MaybePieceByCoordinates - -> Bool -isEnPassantMove move maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } +isEnPassantMove :: MaybePieceByCoordinates -> Component.Move.Move -> Bool +isEnPassantMove maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } move | Just piece <- byCoordinates ! source , let logicalColour = Component.Piece.getLogicalColour piece - = Cartesian.Coordinates.isEnPassantRank logicalColour source && Component.Piece.isPawn piece && destination `elem` Component.Piece.findAttackDestinations source piece && isVacant destination maybePieceByCoordinates -- The move is either En-passant or invalid. + = Cartesian.Coordinates.isEnPassantRank source logicalColour && Component.Piece.isPawn piece && destination `elem` Component.Piece.findAttackDestinations piece source && isVacant maybePieceByCoordinates destination -- The move is either En-passant or invalid. | otherwise = False -- No piece. where (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move - --- | Self-documentation. -type Transformation = MaybePieceByCoordinates -> MaybePieceByCoordinates - -{- | - * Adjust the array to reflect a move. - - * CAVEAT: regrettably this allocates an entire array. --} -movePiece - :: Component.Move.Move - -> Component.Piece.Piece -- ^ The (possibly promoted) piece to place at the destination. - -> Maybe Cartesian.Coordinates.Coordinates -- ^ Destination of any En-passant @Pawn@. - -> Transformation -movePiece move destinationPiece maybeEnPassantDestination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = MkMaybePieceByCoordinates $ byCoordinates // Data.Maybe.maybe id ( - (:) . flip (,) Nothing -- Take the Pawn en-passant. - ) maybeEnPassantDestination [ - ( - Component.Move.getSource move, - Nothing -- Remove the piece from the source. - ), ( - Component.Move.getDestination move, - Just destinationPiece -- Place the piece at the destination, removing any opposing incumbent as a side-effect. - ) - ] diff --git a/src-lib/BishBosh/State/Position.hs b/src-lib/BishBosh/State/Position.hs --- a/src-lib/BishBosh/State/Position.hs +++ b/src-lib/BishBosh/State/Position.hs @@ -43,7 +43,7 @@ mkPosition ) where -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Property.Opposable as Property.Opposable @@ -53,11 +53,10 @@ import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified Control.DeepSeq -import qualified Data.Maybe -- | The state of the game, without regard to how it arrived there. data Position = MkPosition { - getNextLogicalColour :: Attribute.LogicalColour.LogicalColour, -- ^ The next player to move. + getNextLogicalColour :: Colour.LogicalColour.LogicalColour, -- ^ The next player to move. getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates, getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, getMaybeEnPassantAbscissa :: Maybe State.EnPassantAbscissa.EnPassantAbscissa @@ -102,25 +101,23 @@ } instance StateProperty.Hashable.Hashable Position where - listRandoms MkPosition { + listRandoms zobrist MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getMaybeEnPassantAbscissa = maybeEnPassantAbscissa - } zobrist = ( - if Attribute.LogicalColour.isBlack nextLogicalColour + } = ( + if Colour.LogicalColour.isBlack nextLogicalColour then (Component.Zobrist.getRandomForBlacksMove zobrist :) else id - ) . Data.Maybe.maybe id ( - (++) . (`StateProperty.Hashable.listRandoms` zobrist) - ) maybeEnPassantAbscissa $ StateProperty.Hashable.listRandoms castleableRooksByLogicalColour zobrist ++ StateProperty.Hashable.listRandoms maybePieceByCoordinates zobrist + ) $ StateProperty.Hashable.listRandoms zobrist (maybeEnPassantAbscissa, castleableRooksByLogicalColour, maybePieceByCoordinates) -- | Constructor. mkPosition - :: Attribute.LogicalColour.LogicalColour -- ^ The logical colour of the next player to move. + :: Colour.LogicalColour.LogicalColour -- ^ The logical colour of the next player to move. -> State.MaybePieceByCoordinates.MaybePieceByCoordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour - -> Maybe Component.Turn.Turn -- ^ The last /turn/ made. + -> Maybe Component.Turn.Turn -- ^ The last /turn/ made. -> Position mkPosition nextLogicalColour maybePieceByCoordinates castleableRooksByLogicalColour maybeLastTurn = MkPosition { getNextLogicalColour = nextLogicalColour, diff --git a/src-lib/BishBosh/State/TurnsByLogicalColour.hs b/src-lib/BishBosh/State/TurnsByLogicalColour.hs --- a/src-lib/BishBosh/State/TurnsByLogicalColour.hs +++ b/src-lib/BishBosh/State/TurnsByLogicalColour.hs @@ -45,13 +45,13 @@ import Control.Arrow((&&&), (***)) import Data.Array.IArray((!), (//)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -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 BishBosh.Type.Count as Type.Count +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +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 BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -62,7 +62,7 @@ -- | The type used to hold a record of each player's /turn/s. data TurnsByLogicalColour turn = MkTurnsByLogicalColour { - getTurnsByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [turn], + getTurnsByLogicalColour :: Colour.LogicalColour.ArrayByLogicalColour [turn], getNPlies :: Type.Count.NPlies -- ^ The total number of plies applied to the game for both players; this could alternatively be derived using 'countPlies'. } @@ -80,7 +80,7 @@ instance Data.Default.Default (TurnsByLogicalColour turn) where def = MkTurnsByLogicalColour { - getTurnsByLogicalColour = Attribute.LogicalColour.listArrayByLogicalColour $ repeat [], + getTurnsByLogicalColour = Colour.LogicalColour.listArrayByLogicalColour $ repeat [], getNPlies = 0 } @@ -93,24 +93,24 @@ instance Property.Reflectable.ReflectableOnX turn => Property.Reflectable.ReflectableOnX (TurnsByLogicalColour turn) where reflectOnX turnsByLogicalColour@MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = turnsByLogicalColour { - getTurnsByLogicalColour = Attribute.LogicalColour.arrayByLogicalColour . map ( + getTurnsByLogicalColour = Colour.LogicalColour.arrayByLogicalColour . map ( Property.Opposable.getOpposite {-logical colour-} *** Property.Reflectable.reflectOnX {-[turn]-} ) $ Data.Array.IArray.assocs byLogicalColour } -- | Smart constructor. -fromAssocs :: Show turn => [(Attribute.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn +fromAssocs :: Show turn => [(Colour.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn fromAssocs assocs | fromIntegral ( 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 {-logicalColour-} assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tduplicates specified; " $ shows assocs "." + ) /= Colour.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 {-logicalColour-} assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tduplicates specified; " $ shows assocs "." | (> 1) . abs {-allow for Property.Reflectable.reflectOnX-} . 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 + length . (! Colour.LogicalColour.White) &&& length . (! Colour.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 = Attribute.LogicalColour.arrayByLogicalColour assocs + byLogicalColour = Colour.LogicalColour.arrayByLogicalColour assocs turnsByLogicalColour = MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour, getNPlies = countPlies turnsByLogicalColour -- Infer. @@ -121,10 +121,10 @@ * CAVEAT: the result can't be guaranteed if 'Property.Reflectable.reflectOnX' has been called. -} -inferNextLogicalColour :: TurnsByLogicalColour turn -> Attribute.LogicalColour.LogicalColour +inferNextLogicalColour :: TurnsByLogicalColour turn -> Colour.LogicalColour.LogicalColour inferNextLogicalColour MkTurnsByLogicalColour { getNPlies = nPlies } - | even nPlies = Attribute.LogicalColour.White - | otherwise = Attribute.LogicalColour.Black + | even nPlies = Colour.LogicalColour.White + | otherwise = Colour.LogicalColour.Black {- | * Count the total number of plies, regardless of the player. @@ -135,26 +135,26 @@ countPlies MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = fromIntegral $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 byLogicalColour -- | Dereference. -dereference :: Attribute.LogicalColour.LogicalColour -> TurnsByLogicalColour turn -> [turn] -dereference logicalColour MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = byLogicalColour ! logicalColour +dereference :: TurnsByLogicalColour turn -> Colour.LogicalColour.LogicalColour -> [turn] +dereference MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } logicalColour = byLogicalColour ! logicalColour +-- | Self-documentation. +type Transformation turn = TurnsByLogicalColour turn -> TurnsByLogicalColour turn + {- | * Update the specified logical colours. * CAVEAT: obliterates any incumbent data for the specified logical colours. -} -update :: TurnsByLogicalColour turn -> [(Attribute.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn -update MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } assocs = turnsByLogicalColour where +update :: [(Colour.LogicalColour.LogicalColour, [turn])] -> Transformation turn +update assocs MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = turnsByLogicalColour where turnsByLogicalColour = MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour // assocs, getNPlies = countPlies turnsByLogicalColour -- Infer. } --- | Self-documentation. -type Transformation turn = TurnsByLogicalColour turn -> TurnsByLogicalColour turn - -- | Prepend the specified /turn/. -prepend :: Attribute.LogicalColour.LogicalColour -> turn -> Transformation turn +prepend :: Colour.LogicalColour.LogicalColour -> turn -> Transformation turn prepend logicalColour turn MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour, getNPlies = nPlies diff --git a/src-lib/BishBosh/StateProperty/Censor.hs b/src-lib/BishBosh/StateProperty/Censor.hs --- a/src-lib/BishBosh/StateProperty/Censor.hs +++ b/src-lib/BishBosh/StateProperty/Censor.hs @@ -27,11 +27,16 @@ -- ** Type-synonyms NPiecesByRank, -- * Type-classes - Censor(..) + Censor(..), +-- * Functions + findInvalidity ) where -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Type.Count as Type.Count +import Control.Arrow((&&&), (***)) +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating +import qualified BishBosh.Type.Count as Type.Count -- | The difference in the number of /piece/s of each /rank/ held by either side. type NPiecesByRank = Attribute.Rank.ArrayByRank Type.Count.NPieces @@ -48,4 +53,18 @@ hasInsufficientMaterial :: censor -> Bool -- ^ Whether insufficient material remains on the board, to force check-mate; . hasBothKings :: censor -> Bool -- ^ Whether there's exactly one @King@ of each /logical colour/. + +-- | Self-validate. +findInvalidity :: Censor censor => censor -> [String] +findInvalidity = Property.SelfValidating.findErrors [ + ( + not . hasBothKings, + "there must be exactly one King of each logical colour." + ), ( + uncurry (||) . uncurry (***) ( + id &&& id $ (> Component.Piece.nPiecesPerSide) + ) . countPiecesByLogicalColour, + "there are too many pieces of at least one logical colour." + ) + ] diff --git a/src-lib/BishBosh/StateProperty/Hashable.hs b/src-lib/BishBosh/StateProperty/Hashable.hs --- a/src-lib/BishBosh/StateProperty/Hashable.hs +++ b/src-lib/BishBosh/StateProperty/Hashable.hs @@ -28,7 +28,7 @@ module BishBosh.StateProperty.Hashable( -- * Type-classes - Hashable(..), + Hashable(listRandoms), -- * Constants -- combiningOp, -- * Functions @@ -36,14 +36,28 @@ combine ) where +import Control.Arrow((***)) import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified Data.Bits import qualified Data.List +import qualified Data.Maybe -- | An interface to which hashable data can conform. class Hashable hashable where - listRandoms :: hashable -> Component.Zobrist.Zobrist positionHash -> [positionHash] + listRandoms :: Component.Zobrist.Zobrist positionHash -> hashable -> [positionHash] +instance (Hashable l, Hashable r) => Hashable (l, r) where + listRandoms zobrist = uncurry (++) . (listRandoms zobrist *** listRandoms zobrist) + +instance (Hashable f, Hashable s, Hashable t) => Hashable (f, s, t) where + listRandoms zobrist (f, s, t) = listRandoms zobrist f ++ listRandoms zobrist s ++ listRandoms zobrist t + +instance Hashable a => Hashable [a] where + listRandoms zobrist = concatMap $ listRandoms zobrist + +instance Hashable a => Hashable (Maybe a) where + listRandoms zobrist = Data.Maybe.maybe [] $ listRandoms zobrist + -- | The operator used when combining random numbers to compose a hash. combiningOp :: Data.Bits.Bits positionHash => positionHash -> positionHash -> positionHash combiningOp = Data.Bits.xor @@ -53,10 +67,10 @@ Data.Bits.Bits positionHash, Hashable hashable ) - => hashable - -> Component.Zobrist.Zobrist positionHash + => Component.Zobrist.Zobrist positionHash + -> hashable -> positionHash -hash hashable = Data.List.foldl1' combiningOp . listRandoms hashable +hash zobrist = Data.List.foldl1' combiningOp . listRandoms zobrist -- | Include a list of random numbers in the hash. combine :: Data.Bits.Bits positionHash => positionHash -> [positionHash] -> positionHash diff --git a/src-lib/BishBosh/StateProperty/Mutator.hs b/src-lib/BishBosh/StateProperty/Mutator.hs --- a/src-lib/BishBosh/StateProperty/Mutator.hs +++ b/src-lib/BishBosh/StateProperty/Mutator.hs @@ -34,26 +34,40 @@ removePiece ) where +import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Property.Empty as Property.Empty {- | - * Defines the specified /coordinates/, by either placing or removing a /piece/. - - * CAVEAT: this function should only be used to construct custom scenarios, since /piece/s don't normally spring into existence. - - * CAVEAT: doesn't validate the request, so @King@s can be placed /in check/ & @Pawn@s can be placed behind their starting rank or unpromoted on their last /rank/. + * An interface which may be implemented by data which can mutate the board. - * CAVEAT: this function isn't called during normal play. + * CAVEAT: doesn't validate requests, so @King@s can be placed /in check/ & @Pawn@s can be placed behind their starting rank or unpromoted on their last /rank/. -} class Mutator mutator where + {- | + * Defines the specified /coordinates/, by either placing or removing a /piece/. + + * CAVEAT: this function should only be used to construct custom scenarios, since /piece/s don't normally spring into existence. + + * CAVEAT: this function isn't called during normal play. + -} defineCoordinates :: Maybe Component.Piece.Piece -- ^ The optional /piece/ to place (or remove if @Nothing@ is specified). -> Cartesian.Coordinates.Coordinates -- ^ The /coordinates/ to define. -> mutator -> mutator + -- | Move the specified piece, accounting for promotions & casualties. + movePiece + :: Component.Move.Move -- ^ The source & destination /coordinates/. + -> Component.Piece.Piece -- ^ The /piece/ which moved. + -> Maybe Attribute.Rank.Rank -- ^ The (possibly promoted) /rank/ to place at the destination. + -> Either Cartesian.Coordinates.Coordinates (Maybe Attribute.Rank.Rank) -- ^ Either the /coordinates/ of any @Pawn@ which was just captured en-passant, or the /rank/ of any /piece/ taken. + -> mutator + -> mutator + {- | * Place a /piece/ at the specified /coordinates/. @@ -93,5 +107,4 @@ -> mutator -> mutator removePiece = defineCoordinates Nothing - diff --git a/src-lib/BishBosh/StateProperty/Seeker.hs b/src-lib/BishBosh/StateProperty/Seeker.hs --- a/src-lib/BishBosh/StateProperty/Seeker.hs +++ b/src-lib/BishBosh/StateProperty/Seeker.hs @@ -33,19 +33,25 @@ -- * Functions accumulatePawnsByFile, findAllPieces, - summariseNPawnsByLogicalColour + summariseNPawnsByLogicalColour, + findInvalidity ) where -import Control.Arrow((***)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import Control.Arrow((&&&), (***)) +import Data.Array.IArray((!)) +import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Data.Array.IArray import qualified Data.Foldable +import qualified Data.List import qualified Data.Map.Strict as Map -- | The number of /piece/s in each file, for each /logical colour/. @@ -57,15 +63,15 @@ accumulatePawnsByFile = flip (Map.insertWith $ const succ) 1 -- | The number of /piece/s in each file, for each /logical colour/. -type NPiecesByFileByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour NPiecesByFile +type NPiecesByFileByLogicalColour = Colour.LogicalColour.ArrayByLogicalColour NPiecesByFile -- | An interface which may be implemented by data which can search the board. class Seeker seeker where -- | Locate any @Knight@s capable of taking a /piece/ at the specified /coordinates/. findProximateKnights - :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @Knight@ for which to search. - -> Cartesian.Coordinates.Coordinates -- ^ The destination to which the @Knight@ is required to be capable of jumping. - -> seeker + :: seeker + -> Colour.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @Knight@ for which to search. + -> Cartesian.Coordinates.Coordinates -- ^ The destination to which the @Knight@ is required to be capable of jumping. -> [Cartesian.Coordinates.Coordinates] -- | Locate any /piece/s satisfying the specified predicate. @@ -81,14 +87,14 @@ -} countPawnsByFileByLogicalColour :: seeker -> NPiecesByFileByLogicalColour countPawnsByFileByLogicalColour = ( - \(mB, mW) -> Attribute.LogicalColour.listArrayByLogicalColour [mB, mW] + \(mB, mW) -> Colour.LogicalColour.listArrayByLogicalColour [mB, mW] ) . foldr ( ( \(x, isBlack) -> ( if isBlack then Control.Arrow.first else Control.Arrow.second -- Select the appropriate map. ) $ accumulatePawnsByFile x ) . ( - Cartesian.Coordinates.getX *** Attribute.LogicalColour.isBlack . Component.Piece.getLogicalColour + Cartesian.Coordinates.getX *** Colour.LogicalColour.isBlack . Component.Piece.getLogicalColour ) ) Property.Empty.empty . findPieces Component.Piece.isPawn @@ -97,8 +103,28 @@ findAllPieces = findPieces $ const True -- | Resolves 'NPiecesByFileByLogicalColour' into the total number of /Pawn/s on either side. -summariseNPawnsByLogicalColour :: Seeker seeker => seeker -> Attribute.LogicalColour.ArrayByLogicalColour Type.Count.NPieces +summariseNPawnsByLogicalColour :: Seeker seeker => seeker -> Colour.LogicalColour.ArrayByLogicalColour Type.Count.NPieces summariseNPawnsByLogicalColour = Data.Array.IArray.amap ( Data.Foldable.foldl' (+) 0 ) . countPawnsByFileByLogicalColour + +-- | Self-validate. +findInvalidity :: Seeker seeker => seeker -> [String] +findInvalidity = Property.SelfValidating.findErrors [ + ( + uncurry (||) . uncurry (***) ( + id &&& id $ (> Attribute.Rank.initialAllocationByRankPerSide ! Attribute.Rank.Pawn) . fromIntegral . length + ) . Data.List.partition ( + Colour.LogicalColour.isBlack . Component.Piece.getLogicalColour + ) . map snd {-piece-} . findPieces Component.Piece.isPawn, + "there are too many Pawns of at least one logical colour." + ), ( + any ( + uncurry (||) . uncurry (&&&) ( + (==) *** (==) $ Cartesian.Ordinate.yBounds + ) . Cartesian.Coordinates.getY . fst {-coordinates-} + ) . findPieces Component.Piece.isPawn, + "no Pawn can exist on either of the terminal ranks." + ) + ] diff --git a/src-lib/BishBosh/StateProperty/View.hs b/src-lib/BishBosh/StateProperty/View.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/StateProperty/View.hs @@ -0,0 +1,48 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Permits construction & destruction of views of the board. +-} + +module BishBosh.StateProperty.View( +-- * Type-classes + View(..), +-- * Functions + toAssocs, + translate +) where + +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker + +-- | An interface which may be implemented by data which represent a view of the board. +class View view where + -- | Constructor. + fromAssocs :: [Component.Piece.LocatedPiece] -> view + +-- | Deconstructor. +toAssocs :: StateProperty.Seeker.Seeker seeker => seeker -> [Component.Piece.LocatedPiece] +toAssocs = StateProperty.Seeker.findAllPieces + +-- | Convert between implementations. +translate :: (StateProperty.Seeker.Seeker seeker, View view) => seeker -> view +translate = fromAssocs . toAssocs + diff --git a/src-lib/BishBosh/Text/ShowColouredPrefix.hs b/src-lib/BishBosh/Text/ShowColouredPrefix.hs --- a/src-lib/BishBosh/Text/ShowColouredPrefix.hs +++ b/src-lib/BishBosh/Text/ShowColouredPrefix.hs @@ -29,25 +29,25 @@ showsPrefixError ) where -import qualified BishBosh.Attribute.ANSIColourCode as Attribute.ANSIColourCode -import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour -import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix +import qualified BishBosh.Colour.ANSIColourCode as Colour.ANSIColourCode +import qualified BishBosh.Colour.PhysicalColour as Colour.PhysicalColour +import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix -- | Show the prefix used to denote an information-message. showsPrefixInfo :: ShowS -showsPrefixInfo = Attribute.ANSIColourCode.bracket ( - Attribute.ANSIColourCode.selectGraphicsRendition False $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.green +showsPrefixInfo = Colour.ANSIColourCode.bracket ( + Colour.ANSIColourCode.selectGraphicsRendition False $ Colour.ANSIColourCode.mkFgColourCode Colour.PhysicalColour.green ) $ Text.ShowPrefix.showsPrefixInfo "" -- | Show the prefix used to denote a warning-message. showsPrefixWarning :: ShowS -showsPrefixWarning = Attribute.ANSIColourCode.bracket ( - Attribute.ANSIColourCode.selectGraphicsRendition True $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.yellow +showsPrefixWarning = Colour.ANSIColourCode.bracket ( + Colour.ANSIColourCode.selectGraphicsRendition True $ Colour.ANSIColourCode.mkFgColourCode Colour.PhysicalColour.yellow ) $ Text.ShowPrefix.showsPrefixWarning "" -- | Show the prefix used to denote an error-message. showsPrefixError :: ShowS -showsPrefixError = Attribute.ANSIColourCode.bracket ( - Attribute.ANSIColourCode.selectGraphicsRendition True $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.red +showsPrefixError = Colour.ANSIColourCode.bracket ( + Colour.ANSIColourCode.selectGraphicsRendition True $ Colour.ANSIColourCode.mkFgColourCode Colour.PhysicalColour.red ) $ Text.ShowPrefix.showsPrefixError "" diff --git a/src-lib/BishBosh/Time/GameClock.hs b/src-lib/BishBosh/Time/GameClock.hs --- a/src-lib/BishBosh/Time/GameClock.hs +++ b/src-lib/BishBosh/Time/GameClock.hs @@ -34,10 +34,10 @@ ) where import Control.Arrow((***)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Property.SelfValidating as Property.SelfValidating +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Property.Switchable as Property.Switchable import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Time.StopWatch as Time.StopWatch @@ -49,12 +49,12 @@ -- | Models a game-clock, in which each player owns a personal stop-watch, exactly one of which is running at any one time. newtype GameClock = MkGameClock { - deconstruct :: Attribute.LogicalColour.ArrayByLogicalColour Time.StopWatch.StopWatch -- ^ Contains one stop-watch for each of two players. + deconstruct :: Colour.LogicalColour.ArrayByLogicalColour Time.StopWatch.StopWatch -- ^ Contains one stop-watch for each of two players. } instance Property.Switchable.Switchable GameClock where on = fmap ( - MkGameClock . Attribute.LogicalColour.listArrayByLogicalColour . ( + MkGameClock . Colour.LogicalColour.listArrayByLogicalColour . ( Data.Default.def : -- A stopped watch for Black. ) . return {-to List-monad-} ) Property.Switchable.on -- A running watch for White. @@ -62,11 +62,11 @@ toggle gameClock | errorMessages@(_ : _) <- Property.SelfValidating.findInvalidity gameClock = Control.Exception.throwIO . Data.Exception.mkInsufficientData . showString "Duel.Process.Intermediary.initialise:\tinvalid gameClock; " $ show errorMessages | otherwise = fmap ( - MkGameClock . Attribute.LogicalColour.listArrayByLogicalColour + MkGameClock . Colour.LogicalColour.listArrayByLogicalColour ) . mapM Property.Switchable.toggle . Data.Foldable.toList $ deconstruct gameClock switchOff = fmap ( - MkGameClock . Attribute.LogicalColour.listArrayByLogicalColour + MkGameClock . Colour.LogicalColour.listArrayByLogicalColour ) . mapM Property.Switchable.switchOff . Data.Foldable.toList . deconstruct -- CAVEAT: this invalidates the clock, since a subsequent call to 'toggle' would activate both stop-watches. isOn = Data.Foldable.any Property.Switchable.isOn . deconstruct -- CAVEAT: includes the dysfunctional state in which both sides are running. diff --git a/src-lib/BishBosh/Type/Crypto.hs b/src-lib/BishBosh/Type/Crypto.hs --- a/src-lib/BishBosh/Type/Crypto.hs +++ b/src-lib/BishBosh/Type/Crypto.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {- - Copyright (C) 2018 Dr. Alistair Ward + Copyright (C) 2021 Dr. Alistair Ward This file is part of BishBosh. @@ -22,7 +22,7 @@ [@DESCRIPTION@] - * Defines suitable concrete types with which to specialise miscellaneous type-parameters. + * Defines suitable types for various quantities. * CAVEAT: use of narrow numeric types, results in marginally slower performance without any reduction in space-requirements. -} @@ -30,7 +30,7 @@ module BishBosh.Type.Crypto( -- * Types -- ** Type-synonyms - PositionHash, + PositionHash ) where import qualified Data.Word diff --git a/src-lib/BishBosh/Type/Mass.hs b/src-lib/BishBosh/Type/Mass.hs --- a/src-lib/BishBosh/Type/Mass.hs +++ b/src-lib/BishBosh/Type/Mass.hs @@ -31,21 +31,32 @@ module BishBosh.Type.Mass( -- * Types -- ** Type-synonyms + Base, CriterionWeight, CriterionValue, WeightedMean, RankValue, - PieceSquareValue + PieceSquareValue(), +-- * Functions +-- ** Constructors +-- mkPieceSquareValue ) where +#ifdef USE_NEWTYPE_WRAPPERS +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Num as Data.Num +import qualified Control.DeepSeq +import qualified Control.Exception +#endif + #ifdef USE_PRECISION import BishBosh.Data.Ratio() #else import qualified Text.XML.HXT.Arrow.Pickle as HXT #endif --- | The preferred type by which to weight criteria. -type CriterionWeight = +-- | The underling type. +type Base = #ifdef USE_PRECISION Rational #else /* Floating-point */ @@ -62,19 +73,49 @@ # endif #endif --- | The preferred type by which to value criteria. +-- | The type by which to weight criteria. +type CriterionWeight = Base + +-- | The type by which to value criteria. type CriterionValue = CriterionWeight --- | The preferred type by which to represent fitness. +-- | The type by which to represent fitness. type WeightedMean = CriterionValue --- | The preferred type by which to represent the value of a /rank/. -type RankValue = CriterionValue +-- | The type by which to represent the value of a /rank/. +type RankValue = Base -{- | - * The preferred type by which to represent a /piece-square/ value. +-- | The type by which to represent a /piece-square/ value. +#ifdef USE_NEWTYPE_WRAPPERS +newtype PieceSquareValue = MkPieceSquareValue Base deriving (Eq, Ord) - * CAVEAT: performance of 'BishBosh.Evaluation.Fitness.interpolatePieceSquareValues' suffers from use of 'Rational'. --} -type PieceSquareValue = CriterionValue +instance Show PieceSquareValue where + showsPrec precision (MkPieceSquareValue pieceSquareValue) = showsPrec precision pieceSquareValue + +instance Num PieceSquareValue where + MkPieceSquareValue l + MkPieceSquareValue r = mkPieceSquareValue $! l + r + MkPieceSquareValue l * MkPieceSquareValue r = MkPieceSquareValue $! l * r + abs (MkPieceSquareValue pieceSquareValue) = MkPieceSquareValue $! abs pieceSquareValue -- N.B.: if the operand is valid, then this is equivalent to 'id'. + signum (MkPieceSquareValue pieceSquareValue) = MkPieceSquareValue $! signum pieceSquareValue + fromInteger = mkPieceSquareValue . fromInteger + negate (MkPieceSquareValue pieceSquareValue) = mkPieceSquareValue $! negate pieceSquareValue -- CAVEAT: only valid for '0'. + +instance Fractional PieceSquareValue where + MkPieceSquareValue l / MkPieceSquareValue r = mkPieceSquareValue $! l / r -- CAVEAT: it's hard to concoct a scenario in which neither the numerator, denominator nor result are invalid. + fromRational = mkPieceSquareValue . fromRational + +instance Real PieceSquareValue where + toRational (MkPieceSquareValue pieceSquareValue) = toRational pieceSquareValue + +instance Control.DeepSeq.NFData PieceSquareValue where + rnf (MkPieceSquareValue pieceSquareValue) = Control.DeepSeq.rnf pieceSquareValue + +-- | Smart constructor. +mkPieceSquareValue :: Base -> PieceSquareValue +mkPieceSquareValue pieceSquareValue + | Data.Num.inClosedUnitInterval pieceSquareValue = MkPieceSquareValue pieceSquareValue + | otherwise = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Type.Mass.mkPieceSquareValue:\t" $ shows pieceSquareValue " must be within the closed unit-interval [0,1]." +#else +type PieceSquareValue = Base +#endif diff --git a/src-test/BishBosh/Test/HUnit/Attribute/Direction.hs b/src-test/BishBosh/Test/HUnit/Attribute/Direction.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/HUnit/Attribute/Direction.hs +++ /dev/null @@ -1,46 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Static tests. --} - -module BishBosh.Test.HUnit.Attribute.Direction( --- * Constants - testCases -) where - -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified Data.List -import qualified Test.HUnit -import Test.HUnit((~?)) - --- | Check the sanity of the implementation, by validating a list of static test-cases. -testCases :: Test.HUnit.Test -testCases = Test.HUnit.test [ - null ( - Attribute.Direction.diagonals `Data.List.intersect` Attribute.Direction.parallels - ) ~? "BishBosh.Attribute.Direction.[diagonal, parallels] intersect.", - all ( - (== 2) . length . Attribute.Direction.attackDirectionsForPawn - ) Property.FixedMembership.members ~? "'BishBosh.Attribute.Direction.attackDirectionsForPawn' failed." - ] - diff --git a/src-test/BishBosh/Test/HUnit/Attribute/LogicalColour.hs b/src-test/BishBosh/Test/HUnit/Attribute/LogicalColour.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/HUnit/Attribute/LogicalColour.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Static tests. --} - -module BishBosh.Test.HUnit.Attribute.LogicalColour( --- * Constants - testCases -) where - -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified Data.List -import qualified Test.HUnit -import Test.HUnit((~?)) - --- | Check the sanity of the implementation, by validating a list of static test-cases. -testCases :: Test.HUnit.Test -testCases = Test.HUnit.test [ - Property.FixedMembership.members == Data.List.sort Attribute.LogicalColour.range ~? "BishBosh.Attribute.LogicalColour.range is misordered." - ] - diff --git a/src-test/BishBosh/Test/HUnit/Cartesian/Coordinates.hs b/src-test/BishBosh/Test/HUnit/Cartesian/Coordinates.hs --- a/src-test/BishBosh/Test/HUnit/Cartesian/Coordinates.hs +++ b/src-test/BishBosh/Test/HUnit/Cartesian/Coordinates.hs @@ -27,9 +27,9 @@ testCases ) where -import qualified BishBosh.Attribute.LogicalColourOfSquare as Attribute.LogicalColourOfSquare -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColourOfSquare as Colour.LogicalColourOfSquare +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified Data.Array.IArray import qualified Data.List import qualified Test.HUnit @@ -38,12 +38,12 @@ -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ - all (Attribute.LogicalColourOfSquare.isBlack . Cartesian.Coordinates.getLogicalColourOfSquare) ( - Cartesian.Coordinates.extrapolate maxBound {-direction-} (minBound :: Cartesian.Coordinates.Coordinates) + all (Colour.LogicalColourOfSquare.isBlack . Cartesian.Coordinates.getLogicalColourOfSquare) ( + Cartesian.Coordinates.extrapolate (minBound :: Cartesian.Coordinates.Coordinates) maxBound {-direction-} ) ~? "'BishBosh.Cartesian.Coordinates.getLogicalColourOfSquare' failed to find black squares on the main diagonal.", "'BishBosh.Cartesian.Coordinates.getLogicalColourOfSquare' failed to count equal numbers of black & white squares." ~: ( \(black, white) -> length black ~?= length white - ) . Data.List.partition Attribute.LogicalColourOfSquare.isBlack $ map Cartesian.Coordinates.getLogicalColourOfSquare ( + ) . Data.List.partition Colour.LogicalColourOfSquare.isBlack $ map Cartesian.Coordinates.getLogicalColourOfSquare ( Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates] ), "'BishBosh.Cartesian.Coordinates' failed to visit all squares." ~: length ( diff --git a/src-test/BishBosh/Test/HUnit/Colour/LogicalColour.hs b/src-test/BishBosh/Test/HUnit/Colour/LogicalColour.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/HUnit/Colour/LogicalColour.hs @@ -0,0 +1,41 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Static tests. +-} + +module BishBosh.Test.HUnit.Colour.LogicalColour( +-- * Constants + testCases +) where + +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified Data.List +import qualified Test.HUnit +import Test.HUnit((~?)) + +-- | Check the sanity of the implementation, by validating a list of static test-cases. +testCases :: Test.HUnit.Test +testCases = Test.HUnit.test [ + Property.FixedMembership.members == Data.List.sort Colour.LogicalColour.range ~? "BishBosh.Colour.LogicalColour.range is misordered." + ] + diff --git a/src-test/BishBosh/Test/HUnit/Component/Move.hs b/src-test/BishBosh/Test/HUnit/Component/Move.hs --- a/src-test/BishBosh/Test/HUnit/Component/Move.hs +++ b/src-test/BishBosh/Test/HUnit/Component/Move.hs @@ -27,10 +27,10 @@ testCases ) where -import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Direction.Direction as Direction.Direction import qualified BishBosh.Notation.Smith as Notation.Smith import qualified Test.HUnit import Test.HUnit((~?)) @@ -42,32 +42,32 @@ \(direction, s) -> let move :: Component.Move.Move move = Component.QualifiedMove.getMove . Notation.Smith.getQualifiedMove $ read s - in Cartesian.Coordinates.extrapolate direction (Component.Move.getSource move) == Component.Move.interpolate move + in Cartesian.Coordinates.extrapolate (Component.Move.getSource move) direction == Component.Move.interpolate move ) [ ( - Attribute.Direction.ne, "a1h8" + Direction.Direction.ne, "a1h8" ), ( - Attribute.Direction.n, "a1a8" + Direction.Direction.n, "a1a8" ), ( - Attribute.Direction.e, "a1h1" + Direction.Direction.e, "a1h1" ), ( - Attribute.Direction.se, "a8h1" + Direction.Direction.se, "a8h1" ), ( - Attribute.Direction.s, "a8a1" + Direction.Direction.s, "a8a1" ), ( - Attribute.Direction.e, "a8h8" + Direction.Direction.e, "a8h8" ), ( - Attribute.Direction.sw, "h8a1" + Direction.Direction.sw, "h8a1" ), ( - Attribute.Direction.s, "h8h1" + Direction.Direction.s, "h8h1" ), ( - Attribute.Direction.w, "h8a8" + Direction.Direction.w, "h8a8" ), ( - Attribute.Direction.nw, "h1a8" + Direction.Direction.nw, "h1a8" ), ( - Attribute.Direction.n, "h1h8" + Direction.Direction.n, "h1h8" ), ( - Attribute.Direction.w, "h1a1" + Direction.Direction.w, "h1a1" ) ] ~? "'BishBosh.Cartesian.Coordinates.extrapolate' is incompatible with 'BishBosh.Component.Move.interpolate'." ] diff --git a/src-test/BishBosh/Test/HUnit/Component/Piece.hs b/src-test/BishBosh/Test/HUnit/Component/Piece.hs --- a/src-test/BishBosh/Test/HUnit/Component/Piece.hs +++ b/src-test/BishBosh/Test/HUnit/Component/Piece.hs @@ -28,10 +28,10 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -46,16 +46,16 @@ testCases = Test.HUnit.test [ Property.FixedMembership.members == Data.List.sort Component.Piece.range ~? "BishBosh.Component.Piece.range is misordered.", all ( - == Data.List.sort (Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black) + == Data.List.sort (Component.Piece.getAttackDirections $ Component.Piece.mkKing Colour.LogicalColour.Black) ) [ - Data.List.sort $ Component.Piece.getAttackDirections $ Component.Piece.mkQueen Attribute.LogicalColour.Black, - Data.List.sort . uncurry (++) $ (Component.Piece.getAttackDirections . Component.Piece.mkBishop &&& Component.Piece.getAttackDirections . Component.Piece.mkRook) Attribute.LogicalColour.Black + Data.List.sort $ Component.Piece.getAttackDirections $ Component.Piece.mkQueen Colour.LogicalColour.Black, + Data.List.sort . uncurry (++) $ (Component.Piece.getAttackDirections . Component.Piece.mkBishop &&& Component.Piece.getAttackDirections . Component.Piece.mkRook) Colour.LogicalColour.Black ] ~? "'BishBosh.Component.Piece.getAttackDirections' failed to show Queen's moves to be union of Bishop & Rook.", "'BishBosh.Cartesian.Vector.attackVectorsForKing'." ~: ( - length Cartesian.Vector.attackVectorsForKing ~?= length (Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black) + length Cartesian.Vector.attackVectorsForKing ~?= length (Component.Piece.getAttackDirections $ Component.Piece.mkKing Colour.LogicalColour.Black) ), "'BishBosh.Component.Piece.getAttackDirections' failed for King." ~: Data.List.sort ( - Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black {-arbitrarily-} + Component.Piece.getAttackDirections $ Component.Piece.mkKing Colour.LogicalColour.Black {-arbitrarily-} ) ~?= Property.FixedMembership.members, all ( \((s, logicalColour), rank) -> let @@ -66,13 +66,13 @@ concat [ [ ( - "a2b3", Attribute.LogicalColour.White + "a2b3", Colour.LogicalColour.White ), ( - "b3a4", Attribute.LogicalColour.White + "b3a4", Colour.LogicalColour.White ), ( - "a7b6", Attribute.LogicalColour.Black + "a7b6", Colour.LogicalColour.Black ), ( - "b6a5", Attribute.LogicalColour.Black + "b6a5", Colour.LogicalColour.Black ) ] `zip` repeat Attribute.Rank.Pawn, ( @@ -120,13 +120,13 @@ ) $ concat [ [ ( - "a2a3", Attribute.LogicalColour.White + "a2a3", Colour.LogicalColour.White ), ( - "a2a4", Attribute.LogicalColour.White + "a2a4", Colour.LogicalColour.White ), ( - "a7a6", Attribute.LogicalColour.Black + "a7a6", Colour.LogicalColour.Black ), ( - "a7a5", Attribute.LogicalColour.Black + "a7a5", Colour.LogicalColour.Black ) ] `zip` repeat Attribute.Rank.Pawn, ( diff --git a/src-test/BishBosh/Test/HUnit/ContextualNotation/PositionHashQualifiedMoveTree.hs b/src-test/BishBosh/Test/HUnit/ContextualNotation/PositionHashQualifiedMoveTree.hs --- a/src-test/BishBosh/Test/HUnit/ContextualNotation/PositionHashQualifiedMoveTree.hs +++ b/src-test/BishBosh/Test/HUnit/ContextualNotation/PositionHashQualifiedMoveTree.hs @@ -65,14 +65,14 @@ Component.QualifiedMove.getMove . fst {-qualifiedMove-} ) ( ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves matchSwitches ( - mkGame moveStrings - ) . ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest False {-incrementalEvaluation-} ( - Data.Default.def :: Component.Zobrist.Zobrist Type.Crypto.PositionHash - ) $ ContextualNotation.QualifiedMoveForest.fromPGNDatabase [ - ContextualNotation.PGN.mkPGN' [] [ - (ContextualNotation.PGN.dateTag, "2018.01.01") - ] game - ] + ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest False {-incrementalEvaluation-} ( + Data.Default.def :: Component.Zobrist.Zobrist Type.Crypto.PositionHash + ) $ ContextualNotation.QualifiedMoveForest.fromPGNDatabase [ + ContextualNotation.PGN.mkPGN' [] [ + (ContextualNotation.PGN.dateTag, "2018.01.01") + ] game + ] + ) $ mkGame moveStrings ) ~?= [expectedMove] -- | Check the sanity of the implementation, by validating a list of static test-cases. diff --git a/src-test/BishBosh/Test/HUnit/ContextualNotation/StandardAlgebraic.hs b/src-test/BishBosh/Test/HUnit/ContextualNotation/StandardAlgebraic.hs --- a/src-test/BishBosh/Test/HUnit/ContextualNotation/StandardAlgebraic.hs +++ b/src-test/BishBosh/Test/HUnit/ContextualNotation/StandardAlgebraic.hs @@ -29,7 +29,7 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -90,7 +90,7 @@ ContextualNotation.StandardAlgebraic.fromQualifiedMove $ Component.QualifiedMove.mkQualifiedMove move moveType ) ( Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic.testCases:\tinvalid " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows move . showString "; " . show - ) $ Model.Game.validateEitherQualifiedMove eitherQualifiedMove game + ) $ Model.Game.validateEitherQualifiedMove game eitherQualifiedMove _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic.testCases:\tfailed to read " $ shows s "." ) ["g1h3", "e2e3", "e2e4"] ++ map ( \(fen, nextLogicalColour, s, maybeMoveSuffixAnnotation) -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def s of @@ -105,58 +105,58 @@ ContextualNotation.StandardAlgebraic.fromQualifiedMove $ Component.QualifiedMove.mkQualifiedMove move moveType ) ( Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic.testCases:\tinvalid " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows move . showString "; " . show - ) $ Model.Game.validateEitherQualifiedMove eitherQualifiedMove game + ) $ Model.Game.validateEitherQualifiedMove game eitherQualifiedMove _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic.testCases:\tfailed to read FEN" . Text.ShowList.showsAssociation $ show fen _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic.testCases:\tfailed to read " $ shows s "." ) [ ( "r3k2r/8/8/8/8/8/PPPPPPPP/RNBQK2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "e1g1c", -- O-O. Just "!" ), ( "rnbqk2r/pppppppp/8/8/8/8/8/R3K2R", - Attribute.LogicalColour.Black, + Colour.LogicalColour.Black, "e8g8c", -- O-O. Just " ?" ), ( "r3k2r/8/8/8/8/8/PPPPPPPP/R3KBNR", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "e1c1C", -- O-O-O. Just "!!" ), ( "r3kbnr/pppppppp/8/8/8/8/8/R3K2R", - Attribute.LogicalColour.Black, + Colour.LogicalColour.Black, "e8c8C", -- O-O-O. Just " !?" ), ( "r3kbnr/8/2R5/1RnR4/2R5/8/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "b5c5n", -- Rbxc5. Just "?!" ), ( "r3kbnr/8/2R5/1RnR4/2R5/8/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "c4c5n", -- R4xc5. Just "\t??" ), ( "r3kbnr/3N1N2/2N3N1/4b3/2N3N1/3N1N2/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "d3e5b", -- Nd3xe5. Nothing ), ( "r3kbnr/8/8/8/3r4/2P1P3/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "c3d4r", -- cxd4. Nothing ), ( "r3kbnr/1P6/8/8/8/8/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "b7b8N", -- b8=N. Nothing ), ( "r3kbnr/1P6/8/8/8/8/8/R3K2R", - Attribute.LogicalColour.White, + Colour.LogicalColour.White, "b7a8rQ", -- bxa8=Q+. Nothing ) diff --git a/src-test/BishBosh/Test/HUnit/Direction/Direction.hs b/src-test/BishBosh/Test/HUnit/Direction/Direction.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/HUnit/Direction/Direction.hs @@ -0,0 +1,46 @@ +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Static tests. +-} + +module BishBosh.Test.HUnit.Direction.Direction( +-- * Constants + testCases +) where + +import qualified BishBosh.Direction.Direction as Direction.Direction +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified Data.List +import qualified Test.HUnit +import Test.HUnit((~?)) + +-- | Check the sanity of the implementation, by validating a list of static test-cases. +testCases :: Test.HUnit.Test +testCases = Test.HUnit.test [ + null ( + Direction.Direction.diagonals `Data.List.intersect` Direction.Direction.parallels + ) ~? "BishBosh.Direction.Direction.[diagonal, parallels] intersect.", + all ( + (== 2) . length . Direction.Direction.attackDirectionsForPawn + ) Property.FixedMembership.members ~? "'BishBosh.Direction.Direction.attackDirectionsForPawn' failed." + ] + diff --git a/src-test/BishBosh/Test/HUnit/Evaluation/Fitness.hs b/src-test/BishBosh/Test/HUnit/Evaluation/Fitness.hs --- a/src-test/BishBosh/Test/HUnit/Evaluation/Fitness.hs +++ b/src-test/BishBosh/Test/HUnit/Evaluation/Fitness.hs @@ -28,19 +28,19 @@ ) where import Control.Arrow((&&&), (|||)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Component.Piece as Component.Piece -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness -import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator -import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game -import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game +import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.Exception import qualified Data.Default import qualified Test.HUnit @@ -65,7 +65,7 @@ ) Data.Default.def {-moveType-} ) ( Data.Default.def :: State.Board.Board - ) $ Cartesian.Coordinates.rooksStartingCoordinates Attribute.LogicalColour.White + ) $ Cartesian.Coordinates.rooksStartingCoordinates Colour.LogicalColour.White ) ~?= 1, "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving White Queen's Rook." ~: case Notation.MoveNotation.readsQualifiedMove Data.Default.def "a1a3" {-move Queen's Rook (illegally)-} of [(eitherQualifiedMove, "")] -> Evaluation.Fitness.measureValueOfCastlingPotential ( diff --git a/src-test/BishBosh/Test/HUnit/Input/Options.hs b/src-test/BishBosh/Test/HUnit/Input/Options.hs --- a/src-test/BishBosh/Test/HUnit/Input/Options.hs +++ b/src-test/BishBosh/Test/HUnit/Input/Options.hs @@ -31,7 +31,6 @@ import Control.Category((>>>)) import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.Options as Input.Options -import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.List import qualified Data.Maybe @@ -80,9 +79,7 @@ (== Just (head optionsList)) ( (HXT.unpickleDoc HXT.xpickle . HXT.pickleDoc HXT.xpickle) =<< Data.Maybe.listToMaybe ( - optionsList :: [ - Input.Options.Options Type.Mass.PieceSquareValue - ] + optionsList :: [Input.Options.Options] ) ) @? "Input.Options.pickler failed." ) . Data.Maybe.listToMaybe diff --git a/src-test/BishBosh/Test/HUnit/Model/Game.hs b/src-test/BishBosh/Test/HUnit/Model/Game.hs --- a/src-test/BishBosh/Test/HUnit/Model/Game.hs +++ b/src-test/BishBosh/Test/HUnit/Model/Game.hs @@ -32,10 +32,10 @@ import BishBosh.Model.Game((/~)) import Control.Arrow((&&&), (***), (|||)) import Data.Map((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Data.Exception as Data.Exception @@ -58,9 +58,7 @@ \s -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def {-Smith-} s of [(eitherQualifiedMove, "")] -> Right eitherQualifiedMove _ -> Left . shows s . showString " /~ " $ Notation.MoveNotation.showsMoveSyntax Data.Default.def "" - ) ( - Data.Default.def :: Model.Game.Game - ) + ) Data.Default.def -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test @@ -86,7 +84,7 @@ $ (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "r3k2r/8/8/8/8/8/8/R3K2R" :: Model.Game.Game) ) . ( \s -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def s of - [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove + [(eitherQualifiedMove, "")] -> (`Model.Game.isValidEitherQualifiedMove` eitherQualifiedMove) _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t" . shows s . showString " /~ " $ Notation.MoveNotation.showsMoveSyntax Data.Default.def "" ) ) [ @@ -94,7 +92,7 @@ "e1c1C" ] ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed when castling.", "'BishBosh.Model.Game.findQualifiedMovesAvailableToNextPlayer' failed" ~: Model.Game.findQualifiedMovesAvailableToNextPlayer ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "8/3K4/4q3/3bb3/8/8/8/4k3" :: Model.Game.Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "8/3K4/4q3/3bb3/8/8/8/4k3" ) ~?= [ Component.QualifiedMove.mkQualifiedMove ( Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 6)) `Component.Move.mkMove` Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 7)) @@ -102,12 +100,10 @@ ], not ( Model.Game.isValidQualifiedMove ( - Component.QualifiedMove.mkQualifiedMove ( - Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** succ) `Component.Move.mkMove` Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 2)) - ) $ Attribute.MoveType.mkNormalMoveType (Just Attribute.Rank.Pawn) Nothing - ) ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/8/8/8/1b6/3p4/3R4/4K3" :: Model.Game.Game - ) + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/8/8/8/1b6/3p4/3R4/4K3" + ) . Component.QualifiedMove.mkQualifiedMove ( + Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** succ) `Component.Move.mkMove` Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 2)) + ) $ Attribute.MoveType.mkNormalMoveType (Just Attribute.Rank.Pawn) Nothing ) ~? "'BishBosh.Model.Game.isValidQualifiedMove' failed", let pawnsCoordinates :: Cartesian.Coordinates.Coordinates @@ -141,7 +137,7 @@ \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." ) ||| ( \game -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def "a5b6E" of - [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove game ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed for En-passant by White." + [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove game eitherQualifiedMove ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed for En-passant by White." _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t /~ " $ Notation.MoveNotation.showsMoveSyntax Data.Default.def "" ) $ applyMoves [ "a2a4", -- White: Queen's Rook's Pawn. @@ -153,7 +149,7 @@ \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." ) ||| ( \game -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def "a4b3E" of - [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove game ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed for En-passant by Black." + [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove game eitherQualifiedMove ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed for En-passant by Black." _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse move." ) $ applyMoves [ "b1c3", -- White: Queen's Knight. @@ -164,12 +160,12 @@ ], Data.Maybe.maybe False Rule.GameTerminationReason.isStaleMate ( Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "rnbqk2r/pppppp2/8/8/8/7p/6np/6bK" :: Model.Game.Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "rnbqk2r/pppppp2/8/8/8/7p/6np/6bK" ) ) ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Stale-mate\".", all ( \s -> Data.Maybe.maybe False Rule.GameTerminationReason.isDrawByInsufficientMaterial $ Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Model.Game.Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s ) ) [ "2k5/8/1KB5/3B4/8/8/8/8", @@ -178,7 +174,7 @@ ] ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Draw by Insufficient Material\".", all ( \s -> Data.Maybe.maybe True (not . Rule.GameTerminationReason.isDrawByInsufficientMaterial) $ Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Model.Game.Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s ) ) [ "k7/8/K7/8/8/8/8/1Q6", @@ -195,7 +191,7 @@ \(moveString, s) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t" . showString moveString . showString "; " $ showString s "." ) ( uncurry (==) . ( - Model.Game.sortAvailableQualifiedMoves . (! Attribute.LogicalColour.White) . Model.Game.getAvailableQualifiedMovesByLogicalColour &&& Model.Game.sortAvailableQualifiedMoves . Model.Game.mkAvailableQualifiedMovesFor Attribute.LogicalColour.White + Model.Game.sortAvailableQualifiedMoves . (! Colour.LogicalColour.White) . Model.Game.getAvailableQualifiedMovesByLogicalColour &&& Model.Game.sortAvailableQualifiedMoves . (`Model.Game.mkAvailableQualifiedMovesFor` Colour.LogicalColour.White) ) ) . applyMoves $ words "g2g4 f7f6 g1h3 g7g5 h1g1 c7c6 d2d3 h7h5 c1d2 h5g4p d3d4 b8a6 f2f4 g4f3E" ) ~? "'BishBosh.Model.Game.getAvailableQualifiedMovesByLogicalColour' failed after En-passant.", @@ -258,9 +254,9 @@ let longCastle = "e1c1C" in case Notation.MoveNotation.readsQualifiedMove Data.Default.def longCastle of - [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove ( - Property.ForsythEdwards.readFEN "r2qkbnr/ppp1pppp/2np4/5b2/3P4/NQP5/PP1BPPPP/R3KBNR w KQkq - 5 6" :: Model.Game.Game - ) ~? "long Castle through legal check failed." + [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove ( + Property.ForsythEdwards.readFEN "r2qkbnr/ppp1pppp/2np4/5b2/3P4/NQP5/PP1BPPPP/R3KBNR w KQkq - 5 6" + ) eitherQualifiedMove ~? "long Castle through legal check failed." _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse " $ shows longCastle ".", let epds :: [String] @@ -289,7 +285,7 @@ let terminalMoves = map (Notation.Smith.getQualifiedMove . read) ["d6d8", "e7c7", "d6b6"] in all ( - `elem` Model.Game.findQualifiedMovesAvailableTo minBound (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "K7/4q1p1/3r4/8/8/5k2/8/8 b - - 13 49" :: Model.Game.Game) + `elem` Model.Game.findQualifiedMovesAvailableTo (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "K7/4q1p1/3r4/8/8/5k2/8/8 b - - 13 49" :: Model.Game.Game) minBound ) terminalMoves ~? "BishBosh.Test.HUnit.Model.Game.testCases:\tterminal move unavailable." ] diff --git a/src-test/BishBosh/Test/HUnit/Model/GameTree.hs b/src-test/BishBosh/Test/HUnit/Model/GameTree.hs --- a/src-test/BishBosh/Test/HUnit/Model/GameTree.hs +++ b/src-test/BishBosh/Test/HUnit/Model/GameTree.hs @@ -58,19 +58,19 @@ "'BishBosh.Model.GameTree.sortGameTree/MVVLVA' failed" ~: map ( \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn) ) ( - sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.MVVLVA) testString - ) ~?= ["c4d5p","e4d5p","c3d5p","d1d5p","a1b1","c1b2","c1a3","c1d2","c1e3","c1f4","c1g5","c1h6","d1d2","d1d3","d1d4","d1e2","e1d2","e1e2","e1f1","g1e2","g1h3","a2a3","a2a4","g2g3","g2g4","h2h3","h2h4","b3b4","c3b1","c3b5","c3a4","c3e2","f3e2","f3g4","f3h5","c4c5","e4e5"], + take 4 $ sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.MVVLVA) testString + ) ~?= ["c4d5p","e4d5p","c3d5p","d1d5p"], "'BishBosh.Model.GameTree.sortGameTree/SEE' failed" ~: map ( \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn) ) ( - sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.SEE) testString - ) ~?= ["c4d5p","e4d5p","a1b1","c1b2","c1a3","c1d2","c1e3","c1f4","c1g5","c1h6","d1d2","d1d3","d1d4","d1d5p","d1e2","e1d2","e1e2","e1f1","g1e2","g1h3","a2a3","a2a4","g2g3","g2g4","h2h3","h2h4","b3b4","c3b1","c3b5","c3a4","c3e2","c3d5p","f3e2","f3g4","f3h5","c4c5","e4e5"] + take 3 $ sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.SEE) testString + ) ~?= ["c4d5p","e4d5p","a1b1"] ] where sortAvailableMoves :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> String -> [Component.Turn.Turn] sortAvailableMoves maybeSortAlgorithm = Data.Maybe.mapMaybe ( Model.Game.maybeLastTurn . Data.Tree.rootLabel ) . Data.Tree.subForest . Model.GameTree.deconstruct . Model.GameTree.sortGameTree maybeSortAlgorithm ( - `Input.RankValues.findRankValue` Input.RankValues.fromAssocs ( + Input.RankValues.findRankValue $ Input.RankValues.fromAssocs ( zip Property.FixedMembership.members $ map ( fromRational . (/ 10) -- Map into the closed unit-interval. ) [ diff --git a/src-test/BishBosh/Test/HUnit/Search/Search.hs b/src-test/BishBosh/Test/HUnit/Search/Search.hs --- a/src-test/BishBosh/Test/HUnit/Search/Search.hs +++ b/src-test/BishBosh/Test/HUnit/Search/Search.hs @@ -43,7 +43,6 @@ import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Control.Monad.Reader import qualified Data.Default @@ -52,7 +51,7 @@ import Test.HUnit((~?)) -- | Constant. -evaluationOptions :: Fractional pieceSquareValue => Input.EvaluationOptions.EvaluationOptions pieceSquareValue +evaluationOptions :: Input.EvaluationOptions.EvaluationOptions evaluationOptions = Input.EvaluationOptions.mkEvaluationOptions Data.Default.def {-rankValues-} Data.Default.def { Input.CriteriaWeights.getWeightOfMobility = fromRational $ 24 / 1000, Input.CriteriaWeights.getWeightOfCastlingPotential = fromRational $ 5 / 1000 @@ -74,7 +73,7 @@ turnString = Notation.MoveNotation.showNotation Data.Default.def {-Smith-} $ case Search.Search.getQuantifiedGames $ Control.Monad.Reader.runReader ( Search.Search.search searchDepth $ Search.SearchState.initialise ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree ( - evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue + evaluationOptions :: Input.EvaluationOptions.EvaluationOptions ) searchOptions Data.Default.def {-Zobrist-} Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree Type.Crypto.PositionHash ) ) searchOptions of diff --git a/src-test/BishBosh/Test/HUnit/State/Board.hs b/src-test/BishBosh/Test/HUnit/State/Board.hs --- a/src-test/BishBosh/Test/HUnit/State/Board.hs +++ b/src-test/BishBosh/Test/HUnit/State/Board.hs @@ -58,17 +58,17 @@ testCases = Test.HUnit.test [ "'BishBosh.Cartesian.Coordinates' failed to locate the expected pieces on a default board." ~: ( map length . ToolShed.Data.Foldable.gather $ map ( - `State.MaybePieceByCoordinates.dereference` Data.Default.def + State.MaybePieceByCoordinates.dereference Data.Default.def ) (Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates]) ) ~?= [32, 8, 2, 2, 2, 1, 1, 8, 2, 2, 2, 1, 1], let kingsColour = minBound destination = Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 3)) - directionToCoordinates = last . (`Cartesian.Coordinates.extrapolate` destination) + directionToCoordinates = last . Cartesian.Coordinates.extrapolate destination mkPiece = Component.Piece.mkPiece $ Property.Opposable.getOpposite kingsColour - maybeShift = Cartesian.Vector.maybeTranslate destination + maybeShift = (`Cartesian.Vector.maybeTranslate` destination) in all ( - State.Board.isKingChecked kingsColour . placePieces . (:) (Component.Piece.mkKing kingsColour, destination) . return {-to List-monad-} + (`State.Board.isKingChecked` kingsColour) . placePieces . (:) (Component.Piece.mkKing kingsColour, destination) . return {-to List-monad-} ) ( concat [ Data.Maybe.mapMaybe ( @@ -179,113 +179,113 @@ let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing maxBound ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates - ) $ placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkPawn maxBound, - whitePawnsCoordinates - ), ( - Component.Piece.mkPawn minBound, - Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) - ) - ] + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkPawn maxBound, + whitePawnsCoordinates + ), ( + Component.Piece.mkPawn minBound, + Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) + ) + ] + ) maxBound . Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates ) ~? "'BishBosh.State.Board.exposesKing false positive attack by black Pawn, after moving White Pawn.", let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing maxBound ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates - ) $ placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkPawn maxBound, - whitePawnsCoordinates - ), ( - Component.Piece.mkKing minBound, - Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) - ) - ] + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkPawn maxBound, + whitePawnsCoordinates + ), ( + Component.Piece.mkKing minBound, + Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) + ) + ] + ) maxBound . Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates ) ~? "'BishBosh.State.Board.exposesKing false positive attack by black King, after moving White Pawn.", let whiteBishopsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing maxBound ( - Component.Move.mkMove whiteBishopsCoordinates $ Cartesian.Coordinates.translate (succ *** succ) whiteBishopsCoordinates -- Move towards Black Queen. - ) $ placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkBishop maxBound, - whiteBishopsCoordinates - ), ( - Component.Piece.mkQueen minBound, - maxBound - ) - ] + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkBishop maxBound, + whiteBishopsCoordinates + ), ( + Component.Piece.mkQueen minBound, + maxBound + ) + ] + ) maxBound . Component.Move.mkMove whiteBishopsCoordinates $ Cartesian.Coordinates.translate (succ *** succ) whiteBishopsCoordinates -- Move towards Black Queen. ) ~? "'BishBosh.State.Board.exposesKing false positive attack by black Queen, after moving White Bishop.", let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ - in State.Board.exposesKing maxBound ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates -- Expose attack from Black Queen. - ) ( - placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkPawn maxBound, - whitePawnsCoordinates - ), ( - Component.Piece.mkQueen minBound, - maxBound - ) - ] + in ( + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkPawn maxBound, + whitePawnsCoordinates + ), ( + Component.Piece.mkQueen minBound, + maxBound + ) + ] + ) maxBound . Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates -- Expose attack from Black Queen. ) ~? "'BishBosh.State.Board.exposesKing failed after advancing White Pawn.", let whiteKnightsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ - in State.Board.exposesKing maxBound ( - Component.Move.mkMove whiteKnightsCoordinates . Cartesian.Coordinates.mkRelativeCoordinates $ (+ 3) *** (+ 2) -- Expose attack from Black Queen. - ) ( - placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkKnight maxBound, - whiteKnightsCoordinates - ), ( - Component.Piece.mkQueen minBound, - maxBound - ) - ] + in ( + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkKnight maxBound, + whiteKnightsCoordinates + ), ( + Component.Piece.mkQueen minBound, + maxBound + ) + ] + ) maxBound . Component.Move.mkMove whiteKnightsCoordinates . Cartesian.Coordinates.mkRelativeCoordinates $ (+ 3) *** (+ 2) -- Expose attack from Black Queen. ) ~? "'BishBosh.State.Board.exposesKing failed after moving White Knight.", let whiteRooksCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) in not ( - State.Board.exposesKing maxBound ( - Component.Move.mkMove whiteRooksCoordinates $ Cartesian.Coordinates.advance maxBound whiteRooksCoordinates -- Shift blocking-role to Pawn. - ) $ placePieces [ - ( - Component.Piece.mkKing maxBound, - minBound - ), ( - Component.Piece.mkPawn maxBound, - Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ - ), ( - Component.Piece.mkRook maxBound, - whiteRooksCoordinates - ), ( - Component.Piece.mkQueen minBound, - maxBound - ) - ] + State.Board.exposesKing ( + placePieces [ + ( + Component.Piece.mkKing maxBound, + minBound + ), ( + Component.Piece.mkPawn maxBound, + Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ + ), ( + Component.Piece.mkRook maxBound, + whiteRooksCoordinates + ), ( + Component.Piece.mkQueen minBound, + maxBound + ) + ] + ) maxBound . Component.Move.mkMove whiteRooksCoordinates $ Cartesian.Coordinates.advance maxBound whiteRooksCoordinates -- Shift blocking-role to Pawn. ) ~? "'BishBosh.State.Board.exposesKing failed after moving White Rook.", Data.Foldable.all ( Data.Foldable.all (== 1) diff --git a/src-test/BishBosh/Test/QuickCheck/Attribute/Direction.hs b/src-test/BishBosh/Test/QuickCheck/Attribute/Direction.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Attribute/Direction.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. --} - -module BishBosh.Test.QuickCheck.Attribute.Direction( --- * Constants - results -) where - -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified Test.QuickCheck -import qualified ToolShed.Test.ReversibleIO - -instance Test.QuickCheck.Arbitrary Attribute.Direction.Direction where - arbitrary = Test.QuickCheck.elements Property.FixedMembership.members - --- | The constant test-results for this data-type. -results :: IO [Test.QuickCheck.Result] -results = sequence [ - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_readPrependedWhiteSpace" . ToolShed.Test.ReversibleIO.readPrependedWhiteSpace - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: String -> Test.QuickCheck.Property - f garbage = Test.QuickCheck.label "Direction.prop_read" $ case (reads garbage :: [(Attribute.Direction.Direction, String)]) of - [_] -> True - _ -> True -- Unless the read-implementation throws an exception. - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: Attribute.Direction.Direction -> String -> Test.QuickCheck.Property - f direction = Test.QuickCheck.label "Direction.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` "ewEW") direction - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_reflectOnY" . uncurry (==) . (id &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnY) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_getOpposite/Reflectable" . uncurry (==) . (Property.Opposable.getOpposite &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnX) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_areAligned" . uncurry Attribute.Direction.areAligned . (id &&& Property.Opposable.getOpposite) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, - let - f :: Attribute.Direction.Direction -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Direction.prop_isParallel" . uncurry (/=) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f - ] - - - diff --git a/src-test/BishBosh/Test/QuickCheck/Attribute/LogicalColour.hs b/src-test/BishBosh/Test/QuickCheck/Attribute/LogicalColour.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Attribute/LogicalColour.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- - 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 . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. --} - -module BishBosh.Test.QuickCheck.Attribute.LogicalColour( --- * Constants - results -) where - -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -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 Test.QuickCheck - -instance Test.QuickCheck.Arbitrary Attribute.LogicalColour.LogicalColour where - arbitrary = Test.QuickCheck.elements Property.FixedMembership.members - --- | The constant test-results for this data-type. -results :: IO [Test.QuickCheck.Result] -results = sequence [ - let - f :: Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property - f = Test.QuickCheck.label "LogicalColour.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4 } f, - let - f :: Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property - f logicalColour = Test.QuickCheck.label "LogicalColour.prop_fen" $ case Property.ForsythEdwards.readsFEN $ Property.ForsythEdwards.showFEN logicalColour of - [(logicalColour', "")] -> logicalColour' == logicalColour - _ -> False - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4 } f - ] - - diff --git a/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs b/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs --- a/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs +++ b/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs @@ -28,16 +28,16 @@ results ) where -import BishBosh.Test.QuickCheck.Attribute.Direction() +import BishBosh.Test.QuickCheck.Direction.Direction() import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Direction.Direction as Direction.Direction import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Orientated as Property.Orientated import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.Property.Rotatable as Property.Rotatable -import qualified Data.Array.IArray import qualified Data.List import qualified Data.List.Extra import qualified Test.QuickCheck @@ -77,7 +77,7 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property - f coordinates = Test.QuickCheck.label "Coordinates.prop_fromIx" $ Cartesian.Coordinates.fromIx (Data.Array.IArray.index (minBound, maxBound) coordinates) == coordinates + f coordinates = Test.QuickCheck.label "Coordinates.prop_enum" $ toEnum (fromEnum coordinates) == coordinates in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property @@ -89,10 +89,6 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Coordinates.prop_rotate180" . uncurry (==) . (Property.Rotatable.rotate180 &&& Property.Rotatable.rotate180) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f coordinates = Test.QuickCheck.label "Coordinates.prop_rotateIdentity" $ all ((== coordinates) . ($ coordinates)) [ Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90, Property.Rotatable.rotate180 . Property.Rotatable.rotate180, @@ -108,7 +104,15 @@ ] in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Coordinates.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Coordinates.prop_getOpposite/Reflectable" . uncurry (==) . (Property.Opposable.getOpposite &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnX) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f direction source = Test.QuickCheck.label "Coordinates.prop_extrapolate" . ( \extrapolation -> let destination @@ -117,7 +121,7 @@ in source == destination || source : extrapolation == reverse ( destination : Cartesian.Coordinates.interpolate destination source ) - ) $ Cartesian.Coordinates.extrapolate direction source + ) $ Cartesian.Coordinates.extrapolate source direction in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property @@ -132,6 +136,12 @@ null &&& (== 1) . length . Data.List.nub . map Cartesian.Coordinates.getLogicalColourOfSquare ) ) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Coordinates.prop_applyAlongDirectionsFrom" . uncurry (==) . ( + flip (Cartesian.Coordinates.applyAlongDirectionsFrom id) Nothing &&& flip (Cartesian.Coordinates.applyAlongDirectionsFrom id) (Just Property.FixedMembership.members) + ) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Cartesian/Vector.hs b/src-test/BishBosh/Test/QuickCheck/Cartesian/Vector.hs --- a/src-test/BishBosh/Test/QuickCheck/Cartesian/Vector.hs +++ b/src-test/BishBosh/Test/QuickCheck/Cartesian/Vector.hs @@ -31,13 +31,14 @@ import BishBosh.Test.QuickCheck.Cartesian.Coordinates() import Control.Arrow((&&&), (***)) -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Type.Length as Type.Length +import qualified Data.Maybe import qualified Test.QuickCheck import Test.QuickCheck((==>)) @@ -60,26 +61,34 @@ f = Test.QuickCheck.label "Vector.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property f = Test.QuickCheck.label "Vector.prop_orthogonal" . not . uncurry (&&) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property - f vector = not (Property.Orientated.isStraight vector) ==> Test.QuickCheck.label "Vector.prop_straight" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) vector + f vector = not (Property.Orientated.isStraight vector) ==> Test.QuickCheck.label "Vector.prop_(not isStraight => not (isDiagonal || isParallel))" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) vector in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property + f vector = Property.Orientated.isStraight vector ==> Test.QuickCheck.label "Vector.prop_(isStraight => isDiagonal /= isParallel)" . uncurry (/=) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) vector + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property + f vector = Property.Orientated.isParallel vector ==> Test.QuickCheck.label "Vector.prop_(isParallel => isHorizontal /= isVertical)" . uncurry (/=) $ (Property.Orientated.isHorizontal &&& Property.Orientated.isVertical) vector + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let f :: (Type.Length.X, Type.Length.Y) -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f (distanceX, distanceY) coordinates = Test.QuickCheck.label "Vector.prop_maybeTranslate" $ Cartesian.Coordinates.maybeTranslate (deltaX *** deltaY) coordinates == ( Cartesian.Coordinates.maybeTranslateX deltaX coordinates >>= Cartesian.Coordinates.maybeTranslateY deltaY ) where - deltaX :: Type.Length.X -> Type.Length.X + deltaX :: Type.Length.X -> Type.Length.X deltaX = ( + ( (distanceX `mod` Cartesian.Abscissa.xLength) - (Cartesian.Abscissa.xLength `div` 2) ) ) -- Section. - deltaY :: Type.Length.Y -> Type.Length.Y + deltaY :: Type.Length.Y -> Type.Length.Y deltaY = ( + ( (distanceY `mod` Cartesian.Ordinate.yLength) - (Cartesian.Ordinate.yLength `div` 2) @@ -88,14 +97,20 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property - f source destination = Test.QuickCheck.label "Vector.prop_measureDistance => translate" $ Cartesian.Vector.translate source ( - Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.Vector - ) == destination + f source destination = Test.QuickCheck.label "Vector.prop_measureDistance => translate" $ Cartesian.Vector.translate ( + Cartesian.Vector.measureDistance source destination + ) source == destination in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f source destination = Test.QuickCheck.label "Vector.prop_translate" $ Cartesian.Vector.measureDistance source destination == Property.Opposable.getOpposite ( - Cartesian.Vector.measureDistance destination source :: Cartesian.Vector.Vector + Cartesian.Vector.measureDistance destination source + ) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Vector.prop_toMaybeDirection" . uncurry (==) . ( + Data.Maybe.isJust . Cartesian.Vector.toMaybeDirection &&& Property.Orientated.isStraight ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Colour/LogicalColour.hs b/src-test/BishBosh/Test/QuickCheck/Colour/LogicalColour.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Colour/LogicalColour.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.Colour.LogicalColour( +-- * Constants + results +) where + +import Control.Arrow((&&&)) +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour +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 Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Colour.LogicalColour.LogicalColour where + arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Colour.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f = Test.QuickCheck.label "LogicalColour.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4 } f, + let + f :: Colour.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f logicalColour = Test.QuickCheck.label "LogicalColour.prop_fen" $ case Property.ForsythEdwards.readsFEN $ Property.ForsythEdwards.showFEN logicalColour of + [(logicalColour', "")] -> logicalColour' == logicalColour + _ -> False + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4 } f + ] + + diff --git a/src-test/BishBosh/Test/QuickCheck/Component/Move.hs b/src-test/BishBosh/Test/QuickCheck/Component/Move.hs --- a/src-test/BishBosh/Test/QuickCheck/Component/Move.hs +++ b/src-test/BishBosh/Test/QuickCheck/Component/Move.hs @@ -60,16 +60,24 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Component.Move.Move -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Move.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Component.Move.Move -> Test.QuickCheck.Property f = Test.QuickCheck.label "Move.prop_orthogonal" . not . uncurry (&&) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Component.Move.Move -> Test.QuickCheck.Property - f move = not (Property.Orientated.isStraight move) ==> Test.QuickCheck.label "Move.prop_straight" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) move + f move = not (Property.Orientated.isStraight move) ==> Test.QuickCheck.label "Move.prop_(not isStraight => not (isDiagonal || isParallel))" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) move in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Component.Move.Move -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Move.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + f move = Property.Orientated.isStraight move ==> Test.QuickCheck.label "Move.prop_(isStraight => isDiagonal /= isParallel)" . uncurry (/=) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) move + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Component.Move.Move -> Test.QuickCheck.Property + f move = Property.Orientated.isParallel move ==> Test.QuickCheck.label "Move.prop_(isParallel => isHorizontal /= isVertical)" . uncurry (/=) $ (Property.Orientated.isHorizontal &&& Property.Orientated.isVertical) move + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, let f :: Component.Move.Move -> Test.QuickCheck.Property f move = Test.QuickCheck.label "Move.prop_measureDistance" $ Component.Move.measureDistance (Property.Opposable.getOpposite move) == Property.Opposable.getOpposite (Component.Move.measureDistance move) diff --git a/src-test/BishBosh/Test/QuickCheck/Component/QualifiedMove.hs b/src-test/BishBosh/Test/QuickCheck/Component/QualifiedMove.hs --- a/src-test/BishBosh/Test/QuickCheck/Component/QualifiedMove.hs +++ b/src-test/BishBosh/Test/QuickCheck/Component/QualifiedMove.hs @@ -37,7 +37,7 @@ import qualified ToolShed.Test.ReversibleIO instance Test.QuickCheck.Arbitrary Component.QualifiedMove.QualifiedMove where - arbitrary = uncurry Component.QualifiedMove.mkQualifiedMove `fmap` Test.QuickCheck.arbitrary -- CAVEAT: the move & moveType are unlikely to be compatible. + arbitrary = uncurry Component.QualifiedMove.mkQualifiedMove <$> Test.QuickCheck.arbitrary -- CAVEAT: the move & moveType are unlikely to be compatible. -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] diff --git a/src-test/BishBosh/Test/QuickCheck/Component/Turn.hs b/src-test/BishBosh/Test/QuickCheck/Component/Turn.hs --- a/src-test/BishBosh/Test/QuickCheck/Component/Turn.hs +++ b/src-test/BishBosh/Test/QuickCheck/Component/Turn.hs @@ -29,8 +29,8 @@ results ) where -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() import BishBosh.Test.QuickCheck.Attribute.MoveType() +import BishBosh.Test.QuickCheck.Colour.LogicalColour() import BishBosh.Test.QuickCheck.Component.Move() import BishBosh.Test.QuickCheck.Component.Piece() import BishBosh.Test.QuickCheck.Input.RankValues() @@ -94,7 +94,7 @@ f :: Input.RankValues.RankValues -> [Component.Turn.Turn] -> Test.QuickCheck.Property f rankValues' = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/quiet" . uncurry (==) . ( dropWhile Component.Turn.isCapture . Data.List.sortBy ( - Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues') + Component.Turn.compareByMVVLVA $ Input.RankValues.findRankValue rankValues' ) &&& filter ( not . Component.Turn.isCapture ) @@ -104,12 +104,12 @@ f :: [Component.Turn.Turn] -> Test.QuickCheck.Property f = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/MVV" . ( \ranks -> Data.List.sortOn ( - negate . toRational . (`Input.RankValues.findRankValue` rankValues) -- Most valuable victim should be first. + negate . toRational . Input.RankValues.findRankValue rankValues -- Most valuable victim should be first. ) ranks == ranks ) . map head . Data.List.group . Data.Maybe.mapMaybe ( Attribute.MoveType.getMaybeImplicitlyTakenRank . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove ) . Data.List.sortBy ( - Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues) + Component.Turn.compareByMVVLVA $ Input.RankValues.findRankValue rankValues ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let @@ -118,14 +118,14 @@ ( \ranks -> uncurry (++) ( Control.Arrow.first ( - Data.List.sortOn (`Input.RankValues.findRankValue` rankValues) -- Least valuable aggressor should be first. + Data.List.sortOn $ Input.RankValues.findRankValue rankValues -- Least valuable aggressor should be first. ) $ Data.List.partition (/= Attribute.Rank.King) ranks ) == ranks ) . map head . Data.List.group . map Component.Turn.getRank {-aggressor's rank-} ) . Data.List.groupBy ( ToolShed.Data.List.equalityBy $ Attribute.MoveType.getMaybeImplicitlyTakenRank . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove ) . takeWhile Component.Turn.isCapture . Data.List.sortBy ( - Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues) + Component.Turn.compareByMVVLVA $ Input.RankValues.findRankValue rankValues ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PositionHashQualifiedMoveTree.hs b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PositionHashQualifiedMoveTree.hs --- a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PositionHashQualifiedMoveTree.hs +++ b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PositionHashQualifiedMoveTree.hs @@ -66,7 +66,9 @@ ( == Component.QualifiedMove.getMove (Component.Turn.getQualifiedMove lastTurn) ) . Component.QualifiedMove.getMove . fst {-qualifiedMove-} - ) . ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches previousGame $ ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest incrementalEvaluation zobrist qualifiedMoveForest + ) $ ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches ( + ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest incrementalEvaluation zobrist qualifiedMoveForest + ) previousGame ) . head . Model.Game.rollBack ) . tail {-drop the default game-} . Data.Tree.flatten . Model.GameTree.deconstruct $ ContextualNotation.QualifiedMoveForest.toGameTree qualifiedMoveForest in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 8 } f diff --git a/src-test/BishBosh/Test/QuickCheck/Direction/Direction.hs b/src-test/BishBosh/Test/QuickCheck/Direction/Direction.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Direction/Direction.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.Direction.Direction( +-- * Constants + results +) where + +import Control.Arrow((&&&)) +import qualified BishBosh.Direction.Direction as Direction.Direction +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Property.Rotatable as Property.Rotatable +import qualified Data.List.Extra +import qualified Test.QuickCheck +import qualified ToolShed.Test.ReversibleIO +import Test.QuickCheck((==>)) + +instance Test.QuickCheck.Arbitrary Direction.Direction.Direction where + arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_readPrependedWhiteSpace" . ToolShed.Test.ReversibleIO.readPrependedWhiteSpace + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: String -> Test.QuickCheck.Property + f garbage = Test.QuickCheck.label "Direction.prop_read" $ case (reads garbage :: [(Direction.Direction.Direction, String)]) of + [_] -> True + _ -> True -- Unless the read-implementation throws an exception. + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Direction.Direction.Direction -> String -> Test.QuickCheck.Property + f direction = Test.QuickCheck.label "Direction.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` "EW") direction + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_orthogonal" . not . uncurry (&&) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f direction = Property.Orientated.isDiagonal direction ==> Test.QuickCheck.label "Direction.prop_(isDiagonal => not (isHorizontal || isVertical))" . not . uncurry (||) $ (Property.Orientated.isHorizontal &&& Property.Orientated.isVertical) direction + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_(isDiagonal /= isParallel)" . uncurry (/=) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f direction = Property.Orientated.isParallel direction ==> Test.QuickCheck.label "Direction.prop_(isParallel => isHorizontal /= isVertical)" . uncurry (/=) $ (Property.Orientated.isHorizontal &&& Property.Orientated.isVertical) direction + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_reflectOnY" . uncurry (==) . (id &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnY) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f direction = Test.QuickCheck.label "Direction.prop_rotateIdentity" $ all ((== direction) . ($ direction)) [ + Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90, + Property.Rotatable.rotate180 . Property.Rotatable.rotate180, + Property.Rotatable.rotate270 . Property.Rotatable.rotate270 . Property.Rotatable.rotate270 . Property.Rotatable.rotate270 + ] + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f direction = Test.QuickCheck.label "Direction.prop_rotate180/identity" . Data.List.Extra.allSame $ map ($ direction) [ + Property.Rotatable.rotate180, + Property.Rotatable.rotate90 . Property.Rotatable.rotate90, + Property.Rotatable.rotate270 . Property.Rotatable.rotate270 + ] + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_getOpposite/Reflectable" . uncurry (==) . (Property.Opposable.getOpposite &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnX) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, + let + f :: Direction.Direction.Direction -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Direction.prop_areAligned" . uncurry Direction.Direction.areAligned . (id &&& Property.Opposable.getOpposite) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Evaluation/PositionHashQuantifiedGameTree.hs b/src-test/BishBosh/Test/QuickCheck/Evaluation/PositionHashQuantifiedGameTree.hs --- a/src-test/BishBosh/Test/QuickCheck/Evaluation/PositionHashQuantifiedGameTree.hs +++ b/src-test/BishBosh/Test/QuickCheck/Evaluation/PositionHashQuantifiedGameTree.hs @@ -27,16 +27,17 @@ results ) where +import BishBosh.Test.QuickCheck.Input.EvaluationOptions() import BishBosh.Test.QuickCheck.Input.SearchOptions() import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.State.Position as State.Position import qualified BishBosh.Test.QuickCheck.Component.Zobrist as Test.QuickCheck.Component.Zobrist -import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions import qualified BishBosh.Type.Crypto as Type.Crypto import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.List.Extra @@ -50,7 +51,7 @@ results = sequence [ let f - :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions + :: Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game @@ -68,7 +69,7 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let f - :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions + :: Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game diff --git a/src-test/BishBosh/Test/QuickCheck/Input/EvaluationOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/EvaluationOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/EvaluationOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/EvaluationOptions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -24,9 +25,6 @@ -} module BishBosh.Test.QuickCheck.Input.EvaluationOptions( --- * Types --- ** Type-synonyms - EvaluationOptions, -- * Constants results ) where @@ -36,14 +34,12 @@ import BishBosh.Test.QuickCheck.Input.RankValues() import BishBosh.Test.QuickCheck.State.Board() import Control.Arrow((&&&)) -import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable import qualified BishBosh.Input.RankValues as Input.RankValues import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.Array.IArray import qualified Data.List import qualified Data.Map.Strict as Map @@ -51,15 +47,12 @@ import qualified Test.QuickCheck import Test.QuickCheck((==>)) --- | Defines a concrete type for testing. -type EvaluationOptions = Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue +#ifdef USE_PRECISION +import qualified BishBosh.Component.Accountant as Component.Accountant +import qualified BishBosh.Type.Mass as Type.Mass +#endif -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Show pieceSquareValue - ) => Test.QuickCheck.Arbitrary (Input.EvaluationOptions.EvaluationOptions pieceSquareValue) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary EvaluationOptions #-} +instance Test.QuickCheck.Arbitrary Input.EvaluationOptions.EvaluationOptions where arbitrary = do rankValues <- Test.QuickCheck.arbitrary criteriaWeights <- Test.QuickCheck.suchThat Test.QuickCheck.arbitrary $ \c -> Input.RankValues.calculateMaximumTotalValue rankValues /= 0 || Input.CriteriaWeights.getWeightOfMaterial c == 0 @@ -79,22 +72,25 @@ -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ +#ifdef USE_PRECISION let - f :: EvaluationOptions -> State.Board.Board -> Test.QuickCheck.Property - f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour/reflectOnX" . uncurry (==) $ ( - Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour &&& reverse . Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour . Property.Reflectable.reflectOnX + f :: Input.EvaluationOptions.EvaluationOptions -> State.Board.Board -> Test.QuickCheck.Property + f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour" . uncurry (==) $ ( + sumPieceSquareValueByLogicalColour' . State.Board.getCoordinatesByRankByLogicalColour &&& sumPieceSquareValueByLogicalColour' . State.Board.getMaybePieceByCoordinates ) board where maybePieceSquareByCoordinatesByRank = Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions - sumPieceSquareValueByLogicalColour = State.Board.sumPieceSquareValueByLogicalColour $ Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, + + sumPieceSquareValueByLogicalColour' :: Component.Accountant.Accountant accountant => accountant -> [Type.Mass.Base] + sumPieceSquareValueByLogicalColour' = flip (Component.Accountant.sumPieceSquareValueByLogicalColour $ Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank) $ State.Board.getNPieces board + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, +#endif let - f :: Input.EvaluationOptions.EvaluationOptions Rational {-precision is required-} -> State.Board.Board -> Test.QuickCheck.Property - f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour" . uncurry (==) $ ( - Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces . State.Board.getCoordinatesByRankByLogicalColour &&& Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces . State.Board.getMaybePieceByCoordinates + f :: Input.EvaluationOptions.EvaluationOptions -> State.Board.Board -> Test.QuickCheck.Property + f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour/reflectOnX" . uncurry (==) $ ( + Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour &&& reverse . Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour . Property.Reflectable.reflectOnX ) board where maybePieceSquareByCoordinatesByRank = Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions - pieceSquareByCoordinatesByRank = Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank - nPieces = State.Board.getNPieces board - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f + sumPieceSquareValueByLogicalColour = State.Board.sumPieceSquareValueByLogicalColour $ Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Input/Options.hs b/src-test/BishBosh/Test/QuickCheck/Input/Options.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/Options.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/Options.hs @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Input.Options( --- * Types --- ** Type-synonyms --- Options, -- * Constants results ) where @@ -37,23 +34,14 @@ import qualified BishBosh.Input.IOOptions as Input.IOOptions import qualified BishBosh.Input.Options as Input.Options import qualified BishBosh.Input.SearchOptions as Input.SearchOptions -import qualified BishBosh.Type.Mass as Type.Mass import qualified Test.QuickCheck --- | Defines a concrete type for testing. -type Options = Input.Options.Options Type.Mass.PieceSquareValue - -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Show pieceSquareValue - ) => Test.QuickCheck.Arbitrary (Input.Options.Options pieceSquareValue) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary Options #-} +instance Test.QuickCheck.Arbitrary Input.Options.Options where arbitrary = do (maybeMaximumPlies, maybeRandomSeed, evaluationOptions, searchOptions, ioOptions) <- Test.QuickCheck.arbitrary return {-to Gen-monad-} $ Input.Options.mkOptions ( - fmap (fromInteger . succ . abs) maybeMaximumPlies + fromInteger . succ . abs <$> maybeMaximumPlies ) maybeRandomSeed evaluationOptions ( if null $ Input.IOOptions.getPGNOptionsList ioOptions then searchOptions { @@ -66,7 +54,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Options -> Test.QuickCheck.Property + f :: Input.Options.Options -> Test.QuickCheck.Property f options = Test.QuickCheck.label "Options.prop_swapSearchDepth" $ Input.Options.swapSearchDepth (Input.Options.swapSearchDepth options) == options in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Input/PieceSquareTable.hs b/src-test/BishBosh/Test/QuickCheck/Input/PieceSquareTable.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/PieceSquareTable.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/PieceSquareTable.hs @@ -24,32 +24,19 @@ -} module BishBosh.Test.QuickCheck.Input.PieceSquareTable( --- * Types --- ** Type-synonyms --- PieceSquareTable, -- * Constants results ) where import BishBosh.Test.QuickCheck.Attribute.Rank() -import qualified BishBosh.Attribute.Rank as Attribute.Rank +import BishBosh.Test.QuickCheck.Type.Mass() import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Type.Mass as Type.Mass -import qualified Data.List import qualified Test.QuickCheck -import Test.QuickCheck((==>)) --- | Defines a concrete type for testing. -type PieceSquareTable = Input.PieceSquareTable.PieceSquareTable Type.Mass.PieceSquareValue - -instance ( - Fractional pieceSquareValue, - Ord pieceSquareValue, - Show pieceSquareValue - ) => Test.QuickCheck.Arbitrary (Input.PieceSquareTable.PieceSquareTable pieceSquareValue) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary PieceSquareTable #-} +instance Test.QuickCheck.Arbitrary Input.PieceSquareTable.PieceSquareTable where arbitrary = do reflectOnY <- Test.QuickCheck.arbitrary @@ -71,11 +58,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Input.PieceSquareTable.Assocs Attribute.Rank.Rank Type.Mass.PieceSquareValue -> Test.QuickCheck.Property - f assocs = length (Data.List.nub $ concatMap snd assocs) > 1 ==> Test.QuickCheck.label "PieceSquareTable.prop_closedUnitInterval" . Input.PieceSquareTable.inClosedUnitInterval $ Input.PieceSquareTable.normaliseToUnitInterval assocs - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: (Int, Int, Int, Int) -> Test.QuickCheck.Property + f :: (Type.Mass.PieceSquareValue, Type.Mass.PieceSquareValue, Type.Mass.PieceSquareValue, Type.Mass.PieceSquareValue) -> Test.QuickCheck.Property f (a, b, c, d) = Test.QuickCheck.label "PieceSquareTable.prop_mirror" . (== l) . Input.PieceSquareTable.unmirror $ Input.PieceSquareTable.mirror l where l = [a, b, c, d] in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f diff --git a/src-test/BishBosh/Test/QuickCheck/Input/SearchOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/SearchOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/SearchOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/SearchOptions.hs @@ -26,7 +26,7 @@ module BishBosh.Test.QuickCheck.Input.SearchOptions() where import BishBosh.Test.QuickCheck.Attribute.CaptureMoveSortAlgorithm() -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() +import BishBosh.Test.QuickCheck.Colour.LogicalColour() import BishBosh.Test.QuickCheck.Input.StandardOpeningOptions() import Control.Arrow((***)) import qualified BishBosh.Input.SearchOptions as Input.SearchOptions diff --git a/src-test/BishBosh/Test/QuickCheck/Model/Game.hs b/src-test/BishBosh/Test/QuickCheck/Model/Game.hs --- a/src-test/BishBosh/Test/QuickCheck/Model/Game.hs +++ b/src-test/BishBosh/Test/QuickCheck/Model/Game.hs @@ -29,35 +29,36 @@ results ) where +import BishBosh.Test.QuickCheck.Input.EvaluationOptions() import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.MoveType as Attribute.MoveType -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Component.Piece as Component.Piece -import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove -import qualified BishBosh.Component.Turn as Component.Turn -import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness -import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions -import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards -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 BishBosh.Rule.DrawReason as Rule.DrawReason -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour -import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour -import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates -import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions -import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +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 BishBosh.Property.SelfValidating as Property.SelfValidating +import qualified BishBosh.Rule.DrawReason as Rule.DrawReason +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour +import qualified BishBosh.Type.Count as Type.Count import qualified Data.Array.IArray import qualified Data.Default import qualified Data.Foldable import qualified Data.List -import qualified Data.Map as Map +import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Ord import qualified System.Random @@ -76,9 +77,7 @@ ) . Data.Maybe.fromJust . ToolShed.System.Random.select randomGen $ Model.Game.findQualifiedMovesAvailableToNextPlayer game play game _ = game -- Terminate recursion. in Test.QuickCheck.arbitrary >>= ( - \randomGens -> ( - play Data.Default.def . (`take` ToolShed.System.Random.randomGens (System.Random.mkStdGen randomGens)) - ) `fmap` Test.QuickCheck.choose (1 :: Int, 64) + \randomGens -> play Data.Default.def . (`take` ToolShed.System.Random.randomGens (System.Random.mkStdGen randomGens)) <$> Test.QuickCheck.choose (1 :: Int, 64) ) -- | The constant test-results for this data-type. @@ -131,7 +130,7 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Model.Game.Game -> Test.QuickCheck.Property - f game = not (Model.Game.isTerminated game) ==> Test.QuickCheck.label "Game.prop_isValidQualifiedMove" . all (`Model.Game.isValidQualifiedMove` game) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + f game = not (Model.Game.isTerminated game) ==> Test.QuickCheck.label "Game.prop_isValidQualifiedMove" . all (Model.Game.isValidQualifiedMove game) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let f :: Model.Game.Game -> Test.QuickCheck.Property @@ -145,11 +144,11 @@ destination <- Property.FixedMembership.members, source /= destination, let move = Component.Move.mkMove source destination, - maybePromotionRank <- if Data.Maybe.maybe False (Component.Piece.isPawnPromotion destination) $ State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates + maybePromotionRank <- if Data.Maybe.maybe False (`Component.Piece.isPawnPromotion` destination) $ State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source then map Just Attribute.Rank.promotionProspects else [Nothing], - let qualifiedMove = Component.QualifiedMove.mkQualifiedMove move $ State.MaybePieceByCoordinates.inferMoveType move maybePromotionRank maybePieceByCoordinates, - Model.Game.isValidQualifiedMove qualifiedMove game + let qualifiedMove = Component.QualifiedMove.mkQualifiedMove move $ State.MaybePieceByCoordinates.inferMoveType maybePieceByCoordinates move maybePromotionRank, + Model.Game.isValidQualifiedMove game qualifiedMove ] {-list-comprehension-} where sort = Data.List.sortBy $ Data.Ord.comparing Component.QualifiedMove.getMove board = Model.Game.getBoard game @@ -160,7 +159,7 @@ f game = Test.QuickCheck.label "Game.prop_inferMoveType" . all ( \qualifiedMove -> let moveType = Component.QualifiedMove.getMoveType qualifiedMove - inferredMoveType = State.MaybePieceByCoordinates.inferMoveType (Component.QualifiedMove.getMove qualifiedMove) Nothing {-promotion-rank-} . State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game + inferredMoveType = State.MaybePieceByCoordinates.inferMoveType (State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game) (Component.QualifiedMove.getMove qualifiedMove) Nothing {-promotion-rank-} in if Attribute.MoveType.isPromotion moveType then Attribute.MoveType.isPromotion inferredMoveType && Attribute.MoveType.getMaybeExplicitlyTakenRank moveType == Attribute.MoveType.getMaybeExplicitlyTakenRank inferredMoveType else moveType == inferredMoveType @@ -176,12 +175,6 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Model.Game.Game -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Game.prop_mkCoordinatesByRankByLogicalColour" . uncurry (==) . ( - State.CoordinatesByRankByLogicalColour.deconstruct . State.CoordinatesByRankByLogicalColour.sortCoordinates . State.Board.getCoordinatesByRankByLogicalColour &&& State.CoordinatesByRankByLogicalColour.deconstruct . State.CoordinatesByRankByLogicalColour.sortCoordinates . State.CoordinatesByRankByLogicalColour.fromMaybePieceByCoordinates . State.Board.getMaybePieceByCoordinates - ) . Model.Game.getBoard - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_getCoordinatesByRankByLogicalColour/unique" . all ( (== 1) . length ) . ToolShed.Data.Foldable.gather . State.CoordinatesByRankByLogicalColour.listCoordinates . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard @@ -189,17 +182,17 @@ let f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(getAvailableQualifiedMovesByLogicalColour == mkAvailableQualifiedMovesFor)" . Data.Maybe.maybe True ( - == Model.Game.mkAvailableQualifiedMovesFor nextLogicalColour game + == Model.Game.mkAvailableQualifiedMovesFor game nextLogicalColour ) . Map.lookup nextLogicalColour $ Model.Game.getAvailableQualifiedMovesByLogicalColour game where nextLogicalColour = Model.Game.getNextLogicalColour game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(findQualifiedMovesAvailableTo => countPliesAvailableTo)" $ all ( - \logicalColour -> Model.Game.countPliesAvailableTo logicalColour game == ( + \logicalColour -> Model.Game.countPliesAvailableTo game logicalColour == ( if Model.Game.isTerminated game then 0 - else fromIntegral . length $ Model.Game.findQualifiedMovesAvailableTo logicalColour game + else fromIntegral . length $ Model.Game.findQualifiedMovesAvailableTo game logicalColour ) ) Property.FixedMembership.members in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, @@ -219,7 +212,7 @@ f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(getCoordinatesByRankByLogicalColour => getNPawnsByFileByLogicalColour)" . all ( \(logicalColour, nPawnsByFile) -> Data.Foldable.sum nPawnsByFile == fromIntegral ( - length . State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn $ State.Board.getCoordinatesByRankByLogicalColour board + length $ State.CoordinatesByRankByLogicalColour.dereference (State.Board.getCoordinatesByRankByLogicalColour board) logicalColour Attribute.Rank.Pawn ) ) . Data.Array.IArray.assocs $ State.Board.getNPawnsByFileByLogicalColour board where board = Model.Game.getBoard game @@ -233,7 +226,7 @@ let f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_(getMaybeChecked == isKingChecked)" . uncurry (==) . ( - Data.Maybe.isJust . Model.Game.getMaybeChecked &&& uncurry State.Board.isKingChecked . (Model.Game.getNextLogicalColour &&& Model.Game.getBoard) + Data.Maybe.isJust . Model.Game.getMaybeChecked &&& uncurry State.Board.isKingChecked . (Model.Game.getBoard &&& Model.Game.getNextLogicalColour) ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f, let @@ -249,7 +242,7 @@ let f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_reflectOnX/isValidQualifiedMove" . all ( - \(game, turn) -> Model.Game.isValidQualifiedMove (Component.Turn.getQualifiedMove turn) game + \(game, turn) -> Model.Game.isValidQualifiedMove game $ Component.Turn.getQualifiedMove turn ) . Model.Game.rollBack . Property.Reflectable.reflectOnX in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let @@ -271,14 +264,14 @@ let f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(findAttackersOf => listDestinationsFor)" $ all ( - \(destination, destinationLogicalColour, destinationRank, source, sourceRank) -> (destination, Just destinationRank) `elem` State.MaybePieceByCoordinates.listDestinationsFor source ( + \(destination, destinationLogicalColour, destinationRank, source, sourceRank) -> (destination, Just destinationRank) `elem` State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source ( Component.Piece.mkPiece (Property.Opposable.getOpposite destinationLogicalColour) sourceRank - ) maybePieceByCoordinates + ) ) [ (destination, destinationLogicalColour, destinationRank, source, sourceRank) | (destination, piece) <- StateProperty.Seeker.findAllPieces maybePieceByCoordinates, let (destinationLogicalColour, destinationRank) = Component.Piece.getLogicalColour &&& Component.Piece.getRank $ piece, -- Deconstruct. - (source, sourceRank) <- State.Board.findAttackersOf destinationLogicalColour destination board + (source, sourceRank) <- State.Board.findAttackersOf board destinationLogicalColour destination ] {-list-comprehension-} where board = Model.Game.getBoard game maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board @@ -286,19 +279,19 @@ let f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(listDestinationsFor => findAttackersOf)" $ all ( - \(source, piece, destination) -> (source, Component.Piece.getRank piece) `elem` State.Board.findAttackersOf ( + \(source, piece, destination) -> (source, Component.Piece.getRank piece) `elem` State.Board.findAttackersOf board ( Property.Opposable.getOpposite $ Component.Piece.getLogicalColour piece - ) destination board + ) destination ) [ (source, piece, destination) | (source, piece) <- StateProperty.Seeker.findAllPieces maybePieceByCoordinates, - (destination, Just _) <- State.MaybePieceByCoordinates.listDestinationsFor source piece maybePieceByCoordinates -- Identify attacks. + (destination, Just _) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source piece -- Identify attacks. ] {-list-comprehension-} where board = Model.Game.getBoard game maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions -> Model.Game.Game -> Test.QuickCheck.Property + f :: Input.EvaluationOptions.EvaluationOptions -> Model.Game.Game -> Test.QuickCheck.Property f evaluationOptions game = Data.Maybe.isJust ( Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions ) && not ( @@ -317,12 +310,15 @@ ) . abs . uncurry (-) -- Tolerance for floating-point errors. #endif $ ( - Evaluation.Fitness.measurePieceSquareValue pieceSquareByCoordinatesByRank &&& Evaluation.Fitness.measurePieceSquareValueIncrementally ( - Evaluation.Fitness.measurePieceSquareValue pieceSquareByCoordinatesByRank oldGame - ) pieceSquareByCoordinatesByRank + measurePieceSquareValueDifference' &&& Evaluation.Fitness.measurePieceSquareValueDifferenceIncrementally (measurePieceSquareValueDifference' oldGame) pieceSquareByCoordinatesByRank ) game where - pieceSquareByCoordinatesByRank = Data.Maybe.fromJust $ Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions - (oldGame, _) : _ = Model.Game.rollBack game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f + pieceSquareByCoordinatesByRank = Data.Maybe.fromJust $ Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions + measurePieceSquareValueDifference' = Evaluation.Fitness.measurePieceSquareValueDifference pieceSquareByCoordinatesByRank + (oldGame, _) : _ = Model.Game.rollBack game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Game.prop_isValid" . Property.SelfValidating.isValid . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Model/GameTree.hs b/src-test/BishBosh/Test/QuickCheck/Model/GameTree.hs --- a/src-test/BishBosh/Test/QuickCheck/Model/GameTree.hs +++ b/src-test/BishBosh/Test/QuickCheck/Model/GameTree.hs @@ -40,7 +40,7 @@ arbitrary = do depth <- Test.QuickCheck.elements [1 .. 3] - fmap (Property.Arboreal.prune depth . Model.GameTree.fromGame) Test.QuickCheck.arbitrary + Property.Arboreal.prune depth . Model.GameTree.fromGame <$> Test.QuickCheck.arbitrary -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/ICCFNumeric.hs b/src-test/BishBosh/Test/QuickCheck/Notation/ICCFNumeric.hs --- a/src-test/BishBosh/Test/QuickCheck/Notation/ICCFNumeric.hs +++ b/src-test/BishBosh/Test/QuickCheck/Notation/ICCFNumeric.hs @@ -43,7 +43,7 @@ arbitrary = do move <- Test.QuickCheck.arbitrary - Notation.ICCFNumeric.mkICCFNumeric move `fmap` if abs ( + Notation.ICCFNumeric.mkICCFNumeric move <$> if abs ( Cartesian.Vector.getXDistance (Component.Move.measureDistance move) ) <= 1 && ( Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/MoveNotation.hs b/src-test/BishBosh/Test/QuickCheck/Notation/MoveNotation.hs --- a/src-test/BishBosh/Test/QuickCheck/Notation/MoveNotation.hs +++ b/src-test/BishBosh/Test/QuickCheck/Notation/MoveNotation.hs @@ -72,8 +72,7 @@ where turn = Data.Maybe.fromJust $ Model.Game.maybeLastTurn game (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ Component.Turn.getQualifiedMove turn - (Just rank) = fmap Component.Piece.getRank . State.MaybePieceByCoordinates.dereference (Component.Move.getDestination move) . State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game - + (Just rank) = fmap Component.Piece.getRank . State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game) $ Component.Move.getDestination move in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs --- a/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs +++ b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs @@ -44,7 +44,7 @@ arbitrary = do move <- Test.QuickCheck.arbitrary - Notation.PureCoordinate.mkPureCoordinate move `fmap` if abs ( + Notation.PureCoordinate.mkPureCoordinate move <$> if abs ( Cartesian.Vector.getXDistance (Component.Move.measureDistance move) ) <= 1 && ( Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move diff --git a/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs b/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs --- a/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs +++ b/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs @@ -28,7 +28,7 @@ results ) where -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() +import BishBosh.Test.QuickCheck.Colour.LogicalColour() import Control.Arrow((&&&)) import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Rule.Result as Rule.Result @@ -36,7 +36,7 @@ import qualified ToolShed.Test.ReversibleIO instance Test.QuickCheck.Arbitrary Rule.Result.Result where - arbitrary = Rule.Result.mkResult `fmap` Test.QuickCheck.oneof [fmap Just Test.QuickCheck.arbitrary, return {-to Gen-monad-} Nothing] + arbitrary = Rule.Result.mkResult <$> Test.QuickCheck.oneof [fmap Just Test.QuickCheck.arbitrary, return {-to Gen-monad-} Nothing] -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] diff --git a/src-test/BishBosh/Test/QuickCheck/Search/Search.hs b/src-test/BishBosh/Test/QuickCheck/Search/Search.hs --- a/src-test/BishBosh/Test/QuickCheck/Search/Search.hs +++ b/src-test/BishBosh/Test/QuickCheck/Search/Search.hs @@ -68,10 +68,11 @@ Input.SearchOptions.getUsePondering = Input.SearchOptions.getUsePondering defaultSearchOptions, Input.SearchOptions.getStandardOpeningOptions = Input.SearchOptions.getStandardOpeningOptions defaultSearchOptions, Input.SearchOptions.getSearchDepthByLogicalColour = Input.SearchOptions.getSearchDepthByLogicalColour defaultSearchOptions - } - getQuantifiedGames = Search.Search.getQuantifiedGames . Control.Monad.Reader.runReader (Search.Search.search (Input.SearchOptions.minimumSearchDepth + fromIntegral (searchDepth `mod` 3)) searchState) + getQuantifiedGames = Search.Search.getQuantifiedGames . Control.Monad.Reader.runReader ( + Search.Search.search (Input.SearchOptions.minimumSearchDepth + fromIntegral (searchDepth `mod` 3)) searchState + ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 128 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Search/SearchState.hs b/src-test/BishBosh/Test/QuickCheck/Search/SearchState.hs --- a/src-test/BishBosh/Test/QuickCheck/Search/SearchState.hs +++ b/src-test/BishBosh/Test/QuickCheck/Search/SearchState.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -35,11 +34,9 @@ import BishBosh.Test.QuickCheck.Input.SearchOptions() import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree -import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.Bits import qualified System.Random import qualified Test.QuickCheck @@ -47,7 +44,7 @@ -- | A suitable concrete type for testing. type SearchState = Search.SearchState.SearchState Type.Crypto.PositionHash -instance forall positionHash. ( +instance ( Data.Bits.FiniteBits positionHash, Num positionHash, Show positionHash, @@ -55,11 +52,7 @@ ) => Test.QuickCheck.Arbitrary (Search.SearchState.SearchState positionHash) where {-# SPECIALISE instance Test.QuickCheck.Arbitrary SearchState #-} arbitrary = do - evaluationOptions <- Test.QuickCheck.arbitrary - Search.SearchState.initialise <$> ( - Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree ( - evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue - ) <$> Test.QuickCheck.arbitrary {-SearchOptions-} <*> Test.QuickCheck.arbitrary {-Zobrist-} <*> return {-to Gen-monad-} Property.Empty.empty {-MoveFrequency-} <*> Test.QuickCheck.arbitrary {-Game-} + Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree <$> Test.QuickCheck.arbitrary {-EvaluationOptions-} <*> Test.QuickCheck.arbitrary {-SearchOptions-} <*> Test.QuickCheck.arbitrary {-Zobrist-} <*> return {-to Gen-monad-} Property.Empty.empty {-MoveFrequency-} <*> Test.QuickCheck.arbitrary {-Game-} ) diff --git a/src-test/BishBosh/Test/QuickCheck/State/Board.hs b/src-test/BishBosh/Test/QuickCheck/State/Board.hs --- a/src-test/BishBosh/Test/QuickCheck/State/Board.hs +++ b/src-test/BishBosh/Test/QuickCheck/State/Board.hs @@ -28,14 +28,14 @@ results ) where -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() import BishBosh.Test.QuickCheck.Cartesian.Coordinates() +import BishBosh.Test.QuickCheck.Colour.LogicalColour() import Control.Arrow((&&&)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Property.Empty as Property.Empty @@ -60,10 +60,10 @@ instance Test.QuickCheck.Arbitrary State.Board.Board where arbitrary = let - isKingChecked :: Attribute.LogicalColour.LogicalColour -> State.Board.Board -> Bool + isKingChecked :: Colour.LogicalColour.LogicalColour -> State.Board.Board -> Bool isKingChecked logicalColour board = not . all ( - null . ($ board) . State.Board.findAttackersOf logicalColour - ) . State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.King $ State.Board.getCoordinatesByRankByLogicalColour board + null . State.Board.findAttackersOf board logicalColour + ) $ State.CoordinatesByRankByLogicalColour.dereference (State.Board.getCoordinatesByRankByLogicalColour board) logicalColour Attribute.Rank.King in Control.Monad.foldM ( \board piece -> Test.QuickCheck.suchThat ( fmap ( @@ -71,7 +71,7 @@ ) . Test.QuickCheck.suchThat Test.QuickCheck.arbitrary {-destination-} $ uncurry (&&) . ( Data.Maybe.maybe True {-unoccupied-} ( not . Component.Piece.isKing -- Avoid taking a King. - ) . (`State.MaybePieceByCoordinates.dereference` State.Board.getMaybePieceByCoordinates board) &&& not . (`Component.Piece.isPawnPromotion` piece) -- Avoid impossible scenarios. + ) . State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) &&& not . Component.Piece.isPawnPromotion piece -- Avoid impossible scenarios. ) -- Predicate. ) $ not . uncurry (||) . ( isKingChecked minBound &&& isKingChecked maxBound @@ -104,17 +104,21 @@ _ -> False in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, let - f :: Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Colour.LogicalColour.LogicalColour -> Test.QuickCheck.Property f source logicalColour = Test.QuickCheck.label "Board.prop_bishopsMove/logicalColour" . all ( (== Cartesian.Coordinates.getLogicalColourOfSquare source) . Cartesian.Coordinates.getLogicalColourOfSquare . fst {-coordinates-} - ) . State.MaybePieceByCoordinates.listDestinationsFor source piece . State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source where + ) $ State.MaybePieceByCoordinates.listDestinationsFor ( + State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source + ) source piece where piece = Component.Piece.mkBishop logicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Colour.LogicalColour.LogicalColour -> Test.QuickCheck.Property f source logicalColour = Test.QuickCheck.label "Board.prop_knightsMove/logicalColour" . all ( (/= Cartesian.Coordinates.getLogicalColourOfSquare source) . Cartesian.Coordinates.getLogicalColourOfSquare . fst {-coordinates-} - ) . State.MaybePieceByCoordinates.listDestinationsFor source piece . State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source where + ) $ State.MaybePieceByCoordinates.listDestinationsFor ( + State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source + ) source piece where piece = Component.Piece.mkKnight logicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let @@ -122,7 +126,7 @@ f board = Test.QuickCheck.label "Board.prop_listDestinationsFor/unique" $ all ( \(coordinates, piece) -> uncurry (==) . ( length &&& length . Data.List.nub - ) $ State.MaybePieceByCoordinates.listDestinationsFor coordinates piece maybePieceByCoordinates + ) $ State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates coordinates piece ) $ StateProperty.Seeker.findAllPieces maybePieceByCoordinates where maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, @@ -135,13 +139,13 @@ \destination -> foldr ( \rank m -> foldr ( \source -> Map.insertWith Data.Set.union source $ Data.Set.singleton rank - ) m $ State.Board.findAttacksBy ( + ) m $ State.Board.findAttacksBy board ( Component.Piece.mkPiece (Property.Opposable.getOpposite logicalColour) rank - ) destination board + ) destination ) Property.Empty.empty Property.FixedMembership.members == foldr ( \(source, rank) -> Map.insertWith Data.Set.union source $ Data.Set.singleton rank ) Property.Empty.empty ( - State.Board.findAttackersOf logicalColour destination board + State.Board.findAttackersOf board logicalColour destination ) ) coordinates ) . State.CoordinatesByRankByLogicalColour.assocs $ State.Board.getCoordinatesByRankByLogicalColour board @@ -150,18 +154,30 @@ f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_(findBlockingPiece => isObstructed)" $ all ( \(source, _) -> let - isClear = ($ maybePieceByCoordinates) . State.MaybePieceByCoordinates.isClear source + isClear = State.MaybePieceByCoordinates.isClear maybePieceByCoordinates source in all ( \direction -> Data.Maybe.maybe ( - Data.Maybe.maybe True isClear . Data.Maybe.listToMaybe . reverse $ Cartesian.Coordinates.extrapolate direction source + Data.Maybe.maybe True isClear . Data.Maybe.listToMaybe . reverse $ Cartesian.Coordinates.extrapolate source direction ) ( isClear . fst {-destination-} - ) $ State.MaybePieceByCoordinates.findBlockingPiece direction source maybePieceByCoordinates + ) $ State.MaybePieceByCoordinates.findBlockingPiece maybePieceByCoordinates source direction ) Property.FixedMembership.members ) $ StateProperty.Seeker.findAllPieces maybePieceByCoordinates where maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let + f :: State.Board.Board -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f board coordinates = Test.QuickCheck.label "Board.prop_findBlockingPieces" . ( + \maybePieceByCoordinates -> State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates coordinates Nothing == Data.Maybe.mapMaybe (State.MaybePieceByCoordinates.findBlockingPiece maybePieceByCoordinates coordinates) Property.FixedMembership.members + ) $ State.Board.getMaybePieceByCoordinates board + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: State.Board.Board -> Colour.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f board logicalColour coordinates = Test.QuickCheck.label "Board.prop_findAttackerInDirections" . ( + \maybePieceByCoordinates -> State.MaybePieceByCoordinates.findAttackerInDirections maybePieceByCoordinates logicalColour coordinates Nothing == Data.Maybe.mapMaybe (State.MaybePieceByCoordinates.findAttackerInDirection maybePieceByCoordinates logicalColour coordinates) Property.FixedMembership.members + ) $ State.Board.getMaybePieceByCoordinates board + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.prop_findPieces" . uncurry (==) . ( Data.List.sort . StateProperty.Seeker.findAllPieces . State.Board.getCoordinatesByRankByLogicalColour &&& Data.List.sort . StateProperty.Seeker.findAllPieces . State.Board.getMaybePieceByCoordinates @@ -183,7 +199,7 @@ Data.Foldable.sum . ( StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour ! ) &&& fromIntegral . length . ( - \logicalColour -> State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour + \logicalColour -> State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour Attribute.Rank.Pawn ) ) ) Property.FixedMembership.members @@ -192,14 +208,14 @@ let f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_(exposesKing => isKingChecked)" $ all ( - \(logicalColour, move) -> State.Board.isKingChecked logicalColour $ State.Board.movePiece move Nothing board + \(logicalColour, move) -> State.Board.isKingChecked (State.Board.movePiece move Nothing board) logicalColour ) [ (logicalColour, move) | (source, piece) <- StateProperty.Seeker.findAllPieces $ State.Board.getMaybePieceByCoordinates board, let logicalColour = Component.Piece.getLogicalColour piece, - (destination, _) <- State.MaybePieceByCoordinates.listDestinationsFor source piece $ State.Board.getMaybePieceByCoordinates board, + (destination, _) <- State.MaybePieceByCoordinates.listDestinationsFor (State.Board.getMaybePieceByCoordinates board) source piece, let move = Component.Move.mkMove source destination, - State.Board.exposesKing logicalColour move board + State.Board.exposesKing board logicalColour move ] -- List-comprehension. in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let @@ -207,11 +223,9 @@ f board = Test.QuickCheck.label "Board.prop_findProximateKnights" . all ( \(coordinates, piece) -> let logicalColour = Property.Opposable.getOpposite $ Component.Piece.getLogicalColour piece - in Data.List.sort ( - StateProperty.Seeker.findProximateKnights logicalColour coordinates maybePieceByCoordinates - ) == Data.List.sort ( - StateProperty.Seeker.findProximateKnights logicalColour coordinates coordinatesByRankByLogicalColour - ) + in uncurry (==) $ ( + Data.List.sort . StateProperty.Seeker.findProximateKnights maybePieceByCoordinates logicalColour &&& Data.List.sort . StateProperty.Seeker.findProximateKnights coordinatesByRankByLogicalColour logicalColour + ) coordinates ) $ StateProperty.Seeker.findAllPieces maybePieceByCoordinates where (maybePieceByCoordinates, coordinatesByRankByLogicalColour) = State.Board.getMaybePieceByCoordinates &&& State.Board.getCoordinatesByRankByLogicalColour $ board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f diff --git a/src-test/BishBosh/Test/QuickCheck/State/CastleableRooksByLogicalColour.hs b/src-test/BishBosh/Test/QuickCheck/State/CastleableRooksByLogicalColour.hs --- a/src-test/BishBosh/Test/QuickCheck/State/CastleableRooksByLogicalColour.hs +++ b/src-test/BishBosh/Test/QuickCheck/State/CastleableRooksByLogicalColour.hs @@ -28,12 +28,12 @@ results ) where -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() import BishBosh.Test.QuickCheck.Cartesian.Coordinates() +import BishBosh.Test.QuickCheck.Colour.LogicalColour() import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Reflectable as Property.Reflectable @@ -84,29 +84,29 @@ f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f castleableRooksByLogicalColour = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(canCastle /= hasCastled)" . not $ any ( uncurry (&&) . ( - (`State.CastleableRooksByLogicalColour.canCastle` castleableRooksByLogicalColour) &&& (`State.CastleableRooksByLogicalColour.hasCastled` castleableRooksByLogicalColour) + State.CastleableRooksByLogicalColour.canCastle castleableRooksByLogicalColour &&& State.CastleableRooksByLogicalColour.hasCastled castleableRooksByLogicalColour ) ) Property.FixedMembership.members in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: Colour.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f logicalColour coordinates castleableRooksByLogicalColour = coordinates `notElem` [ minBound, Cartesian.Coordinates.bottomRight, Cartesian.Coordinates.topLeft, maxBound - ] ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_canCastleWith" . not $ State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour + ] ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_canCastleWith" . not $ State.CastleableRooksByLogicalColour.canCastleWith castleableRooksByLogicalColour logicalColour coordinates in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64} f, let - f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property - f logicalColour coordinates castleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(canCastleWith => canCastle)" $ State.CastleableRooksByLogicalColour.canCastle logicalColour castleableRooksByLogicalColour + f :: Colour.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f logicalColour coordinates castleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.canCastleWith castleableRooksByLogicalColour logicalColour coordinates ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(canCastleWith => canCastle)" $ State.CastleableRooksByLogicalColour.canCastle castleableRooksByLogicalColour logicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64, Test.QuickCheck.maxDiscardRatio = 128 } f, let - f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property - f logicalColour coordinates castleableRooksByLogicalColour = not (State.CastleableRooksByLogicalColour.canCastle logicalColour castleableRooksByLogicalColour) ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(not . canCastle => not . canCastleWith)" . not $ State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour + f :: Colour.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f logicalColour coordinates castleableRooksByLogicalColour = not (State.CastleableRooksByLogicalColour.canCastle castleableRooksByLogicalColour logicalColour) ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(not . canCastle => not . canCastleWith)" . not $ State.CastleableRooksByLogicalColour.canCastleWith castleableRooksByLogicalColour logicalColour coordinates in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs --- a/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs @@ -41,24 +41,20 @@ let f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property f zobrist game = Test.QuickCheck.label "Hashable.prop_hash(Game)/unique" . areUnique . map ( - (`StateProperty.Hashable.hash` zobrist) . (`Model.Game.applyQualifiedMove` game) + StateProperty.Hashable.hash zobrist . (`Model.Game.applyQualifiedMove` game) ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property f zobrist game = Test.QuickCheck.label "Hashable.prop_hash(Position)/unique" . areUnique . map ( - (`StateProperty.Hashable.hash` zobrist) . Model.Game.mkPosition . (`Model.Game.applyQualifiedMove` game) + StateProperty.Hashable.hash zobrist . Model.Game.mkPosition . (`Model.Game.applyQualifiedMove` game) ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property f zobrist game = Test.QuickCheck.label "Hashable.prop_(hash(Game) == hash(Position))" . all ( uncurry (==) . ( - ( - `StateProperty.Hashable.hash` zobrist - ) &&& ( - `StateProperty.Hashable.hash` zobrist - ) . Model.Game.mkPosition + StateProperty.Hashable.hash zobrist &&& StateProperty.Hashable.hash zobrist . Model.Game.mkPosition ) . (`Model.Game.applyQualifiedMove` game) ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, @@ -66,8 +62,8 @@ f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property f zobrist game = Test.QuickCheck.label "Hashable.prop_incrementalEvaluation" . all ( ( - \game' -> StateProperty.Hashable.hash game' zobrist == Model.Game.updateIncrementalPositionHash game ( - StateProperty.Hashable.hash game zobrist + \game' -> StateProperty.Hashable.hash zobrist game' == Model.Game.updateIncrementalPositionHash game ( + StateProperty.Hashable.hash zobrist game ) game' zobrist ) . (`Model.Game.applyQualifiedMove` game) ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/Mutator.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/Mutator.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/Mutator.hs @@ -0,0 +1,90 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.StateProperty.Mutator( +-- * Constants + results, +-- * Functions +-- normalise +) where + +import BishBosh.Test.QuickCheck.Component.Piece() +import BishBosh.Test.QuickCheck.Model.Game() +import Control.Arrow((&&&)) +import Test.QuickCheck ((==>)) +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator +import qualified BishBosh.StateProperty.View as StateProperty.View +import qualified Data.Default +import qualified Data.Maybe +import qualified Test.QuickCheck + +-- | Facilitate comparison. +normalise :: State.CoordinatesByRankByLogicalColour.CoordinatesByRankByLogicalColour -> State.CoordinatesByRankByLogicalColour.BareCoordinatesByRankByLogicalColour +normalise = State.CoordinatesByRankByLogicalColour.deconstruct . State.CoordinatesByRankByLogicalColour.sortCoordinates + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Maybe Component.Piece.Piece -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f maybePiece coordinates = let + defineCoordinates :: StateProperty.Mutator.Mutator mutator => mutator -> mutator + defineCoordinates = StateProperty.Mutator.defineCoordinates maybePiece coordinates + in Test.QuickCheck.label "Mutator.prop_defineCoordinates" . uncurry (==) $ (normalise . StateProperty.View.translate . defineCoordinates . State.Board.getMaybePieceByCoordinates &&& normalise . defineCoordinates . State.Board.getCoordinatesByRankByLogicalColour) Data.Default.def + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 128 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f game = not ( + uncurry (||) $ (Model.Game.isTerminated &&& Property.Null.isNull) game + ) ==> Test.QuickCheck.label "Mutator.prop_movePiece" . all ( + \qualifiedMove -> let + (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove + board = Model.Game.getBoard game + + movePiece :: StateProperty.Mutator.Mutator mutator => mutator -> mutator + movePiece = StateProperty.Mutator.movePiece move ( + Data.Maybe.fromJust . State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) $ Component.Move.getSource move + ) ( + Attribute.MoveType.getMaybePromotedRank moveType + ) $ if Attribute.MoveType.isEnPassant moveType + then Left . Component.Move.getDestination . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove . Data.Maybe.fromJust $ Model.Game.maybeLastTurn game + else Right $ Attribute.MoveType.getMaybeExplicitlyTakenRank moveType + in uncurry (==) $ ( + normalise . StateProperty.View.translate . movePiece . State.Board.getMaybePieceByCoordinates &&& normalise . movePiece . State.Board.getCoordinatesByRankByLogicalColour + ) board + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 128 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/View.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/View.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/View.hs @@ -0,0 +1,65 @@ +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.StateProperty.View( +-- * Constants + results +) where + +import BishBosh.Test.QuickCheck.Model.Game() +import Control.Arrow((&&&)) +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.StateProperty.View as StateProperty.View +import qualified Data.List +import qualified Test.QuickCheck + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "View.prop_toAssocs(CoordinatesByRankByLogicalColour == getMaybePieceByCoordinates)" . uncurry (==) . ( + normalise . State.Board.getCoordinatesByRankByLogicalColour &&& normalise . State.Board.getMaybePieceByCoordinates + ) . Model.Game.getBoard where + normalise :: StateProperty.Seeker.Seeker seeker => seeker -> [Component.Piece.LocatedPiece] + normalise = Data.List.sortOn fst {-coordinates-} . StateProperty.View.toAssocs + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "View.prop_translate(MaybePieceByCoordinates)" . uncurry (==) . ( + id &&& StateProperty.View.translate {-to self-} + ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "View.prop_translate(CoordinatesByRankByLogicalColour)" . uncurry (==) . ( + State.CoordinatesByRankByLogicalColour.deconstruct &&& State.CoordinatesByRankByLogicalColour.deconstruct . StateProperty.View.translate {-to self-} + ) . State.CoordinatesByRankByLogicalColour.sortCoordinates . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Type/Mass.hs b/src-test/BishBosh/Test/QuickCheck/Type/Mass.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Type/Mass.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + Copyright (C) 2021 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 . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' +-} + +module BishBosh.Test.QuickCheck.Type.Mass() where + +#ifdef USE_NEWTYPE_WRAPPERS +import qualified BishBosh.Type.Mass as Type.Mass +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Type.Mass.PieceSquareValue where + arbitrary = let + resolution :: Int + resolution = 100 + in fromRational . (/ fromIntegral resolution) . fromIntegral <$> Test.QuickCheck.elements [0 .. pred resolution] +#endif + diff --git a/src-test/BishBosh/Test/QuickCheck/UI/Command.hs b/src-test/BishBosh/Test/QuickCheck/UI/Command.hs --- a/src-test/BishBosh/Test/QuickCheck/UI/Command.hs +++ b/src-test/BishBosh/Test/QuickCheck/UI/Command.hs @@ -43,9 +43,9 @@ UI.Command.Save, UI.Command.Swap ], -- Nullary commands - UI.Command.Print `fmap` Test.QuickCheck.arbitrary, + UI.Command.Print <$> Test.QuickCheck.arbitrary, fmap UI.Command.RollBack . Test.QuickCheck.elements $ Nothing : map Just [1 .. 10], - UI.Command.Set `fmap` Test.QuickCheck.arbitrary + UI.Command.Set <$> Test.QuickCheck.arbitrary ] -- | The constant test-results for this data-type. diff --git a/src-test/HUnit.hs b/src-test/HUnit.hs --- a/src-test/HUnit.hs +++ b/src-test/HUnit.hs @@ -24,18 +24,18 @@ module Main(main) where -import qualified BishBosh.Test.HUnit.Attribute.Direction as Test.HUnit.Attribute.Direction -import qualified BishBosh.Test.HUnit.Attribute.LogicalColour as Test.HUnit.Attribute.LogicalColour import qualified BishBosh.Test.HUnit.Attribute.Rank as Test.HUnit.Attribute.Rank import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates import qualified BishBosh.Test.HUnit.Cartesian.Vector as Test.HUnit.Cartesian.Vector -import qualified BishBosh.Test.HUnit.Component.Move as Test.HUnit.Component.Move +import qualified BishBosh.Test.HUnit.Colour.LogicalColour as Test.HUnit.Colour.LogicalColour import qualified BishBosh.Test.HUnit.Component.CastlingMove as Test.HUnit.Component.CastlingMove +import qualified BishBosh.Test.HUnit.Component.Move as Test.HUnit.Component.Move import qualified BishBosh.Test.HUnit.Component.Piece as Test.HUnit.Component.Piece import qualified BishBosh.Test.HUnit.Component.Zobrist as Test.HUnit.Component.Zobrist import qualified BishBosh.Test.HUnit.ContextualNotation.PGN as Test.HUnit.ContextualNotation.PGN import qualified BishBosh.Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree as Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree import qualified BishBosh.Test.HUnit.ContextualNotation.StandardAlgebraic as Test.HUnit.ContextualNotation.StandardAlgebraic +import qualified BishBosh.Test.HUnit.Direction.Direction as Test.HUnit.Direction.Direction import qualified BishBosh.Test.HUnit.Evaluation.Fitness as Test.HUnit.Evaluation.Fitness import qualified BishBosh.Test.HUnit.Input.Options as Test.HUnit.Input.Options import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game @@ -52,8 +52,8 @@ main :: IO () main = mapM_ Test.HUnit.runTestTT [ Test.HUnit.Text.AutoComplete.testCases, - Test.HUnit.Attribute.Direction.testCases, - Test.HUnit.Attribute.LogicalColour.testCases, + Test.HUnit.Colour.LogicalColour.testCases, + Test.HUnit.Direction.Direction.testCases, Test.HUnit.Attribute.Rank.testCases, Test.HUnit.Cartesian.Coordinates.testCases, Test.HUnit.Cartesian.Vector.testCases, diff --git a/src-test/QuickCheck.hs b/src-test/QuickCheck.hs --- a/src-test/QuickCheck.hs +++ b/src-test/QuickCheck.hs @@ -24,12 +24,11 @@ module Main(main) where -import qualified BishBosh.Test.QuickCheck.Attribute.Direction as Test.QuickCheck.Attribute.Direction -import qualified BishBosh.Test.QuickCheck.Attribute.LogicalColour as Test.QuickCheck.Attribute.LogicalColour import qualified BishBosh.Test.QuickCheck.Attribute.MoveType as Test.QuickCheck.Attribute.MoveType import qualified BishBosh.Test.QuickCheck.Attribute.Rank as Test.QuickCheck.Attribute.Rank import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates import qualified BishBosh.Test.QuickCheck.Cartesian.Vector as Test.QuickCheck.Cartesian.Vector +import qualified BishBosh.Test.QuickCheck.Colour.LogicalColour as Test.QuickCheck.Colour.LogicalColour import qualified BishBosh.Test.QuickCheck.Component.Move as Test.QuickCheck.Component.Move import qualified BishBosh.Test.QuickCheck.Component.Piece as Test.QuickCheck.Component.Piece import qualified BishBosh.Test.QuickCheck.Component.QualifiedMove as Test.QuickCheck.Component.QualifiedMove @@ -41,6 +40,7 @@ import qualified BishBosh.Test.QuickCheck.ContextualNotation.StandardAlgebraic as Test.QuickCheck.ContextualNotation.StandardAlgebraic import qualified BishBosh.Test.QuickCheck.Data.Foldable as Test.QuickCheck.Data.Foldable import qualified BishBosh.Test.QuickCheck.Data.Integral as Test.QuickCheck.Data.Integral +import qualified BishBosh.Test.QuickCheck.Direction.Direction as Test.QuickCheck.Direction.Direction import qualified BishBosh.Test.QuickCheck.Evaluation.PositionHashQuantifiedGameTree as Test.QuickCheck.Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Test.QuickCheck.Input.CriteriaWeights as Test.QuickCheck.Input.CriteriaWeights import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions @@ -65,7 +65,9 @@ import qualified BishBosh.Test.QuickCheck.State.Position as Test.QuickCheck.State.Position import qualified BishBosh.Test.QuickCheck.StateProperty.Censor as Test.QuickCheck.StateProperty.Censor import qualified BishBosh.Test.QuickCheck.StateProperty.Hashable as Test.QuickCheck.StateProperty.Hashable +import qualified BishBosh.Test.QuickCheck.StateProperty.Mutator as Test.QuickCheck.StateProperty.Mutator import qualified BishBosh.Test.QuickCheck.StateProperty.Seeker as Test.QuickCheck.StateProperty.Seeker +import qualified BishBosh.Test.QuickCheck.StateProperty.View as Test.QuickCheck.StateProperty.View import qualified BishBosh.Test.QuickCheck.State.TurnsByLogicalColour as Test.QuickCheck.State.TurnsByLogicalColour import qualified BishBosh.Test.QuickCheck.Text.Encoding as Test.QuickCheck.Text.Encoding import qualified BishBosh.Test.QuickCheck.UI.Command as Test.QuickCheck.UI.Command @@ -83,10 +85,10 @@ Test.QuickCheck.Data.Foldable.results, Test.QuickCheck.Data.Integral.results, Test.QuickCheck.Text.Encoding.results, - Test.QuickCheck.Attribute.LogicalColour.results, - Test.QuickCheck.Attribute.Direction.results, + Test.QuickCheck.Colour.LogicalColour.results, Test.QuickCheck.Attribute.Rank.results, Test.QuickCheck.Attribute.MoveType.results, + Test.QuickCheck.Direction.Direction.results, Test.QuickCheck.Input.EvaluationOptions.results, Test.QuickCheck.Input.Options.results, Test.QuickCheck.Input.PieceSquareTable.results, @@ -111,6 +113,8 @@ Test.QuickCheck.StateProperty.Censor.results, Test.QuickCheck.StateProperty.Hashable.results, Test.QuickCheck.StateProperty.Seeker.results, + Test.QuickCheck.StateProperty.View.results, + Test.QuickCheck.StateProperty.Mutator.results, Test.QuickCheck.Model.Game.results, Test.QuickCheck.Model.GameTree.results, Test.QuickCheck.Model.MoveFrequency.results,