diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -39,3 +39,4 @@ ## Author This application is written & maintained by Dr. Alistair Ward. + diff --git a/bishbosh.cabal b/bishbosh.cabal --- a/bishbosh.cabal +++ b/bishbosh.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.0 +cabal-version: 2.4 -- This file is part of BishBosh. -- @@ -16,10 +16,9 @@ -- along with BishBosh. If not, see . Name: bishbosh -Version: 0.1.0.0 +Version: 0.1.1.0 Copyright: (C) 2018 Dr. Alistair Ward --- License: GPL-3.0-or-later -License: GPL-3 +License: GPL-3.0-or-later License-file: LICENSE Author: Dr. Alistair Ward Stability: stable @@ -86,6 +85,12 @@ Manual: True Default: False +-- Whether, to wrap common types in 'newtype' for increased type-safety. CAVEAT: there's a ~10% performance-penalty. +flag newtypewrappers + Description: Wrap common types in newtype for increased type-safety. + Manual: True + Default: False + -- Concurrency is used to implement Pondering, & parallelism is used when searching through archived games. flag threaded Description: Build for parallel runtime. @@ -112,16 +117,12 @@ Exposed-modules: BishBosh.Attribute.CaptureMoveSortAlgorithm BishBosh.Attribute.ColourScheme - BishBosh.Attribute.CriterionValue - BishBosh.Attribute.CriterionWeight BishBosh.Attribute.Direction BishBosh.Attribute.LogicalColour BishBosh.Attribute.LogicalColourOfSquare BishBosh.Attribute.MoveType BishBosh.Attribute.PhysicalColour BishBosh.Attribute.Rank - BishBosh.Attribute.RankValues - BishBosh.Attribute.WeightedMeanAndCriterionValues BishBosh.Cartesian.Abscissa BishBosh.Cartesian.Coordinates BishBosh.Cartesian.Ordinate @@ -144,14 +145,12 @@ BishBosh.Data.Either BishBosh.Data.Enum BishBosh.Data.Exception - BishBosh.Data.Float BishBosh.Data.Foldable BishBosh.Data.Integral BishBosh.Data.List BishBosh.Data.Num BishBosh.Data.Ratio BishBosh.Data.RoseTree - BishBosh.Data.Time BishBosh.Evaluation.Fitness BishBosh.Evaluation.PositionHashQuantifiedGameTree BishBosh.Evaluation.QuantifiedGame @@ -166,17 +165,19 @@ BishBosh.Input.Options BishBosh.Input.PGNOptions BishBosh.Input.PieceSquareTable + BishBosh.Input.RankValues BishBosh.Input.SearchOptions BishBosh.Input.StandardOpeningOptions BishBosh.Input.UIOptions BishBosh.Input.Verbosity - BishBosh.Model.DrawReason + BishBosh.Metric.CriterionValue + BishBosh.Metric.CriterionWeight + BishBosh.Metric.RankValue + BishBosh.Metric.WeightedMeanAndCriterionValues BishBosh.Model.Game - BishBosh.Model.GameTerminationReason BishBosh.Model.GameTree BishBosh.Model.MoveFrequency BishBosh.Model.PositionHashTree - BishBosh.Model.Result BishBosh.Notation.ICCFNumeric BishBosh.Notation.MoveNotation BishBosh.Notation.PureCoordinate @@ -191,7 +192,12 @@ BishBosh.Property.Orientated BishBosh.Property.Reflectable BishBosh.Property.Rotatable + BishBosh.Property.SelfValidating BishBosh.Property.ShowFloat + BishBosh.Property.Switchable + BishBosh.Rule.DrawReason + BishBosh.Rule.GameTerminationReason + BishBosh.Rule.Result BishBosh.Search.AlphaBeta BishBosh.Search.DynamicMoveData BishBosh.Search.EphemeralData @@ -216,7 +222,12 @@ BishBosh.Text.Encoding BishBosh.Text.ShowList BishBosh.Text.ShowPrefix - BishBosh.Types + BishBosh.Time.GameClock + BishBosh.Time.StopWatch + BishBosh.Type.Count + BishBosh.Type.Crypto + BishBosh.Type.Length + BishBosh.Type.Mass BishBosh.UI.Command BishBosh.UI.PrintObject BishBosh.UI.ReportObject @@ -255,7 +266,7 @@ if flag(polyparse) Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=1 + CPP-Options: -DUSE_POLYPARSE=2 Exposed-modules: BishBosh.Text.Poly else Build-depends: parsec @@ -263,6 +274,9 @@ if flag(narrownumbers) CPP-Options: -DUSE_NARROW_NUMBERS + if flag(newtypewrappers) + CPP-Options: -DUSE_NEWTYPE_WRAPPERS + if flag(threaded) Build-depends: parallel >= 3.0 CPP-Options: -DUSE_PARALLEL @@ -304,7 +318,6 @@ hxt, mtl, random, - time, toolshed >= 0.18 if impl(ghc >= 7.0) @@ -356,6 +369,7 @@ Other-modules: Duel.Data.Options Duel.IO.Logger + Duel.Process.Handles Duel.Process.Intermediary Paths_bishbosh @@ -365,6 +379,7 @@ containers, data-default, filepath, + hxt, process >= 1.6.4 CPP-Options: -DMOVE_NOTATION='S' @@ -406,6 +421,8 @@ BishBosh.Test.HUnit.Search.Search BishBosh.Test.HUnit.State.Board BishBosh.Test.HUnit.Text.AutoComplete + BishBosh.Test.HUnit.Time.GameClock + BishBosh.Test.HUnit.Time.StopWatch Paths_bishbosh Build-depends: @@ -418,16 +435,15 @@ HUnit, hxt, mtl, + random, toolshed >= 0.18 --- CPP-Options: -DUSE_SEARCH - if impl(ghc >= 8.0) GHC-options: -Wredundant-constraints if flag(polyparse) Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=1 + CPP-Options: -DUSE_POLYPARSE=2 else Build-depends: parsec @@ -441,12 +457,10 @@ Other-modules: BishBosh.Test.QuickCheck.Attribute.CaptureMoveSortAlgorithm - BishBosh.Test.QuickCheck.Attribute.CriterionWeight BishBosh.Test.QuickCheck.Attribute.Direction BishBosh.Test.QuickCheck.Attribute.LogicalColour BishBosh.Test.QuickCheck.Attribute.MoveType BishBosh.Test.QuickCheck.Attribute.Rank - BishBosh.Test.QuickCheck.Attribute.RankValues BishBosh.Test.QuickCheck.Cartesian.Coordinates BishBosh.Test.QuickCheck.Cartesian.Vector BishBosh.Test.QuickCheck.Component.Move @@ -471,20 +485,23 @@ BishBosh.Test.QuickCheck.Input.Options BishBosh.Test.QuickCheck.Input.PGNOptions BishBosh.Test.QuickCheck.Input.PieceSquareTable + BishBosh.Test.QuickCheck.Input.RankValues BishBosh.Test.QuickCheck.Input.SearchOptions BishBosh.Test.QuickCheck.Input.StandardOpeningOptions BishBosh.Test.QuickCheck.Input.UIOptions BishBosh.Test.QuickCheck.Input.Verbosity - BishBosh.Test.QuickCheck.Model.DrawReason + BishBosh.Test.QuickCheck.Metric.CriterionWeight + BishBosh.Test.QuickCheck.Metric.RankValue BishBosh.Test.QuickCheck.Model.Game - BishBosh.Test.QuickCheck.Model.GameTerminationReason BishBosh.Test.QuickCheck.Model.GameTree BishBosh.Test.QuickCheck.Model.MoveFrequency - BishBosh.Test.QuickCheck.Model.Result BishBosh.Test.QuickCheck.Notation.ICCFNumeric BishBosh.Test.QuickCheck.Notation.MoveNotation BishBosh.Test.QuickCheck.Notation.PureCoordinate BishBosh.Test.QuickCheck.Notation.Smith + BishBosh.Test.QuickCheck.Rule.DrawReason + BishBosh.Test.QuickCheck.Rule.GameTerminationReason + BishBosh.Test.QuickCheck.Rule.Result BishBosh.Test.QuickCheck.Search.KillerMoves BishBosh.Test.QuickCheck.Search.Search BishBosh.Test.QuickCheck.Search.SearchState @@ -495,6 +512,7 @@ BishBosh.Test.QuickCheck.StateProperty.Censor BishBosh.Test.QuickCheck.State.TurnsByLogicalColour BishBosh.Test.QuickCheck.Text.Encoding + BishBosh.Test.QuickCheck.Time.StopWatch BishBosh.Test.QuickCheck.UI.Command BishBosh.Test.QuickCheck.UI.PrintObject BishBosh.Test.QuickCheck.UI.ReportObject @@ -519,7 +537,7 @@ if flag(polyparse) Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=1 + CPP-Options: -DUSE_POLYPARSE=2 else Build-depends: parsec 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.0.0 +Version: 0.1.1.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 @@ -4,79 +4,115 @@ * First version of the package. ## 0.0.0.2 -Minor changes required to build on Windows. +* Minor changes required to build on Windows. ## 0.0.0.3 -Added **Paths_bishbosh** to **Other-modules** section of cabal file. +* Added **Paths_bishbosh** to **Other-modules** section of cabal file. ## 0.0.0.4 -Changed references to author's domain-name. +* Changed references to author's domain-name. ## 0.0.0.5 -Added ability to specify the text-encoding used in a PGN-database file. -Updated list of test-compilers. +* Added ability to specify the text-encoding used in a PGN-database file. +* Updated list of test-compilers. ## 0.0.0.6 -Fixed failure to persist game-state after requesting that the game be restarted. -Fixed parsing of **TextEncoding** in **PGNOptions**. -Replaced module **Distribution.Verbosity** with **BishBosh.Input.Verbosity**. +* Fixed failure to persist game-state after requesting that the game be restarted. +* Fixed parsing of **TextEncoding** in **PGNOptions**. +* Replaced module **Distribution.Verbosity** with **BishBosh.Input.Verbosity**. ## 0.0.0.7 -Rewrote function **BishBosh.Data.RoseTree.countTerminalNodes** in accordance with the suggestions of David Feuer. -Amended function **BishBosh.State.EnPassantAbscissa.mkMaybeEnPassantAbscissa** to guard against exposing one's King after En-passant capture. +* Rewrote function **BishBosh.Data.RoseTree.countTerminalNodes** in accordance with the suggestions of David Feuer. +* Amended function **BishBosh.State.EnPassantAbscissa.mkMaybeEnPassantAbscissa** to guard against exposing one's King after En-passant capture. ## 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. +* 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. ## 0.1.0.0 ### Bug-fixes: - * Upgraded the transposition-table in module **Search.DynamicMoveData**, from merely recording moves (which doesn't include the rank to which a Pawn is promoted), to recording qualified-moves. - * In function **Search.AlphaBeta.negaMax.descend.selectMax**, amended bound function **isFitter** to prefer shorter move-sequences where fitness is equal, & corrected the scenario in which all nodes were skipped because they were repetitious, but without ever defining alpha. +* Upgraded the transposition-table in module **Search.DynamicMoveData**, from merely recording moves (which doesn't include the rank to which a Pawn is promoted), to recording qualified-moves. +* In function **Search.AlphaBeta.negaMax.descend.selectMax**, amended bound function **isFitter** to prefer shorter move-sequences where fitness is equal, & corrected the scenario in which all nodes were skipped because they were repetitious, but without ever defining alpha. + ### Features: - * Added the configurable runtime ability to asynchronously decompress PGN-databases, & to set a maximum number of games to read. - * Added a configuration-option to normalise the values of specified piece-square tables into the closed unit-interval. - * Modularised the packaged config-files, by defining XML **External Entities** in the DTD. - * Added suggestions on failure to parse a user-command, & created a module **Text.AutoComplete** to contain common code. - * Added runtime commands: - ----------------------------------------- - Command | Purpose - --------------------------------| ------- - **availableMoves** | to report all available moves from the current position. - **maxPositionInstances** | to reveal the maximum number of instances any available position has been visited. - **reversiblePlyCount** | to count the number of consecutive reversible plies that have been made. - ----------------------------------------- - * Added **makefile** to facilitate common tasks. - * Removed the configuration-option **preferMovesTowardsCentre** & its implementation in function **Cartesian.Coordinates.radiusSquared**, because of it's conceptually wobbly foundations. +* Added the configurable runtime ability to asynchronously decompress PGN-databases, & to set a maximum number of games to read. +* Added a configuration-option to normalise the values of specified piece-square tables into the closed unit-interval. +* Modularised the packaged config-files, by defining XML **External Entities** in the DTD. +* Added suggestions on failure to parse a user-command, & created a module **Text.AutoComplete** to contain common code. +* Added **makefile** to facilitate common tasks. +* Removed the configuration-option **preferMovesTowardsCentre** & its implementation in function **Cartesian.Coordinates.radiusSquared**, because of it's conceptually wobbly foundations. + +### New Runtime Cmmands: +----------------------------------------- +Command | Purpose +--------------------------------| ------- +**availableMoves** | to report all available moves from the current position. +**maxPositionInstances** | to reveal the maximum number of instances any available position has been visited. +**reversiblePlyCount** | to count the number of consecutive reversible plies that have been made. +----------------------------------------- + ### Command-line Options: - * Added a new module **Input.CategorisedCommandLineOptions** to improved the partitioning of command-line options into functional categories. - * Added a command-line option **--formatPieceSquareTableForGNUPlot** to print the piece-square tables in a format suitable for **GNUPlot**. +* Added a new module **Input.CategorisedCommandLineOptions** to improved the partitioning of command-line options into functional categories. +* Added a command-line option **--formatPieceSquareTableForGNUPlot** to print the piece-square tables in a format suitable for **GNUPlot**. + ### Performance: - * Included a compilation-flag **unboxedarrays**, to request the use of unboxed arrays where (infrequently) possible. - * Changed data-type **Component.PieceSquareByCoordinatesByRank.EitherPieceSquareValueByNPiecesByCoordinates**, bringing type **Cartesian.Coordinates.ByCoordinates** inside **Either**, leading to significant space/time gains. - * Constructed each large constant data-structure in parallel. Bracketed all data-parallel operations with CPP-conditionals controlled by the compilation-flag **threaded**. - * Parallelised function **Attribute.CriterionValue.calculateWeightedMean**. -### Architectural: - * Added new modules: - ----------------------------------------- - Module | Purpose - --------------------------------| ------- - **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. - **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**. - **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. - ----------------------------------------- +* Included a compilation-flag **unboxedarrays**, to request the use of unboxed arrays where (infrequently) possible. +* Changed data-type **Component.PieceSquareByCoordinatesByRank.EitherPieceSquareValueByNPiecesByCoordinates**, bringing type **Cartesian.Coordinates.ByCoordinates** inside **Either**, leading to significant space/time gains. +* Constructed each large constant data-structure in parallel. Bracketed all data-parallel operations with CPP-conditionals controlled by the compilation-flag **threaded**. +* Parallelised function **Attribute.CriterionValue.calculateWeightedMean**. + +### New Modules: +----------------------------------------- +Module | Purpose +--------------------------------| ------- +**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. +**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**. +**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. +----------------------------------------- + ### Testing: - * Split **src-test/Main.hs** into **src-test/HUnit.hs** & **src-test/QuickCheck.hs**, each referenced independently from the cabal file. - * Added an executable **duel** (to coordinate a battle between two independently configured instances of **bishbosh**) & a corresponding section-1 man-page. - * Validated the list of ranks supplied to construct either **Attribute.RankValues.RankValues** or **Input.PieceSquareTable.PieceSquareTable**. +* Split **src-test/Main.hs** into **src-test/HUnit.hs** & **src-test/QuickCheck.hs**, each referenced independently from the cabal file. +* Added an executable **duel** (to coordinate a battle between two independently configured instances of **bishbosh**) & a corresponding section-1 man-page. +* Validated the list of ranks supplied to construct either **Attribute.RankValues.RankValues** or **Input.PieceSquareTable.PieceSquareTable**. + ### Refactoring: - * Flattened the nested array **Component.Zobrist.getRandomByCoordinatesByRankByLogicalColour**, by means of a composite index. - * Reimplemented function **Cartesian.Coordinates.getLogicalColourOfSquare**. - * Reimplemented function **Cartesian.Coordinates.interpolationsByDestinationBySource** in terms of function **Cartesian.Coordinates.extrapolationsByDirectionByCoordinates**. - * Used the **LambdaCase** language-extension. +* Flattened the nested array **Component.Zobrist.getRandomByCoordinatesByRankByLogicalColour**, by means of a composite index. +* Reimplemented function **Cartesian.Coordinates.getLogicalColourOfSquare**. +* Reimplemented function **Cartesian.Coordinates.interpolationsByDestinationBySource** in terms of function **Cartesian.Coordinates.extrapolationsByDirectionByCoordinates**. +* Used the **LambdaCase** language-extension. + +## 0.1.1.0 +### New Modules: +--------------------------------------------------------- +New Module | Purpose +------------------------------------------------| ------- +**BishBosh.Time.StopWatch** | Replaces module **BishBosh.Data.Time** to encapsulate interaction with module **Data.Time.Clock**. +**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.Crypto** | Self-documentation. +**BishBosh.Type.Length** | Replaced the polymorphic type-parameters **row** & **column** with newtypes 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. + +### 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**. + +### BishBosh: +* Created a new directory **Rule/** to which **Model.**{**DrawReason**, **GameTerminationReason**, **Result**} were relocated. +* 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. + + 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. +* Avoided repeated calls from module **BishBosh.Evaluation.Fitness** to function **IBishBosh.nput.RankValues.calculateMaximumTotalValue** by adding the record-field **BishBosh.Input.EvaluationOptions.getMaximumTotalRankValue**. + diff --git a/config/bishbosh.dtd b/config/bishbosh.dtd --- a/config/bishbosh.dtd +++ b/config/bishbosh.dtd @@ -30,8 +30,8 @@ > @@ -145,7 +145,6 @@ displaySAN (False | True) #IMPLIED editMode (False | True) #IMPLIED forceMode (False | True) #IMPLIED - pause CDATA #IMPLIED ponderMode (False | True) #IMPLIED postMode (False | True) #IMPLIED protocolVersion CDATA #IMPLIED diff --git a/config/bishbosh.rng b/config/bishbosh.rng --- a/config/bishbosh.rng +++ b/config/bishbosh.rng @@ -20,7 +20,7 @@ - + @@ -268,7 +268,6 @@ displaySAN editMode forceMode - pause ponderMode postMode diff --git a/config/rankValues_Carlson.xml b/config/rankValues_Carlson.xml --- a/config/rankValues_Carlson.xml +++ b/config/rankValues_Carlson.xml @@ -22,9 +22,9 @@ These are the values (in the closed unit-interval rather than the traditional centi-pawns) of various ranks of piece. N.B.: derived from . --> - - - - - - + + + + + + diff --git a/config/rankValues_Kaufman.xml b/config/rankValues_Kaufman.xml --- a/config/rankValues_Kaufman.xml +++ b/config/rankValues_Kaufman.xml @@ -22,9 +22,9 @@ These are the values (in the closed unit-interval rather than the traditional centi-pawns) of various ranks of piece N.B.: derived from Larry Kaufman's values; --> - - - - - - + + + + + + diff --git a/config/rankValues_Medvedev.xml b/config/rankValues_Medvedev.xml --- a/config/rankValues_Medvedev.xml +++ b/config/rankValues_Medvedev.xml @@ -22,9 +22,9 @@ These are the values (in the closed unit-interval rather than the traditional centi-pawns) of various ranks of piece. N.B.: derived from https://www.chessprogramming.org/Point_Value_by_Regression_Analysis. --> - - - - - - + + + + + + diff --git a/copyright b/copyright --- a/copyright +++ b/copyright @@ -9,3 +9,4 @@ License: GNU GENERAL PUBLIC LICENSE Version 3; see '/usr/share/common-licenses/GPL-3' or '/usr/share/doc/licenses/gpl-3.0.txt' where available, or the local packaged file 'LICENSE'. + diff --git a/makefile b/makefile --- a/makefile +++ b/makefile @@ -13,61 +13,61 @@ # You should have received a copy of the GNU General Public License # along with BishBosh. If not, see . -.PHONY: hlint test prof cabalCheck sdist findOmissions xboard duel haddock graphmod +.PHONY: cabalCheck duel findOmissions graphmod haddock hlint prof randomTest sdist test xboard PACKAGE_NAME = bishbosh SHELL = /bin/bash GHC_OPTIONS = --ghc-options='-j' BIN_DIR = $$HOME/.local/bin/ -# Build hlint. -$(BIN_DIR)/hlint: - @stack install hlint +$(BIN_DIR)/graphmod $(BIN_DIR)/hlint: + @[ -x $@ ] || stack install $(suffix @) $(GHC_OPTIONS) -# Check for lint. +# Display the module-dependency graph. +graphmod: $(BIN_DIR)/graphmod + @$@ --graph-dim='40,24' -i 'src-lib' -i 'src-exe' Main | tred | dot -Tsvg | display + +# Groom sourcecode. hlint: $(BIN_DIR)/hlint - @$@ --cpp-define 'USE_PARALLEL'\ + @$@ -j --no-exit-code\ + --cpp-define 'USE_PARALLEL'\ --cpp-define 'USE_POLYPARSE=1'\ --cpp-define 'USE_UNBOXED_ARRAYS'\ + --cpp-define 'USE_NEWTYPE_WRAPPERS'\ --ignore 'Use tuple-section'\ - src-lib/ +RTS -N -RTS || true - @$@ --cpp-define 'USE_HXTRELAXNG'\ + src-lib/ +RTS -N -RTS + @$@ -j --no-exit-code\ + --cpp-define 'USE_HXTRELAXNG'\ --cpp-define 'USE_PARALLEL'\ --cpp-define 'USE_UNBOXED_ARRAYS'\ --cpp-define 'USE_UNIX'\ --cpp-define 'MOVE_NOTATION=S'\ --ignore 'Reduce duplication'\ - src-exe/ +RTS -N -RTS || true - @$@ --cpp-define 'USE_PARALLEL'\ + src-exe/ +RTS -N -RTS + @$@ -j --cpp-define 'USE_PARALLEL'\ --cpp-define 'USE_POLYPARSE=1'\ --cpp-define 'USE_SEARCH'\ --ignore 'Use tuple-section'\ src-test/ +RTS -N -RTS -# Compile with various CPP-flags & run the test-suites. +# Serially compile with various CPP-flags & run the test-suites. test: - @for FLAG in -narrownumbers -polyparse -hxtrelaxng narrownumbers -threaded unboxedarrays; do\ + @for FLAG in -polyparse newtypewrappers -hxtrelaxng narrownumbers unboxedarrays -threaded; do\ echo $${FLAG};\ stack '$@' --flag="$(PACKAGE_NAME):$${FLAG}" $(GHC_OPTIONS) || break;\ done +# Compile with random CPP-flags & run the test-suites. +randomTest: + @FLAGS=$$(shuf --echo -- hxtrelaxng -hxtrelaxng narrownumbers -narrownumbers newtypewrappers -newtypewrappers polyparse -polyparse threaded -threaded unboxedarrays -unboxedarrays | head --lines=3 | sed -e 's/\(.*\)/--flag=$(PACKAGE_NAME):\1/');\ + echo $$FLAGS;\ + stack test $${FLAGS} $(GHC_OPTIONS) + # Profile. prof: @stack install --library-profiling --executable-profiling $(GHC_OPTIONS) @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_$@.xml' +RTS -p -N2 -RTS -# Check the cabal-file. -cabalCheck: - @cabal check - -# Package for upload to Hackage. -sdist: - @cabal '$@' - -# Find source-files missing from the distribution. -findOmissions: sdist - @diff <(find src-* -type f \( -name '*.hs' -a ! -name 'Setup.hs' \) | sed 's!^\./!!' | sort) <(tar -ztf dist*/sdist/$(PACKAGE_NAME)-*.tar.gz | grep '\.hs$$' | sed 's!^$(PACKAGE_NAME)-[0-9.]*/!!' | sort) - # Install this product. $(BIN_DIR)/$(PACKAGE_NAME) $(BIN_DIR)/duel: @stack install $(GHC_OPTIONS) @@ -78,13 +78,21 @@ # Start a battle. duel: $(BIN_DIR)/duel - @$@ --verbosity='Verbose' --nGames=128 --readTimeout=30 -i 'config/Raw/bishbosh_$@_white.xml' -i 'config/Raw/bishbosh_$@_black.xml' + @$@ --nGames=32 --verbosity='Verbose' -i 'config/Raw/$(PACKAGE_NAME)_$@_white.xml' -i 'config/Raw/$(PACKAGE_NAME)_$@_black.xml' # Build the source-code documentation. haddock: @stack '$@' --no-$@-deps $(GHC_OPTIONS) -# Show module-dependency graph. -graphmod: - @$@ --graph-dim='40,24' -i 'src-exe' -i 'src-lib' Main | tred | dot -Tsvg | display # CAVEAT: doesn't include 'Duel'. +# Package for upload to Hackage. +sdist: + @cabal '$@' + +# Check the cabal-file. +cabalCheck: + @cabal check + +# Find source-files missing from the distribution. +findOmissions: sdist + @diff <(find src-* -type f -name '*.hs' | sed 's!^\./!!' | sort) <(tar -ztf dist*/sdist/$(PACKAGE_NAME)-*.tar.gz | grep '\.hs$$' | grep -v 'Setup.hs' | sed 's!^$(PACKAGE_NAME)-[0-9.]*/!!' | sort) diff --git a/man/man1/duel.1 b/man/man1/duel.1 --- a/man/man1/duel.1 +++ b/man/man1/duel.1 @@ -7,7 +7,8 @@ .PP An application which automatically plays chess, by forking two independently configured instances of \fBbishbosh\fR. One instance automates the moves of White & the other automates the moves of Black. -This application merely acts as an intermediary, passing moves between these instances to synchronise their positions, while collating the game-results to permit comparison of the fitness of their respective configurations. +This application merely acts as an intermediary, passing moves between these instances to synchronise their positions, +while measuring the total time taken by either side & collating the game-results to permit comparison of the fitness of their respective configurations. .PP This process facilitates optimisation of the complex configuration of \fBbishbosh\fR. .SH OPTIONS @@ -15,21 +16,32 @@ \fB--verbosity=\fR(\fBSilent\fR|\fBNormal\fR|\fBVerbose\fR|\fBDeafening\fR), defaulting to "\fBNormal\fR". Defines the quantity of ancillary output required. .TP +\fB-d\fR \fIInt\fR, \fB--nDecimalDigits=\fR\fIInt\fR, defaulting to "\fB0\fR". +The precision with which to display the total time taken by each side. +.TP \fB-n\fR \fIInt\fR, \fB--nGames=\fR\fIInt\fR, defaulting to "\fB1\fR". The number of games to be played before presenting the results. .TP \fB-t\fR \fIInt\fR, \fB--readTimeout=\fR\fIInt\fR, defaulting to \fIindefinitely\fR. -The number of seconds to wait for a move before aborting. -CAVEAT: the period typically required depends on; +The maximum number of seconds to wait for one of the forked processes to return a move, before aborting. +CAVEAT: the required period typically required depends on; .IP \(bu the machine's speed, .IP \(bu what else is running on the machine, .IP \(bu -the search-depth, +the size of the machine's RAM, .IP \(bu -the fitness-evaluation criteria. +the time initially required to process any PGN-database, +.IP \(bu +\fBbishbosh\fR's configuration (e.g. search-depth or fitness-evaluation criteria). .TP +.B --verifyConfiguration +Verify the mutual compatibility of the two configuration-files before forwarding each to a forked instance of \fBbishbosh\fR, +where the syntactic & semantic correctness will be independently verified. +The configurations are required to define the same move-notation & to define the logical colour of the automated player in the correct order to avoid deadlock. +N.B. since verification of this compatibility-requirement necessitates parsing, syntactic-verification is an inevitable side-effect. +.TP \fB-i\fR \fIFile-path\fR, \fB--appendInputConfigFilePath=\fR\fIFile-path\fR; there is no default. Define the path to a configuration-file to forward to \fBbishbosh\fR. Two such paths are required, the first will be passed to the instance playing White & the second to the instance playing Black. @@ -44,20 +56,22 @@ \fB0\fR on success, & >\fB0\fR if an error occurs. .SH EXAMPLES .nf -.B duel --verbosity='Verbose' --nGames=128 -i 'config/Raw/bishbosh_duel_white.xml' -i 'config/Raw/bishbosh_duel_black.xml' +.B duel --nGames=32 --verbosity='Verbose' --verifyConfiguration -i 'config/Raw/bishbosh_duel_white.xml' -i 'config/Raw/bishbosh_duel_black.xml' .fi .IP \(bu The application has been instructed to provide a relatively large amount of feedback. .IP \(bu -Two packaged configuration-files have been referenced, the first referring to the instance playing White, as required. +Two packaged configuration-files have been referenced. .IP \(bu +The compatibility of the configuration-files is verified to confirm that they automate White & Black respectively, & that they use the same move-notation. +.IP \(bu CAVEAT: assumes that the executable exists on \fB$PATH\fR, otherwise an explicit path will be required. .PP .nf .B make duel .fi .IP \(bu -The same as above. +Much the same as the previous example, but verification is unnecessary since the configuration-files are hard-coded. .IP \(bu The current working directory must be \fBbishbosh\fR's installation-directory where the required \fBmakefile\fR is defined. .SH FILES @@ -74,8 +88,6 @@ .SH AUTHOR Written by Dr. Alistair Ward. .SH BUGS -.IP \(bu -The comparison between the configurations of the two instances doesn't factor the time taken by each instance. .SS "REPORTING BUGS" Report bugs to "\fBbishbosh@functionalley.com\fR". .SH COPYRIGHT diff --git a/src-exe/BishBosh/Concurrent/Pondering.hs b/src-exe/BishBosh/Concurrent/Pondering.hs --- a/src-exe/BishBosh/Concurrent/Pondering.hs +++ b/src-exe/BishBosh/Concurrent/Pondering.hs @@ -91,3 +91,4 @@ ) ( const $ return {-to IO-monad-} "purging MVar." ) + 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 @@ -38,7 +38,7 @@ play ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.ContextualNotation.PositionHashQualifiedMoveTree as ContextualNotation.PositionHashQualifiedMoveTree import qualified BishBosh.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest @@ -54,7 +54,9 @@ import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.State.PlayState as State.PlayState import qualified BishBosh.Text.ShowColouredPrefix as Text.ShowColouredPrefix -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +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 @@ -74,15 +76,7 @@ -- | Plays the game according to the specified configuration. play :: ( - Control.DeepSeq.NFData column, -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Control.DeepSeq.NFData criterionWeight, Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, - Control.DeepSeq.NFData weightedMean, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y, Data.Array.IArray.Ix x, @@ -90,45 +84,29 @@ 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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, - Integral column, Integral x, Integral y, Ord positionHash, Read x, Read y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Real weightedMean, - Show column, Show pieceSquareValue, - Show row, Show x, Show y, System.Random.Random positionHash, System.Random.RandomGen randomGen ) => randomGen - -> Input.Options.Options column criterionWeight pieceSquareValue rankValue row x y + -> Input.Options.Options pieceSquareValue x y -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y -- ^ Standard openings. - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) -{-# SPECIALISE play :: ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row, - Integral column, - Show column, - Show row, - System.Random.RandomGen randomGen - ) + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) +{-# SPECIALISE play + :: System.Random.RandomGen randomGen => randomGen - -> Input.Options.Options column T.CriterionWeight T.PieceSquareValue T.RankValue row T.X T.Y - -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest T.X T.Y - -> IO (State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y) + -> Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y + -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest Type.Length.X Type.Length.Y + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) #-} play randomGen options qualifiedMoveForest = Data.Maybe.maybe ( return {-to IO-monad-} Data.Default.def {-game-} @@ -169,7 +147,7 @@ else Property.Empty.empty {-MoveFrequency-} ) ) >>= ( - const UI.Raw.takeTurns `either` const UI.CECP.takeTurns $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- Select a user-interface. + const UI.Raw.takeTurns ||| const UI.CECP.takeTurns $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- Select a user-interface. ) ( ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest ( Input.EvaluationOptions.getIncrementalEvaluation $ Input.Options.getEvaluationOptions options diff --git a/src-exe/BishBosh/State/ApplicationTerminationReason.hs b/src-exe/BishBosh/State/ApplicationTerminationReason.hs --- a/src-exe/BishBosh/State/ApplicationTerminationReason.hs +++ b/src-exe/BishBosh/State/ApplicationTerminationReason.hs @@ -40,8 +40,8 @@ | MaximumPlies -- ^ The configured maximum number of /turn/s has been reached. instance Show ApplicationTerminationReason where - showsPrec _ ByRequest = showString "by request" - showsPrec _ MaximumPlies = showString "because the configured maximum number of plies has been reached" + show ByRequest = "by request" + show MaximumPlies = "because the configured maximum number of plies has been reached" instance Control.DeepSeq.NFData ApplicationTerminationReason where rnf _ = () 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 @@ -65,13 +65,16 @@ import qualified BishBosh.Input.IOOptions as Input.IOOptions import qualified BishBosh.Input.Options as Input.Options import qualified BishBosh.Input.UIOptions as Input.UIOptions +import qualified BishBosh.Metric.CriterionValue as Metric.CriterionValue import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.State.ApplicationTerminationReason as State.ApplicationTerminationReason import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Bits @@ -81,58 +84,45 @@ import qualified Data.Ord import qualified Factory.Math.Statistics -#ifdef USE_PARALLEL -import qualified Control.DeepSeq -#endif - #ifdef USE_UNBOXED_ARRAYS import qualified Data.Array.Unboxed #endif -- | The type threaded through the sequence of /game/s during play. -data PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y = MkPlayState { - getCriterionValues :: [[criterionValue]], -- ^ The /criterion-value/s accumulated during the game. - getZobrist :: Component.Zobrist.Zobrist x y positionHash, -- ^ The constant hash-codes used construct position-hashes. - getMoveFrequency :: Model.GameTree.MoveFrequency x y, -- ^ The constant frequency of moves extracted from file. - getSearchState :: Search.SearchState.SearchState x y positionHash criterionValue weightedMean, - getOptions :: Input.Options.Options column criterionWeight pieceSquareValue rankValue row x y, -- ^ The constant options by which the game is configured. - getMaybeApplicationTerminationReason :: Maybe State.ApplicationTerminationReason.ApplicationTerminationReason -- ^ Whether the game has terminated. +data PlayState pieceSquareValue positionHash x y = MkPlayState { + getCriterionValues :: [[Metric.CriterionValue.CriterionValue]], -- ^ The /criterion-value/s accumulated during the game. + getZobrist :: Component.Zobrist.Zobrist x y positionHash, -- ^ The constant hash-codes used construct position-hashes. + getMoveFrequency :: Model.GameTree.MoveFrequency x y, -- ^ The constant frequency of moves extracted from file. + getSearchState :: Search.SearchState.SearchState x y positionHash, + getOptions :: Input.Options.Options pieceSquareValue x y, -- ^ The constant options by which the game is configured. + getMaybeApplicationTerminationReason :: Maybe State.ApplicationTerminationReason.ApplicationTerminationReason -- ^ Whether the game has terminated. } -- | Constructor. initialise :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif Data.Array.IArray.Ix x, #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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y ) - => Input.Options.Options column criterionWeight pieceSquareValue rankValue row x y + => Input.Options.Options pieceSquareValue x y -> Component.Zobrist.Zobrist x y positionHash -> Model.GameTree.MoveFrequency x y -> Model.Game.Game x y - -> PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + -> PlayState pieceSquareValue positionHash x y {-# SPECIALISE initialise - :: Input.Options.Options column T.CriterionWeight T.PieceSquareValue T.RankValue row T.X T.Y - -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash - -> Model.GameTree.MoveFrequency T.X T.Y - -> Model.Game.Game T.X T.Y - -> PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y + :: Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y + -> Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash + -> Model.GameTree.MoveFrequency Type.Length.X Type.Length.Y + -> Model.Game.Game Type.Length.X Type.Length.Y + -> PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y #-} initialise options zobrist moveFrequency game = MkPlayState { getCriterionValues = [], @@ -146,41 +136,32 @@ } -- | Accessor. -getGame :: PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y -> Model.Game.Game x y +getGame :: PlayState pieceSquareValue positionHash x y -> Model.Game.Game x y 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 column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y = PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y -> PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y +type Transformation pieceSquareValue positionHash x y = PlayState pieceSquareValue positionHash x y -> PlayState pieceSquareValue positionHash x y -- | Mutator. -setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y +setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> Transformation pieceSquareValue positionHash x y 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_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif Data.Array.IArray.Ix x, #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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y - ) => Model.Game.Game x y -> Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + ) => Model.Game.Game x y -> Transformation pieceSquareValue positionHash x y reconstructPositionHashQuantifiedGameTree game playState@MkPlayState { getZobrist = zobrist, getMoveFrequency = moveFrequency, @@ -193,27 +174,18 @@ -- | Reset to the initial state. resetPositionHashQuantifiedGameTree :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif Data.Array.IArray.Ix x, #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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y - ) => Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + ) => Transformation pieceSquareValue positionHash x y resetPositionHashQuantifiedGameTree playState = reconstructPositionHashQuantifiedGameTree Data.Default.def playState { getCriterionValues = [], getMaybeApplicationTerminationReason = Nothing @@ -221,19 +193,16 @@ -- | Mutator. updateWithAutomaticMove - :: [criterionValue] - -> Search.SearchState.SearchState x y positionHash criterionValue weightedMean - -> Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + :: [Metric.CriterionValue.CriterionValue] + -> Search.SearchState.SearchState x y positionHash + -> Transformation pieceSquareValue positionHash x y updateWithAutomaticMove criterionValues searchState playState = playState { getCriterionValues = criterionValues : getCriterionValues playState, getSearchState = searchState } -- | Mutator. -updateWithManualMove :: ( - Eq x, - Eq y - ) => Model.Game.Game x y -> Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y +updateWithManualMove :: (Eq x, Eq y) => Model.Game.Game x y -> Transformation pieceSquareValue positionHash x y updateWithManualMove game playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.State.PlayState.updateWithManualMove:\tEvaluation.PositionHashQuantifiedGameTree.reduce failed." @@ -251,15 +220,20 @@ -- | Calculate the /root-mean-square/ & the /standard-deviation/, of the values of each type of /criterion/. calculateCriterionValueStatistics :: ( Floating standardDeviation, - Fractional mean, - Real criterionValue - ) => PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y -> [(mean, standardDeviation)] + Fractional mean + ) + => PlayState pieceSquareValue positionHash x y + -> [(mean, standardDeviation)] calculateCriterionValueStatistics MkPlayState { getCriterionValues = criterionValues } = map ( - Factory.Math.Statistics.getMean &&& Factory.Math.Statistics.getStandardDeviation + ( + Factory.Math.Statistics.getMean &&& Factory.Math.Statistics.getStandardDeviation + ) . map ( + \criterionValue -> realToFrac criterionValue :: Type.Mass.CriterionValue + ) ) $ Data.List.transpose criterionValues -- | Resignation by the player who currently holds the choice of move. -resign :: Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y +resign :: Transformation pieceSquareValue positionHash x y resign playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Evaluation.PositionHashQuantifiedGameTree.resign $ Search.SearchState.getPositionHashQuantifiedGameTree searchState ) playState @@ -274,7 +248,7 @@ Show y ) => String -- ^ Move-string. - -> PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + -> PlayState pieceSquareValue positionHash x y -> [String] -- ^ Suggested corrections. suggestCorrections moveString playState@MkPlayState { getOptions = options } | Model.Game.isTerminated game = [] @@ -286,11 +260,12 @@ -- | Whether the game in the first /play-state/ has more plies than that in the second. hasMorePlies - :: PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y + :: PlayState pieceSquareValue positionHash x y + -> PlayState pieceSquareValue positionHash x y -> 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 column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y -> Bool +hasApplicationTerminationBeenRequested :: PlayState pieceSquareValue positionHash x y -> 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 @@ -43,11 +43,9 @@ takeTurns ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import Control.Monad((>=>)) import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn @@ -57,7 +55,6 @@ import qualified BishBosh.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Data.Time as Data.Time import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame @@ -66,15 +63,18 @@ import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.IOOptions as Input.IOOptions import qualified BishBosh.Input.Options as Input.Options +import qualified BishBosh.Input.RankValues as Input.RankValues import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Input.StandardOpeningOptions as Input.StandardOpeningOptions import qualified BishBosh.Input.UIOptions as Input.UIOptions +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Property.Switchable as Property.Switchable +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.State.ApplicationTerminationReason as State.ApplicationTerminationReason @@ -82,7 +82,11 @@ import qualified BishBosh.State.PlayState as State.PlayState import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix -import qualified BishBosh.Types as T +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.Length as Type.Length +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 @@ -99,8 +103,6 @@ import qualified Data.List.Extra import qualified Data.Map import qualified Data.Maybe -import qualified Data.Time.Clock -import qualified Numeric import qualified System.IO import qualified System.Random import qualified ToolShed.System.Random @@ -111,23 +113,23 @@ -- | Used in output to prefix hints. hintTag :: String -hintTag = "Hint:" +hintTag = "Hint:" -- | Used in output, to prefix moves. moveTag :: String -moveTag = "move" +moveTag = "move" -- | Used in output, to qualify a draw-offer. offerTag :: String -offerTag = "offer" +offerTag = "offer" -- | The response to a ping request. pongTag :: String -pongTag = "pong" +pongTag = "pong" -- | The command used to request the version of the CECP protocol. protoverTag :: String -protoverTag = "protover" +protoverTag = "protover" -- | Constant. explicitEnpassant :: ContextualNotation.StandardAlgebraic.ExplicitEnPassant @@ -164,29 +166,24 @@ mkParseFailureError :: ShowS mkParseFailureError = mkErrorMessage "parse-failure" --- | Format thinking-output suitable to be posted to xboard. -showsThinking :: ( - Fractional rankValue, - Real rankValue, - Real weightedMean - ) - => Input.SearchOptions.SearchDepth - -> Input.EvaluationOptions.EvaluationOptions criterionWeight pieceSquareValue rankValue x y - -> weightedMean - -> Data.Time.Clock.NominalDiffTime -- ^ Elapsed time. - -> Component.Move.NPlies -- ^ Nodes searched. - -> String -- ^ Principal variation. +-- | Format thinking-output suitable to be posted to /xboard/. +showsThinking + :: Property.ShowFloat.ShowFloat stoppedWatch + => Type.Count.NPlies -- ^ Search-depth. + -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y + -> Type.Mass.WeightedMean + -> stoppedWatch + -> Type.Count.NPositions -- ^ Nodes searched. + -> String -- ^ Principal variation. -> ShowS -showsThinking searchDepth evaluationOptions weightedMean elapsedTime nPlies principalVariation = Text.ShowList.showsDelimitedList (showChar ' ') id id [ +showsThinking searchDepth evaluationOptions weightedMean stoppedWatch nPlies principalVariation = Text.ShowList.showsDelimitedList (showChar ' ') id id [ shows searchDepth, - shows . ( - round :: Double -> Int - ) $ 100 {-centi-Pawns-} * realToFrac ( + shows . (round :: Type.Mass.RankValue -> Int) $ 100 {-centi-Pawns-} * ( uncurry (/) . ( - Attribute.RankValues.calculateMaximumTotalValue &&& Attribute.RankValues.findRankValue Attribute.Rank.Pawn + Input.RankValues.calculateMaximumTotalValue &&& realToFrac . Input.RankValues.findRankValue Attribute.Rank.Pawn ) $ Input.EvaluationOptions.getRankValues evaluationOptions ) * realToFrac weightedMean, - shows (round $ 100 {-centi-seconds-} * elapsedTime :: Int), + Property.ShowFloat.showsFloat (shows . (round :: Double -> Int) . (* 100)) stoppedWatch, shows nPlies ] . showChar '\t' . showString principalVariation @@ -195,15 +192,8 @@ * 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 column criterionValue criterionWeight pieceSquareValue positionHash randomGen rankValue row weightedMean x y. ( - Control.DeepSeq.NFData column, -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Control.DeepSeq.NFData criterionWeight, +readMove :: forall pieceSquareValue positionHash randomGen x y. ( Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y, Data.Array.IArray.Ix x, @@ -211,45 +201,31 @@ 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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, Ord positionHash, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Real weightedMean, - Show column, Show pieceSquareValue, - Show row, Show x, Show y, System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash -> randomGen - -> Data.Time.Clock.UTCTime - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) -{-# SPECIALISE readMove :: ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row, - Show column, - Show row, - System.Random.RandomGen randomGen - ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree T.X T.Y T.PositionHash + -> Time.StopWatch.StopWatch + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) +{-# SPECIALISE readMove + :: System.Random.RandomGen randomGen + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> randomGen - -> Data.Time.Clock.UTCTime - -> State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y - -> IO (State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y) + -> Time.StopWatch.StopWatch + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) #-} readMove positionHashQualifiedMoveTree randomGen = slave where - slave startUTCTime playState = let + slave runningWatch playState = let (game, options) = State.PlayState.getGame &&& State.PlayState.getOptions $ playState (searchOptions, ioOptions) = Input.Options.getSearchOptions &&& Input.Options.getIOOptions $ options @@ -261,13 +237,13 @@ moveNotation = Input.UIOptions.getMoveNotation uiOptions nDecimalDigits = Input.UIOptions.getNDecimalDigits uiOptions verbosity = Input.UIOptions.getVerbosity uiOptions - in ( - const . Control.Exception.throwIO $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.readMove.slave:\tunexpectedly found 'NativeUIOptions'." - ) `either` ( + in const ( + Control.Exception.throwIO $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.readMove.slave:\tunexpectedly found 'NativeUIOptions'." + ) ||| ( \cecpOptions -> let displaySAN = Input.CECPOptions.getDisplaySAN cecpOptions - onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -285,7 +261,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 x y criterionValue weightedMean) + else Notation.MoveNotation.showNotation moveNotation $ Evaluation.QuantifiedGame.getLastTurn (quantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y) _ -> 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 @@ -345,7 +321,7 @@ ) ( \(filePath, _) -> Control.Exception.catch ( do - System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` (Data.Default.def :: Model.Game.Game T.X T.Y)) + System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` (Data.Default.def :: Model.Game.Game Type.Length.X Type.Length.Y)) Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "the game-state has been saved in " $ shows filePath "." ) $ \e -> System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixError $ show (e :: Control.Exception.SomeException) @@ -361,13 +337,14 @@ } } onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Component.Move.NPlies -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) rollBack nPlies - | (game', _) : _ <- drop (pred nPlies) $ Model.Game.rollBack game = return {-to IO-monad-} $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState - | otherwise = onCommand UI.Command.Restart + | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = return {-to IO-monad-} $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState + | otherwise = onCommand UI.Command.Restart in Data.Maybe.maybe ( let - nPlies = succ $ Data.Map.size searchDepthByLogicalColour -- In fully manual play, rollback one ply, in semi-manual play rollback two plies. + nPlies :: Type.Count.NPlies + nPlies = fromIntegral . succ $ Data.Map.size searchDepthByLogicalColour -- In fully manual play, rollback one ply, in semi-manual play rollback two plies. in do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "rolling-back " $ shows nPlies " plies." @@ -403,7 +380,7 @@ do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." - slave startUTCTime playState { + slave runningWatch playState { State.PlayState.getOptions = Control.DeepSeq.force $ case setObject of UI.SetObject.SearchDepth searchDepth -> options { Input.Options.getSearchOptions = Input.SearchOptions.setSearchDepth searchDepth $ Input.Options.getSearchOptions options @@ -420,12 +397,12 @@ Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixWarning . showString " there aren't any " $ shows Input.SearchOptions.searchDepthTag " to swap." eventLoop - | otherwise = do + | otherwise = do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "swapping " $ shows Input.SearchOptions.searchDepthTag "." return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash x y) eventLoop = getLine >>= \line -> do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "received \"" $ showString line "\"." @@ -674,13 +651,13 @@ eventLoop | otherwise -> do - elapsedTime <- Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- Property.Switchable.toggle runningWatch - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "paused => stopping the clock at " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "paused => stopping the watch at " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.setEitherNativeUIOrCECPOptions ( - Right cecpOptions { Input.CECPOptions.getMaybePaused = Just elapsedTime } + Right $ Input.CECPOptions.pause stoppedWatch cecpOptions ) options } "playother" @@ -705,16 +682,14 @@ ) options } "resume" - | Just timeTaken <- maybePaused -> do - startUTCTime' <- Data.Time.Clock.getCurrentTime + | Just stoppedWatch <- maybePaused -> do + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowPrefix.showsPrefixInfo "resuming => restarting the watch." - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowPrefix.showsPrefixInfo "resuming => restarting the clock." + runningWatch' <- Property.Switchable.toggle stoppedWatch - slave ( - Data.Time.Clock.addUTCTime (negate timeTaken) startUTCTime' -- Restart the clock. - ) playState { + slave runningWatch' playState { State.PlayState.getOptions = Input.Options.setEitherNativeUIOrCECPOptions ( - Right cecpOptions { Input.CECPOptions.getMaybePaused = Nothing } + Right $ Input.CECPOptions.resume cecpOptions ) options } | otherwise -> do @@ -922,7 +897,7 @@ | Just value <- featureName `lookup` Input.CECPFeatures.getFeatures cecpFeatures -> do Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixWarning . showString Input.CECPFeatures.featureTag . Text.ShowList.showsAssociation $ shows arg' " rejected." - slave startUTCTime playState { + slave runningWatch playState { State.PlayState.getOptions = either ( \i -> if i /= 0 then \options' -> options' { @@ -940,7 +915,7 @@ [(featureName, stringArg)] -> do Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixWarning . showString Input.CECPFeatures.featureTag . Text.ShowList.showsAssociation $ shows arg' " rejected because of syntax." - slave startUTCTime playState { + slave runningWatch playState { State.PlayState.getOptions = options { Input.Options.getIOOptions = Input.IOOptions.deleteCECPFeature ( featureName, @@ -1014,7 +989,7 @@ maybePaused = Input.CECPOptions.getMaybePaused cecpOptions - moveCommand :: String -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + moveCommand :: String -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) moveCommand moveString = case Notation.MoveNotation.readsQualifiedMove moveNotation moveString of [(eitherQualifiedMove, "")] | Just errorMessage <- Model.Game.validateEitherQualifiedMove eitherQualifiedMove game -> do @@ -1024,9 +999,7 @@ eventLoop -- Recurse. | otherwise -> do - elapsedTime <- if forceMode - then return {-to IO-monad-} 0 - else Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- Property.Switchable.toggle runningWatch let game' = Model.Game.applyEitherQualifiedMove eitherQualifiedMove game @@ -1037,7 +1010,7 @@ Notation.MoveNotation.showNotation moveNotation . Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.UI.CECP.readMove.onCommand.moveCommand:\tModel.Game.maybeLastTurn failed." ) $ Model.Game.maybeLastTurn game' - ) . showString " was requested after " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + ) . showString " was requested after " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition game' positionHashQualifiedMoveTree of [] -> return () @@ -1066,16 +1039,8 @@ ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall column criterionValue criterionWeight pieceSquareValue positionHash randomGen rankValue row weightedMean x y. ( - Control.DeepSeq.NFData column, -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Control.DeepSeq.NFData criterionWeight, +takeTurns :: forall pieceSquareValue positionHash randomGen x y. ( Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, - Control.DeepSeq.NFData weightedMean, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y, Data.Array.IArray.Ix x, @@ -1083,40 +1048,26 @@ 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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, Ord positionHash, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Real weightedMean, - Show column, Show pieceSquareValue, - Show row, Show x, Show y, System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash -> randomGen - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) -{-# SPECIALISE takeTurns :: ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row, - Show column, - Show row, - System.Random.RandomGen randomGen - ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree T.X T.Y T.PositionHash + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) +{-# SPECIALISE takeTurns + :: System.Random.RandomGen randomGen + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> randomGen - -> State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y - -> IO (State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = do mVar <- Control.Concurrent.newEmptyMVar @@ -1136,24 +1087,24 @@ slave :: Maybe (Concurrent.Pondering.Pondering (Component.Move.Move x y)) - -> Maybe Component.Move.NPlies + -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) 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) = either ( - const . Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.takeTurns.slave:\tunexpectedly found 'NativeUIOptions'." - ) ( + (ponderMode, isPostMode) = const ( + Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.takeTurns.slave:\tunexpectedly found 'NativeUIOptions'." + ) ||| ( Input.CECPOptions.getPonderMode &&& Input.CECPOptions.getPostMode ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions' in Data.Maybe.maybe ( do - startUTCTime <- Data.Time.Clock.getCurrentTime + runningWatch <- Property.Switchable.on Data.Maybe.maybe ( do - playState'' <- readMove positionHashQualifiedMoveTree randomGen' startUTCTime playState' -- Read the user's command or move. + playState'' <- readMove positionHashQualifiedMoveTree randomGen' runningWatch playState' -- Read the user's command or move. (,) playState'' `fmap` ( if playState' `State.PlayState.hasMorePlies` playState'' @@ -1199,30 +1150,30 @@ quantifiedGames@(quantifiedGame : continuation {-optimal move-sequence-}) -> let bestTurn = Evaluation.QuantifiedGame.getLastTurn quantifiedGame in do - elapsedTime <- bestTurn `seq` Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- bestTurn `seq` Property.Switchable.toggle runningWatch Control.Monad.when (verbosity > Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . ( if verbosity == maxBound then Property.ShowFloat.showsFloatToN nDecimalDigits ( Control.Monad.Reader.runReader ( Evaluation.Fitness.evaluateFitness Nothing game' - ) evaluationOptions :: Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue + ) evaluationOptions :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues ) . Search.Search.showsSeparator -- Prepend the fitness of the original game prior to the result. else id - ) . Notation.MoveNotation.showsNotationFloatToNDecimals moveNotation nDecimalDigits searchResult' . showString " in " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + ) . Notation.MoveNotation.showsNotationFloatToNDecimals moveNotation nDecimalDigits searchResult' . showString " in " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." Control.Monad.when isPostMode . putStrLn $ showsThinking searchDepth' evaluationOptions ( Evaluation.QuantifiedGame.getFitness $ last quantifiedGames - ) elapsedTime ( - Search.Search.getNPliesEvaluated searchResult' + ) stoppedWatch ( + Search.Search.getNPositionsEvaluated searchResult' ) ( Text.ShowList.showsDelimitedList ( showChar ' ' ) id id ( zipWith ( - \turn originalGame -> if either ( - const . Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.takeTurns:\tunexpectedly found 'NativeUIOptions'." - ) Input.CECPOptions.getDisplaySAN $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions + \turn originalGame -> if const ( + Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.UI.CECP.takeTurns:\tunexpectedly found 'NativeUIOptions'." + ) ||| Input.CECPOptions.getDisplaySAN $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions then ContextualNotation.StandardAlgebraic.showsTurn explicitEnpassant turn originalGame else Notation.MoveNotation.showsNotation moveNotation turn ) ( @@ -1235,7 +1186,7 @@ (,) ( State.PlayState.updateWithAutomaticMove ( - Attribute.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame + Metric.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) searchState' playState' ) `fmap` if ponderMode && Input.SearchOptions.getUsePondering searchOptions then case continuation of @@ -1258,7 +1209,7 @@ ) ) ( \(qualifiedMove, names) -> do - elapsedTime <- Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- Property.Switchable.toggle runningWatch Data.Maybe.maybe ( return {-to IO-monad-} () @@ -1268,12 +1219,14 @@ let selectedGame = Model.Game.applyQualifiedMove qualifiedMove game' - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "selected " . Notation.MoveNotation.showsNotation moveNotation qualifiedMove . showString " from:" . ContextualNotation.QualifiedMoveForest.showsNames maybeMaximumPGNNames names . showString "\n\tin " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "selected " . Notation.MoveNotation.showsNotation moveNotation qualifiedMove . showString " from:" . ContextualNotation.QualifiedMoveForest.showsNames maybeMaximumPGNNames names . showString "\n\tin " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." - Control.Monad.when isPostMode . putStrLn $ showsThinking searchDepth' evaluationOptions (0 :: weightedMean) elapsedTime 0 ( + Control.Monad.when isPostMode . putStrLn $ showsThinking searchDepth' evaluationOptions 0 stoppedWatch 0 ( Data.List.intercalate ( showString ".\n" $ replicate 4 ' ' -- Continuations must be preceded by at least 4 spaces. - ) $ Data.Maybe.maybe names (`take` names) maybeMaximumPGNNames + ) $ Data.Maybe.maybe names ( + (`take` names) . fromIntegral + ) maybeMaximumPGNNames ) "." putStrLn . showString moveTag . showChar ' ' $ Notation.MoveNotation.showNotation moveNotation qualifiedMove -- Send the move to the GUI. @@ -1306,13 +1259,13 @@ ) ) ( \gameTerminationReason -> do - putStrLn . shows (Model.GameTerminationReason.toResult gameTerminationReason) . showString " {" $ shows gameTerminationReason "}" -- Send the result to the GUI. + putStrLn . shows (Rule.GameTerminationReason.toResult gameTerminationReason) . showString " {" $ shows gameTerminationReason "}" -- Send the result to the GUI. let criterionValueStatistics = State.PlayState.calculateCriterionValueStatistics playState' showsFloat :: Double -> ShowS - showsFloat = Numeric.showFFloat $ Just nDecimalDigits + showsFloat = Property.ShowFloat.showsFloatToN' nDecimalDigits Control.Monad.when ( verbosity == maxBound && not (null criterionValueStatistics) @@ -1321,7 +1274,7 @@ ) criterionValueStatistics "." readMove positionHashQualifiedMoveTree randomGen' ( - Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.UI.CECP.takeTurns.slave:\tundefined startUTCTime." + Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.UI.CECP.takeTurns.slave:\tundefined stop-watch." ) playState' {-there're zero valid moves, but the user can issue commands-} >>= slave Nothing maybeMaximumPlies randomGens -- Tail recurse. ) $ Model.Game.getMaybeTerminationReason game' 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 @@ -29,9 +29,8 @@ takeTurns ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import Control.Monad((>=>), (<=<)) -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn @@ -40,7 +39,6 @@ import qualified BishBosh.ContextualNotation.PositionHashQualifiedMoveTree as ContextualNotation.PositionHashQualifiedMoveTree import qualified BishBosh.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Data.Time as Data.Time import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame @@ -50,11 +48,13 @@ import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Input.StandardOpeningOptions as Input.StandardOpeningOptions import qualified BishBosh.Input.UIOptions as Input.UIOptions +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Property.Switchable as Property.Switchable import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.State.ApplicationTerminationReason as State.ApplicationTerminationReason @@ -65,7 +65,11 @@ import qualified BishBosh.Text.ShowColouredPrefix as Text.ShowColouredPrefix import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix -import qualified BishBosh.Types as T +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.Length as Type.Length +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 @@ -81,8 +85,6 @@ import qualified Data.List.Extra import qualified Data.Map import qualified Data.Maybe -import qualified Data.Time.Clock -import qualified Numeric import qualified System.IO import qualified System.Random import qualified ToolShed.System.Random @@ -96,15 +98,8 @@ * 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 column criterionValue criterionWeight pieceSquareValue positionHash randomGen rankValue row weightedMean x y. ( - Control.DeepSeq.NFData column, -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Control.DeepSeq.NFData criterionWeight, +readMove :: forall pieceSquareValue positionHash randomGen x y. ( Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y, Data.Array.IArray.Ix x, @@ -112,48 +107,32 @@ 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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, - Integral column, Integral x, Integral y, Ord positionHash, Read x, Read y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Real weightedMean, - Show column, Show pieceSquareValue, - Show row, Show x, Show y, System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash -> randomGen - -> Data.Time.Clock.UTCTime - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) -{-# SPECIALISE readMove :: ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row, - Integral column, - Show column, - Show row, - System.Random.RandomGen randomGen - ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree T.X T.Y T.PositionHash + -> Time.StopWatch.StopWatch + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) +{-# SPECIALISE readMove + :: System.Random.RandomGen randomGen + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> randomGen - -> Data.Time.Clock.UTCTime - -> State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y - -> IO (State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y) + -> Time.StopWatch.StopWatch + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) #-} -readMove positionHashQualifiedMoveTree randomGen startUTCTime playState = let +readMove positionHashQualifiedMoveTree randomGen runningWatch playState = let (game, options) = State.PlayState.getGame &&& State.PlayState.getOptions $ playState (searchOptions, ioOptions) = Input.Options.getSearchOptions &&& Input.Options.getIOOptions $ options @@ -174,7 +153,7 @@ Notation.MoveNotation.getOrigin moveNotation ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard - onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -244,7 +223,7 @@ ) ( \(filePath, _) -> Control.Exception.catch ( do - System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` (Data.Default.def :: Model.Game.Game T.X T.Y)) + System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` (Data.Default.def :: Model.Game.Game Type.Length.X Type.Length.Y)) Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "the initial game-state has been saved in " $ shows filePath "." ) $ \e -> System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixError $ show (e :: Control.Exception.SomeException) @@ -252,16 +231,17 @@ return {-to IO-monad-} $ State.PlayState.resetPositionHashQuantifiedGameTree playState onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Component.Move.NPlies -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) rollBack nPlies - | (game', _) : _ <- drop (pred nPlies) $ Model.Game.rollBack game = do + | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = do Control.Monad.when (verbosity == maxBound) . putStrLn $ show2D game' return {-to IO-monad-} $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState | otherwise = onCommand UI.Command.Restart in Data.Maybe.maybe ( let - nPlies = succ $ Data.Map.size searchDepthByLogicalColour -- In fully manual play, rollback one ply, in semi-manual play rollback two plies. + nPlies :: Type.Count.NPlies + nPlies = fromIntegral . succ $ Data.Map.size searchDepthByLogicalColour -- In fully manual play, rollback one ply, in semi-manual play rollback two plies. in do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "rolling-back " $ shows nPlies " plies." @@ -297,7 +277,7 @@ do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." - readMove positionHashQualifiedMoveTree randomGen startUTCTime playState { + readMove positionHashQualifiedMoveTree randomGen runningWatch playState { State.PlayState.getOptions = Control.DeepSeq.force $ case setObject of UI.SetObject.SearchDepth searchDepth -> options { Input.Options.getSearchOptions = Input.SearchOptions.setSearchDepth searchDepth $ Input.Options.getSearchOptions options @@ -319,21 +299,23 @@ return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash x y) eventLoop = getLine >>= \line -> case Data.List.Extra.trim line of "?" -> onCommand $ UI.Command.Print UI.PrintObject.Help - ':' : s -> either ( - \errorMessage -> do - System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixError $ showString errorMessage "." - - eventLoop - ) ( - \(command, remainder) -> if null $ Data.List.Extra.trimStart remainder - then onCommand command - else do - System.IO.hPutStrLn System.IO.stderr . showString "unexpected trailing text " $ shows remainder "." + ':' : s -> ( + ( + \errorMessage -> do + System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixError $ showString errorMessage "." eventLoop + ) ||| ( + \(command, remainder) -> if null $ Data.List.Extra.trimStart remainder + then onCommand command + else do + System.IO.hPutStrLn System.IO.stderr . showString "unexpected trailing text " $ shows remainder "." + + eventLoop + ) ) . UI.Command.readsCommand $ UI.Command.autoComplete s s -> let corrections = State.PlayState.suggestCorrections s playState @@ -346,7 +328,7 @@ eventLoop -- Recurse. | otherwise -> do - elapsedTime <- Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- Property.Switchable.toggle runningWatch let game' = Model.Game.applyEitherQualifiedMove eitherQualifiedMove game @@ -357,7 +339,7 @@ Notation.MoveNotation.showNotation moveNotation . Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.UI.Raw.readMove.eventLoop:\tModel.Game.maybeLastTurn failed." ) $ Model.Game.maybeLastTurn game' - ) . showString " was requested after " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + ) . showString " was requested after " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." case ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition game' positionHashQualifiedMoveTree of [] -> return {-to IO-monad-} () @@ -383,21 +365,13 @@ Control.Monad.unless (verbosity == minBound) . putStrLn . showString "Enter either a move in " . shows moveNotation . showString "-notation, or '?' for " $ showString UI.PrintObject.helpTag ":" eventLoop - ) `either` ( - const . Control.Exception.throwIO $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.readMove:\tunexpected CECP-options." + ) ||| const ( + Control.Exception.throwIO $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.readMove:\tunexpected CECP-options." ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall column criterionValue criterionWeight pieceSquareValue positionHash randomGen rankValue row weightedMean x y. ( - Control.DeepSeq.NFData column, -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Control.DeepSeq.NFData criterionWeight, +takeTurns :: forall pieceSquareValue positionHash randomGen x y. ( Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, - Control.DeepSeq.NFData weightedMean, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y, Data.Array.IArray.Ix x, @@ -405,44 +379,28 @@ 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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, - Integral column, Integral x, Integral y, Ord positionHash, Read x, Read y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Real weightedMean, - Show column, Show pieceSquareValue, - Show row, Show x, Show y, System.Random.RandomGen randomGen ) => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash -> randomGen - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) -{-# SPECIALISE takeTurns :: ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row, - Integral column, - Show column, - Show row, - System.Random.RandomGen randomGen - ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree T.X T.Y T.PositionHash + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) +{-# SPECIALISE takeTurns + :: System.Random.RandomGen randomGen + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> randomGen - -> State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y - -> IO (State.PlayState.PlayState column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue row T.WeightedMean T.X T.Y) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = let options = State.PlayState.getOptions playState @@ -468,19 +426,19 @@ slave :: Maybe (Concurrent.Pondering.Pondering (Component.Move.Move x y)) - -> Maybe Component.Move.NPlies + -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y - -> IO (State.PlayState.PlayState column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y) + -> State.PlayState.PlayState pieceSquareValue positionHash x y + -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) slave maybePondering maybeMaximumPlies ~(randomGen' : randomGens) playState' = let (game', searchOptions') = State.PlayState.getGame &&& Input.Options.getSearchOptions . State.PlayState.getOptions $ playState' -- Deconstruct. in Data.Maybe.maybe ( do - startUTCTime <- Data.Time.Clock.getCurrentTime + runningWatch <- Property.Switchable.on Data.Maybe.maybe ( do - playState'' <- readMove positionHashQualifiedMoveTree randomGen' startUTCTime playState' -- Block reading a command-sequence terminating in a move from a manual player. + playState'' <- readMove positionHashQualifiedMoveTree randomGen' runningWatch playState' -- Block reading a command-sequence terminating in a move from a manual player. (,) playState'' `fmap` ( if playState' `State.PlayState.hasMorePlies` playState'' @@ -527,7 +485,7 @@ bestTurn = Evaluation.QuantifiedGame.getLastTurn quantifiedGame showsMove = Notation.MoveNotation.showsNotation moveNotation bestTurn in do - elapsedTime <- bestTurn `seq` Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- bestTurn `seq` Property.Switchable.toggle runningWatch if verbosity == minBound then putStrLn $ showsMove "" -- CAVEAT: potentially machine-interpreted. @@ -537,20 +495,18 @@ then Property.ShowFloat.showsFloatToN nDecimalDigits ( Control.Monad.Reader.runReader ( Evaluation.Fitness.evaluateFitness Nothing game' - ) $ Input.Options.getEvaluationOptions options :: Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue + ) $ Input.Options.getEvaluationOptions options :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues ) . Search.Search.showsSeparator -- Prepend the fitness of the original game prior to the new result. else id - ) $ ( - if verbosity > Data.Default.def - then Notation.MoveNotation.showsNotationFloatToNDecimals moveNotation nDecimalDigits searchResult' . showString " in " . Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime - else showsMove - ) "." + ) $ if verbosity > Data.Default.def + then Notation.MoveNotation.showsNotationFloatToNDecimals moveNotation nDecimalDigits searchResult' . showString " in " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." + else showsMove "." putStrLn . show2D $ Evaluation.QuantifiedGame.getGame quantifiedGame (,) ( State.PlayState.updateWithAutomaticMove ( - Attribute.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame + Metric.WeightedMeanAndCriterionValues.getCriterionValues $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) searchState' playState' ) `fmap` if Input.SearchOptions.getUsePondering searchOptions then case continuation of @@ -573,7 +529,7 @@ ) ) ( \(qualifiedMove, names) -> do - elapsedTime <- Data.Time.measureElapsedTime startUTCTime + stoppedWatch <- Property.Switchable.toggle runningWatch Data.Maybe.maybe ( return {-to IO-monad-} () @@ -589,7 +545,7 @@ else do Control.Monad.when (verbosity > Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "selected " . Notation.MoveNotation.showsNotation moveNotation qualifiedMove . showString " from:" . ContextualNotation.QualifiedMoveForest.showsNames ( Input.IOOptions.getMaybeMaximumPGNNames ioOptions - ) names . showString "\n\tin " $ Data.Time.showsTimeAsSeconds nDecimalDigits elapsedTime "." + ) names . showString "\n\tin " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." putStrLn $ show2D selectedGame @@ -632,7 +588,7 @@ criterionValueStatistics = State.PlayState.calculateCriterionValueStatistics playState' showsFloat :: Double -> ShowS - showsFloat = Numeric.showFFloat $ Just nDecimalDigits + showsFloat = Property.ShowFloat.showsFloatToN' nDecimalDigits Control.Monad.when ( verbosity == maxBound && not (null criterionValueStatistics) @@ -641,7 +597,7 @@ ) criterionValueStatistics "." readMove positionHashQualifiedMoveTree randomGen' ( - Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.takeTurns.slave:\tundefined startUTCTime." + Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.takeTurns.slave:\tundefined stop-watch." ) playState' {-there're zero valid moves, but the user can issue commands-} >>= slave Nothing maybeMaximumPlies randomGens -- Tail recurse. ) $ Model.Game.getMaybeTerminationReason game' @@ -649,7 +605,7 @@ Control.Monad.unless (verbosity == minBound) . putStrLn . show2D $ State.PlayState.getGame playState slave Nothing (Input.Options.getMaybeMaximumPlies options) (ToolShed.System.Random.randomGens randomGen) playState - ) `either` ( - const . Control.Exception.throwIO $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.takeTurns:\tunexpected CECP-options." + ) ||| const ( + Control.Exception.throwIO $ Data.Exception.mkInvalidDatum "BishBosh.UI.Raw.takeTurns:\tunexpected CECP-options." ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions diff --git a/src-exe/Duel.hs b/src-exe/Duel.hs --- a/src-exe/Duel.hs +++ b/src-exe/Duel.hs @@ -75,26 +75,41 @@ ) . mkTypeSpecification $ Text.Case.toUpperInitial Input.Verbosity.tag ) . showString "define the log-level; default '" $ shows (Data.Default.def :: Input.Verbosity.Verbosity) "'.", let + flag = "nDecimalDigits" + in G.Option "d" [flag] ( + G.ReqArg ( + Just . (,) flag . Just &&& Input.CommandLineOption.mkOptionsMutator . Data.Options.setNDecimalDigits . Input.CommandLineOption.readBoundedIntegral + ) $ mkTypeSpecification "Int" + ) . showString "define the precision with which to display floating-point numbers; default " $ shows (Data.Options.getNDecimalDigits Data.Default.def) ".", + let flag = "nGames" in G.Option "n" [flag] ( G.ReqArg ( Just . (,) flag . Just &&& Input.CommandLineOption.mkOptionsMutator . Data.Options.setNGames . Input.CommandLineOption.readBoundedIntegral ) $ mkTypeSpecification "Int" - ) "define the number of games to play.", + ) . showString "define the number of games to play; default " $ shows (Data.Options.getNGames Data.Default.def) ".", let flag = "readTimeout" in G.Option "t" [flag] ( G.ReqArg ( Just . (,) flag . Just &&& Input.CommandLineOption.mkOptionsMutator . Data.Options.setReadTimeout . Input.CommandLineOption.readBoundedIntegral - ) $ mkTypeSpecification "s" + ) $ mkTypeSpecification "Seconds" ) . showString "define the read-timeout; default " $ shows (Data.Options.getReadTimeout Data.Default.def) " s.", let + flag = "verifyConfiguration" + in G.Option "" [flag] ( + G.NoArg ( + Nothing {-N/A-}, + Input.CommandLineOption.mkOptionsMutator $ Data.Options.setVerifyConfiguration True + ) + ) "verify the mutual compatibility of the two configuration-files before forwarding each to a forked instance of 'bishbosh'.", + let flag = "appendInputConfigFilePath" in G.Option "i" [flag] ( G.ReqArg ( Just . (,) flag . Just &&& Input.CommandLineOption.mkOptionsMutator . Data.Options.appendInputConfigFilePath ) $ mkTypeSpecification "File-path" - ) . showString "define the path to an XML-file, to forward to an instance of bishbosh; " $ shows Data.Options.requiredInputConfigFiles " are required, White's first, then Black's." + ) "define the path to an XML-file, to forward to a forked instance of 'bishbosh'; specify White's first, then Black's." ] where author :: String author = "Dr. Alistair Ward" @@ -119,3 +134,4 @@ (_, nonOptions, []) -> Control.Exception.throwIO . Data.Exception.mkRedundantData . showString "unexpected command-line arguments; " $ shows nonOptions "." (_, _, errors) -> Control.Exception.throwIO . Data.Exception.mkParseFailure $ concat errors ) . G.getOpt G.RequireOrder optDescrList + 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 @@ -26,74 +26,91 @@ module Duel.Data.Options( -- * Types --- ** Type-synonyms - ReadTimeout, -- ** Data-types Options( -- MkOptions, - getVerbosity, + getInputConfigFilePaths, + getNDecimalDigits, getNGames, getReadTimeout, - getInputConfigFilePaths + getVerbosity, + getVerifyConfiguration ), --- * Constants - requiredInputConfigFiles, -- * Functions -- ** Mutators - setVerbosity, + setNDecimalDigits, setNGames, setReadTimeout, + setVerbosity, + setVerifyConfiguration, appendInputConfigFilePath ) where import qualified Control.Exception import qualified Data.Default -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Input.Verbosity as Input.Verbosity -import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Attribute.LogicalColour as Attribute.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 System.FilePath --- | The read-timeout in ms. -type ReadTimeout = Int - --- | Container for all comand-line options. +-- | Container for all command-line options. data Options = MkOptions { + getInputConfigFilePaths :: [System.FilePath.FilePath], -- ^ The configuration-file paths for White & Black respectively. + getNDecimalDigits :: Type.Count.NDecimalDigits, -- ^ The precision with which floating-point quantities are diaplayed. + getNGames :: Type.Count.NGames, -- ^ The number of successive games to play. + getReadTimeout :: Type.Count.NSeconds, -- ^ The seconds to wait for a move before timing-out. CAVEAT: any positive value should account for both configuration-options (e.g. search-depth) & the machine-speed. getVerbosity :: Input.Verbosity.Verbosity, -- ^ The extent to which logging is required. CAVEAT: this isn't forwarded to the forked instances of BishBosh. - getNGames :: Model.Game.NGames, -- ^ The number of successive games to play. - getReadTimeout :: ReadTimeout, -- ^ The seconds to wait for a move before timing-out. CAVEAT: a positive value should account for both search-depth & the machine-speed. - getInputConfigFilePaths :: [System.FilePath.FilePath] + getVerifyConfiguration :: Bool -- ^ Whether to check the configuration-files before forwarding them. } deriving (Eq, Show) instance Data.Default.Default Options where def = MkOptions { - getVerbosity = Data.Default.def, + getInputConfigFilePaths = [], -- CAVEAT: invalid; there must be exactly 2. + getNDecimalDigits = 0, getNGames = 1, getReadTimeout = -1, -- N.B.: a negative value is interpreted as an indefinite period. - getInputConfigFilePaths = [] + getVerbosity = Data.Default.def, + getVerifyConfiguration = False } +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.") + ] + -- | Mutator. -setVerbosity :: Input.Verbosity.Verbosity -> Options -> Options -setVerbosity verbosity options = options { getVerbosity = verbosity } +setNDecimalDigits :: Type.Count.NDecimalDigits -> Options -> Options +setNDecimalDigits nDecimalDigits options + | nDecimalDigits < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "Duel.Data.Options:\tnDecimalDigits=" $ shows nDecimalDigits " mustn't be negative." + | otherwise = options { getNDecimalDigits = nDecimalDigits } -- | Mutator. -setNGames :: Model.Game.NGames -> Options -> Options -setNGames n options - | n <= 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "Duel.Data.Options:\tnGames=" $ shows n " must exceed zero." - | otherwise = options { getNGames = n } +setNGames :: Type.Count.NGames -> Options -> Options +setNGames nGames options + | nGames <= 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "Duel.Data.Options:\tnGames=" $ shows nGames " must exceed zero." + | otherwise = options { getNGames = nGames } -- | Mutator. -setReadTimeout :: ReadTimeout -> Options -> Options +setReadTimeout :: Type.Count.NSeconds -> Options -> Options setReadTimeout t options = options { getReadTimeout = t } --- | The constant exact number of input config-files required. -requiredInputConfigFiles :: Int -requiredInputConfigFiles = 2 +-- | Mutator. +setVerbosity :: Input.Verbosity.Verbosity -> Options -> Options +setVerbosity verbosity options = options { getVerbosity = verbosity } -- | Mutator. +setVerifyConfiguration :: Bool -> Options -> Options +setVerifyConfiguration b options = options { getVerifyConfiguration = b } + +-- | Mutator. appendInputConfigFilePath :: System.FilePath.FilePath -> Options -> Options appendInputConfigFilePath s options - | length inputConfigFilePaths == requiredInputConfigFiles = Control.Exception.throw . Data.Exception.mkRedundantData . showString "Duel.Data.Options:\texactly " . shows requiredInputConfigFiles . showString " files are required:\t" $ shows inputConfigFilePaths "." - | otherwise = options { getInputConfigFilePaths = s : inputConfigFilePaths } + | 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 "." + | otherwise = options { getInputConfigFilePaths = s : inputConfigFilePaths } where inputConfigFilePaths = getInputConfigFilePaths options + diff --git a/src-exe/Duel/IO/Logger.hs b/src-exe/Duel/IO/Logger.hs --- a/src-exe/Duel/IO/Logger.hs +++ b/src-exe/Duel/IO/Logger.hs @@ -61,3 +61,4 @@ System.IO.hGetLine handle >>= putString slave -- Recurse. + diff --git a/src-exe/Duel/Process/Handles.hs b/src-exe/Duel/Process/Handles.hs new file mode 100644 --- /dev/null +++ b/src-exe/Duel/Process/Handles.hs @@ -0,0 +1,95 @@ +{- + 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@] Wraps "System.Process". +-} + +module Duel.Process.Handles( +-- * Types +-- ** Data-types + Handles( +-- MkHandles, +-- getStdIn, +-- getStdOut, + getStdErr +-- getPId + ), +-- * Functions + cleanupHandles, + showHandles, +-- ** Accessors + getHandlePair, +-- ** Constructor + mkHandles +) where + +import qualified System.IO +import qualified System.Process + +-- | A container for the IO-handles & process-id of a child process. +data Handles = MkHandles { + getStdIn :: System.IO.Handle, + getStdOut :: System.IO.Handle, + getStdErr :: System.IO.Handle, + getPId :: System.Process.ProcessHandle +} + +-- | Constructor. +mkHandles :: String -> [String] -> IO Handles +mkHandles command args = do + (stdIn, stdOut, stdErr, pId) <- System.Process.runInteractiveProcess command args Nothing Nothing + + sequence_ $ [ + (`System.IO.hSetBuffering` System.IO.LineBuffering), + (`System.IO.hSetEncoding` System.IO.latin1) + ] <*> [stdIn, stdOut] + + return {- to IO-monad -} MkHandles { + getStdIn = stdIn, + getStdOut = stdOut, + getStdErr = stdErr, + getPId = pId + } + +-- | Accessor. +getHandlePair :: Handles -> (System.IO.Handle, System.IO.Handle) +getHandlePair MkHandles { + getStdIn = stdIn, + getStdOut = stdOut +} = (stdIn, stdOut) + +-- | Show the configuration of the IO-handles. +showHandles :: Handles -> IO [String] +showHandles MkHandles { + getStdIn = stdIn, + getStdOut = stdOut, + getStdErr = stdErr +} = mapM System.IO.hShow [stdIn, stdOut, stdErr] + +-- | Terminates the child-process & closes any IO-handles. +cleanupHandles :: Handles -> IO () +cleanupHandles MkHandles { + getStdIn = stdIn, + getStdOut = stdOut, + getStdErr = stdErr, + getPId = pId +} = System.Process.cleanupProcess (Just stdIn, Just stdOut, Just stdErr, pId) + 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 @@ -21,7 +21,6 @@ [@AUTHOR@] Dr. Alistair Ward [@DESCRIPTION@] Starts the two bishbosh-processes & acts as an intermediary. - -} module Duel.Process.Intermediary ( @@ -37,17 +36,30 @@ -- purge, -- startGame -- startProcess, +-- bracketProcess initialise ) where +import Control.Arrow((&&&), (|||)) +import Control.Category((>>>)) import qualified BishBosh.Attribute.LogicalColour as Attribute.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 +import qualified BishBosh.Input.Options as Input.Options +import qualified BishBosh.Input.SearchOptions as Input.SearchOptions +import qualified BishBosh.Input.UIOptions as Input.UIOptions import qualified BishBosh.Input.Verbosity as Input.Verbosity -import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason +import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Types as T +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating +import qualified BishBosh.Property.Switchable as Property.Switchable +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason +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.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified BishBosh.UI.Command as UI.Command import qualified Control.Exception import qualified Control.Monad @@ -56,10 +68,11 @@ import qualified Data.Maybe import qualified Duel.Data.Options as Data.Options import qualified Duel.IO.Logger as IO.Logger +import qualified Duel.Process.Handles as Process.Handles import qualified System.Exit import qualified System.FilePath import qualified System.IO -import qualified System.Process +import qualified Text.XML.HXT.Core as HXT #ifdef MOVE_NOTATION # if MOVE_NOTATION == 'I' @@ -82,7 +95,7 @@ runBishBosh :: Input.Verbosity.Verbosity -> System.FilePath.FilePath -- ^ The path to a configuration-file. - -> IO (System.IO.Handle, System.IO.Handle, System.IO.Handle, System.Process.ProcessHandle) + -> IO Process.Handles.Handles runBishBosh verbosity configFilePath = let command = "bishbosh" args = [ @@ -95,19 +108,23 @@ in do Control.Monad.when (verbosity > Data.Default.def) . IO.Logger.printInfo . showString "Starting command; " $ shows (command, args) "." - System.Process.runInteractiveProcess command args Nothing Nothing + Process.Handles.mkHandles command args -- | Read either a move or a game-termination reason from the specified handle. readMove :: Input.Verbosity.Verbosity - -> Data.Options.ReadTimeout + -> Type.Count.NSeconds -- ^ Read-timout. -> Attribute.LogicalColour.LogicalColour -- ^ Whose turn it is. -> System.IO.Handle -- ^ Output handle from which data should be read. - -> IO (Either Model.GameTerminationReason.GameTerminationReason (MoveNotation T.X T.Y)) + -> IO (Either Rule.GameTerminationReason.GameTerminationReason (MoveNotation Type.Length.X Type.Length.Y)) readMove verbosity readTimeout logicalColour stdOut = do - Control.Monad.when (verbosity == maxBound) . IO.Logger.printInfo . showString "Waiting for " $ shows logicalColour "." + Control.Monad.when (verbosity == maxBound) . IO.Logger.printInfo . showString "Waiting " . ( + if readTimeout < 0 + then showString "indefinitely" + else showString "for up to " . shows readTimeout . showString " s" + ) . showString " for " $ shows logicalColour " to move." - inputReady <- System.IO.hWaitForInput stdOut $ 1000 * readTimeout + inputReady <- System.IO.hWaitForInput stdOut $ 1000 * fromIntegral readTimeout Control.Monad.unless inputReady . Control.Exception.throwIO . Data.Exception.mkRequestFailure . showString "Duel.Process.Intermediary.readMove:\ttimed-out after " $ shows readTimeout " s." @@ -128,45 +145,45 @@ -- | Read either a move from the first handle & write it to the second. copyMove :: Input.Verbosity.Verbosity - -> Data.Options.ReadTimeout + -> 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. - -> IO (Maybe Model.GameTerminationReason.GameTerminationReason) + -> IO (Maybe Rule.GameTerminationReason.GameTerminationReason) copyMove verbosity readTimeout logicalColour stdOut stdIn = do - readMove verbosity readTimeout logicalColour stdOut >>= ( - return {-to IO-monad-} . Just - ) `either` ( + readMove verbosity readTimeout logicalColour stdOut >>= return {-to IO-monad-} . Just ||| ( \move -> do System.IO.hPrint stdIn move return {-to IO-monad-} Nothing ) --- | Contains stdin & stdout handles respectively. +-- | Contains /stdin/ & /stdout/ handles respectively. type IOHandles = (System.IO.Handle, System.IO.Handle) -- | Shuttle moves between the two child processes until the game terminates. play - :: Input.Verbosity.Verbosity - -> Data.Options.ReadTimeout + :: Property.Switchable.Switchable gameClock + => Input.Verbosity.Verbosity + -> Type.Count.NSeconds -- ^ Read-timout. -> IOHandles -> IOHandles - -> IO Model.GameTerminationReason.GameTerminationReason + -> gameClock + -> IO (Rule.GameTerminationReason.GameTerminationReason, gameClock) play verbosity readTimeout = slave maxBound where - slave logicalColour producer@(_, stdOut) consumer@(stdIn', stdOut') = copyMove verbosity readTimeout logicalColour stdOut stdIn' >>= Data.Maybe.maybe ( + slave logicalColour producer@(_, stdOut) consumer@(stdIn', stdOut') gameClock = copyMove verbosity readTimeout logicalColour stdOut stdIn' >>= Data.Maybe.maybe ( do Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Swapping player-roles." - slave (Property.Opposable.getOpposite logicalColour) consumer producer -- Recurse. + Property.Switchable.toggle gameClock >>= slave (Property.Opposable.getOpposite logicalColour) consumer producer -- Recurse. ) ( \gameTerminationReason -> do readMove verbosity readTimeout logicalColour stdOut' >>= ( \gameTerminationReason' -> do Control.Monad.unless (gameTerminationReason == gameTerminationReason') . Control.Exception.throwIO . Data.Exception.mkIncompatibleData . showString "Duel.Process.Intermediary.play:\tsecond game terminated for a different reason; " $ shows gameTerminationReason' "." - return {-to IO-monad-} gameTerminationReason - ) `either` ( + return {-to IO-monad-} (gameTerminationReason, gameClock) + ) ||| ( \move -> Control.Exception.throwIO . Data.Exception.mkParseFailure . showString "Duel.Process.Intermediary.play:\tread from " . shows (Property.Opposable.getOpposite logicalColour) . showString ", unexpected move='" $ shows move "'." ) ) @@ -181,33 +198,42 @@ {- | * Accumulates the frequency of each game-termination reason - * N.B.: the recorded result is merely a string, though it could be read into a 'BishBosh.Model.GameTerminationReason'. + * N.B.: the recorded result is merely a string, though it could be read into a 'BishBosh.Rule.GameTerminationReason'. -} -type GameTerminationReasonsMap = Data.Map.Strict.Map Model.GameTerminationReason.GameTerminationReason Int +type GameTerminationReasonsMap = Data.Map.Strict.Map Rule.GameTerminationReason.GameTerminationReason Type.Count.NGames {- | - * Start two independently configured (though of matching move-notation) instances of 'bishbosh'. + * Constructs a game-clock. + * Starts two independently configured (though of matching move-notation) concurrent instances of 'bishbosh'. + * One instance automates White & one automates Black. * Shuttle moves between the instances. - * Plays repeatedly & accumulating the final results of each game. + * Plays repeatedly, measuring both the total time taken by each side & accumulating the final results of each game. + + * Prints the total time taken by either side, & returns the accumulated results of each game. -} startGame :: Input.Verbosity.Verbosity - -> Data.Options.ReadTimeout - -> IOHandles -- ^ White's handles. - -> IOHandles -- ^ Black's handles. + -> Type.Count.NDecimalDigits + -> Type.Count.NSeconds -- ^ Read-timeout. + -> IOHandles -- ^ White's handles. + -> IOHandles -- ^ Black's handles. -> GameTerminationReasonsMap - -> Model.Game.NGames + -> Type.Count.NGames -> IO GameTerminationReasonsMap -startGame verbosity readTimeout producer consumer = slave where - slave gameTerminationReasonsMap 0 = return {-to IO-monad-} gameTerminationReasonsMap - slave gameTerminationReasonsMap nGames = do +startGame verbosity nDecimalDigits readTimeout producer consumer gameTerminationReasonsMap nGames = Property.Switchable.on >>= slave gameTerminationReasonsMap nGames where + slave :: GameTerminationReasonsMap -> Type.Count.NGames -> Time.GameClock.GameClock -> IO GameTerminationReasonsMap + slave gameTerminationReasonsMap' 0 gameClock = do + Time.GameClock.showsElapsedTimes nDecimalDigits gameClock >>= IO.Logger.printInfo . showString "Elapsed time" . Text.ShowList.showsAssociation . ($ ".") + + return {-to IO-monad-} gameTerminationReasonsMap' + slave gameTerminationReasonsMap' nGames' gameClock = do Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Starting game." - gameTerminationReason <- play verbosity readTimeout producer consumer + (gameTerminationReason, gameClock') <- play verbosity readTimeout producer consumer gameClock sequence_ $ [ \(_, stdOut) -> do @@ -221,58 +247,91 @@ ] <*> [consumer, producer] slave ( - Data.Map.Strict.insertWith (const succ) gameTerminationReason 1 gameTerminationReasonsMap - ) $ pred nGames -- Recurse. + Data.Map.Strict.insertWith (const succ) gameTerminationReason 1 gameTerminationReasonsMap' + ) ( + pred nGames' -- Recurse. + ) gameClock' --- | Start 'bishbosh', print any errors, unbuffer its I/O, & return the process-handles. +-- | Start 'bishbosh', print any errors, & return the process-handles. startProcess :: Input.Verbosity.Verbosity -> System.FilePath.FilePath -- ^ The path to a configuration-file. - -> IO (System.IO.Handle, System.IO.Handle, System.IO.Handle, System.Process.ProcessHandle) + -> IO Process.Handles.Handles startProcess verbosity configFilePath = do - handles@(stdIn, stdOut, stdErr, _) <- runBishBosh verbosity configFilePath - - IO.Logger.dump stdErr + handles <- runBishBosh verbosity configFilePath - sequence_ $ [ - (`System.IO.hSetBuffering` System.IO.LineBuffering), - (`System.IO.hSetEncoding` System.IO.latin1) - ] <*> [stdIn, stdOut] + IO.Logger.dump $ Process.Handles.getStdErr handles - Control.Monad.when (verbosity == maxBound) $ mapM System.IO.hShow [stdIn, stdOut, stdErr] >>= IO.Logger.printInfo . show + Control.Monad.when (verbosity == maxBound) $ Process.Handles.showHandles handles >>= mapM_ IO.Logger.printInfo return {-to IO-monad-} handles --- | Play the requested number of games & display the accumulated results. +-- | Starts the process, performs the requested action, then clean-up. +bracketProcess + :: Input.Verbosity.Verbosity + -> [System.FilePath.FilePath] -- ^ The configuration-file paths for White & Black respectively. + -> ([Process.Handles.Handles] -> IO ()) -- ^ Run the game. + -> IO () +bracketProcess verbosity inputConfigFilePaths = Control.Exception.bracket ( + startProcess verbosity `mapM` inputConfigFilePaths + ) ( + sequence . ( + [ + IO.Logger.dump . Process.Handles.getStdErr, + Process.Handles.cleanupHandles + ] <*> + ) + ) + +{- | + * Unpacks the configuration-options. + + * Optionally verifies the compatibility of the two configuration-files. + + * Plays the requested number of games. + + * Prints the results. +-} initialise :: Data.Options.Options -> IO () -initialise options = let - verbosity = Data.Options.getVerbosity options - in Control.Exception.catch ( - Control.Exception.bracket ( - startProcess verbosity `mapM` Data.Options.getInputConfigFilePaths options - ) ( - \processes@[(_, _, stdErr, _), (_, _, stdErr', _)] -> do - mapM_ IO.Logger.dump [stdErr, stdErr'] +initialise options + | errorMessages@(_ : _) <- Property.SelfValidating.findInvalidity options = Control.Exception.throwIO . Data.Exception.mkInsufficientData . showString "Duel.Process.Intermediary.initialise:\tinvalid options; " $ show errorMessages + | otherwise = let + (verbosity, inputConfigFilePaths) = Data.Options.getVerbosity &&& Data.Options.getInputConfigFilePaths $ options + hxtTraceLevel = fromEnum verbosity `min` 2 {-CAVEAT: HXT trace-levels 3 & 4 are too verbose-} + in Control.Exception.catch ( + do + Control.Monad.when (Data.Options.getVerifyConfiguration options) $ do + [(logicalColoursFirst, moveNotationFirst), (logicalColoursSecond, moveNotationSecond)] <- mapM ( + \configFilePath -> do + [pair] <- HXT.runX $ HXT.setTraceLevel hxtTraceLevel + >>> HXT.xunpickleDocument HXT.xpickle [ + HXT.withRemoveWS HXT.yes, + HXT.withStrictInput HXT.no -- Only a fraction of the document is required. + ] configFilePath + >>> HXT.arr ( + \inputOptions -> Input.SearchOptions.identifyAutomatedPlayers . Input.Options.getSearchOptions &&& Input.UIOptions.getMoveNotation . Input.IOOptions.getUIOptions . Input.Options.getIOOptions $ ( + inputOptions :: Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y -- Arbitrary concrete type. + ) + ) -- Lift function into an arrow. - Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Cleaning-up child processes." + return {-to IO-monad-} pair + ) inputConfigFilePaths - mapM_ ( - \(hIn, hOut, hErr, pId) -> System.Process.cleanupProcess (Just hIn, Just hOut, Just hErr, pId) - ) processes - ) ( - \[(stdIn, stdOut, _, _), (stdIn', stdOut', _, _)] -> startGame verbosity ( - Data.Options.getReadTimeout options - ) ( - stdIn, stdOut - ) ( - stdIn', stdOut' - ) Data.Map.Strict.empty ( - Data.Options.getNGames options - ) >>= IO.Logger.printInfo . show . Data.Map.Strict.toList - ) - ) $ \e -> do - IO.Logger.printError . showString "caught " $ show (e :: Control.Exception.SomeException) + Control.Monad.unless (logicalColoursFirst == [maxBound] && logicalColoursSecond == [minBound]) . Control.Exception.throwIO . Data.Exception.mkIncompatibleData . showString "Duel.Process.Intermediary.initialise:\tconfiguration-files must automate White & Black respectively; " $ shows (logicalColoursFirst ++ logicalColoursSecond) "." - Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Exiting." + Control.Monad.unless (moveNotationFirst == moveNotationSecond) . Control.Exception.throwIO . Data.Exception.mkIncompatibleData . showString "Duel.Process.Intermediary.initialise:\tconfiguration-files must define the same " . showString Notation.MoveNotation.tag . Text.ShowList.showsAssociation $ shows (moveNotationFirst, moveNotationSecond) "." - System.Exit.exitFailure + bracketProcess verbosity inputConfigFilePaths $ \[handles, handles'] -> uncurry ( + uncurry (startGame verbosity) $ (Data.Options.getNDecimalDigits &&& Data.Options.getReadTimeout) options + ) ( + ($ handles) &&& ($ handles') $ Process.Handles.getHandlePair + ) Data.Map.Strict.empty ( + Data.Options.getNGames options + ) >>= IO.Logger.printInfo . show . Data.Map.Strict.toList + ) $ \e -> do + IO.Logger.printError . showString "caught " $ show (e :: Control.Exception.SomeException) + + Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Exiting." + + System.Exit.exitFailure + diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -29,9 +29,8 @@ module Main(main) where -import BishBosh.Data.Float() --- import BishBosh.Data.Ratio() -- Required if either criterionWeight or criterionValue is Rational. -import Control.Arrow((&&&), (***)) +--import BishBosh.Data.Ratio() -- Required if either Type.Mass.CriterionWeight or Type.Mass.CriterionValue is Rational. +import Control.Arrow((&&&), (***), (|||)) import Control.Category((>>>)) import Data.Array.IArray((!)) import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank @@ -58,14 +57,16 @@ import qualified BishBosh.Text.ShowColouredPrefix as Text.ShowColouredPrefix import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Control.Monad import qualified Data.Default import qualified Data.List import qualified Data.Maybe import qualified Data.Version -import qualified Numeric import qualified Paths_bishbosh as Paths -- Either local stub, or package-instance auto-generated by 'Setup build'. import qualified System.Console.GetOpt as G import qualified System.Directory @@ -81,10 +82,6 @@ import qualified ToolShed.System.File import System.FilePath((), (<.>)) -#ifdef USE_NARROW_NUMBERS -import BishBosh.Data.Integral() -- HXT.XmlPickler. -#endif - #ifdef USE_HXTRELAXNG import qualified Text.XML.HXT.RelaxNG #endif @@ -98,9 +95,7 @@ #endif -- Define concrete types to resolve the underlying polymorphic functions. -type Row = T.Y -type Column = T.X -- N.B. there's no requirement to be the same type as Row. -type Options = Input.Options.Options Column T.CriterionWeight T.PieceSquareValue T.RankValue Row T.X T.Y +type Options = Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y writeXMLToFile :: HXT.XmlPickler pickleable @@ -232,9 +227,9 @@ mkTypeSpecification s = showChar '<' $ showString s ">" intTypeSpecification, filePathTypeSpecification :: String - (intTypeSpecification, filePathTypeSpecification) = ($ intString) &&& ($ filePathString) $ mkTypeSpecification + (intTypeSpecification, filePathTypeSpecification) = ($ intString) &&& ($ filePathString) $ mkTypeSpecification - defaultUIOptions :: Input.UIOptions.UIOptions Row Column + defaultUIOptions :: Input.UIOptions.UIOptions defaultUIOptions = Data.Default.def defaultRandomSeed :: Input.Options.RandomSeed @@ -282,7 +277,7 @@ ) ["Opening", "End"] ) $ map ( \selector -> Component.PieceSquareByCoordinatesByRank.formatForGNUPlot ( - Numeric.showFFloat . Just . Input.UIOptions.getNDecimalDigits . Input.IOOptions.getUIOptions $ Input.Options.getIOOptions options -- PieceSquareValue formatter. + Property.ShowFloat.showsFloatToN' . Input.UIOptions.getNDecimalDigits . Input.IOOptions.getUIOptions $ Input.Options.getIOOptions options -- PieceSquareValue formatter. ) ( showChar '\t' -- Column-delimiter. ) ( @@ -331,17 +326,6 @@ configDir :: System.FilePath.FilePath configDir = dataDir "config" - inputSysConfigList :: HXT.SysConfigList - inputSysConfigList = [ - HXT.withRemoveWS HXT.yes, -- Remove white-space, e.g. any indentation which might have been introduced by 'HXT.withIndent'. - HXT.withStrictInput HXT.yes, -- Read the input file strictly (cf. lazily), this ensures file-closure even if not completely read. -#ifdef USE_HXTRELAXNG - Text.XML.HXT.RelaxNG.withRelaxNG $ configDir progName <.> "rng" -- Validate against the referenced RelaxNG schema. -#else - HXT.withValidate HXT.yes -- Validate against any DTD referenced from the specified XML-file. -#endif - ] - hxtTraceLevel :: Int hxtTraceLevel = fromEnum preVerbosity `min` 2 {-CAVEAT: HXT trace-levels 3 & 4 are too verbose-} @@ -365,7 +349,7 @@ (showsInfoPrefix, showsWarningPrefix) = const ( Text.ShowColouredPrefix.showsPrefixInfo, Text.ShowColouredPrefix.showsPrefixWarning - ) `either` const ( + ) ||| const ( Text.ShowPrefix.showsPrefixInfo, Text.ShowPrefix.showsPrefixWarning ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions @@ -423,14 +407,16 @@ ) executablePath in ( \pgnDatabase -> do - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . showsInfoPrefix . showString "read PGN-database" . Text.ShowList.showsAssociation . shows pgnDatabaseFilePath . showString " containing (nGames, nMoves)" . Text.ShowList.showsAssociation $ shows ( + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . showsInfoPrefix . showString "read PGN-database" . Text.ShowList.showsAssociation . shows pgnDatabaseFilePath . showString " containing (nGames, nPositions)" . Text.ShowList.showsAssociation $ shows ( Data.List.foldl' ( \acc pgn -> let - acc'@(nGames, nPlies) = succ *** ( - + State.TurnsByLogicalColour.getNPlies (Model.Game.getTurnsByLogicalColour $ ContextualNotation.PGN.getGame pgn) + acc'@(nGames, nPositions) = succ *** ( + + State.TurnsByLogicalColour.getNPlies ( + Model.Game.getTurnsByLogicalColour $ ContextualNotation.PGN.getGame pgn + ) ) $ acc - in nGames `seq` nPlies `seq` acc' - ) (0 :: Model.Game.NGames, 0) pgnDatabase + in nGames `seq` nPositions `seq` acc' + ) (0 :: Type.Count.NGames, 0) pgnDatabase ) "." -- CAVEAT: this stalls rendering of the native UI. return {-to IO-monad-} $ ContextualNotation.QualifiedMoveForest.mergePGNDatabase pgnDatabase qualifiedMoveForest @@ -460,16 +446,24 @@ ) Property.Empty.empty {-QualifiedMoveForest-} (Input.IOOptions.getPGNOptionsList ioOptions) let - maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Column T.CriterionValue T.CriterionWeight T.PieceSquareValue T.PositionHash T.RankValue Row T.WeightedMean T.X T.Y) + maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) 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) "." return {-to IO-monad-} options' in Control.Monad.void {-discard the state returned by processInputOptions-} . HXT.runX $ HXT.setTraceLevel hxtTraceLevel - >>> HXT.xunpickleDocument HXT.xpickle inputSysConfigList configFilePath + >>> HXT.xunpickleDocument HXT.xpickle [ + HXT.withRemoveWS HXT.yes, -- Remove white-space, e.g. any indentation which might have been introduced by 'HXT.withIndent'. + HXT.withStrictInput HXT.yes, -- Read the input file strictly (cf. lazily), this ensures file-closure even if not completely read. +#ifdef USE_HXTRELAXNG + Text.XML.HXT.RelaxNG.withRelaxNG $ configDir progName <.> "rng" -- Validate against the referenced RelaxNG schema. +#else + HXT.withValidate HXT.yes -- Validate against any DTD referenced from the specified XML-file. +#endif + ] configFilePath >>> HXT.traceMsg hxtTraceLevel (showString Input.Options.tag " parsed") - >>> HXT.arrIO processInputOptions + >>> HXT.arrIO processInputOptions -- Lift an IO-function into an arrow. | otherwise -> Control.Exception.throwIO . Data.Exception.mkInsufficientData $ shows (Input.CommandLineOption.longFlagPrefix ++ inputConfigFilePathFlag) " must be specified." where categorisedCommandLineOptions = Input.CommandLineOption.categorise $ map snd commandLineOptions diff --git a/src-lib/BishBosh/Attribute/CriterionValue.hs b/src-lib/BishBosh/Attribute/CriterionValue.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/CriterionValue.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE CPP #-} -{- - 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 value of a single /criterion/, which quantifies the significance of some concept; - many such criteria may exist, & their weighted-mean drives automated selection of /move/s. - - * Each /criterion-value/ is normalised into the /signed closed unit-interval/. - - [@CAVEAT@] - - * While this data-type could implement the classes 'Num', 'Fractional' & 'Real', these interfaces would allow one to construct invalid instances. --} - -module BishBosh.Attribute.CriterionValue( --- * Types --- ** Data-types - CriterionValue(), --- * Constants - zero, --- * Functions - calculateWeightedMean, --- ** Constructor - mkCriterionValue -) where - -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.CriterionWeight as Attribute.CriterionWeight -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues -import qualified BishBosh.Types as T -import qualified Control.Exception -import qualified Factory.Math.Statistics - -#ifdef USE_PARALLEL -import qualified Control.DeepSeq -import qualified Control.Parallel.Strategies -#endif - --- | Quantifies some criterion; the larger the signed value, the better. -newtype CriterionValue criterionValue = MkCriterionValue criterionValue deriving (Eq, Show) - -instance Num criterionValue => Bounded (CriterionValue criterionValue) where - minBound = MkCriterionValue $ negate 1 - maxBound = MkCriterionValue 1 - --- | Smart constructor. -mkCriterionValue :: ( - Num criterionValue, - Ord criterionValue - ) => criterionValue -> CriterionValue criterionValue -mkCriterionValue criterionValue = Control.Exception.assert (abs criterionValue <= 1) $ MkCriterionValue criterionValue - --- | Constant. -zero :: Num criterionValue => CriterionValue criterionValue -zero = MkCriterionValue 0 - -{- | - * Calculates the /weighted mean/ of the specified 'CriterionValue's using the corresponding /criterion-weight/s. - - * Also writes individual unweighted 'CriterionValue's, to facilitate post-analysis; - if the corresponding weight is @0@, evaluation of the criterion is, for efficiency, avoided. - - * CAVEAT: if all weights are @0@, then the result is indeterminate. --} -calculateWeightedMean :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Fractional weightedMean, - Real criterionValue, - Real criterionWeight - ) => [(CriterionValue criterionValue, Attribute.CriterionWeight.CriterionWeight criterionWeight)] -> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue -{-# INLINABLE calculateWeightedMean #-} -{-# SPECIALISE calculateWeightedMean :: [(CriterionValue T.CriterionValue, Attribute.CriterionWeight.CriterionWeight T.CriterionWeight)] -> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues T.WeightedMean T.CriterionValue #-} -calculateWeightedMean assocs = uncurry Attribute.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues $ ( - Factory.Math.Statistics.getWeightedMean &&& map fst - ) -#ifdef USE_PARALLEL - $ Control.Parallel.Strategies.withStrategy ( - Control.Parallel.Strategies.parList $ Control.Parallel.Strategies.evalTuple2 Control.Parallel.Strategies.rdeepseq Control.Parallel.Strategies.r0 - ) -#endif - [ - (bareCriterionValue, bareCriterionWeight) | - (MkCriterionValue bareCriterionValue, criterionWeight) <- assocs, - let bareCriterionWeight = Attribute.CriterionWeight.deconstruct criterionWeight, - bareCriterionWeight /= 0 - ] -- List-comprehension. - diff --git a/src-lib/BishBosh/Attribute/CriterionWeight.hs b/src-lib/BishBosh/Attribute/CriterionWeight.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/CriterionWeight.hs +++ /dev/null @@ -1,90 +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 weight associated with some 'Attribute.CriterionValue.CriterionValue'. - - * Each weighting is constrained to the unsigned /closed unit-interval/; negative values aren't permitted. - - * If the /criterion-value/ is considered unimportant, then its weight can be set to @0@, whilst concepts of great significance can be set to @1@. - - [@CAVEAT@] - - * While this data-type could implement the classes 'Functor', 'Num', 'Fractional' & 'Real', these interfaces allow one to construct invalid instances. --} - -module BishBosh.Attribute.CriterionWeight( --- * Types --- ** Data-types - CriterionWeight( --- MkCriterionWeight, - deconstruct - ), --- * Functions --- ** Constructor - mkCriterionWeight -) where - -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Data.Num as Data.Num -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified Control.DeepSeq -import qualified Control.Exception -import qualified Data.Default -import qualified Text.XML.HXT.Arrow.Pickle as HXT - --- | Quantifies the relative significance, of a criterion-value; the larger the weight, the more significant the criterion is relative to other criteria. -newtype CriterionWeight criterionWeight = MkCriterionWeight { - deconstruct :: criterionWeight -} deriving (Eq, Ord) - -instance Show criterionWeight => Show (CriterionWeight criterionWeight) where - showsPrec _ (MkCriterionWeight criterionWeight) = shows criterionWeight - -instance Num criterionWeight => Bounded (CriterionWeight criterionWeight) where - minBound = MkCriterionWeight 0 - maxBound = MkCriterionWeight 1 - -instance Num criterionWeight => Data.Default.Default (CriterionWeight criterionWeight) where - def = minBound - -instance Control.DeepSeq.NFData criterionWeight => Control.DeepSeq.NFData (CriterionWeight criterionWeight) where - rnf (MkCriterionWeight criterionWeight) = Control.DeepSeq.rnf criterionWeight - -instance ( - HXT.XmlPickler criterionWeight, - Num criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => HXT.XmlPickler (CriterionWeight criterionWeight) where - xpickle = HXT.xpWrap (mkCriterionWeight, deconstruct) HXT.xpickle - --- | Smart constructor. -mkCriterionWeight :: ( - Num criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => criterionWeight -> CriterionWeight criterionWeight -mkCriterionWeight criterionWeight - | Data.Num.inClosedUnitInterval criterionWeight = MkCriterionWeight criterionWeight - | otherwise = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Attribute.CriterionWeight.mkCriterionWeight:\tweight" . Text.ShowList.showsAssociation $ shows criterionWeight " must be within the closed unit-interval, '[0,1]'." - diff --git a/src-lib/BishBosh/Attribute/Direction.hs b/src-lib/BishBosh/Attribute/Direction.hs --- a/src-lib/BishBosh/Attribute/Direction.hs +++ b/src-lib/BishBosh/Attribute/Direction.hs @@ -32,7 +32,6 @@ module BishBosh.Attribute.Direction( -- * Types -- ** Type-synonyms - NDirections, ArrayByDirection, -- ** Data-types Direction( @@ -73,6 +72,7 @@ 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 @@ -116,9 +116,6 @@ se :: Direction se = MkDirection GT LT --- | A number of /direction/s. -type NDirections = Int -- N.B.: 'Data.Int.Int8' saves neither time nor space. - -- | 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. @@ -224,7 +221,7 @@ instance Property.FixedMembership.FixedMembership Direction where members = range --- | Smart-constructor. +-- | Smart constructor. mkDirection :: Ordering -- ^ The sense of the change in the /x/-coordinate. -> Ordering -- ^ The sense of the change in the /y/-coordinate. @@ -241,8 +238,8 @@ diagonals = [sw, nw, se, ne] -- | The constant number of distinct /direction/s. -nDistinctDirections :: NDirections -nDistinctDirections = length range +nDistinctDirections :: Type.Count.NDirections +nDistinctDirections = fromIntegral $ length range {- | * Returns a list of /direction/s, each paired with its anti-parallel. diff --git a/src-lib/BishBosh/Attribute/LogicalColour.hs b/src-lib/BishBosh/Attribute/LogicalColour.hs --- a/src-lib/BishBosh/Attribute/LogicalColour.hs +++ b/src-lib/BishBosh/Attribute/LogicalColour.hs @@ -51,6 +51,7 @@ 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 @@ -92,8 +93,8 @@ members = range -- | The constant number of distinct /logical colour/s. -nDistinctLogicalColours :: Int -nDistinctLogicalColours = length range +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 diff --git a/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs b/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs --- a/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs +++ b/src-lib/BishBosh/Attribute/LogicalColourOfSquare.hs @@ -56,3 +56,4 @@ -- | 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 @@ -170,7 +170,7 @@ maybePromotionRank <- Nothing : map Just Attribute.Rank.promotionProspects ] -- List-comprehension. --- | Smart-constructor for normal move-types. +-- | Smart constructor for normal move-types. mkMaybeNormalMoveType :: Maybe Attribute.Rank.Rank -- ^ The /rank/ of any opposing /piece/ which was just taken. -> Maybe Attribute.Rank.Rank -- ^ The /rank/ to which a @Pawn@ was just promoted. 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -31,7 +30,6 @@ -- * Types -- ** Type-synonyms EvaluateRank, --- NRanks, ArrayByRank, UArrayByRank, -- ** Data-types @@ -51,6 +49,7 @@ earthBound, expendable, nDistinctRanks, +-- allocationPerSide, -- * Functions compareByLVA, findUndefinedRanks, @@ -59,7 +58,9 @@ arrayByRank ) where +import qualified BishBosh.Metric.RankValue as Metric.RankValue import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray @@ -104,17 +105,16 @@ index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . fromEnum instance Show Rank where - showsPrec _ = showChar . \case - Pawn -> 'p' - Rook -> 'r' - Knight -> 'n' - Bishop -> 'b' - Queen -> 'q' - King -> 'k' + show Pawn = "p" + show Rook = "r" + show Knight = "n" + show Bishop = "b" + show Queen = "q" + show King = "k" instance Read Rank where - readsPrec _ (c : s) - | Data.Char.isSpace c = reads s -- Consume. + readsPrec precedence (c : s) + | Data.Char.isSpace c = readsPrec precedence s -- Consume. | otherwise = map (flip (,) s) $ case Data.Char.toLower c of 'p' -> [Pawn] 'r' -> [Rook] @@ -180,7 +180,7 @@ expendable = Data.List.delete King range -- | The type of a function which returns a /rank/'s value. -type EvaluateRank rankValue = Rank -> rankValue +type EvaluateRank = Rank -> Metric.RankValue.RankValue {- | * Given two alternative capture moves, this function compares the rank-value of the aggressors. @@ -188,8 +188,7 @@ * N.B.: a @King@ is always considered most valuable, regardless of the evaluation-function supplied. -} compareByLVA - :: Ord rankValue - => EvaluateRank rankValue + :: EvaluateRank -> Rank -> Rank -> Ordering @@ -199,12 +198,13 @@ | rankR == King = LT | otherwise = Data.Ord.comparing evaluateRank rankL rankR --- | A number of ranks. -type NRanks = Int - -- | The constant number of distinct /rank/s. -nDistinctRanks :: NRanks -nDistinctRanks = length range +nDistinctRanks :: Type.Count.NRanks +nDistinctRanks = fromIntegral $ length range + +-- | The number of each rank allocated to each side. +allocationPerSide :: ArrayByRank Type.Count.NRanks +allocationPerSide = listArrayByRank [8, 2, 2, 2, 1, 1] -- | A boxed array indexed by /rank/, of arbitrary values. type ArrayByRank = Data.Array.IArray.Array Rank diff --git a/src-lib/BishBosh/Attribute/RankValues.hs b/src-lib/BishBosh/Attribute/RankValues.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/RankValues.hs +++ /dev/null @@ -1,142 +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@] - - * The relative values of the various /rank/s of chess-piece. - - * --} - -module BishBosh.Attribute.RankValues( --- * Types --- ** Data-types - RankValues(), --- * Constants - tag, --- * Functions - findRankValue, - calculateMaximumTotalValue, --- ** Constructor - fromAssocs -) where - -import Control.Arrow((&&&), (***)) -import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Data.Foldable as Data.Foldable -import qualified BishBosh.Data.Num as Data.Num -import qualified BishBosh.Property.ShowFloat as Property.ShowFloat -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified Control.Arrow -import qualified Control.DeepSeq -import qualified Control.Exception -import qualified Data.Array.IArray -import qualified Data.Default -import qualified Data.List -import qualified Text.XML.HXT.Arrow.Pickle as HXT - --- | Used to qualify XML. -tag :: String -tag = "rankValues" - -{- | - * The constant value associated with each /rank/; the higher, the more valuable it is considered to be. - - * N.B.: only relative values are significant; the absolute value associated with any /rank/ is irrelevant; typically ranks are valued in /centipawns/. - - * CAVEAT: a @King@ can never be taken, but assigning the value /infinity/ creates problems, so typically it has the value @0@. --} -newtype RankValues rankValue = MkRankValues { - deconstruct :: Attribute.Rank.ArrayByRank rankValue -} deriving (Eq, Read, Show) - -instance Real rankValue => Property.ShowFloat.ShowFloat (RankValues rankValue) where - showsFloat fromDouble = Text.ShowList.showsAssociationList' . map (show *** fromDouble . realToFrac) . Data.Array.IArray.assocs . deconstruct - -instance ( - Fractional rankValue, - Ord rankValue, - Show rankValue - ) => Data.Default.Default (RankValues rankValue) where - def = fromAssocs $ map ( - Control.Arrow.second (/ 10) -- Map into the closed unit-interval. - ) [ - ( - Attribute.Rank.Pawn, 1 - ), ( - Attribute.Rank.Rook, 5 - ), ( - Attribute.Rank.Knight, 3 - ), ( - Attribute.Rank.Bishop, 3 - ), ( - Attribute.Rank.Queen, 9 - ), ( - Attribute.Rank.King, 0 -- N.B.: move-selection is independent of this value (since it can't be taken), so it can be defined arbitrarily. - ) - ] - -instance Control.DeepSeq.NFData rankValue => Control.DeepSeq.NFData (RankValues rankValue) where - rnf (MkRankValues byRank) = Control.DeepSeq.rnf byRank - -instance ( - Fractional rankValue, - HXT.XmlPickler rankValue, - Ord rankValue, - Show rankValue - ) => HXT.XmlPickler (RankValues rankValue) where - xpickle = HXT.xpDefault Data.Default.def . HXT.xpWrap ( - fromAssocs, -- Construct from an association-list. - Data.Array.IArray.assocs . deconstruct -- Deconstruct to an association-list. - ) . HXT.xpList1 . HXT.xpElem tag $ HXT.xpickle {-rank-} `HXT.xpPair` HXT.xpAttr "value" HXT.xpickle - --- | Smart-constructor. -fromAssocs :: ( - Fractional rankValue, - Ord rankValue, - Show rankValue - ) => [(Attribute.Rank.Rank, rankValue)] -> RankValues rankValue -fromAssocs assocs - | not $ null undefinedRanks = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.Attribute.RankValues.fromAssocs:\tranks" . Text.ShowList.showsAssociation $ shows undefinedRanks " are undefined." - | not $ null duplicateRanks = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Attribute.RankValues.fromAssocs:\tranks must be distinct; " $ shows duplicateRanks "." - | not $ all ( - Data.Num.inClosedUnitInterval . snd {-rank-value-} - ) assocs = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Attribute.RankValues.fromAssocs:\tall values must be within the closed unit-interval, [0,1]; " $ shows assocs "." - | otherwise = MkRankValues $ Attribute.Rank.arrayByRank assocs - where - (undefinedRanks, duplicateRanks) = Attribute.Rank.findUndefinedRanks &&& Data.Foldable.findDuplicates $ map fst assocs - --- | Query. -findRankValue :: Attribute.Rank.Rank -> RankValues rankValue -> rankValue -findRankValue rank (MkRankValues byRank) = byRank ! rank - -{- | - * The maximum total rank-value one side can have. - - * CAVEAT: assumes that zero pieces have been captured, all @Pawn@s have been queened, & that this is the most valuable /rank/ of /piece/. --} -calculateMaximumTotalValue :: Num rankValue => RankValues rankValue -> rankValue -calculateMaximumTotalValue (MkRankValues byRank) = 9 {-accounting for all possible promotions-} * (byRank ! Attribute.Rank.Queen) + 2 * Data.List.foldl' ( - \acc -> (+ acc) . (byRank !) - ) 0 Attribute.Rank.flank - diff --git a/src-lib/BishBosh/Attribute/WeightedMeanAndCriterionValues.hs b/src-lib/BishBosh/Attribute/WeightedMeanAndCriterionValues.hs deleted file mode 100644 --- a/src-lib/BishBosh/Attribute/WeightedMeanAndCriterionValues.hs +++ /dev/null @@ -1,83 +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@] The unweighted values of each criterion used to assess the fitness of a position, & the resulting weighted mean. --} - -module BishBosh.Attribute.WeightedMeanAndCriterionValues( --- * Types --- ** Data-types - WeightedMeanAndCriterionValues( --- MkWeightedMeanAndCriterionValues, - getWeightedMean, - getCriterionValues - ), --- * Constants - criterionValuesTag, - weightedMeanTag, --- * Functions - negateWeightedMean, --- ** Constructor - mkWeightedMeanAndCriterionValues -) where - -import qualified BishBosh.Property.ShowFloat as Property.ShowFloat -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified Control.DeepSeq - --- | Qualifies output. -criterionValuesTag :: String -criterionValuesTag = "criterion-values" - --- | Qualifies output. -weightedMeanTag :: String -weightedMeanTag = "weighted-mean" - --- | A /weighted mean/ & the individual unweighted criterion-values from which it was composed. -data WeightedMeanAndCriterionValues weightedMean criterionValue = MkWeightedMeanAndCriterionValues { - getWeightedMean :: weightedMean, -- ^ The weighted mean of a list of criterion-values. - getCriterionValues :: [criterionValue] -- ^ The unweighted 'Attribute.CriterionValue.CriterionValue's from which the weighted mean was composed. -} deriving (Eq, Show) - -instance Control.DeepSeq.NFData weightedMean => Control.DeepSeq.NFData (WeightedMeanAndCriterionValues weightedMean criterionValue) where - rnf MkWeightedMeanAndCriterionValues { getWeightedMean = weightedMean } = Control.DeepSeq.rnf weightedMean -- The other field is a prerequisite. - -instance (Real criterionValue, Real weightedMean) => Property.ShowFloat.ShowFloat (WeightedMeanAndCriterionValues weightedMean criterionValue) where - showsFloat fromDouble MkWeightedMeanAndCriterionValues { - getWeightedMean = weightedMean, - getCriterionValues = criterionValues - } = Text.ShowList.showsAssociationList' [ - (weightedMeanTag, fromDouble $ realToFrac weightedMean), - (criterionValuesTag, Text.ShowList.showsFormattedList' (fromDouble . realToFrac) criterionValues) - ] - --- | Constructor. -mkWeightedMeanAndCriterionValues :: weightedMean -> [criterionValue] -> WeightedMeanAndCriterionValues weightedMean criterionValue -mkWeightedMeanAndCriterionValues = MkWeightedMeanAndCriterionValues - -{- | - * Negate the /weightedMean/, but leave the criterion-values unaltered. - - * This can be used to assess the fitness of a position from the perspective of one's opponent. --} -negateWeightedMean :: Num weightedMean => WeightedMeanAndCriterionValues weightedMean criterionValue -> WeightedMeanAndCriterionValues weightedMean criterionValue -negateWeightedMean weightedMeanAndCriterionValues@MkWeightedMeanAndCriterionValues { getWeightedMean = weightedMean } = weightedMeanAndCriterionValues { getWeightedMean = negate weightedMean } - diff --git a/src-lib/BishBosh/Cartesian/Abscissa.hs b/src-lib/BishBosh/Cartesian/Abscissa.hs --- a/src-lib/BishBosh/Cartesian/Abscissa.hs +++ b/src-lib/BishBosh/Cartesian/Abscissa.hs @@ -52,7 +52,7 @@ ) where import qualified BishBosh.Data.Enum as Data.Enum -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray @@ -61,7 +61,7 @@ xOrigin = 0 -- | The constant length of the /x/-axis. -xLength :: T.Distance +xLength :: Type.Length.Distance xLength = 8 -- | The constant lower bound of abscissae. 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 @@ -92,7 +92,7 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray @@ -122,7 +122,7 @@ rnf MkCoordinates { getX = x, getY = y } = Control.DeepSeq.rnf (x, y) instance (Show x, Show y) => Show (Coordinates x y) where - showsPrec _ MkCoordinates { getX = x, getY = y } = shows (x, y) + showsPrec precedence MkCoordinates { getX = x, getY = y } = showsPrec precedence (x, y) instance ( Enum x, @@ -132,14 +132,14 @@ Read x, Read y ) => Read (Coordinates x y) where - readsPrec _ s = [ + readsPrec precedence s = [ (coordinates, remainder) | - ((x, y), remainder) <- reads s, + ((x, y), remainder) <- readsPrec precedence s, coordinates <- Data.Maybe.maybeToList $ mkMaybeCoordinates x y ] -- List-comprehension. instance (Ord x, Ord y) => Ord (Coordinates x y) where - {-# SPECIALISE instance Ord (Coordinates T.X T.Y) #-} + {-# SPECIALISE instance Ord (Coordinates Type.Length.X Type.Length.Y) #-} 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 (Enum x, Enum y) => Bounded (Coordinates x y) where @@ -158,7 +158,7 @@ Ord x, Ord y ) => Data.Array.IArray.Ix (Coordinates x y) where - {-# SPECIALISE instance Data.Array.IArray.Ix (Coordinates T.X T.Y) #-} + {-# SPECIALISE instance Data.Array.IArray.Ix (Coordinates Type.Length.X Type.Length.Y) #-} 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 @@ -193,7 +193,7 @@ nSquares = fromIntegral $ Cartesian.Abscissa.xLength * Cartesian.Ordinate.yLength instance (Enum x, Enum y) => Property.FixedMembership.FixedMembership (Coordinates x y) where - {-# SPECIALISE instance Property.FixedMembership.FixedMembership (Coordinates T.X T.Y) #-} + {-# SPECIALISE instance Property.FixedMembership.FixedMembership (Coordinates Type.Length.X Type.Length.Y) #-} members = [ MkCoordinates { getX = x, @@ -244,7 +244,7 @@ -- | Convert to an array-index. toIx :: (Enum x, Enum y) => Coordinates x y -> Int -{-# SPECIALISE toIx :: Coordinates T.X T.Y -> Int #-} +{-# SPECIALISE toIx :: Coordinates Type.Length.X Type.Length.Y -> Int #-} toIx MkCoordinates { getX = x, getY = y @@ -426,7 +426,7 @@ extrapolate = extrapolate' -- | A specialisation of 'extrapolate'. -extrapolateInt :: Attribute.Direction.Direction -> Coordinates T.X T.Y -> [Coordinates T.X T.Y] +extrapolateInt :: Attribute.Direction.Direction -> Coordinates Type.Length.X Type.Length.Y -> [Coordinates Type.Length.X Type.Length.Y] extrapolateInt direction coordinates = extrapolationsByDirectionByCoordinates ! coordinates ! direction -- | The constant lists of /coordinates/, extrapolated from every /coordinate/ in the /board/, in every /direction/. @@ -440,7 +440,7 @@ Ord x, Ord y ) => ArrayByCoordinates x y (Attribute.Direction.ArrayByDirection [Coordinates x y]) -{-# SPECIALISE extrapolationsByDirectionByCoordinates :: ArrayByCoordinates T.X T.Y (Attribute.Direction.ArrayByDirection [Coordinates T.X T.Y]) #-} -- To promote memoisation. +{-# SPECIALISE extrapolationsByDirectionByCoordinates :: ArrayByCoordinates Type.Length.X Type.Length.Y (Attribute.Direction.ArrayByDirection [Coordinates Type.Length.X Type.Length.Y]) #-} -- To promote memoisation. extrapolationsByDirectionByCoordinates = listArrayByCoordinates #ifdef USE_PARALLEL . Control.Parallel.Strategies.withStrategy (Control.Parallel.Strategies.parList Control.Parallel.Strategies.rdeepseq) @@ -460,7 +460,7 @@ Ord x, Ord y ) => ArrayByCoordinates x y (Data.Map.Map (Coordinates x y) [Coordinates x y]) -{-# SPECIALISE interpolationsByDestinationBySource :: ArrayByCoordinates T.X T.Y (Data.Map.Map (Coordinates T.X T.Y) [Coordinates T.X T.Y]) #-} -- To promote memoisation. +{-# SPECIALISE interpolationsByDestinationBySource :: ArrayByCoordinates Type.Length.X Type.Length.Y (Data.Map.Map (Coordinates Type.Length.X Type.Length.Y) [Coordinates Type.Length.X Type.Length.Y]) #-} -- To promote memoisation. interpolationsByDestinationBySource = Data.Array.IArray.amap ( Data.Map.fromList . map ( last {-destination-} &&& id {-interpolation-} @@ -496,7 +496,7 @@ | otherwise = Control.Exception.assert ( x == x' || y == y' || ( let - distanceX, distanceY :: T.Distance + distanceX, distanceY :: Type.Length.Distance (distanceX, distanceY) = measureDistance source destination in abs distanceX == abs distanceY ) -- Check that the move is straight. @@ -509,7 +509,7 @@ EQ -> repeat fromAfter -- | A specialisation of 'interpolate'. -interpolateInt :: Coordinates T.X T.Y -> Coordinates T.X T.Y -> [Coordinates T.X T.Y] +interpolateInt :: Coordinates Type.Length.X Type.Length.Y -> Coordinates Type.Length.X Type.Length.Y -> [Coordinates Type.Length.X Type.Length.Y] interpolateInt coordinatesSource coordinatesDestination = interpolationsByDestinationBySource ! coordinatesSource Data.Map.! coordinatesDestination -- | The type of a function which changes one set of /coordinates/ to another. @@ -540,7 +540,7 @@ } -- -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, xDistance', yDistance, yDistance' :: T.Distance + xDistance, xDistance', yDistance, yDistance' :: Type.Length.Distance xDistance = fromIntegral $ Cartesian.Abscissa.toIx x yDistance = fromIntegral $ Cartesian.Ordinate.toIx y xDistance' = pred Cartesian.Abscissa.xLength - xDistance @@ -576,7 +576,7 @@ | even $ uncurry (+) distance = Attribute.LogicalColourOfSquare.black | otherwise = Attribute.LogicalColourOfSquare.white where - distance :: (T.Distance, T.Distance) + distance :: (Type.Length.Distance, Type.Length.Distance) distance = measureDistance minBound coordinates -- | Whether the specified squares have the same /logical colour/. 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 @@ -58,7 +58,7 @@ import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Data.Enum as Data.Enum import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray @@ -67,7 +67,7 @@ yOrigin = Cartesian.Abscissa.xOrigin -- N.B. it doesn't need to be the same. -- | The constant length of the /y/-axis. -yLength :: T.Distance +yLength :: Type.Length.Distance yLength = Cartesian.Abscissa.xLength -- Because the board is square. -- | The constant lower bound of ordinates. 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 @@ -63,7 +63,7 @@ import qualified BishBosh.Data.Enum as Data.Enum import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception @@ -116,7 +116,7 @@ isStraight vector = isParallel vector || isDiagonal vector -- | A suitable concrete type. -type VectorInt = Vector T.Distance +type VectorInt = Vector Type.Length.Distance instance Control.DeepSeq.NFData distance => Control.DeepSeq.NFData (Vector distance) where rnf MkVector { getXDistance = xDistance, getYDistance = yDistance } = Control.DeepSeq.rnf (xDistance, yDistance) @@ -230,7 +230,7 @@ => Cartesian.Coordinates.Coordinates x y -> Vector distance -> Maybe (Cartesian.Coordinates.Coordinates x y) -{-# SPECIALISE maybeTranslate :: Cartesian.Coordinates.Coordinates T.X T.Y -> Vector T.Distance -> Maybe (Cartesian.Coordinates.Coordinates T.X T.Y) #-} +{-# SPECIALISE maybeTranslate :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Vector Type.Length.Distance -> Maybe (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) #-} maybeTranslate coordinates (MkVector xDistance yDistance) = Cartesian.Coordinates.maybeTranslate ( Data.Enum.translate (+ fromIntegral xDistance) *** Data.Enum.translate (+ fromIntegral yDistance) ) coordinates 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 @@ -51,7 +51,7 @@ import qualified BishBosh.Data.Enum as Data.Enum import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception -- | Defines a castling-move. @@ -121,7 +121,7 @@ getCastlingMoves = defineCastlingMoves -- | A specialisation of 'getCastlingMoves'. -getCastlingMovesInt :: Attribute.LogicalColour.LogicalColour -> [CastlingMove T.X T.Y] +getCastlingMovesInt :: Attribute.LogicalColour.LogicalColour -> [CastlingMove Type.Length.X Type.Length.Y] getCastlingMovesInt = (castlingMovesByLogicalColour !) -- | Break-down the two castling-moves for the specified /logical colour/ into a long & a short castling-move. @@ -131,7 +131,7 @@ Eq y, Ord x ) => Attribute.LogicalColour.LogicalColour -> (CastlingMove x y, CastlingMove x y) -{-# SPECIALISE getLongAndShortMoves :: Attribute.LogicalColour.LogicalColour -> (CastlingMove T.X T.Y, CastlingMove T.X T.Y) #-} +{-# SPECIALISE getLongAndShortMoves :: Attribute.LogicalColour.LogicalColour -> (CastlingMove Type.Length.X Type.Length.Y, CastlingMove Type.Length.X Type.Length.Y) #-} 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 @@ -25,8 +25,6 @@ module BishBosh.Component.Move( -- * Types -- ** Type-synonyms - NMoves, - NPlies, Move( -- MkMove, getSource, @@ -50,7 +48,8 @@ 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.Types as T +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 @@ -60,14 +59,8 @@ tag :: String tag = "move" --- | A number of moves. -type NMoves = Int - --- | A number of half-moves into a /game/. -type NPlies = NMoves - -- | The constant number of plies per move. -nPliesPerMove :: NPlies +nPliesPerMove :: Type.Count.NPlies nPliesPerMove = 2 {- | @@ -81,7 +74,7 @@ } deriving Eq instance (Ord x, Ord y) => Ord (Move x y) where - {-# SPECIALISE instance Ord (Move T.X T.Y) #-} + {-# SPECIALISE instance Ord (Move Type.Length.X Type.Length.Y) #-} move@MkMove { getSource = source } `compare` move'@MkMove { getSource = source' } = case source `compare` source' of EQ -> Data.Ord.comparing getDestination move move' ordering -> ordering @@ -93,10 +86,10 @@ } = Control.DeepSeq.rnf (source, destination) instance (Show x, Show y) => Show (Move x y) where - showsPrec _ MkMove { + showsPrec precedence MkMove { getSource = source, getDestination = destination - } = shows (source, destination) + } = showsPrec precedence (source, destination) instance ( Enum x, @@ -106,7 +99,7 @@ Read x, Read y ) => Read (Move x y) where - readsPrec _ = map (Control.Arrow.first $ uncurry mkMove) . reads + readsPrec precedence = map (Control.Arrow.first $ uncurry mkMove) . readsPrec precedence instance Property.Opposable.Opposable (Move x y) where getOpposite (MkMove source destination) = MkMove { @@ -155,7 +148,7 @@ Num distance, Ord distance ) => Move x y -> Cartesian.Vector.Vector distance -{-# SPECIALISE measureDistance :: Move T.X T.Y -> Cartesian.Vector.VectorInt #-} +{-# SPECIALISE measureDistance :: Move Type.Length.X Type.Length.Y -> Cartesian.Vector.VectorInt #-} measureDistance MkMove { getSource = source, getDestination = destination @@ -168,7 +161,7 @@ Ord x, Ord y ) => Move x y -> [Cartesian.Coordinates.Coordinates x y] -{-# SPECIALISE interpolate :: Move T.X T.Y -> [Cartesian.Coordinates.Coordinates T.X T.Y] #-} +{-# SPECIALISE interpolate :: Move Type.Length.X Type.Length.Y -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] #-} interpolate move@MkMove { getSource = source, getDestination = destination 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 @@ -27,7 +27,6 @@ module BishBosh.Component.Piece( -- * Types -- ** Type-synonyms - NPieces, -- ByRankByLogicalColour, -- AttackDestinationsByCoordinatesByRankByLogicalColour, -- ArrayByPiece, @@ -92,7 +91,8 @@ 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.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray @@ -111,12 +111,9 @@ tag :: String tag = "piece" --- | A number of /piece/s. -type NPieces = Int -- N.B.: 'Data.Int.Int8' saves neither time nor space. - -- | The initial number of pieces per side in a standard opening position; some of which are duplicates. -nPiecesPerSide :: NPieces -nPiecesPerSide = fromIntegral Cartesian.Abscissa.xLength * 2 {-rows-} +nPiecesPerSide :: Type.Count.NPieces +nPiecesPerSide = fromIntegral $ Cartesian.Abscissa.xLength * 2 {-rows-} -- | A Chess-piece has a /logical colour/ & a /rank/. data Piece = MkPiece { @@ -136,7 +133,7 @@ index (lower, upper) MkPiece { getLogicalColour = logicalColour, getRank = rank - } = Control.Exception.assert (lower == minBound && upper == maxBound) $ fromEnum logicalColour * Attribute.Rank.nDistinctRanks + fromEnum rank + } = Control.Exception.assert (lower == minBound && upper == maxBound) $ fromEnum logicalColour * fromIntegral Attribute.Rank.nDistinctRanks + fromEnum rank instance Read Piece where readsPrec _ = Property.ForsythEdwards.readsFEN @@ -287,7 +284,7 @@ Ord x, Ord y ) => AttackDestinationsByCoordinatesByRankByLogicalColour x y -{-# SPECIALISE attackDestinationsByCoordinatesByRankByLogicalColour :: AttackDestinationsByCoordinatesByRankByLogicalColour T.X T.Y #-} -- To promote memoisation. +{-# SPECIALISE attackDestinationsByCoordinatesByRankByLogicalColour :: AttackDestinationsByCoordinatesByRankByLogicalColour Type.Length.X Type.Length.Y #-} -- To promote memoisation. attackDestinationsByCoordinatesByRankByLogicalColour = mkByRankByLogicalColour Attribute.Rank.fixedAttackRange $ \logicalColour rank -> Cartesian.Coordinates.listArrayByCoordinates $ map ( `findAttackDestinations'` mkPiece logicalColour rank ) Property.FixedMembership.members @@ -326,7 +323,7 @@ findAttackDestinations = findAttackDestinations' -- | A specialisation of 'findAttackDestinations', more efficiently implemented by calling 'attackDestinationsByCoordinatesByRankByLogicalColour'. -findAttackDestinationsInt :: Cartesian.Coordinates.Coordinates T.X T.Y -> Piece -> [Cartesian.Coordinates.Coordinates T.X T.Y] +findAttackDestinationsInt :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Piece -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] findAttackDestinationsInt coordinates MkPiece { getLogicalColour = logicalColour, getRank = rank @@ -373,7 +370,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ Destination (victim's location). -> Piece -- ^ Attacker. -> Bool -{-# SPECIALISE canAttackAlong :: Cartesian.Coordinates.Coordinates T.X T.Y -> Cartesian.Coordinates.Coordinates T.X T.Y -> Piece -> Bool #-} +{-# SPECIALISE canAttackAlong :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Piece -> Bool #-} canAttackAlong source destination piece = ( case getRank piece of Attribute.Rank.Pawn -> Cartesian.Vector.isPawnAttack $ getLogicalColour piece @@ -400,7 +397,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. -> Piece -> Bool -{-# SPECIALISE canMoveBetween :: Cartesian.Coordinates.Coordinates T.X T.Y -> Cartesian.Coordinates.Coordinates T.X T.Y -> Piece -> Bool #-} +{-# SPECIALISE canMoveBetween :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Piece -> Bool #-} canMoveBetween source destination piece = ( case getRank piece of Attribute.Rank.Pawn -> \distance -> let 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 @@ -46,7 +46,7 @@ mkPieceSquareByCoordinatesByRank ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import Data.Array.IArray((!)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank @@ -56,17 +56,22 @@ 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.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.DeepSeq import qualified Data.Array.IArray import qualified Data.List -- | The piece-square value may vary as the game progresses. -type PieceSquareValueByNPieces pieceSquareValue = Data.Array.IArray.Array Component.Piece.NPieces pieceSquareValue +type PieceSquareValueByNPieces pieceSquareValue = Data.Array.IArray.Array Type.Count.NPieces pieceSquareValue -- | The bounds of the number of pieces on the board, at the end-game & opening-game respectively. -nPiecesBounds :: (Component.Piece.NPieces, Component.Piece.NPieces) -nPiecesBounds = (3 {-minimum sufficient material-}, Attribute.LogicalColour.nDistinctLogicalColours * Component.Piece.nPiecesPerSide) +nPiecesBounds :: (Type.Count.NPieces, Type.Count.NPieces) +nPiecesBounds = ( + 3 {-minimum sufficient material-}, + fromIntegral Attribute.LogicalColour.nDistinctLogicalColours * Component.Piece.nPiecesPerSide + ) -- | Self-documentation. type EitherPieceSquareValueByNPiecesByCoordinates x y pieceSquareValue = Either ( @@ -107,24 +112,24 @@ Ord x, Ord y ) - => Component.Piece.NPieces -- ^ The progress through the game. + => 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 x y -- ^ The /piece/'s location. -> PieceSquareByCoordinatesByRank x y pieceSquareValue -> pieceSquareValue {-# SPECIALISE findPieceSquareValue - :: Component.Piece.NPieces + :: Type.Count.NPieces -> Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank - -> Cartesian.Coordinates.Coordinates T.X T.Y - -> PieceSquareByCoordinatesByRank T.X T.Y T.PieceSquareValue - -> T.PieceSquareValue + -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y + -> PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue + -> Type.Mass.PieceSquareValue #-} -findPieceSquareValue nPieces logicalColour rank coordinates MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = either (!) ( - \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) - ) ( - byRank ! rank +findPieceSquareValue nPieces logicalColour rank coordinates MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = ( + (!) ||| ( + \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) + ) $ byRank ! rank ) $ ( if Attribute.LogicalColour.isBlack logicalColour then Property.Reflectable.reflectOnX @@ -145,24 +150,24 @@ Ord x, Ord y ) - => Component.Piece.NPieces -- ^ The progress through the game. + => 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 x y] -- ^ The locations of interest for the specified /piece/. -> PieceSquareByCoordinatesByRank x y pieceSquareValue -> [pieceSquareValue] {-# SPECIALISE findPieceSquareValues - :: Component.Piece.NPieces + :: Type.Count.NPieces -> Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank - -> [Cartesian.Coordinates.Coordinates T.X T.Y] - -> PieceSquareByCoordinatesByRank T.X T.Y T.PieceSquareValue - -> [T.PieceSquareValue] + -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] + -> PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue + -> [Type.Mass.PieceSquareValue] #-} -findPieceSquareValues nPieces logicalColour rank coordinatesList MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = either (!) ( - \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) - ) ( - byRank ! rank +findPieceSquareValues nPieces logicalColour rank coordinatesList MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = ( + (!) ||| ( + \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) + ) $ byRank ! rank ) `map` ( if Attribute.LogicalColour.isBlack logicalColour then map Property.Reflectable.reflectOnX @@ -218,11 +223,9 @@ else id ) . showS ) id . zip ( - Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates T.X T.Y] + Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] ) . Data.List.transpose . map ( - Data.Array.IArray.elems `either` ( - map selector {-select one pieceSquareValue from interpolated values-} . Data.Array.IArray.elems {-ByCoordinates-} - ) + Data.Array.IArray.elems ||| map selector {-select one pieceSquareValue from interpolated values-} . Data.Array.IArray.elems {-ByCoordinates-} ) $ Data.Array.IArray.elems {-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 @@ -48,10 +48,10 @@ } deriving Eq instance (Show x, Show y) => Show (QualifiedMove x y) where - showsPrec _ MkQualifiedMove { + showsPrec precedence MkQualifiedMove { getMove = move, getMoveType = moveType - } = shows (move, moveType) + } = showsPrec precedence (move, moveType) instance ( Enum x, @@ -61,7 +61,7 @@ Read x, Read y ) => Read (QualifiedMove x y) where - readsPrec _ = map (Control.Arrow.first $ uncurry MkQualifiedMove) . reads + readsPrec precedence = map (Control.Arrow.first $ uncurry MkQualifiedMove) . readsPrec precedence instance (Control.DeepSeq.NFData x, Control.DeepSeq.NFData y) => Control.DeepSeq.NFData (QualifiedMove x y) where rnf MkQualifiedMove { 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 @@ -81,11 +81,11 @@ } = Control.DeepSeq.rnf (qualifiedMove, rank, isRepeatableMove) instance (Show x, Show y) => Show (Turn x y) where - showsPrec _ MkTurn { + showsPrec precedence MkTurn { getQualifiedMove = qualifiedMove, getRank = rank -- getIsRepeatableMove = isRepeatableMove - } = shows ( + } = showsPrec precedence ( qualifiedMove, rank -- isRepeatableMove -- Derived. @@ -99,7 +99,7 @@ Read x, Read y ) => Read (Turn x y) where - readsPrec _ = map (Control.Arrow.first $ uncurry mkTurn) . reads + readsPrec precedence = map (Control.Arrow.first $ uncurry mkTurn) . readsPrec precedence instance Enum y => Property.Reflectable.ReflectableOnX (Turn x y) where reflectOnX turn@MkTurn { getQualifiedMove = qualifiedMove } = turn { getQualifiedMove = Property.Reflectable.reflectOnX qualifiedMove } @@ -138,8 +138,7 @@ -- | Forwards the request to 'Attribute.Rank.compareByLVA'. compareByLVA - :: Ord rankValue - => Attribute.Rank.EvaluateRank rankValue + :: Attribute.Rank.EvaluateRank -> Turn x y -> Turn x y -> Ordering @@ -155,8 +154,7 @@ * CAVEAT: no account is made for any defenders of the attacked piece, which might recoup transient gains. -} compareByMVVLVA - :: Ord rankValue - => Attribute.Rank.EvaluateRank rankValue + :: Attribute.Rank.EvaluateRank -> Turn x y -> Turn x y -> Ordering 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 @@ -75,17 +75,17 @@ import Control.Arrow((&&&), (***)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.ContextualNotation.PGNComment as ContextualNotation.PGNComment import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason -import qualified BishBosh.Model.Result as Model.Result import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason +import qualified BishBosh.Rule.Result as Rule.Result import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Applicative import qualified Control.Arrow import qualified Control.DeepSeq @@ -215,7 +215,7 @@ Show x, Show y ) => Show (PGN x y) where - {-# SPECIALISE instance Show (PGN T.X T.Y) #-} + {-# SPECIALISE instance Show (PGN Type.Length.X Type.Length.Y) #-} showsPrec _ MkPGN { getMaybeEventName = maybeEventName, getMaybeSiteName = maybeSiteName, @@ -243,7 +243,7 @@ ), ( blackPlayerNameTag, representUnknownTagValue maybeBlackPlayerName ), ( - resultTag, quote . Data.Maybe.maybe (showChar inProgressFlag) (shows . Model.GameTerminationReason.toResult) $ Model.Game.getMaybeTerminationReason game + resultTag, quote . Data.Maybe.maybe (showChar inProgressFlag) (shows . Rule.GameTerminationReason.toResult) $ Model.Game.getMaybeTerminationReason game ) ] ++ map ( Control.Arrow.second $ quote . showString @@ -308,7 +308,7 @@ setGame :: Model.Game.Game x y -> PGN x y -> PGN x y setGame game pgn = pgn { getGame = game } --- | Smart-constructor. +-- | Smart constructor. mkPGN' :: [Tag] -- ^ Identify fields used to form a unique composite game-identifier. -> [TagPair] -- ^ The data from which to extract the required values. @@ -372,7 +372,7 @@ Show x, Show y ) => Model.Game.Game x y -> ShowS -{-# SPECIALISE showsMoveText :: Model.Game.Game T.X T.Y -> ShowS #-} +{-# SPECIALISE showsMoveText :: Model.Game.Game Type.Length.X Type.Length.Y -> ShowS #-} showsMoveText game = foldr (.) ( Data.Maybe.maybe ( showsBlockComment "Game unfinished" . showChar ' ' . showChar inProgressFlag @@ -380,7 +380,7 @@ ( \(s, showsPGN) -> showsBlockComment s . showChar ' ' . showsPGN ) . ( - filter (/= ContextualNotation.PGNComment.blockCommentEnd) . show &&& shows . Model.GameTerminationReason.toResult + filter (/= ContextualNotation.PGNComment.blockCommentEnd) . show &&& shows . Rule.GameTerminationReason.toResult ) ) $ Model.Game.getMaybeTerminationReason game ) $ Data.List.unfoldr ( @@ -396,7 +396,7 @@ ) $ Data.List.splitAt 1 remainder _ -> Nothing ) ( - 1 :: Component.Move.NMoves, + 1 :: Type.Count.NMoves, reverse {-chronological-} $ fst . foldr ( \turn (l, game') -> ( ContextualNotation.StandardAlgebraic.showsTurn False turn game' : l, @@ -416,7 +416,7 @@ Show x, Show y ) => Model.Game.Game x y -> IO ShowS -{-# SPECIALISE showsGame :: Model.Game.Game T.X T.Y -> IO ShowS #-} +{-# SPECIALISE showsGame :: Model.Game.Game Type.Length.X Type.Length.Y -> IO ShowS #-} showsGame game = do utcTime <- Data.Time.Clock.getCurrentTime @@ -453,12 +453,12 @@ * N.B.: officially terminated by a single period (for White), or three (by Black); though this parser is more flexible. -} -moveNumberParser :: Num n => +moveNumberParser :: #ifdef USE_POLYPARSE - Text.Poly.TextParser n + Text.Poly.TextParser Type.Count.NMoves moveNumberParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.unsignedDecimal `Poly.discard` Control.Applicative.some (Text.Poly.char moveNumberTerminator) #else /* Parsec */ - Parsec.Parser n + Parsec.Parser Type.Count.NMoves moveNumberParser = Parsec.try $ Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> fmap Data.Integral.stringToUnsignedDecimal ( Parsec.manyTill Parsec.digit ( Control.Applicative.some $ Parsec.char moveNumberTerminator @@ -469,7 +469,7 @@ -- | Parse an optional result. maybeResultParser :: #ifdef USE_POLYPARSE - Text.Poly.TextParser (Maybe Model.Result.Result) + Text.Poly.TextParser (Maybe Rule.Result.Result) maybeResultParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Poly.oneOf' [ ( "Result", @@ -482,7 +482,7 @@ ) ] #else /* Parsec */ - Parsec.Parser (Maybe Model.Result.Result) + Parsec.Parser (Maybe Rule.Result.Result) maybeResultParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> ( Parsec.try ( Parsec.choice $ map ( @@ -507,7 +507,7 @@ => IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Text.Poly.TextParser (Model.Game.Game x y) -{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Text.Poly.TextParser (Model.Game.Game T.X T.Y) #-} +{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Text.Poly.TextParser (Model.Game.Game Type.Length.X Type.Length.Y) #-} moveTextParser isStrictlySequential validateMoves = let elementSequenceParser :: ( Enum x, @@ -518,7 +518,8 @@ Show y ) => Model.Game.Game x y -> Text.Poly.TextParser (Model.Game.Game x y) elementSequenceParser game = let - expectedMoveNumber = succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game + expectedMoveNumber :: Type.Count.NMoves + expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game in do moveNumber <- ( if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game @@ -553,7 +554,7 @@ => IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Parsec.Parser (Model.Game.Game x y) -{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Parsec.Parser (Model.Game.Game T.X T.Y) #-} +{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Parsec.Parser (Model.Game.Game Type.Length.X Type.Length.Y) #-} moveTextParser isStrictlySequential validateMoves = let elementSequenceParser :: ( Enum x, @@ -564,7 +565,8 @@ Show y ) => Model.Game.Game x y -> Parsec.Parser (Model.Game.Game x y) elementSequenceParser game = let - expectedMoveNumber = succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game + expectedMoveNumber :: Type.Count.NMoves + expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game in do moveNumber <- ( if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game @@ -614,7 +616,7 @@ -> [Tag] -- ^ Identify fields used to form a unique composite game-identifier. #ifdef USE_POLYPARSE -> Text.Poly.TextParser (PGN x y) -{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Text.Poly.TextParser (PGN T.X T.Y) #-} +{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Text.Poly.TextParser (PGN Type.Length.X Type.Length.Y) #-} parser isStrictlySequential validateMoves identificationTags = do tagPairs <- Control.Applicative.many $ tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser moveText <- moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser @@ -642,7 +644,7 @@ ) #else /* Parsec */ -> Parsec.Parser (PGN x y) -{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Parsec.Parser (PGN T.X T.Y) #-} +{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Parsec.Parser (PGN Type.Length.X Type.Length.Y) #-} parser isStrictlySequential validateMoves identificationTags = mkPGN' identificationTags <$> ( removeUnknownTagValues <$> Control.Applicative.many ( tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser diff --git a/src-lib/BishBosh/ContextualNotation/PGNDatabase.hs b/src-lib/BishBosh/ContextualNotation/PGNDatabase.hs --- a/src-lib/BishBosh/ContextualNotation/PGNDatabase.hs +++ b/src-lib/BishBosh/ContextualNotation/PGNDatabase.hs @@ -35,7 +35,7 @@ PGNDatabase, -- PGNPredicate, Decompressor, --- MaybeMaximumGames, + MaybeMaximumGames, -- * Functions -- parser, -- parse, @@ -46,7 +46,8 @@ import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Control.Monad import qualified Data.Maybe @@ -57,12 +58,14 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# else /* Plain */ +import qualified Control.Arrow import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# endif #else /* Parsec */ +import qualified Control.Arrow import qualified Text.ParserCombinators.Parsec as Parsec import Text.ParserCombinators.Parsec(()) #endif @@ -84,11 +87,11 @@ -> [ContextualNotation.PGN.Tag] #ifdef USE_POLYPARSE -> Text.Poly.TextParser (PGNDatabase x y) -{-# SPECIALISE parser :: ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> Text.Poly.TextParser (PGNDatabase T.X T.Y) #-} +{-# SPECIALISE parser :: ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> Text.Poly.TextParser (PGNDatabase Type.Length.X Type.Length.Y) #-} parser isStrictlySequential validateMoves identificationTags = Poly.manyFinally' parser' $ Text.Poly.spaces >> Poly.eof #else /* Parsec */ -> Parsec.Parser (PGNDatabase x y) -{-# SPECIALISE parser :: ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> Parsec.Parser (PGNDatabase T.X T.Y) #-} +{-# SPECIALISE parser :: ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> Parsec.Parser (PGNDatabase Type.Length.X Type.Length.Y) #-} parser isStrictlySequential validateMoves identificationTags = Parsec.manyTill parser' (Parsec.try $ Parsec.spaces >> Parsec.try Parsec.eof) "PGN-database" #endif where @@ -98,7 +101,7 @@ type PGNPredicate x y = ContextualNotation.PGN.PGN x y -> Bool -- | The optional maximum number of games to read. -type MaybeMaximumGames = Maybe Int +type MaybeMaximumGames = Maybe Type.Count.NGames -- | Parses a PGN-database from the specified string. parse :: ( @@ -117,20 +120,20 @@ -> MaybeMaximumGames -- ^ Optional maximum number of games to read from the database (after they've been filtered). -> String -- ^ The database-contents. -> Either String (PGNDatabase x y) -{-# SPECIALISE parse :: String -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> PGNPredicate T.X T.Y -> MaybeMaximumGames -> String -> Either String (PGNDatabase T.X T.Y) #-} +{-# SPECIALISE parse :: String -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] -> PGNPredicate Type.Length.X Type.Length.Y -> MaybeMaximumGames -> String -> Either String (PGNDatabase Type.Length.X Type.Length.Y) #-} #ifdef USE_POLYPARSE -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 parse _ isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = Right -- N.B.: the lazy parser throws an exception rather than returning 'Either', because otherwise it can't choose whether to construct with 'Left' or 'Right' until the input has been fully parsed. -#else /* Plain */ -parse name isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = either (Left . showString "regarding " . shows name . showString ", ") Right -#endif +# else /* Plain */ +parse name isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = Control.Arrow.left (showString "regarding " . shows name . showString ", ") +# endif . fst {-discard unparsed data-} . Poly.runParser parser' #else /* Parsec */ -parse name isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = either (Left . showString "failed to parse; " . show) Right . Parsec.parse parser' name +parse name isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = Control.Arrow.left (showString "failed to parse; " . show) . Parsec.parse parser' name #endif where parser' = ( - Data.Maybe.maybe id take maybeMaximumGames . filter pgnPredicate -- CAVEAT: apply the filter before extracting the required number of games. + Data.Maybe.maybe id (take . fromIntegral) maybeMaximumGames . filter pgnPredicate -- CAVEAT: apply the filter before extracting the required number of games. ) `fmap` parser isStrictlySequential validateMoves identificationTags -- | The name of an executable used to decompress (to stdout) the PGN-file. @@ -154,7 +157,7 @@ -> PGNPredicate x y -- ^ Used to filter entries from the database. -> MaybeMaximumGames -- ^ Optional maximum number of games to read from the database (after they've been filtered). -> IO (Either String (PGNDatabase x y)) -{-# SPECIALISE parseIO :: System.FilePath.FilePath -> Maybe Decompressor -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> System.IO.TextEncoding -> [ContextualNotation.PGN.Tag] -> PGNPredicate T.X T.Y -> MaybeMaximumGames -> IO (Either String (PGNDatabase T.X T.Y)) #-} +{-# SPECIALISE parseIO :: System.FilePath.FilePath -> Maybe Decompressor -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> System.IO.TextEncoding -> [ContextualNotation.PGN.Tag] -> PGNPredicate Type.Length.X Type.Length.Y -> MaybeMaximumGames -> IO (Either String (PGNDatabase Type.Length.X Type.Length.Y)) #-} parseIO filePath maybeDecompressionCommand isStrictlySequential validateMoves textEncoding identificationTags pgnPredicate maybeMaximumGames = parse filePath isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames `fmap` Data.Maybe.maybe ( System.IO.withFile filePath System.IO.ReadMode $ \fileHandle -> do System.IO.hSetEncoding fileHandle textEncoding 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 @@ -54,10 +54,12 @@ import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.Result as Model.Result import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Rule.Result as Rule.Result import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.Exception import qualified Data.Array.IArray @@ -89,7 +91,7 @@ data PositionHashQualifiedMoveTree x y positionHash = MkPositionHashQualifiedMoveTree { getZobrist :: Component.Zobrist.Zobrist x y positionHash, -- ^ Used to hash each position in the tree. getTree :: Tree x y positionHash, - getMinimumPieces :: Component.Piece.NPieces -- ^ The minimum number of /piece/s remaining after the last /move/ in any game defined in the tree. + getMinimumPieces :: Type.Count.NPieces -- ^ The minimum number of /piece/s remaining after the last /move/ in any game defined in the tree. } -- | Augment the specified /qualified-move forest/ with a /Zobrist-hash/ of the /position/ & include the default initial game at the apex. @@ -106,7 +108,7 @@ -> Component.Zobrist.Zobrist x y positionHash -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y -> PositionHashQualifiedMoveTree x y positionHash -{-# SPECIALISE fromQualifiedMoveForest :: Bool -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest T.X T.Y -> PositionHashQualifiedMoveTree T.X T.Y T.PositionHash #-} +{-# SPECIALISE fromQualifiedMoveForest :: Bool -> Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest Type.Length.X Type.Length.Y -> PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} fromQualifiedMoveForest incrementalEvaluation zobrist qualifiedMoveForest = MkPositionHashQualifiedMoveTree { getZobrist = zobrist, getTree = let @@ -199,7 +201,7 @@ Enum y, Ord y ) => FindMatch x y positionHash -{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch T.X T.Y T.PositionHash #-} +{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} findNextOnymousQualifiedMovesForPosition requiredGame positionHashQualifiedMoveTree@MkPositionHashQualifiedMoveTree { getZobrist = zobrist, getTree = tree @@ -207,26 +209,26 @@ | cantConverge requiredGame positionHashQualifiedMoveTree = [] -- The specified game has fewer pieces than any defined in the tree. | otherwise = slave (2 * Component.Piece.nPiecesPerSide) tree where + (requiredPositionHash, requiredNPieces) = (`Component.Zobrist.hash2D` zobrist) &&& State.Board.getNPieces . Model.Game.getBoard $ requiredGame + slave nPieces Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash }, Data.Tree.subForest = forest - } - | nPieces < State.Board.getNPieces ( - Model.Game.getBoard requiredGame - ) = [] -- There are fewer pieces remaining in the tree than required. - | otherwise = ( - if positionHash == Component.Zobrist.hash2D requiredGame zobrist - then ( - map onymiseQualifiedMove forest ++ -- The Zobrist-hash/position matches, so one can select any move from the forest. - ) -- Section. - else id - ) $ concatMap ( - \node@Data.Tree.Node { - Data.Tree.rootLabel = MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just (qualifiedMove, _) } - } -> slave ( - Attribute.MoveType.nPiecesMutator (Component.QualifiedMove.getMoveType qualifiedMove) nPieces - ) node -- Recurse to see if deeper matches exist. - ) forest + } = ( + if positionHash == requiredPositionHash + then ( + map onymiseQualifiedMove forest ++ -- The position matches, so one can select any move from the forest. + ) -- Section. + else id + ) $ concatMap ( + \node@Data.Tree.Node { + Data.Tree.rootLabel = MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just (qualifiedMove, _) } + } -> if Attribute.MoveType.isCapture $ Component.QualifiedMove.getMoveType qualifiedMove + then if nPieces == requiredNPieces + then [] -- Terminate the recursion; no further pieces can be lost if a match is to occur. + else slave (pred nPieces) node -- Recurse. + else slave nPieces node -- Recurse. + ) forest -- | Finds any single /move/s which can join the current /position/ with a member of the forest. findNextJoiningOnymousQualifiedMovesFromPosition :: ( @@ -242,24 +244,21 @@ Show x, Show y ) => FindMatch x y positionHash -{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch T.X T.Y T.PositionHash #-} -findNextJoiningOnymousQualifiedMovesFromPosition game positionHashQualifiedMoveTree = [ - ( - preMatchQualifiedMove, - concatMap snd {-[OnymousResult]-} matchingOnymousQualifiedMoves -- Discard the opponent's matching move, but cite the names of archived games it reached. - ) | - not $ Model.Game.isTerminated game, - (preMatchQualifiedMove, matchingOnymousQualifiedMoves) <- +{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} +findNextJoiningOnymousQualifiedMovesFromPosition game positionHashQualifiedMoveTree + | 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. + movePair@(_, _ : _) <- #ifdef USE_PARALLEL - Control.Parallel.Strategies.withStrategy ( - Control.Parallel.Strategies.parList $ Control.Parallel.Strategies.evalTuple2 Control.Parallel.Strategies.r0 {-pre-match move-} Control.Parallel.Strategies.rdeepseq {-matching moves-} - ) . + Control.Parallel.Strategies.withStrategy ( + Control.Parallel.Strategies.parList $ Control.Parallel.Strategies.evalTuple2 Control.Parallel.Strategies.r0 {-pre-match move-} Control.Parallel.Strategies.rdeepseq {-matching moves-} + ) . #endif - map ( - id &&& (`findNextOnymousQualifiedMovesForPosition` positionHashQualifiedMoveTree) . (`Model.Game.applyQualifiedMove` game) -- Apply this player's move. - ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game, - not $ null matchingOnymousQualifiedMoves - ] -- List-comprehension. + map ( + id &&& (`findNextOnymousQualifiedMovesForPosition` positionHashQualifiedMoveTree) . (`Model.Game.applyQualifiedMove` game) -- Apply this player's move. + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + ] -- List-comprehension. {- | * Calls 'findNextOnymousQualifiedMovesForGame' to find an exact match for the current /game/ in the tree. @@ -289,7 +288,7 @@ ) => (Bool, Bool, Bool) -- ^ MatchSwitches. -> FindMatch x y positionHash -{-# SPECIALISE findNextOnymousQualifiedMoves :: (Bool, Bool, Bool) -> FindMatch T.X T.Y T.PositionHash #-} +{-# SPECIALISE findNextOnymousQualifiedMoves :: (Bool, Bool, Bool) -> FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} findNextOnymousQualifiedMoves (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) game positionHashQualifiedMoveTree | cantConverge game positionHashQualifiedMoveTree = [] -- The specified game is smaller than any defined in the tree. | otherwise = Data.Maybe.fromMaybe [] . Data.List.find ( @@ -336,9 +335,9 @@ :: System.Random.RandomGen randomGen => randomGen -> (Bool, Bool, Bool) - -> Model.Game.Game T.X T.Y - -> PositionHashQualifiedMoveTree T.X T.Y T.PositionHash - -> Maybe (Component.QualifiedMove.QualifiedMove T.X T.Y, [ContextualNotation.QualifiedMoveForest.Name]) + -> Model.Game.Game Type.Length.X Type.Length.Y + -> PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash + -> Maybe (Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y, [ContextualNotation.QualifiedMoveForest.Name]) #-} maybeRandomlySelectOnymousQualifiedMove randomGen matchSwitches game positionHashQualifiedMoveTree = case findNextOnymousQualifiedMoves matchSwitches game positionHashQualifiedMoveTree of [] -> Nothing @@ -354,7 +353,7 @@ then id else negate ) 1 {-victory-} - ) . Model.Result.findMaybeVictor . snd {-result-} -- Score the result, according to which side we'd like to win. + ) . Rule.Result.findMaybeVictor . snd {-result-} -- Score the result, according to which side we'd like to win. ) . snd {-[OnymousResult]-} ) onymousQualifiedMoves 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 @@ -50,24 +50,23 @@ import Control.Applicative((<|>)) import Control.Arrow((&&&), (***)) -import qualified BishBosh.Attribute.MoveType as Attribute.MoveType -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.ContextualNotation.PGN as ContextualNotation.PGN -import qualified BishBosh.ContextualNotation.PGNDatabase as ContextualNotation.PGNDatabase -import qualified BishBosh.Data.RoseTree as Data.RoseTree -import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason -import qualified BishBosh.Model.GameTree as Model.GameTree -import qualified BishBosh.Model.Result as Model.Result -import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation -import qualified BishBosh.Property.Empty as Property.Empty -import qualified BishBosh.Property.Null as Property.Null -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN +import qualified BishBosh.ContextualNotation.PGNDatabase as ContextualNotation.PGNDatabase +import qualified BishBosh.Data.RoseTree as Data.RoseTree +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Model.GameTree as Model.GameTree +import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason +import qualified BishBosh.Rule.Result as Rule.Result +import qualified BishBosh.State.Board as State.Board +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 Control.Arrow import qualified Data.Default import qualified Data.List @@ -78,7 +77,7 @@ type Name = String -- | The name of a /game/, & it's /result/. -type OnymousResult = (Name, Model.Result.Result) +type OnymousResult = (Name, Rule.Result.Result) {- | * Terminal nodes contain the unique name of the /move/-sequence leading to them, from which other information can be found as required, from the original database. @@ -119,19 +118,19 @@ ) maybeOnymousResult "" ) forest --- | Shows a list of the names of archived games, optionally capped at the specified number. +-- | Shows an optional capped list of the names of archived games. showsNames - :: Maybe Int -- ^ The optional maximum number of names to show. + :: Maybe Type.Count.NGames -- ^ The optional maximum number of names to show. -> [Name] -> ShowS showsNames maybeMaximumPGNNames names = Text.ShowList.showsUnterminatedList . map ( \name -> showString "\n\t" . showString name ) $ Data.Maybe.maybe id ( \maximumPGNNames -> ( - if maximumPGNNames < length names' + if fromIntegral maximumPGNNames < length names' then (++ ["..."]) else id - ) . take maximumPGNNames + ) . take (fromIntegral maximumPGNNames) ) maybeMaximumPGNNames names' where names' = Data.List.nub $ Data.List.sort names @@ -144,8 +143,8 @@ mergePGNDatabase pgnDatabase MkQualifiedMoveForest { deconstruct = initialForest } = MkQualifiedMoveForest $ foldr ( \pgn -> merge ( mkCompositeIdentifier &&& Data.Maybe.maybe ( - Model.Result.mkResult Nothing -- The game is still in progress. - ) Model.GameTerminationReason.toResult . Model.Game.getMaybeTerminationReason . ContextualNotation.PGN.getGame $ pgn -- Construct an onymous result. + Rule.Result.mkResult Nothing -- The game is still in progress. + ) Rule.GameTerminationReason.toResult . Model.Game.getMaybeTerminationReason . ContextualNotation.PGN.getGame $ pgn -- Construct an onymous result. ) ( map Component.Turn.getQualifiedMove . Model.Game.listTurnsChronologically $ ContextualNotation.PGN.getGame pgn -- Extract the list of qualified moves defining this game. ) @@ -192,10 +191,10 @@ fromPGNDatabase = (`mergePGNDatabase` Property.Empty.empty {-QualifiedMoveForest-}) -- | Find the minimum number of /piece/s in any of the recorded /game/s. -findMinimumPieces :: QualifiedMoveForest x y -> Component.Piece.NPieces +findMinimumPieces :: QualifiedMoveForest x y -> Type.Count.NPieces findMinimumPieces = slave ( State.Board.getNPieces ( - Data.Default.def :: State.Board.Board T.X T.Y -- CAVEAT: this assumes the game to which the moves in the forest refer. + Data.Default.def :: State.Board.Board Type.Length.X Type.Length.Y -- CAVEAT: this assumes the game to which the moves in the forest refer. ) ) . deconstruct where slave nPieces [] = nPieces @@ -208,22 +207,22 @@ ) subForest -- Recurse. ) forest --- | Count the number of /game/s & /plies/. -count :: QualifiedMoveForest x y -> (Model.Game.NGames, Component.Move.NPlies) +-- | Count the number of /game/s & distinct /positions/. +count :: QualifiedMoveForest x y -> (Type.Count.NGames, Type.Count.NPositions) count = slave . deconstruct where slave = Data.List.foldl' ( - \(nGames, nPlies) Data.Tree.Node { + \(nGames, nPositions) Data.Tree.Node { Data.Tree.rootLabel = (_, maybeOnymousResult), Data.Tree.subForest = forest } -> let - acc@(nGames', nPlies') = ( + acc@(nGames', nPositions') = ( (+ nGames) . ( if Data.Maybe.isJust maybeOnymousResult then succ else id - ) *** (+ nPlies) . succ + ) *** (+ nPositions) . succ ) $ slave forest {-recurse-} - in nGames' `seq` nPlies' `seq` acc + in nGames' `seq` nPositions' `seq` acc ) (0, 0) {- | @@ -239,7 +238,7 @@ Show x, Show y ) => QualifiedMoveForest x y -> Model.GameTree.GameTree x y -{-# SPECIALISE toGameTree :: QualifiedMoveForest T.X T.Y -> Model.GameTree.GameTree T.X T.Y #-} +{-# SPECIALISE toGameTree :: QualifiedMoveForest Type.Length.X Type.Length.Y -> Model.GameTree.GameTree Type.Length.X Type.Length.Y #-} toGameTree MkQualifiedMoveForest { deconstruct = qualifiedMoveForest } = Model.GameTree.fromBareGameTree Data.Tree.Node { Data.Tree.rootLabel = initialGame, Data.Tree.subForest = map (slave initialGame) qualifiedMoveForest @@ -254,3 +253,4 @@ Data.Tree.subForest = map (slave game') qualifiedMoveForest' -- Recurse. } where game' = Model.Game.applyQualifiedMove qualifiedMove game + 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 @@ -69,13 +69,13 @@ import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Applicative import qualified Control.Exception import qualified Control.Monad @@ -161,7 +161,7 @@ -> Component.Turn.Turn x y -> Model.Game.Game x y -- ^ The /game/ prior to application of the specified /turn/. -> ShowS -{-# SPECIALISE showsTurn :: ExplicitEnPassant -> Component.Turn.Turn T.X T.Y -> Model.Game.Game T.X T.Y -> ShowS #-} +{-# SPECIALISE showsTurn :: ExplicitEnPassant -> Component.Turn.Turn Type.Length.X Type.Length.Y -> Model.Game.Game Type.Length.X Type.Length.Y -> ShowS #-} showsTurn explicitEnPassant turn game | Just sourceRank <- fmap Component.Piece.getRank . State.MaybePieceByCoordinates.dereference source $ State.Board.getMaybePieceByCoordinates board = ( if sourceRank == Attribute.Rank.Pawn @@ -200,7 +200,7 @@ ) . showsDestination ) . ( if Data.Maybe.isJust $ Model.Game.getMaybeChecked game' - then showChar $ if Data.Maybe.maybe False Model.GameTerminationReason.isCheckMate $ Model.Game.getMaybeTerminationReason game' + then showChar $ if Data.Maybe.maybe False Rule.GameTerminationReason.isCheckMate $ Model.Game.getMaybeTerminationReason game' then checkMateFlag else checkFlag else id @@ -237,7 +237,7 @@ -> Component.Turn.Turn x y -> Model.Game.Game x y -- ^ The /game/ prior to application of the specified /turn/. -> String -{-# SPECIALISE showTurn :: ExplicitEnPassant -> Component.Turn.Turn T.X T.Y -> Model.Game.Game T.X T.Y -> String #-} +{-# SPECIALISE showTurn :: ExplicitEnPassant -> Component.Turn.Turn Type.Length.X Type.Length.Y -> Model.Game.Game Type.Length.X Type.Length.Y -> String #-} showTurn explicitEnPassant turn game = showsTurn explicitEnPassant turn game "" -- | A convenience-function, which generates the /turn/ required to call 'showsTurn'. @@ -253,7 +253,7 @@ -> Component.QualifiedMove.QualifiedMove x y -> Model.Game.Game x y -> ShowS -{-# SPECIALISE showsMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove T.X T.Y -> Model.Game.Game T.X T.Y -> ShowS #-} +{-# SPECIALISE showsMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Model.Game.Game Type.Length.X Type.Length.Y -> ShowS #-} showsMove explicitEnPassant qualifiedMove game = showsTurn explicitEnPassant ( Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.ContextualNotation.StandardAlgebraic.showsMove:\tModel.Game.maybeLastTurn failed." @@ -273,7 +273,7 @@ -> Component.QualifiedMove.QualifiedMove x y -> Model.Game.Game x y -> String -{-# SPECIALISE showMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove T.X T.Y -> Model.Game.Game T.X T.Y -> String #-} +{-# SPECIALISE showMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Model.Game.Game Type.Length.X Type.Length.Y -> String #-} showMove explicitEnPassant qualifiedMove game = showsMove explicitEnPassant qualifiedMove game "" -- | Applies the specified /move/ to the specified /game/. @@ -285,7 +285,7 @@ Show x, Show y ) => StandardAlgebraic x y -> Model.Game.Transformation x y -{-# SPECIALISE movePiece :: StandardAlgebraic T.X T.Y -> Model.Game.Transformation T.X T.Y #-} +{-# SPECIALISE movePiece :: StandardAlgebraic Type.Length.X Type.Length.Y -> Model.Game.Transformation Type.Length.X Type.Length.Y #-} movePiece MkStandardAlgebraic { getQualifiedMove = qualifiedMove } = Model.Game.applyQualifiedMove qualifiedMove #ifdef USE_POLYPARSE @@ -332,7 +332,7 @@ -> Model.Game.Game x y #ifdef USE_POLYPARSE -> Text.Poly.TextParser (StandardAlgebraic x y) -{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game T.X T.Y -> Text.Poly.TextParser (StandardAlgebraic T.X T.Y) #-} +{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game Type.Length.X Type.Length.Y -> Text.Poly.TextParser (StandardAlgebraic Type.Length.X Type.Length.Y) #-} parser explicitEnPassant validateMoves game = let nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour @@ -483,7 +483,7 @@ else return {-to Parser-monad-} qualifiedMove #else /* Parsec */ -> Parsec.Parser (StandardAlgebraic x y) -{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game T.X T.Y -> Parsec.Parser (StandardAlgebraic T.X T.Y) #-} +{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game Type.Length.X Type.Length.Y -> Parsec.Parser (StandardAlgebraic Type.Length.X Type.Length.Y) #-} parser explicitEnPassant validateMoves game = let nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour diff --git a/src-lib/BishBosh/Data/Either.hs b/src-lib/BishBosh/Data/Either.hs --- a/src-lib/BishBosh/Data/Either.hs +++ b/src-lib/BishBosh/Data/Either.hs @@ -28,6 +28,7 @@ xpickle ) where +import Control.Arrow((|||)) import qualified Text.XML.HXT.Arrow.Pickle as HXT {- @@ -39,7 +40,7 @@ -- | Pickler for an arbitrary datum of type 'Either'. xpickle :: HXT.PU l -> HXT.PU r -> HXT.PU (Either l r) xpickle lPickler rPickler = HXT.xpAlt ( - const 0 `either` const 1 -- Index into the subsequent pickler-list. + const 0 ||| const 1 -- Index into the subsequent pickler-list. ) [ HXT.xpWrap ( Left, -- Construct. diff --git a/src-lib/BishBosh/Data/Exception.hs b/src-lib/BishBosh/Data/Exception.hs --- a/src-lib/BishBosh/Data/Exception.hs +++ b/src-lib/BishBosh/Data/Exception.hs @@ -55,6 +55,7 @@ isBadRequest ) where +import Control.Arrow((|||)) import qualified Control.Exception import qualified Data.Typeable @@ -86,10 +87,10 @@ instance Control.Exception.Exception Exception instance Show Exception where - showsPrec _ MkException { + showsPrec precedence MkException { getType = eitherBadDataOrBadRequest, getDetails = details - } = either shows shows eitherBadDataOrBadRequest . showString "; " . showString details + } = (showsPrec precedence ||| showsPrec precedence) eitherBadDataOrBadRequest . showString "; " . showString details -- | Constructor. mkDuplicateData :: String -> Exception diff --git a/src-lib/BishBosh/Data/Float.hs b/src-lib/BishBosh/Data/Float.hs deleted file mode 100644 --- a/src-lib/BishBosh/Data/Float.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- - Copyright (C) 2018 Dr. Alistair Ward - - This file is part of WeekDaze. - - WeekDaze 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. - - WeekDaze 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 WeekDaze. If not, see . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Defines a /pickler/ for 'Float' & 'Double'. --} - -module BishBosh.Data.Float() where - -import qualified Text.XML.HXT.Arrow.Pickle as HXT - -instance HXT.XmlPickler Float where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Double where - xpickle = HXT.xpPrim - diff --git a/src-lib/BishBosh/Data/Integral.hs b/src-lib/BishBosh/Data/Integral.hs --- a/src-lib/BishBosh/Data/Integral.hs +++ b/src-lib/BishBosh/Data/Integral.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -20,7 +19,7 @@ {- | [@AUTHOR@] Dr. Alistair Ward - [@DESCRIPTION@] Arbitrary operations for integral types. + [@DESCRIPTION@] Arbitrary operations for numeric types. -} module BishBosh.Data.Integral( @@ -29,31 +28,7 @@ ) where import qualified Data.Char -import qualified Data.Int import qualified Data.List -import qualified Data.Word -import qualified Text.XML.HXT.Arrow.Pickle as HXT - -instance HXT.XmlPickler Data.Int.Int8 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Int.Int16 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Int.Int32 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Word.Word8 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Word.Word16 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Word.Word32 where - xpickle = HXT.xpPrim - -instance HXT.XmlPickler Data.Word.Word where - xpickle = HXT.xpPrim {- | * N.B. much faster than the instance of 'Read' for the integral type. TODO: compare with 'Numeric.readDec'. diff --git a/src-lib/BishBosh/Data/Num.hs b/src-lib/BishBosh/Data/Num.hs --- a/src-lib/BishBosh/Data/Num.hs +++ b/src-lib/BishBosh/Data/Num.hs @@ -32,3 +32,4 @@ -- | Whether the specified number lies within the closed unit-interval, @[0,1]@; . inClosedUnitInterval :: (Num n, Ord n) => n -> Bool inClosedUnitInterval = uncurry (&&) . ((>= 0) &&& (<= 1)) + diff --git a/src-lib/BishBosh/Data/Time.hs b/src-lib/BishBosh/Data/Time.hs deleted file mode 100644 --- a/src-lib/BishBosh/Data/Time.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@] --} - -module BishBosh.Data.Time( --- * Functions - showsTimeAsSeconds, - measureElapsedTime - ) where - -import qualified Data.Time.Clock -import qualified Text.Printf - --- | Shows a time-difference as a number of seconds, to the required precision. -showsTimeAsSeconds :: Text.Printf.PrintfArg i => i -> Data.Time.Clock.NominalDiffTime -> ShowS -showsTimeAsSeconds nDecimalDigits time = showString $ Text.Printf.printf "%.*fs" nDecimalDigits (realToFrac time :: Double) - --- | Measure the time which has elapsed since that specified. -measureElapsedTime :: Data.Time.Clock.UTCTime -> IO Data.Time.Clock.NominalDiffTime -measureElapsedTime startUTCTime = (`Data.Time.Clock.diffUTCTime` startUTCTime) `fmap` Data.Time.Clock.getCurrentTime - 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 @@ -49,12 +49,8 @@ import Control.Applicative((<|>)) import Control.Arrow((&&&)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.CriterionValue as Attribute.CriterionValue -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.RankValues as Attribute.RankValues -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate @@ -65,35 +61,32 @@ import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Input.RankValues as Input.RankValues +import qualified BishBosh.Metric.CriterionValue as Metric.CriterionValue +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Monad.Reader import qualified Data.Array.IArray import qualified Data.List import qualified Data.Map.Strict import qualified Data.Maybe -#ifdef USE_PARALLEL -import qualified Control.DeepSeq -#endif - #ifdef USE_UNBOXED_ARRAYS import qualified Data.Array.Unboxed #endif -- | Construct a criterion-value from a piece-square value. -mkPieceSquareCriterionValue :: ( - Fractional criterionValue, - Ord criterionValue, - Real pieceSquareValue - ) => pieceSquareValue -> Attribute.CriterionValue.CriterionValue criterionValue -mkPieceSquareCriterionValue = Attribute.CriterionValue.mkCriterionValue . ( +mkPieceSquareCriterionValue :: Real pieceSquareValue => pieceSquareValue -> Metric.CriterionValue.CriterionValue +mkPieceSquareCriterionValue = fromRational . ( / fromIntegral Component.Piece.nPiecesPerSide - ) . realToFrac + ) . toRational -- | Measures the piece-square value from the perspective of the last player to move. measurePieceSquareValue :: ( @@ -109,7 +102,7 @@ => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue -> Model.Game.Game x y -> pieceSquareValue -{-# SPECIALISE measurePieceSquareValue :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank T.X T.Y T.PieceSquareValue -> Model.Game.Game T.X T.Y -> T.PieceSquareValue #-} +{-# SPECIALISE measurePieceSquareValue :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue -> Model.Game.Game Type.Length.X Type.Length.Y -> Type.Mass.PieceSquareValue #-} measurePieceSquareValue pieceSquareByCoordinatesByRank game | Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game = difference | otherwise = negate difference -- Represent the piece-square value from Black's perspective. @@ -138,7 +131,7 @@ -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue -> Model.Game.Game x y -> pieceSquareValue -{-# SPECIALISE measurePieceSquareValueIncrementally :: T.PieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank T.X T.Y T.PieceSquareValue -> Model.Game.Game T.X T.Y -> T.PieceSquareValue #-} +{-# SPECIALISE measurePieceSquareValueIncrementally :: Type.Mass.PieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue -> Model.Game.Game Type.Length.X Type.Length.Y -> Type.Mass.PieceSquareValue #-} measurePieceSquareValueIncrementally previousPieceSquareValue pieceSquareByCoordinatesByRank game | Attribute.MoveType.isQuiet $ Component.QualifiedMove.getMoveType qualifiedMove = let findPieceSquareValues coordinatesList = Component.PieceSquareByCoordinatesByRank.findPieceSquareValues ( @@ -158,26 +151,24 @@ qualifiedMove = Component.Turn.getQualifiedMove turn -- | Measure the arithmetic difference between the total /rank-value/ of the /piece/s currently held by either side; . -measureValueOfMaterial :: ( - Fractional criterionValue, - Fractional rankValue, - Ord criterionValue, - Real rankValue - ) - => Attribute.RankValues.RankValues rankValue +measureValueOfMaterial + :: Input.RankValues.RankValues + -> Type.Mass.RankValue -- ^ Maximum total rank-value. -> Model.Game.Game x y - -> Attribute.CriterionValue.CriterionValue criterionValue --- {-# SPECIALISE measureValueOfMaterial :: Attribute.RankValues.RankValues T.RankValue -> Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfMaterial rankValues game = Attribute.CriterionValue.mkCriterionValue . ( - / fromIntegral Component.Piece.nPiecesPerSide -- Normalise. - ) . realToFrac . ( + -> Metric.CriterionValue.CriterionValue +-- {-# SPECIALISE measureValueOfMaterial :: Input.RankValues.RankValues -> Type.Mass.RankValue -> Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfMaterial rankValues maximumTotalRankValue game = fromRational . ( + / toRational maximumTotalRankValue -- Normalise. + ) . ( if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game then id -- White just moved. else negate -- Black just moved. ) . Data.List.foldl' ( - \acc (rank, nPieces) -> if nPieces == 0 - then acc -- Avoid calling 'Attribute.RankValues.findRankValue'. - else acc + Attribute.RankValues.findRankValue rank rankValues * fromIntegral nPieces + \acc (rank, nPiecesDifference) -> if nPiecesDifference == 0 + then acc -- Avoid calling 'Input.RankValues.findRankValue'. + else acc + toRational ( + Input.RankValues.findRankValue rank rankValues + ) * fromIntegral nPiecesDifference ) 0 . Data.Array.IArray.assocs . State.Board.getNPiecesDifferenceByRank {-which arbitrarily counts White pieces as positive & Black as negative-} $ Model.Game.getBoard game {- | @@ -192,7 +183,7 @@ => getWeightOfMobility * 1 > weightOfMaterial * (8.8 / 102.47) => getWeightOfMobility > weightOfMaterial / 11.6 - The corollary is that one probably shouldn't sacrifice even a @Knight@ to temporarily reduce one's opponent mobility to one. + The corollary is that one probably shouldn't sacrifice even a @Knight@ to temporarily reduce one's opponent's mobility to one. measureValueOfMobility = 0.5 when mobility = 1, => getWeightOfMobility * 0.5 < weightOfMaterial * (3.2 / 102.47) => getWeightOfMobility < weightOfMaterial / 16.0 @@ -201,28 +192,23 @@ This presents a paradox ! -} measureValueOfMobility :: ( - Enum x, - Enum y, - Fractional criterionValue, - Ord criterionValue, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue -{-# SPECIALISE measureValueOfMobility :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfMobility game = Attribute.CriterionValue.mkCriterionValue . uncurry (-) . ( + Enum x, + Enum y, + Ord x, + Ord y, + Show x, + Show y + ) => Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +{-# SPECIALISE measureValueOfMobility :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfMobility game = fromRational . uncurry (-) . ( measureConstriction &&& measureConstriction . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where - measureConstriction logicalColour = recip . fromIntegral . succ {-avoid divide-by-zero-} $ Model.Game.countMovesAvailableTo logicalColour game + measureConstriction logicalColour = recip . fromIntegral {-NPlies-} . succ {-avoid divide-by-zero-} $ Model.Game.countPliesAvailableTo logicalColour game -- | Measure the arithmetic difference between the potential to /Castle/, on either side. -measureValueOfCastlingPotential :: ( - Fractional criterionValue, - Ord criterionValue - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue --- {-# SPECIALISE measureValueOfCastlingPotential :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfCastlingPotential game = Attribute.CriterionValue.mkCriterionValue . uncurry (-) . ( +measureValueOfCastlingPotential :: Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +-- {-# SPECIALISE measureValueOfCastlingPotential :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfCastlingPotential game = fromRational . uncurry (-) . ( castlingPotential . Property.Opposable.getOpposite {-recent mover-} &&& castlingPotential ) $ Model.Game.getNextLogicalColour game where castlingPotential = Data.Maybe.maybe 1 {-have Castled-} ( @@ -238,18 +224,15 @@ * CAVEAT: this is a negative attribute, so the weighted normalised value shouldn't exceed the reduction due to 'measureValueOfMaterial' resulting from a @Pawn@-sacrifice. -} -measureValueOfDoubledPawns :: ( - Fractional criterionValue, - Ord criterionValue - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue --- {-# SPECIALISE measureValueOfDoubledPawns :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfDoubledPawns game = Attribute.CriterionValue.mkCriterionValue . ( +measureValueOfDoubledPawns :: Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +-- {-# SPECIALISE measureValueOfDoubledPawns :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfDoubledPawns game = fromRational . ( / 6 -- Normalise to [-1 .. 1]; the optimal scenario is all files containing one Pawn; the worst scenario is two files each containing four Pawns, all but one per file of which are counted as doubled. - ) . fromIntegral . uncurry (-) . ( + ) . fromIntegral {-NPieces-} . uncurry (-) . ( countDoubledPawns &&& countDoubledPawns . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where countDoubledPawns logicalColour = uncurry (-) . ( - Data.Map.Strict.foldl' (+) 0 &&& Data.Map.Strict.size {-one Pawn can't be considered to be doubled, so substract one Pawn per column-} + Data.Map.Strict.foldl' (+) 0 &&& fromIntegral . Data.Map.Strict.size {-one Pawn can't be considered to be doubled, so substract one Pawn per column-} ) $ State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour {- | @@ -257,19 +240,14 @@ * CAVEAT: this is a negative attribute, so the weighted normalised value shouldn't exceed the reduction due to 'measureValueOfMaterial' resulting from a @Pawn@-sacrifice. -} -measureValueOfIsolatedPawns :: ( - Enum x, - Fractional criterionValue, - Ord criterionValue, - Ord x - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue -{-# SPECIALISE measureValueOfIsolatedPawns :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfIsolatedPawns game = Attribute.CriterionValue.mkCriterionValue . ( - / fromIntegral Cartesian.Abscissa.xLength -- Normalise to [-1 .. 1]; the optimal scenario is eight files each containing one Pawn & the worst scenario is all Pawns isolated (e.g. 4 alternate files of 2, 2 separate files or 4, ...). - ) . fromIntegral . uncurry (-) . ( +measureValueOfIsolatedPawns :: (Enum x, Ord x) => Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +{-# SPECIALISE measureValueOfIsolatedPawns :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfIsolatedPawns game = fromRational . ( + / fromIntegral {-Int-} Cartesian.Abscissa.xLength -- Normalise to [-1 .. 1]; the optimal scenario is eight files each containing one Pawn & the worst scenario is all Pawns isolated (e.g. 4 alternate files of 2, 2 separate files or 4, ...). + ) . fromIntegral {-NPieces-} . uncurry (-) . ( countIsolatedPawns &&& countIsolatedPawns . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where - countIsolatedPawns :: Attribute.LogicalColour.LogicalColour -> Component.Piece.NPieces + countIsolatedPawns :: Attribute.LogicalColour.LogicalColour -> Type.Count.NPieces countIsolatedPawns logicalColour = Data.Map.Strict.foldlWithKey' ( \acc x nPawns -> ( if (`Data.Map.Strict.member` nPawnsByFile) `any` Cartesian.Abscissa.getAdjacents x @@ -280,22 +258,17 @@ nPawnsByFile = State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour -- | Measure the arithmetic difference between the number of /passed/ @Pawn@s on either side; . -measureValueOfPassedPawns :: forall x y criterionValue. ( - Enum y, - Fractional criterionValue, - Ord criterionValue - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue -{-# SPECIALISE measureValueOfPassedPawns :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfPassedPawns game = Attribute.CriterionValue.mkCriterionValue . ( - / fromIntegral Cartesian.Abscissa.xLength -- Normalise to [-1 .. 1]. +measureValueOfPassedPawns :: forall x y. Enum y => Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +{-# SPECIALISE measureValueOfPassedPawns :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfPassedPawns game = fromRational . ( + / fromIntegral {-Int-} Cartesian.Abscissa.xLength -- Normalise to [-1 .. 1]. ) . uncurry (-) . ( valuePassedPawns . Property.Opposable.getOpposite {-recent mover-} &&& valuePassedPawns ) $ Model.Game.getNextLogicalColour game where - valuePassedPawns :: Attribute.LogicalColour.LogicalColour -> criterionValue valuePassedPawns logicalColour = Data.List.foldl' ( - \acc -> (acc +) . recip {-value increases exponentially as distance to promotion decreases-} . fromIntegral . abs . subtract ( + \acc -> (acc +) . recip {-value increases exponentially as distance to promotion decreases-} . fromIntegral {-Int-} . abs . subtract ( fromEnum ( - Cartesian.Ordinate.lastRank logicalColour :: y + Cartesian.Ordinate.lastRank logicalColour :: y -- N.B.: ScopedTypeVariables. ) ) . fromEnum . Cartesian.Coordinates.getY -- Measure the distance to promotion. ) 0 $ State.Board.getPassedPawnCoordinatesByLogicalColour (Model.Game.getBoard game) ! logicalColour @@ -303,16 +276,18 @@ {- | * The constant maximum total number of times the /piece/s of either side, can be defended. - * This calculation assumes that: + * Assumes all Pawns have been Queened. - ** every /piece/ can defend another in every /direction/ it can attack, - which is impossible, since in a 2-D board one can always draw a perimeter around the /piece/s, - beyond which there're zero /pieces/ to defend, so the outer /piece/s can never be fully utilised; + * CAVEAT: assuming the optimal arrangement of pieces: - ** all @Pawn@s have been /queened/, which is unrealistic. + RQQB = 3 + 7 + 3 + 2 = 15 + QQQN = 4 + 6 + 8 + 4 = 22 + NQQK = 4 + 8 + 6 + 0 = 18 + BQQR = 2 + 3 + 7 + 3 = 15 + = 70 -} -maximumDefended :: Component.Piece.NPieces -maximumDefended = (9 {-Queens-} + 1 {-King-} + 2 {-Knights-} + 2 {-Rooks + Bishops-}) * Attribute.Direction.nDistinctDirections +maximumDefended :: Type.Count.NPieces +maximumDefended = 70 {- | * Measure the normalised arithmetic difference between the number of /piece/s defending each of one's own, on either side. @@ -326,14 +301,11 @@ * CAVEAT: this criterion competes with /mobility/, since each defended /piece/ blocks the path of the defender. -} -measureValueOfDefence :: ( - Fractional criterionValue, - Ord criterionValue - ) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue --- {-# SPECIALISE measureValueOfDefence :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-} -measureValueOfDefence game = Attribute.CriterionValue.mkCriterionValue . ( - / fromIntegral maximumDefended -- Normalise. - ) . fromIntegral . uncurry (-) . ( +measureValueOfDefence :: Model.Game.Game x y -> Metric.CriterionValue.CriterionValue +-- {-# SPECIALISE measureValueOfDefence :: Model.Game.Game Type.Length.X Type.Length.Y -> Metric.CriterionValue.CriterionValue #-} +measureValueOfDefence game = fromRational . ( + / fromIntegral {-NPieces-} maximumDefended -- Normalise. + ) . fromIntegral {-NPieces-} . uncurry (-) . ( (! Property.Opposable.getOpposite {-recent mover-} nextLogicalColour) &&& (! nextLogicalColour) ) . State.Board.summariseNDefendersByLogicalColour $ Model.Game.getBoard game where nextLogicalColour = Model.Game.getNextLogicalColour game @@ -350,50 +322,39 @@ * Many possible criteria aren't measured because they're, either currently or imminently, represented by those that are, typically by 'measureValueOfMaterial'. -} evaluateFitness :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif #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 Enum x, Enum y, - Fractional criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Ord x, Ord y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y ) => Maybe pieceSquareValue -- ^ An optional value for the specified game. -> Model.Game.Game x y - -> Input.EvaluationOptions.Reader criterionWeight pieceSquareValue rankValue x y ( - Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue - ) -{-# SPECIALISE evaluateFitness :: Maybe T.PieceSquareValue -> Model.Game.Game T.X T.Y -> Input.EvaluationOptions.Reader T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y (Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues T.WeightedMean T.CriterionValue) #-} + -> Input.EvaluationOptions.Reader pieceSquareValue x y Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues +{-# SPECIALISE evaluateFitness :: Maybe Type.Mass.PieceSquareValue -> Model.Game.Game Type.Length.X Type.Length.Y -> Input.EvaluationOptions.Reader Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues #-} evaluateFitness maybePieceSquareValue game - | Just gameTerminationReason <- Model.Game.getMaybeTerminationReason game = return {-to Reader-monad-} $ Attribute.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues ( - if Model.GameTerminationReason.isCheckMate gameTerminationReason + | 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. ) [] | otherwise = do criteriaWeights <- Control.Monad.Reader.asks Input.EvaluationOptions.getCriteriaWeights - rankValues <- Control.Monad.Reader.asks Input.EvaluationOptions.getRankValues + 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 ( - measureValueOfMaterial rankValues game + uncurry measureValueOfMaterial rankValuePair game ) ( measureValueOfMobility game ) ( - Data.Maybe.maybe Attribute.CriterionValue.zero mkPieceSquareCriterionValue $ maybePieceSquareValue <|> fmap ( + Data.Maybe.maybe 0 mkPieceSquareCriterionValue $ maybePieceSquareValue <|> fmap ( `measurePieceSquareValue` game ) maybePieceSquareByCoordinatesByRank ) ( 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 @@ -66,22 +66,24 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues -import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove -import qualified BishBosh.Component.Turn as Component.Turn -import qualified BishBosh.Component.Zobrist as Component.Zobrist -import qualified BishBosh.Data.RoseTree as Data.RoseTree -import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness -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.Model.GameTree as Model.GameTree -import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation -import qualified BishBosh.Property.Arboreal as Property.Arboreal -import qualified BishBosh.Property.Null as Property.Null -import qualified BishBosh.Types as T +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Component.Zobrist as Component.Zobrist +import qualified BishBosh.Data.RoseTree as Data.RoseTree +import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness +import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Input.RankValues as Input.RankValues +import qualified BishBosh.Input.SearchOptions as Input.SearchOptions +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Model.GameTree as Model.GameTree +import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.Arboreal as Property.Arboreal +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.Monad.Reader import qualified Data.Array.IArray @@ -89,56 +91,48 @@ import qualified Data.Maybe import qualified Data.Tree -#ifdef USE_PARALLEL -import qualified Control.DeepSeq -#endif - #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 x y positionHash criterionValue weightedMean = MkNodeLabel { +data NodeLabel x y positionHash = MkNodeLabel { getPositionHash :: positionHash, -- ^ The hash of the /game/ contained in 'getQuantifiedGame'. - getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean + getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y } deriving (Eq, Show) -instance (Enum x, Enum y, Real weightedMean) => Notation.MoveNotation.ShowNotationFloat (NodeLabel x y positionHash criterionValue weightedMean) where +instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (NodeLabel x y positionHash) where showsNotationFloat moveNotation showsDouble MkNodeLabel { getQuantifiedGame = quantifiedGame } = Notation.MoveNotation.showsNotation moveNotation ( Evaluation.QuantifiedGame.getLastTurn quantifiedGame ) . showString "\t=> " . showsDouble ( - realToFrac . Attribute.WeightedMeanAndCriterionValues.getWeightedMean $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame + realToFrac . Metric.WeightedMeanAndCriterionValues.getWeightedMean $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) -instance Property.Null.Null (NodeLabel x y positionHash criterionValue weightedMean) where +instance Property.Null.Null (NodeLabel x y positionHash) where isNull MkNodeLabel { getQuantifiedGame = quantifiedGame } = Property.Null.isNull quantifiedGame -- | Whether the last qualifiedMove of the /game/ in a node, matches a specified /QualifiedMove/. -equalsLastQualifiedMove :: (Eq x, Eq y) => Component.QualifiedMove.QualifiedMove x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean) +equalsLastQualifiedMove :: (Eq x, Eq y) => Component.QualifiedMove.QualifiedMove x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash) equalsLastQualifiedMove qualifiedMove MkNodeLabel { getQuantifiedGame = quantifiedGame } = (== qualifiedMove) . Component.Turn.getQualifiedMove $ Evaluation.QuantifiedGame.getLastTurn quantifiedGame -- | The tree resulting from each possible move-choice applied to a /game/, including a position-hash & an evaluation of the resulting fitness. -type BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean = Data.Tree.Tree (NodeLabel x y positionHash criterionValue weightedMean) +type BarePositionHashQuantifiedGameTree x y positionHash = Data.Tree.Tree (NodeLabel x y positionHash) -- | Accessor. -getRootQuantifiedGame' :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean +getRootQuantifiedGame' :: BarePositionHashQuantifiedGameTree x y positionHash -> Evaluation.QuantifiedGame.QuantifiedGame x y getRootQuantifiedGame' Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame } } = quantifiedGame -- | Wrap the bare tree. -newtype PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean = MkPositionHashQuantifiedGameTree { - deconstruct :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean +newtype PositionHashQuantifiedGameTree x y positionHash = MkPositionHashQuantifiedGameTree { + deconstruct :: BarePositionHashQuantifiedGameTree x y positionHash } deriving Eq -instance Property.Arboreal.Prunable (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean) where +instance Property.Arboreal.Prunable (PositionHashQuantifiedGameTree x y positionHash) where prune depth MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree $ Property.Arboreal.prune depth barePositionHashQuantifiedGameTree -instance ( - Enum x, - Enum y, - Real weightedMean - ) => Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean) where +instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree x y positionHash) where showsNotationFloat moveNotation showsDouble MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = showString $ ( if Property.Null.isNull . Data.Tree.rootLabel $ barePositionHashQuantifiedGameTree then Data.RoseTree.drawForest toString . Data.Tree.subForest @@ -147,45 +141,36 @@ toString nodeLabel = Notation.MoveNotation.showsNotationFloat moveNotation showsDouble nodeLabel "" -- | Constructor. -fromBarePositionHashQuantifiedGameTree :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean +fromBarePositionHashQuantifiedGameTree :: BarePositionHashQuantifiedGameTree x y positionHash -> PositionHashQuantifiedGameTree x y positionHash fromBarePositionHashQuantifiedGameTree = MkPositionHashQuantifiedGameTree -- | Constructor. mkPositionHashQuantifiedGameTree :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif Data.Array.IArray.Ix x, #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 criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Integral x, Integral y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y ) - => Input.EvaluationOptions.EvaluationOptions criterionWeight pieceSquareValue rankValue x y + => Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y -> Input.SearchOptions.SearchOptions -> Component.Zobrist.Zobrist x y positionHash -> Model.GameTree.MoveFrequency x y -> Model.Game.Game x y -- ^ The current state of the /game/. - -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + -> PositionHashQuantifiedGameTree x y positionHash {-# SPECIALISE mkPositionHashQuantifiedGameTree - :: Input.EvaluationOptions.EvaluationOptions T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y + :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y -> Input.SearchOptions.SearchOptions - -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash - -> Model.GameTree.MoveFrequency T.X T.Y - -> Model.Game.Game T.X T.Y - -> PositionHashQuantifiedGameTree T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean + -> Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash + -> Model.GameTree.MoveFrequency Type.Length.X Type.Length.Y + -> Model.Game.Game Type.Length.X Type.Length.Y + -> PositionHashQuantifiedGameTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} mkPositionHashQuantifiedGameTree evaluationOptions searchOptions zobrist moveFrequency seedGame = MkPositionHashQuantifiedGameTree ( if Input.EvaluationOptions.getIncrementalEvaluation evaluationOptions @@ -237,11 +222,11 @@ bareGameTree = Model.GameTree.deconstruct . Model.GameTree.sortGameTree ( Input.SearchOptions.getMaybeCaptureMoveSortAlgorithm searchOptions ) ( - `Attribute.RankValues.findRankValue` Input.EvaluationOptions.getRankValues evaluationOptions + `Input.RankValues.findRankValue` Input.EvaluationOptions.getRankValues evaluationOptions ) moveFrequency $ Model.GameTree.fromGame seedGame -- | Accessor. -getRootPositionHash :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> positionHash +getRootPositionHash :: PositionHashQuantifiedGameTree x y positionHash -> positionHash getRootPositionHash MkPositionHashQuantifiedGameTree { deconstruct = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash } @@ -249,7 +234,7 @@ } = positionHash -- | Accessor. -getRootQuantifiedGame :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean +getRootQuantifiedGame :: PositionHashQuantifiedGameTree x y positionHash -> Evaluation.QuantifiedGame.QuantifiedGame x y getRootQuantifiedGame MkPositionHashQuantifiedGameTree { deconstruct = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame } @@ -258,29 +243,29 @@ -- | Forward request. reduce - :: Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean) - -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean - -> Maybe (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean) + :: Data.RoseTree.IsMatch (NodeLabel x y positionHash) + -> PositionHashQuantifiedGameTree x y positionHash + -> Maybe (PositionHashQuantifiedGameTree x y positionHash) reduce isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree `fmap` Data.RoseTree.reduce isMatch barePositionHashQuantifiedGameTree -- | Forward request. traceRoute - :: (Component.Turn.Turn x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean)) - -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + :: (Component.Turn.Turn x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash)) + -> PositionHashQuantifiedGameTree x y positionHash -> [Component.Turn.Turn x y] - -> Maybe [NodeLabel x y positionHash criterionValue weightedMean] + -> Maybe [NodeLabel x y positionHash] traceRoute isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute isMatch barePositionHashQuantifiedGameTree -- | Follow the specified move-sequence down the /positionHashQuantifiedGameTree/. traceMatchingMoves :: (Eq x, Eq y) - => PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + => PositionHashQuantifiedGameTree x y positionHash -> [Component.QualifiedMove.QualifiedMove x y] - -> Maybe [NodeLabel x y positionHash criterionValue weightedMean] -- ^ Returns 'Nothing', on failure to match a move. + -> Maybe [NodeLabel x y positionHash] -- ^ Returns 'Nothing', on failure to match a move. traceMatchingMoves MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute equalsLastQualifiedMove barePositionHashQuantifiedGameTree -- | Amend the apex-game to reflect the resignation of the next player. -resign :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean +resign :: PositionHashQuantifiedGameTree x y positionHash -> PositionHashQuantifiedGameTree x y positionHash resign MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree@Data.Tree.Node { Data.Tree.rootLabel = nodeLabel@MkNodeLabel { getQuantifiedGame = quantifiedGame } @@ -292,7 +277,7 @@ } -- | Self-documentation. -type Forest x y positionHash criterionValue weightedMean = [BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean] +type Forest x y positionHash = [BarePositionHashQuantifiedGameTree x y positionHash] {- | * Promotes the first matching /move/ to the head of the forest, then descends & recursively promotes the next matching move in the sub-forest. @@ -301,9 +286,9 @@ -} promoteMatchingMoves :: (Eq x, Eq y) - => [Component.QualifiedMove.QualifiedMove x y] -- ^ The list of qualifiedMoves, which should be promoted at successively deeper levels in the tree. - -> Forest x y positionHash criterionValue weightedMean - -> Maybe (Forest x y positionHash criterionValue weightedMean) -- ^ Returns 'Nothing' on failure to match a move. + => [Component.QualifiedMove.QualifiedMove x y] -- ^ The list of qualifiedMoves, which should be promoted at successively deeper levels in the tree. + -> Forest x y positionHash + -> Maybe (Forest x y positionHash) -- ^ Returns 'Nothing' on failure to match a move. promoteMatchingMoves = Data.RoseTree.promote equalsLastQualifiedMove {- | @@ -312,9 +297,9 @@ * N.B.: this can be used to dynamically re-order the forest using the killer heuristic. -} sortNonCaptureMoves - :: (Forest x y positionHash criterionValue weightedMean -> Forest x y positionHash criterionValue weightedMean) - -> Forest x y positionHash criterionValue weightedMean - -> Forest x y positionHash criterionValue weightedMean + :: (Forest x y positionHash -> Forest x y positionHash) + -> Forest x y positionHash + -> Forest x y positionHash sortNonCaptureMoves sortForest = uncurry (++) . Control.Arrow.second sortForest . span ( Component.Turn.isCapture . Evaluation.QuantifiedGame.getLastTurn . getRootQuantifiedGame' -- Shield any capture-moves, which were previously advanced by static sorting, from the sort. ) 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 @@ -54,17 +54,19 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Component.Turn as Component.Turn -import qualified BishBosh.Data.Exception as Data.Exception -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.Notation.MoveNotation as Notation.MoveNotation -import qualified BishBosh.Property.Null as Property.Null -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.Null as Property.Null +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.Type.Mass as Type.Mass import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Maybe @@ -75,80 +77,67 @@ #endif -- | The selected /game/ & the criteria against which it was quantified. -data QuantifiedGame x y criterionValue weightedMean = MkQuantifiedGame { +data QuantifiedGame x y = MkQuantifiedGame { getGame :: Model.Game.Game x y, -- ^ The /game/ resulting from a sequence of /turn/s. - getWeightedMeanAndCriterionValues :: Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue + getWeightedMeanAndCriterionValues :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues } deriving (Eq, Show) -instance Control.DeepSeq.NFData weightedMean => Control.DeepSeq.NFData (QuantifiedGame x y criterionValue weightedMean) where +instance Control.DeepSeq.NFData (QuantifiedGame x y) where rnf MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Control.DeepSeq.rnf weightedMeanAndCriterionValues -- The other field is a prerequisite. -instance (Enum x, Enum y, Real criterionValue, Real weightedMean) => Notation.MoveNotation.ShowNotationFloat (QuantifiedGame x y criterionValue weightedMean) where +instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (QuantifiedGame x y) where showsNotationFloat moveNotation showsDouble quantifiedGame = Text.ShowList.showsAssociationList Text.ShowList.showsSeparator $ map ($ quantifiedGame) [ (,) Component.Move.tag . Notation.MoveNotation.showsNotation moveNotation . getLastTurn, - (,) Attribute.WeightedMeanAndCriterionValues.weightedMeanTag . showsDouble . realToFrac . getFitness, - (,) Attribute.WeightedMeanAndCriterionValues.criterionValuesTag . Text.ShowList.showsFormattedList' (showsDouble . realToFrac) . Attribute.WeightedMeanAndCriterionValues.getCriterionValues . getWeightedMeanAndCriterionValues + (,) Metric.WeightedMeanAndCriterionValues.weightedMeanTag . showsDouble . realToFrac . getFitness, + (,) Metric.WeightedMeanAndCriterionValues.criterionValuesTag . Text.ShowList.showsFormattedList' (showsDouble . realToFrac) . Metric.WeightedMeanAndCriterionValues.getCriterionValues . getWeightedMeanAndCriterionValues ] -instance Property.Null.Null (QuantifiedGame x y criterionValue weightedMean) where +instance Property.Null.Null (QuantifiedGame x y) where isNull MkQuantifiedGame { getGame = game } = Property.Null.isNull game -- | Accessor. -getFitness :: QuantifiedGame x y criterionValue weightedMean -> weightedMean -getFitness MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Attribute.WeightedMeanAndCriterionValues.getWeightedMean weightedMeanAndCriterionValues +getFitness :: QuantifiedGame x y -> Type.Mass.WeightedMean +getFitness MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Metric.WeightedMeanAndCriterionValues.getWeightedMean weightedMeanAndCriterionValues --- | Like 'fromGame' except that the caller determines the piece-square value. +-- | Constructor. fromGame :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif #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 Enum x, Enum y, - Fractional criterionValue, Fractional pieceSquareValue, - Fractional rankValue, - Fractional weightedMean, Ord x, Ord y, - Real criterionValue, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show x, Show y ) => Maybe pieceSquareValue -- ^ The value for the specified game. -> Model.Game.Game x y -- ^ The current state of the /game/. - -> Input.EvaluationOptions.Reader criterionWeight pieceSquareValue rankValue x y (QuantifiedGame x y criterionValue weightedMean) -{-# SPECIALISE fromGame :: Maybe T.PieceSquareValue -> Model.Game.Game T.X T.Y -> Input.EvaluationOptions.Reader T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y (QuantifiedGame T.X T.Y T.CriterionValue T.WeightedMean) #-} + -> Input.EvaluationOptions.Reader pieceSquareValue x y (QuantifiedGame x y) +{-# SPECIALISE fromGame :: Maybe Type.Mass.PieceSquareValue -> Model.Game.Game Type.Length.X Type.Length.Y -> Input.EvaluationOptions.Reader Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y (QuantifiedGame Type.Length.X Type.Length.Y) #-} fromGame maybePieceSquareValue game = MkQuantifiedGame game `fmap` Evaluation.Fitness.evaluateFitness maybePieceSquareValue game -- | Retrieve the /turn/ used to generate the selected /game/. -getLastTurn :: QuantifiedGame x y criterionValue weightedMean -> Component.Turn.Turn x y +getLastTurn :: QuantifiedGame x y -> Component.Turn.Turn x y getLastTurn MkQuantifiedGame { getGame = game } = Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Evaluation.QuantifiedGame.getLastTurn:\tzero turns have been made." ) $ Model.Game.maybeLastTurn game --- | Drop the specified number of old turns from the start of the chronological sequence, leaving the most recent. +-- | Drop the specified number of plies from the start of the chronological sequence, leaving the most recent. getLatestTurns - :: Component.Move.NPlies - -> QuantifiedGame x y criterionValue weightedMean + :: Type.Count.NPlies -- ^ The number of plies to drop from the start of the chronological sequence. + -> QuantifiedGame x y -> [Component.Turn.Turn x y] -getLatestTurns nPlies MkQuantifiedGame { getGame = game } = drop nPlies $ Model.Game.listTurnsChronologically game +getLatestTurns nPlies MkQuantifiedGame { getGame = game } = fromIntegral nPlies `drop` Model.Game.listTurnsChronologically game -- | Represent the /fitness/ of the /game/ resulting from a future /move/ by the opponent, from the perspective of the current player. -negateFitness :: Num weightedMean => QuantifiedGame x y criterionValue weightedMean -> QuantifiedGame x y criterionValue weightedMean -negateFitness quantifiedGame@MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = quantifiedGame { getWeightedMeanAndCriterionValues = Attribute.WeightedMeanAndCriterionValues.negateWeightedMean weightedMeanAndCriterionValues } +negateFitness :: QuantifiedGame x y -> QuantifiedGame x y +negateFitness quantifiedGame@MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = quantifiedGame { getWeightedMeanAndCriterionValues = Metric.WeightedMeanAndCriterionValues.negateWeightedMean weightedMeanAndCriterionValues } -- | Compares fitness. -compareFitness - :: Ord weightedMean - => QuantifiedGame x y criterionValue weightedMean - -> QuantifiedGame x y criterionValue weightedMean - -> Ordering +compareFitness :: QuantifiedGame x y -> QuantifiedGame x y -> Ordering compareFitness = Data.Ord.comparing getFitness {- | @@ -156,12 +145,13 @@ * N.B.: 'Nothing' is interpreted as unbounded. -} -type OpenInterval x y criterionValue weightedMean = (Maybe (QuantifiedGame x y criterionValue weightedMean), Maybe (QuantifiedGame x y criterionValue weightedMean)) +type OpenInterval x y = (Maybe (QuantifiedGame x y), Maybe (QuantifiedGame x y)) -- | Constant. -unboundedInterval :: OpenInterval x y criterionValue weightedMean +unboundedInterval :: OpenInterval x y unboundedInterval = (Nothing, Nothing) -- | Reflect the interval about zero. -negateInterval :: Num weightedMean => OpenInterval x y criterionValue weightedMean -> OpenInterval x y criterionValue weightedMean +negateInterval :: OpenInterval x y -> OpenInterval x y negateInterval (maybeAlpha, maybeBeta) = ($ maybeBeta) &&& ($ maybeAlpha) $ fmap negateFitness + diff --git a/src-lib/BishBosh/Input/CECPFeatures.hs b/src-lib/BishBosh/Input/CECPFeatures.hs --- a/src-lib/BishBosh/Input/CECPFeatures.hs +++ b/src-lib/BishBosh/Input/CECPFeatures.hs @@ -81,8 +81,9 @@ ) where import BishBosh.Data.Bool() -- For 'HXT.XmlPickler Bool'. -import qualified BishBosh.Data.Foldable as Data.Foldable +import Control.Arrow((|||)) import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Foldable as Data.Foldable import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.DeepSeq import qualified Control.Exception @@ -329,7 +330,7 @@ \s -> case reads s of [(i, "")] -> Left i _ -> Right s, - \value -> showChar '"' $ either shows showString value "\"" + \value -> showChar '"' $ (shows ||| showString) value "\"" ) ( HXT.xpAttr "value" HXT.xpText0 ) @@ -338,17 +339,15 @@ ) where def = Data.Default.def --- | Smart-constructor. +-- | Smart constructor. mkCECPFeatures :: [Feature] -> Bool -> CECPFeatures mkCECPFeatures features done | Just (key, _) <- Data.List.find ( not . all Data.Char.isAlpha . fst {-key-} ) features = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.CECPFeatures.mkCECPFeatures:\tinvalid key" . Text.ShowList.showsAssociation $ shows key "." | Just (_, value) <- Data.List.find ( - either ( - const False - ) ( - any (`elem` "\"\n\r") -- Prevent command-injection. + ( + const False ||| any (`elem` "\"\n\r") {-Prevent command-injection-} ) . snd {-value-} ) features = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.CECPFeatures.mkCECPFeatures:\tinvalid value" . Text.ShowList.showsAssociation $ shows value "." | not $ null duplicateFeatures = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.CECPFeatures.mkCECPFeatures:\tduplicate features " $ shows duplicateFeatures "." @@ -380,11 +379,9 @@ getFeatures = features } = cecpFeatures { getFeatures = filter ( - either ( - const $ (/= key) . fst - ) ( - const (/= feature) -- N.B.: string-valued features must also match the specified value, to account for possibility of duplicates. - ) value + const ( + (/= key) . fst + ) ||| const (/= feature) {-N.B.: string-valued features must also match the specified value, to account for possibility of duplicates-} $ value ) features } @@ -403,6 +400,6 @@ } = Data.Maybe.maybe ( Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Input.CECPFeatures.isFeatureDisabled:\t" $ shows key " not found." ) ( - (== 0) `either` null + (== 0) ||| null ) $ lookup key features diff --git a/src-lib/BishBosh/Input/CECPOptions.hs b/src-lib/BishBosh/Input/CECPOptions.hs --- a/src-lib/BishBosh/Input/CECPOptions.hs +++ b/src-lib/BishBosh/Input/CECPOptions.hs @@ -62,17 +62,20 @@ setProtocolVersion, updateFeature, deleteFeature, - resetModes + resetModes, + pause, + resume ) where import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.CECPFeatures as Input.CECPFeatures +import qualified BishBosh.Property.Switchable as Property.Switchable import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Time.StopWatch as Time.StopWatch import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Default import qualified Data.Maybe -import qualified Data.Time.Clock import qualified Text.XML.HXT.Arrow.Pickle as HXT -- | Used to qualify XML. @@ -119,14 +122,14 @@ -- | Defines options related to CECP. data CECPOptions = MkCECPOptions { - getAnalyseMode :: Mode, -- ^ TODO. - getDisplaySAN :: Bool, -- ^ Whether to display moves in SAN or 'Input.UIOptions.getMoveNotation'. - getEditMode :: Mode, -- ^ Whether the game should be placed in set-up mode. - getForceMode :: Mode, -- ^ Neither player's moves are automated, allowing an arbitrary game to be configured. - getMaybePaused :: Maybe Data.Time.Clock.NominalDiffTime, -- ^ Whether the engine was paused after the specified time. - getPonderMode :: Mode, -- ^ Whether to keep thinking while it's one's opponent's turn. - getPostMode :: Mode, -- ^ Whether to show the details of deliberations. - getProtocolVersion :: ProtocolVersion, -- ^ The version of the CECP-protocol to use. + getAnalyseMode :: Mode, -- ^ TODO. + getDisplaySAN :: Bool, -- ^ Whether to display moves in SAN or 'Input.UIOptions.getMoveNotation'. + getEditMode :: Mode, -- ^ Whether the game should be placed in set-up mode. + getForceMode :: Mode, -- ^ Neither player's moves are automated, allowing an arbitrary game to be configured. + getMaybePaused :: Maybe Time.StopWatch.StopWatch, -- ^ Whether the engine was paused & a paused watch. + getPonderMode :: Mode, -- ^ Whether to keep thinking while it's one's opponent's turn. + getPostMode :: Mode, -- ^ Whether to show the details of deliberations. + getProtocolVersion :: ProtocolVersion, -- ^ The version of the CECP-protocol to use. getCECPFeatures :: Input.CECPFeatures.CECPFeatures } deriving Eq @@ -200,19 +203,18 @@ instance HXT.XmlPickler CECPOptions where xpickle = HXT.xpElem tag . HXT.xpWrap ( - \(a, b, c, d, e, f, g, h, i) -> mkCECPOptions a b c d e f g h i, -- Construct. + \(a, b, c, d, e, f, g, h) -> mkCECPOptions a b c d (getMaybePaused def) e f g h, -- Construct. \MkCECPOptions { getAnalyseMode = analyseMode, getDisplaySAN = displaySAN, getEditMode = editMode, getForceMode = forceMode, - getMaybePaused = maybePaused, getPonderMode = ponderMode, getPostMode = postMode, getProtocolVersion = protocolVersion, getCECPFeatures = cecpFeatures - } -> (analyseMode, displaySAN, editMode, forceMode, maybePaused, ponderMode, postMode, protocolVersion, cecpFeatures) -- Deconstruct. - ) $ HXT.xp9Tuple ( + } -> (analyseMode, displaySAN, editMode, forceMode, ponderMode, postMode, protocolVersion, cecpFeatures) -- Deconstruct. + ) $ HXT.xp8Tuple ( getAnalyseMode def `HXT.xpDefault` HXT.xpAttr analyseModeTag HXT.xpickle ) ( getDisplaySAN def `HXT.xpDefault` HXT.xpAttr displaySANTag HXT.xpickle @@ -221,8 +223,6 @@ ) ( getForceMode def `HXT.xpDefault` HXT.xpAttr forceModeTag HXT.xpickle ) ( - HXT.xpOption . HXT.xpWrap (toEnum, fromEnum) $ HXT.xpAttr pausedTag HXT.xpInt - ) ( getPonderMode def `HXT.xpDefault` HXT.xpAttr ponderModeTag HXT.xpickle ) ( getPostMode def `HXT.xpDefault` HXT.xpAttr postModeTag HXT.xpickle @@ -233,23 +233,22 @@ -- | Smart constructor. mkCECPOptions - :: Mode -- ^ Analyse-mode. - -> Bool -- ^ Display SAN. - -> Mode -- ^ Edit-mode. - -> Mode -- ^ Force-mode. - -> Maybe Data.Time.Clock.NominalDiffTime -- ^ Paused. - -> Mode -- ^ Ponder-mode. - -> Mode -- ^ Post-mode. + :: Mode -- ^ Analyse-mode. + -> Bool -- ^ Display SAN. + -> Mode -- ^ Edit-mode. + -> Mode -- ^ Force-mode. + -> Maybe Time.StopWatch.StopWatch -- ^ Paused. + -> Mode -- ^ Ponder-mode. + -> Mode -- ^ Post-mode. -> ProtocolVersion -> Input.CECPFeatures.CECPFeatures -> CECPOptions mkCECPOptions analyseMode displaySAN editMode forceMode maybePaused ponderMode postMode protocolVersion cecpFeatures - | protocolVersion < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.UI.CECPOptions.mkCECPOptions:\t" $ shows protocolVersionTag " must exceed zero." - | Data.Maybe.maybe False (< 0) maybePaused = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.UI.CECPOptions.mkCECPOptions:\t" $ shows pausedTag "; time already taken can't be negative." - | otherwise = MkCECPOptions { + | protocolVersion < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.UI.CECPOptions.mkCECPOptions:\t" $ shows protocolVersionTag " must exceed zero." + | otherwise = MkCECPOptions { getAnalyseMode = analyseMode, - getEditMode = editMode, getDisplaySAN = displaySAN, + getEditMode = editMode, getForceMode = forceMode, getMaybePaused = maybePaused, getPonderMode = ponderMode, @@ -322,4 +321,16 @@ postMode ) ] + +-- | Mutator. +pause :: Time.StopWatch.StopWatch -> CECPOptions -> CECPOptions +pause _ MkCECPOptions { getMaybePaused = Just _ } = Control.Exception.throw $ Data.Exception.mkRequestFailure "BishBosh.Input.CECPOptions.pause:\talready paused." +pause stopWatch cecpOptions + | Property.Switchable.isOn stopWatch = Control.Exception.throw $ Data.Exception.mkRequestFailure "BishBosh.Input.CECPOptions.pause:\tthe stop-watch is still running." + | otherwise = cecpOptions { getMaybePaused = Just stopWatch } + +-- | Mutator. +resume :: CECPOptions -> CECPOptions +resume MkCECPOptions { getMaybePaused = Nothing } = Control.Exception.throw $ Data.Exception.mkRequestFailure "BishBosh.Input.CECPOptions.resume:\talready resumed." +resume cecpOptions = cecpOptions { getMaybePaused = Nothing } diff --git a/src-lib/BishBosh/Input/CategorisedCommandLineOptions.hs b/src-lib/BishBosh/Input/CategorisedCommandLineOptions.hs --- a/src-lib/BishBosh/Input/CategorisedCommandLineOptions.hs +++ b/src-lib/BishBosh/Input/CategorisedCommandLineOptions.hs @@ -103,3 +103,4 @@ -- | Mutator. prependOptionsMutator :: OptionsMutator options -> Transformation options prependOptionsMutator optionsMutator categorisedCommandLineOptions = categorisedCommandLineOptions { getOptionsMutators = optionsMutator : getOptionsMutators categorisedCommandLineOptions } + diff --git a/src-lib/BishBosh/Input/CriteriaWeights.hs b/src-lib/BishBosh/Input/CriteriaWeights.hs --- a/src-lib/BishBosh/Input/CriteriaWeights.hs +++ b/src-lib/BishBosh/Input/CriteriaWeights.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -53,60 +52,60 @@ -- * Functions calculateWeightedMean, normalise, - perturbWeights, +-- perturbWeights, -- ** Constructor mkCriteriaWeights ) where -import qualified BishBosh.Attribute.CriterionValue as Attribute.CriterionValue -import qualified BishBosh.Attribute.CriterionWeight as Attribute.CriterionWeight -import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Property.ShowFloat as Property.ShowFloat -import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Metric.CriterionValue as Metric.CriterionValue +import qualified BishBosh.Metric.CriterionWeight as Metric.CriterionWeight +import qualified BishBosh.Metric.WeightedMeanAndCriterionValues as Metric.WeightedMeanAndCriterionValues +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Default import qualified System.Random -import qualified Text.XML.HXT.Arrow.Pickle as HXT +import qualified Text.XML.HXT.Arrow.Pickle as HXT -- | Used to qualify the XML. tag :: String -tag = "criteriaWeights" +tag = "criteriaWeights" -- | Used to qualify the XML. weightOfMaterialTag :: String -weightOfMaterialTag = "material" +weightOfMaterialTag = "material" -- | Used to qualify the XML. weightOfMobilityTag :: String -weightOfMobilityTag = "mobility" +weightOfMobilityTag = "mobility" -- | Used to qualify the XML. weightOfPieceSquareValueTag :: String -weightOfPieceSquareValueTag = "pieceSquareValue" +weightOfPieceSquareValueTag = "pieceSquareValue" -- | Used to qualify the XML. weightOfCastlingPotentialTag :: String -weightOfCastlingPotentialTag = "castlingPotential" +weightOfCastlingPotentialTag = "castlingPotential" -- | Used to qualify the XML. weightOfDefenceTag :: String -weightOfDefenceTag = "defence" +weightOfDefenceTag = "defence" -- | Used to qualify the XML. weightOfDoubledPawnsTag :: String -weightOfDoubledPawnsTag = "doubledPawns" +weightOfDoubledPawnsTag = "doubledPawns" -- | Used to qualify the XML. weightOfIsolatedPawnsTag :: String -weightOfIsolatedPawnsTag = "isolatedPawns" +weightOfIsolatedPawnsTag = "isolatedPawns" -- | Used to qualify the XML. weightOfPassedPawnsTag :: String -weightOfPassedPawnsTag = "passedPawns" +weightOfPassedPawnsTag = "passedPawns" {- | * The weight of various criteria used to select a /move/ from alternatives, at a specific point in the game. @@ -114,36 +113,35 @@ * CAVEAT: these weights determine the effective value of /isolated/ or /doubled/ @Pawn@s, & this value shouldn't be less than their weighted normalised /rank-value/, otherwise sacrifice would be beneficial. -} -data CriteriaWeights criterionWeight = MkCriteriaWeights { - getWeightOfMaterial :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total /rank-value/ of the /piece/s currently in play on either side; . - getWeightOfMobility :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the reciprocal of the number of destinations available to the /piece/s of either side. N.B. this weight can be derived from 'getWeightOfMaterial' since losing a @Queen@ is less significant than reducing mobility to zero; . - getWeightOfPieceSquareValue :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference in the values of the squares occupied by the pieces of either side. - getWeightOfCastlingPotential :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ Whether each player has been permanently prevented from /Castling/. - getWeightOfDefence :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the number of /piece/s defending each of one's own, compared with the opponent. - getWeightOfDoubledPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total number of /doubled/ @Pawn@s on either side; . - getWeightOfIsolatedPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total number of /isolated/ @Pawn@s on either side; . - getWeightOfPassedPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ The arithmetic difference between the total number of /passed/ @Pawn@s on either side; . +data CriteriaWeights = MkCriteriaWeights { + getWeightOfMaterial :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference between the total /rank-value/ of the /piece/s currently in play on either side; . + getWeightOfMobility :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference between the reciprocal of the number of destinations available to the /piece/s of either side. N.B. this weight can be derived from 'getWeightOfMaterial' since losing a @Queen@ is less significant than reducing mobility to zero; . + getWeightOfPieceSquareValue :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference in the values of the squares occupied by the pieces of either side. + getWeightOfCastlingPotential :: Metric.CriterionWeight.CriterionWeight, -- ^ Whether each player has been permanently prevented from /Castling/. + getWeightOfDefence :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference between the number of /piece/s defending each of one's own, compared with the opponent. + getWeightOfDoubledPawns :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference between the total number of /doubled/ @Pawn@s on either side; . + getWeightOfIsolatedPawns :: Metric.CriterionWeight.CriterionWeight, -- ^ The arithmetic difference between the total number of /isolated/ @Pawn@s on either side; . + getWeightOfPassedPawns :: Metric.CriterionWeight.CriterionWeight -- ^ The arithmetic difference between the total number of /passed/ @Pawn@s on either side; . } deriving (Eq, Show) --- | Smart-constructor. +-- | Smart constructor. mkCriteriaWeights - :: (Eq criterionWeight, Num criterionWeight) - => Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /material/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /mobility/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /pieceSquareValue/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /castlingPotential/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /defence/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /doubledPawns/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /isolatedPawns/. - -> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /passedPawns/. - -> CriteriaWeights criterionWeight + :: Metric.CriterionWeight.CriterionWeight -- ^ /material/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /mobility/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /pieceSquareValue/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /castlingPotential/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /defence/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /doubledPawns/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /isolatedPawns/. + -> Metric.CriterionWeight.CriterionWeight -- ^ /passedPawns/. + -> CriteriaWeights mkCriteriaWeights a b c d e f g h | criteriaWeights == minBound = Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.Input.CriteriaWeights.mkCriteriaWeights:\tall weights are zero." | otherwise = criteriaWeights where criteriaWeights = MkCriteriaWeights a b c d e f g h -instance Real criterionWeight => Property.ShowFloat.ShowFloat (CriteriaWeights criterionWeight) where +instance Property.ShowFloat.ShowFloat CriteriaWeights where showsFloat fromDouble MkCriteriaWeights { getWeightOfMaterial = weightOfMaterial, getWeightOfMobility = weightOfMobility, @@ -154,7 +152,7 @@ getWeightOfIsolatedPawns = weightOfIsolatedPawns, getWeightOfPassedPawns = weightOfPassedPawns } = Text.ShowList.showsAssociationList' $ map ( - Control.Arrow.second $ fromDouble . realToFrac . Attribute.CriterionWeight.deconstruct + Control.Arrow.second $ fromDouble . realToFrac ) [ ( weightOfMaterialTag, weightOfMaterial @@ -175,7 +173,7 @@ ) ] -instance Num criterionWeight => Data.Default.Default (CriteriaWeights criterionWeight) where +instance Data.Default.Default CriteriaWeights where def = MkCriteriaWeights { getWeightOfMaterial = maxBound, getWeightOfMobility = Data.Default.def, @@ -187,19 +185,14 @@ getWeightOfPassedPawns = Data.Default.def } -instance Control.DeepSeq.NFData criterionWeight => Control.DeepSeq.NFData (CriteriaWeights criterionWeight) where +instance Control.DeepSeq.NFData CriteriaWeights where rnf (MkCriteriaWeights a b c d e f g h) = Control.DeepSeq.rnf [a, b, c, d, e, f, g, h] -instance Num criterionWeight => Bounded (CriteriaWeights criterionWeight) where +instance Bounded CriteriaWeights where maxBound = MkCriteriaWeights maxBound maxBound maxBound maxBound maxBound maxBound maxBound maxBound minBound = MkCriteriaWeights minBound minBound minBound minBound minBound minBound minBound minBound -instance ( - HXT.XmlPickler criterionWeight, - Num criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => HXT.XmlPickler (CriteriaWeights criterionWeight) where +instance HXT.XmlPickler CriteriaWeights where xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag $ HXT.xpWrap ( \(a, b, c, d, e, f, g, h) -> mkCriteriaWeights a b c d e f g h, -- Construct. \MkCriteriaWeights { @@ -249,36 +242,17 @@ * Also writes individual unweighted /criterion-value/s, to facilitate post-analysis; if the corresponding weight is zero, for efficiency evaluation of the criterion is avoided. -} -calculateWeightedMean :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif - Fractional weightedMean, - Real criterionValue, - Real criterionWeight - ) - => CriteriaWeights criterionWeight - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /material/: maximum if a player's /move/ equals the maximum total piece value (including /queened/ @Pawn@s), while their opponent has just a @King@. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /mobility/: maximum when the opponent is check-mated. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /pieceSquareValue/: maximum when this player occupies all the strategically important squares & the opponent none. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /castlingPotential/: maximum when this player either has /castled/ or can, but the opponent has been permanently prevented. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /defence/: maximum when this player's /piece/s are fully utilised in defence, but none of the opponent's are. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /doubledPawns/: maximum when this player hasn't any /doubled/ @Pawn@s & the opponent has two files of four @Pawn@s. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /isolatedPawns/: maximum when this player hasn't any /isolated/ @Pawn@s & all the opponent's @Pawn@s are /isolated/. - -> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /passedPawns/: maximum when this player has 8 /passed/ @Pawn@s & the opponent has none. - -> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue -- ^ The individual /criteria/ values, & their /weighted mean/. -{-# SPECIALISE calculateWeightedMean - :: CriteriaWeights T.CriterionWeight - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.CriterionValue.CriterionValue T.CriterionValue - -> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues T.WeightedMean T.CriterionValue - #-} +calculateWeightedMean + :: CriteriaWeights + -> Metric.CriterionValue.CriterionValue -- ^ /material/: maximum if a player's /move/ equals the maximum total piece value (including /queened/ @Pawn@s), while their opponent has just a @King@. + -> Metric.CriterionValue.CriterionValue -- ^ /mobility/: maximum when the opponent is check-mated. + -> Metric.CriterionValue.CriterionValue -- ^ /pieceSquareValue/: maximum when this player occupies all the strategically important squares & the opponent none. + -> Metric.CriterionValue.CriterionValue -- ^ /castlingPotential/: maximum when this player either has /castled/ or can, but the opponent has been permanently prevented. + -> Metric.CriterionValue.CriterionValue -- ^ /defence/: maximum when this player's /piece/s are fully utilised in defence, but none of the opponent's are. + -> Metric.CriterionValue.CriterionValue -- ^ /doubledPawns/: maximum when this player hasn't any /doubled/ @Pawn@s & the opponent has two files of four @Pawn@s. + -> Metric.CriterionValue.CriterionValue -- ^ /isolatedPawns/: maximum when this player hasn't any /isolated/ @Pawn@s & all the opponent's @Pawn@s are /isolated/. + -> Metric.CriterionValue.CriterionValue -- ^ /passedPawns/: maximum when this player has 8 /passed/ @Pawn@s & the opponent has none. + -> Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues -- ^ The individual /criteria/ values, & their /weighted mean/. calculateWeightedMean MkCriteriaWeights { getWeightOfMaterial = weightOfMaterial, getWeightOfMobility = weightOfMobility, @@ -288,7 +262,7 @@ getWeightOfDoubledPawns = weightOfDoubledPawns, getWeightOfIsolatedPawns = weightOfIsolatedPawns, getWeightOfPassedPawns = weightOfPassedPawns -} material mobility pieceSquareValue castlingPotential defence doubledPawns isolatedPawns passedPawns = Attribute.CriterionValue.calculateWeightedMean [ +} material mobility pieceSquareValue castlingPotential defence doubledPawns isolatedPawns passedPawns = Metric.WeightedMeanAndCriterionValues.calculateWeightedMean [ ( material, weightOfMaterial ), ( @@ -309,14 +283,10 @@ ] -- | The type of a function which mutates 'CriteriaWeights'. -type Transformation criterionWeight = CriteriaWeights criterionWeight -> CriteriaWeights criterionWeight +type Transformation = CriteriaWeights -> CriteriaWeights -- | Adjust the mean weight, so that the maximum weight is @1@. -normalise :: ( - Fractional criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => Transformation criterionWeight +normalise :: Transformation normalise criteriaWeights@MkCriteriaWeights { getWeightOfMaterial = weightOfMaterial, getWeightOfMobility = weightOfMobility, @@ -338,35 +308,29 @@ getWeightOfIsolatedPawns = normaliseCriterionWeight weightOfIsolatedPawns, getWeightOfPassedPawns = normaliseCriterionWeight weightOfPassedPawns } where - normaliseCriterionWeight = Attribute.CriterionWeight.mkCriterionWeight . ( - / Attribute.CriterionWeight.deconstruct ( - maximum [ - weightOfMaterial, - weightOfMobility, - weightOfPieceSquareValue, - weightOfCastlingPotential, - weightOfDefence, - weightOfDoubledPawns, - weightOfIsolatedPawns, - weightOfPassedPawns - ] - ) - ) . Attribute.CriterionWeight.deconstruct + normaliseCriterionWeight = ( + / maximum [ + weightOfMaterial, + weightOfMobility, + weightOfPieceSquareValue, + weightOfCastlingPotential, + weightOfDefence, + weightOfDoubledPawns, + weightOfIsolatedPawns, + weightOfPassedPawns + ] + ) -- Section. {- | * Independently perturbs each /criterion-weight/ by a random value, of configurable magnitude. * Under this transformation, /criterion-weight/s of @0@, will remain unchanged, thus irrelevant criteria remain irrelevant. -} -perturbWeights :: ( - Fractional criterionWeight, - Real criterionWeight, - Show criterionWeight, - System.Random.RandomGen randomGen - ) +perturbWeights + :: System.Random.RandomGen randomGen => randomGen - -> criterionWeight -- ^ Change-magnitude. - -> Transformation criterionWeight + -> Type.Mass.CriterionWeight -- ^ Change-magnitude. + -> Transformation perturbWeights _ 0 criteriaWeights = criteriaWeights perturbWeights randomGen changeMagnitude MkCriteriaWeights { getWeightOfMaterial = weightOfMaterial, @@ -387,15 +351,15 @@ getWeightOfIsolatedPawns = reduceBy g weightOfIsolatedPawns, getWeightOfPassedPawns = reduceBy h weightOfPassedPawns } where - (a : b : c : d : e : f : g : h : _) = System.Random.randomRs (1 :: Double, succ $ realToFrac changeMagnitude) randomGen - reduceBy randomValue = Attribute.CriterionWeight.mkCriterionWeight . (/ realToFrac randomValue) . Attribute.CriterionWeight.deconstruct -- N.B. this always reduces the weight, leaving 'normalise' to correct this. + (a : b : c : d : e : f : g : h : _) = System.Random.randomRs (1, succ changeMagnitude) randomGen + reduceBy randomValue = (/ realToFrac randomValue) -- N.B. this always reduces the weight, leaving 'normalise' to correct this. -- | A constant list of named accessors & mutators. onymousOperators :: [ ( - String, -- Tag. - CriteriaWeights criterionWeight -> Attribute.CriterionWeight.CriterionWeight criterionWeight, -- Accessor. - Attribute.CriterionWeight.CriterionWeight criterionWeight -> Transformation criterionWeight -- Mutator. + String, -- Tag. + CriteriaWeights -> Metric.CriterionWeight.CriterionWeight, -- Accessor. + Metric.CriterionWeight.CriterionWeight -> Transformation -- Mutator. ) -- Triple. ] onymousOperators = [ 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 @@ -38,6 +38,7 @@ EvaluationOptions( -- MkEvaluationOptions, getRankValues, + getMaximumTotalRankValue, getCriteriaWeights, getIncrementalEvaluation, -- getMaybePieceSquareTablePair, @@ -56,14 +57,15 @@ import BishBosh.Data.Bool() import Control.Arrow((***)) -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable +import qualified BishBosh.Input.RankValues as Input.RankValues import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad.Reader @@ -96,54 +98,53 @@ type PieceSquareTablePair x y pieceSquareValue = (Input.PieceSquareTable.PieceSquareTable x y pieceSquareValue, Input.PieceSquareTable.PieceSquareTable x y pieceSquareValue) -- | Defines the options related to the automatic selection of /move/s. -data EvaluationOptions criterionWeight pieceSquareValue rankValue x y = MkEvaluationOptions { - getRankValues :: Attribute.RankValues.RankValues rankValue, -- ^ The static value associated with each /piece/'s /rank/. - getCriteriaWeights :: Input.CriteriaWeights.CriteriaWeights criterionWeight, -- ^ 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 x y pieceSquareValue), -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. +data EvaluationOptions pieceSquareValue x y = 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 x y pieceSquareValue), -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. getMaybePieceSquareByCoordinatesByRank :: Maybe ( Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue - ) -- ^ The optional value for each rank of /piece/, when occupying each coordinate, at each phase of the game. + ) -- ^ 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 criterionWeight, Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (EvaluationOptions criterionWeight pieceSquareValue rankValue x y) where + ) => Control.DeepSeq.NFData (EvaluationOptions pieceSquareValue x y) where rnf MkEvaluationOptions { - getRankValues = rankValues, +-- getRankValues = rankValues, + getMaximumTotalRankValue = maximumTotalValue, getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, -- getMaybePieceSquareTablePair = maybePieceSquareTablePair, getMaybePieceSquareByCoordinatesByRank = maybePieceSquareByCoordinatesByRank - } = Control.DeepSeq.rnf (rankValues, criteriaWeights, incrementalEvaluation, maybePieceSquareByCoordinatesByRank) + } = Control.DeepSeq.rnf (maximumTotalValue, criteriaWeights, incrementalEvaluation, maybePieceSquareByCoordinatesByRank) instance ( Enum x, Enum y, Ord x, Ord y, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, Show pieceSquareValue - ) => Property.ShowFloat.ShowFloat (EvaluationOptions criterionWeight pieceSquareValue rankValue x y) where + ) => Property.ShowFloat.ShowFloat (EvaluationOptions pieceSquareValue x y) where showsFloat fromDouble MkEvaluationOptions { getRankValues = rankValues, +-- getMaximumTotalRankValue = maximumTotalValue, getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, getMaybePieceSquareTablePair = maybePieceSquareTablePair -- getMaybePieceSquareByCoordinatesByRank = maybePieceSquareByCoordinatesByRank } = Text.ShowList.showsAssociationList' $ [ ( - Attribute.RankValues.tag, Property.ShowFloat.showsFloat fromDouble rankValues + Input.RankValues.tag, Property.ShowFloat.showsFloat fromDouble rankValues ), ( incrementalEvaluationTag, shows incrementalEvaluation ), ( - Input.CriteriaWeights.tag, Property.ShowFloat.showsFloat fromDouble criteriaWeights + Input.CriteriaWeights.tag, Property.ShowFloat.showsFloat fromDouble criteriaWeights ) ] ++ Data.Maybe.maybe [] ( \(t, t') -> [ @@ -157,42 +158,32 @@ ] ) maybePieceSquareTablePair -instance ( - Fractional rankValue, - Num criterionWeight, - Ord rankValue, - Show rankValue - ) => Data.Default.Default (EvaluationOptions criterionWeight pieceSquareValue rankValue x y) where +instance Data.Default.Default (EvaluationOptions pieceSquareValue x y) where def = MkEvaluationOptions { - getRankValues = Data.Default.def, + getRankValues = rankValues, + getMaximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues, getCriteriaWeights = Data.Default.def, getIncrementalEvaluation = True, getMaybePieceSquareTablePair = Nothing, getMaybePieceSquareByCoordinatesByRank = Nothing - } + } where + rankValues = Data.Default.def instance ( Enum x, Enum y, Fractional pieceSquareValue, - Fractional rankValue, - HXT.XmlPickler criterionWeight, - HXT.XmlPickler rankValue, - Num criterionWeight, - Ord criterionWeight, Ord pieceSquareValue, - Ord rankValue, Ord x, Ord y, Real pieceSquareValue, - Show pieceSquareValue, - Show criterionWeight, - Show rankValue - ) => HXT.XmlPickler (EvaluationOptions criterionWeight pieceSquareValue rankValue x y) where + Show pieceSquareValue + ) => HXT.XmlPickler (EvaluationOptions pieceSquareValue x y) where xpickle = HXT.xpDefault def . HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d) -> mkEvaluationOptions a b c d, -- Construct. \MkEvaluationOptions { getRankValues = rankValues, +-- getMaximumTotalRankValue = maximumTotalRankValue, getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, getMaybePieceSquareTablePair = maybePieceSquareTablePair @@ -232,17 +223,15 @@ mkEvaluationOptions :: ( Enum x, Enum y, - Eq criterionWeight, Fractional pieceSquareValue, - Num criterionWeight, Ord x, Ord y ) - => Attribute.RankValues.RankValues rankValue -- ^ The static value associated with each /piece/'s /rank/. - -> Input.CriteriaWeights.CriteriaWeights criterionWeight -- ^ 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 x y pieceSquareValue) -- ^ The value to each type of piece, of each square, during normal play & the end-game. - -> EvaluationOptions criterionWeight pieceSquareValue rankValue x y + -> Maybe (PieceSquareTablePair x y pieceSquareValue) -- ^ The value to each type of piece, of each square, during normal play & the end-game. + -> EvaluationOptions pieceSquareValue x y mkEvaluationOptions rankValues criteriaWeights incrementalEvaluation maybePieceSquareTablePair | Just (pieceSquareTable, _) <- maybePieceSquareTablePair , let undefinedRanks = Input.PieceSquareTable.findUndefinedRanks pieceSquareTable @@ -253,6 +242,7 @@ = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.EvaluationOptions.mkEvaluationOptions:\tweight of " . shows Input.CriteriaWeights.weightOfPieceSquareValueTag . showString " is defined but " $ shows Input.PieceSquareTable.tag " isn't." | otherwise = MkEvaluationOptions { getRankValues = rankValues, + getMaximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues, -- Infer. getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, getMaybePieceSquareTablePair = maybePieceSquareTablePair, @@ -260,5 +250,5 @@ } -- | Self-documentation. -type Reader criterionWeight pieceSquareValue rankValue x y = Control.Monad.Reader.Reader (EvaluationOptions criterionWeight pieceSquareValue rankValue x y) +type Reader pieceSquareValue x y = Control.Monad.Reader.Reader (EvaluationOptions pieceSquareValue x y) diff --git a/src-lib/BishBosh/Input/IOOptions.hs b/src-lib/BishBosh/Input/IOOptions.hs --- a/src-lib/BishBosh/Input/IOOptions.hs +++ b/src-lib/BishBosh/Input/IOOptions.hs @@ -26,7 +26,6 @@ -- * Types -- ** Type-synonyms -- Transformation, - MaximumPGNNames, -- ** Data-types IOOptions( -- MkIOOptions, @@ -63,6 +62,7 @@ import qualified BishBosh.Input.Verbosity as Input.Verbosity import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -95,22 +95,16 @@ automaticTag :: String automaticTag = "automatic" --- | The maximum number names, of matching games from the PGN-database, to display. -type MaximumPGNNames = Int - -- | Defines options related to i/o. -data IOOptions row column = MkIOOptions { +data IOOptions = MkIOOptions { getMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath, -- ^ An optional path to a file, into which the unprocessed configuration, formatted as XML, should be written (obliterating any existing file-contents). - getMaybeMaximumPGNNames :: Maybe MaximumPGNNames, -- ^ The maximum number names, of matching games from the PGN-database, to display; @Nothing@ implies no maximum. - getPGNOptionsList :: [Input.PGNOptions.PGNOptions], -- ^ How to construct PGN-databases. + getMaybeMaximumPGNNames :: Maybe Type.Count.NGames, -- ^ The maximum number of names to display, of matching games from the PGN-database; @Nothing@ implies unlimited. CAVEAT: pedantically, it's a number of names not a number of games. + getPGNOptionsList :: [Input.PGNOptions.PGNOptions], -- ^ How to construct each PGN-database. getMaybePersistence :: Maybe (System.FilePath.FilePath, Bool), -- ^ Optional path to a file, into which game-state can be persisted (obliterating any existing content), & whether to save this state automatically after each move. - getUIOptions :: Input.UIOptions.UIOptions row column -- ^ Options which define the user-interface. + getUIOptions :: Input.UIOptions.UIOptions -- ^ Options which define the user-interface. } deriving Eq -instance ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row - ) => Control.DeepSeq.NFData (IOOptions row column) where +instance Control.DeepSeq.NFData IOOptions where rnf MkIOOptions { getMaybeOutputConfigFilePath = maybeOutputConfigFilePath, getMaybeMaximumPGNNames = maybeMaximumPGNNames, @@ -125,7 +119,7 @@ uiOptions ) -instance (Show column, Show row) => Show (IOOptions row column) where +instance Show IOOptions where showsPrec _ MkIOOptions { getMaybeOutputConfigFilePath = maybeOutputConfigFilePath, getMaybeMaximumPGNNames = maybeMaximumPGNNames, @@ -148,7 +142,7 @@ ) ] -instance (Num column, Num row) => Data.Default.Default (IOOptions row column) where +instance Data.Default.Default IOOptions where def = MkIOOptions { getMaybeOutputConfigFilePath = Nothing, getMaybeMaximumPGNNames = Nothing, @@ -157,14 +151,7 @@ getUIOptions = Data.Default.def } -instance ( - HXT.XmlPickler column, - HXT.XmlPickler row, - Integral column, - Integral row, - Show column, - Show row - ) => HXT.XmlPickler (IOOptions row column) where +instance HXT.XmlPickler IOOptions where xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d, e) -> mkIOOptions a b c d e, -- Construct. \MkIOOptions { @@ -183,7 +170,7 @@ ) $ HXT.xp5Tuple ( HXT.xpOption $ HXT.xpTextAttr outputConfigFilePathTag {-can't be null-} ) ( - HXT.xpAttrImplied maximumPGNNamesTag HXT.xpInt + HXT.xpAttrImplied maximumPGNNamesTag HXT.xpickle ) HXT.xpickle {-PGNOptions-} ( HXT.xpOption $ HXT.xpElem persistenceTag ( HXT.xpTextAttr filePathTag `HXT.xpPair` HXT.xpDefault True (HXT.xpAttr automaticTag HXT.xpickle {-Bool-}) @@ -193,11 +180,11 @@ -- | Smart constructor. mkIOOptions :: Maybe System.FilePath.FilePath -- ^ An optional path to a file, into which the unprocessed configuration, formatted as XML, should be written (obliterating any existing file-contents). - -> Maybe MaximumPGNNames -- ^ The optional maximum number of names, of matching PGN-games, to display; @Nothing@ implies unlimited. + -> Maybe Type.Count.NGames -- ^ The optional maximum number of names, of matching PGN-games, to display; @Nothing@ implies unlimited. -> [Input.PGNOptions.PGNOptions] -- ^ How to find & process PGN-databases. -> Maybe (System.FilePath.FilePath, Bool) -- ^ Optional path to a file, into which game-state can be persisted (obliterating any existing content), & whether to save this state automatically after each move. - -> Input.UIOptions.UIOptions row column - -> IOOptions row column + -> Input.UIOptions.UIOptions + -> IOOptions mkIOOptions maybeOutputConfigFilePath maybeMaximumPGNNames pgnOptionsList maybePersistence uiOptions | Data.Maybe.maybe False ( not . System.FilePath.isValid {-i.e. non-null on POSIX-} @@ -221,10 +208,10 @@ duplicateFilePaths = Data.Foldable.findDuplicates $ map (System.FilePath.normalise . Input.PGNOptions.getDatabaseFilePath) pgnOptionsList -- | The type of a function used to transform 'IOOptions'. -type Transformation row column = IOOptions row column -> IOOptions row column +type Transformation = IOOptions -> IOOptions -- | Mutator. -setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation row column +setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation setMaybeOutputConfigFilePath maybeOutputConfigFilePath ioOptions | Data.Maybe.maybe False ( not . System.FilePath.isValid {-i.e. non-null on POSIX-} @@ -234,7 +221,7 @@ } -- | Mutator. -setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions row column -> Transformation row column +setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions ioOptions@MkIOOptions { getUIOptions = uiOptions } = ioOptions { getUIOptions = uiOptions { Input.UIOptions.getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions @@ -242,7 +229,7 @@ } -- | Mutator. -setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation row column +setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation setMaybePrintMoveTree maybePrintMoveTree ioOptions@MkIOOptions { getUIOptions = uiOptions } = ioOptions { getUIOptions = uiOptions { Input.UIOptions.getMaybePrintMoveTree = maybePrintMoveTree @@ -250,19 +237,19 @@ } -- | Mutator. -updateCECPFeature :: Input.CECPFeatures.Feature -> Transformation row column +updateCECPFeature :: Input.CECPFeatures.Feature -> Transformation updateCECPFeature feature ioOptions@MkIOOptions { getUIOptions = uiOptions } = ioOptions { getUIOptions = Input.UIOptions.updateCECPFeature feature uiOptions } -- | Mutator. -deleteCECPFeature :: Input.CECPFeatures.Feature -> Transformation row column +deleteCECPFeature :: Input.CECPFeatures.Feature -> Transformation deleteCECPFeature feature ioOptions@MkIOOptions { getUIOptions = uiOptions } = ioOptions { getUIOptions = Input.UIOptions.deleteCECPFeature feature uiOptions } -- | Mutator. -setVerbosity :: Input.Verbosity.Verbosity -> Transformation row column +setVerbosity :: Input.Verbosity.Verbosity -> Transformation setVerbosity verbosity ioOptions@MkIOOptions { getUIOptions = uiOptions } = ioOptions { getUIOptions = uiOptions { Input.UIOptions.getVerbosity = verbosity 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 @@ -25,7 +25,7 @@ module BishBosh.Input.NativeUIOptions( -- * Types -- ** Type-synonyms - ScreenCoordinates, +-- ScreenCoordinates, -- ** Data-types NativeUIOptions( -- MkNativeUIOptions, @@ -46,6 +46,7 @@ import qualified BishBosh.Attribute.ColourScheme as Attribute.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 import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Default @@ -67,19 +68,16 @@ nColumnsTag :: String nColumnsTag = "nColumns" --- | The coordinates used to index the screen. -type ScreenCoordinates row column = (row, column) +-- | The coordinates used to index the screen. CAVEAT: the name is an anachronistic hang-over from a discarded implementation of a Curses display. +type ScreenCoordinates = (Type.Length.Row, Type.Length.Column) -- | Constructor. -data NativeUIOptions row column = MkNativeUIOptions { - getBoardMagnification :: ScreenCoordinates row column, -- ^ The factor by which the dimensions of the board are stretched when displayed. +data NativeUIOptions = MkNativeUIOptions { + getBoardMagnification :: ScreenCoordinates, -- ^ The factor by which the dimensions of the board are stretched when displayed. getColourScheme :: Attribute.ColourScheme.ColourScheme } deriving Eq -instance ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row - ) => Control.DeepSeq.NFData (NativeUIOptions row column) where +instance Control.DeepSeq.NFData NativeUIOptions where rnf MkNativeUIOptions { getBoardMagnification = boardMagnification, getColourScheme = colourScheme @@ -88,34 +86,27 @@ colourScheme ) -instance (Show row, Show column) => Show (NativeUIOptions row column) where - showsPrec _ MkNativeUIOptions { +instance Show NativeUIOptions where + showsPrec precision MkNativeUIOptions { getBoardMagnification = boardMagnification, getColourScheme = colourScheme } = Text.ShowList.showsAssociationList' [ ( boardMagnificationTag, - shows boardMagnification + showsPrec precision boardMagnification ), ( Attribute.ColourScheme.tag, - shows colourScheme + showsPrec precision colourScheme ) ] -instance (Num row, Num column) => Data.Default.Default (NativeUIOptions row column) where +instance Data.Default.Default NativeUIOptions where def = MkNativeUIOptions { getBoardMagnification = (1, 1), getColourScheme = Data.Default.def } -instance ( - HXT.XmlPickler column, - HXT.XmlPickler row, - Integral column, - Integral row, - Show column, - Show row - ) => HXT.XmlPickler (NativeUIOptions row column) where +instance HXT.XmlPickler NativeUIOptions where xpickle = HXT.xpElem tag . HXT.xpWrap ( uncurry mkNativeUIOptions, -- Construct. \MkNativeUIOptions { @@ -135,15 +126,10 @@ def = Data.Default.def -- | Smart constructor. -mkNativeUIOptions :: ( - Integral column, - Integral row, - Show column, - Show row - ) - => ScreenCoordinates row column -- ^ The factor by which the dimensions of the board are stretched when displayed. +mkNativeUIOptions + :: ScreenCoordinates -- ^ The factor by which the dimensions of the board are stretched when displayed. -> Attribute.ColourScheme.ColourScheme - -> NativeUIOptions row column + -> NativeUIOptions mkNativeUIOptions boardMagnification colourScheme | uncurry (||) $ ( (< 1) *** (< 1) @@ -155,3 +141,4 @@ getBoardMagnification = boardMagnification, getColourScheme = colourScheme } + 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 @@ -59,8 +59,6 @@ ) where import BishBosh.Data.Bool() -- For 'HXT.xpickle'. -import BishBosh.Data.Integral() -- For 'HXT.XmlPickler NMoves'. -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.IOOptions as Input.IOOptions @@ -70,6 +68,7 @@ import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Default @@ -93,23 +92,19 @@ type RandomSeed = Int -- | Defines the application's options. -data Options column criterionWeight pieceSquareValue rankValue row x y = MkOptions { - getMaybeMaximumPlies :: Maybe Component.Move.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 criterionWeight pieceSquareValue rankValue x y, -- ^ 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 row column -- ^ The /ioOptions/ by which to receive commands & present results. +data Options pieceSquareValue x y = 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 x y, -- ^ 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 column, - Control.DeepSeq.NFData criterionWeight, Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData rankValue, - Control.DeepSeq.NFData row, Control.DeepSeq.NFData x, Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Options column criterionWeight pieceSquareValue rankValue row x y) where + ) => Control.DeepSeq.NFData (Options pieceSquareValue x y) where rnf MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -123,13 +118,9 @@ Enum y, Ord x, Ord y, - Real criterionWeight, Real pieceSquareValue, - Real rankValue, - Show column, - Show pieceSquareValue, - Show row - ) => Property.ShowFloat.ShowFloat (Options column criterionWeight pieceSquareValue rankValue row x y) where + Show pieceSquareValue + ) => Property.ShowFloat.ShowFloat (Options pieceSquareValue x y) where showsFloat fromDouble MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -153,14 +144,7 @@ ) ] -instance ( - Fractional rankValue, - Num criterionWeight, - Num column, - Num row, - Ord rankValue, - Show rankValue - ) => Data.Default.Default (Options column criterionWeight pieceSquareValue rankValue row x y) where +instance Data.Default.Default (Options pieceSquareValue x y) where def = MkOptions { getMaybeMaximumPlies = Nothing, getMaybeRandomSeed = Nothing, @@ -173,26 +157,12 @@ Enum x, Enum y, Fractional pieceSquareValue, - Fractional rankValue, - HXT.XmlPickler column, - HXT.XmlPickler criterionWeight, - HXT.XmlPickler rankValue, - HXT.XmlPickler row, - Integral column, - Integral row, - Num criterionWeight, Ord pieceSquareValue, - Ord rankValue, Ord x, Ord y, - Real criterionWeight, Real pieceSquareValue, - Show column, - Show criterionWeight, - Show pieceSquareValue, - Show rankValue, - Show row - ) => HXT.XmlPickler (Options column criterionWeight pieceSquareValue rankValue row x y) where + Show pieceSquareValue + ) => HXT.XmlPickler (Options pieceSquareValue x y) where xpickle = HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d, e) -> mkOptions a b c d e, -- Construct. \MkOptions { @@ -209,19 +179,19 @@ ioOptions ) -- Deconstruct. ) $ HXT.xp5Tuple ( - HXT.xpAttrImplied maximumPliesTag HXT.xpInt {-NMoves-} + HXT.xpAttrImplied maximumPliesTag HXT.xpickle {-NPlies-} ) ( HXT.xpAttrImplied randomSeedTag HXT.xpInt ) HXT.xpickle {-EvaluationOptions-} HXT.xpickle {-SearchOptions-} HXT.xpickle {-IOOptions-} -- | Smart constructor. mkOptions - :: Maybe Component.Move.NPlies -- ^ The maximum number of plies before the game is terminated; required for profiling the application. + :: 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 criterionWeight pieceSquareValue rankValue x y + -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y -> Input.SearchOptions.SearchOptions - -> Input.IOOptions.IOOptions row column - -> Options column criterionWeight pieceSquareValue rankValue row x y + -> Input.IOOptions.IOOptions + -> Options pieceSquareValue x y 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." @@ -234,22 +204,22 @@ } -- | The type of a function used to transform 'Options'. -type Transformation column criterionWeight pieceSquareValue rankValue row x y = Options column criterionWeight pieceSquareValue rankValue row x y -> Options column criterionWeight pieceSquareValue rankValue row x y +type Transformation pieceSquareValue x y = Options pieceSquareValue x y -> Options pieceSquareValue x y -- | Mutator. -setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation pieceSquareValue x y setMaybeOutputConfigFilePath maybeOutputConfigFilePath options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybeOutputConfigFilePath maybeOutputConfigFilePath ioOptions } -- | Mutator. -setMaybeRandomSeed :: Maybe RandomSeed -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setMaybeRandomSeed :: Maybe RandomSeed -> Transformation pieceSquareValue x y setMaybeRandomSeed maybeRandomSeed options = options { getMaybeRandomSeed = maybeRandomSeed } -- | Mutator. -setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation pieceSquareValue x y setMaybePersistence maybePersistence options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = ioOptions { Input.IOOptions.getMaybePersistence = maybePersistence @@ -257,25 +227,25 @@ } -- | Mutator. -setVerbosity :: Input.Verbosity.Verbosity -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setVerbosity :: Input.Verbosity.Verbosity -> Transformation pieceSquareValue x y setVerbosity verbosity options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setVerbosity verbosity ioOptions } -- | Mutator. -setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions row column -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation pieceSquareValue x y setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions ioOptions } -- | Mutator. -setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation column criterionWeight pieceSquareValue rankValue row x y +setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation pieceSquareValue x y setMaybePrintMoveTree maybePrintMoveTree options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybePrintMoveTree maybePrintMoveTree ioOptions } -- | Mutator. -swapSearchDepth :: Transformation column criterionWeight pieceSquareValue rankValue row x y +swapSearchDepth :: Transformation pieceSquareValue x y swapSearchDepth options@MkOptions { getSearchOptions = searchOptions } = options { getSearchOptions = Input.SearchOptions.swapSearchDepth searchOptions } diff --git a/src-lib/BishBosh/Input/PGNOptions.hs b/src-lib/BishBosh/Input/PGNOptions.hs --- a/src-lib/BishBosh/Input/PGNOptions.hs +++ b/src-lib/BishBosh/Input/PGNOptions.hs @@ -52,7 +52,6 @@ ) where import BishBosh.Data.Bool() -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN import qualified BishBosh.ContextualNotation.PGNDatabase as ContextualNotation.PGNDatabase import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic @@ -60,6 +59,7 @@ import qualified BishBosh.Data.Foldable as Data.Foldable import qualified BishBosh.Text.Encoding as Text.Encoding import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Char @@ -109,8 +109,8 @@ getValidateMoves :: ContextualNotation.StandardAlgebraic.ValidateMoves, -- ^ Whether moves should be validated, which can become tedious if they're already known to be valid. getTextEncoding :: System.IO.TextEncoding, -- ^ The conversion-scheme between byte-sequences & Unicode characters. getIdentificationTags :: [ContextualNotation.PGN.Tag], -- ^ The tags to extract from this PGN-database to form a unique composite game-identifier. - getMinimumPlies :: Component.Move.NPlies, -- ^ The minimum number of plies required from a recorded game. - getMaybeMaximumGames :: Maybe Int -- ^ The optional maximum number of games to read from the PGN-database. + getMinimumPlies :: Type.Count.NPlies, -- ^ The minimum number of plies required before a recorded game is considered useful. + getMaybeMaximumGames :: ContextualNotation.PGNDatabase.MaybeMaximumGames -- ^ The optional maximum number of games to read from the PGN-database. } deriving Eq instance Control.DeepSeq.NFData PGNOptions where @@ -198,7 +198,7 @@ ) HXT.xpickle {-TextEncoding-} ( HXT.xpList . HXT.xpElem identificationTagTag $ HXT.xpTextAttr "tag" ) ( - getMinimumPlies def `HXT.xpDefault` HXT.xpAttr minimumPliesTag HXT.xpickle {-NMoves-} + getMinimumPlies def `HXT.xpDefault` HXT.xpAttr minimumPliesTag HXT.xpickle {-NPlies-} ) ( HXT.xpOption $ HXT.xpAttr maximumGamesTag HXT.xpickle {-NGames-} ) where @@ -212,8 +212,8 @@ -> ContextualNotation.StandardAlgebraic.ValidateMoves -> System.IO.TextEncoding -> [ContextualNotation.PGN.Tag] -- ^ Optional identification tags. - -> Component.Move.NPlies -- ^ The minimum plies. - -> Maybe Int -- ^ The optional maximum number of games to read from the database. + -> Type.Count.NPlies -- ^ The minimum plies. + -> ContextualNotation.PGNDatabase.MaybeMaximumGames -- ^ The optional maximum number of games to read from the database. -> PGNOptions mkPGNOptions databaseFilePath maybeDecompressor isStrictlySequential validateMoves textEncoding identificationTags minimumPlies maybeMaximumGames | not $ System.FilePath.isValid databaseFilePath = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.PGNOptions.mkPGNOptions:\tinvalid " . showString databaseFilePathTag . Text.ShowList.showsAssociation $ shows databaseFilePath "." 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 @@ -75,6 +75,7 @@ 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 @@ -183,11 +184,11 @@ showString "by" $ Text.Case.toUpperInitial Attribute.Rank.tag ) $ HXT.xpickle {-rank-} `HXT.xpPair` HXT.xpWrap ( \s -> [ - realToFrac (pieceSquareValue :: Double) | + realToFrac (pieceSquareValue :: Type.Mass.PieceSquareValue) | word <- words s, (pieceSquareValue, "") <- reads word ], -- List-comprehension. - unwords . map (show . (\pieceSquareValue -> realToFrac pieceSquareValue :: Double)) + unwords . map (show . (\pieceSquareValue -> realToFrac pieceSquareValue :: Type.Mass.PieceSquareValue)) ) ( HXT.xpTextAttr . showString "by" $ Text.Case.toUpperInitial Cartesian.Coordinates.tag ) diff --git a/src-lib/BishBosh/Input/RankValues.hs b/src-lib/BishBosh/Input/RankValues.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Input/RankValues.hs @@ -0,0 +1,133 @@ +{- + 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@] + + * The relative values of the various /rank/s of chess-piece. + + * +-} + +module BishBosh.Input.RankValues( +-- * Types +-- ** Data-types + RankValues( +-- MkRankValues, +-- deconstruct + ), +-- * Constants + tag, +-- * Functions + findRankValue, + calculateMaximumTotalValue, +-- ** Constructor + fromAssocs +) where + +import Control.Arrow((&&&), (***)) +import Data.Array.IArray((!)) +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Foldable as Data.Foldable +import qualified BishBosh.Metric.RankValue as Metric.RankValue +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Mass as Type.Mass +import qualified Control.DeepSeq +import qualified Control.Exception +import qualified Data.Array.IArray +import qualified Data.Default +import qualified Data.List +import qualified Text.XML.HXT.Arrow.Pickle as HXT + +-- | Used to qualify XML. +tag :: String +tag = "rankValues" + +{- | + * The constant value associated with each /rank/; the higher, the more valuable it is considered to be. + + * N.B.: only relative values are significant; the absolute value associated with any /rank/ is irrelevant; typically ranks are valued in /centipawns/. + + * CAVEAT: a @King@ can never be taken, but assigning the value /infinity/ creates problems, so typically it has the value @0@. +-} +newtype RankValues = MkRankValues { + deconstruct :: Attribute.Rank.ArrayByRank Metric.RankValue.RankValue +} deriving (Eq, Read, Show) + +instance Property.ShowFloat.ShowFloat RankValues where + showsFloat fromDouble = Text.ShowList.showsAssociationList' . map (show *** Property.ShowFloat.showsFloat fromDouble) . Data.Array.IArray.assocs . deconstruct + +instance Data.Default.Default RankValues where + def = MkRankValues . Attribute.Rank.listArrayByRank $ map ( + fromRational . (/ 10) -- Map into the closed unit-interval. + ) [ + 1, + 5, + 3, + 3, + 9, + 0 -- N.B.: move-selection is independent of the King's value (since it can't be taken), so it can be defined arbitrarily. + ] + +instance Control.DeepSeq.NFData RankValues where + rnf (MkRankValues byRank) = Control.DeepSeq.rnf byRank + +instance HXT.XmlPickler RankValues where + xpickle = HXT.xpDefault Data.Default.def . HXT.xpWrap ( + fromAssocs, -- Construct from an association-list. + Data.Array.IArray.assocs . deconstruct -- Deconstruct to an association-list. + ) . HXT.xpList1 . HXT.xpElem tag $ HXT.xpickle {-Rank-} `HXT.xpPair` HXT.xpickle {-RankValue-} + +-- | Smart constructor. +fromAssocs :: [(Attribute.Rank.Rank, Metric.RankValue.RankValue)] -> RankValues +fromAssocs assocs + | not $ null undefinedRanks = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.Input.RankValues.fromAssocs:\tranks" . Text.ShowList.showsAssociation $ shows undefinedRanks " are undefined." + | not $ null duplicateRanks = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.RankValues.fromAssocs:\tranks must be distinct; " $ shows duplicateRanks "." + | all ( + (== 0) . snd {-RankValue-} + ) assocs = Control.Exception.throw . Data.Exception.mkNullDatum . showString "BishBosh.Input.RankValues.fromAssocs:\tat least one rank should have a non-zero value; " $ shows assocs "." + | byRank ! Attribute.Rank.Queen /= maximum [ + rankValue | + (rank, rankValue) <- assocs, + rank /= Attribute.Rank.King -- Whose rank-value is irrelevant. + ] {-list-comprehension-} = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.RankValues.fromAssocs:\texcepting possibly the King, the Queen should be the most valuable rank; " $ shows assocs "." + | otherwise = MkRankValues byRank + where + (undefinedRanks, duplicateRanks) = Attribute.Rank.findUndefinedRanks &&& Data.Foldable.findDuplicates $ map fst assocs + byRank = Attribute.Rank.arrayByRank assocs + +-- | Query. +findRankValue :: Attribute.Rank.Rank -> RankValues -> Metric.RankValue.RankValue +findRankValue rank (MkRankValues byRank) = byRank ! rank + +{- | + * The maximum total rank-value one side can have. + + * CAVEAT: assumes that zero pieces have been captured, all @Pawn@s have been queened, & that this is the most valuable /rank/ of /piece/. +-} +calculateMaximumTotalValue :: RankValues -> Type.Mass.RankValue +calculateMaximumTotalValue (MkRankValues byRank) = 9 {-accounting for all possible promotions-} * realToFrac ( + byRank ! Attribute.Rank.Queen + ) + 2 * Data.List.foldl' ( + \acc -> (+ acc) . realToFrac . (byRank !) + ) 0 Attribute.Rank.flank + 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 @@ -25,7 +25,6 @@ module BishBosh.Input.SearchOptions( -- * Types -- ** Type-synonyms - SearchDepth, SortOnStandardOpeningMoveFrequency, HammingDistance, -- Transformation, @@ -71,6 +70,7 @@ getSearchDepth, maybeRetireTranspositionsAfter, maybeMinimumTranspositionSearchDepth, + identifyAutomatedPlayers, -- ** Mutators setSearchDepth, swapSearchDepth, @@ -79,17 +79,16 @@ ) where import BishBosh.Data.Bool() -- For 'HXT.xpickle'. -import BishBosh.Data.Integral() -- For 'HXT.XmlPickler NMoves'. import Control.Arrow((***)) import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Data.Foldable import qualified BishBosh.Input.StandardOpeningOptions as Input.StandardOpeningOptions import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Text.Case as Text.Case import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad.Reader @@ -139,11 +138,8 @@ searchDepthByLogicalColourTag :: String searchDepthByLogicalColourTag = showString searchDepthTag . showString "By" $ Text.Case.toUpperInitial Attribute.LogicalColour.tag --- | The number of plies to search for the optimal move. -type SearchDepth = Component.Move.NPlies - -- | The constant minimum permissible search-depth. -minimumSearchDepth :: SearchDepth +minimumSearchDepth :: Type.Count.NPlies minimumSearchDepth = 1 {- | @@ -151,7 +147,7 @@ * CAVEAT: this is rather arbitrary. -} -defaultSearchDepth :: SearchDepth +defaultSearchDepth :: Type.Count.NPlies defaultSearchDepth = 4 -- | Sort moves on the decreasing frequency of occurrence in standard openings. @@ -161,7 +157,7 @@ type HammingDistance = Int -- | The number of full moves (one for each player) after which to retire killer moves. -type MaybeRetireAfterNMoves = Maybe Component.Move.NMoves +type MaybeRetireAfterNMoves = Maybe Type.Count.NMoves -- | Whether to short-circuit the fitness-evaluation of /position/s which have been visited before in the current /game/. type TrapRepeatedPositions = Bool @@ -170,22 +166,22 @@ type UsePondering = Bool -- | The number of full moves (one for each player) after which to retire transpositions & the search-depth beneath which they aren't recorded at all. -type MaybeUseTranspositions = Maybe (Component.Move.NMoves, SearchDepth) +type MaybeUseTranspositions = Maybe (Type.Count.NMoves, Type.Count.NPlies) -- | The depth to search for each /logical colour/. -type SearchDepthByLogicalColour = Data.Map.Strict.Map Attribute.LogicalColour.LogicalColour SearchDepth +type SearchDepthByLogicalColour = Data.Map.Strict.Map Attribute.LogicalColour.LogicalColour Type.Count.NPlies -- | Defines options related to searching for a move. data SearchOptions = MkSearchOptions { - getSortOnStandardOpeningMoveFrequency :: SortOnStandardOpeningMoveFrequency, + getSortOnStandardOpeningMoveFrequency :: SortOnStandardOpeningMoveFrequency, -- ^ Whether to sort moves on the decreasing frequency of occurrence in standard openings. getMaybeCaptureMoveSortAlgorithm :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm, - getMaybeMinimumHammingDistance :: Maybe HammingDistance, - getMaybeRetireKillerMovesAfter :: MaybeRetireAfterNMoves, - getTrapRepeatedPositions :: TrapRepeatedPositions, - getUsePondering :: UsePondering, + getMaybeMinimumHammingDistance :: Maybe HammingDistance, -- ^ The optional minimum Hamming-distance between the random numbers from which Zobrist-hashes are composed. + getMaybeRetireKillerMovesAfter :: MaybeRetireAfterNMoves, -- ^ The number of full moves (one for each player) after which to retire killer moves. + getTrapRepeatedPositions :: TrapRepeatedPositions, -- ^ Whether to short-circuit the fitness-evaluation of /position/s which have been visited before in the current /game/. + getUsePondering :: UsePondering, -- ^ Whether to ponder about one's next move while the opponent is thinking. getMaybeUseTranspositions :: MaybeUseTranspositions, getStandardOpeningOptions :: Input.StandardOpeningOptions.StandardOpeningOptions, - getSearchDepthByLogicalColour :: SearchDepthByLogicalColour + getSearchDepthByLogicalColour :: SearchDepthByLogicalColour -- ^ The depth to search for each /logical colour/. } deriving Eq instance Control.DeepSeq.NFData SearchOptions where @@ -297,13 +293,13 @@ ) ( HXT.xpAttrImplied minimumHammingDistanceTag HXT.xpInt ) ( - HXT.xpAttrImplied retireKillerMovesAfterTag HXT.xpInt + HXT.xpAttrImplied retireKillerMovesAfterTag HXT.xpickle {-NMoves-} ) ( getTrapRepeatedPositions def `HXT.xpDefault` HXT.xpAttr trapRepeatedPositionsTag HXT.xpickle {-Bool-} ) ( getUsePondering def `HXT.xpDefault` HXT.xpAttr usePonderingTag HXT.xpickle {-Bool-} ) ( - HXT.xpOption . HXT.xpElem "transpositions" $ HXT.xpAttr retireTranspositionsAfterTag HXT.xpInt `HXT.xpPair` HXT.xpAttr minimumTranspositionSearchDepthTag HXT.xpInt + HXT.xpOption . HXT.xpElem "transpositions" $ HXT.xpAttr retireTranspositionsAfterTag HXT.xpickle {-NMoves-} `HXT.xpPair` HXT.xpAttr minimumTranspositionSearchDepthTag HXT.xpickle {-NPlies-} ) HXT.xpickle {-standardOpeningOptions-} ( HXT.xpElem searchDepthByLogicalColourTag . HXT.xpWrap ( Data.Map.Strict.fromList . ( @@ -316,7 +312,7 @@ Data.Map.Strict.toList -- Deconstruct to a List. ) . HXT.xpList {-potentially null-} . HXT.xpElem ( showString "by" $ Text.Case.toUpperInitial Attribute.LogicalColour.tag - ) $ HXT.xpickle {-LogicalColour-} `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpInt + ) $ HXT.xpickle {-LogicalColour-} `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpickle {-NPlies-} ) where def = Data.Default.def @@ -365,7 +361,7 @@ } -- | Get either player's search-depth, using a default value when none are defined. -getSearchDepth :: SearchOptions -> SearchDepth +getSearchDepth :: SearchOptions -> Type.Count.NPlies getSearchDepth MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } = Data.Maybe.fromMaybe defaultSearchDepth . Data.Maybe.listToMaybe $ Data.Map.Strict.elems searchDepthByLogicalColour -- Manual players don't have a searchDepth, so use the opponent's settings. -- | Self-documentation. @@ -377,17 +373,17 @@ -- | When to retire transpositions. maybeRetireTranspositionsAfter :: SearchOptions -> MaybeRetireAfterNMoves -maybeRetireTranspositionsAfter MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap fst maybeUseTranspositions +maybeRetireTranspositionsAfter MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap fst {-NMoves-} maybeUseTranspositions -- | The search-depth beneath which transpositions aren't recorded. -maybeMinimumTranspositionSearchDepth :: SearchOptions -> Maybe SearchDepth -maybeMinimumTranspositionSearchDepth MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap snd maybeUseTranspositions +maybeMinimumTranspositionSearchDepth :: SearchOptions -> Maybe Type.Count.NPlies +maybeMinimumTranspositionSearchDepth MkSearchOptions { getMaybeUseTranspositions = maybeUseTranspositions } = fmap snd {-NPlies-} maybeUseTranspositions -- | The type of a function used to transform 'SearchOptions'. type Transformation = SearchOptions -> SearchOptions -- | Mutator. -setSearchDepth :: SearchDepth -> Transformation +setSearchDepth :: Type.Count.NPlies -> Transformation setSearchDepth searchDepth searchOptions@MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } | searchDepth < minimumSearchDepth = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.setSearchDepth:\t" . showString searchDepthTag . Text.ShowList.showsAssociation $ shows searchDepth " must be positive." | otherwise = searchOptions { getSearchDepthByLogicalColour = Data.Map.Strict.map (const searchDepth) searchDepthByLogicalColour } @@ -400,5 +396,12 @@ getSearchDepthByLogicalColour = Data.Map.Strict.mapKeys Property.Opposable.getOpposite searchDepthByLogicalColour } +-- | 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 MkSearchOptions { + getSearchDepthByLogicalColour = searchDepthByLogicalColour +} = Data.Map.Strict.keys searchDepthByLogicalColour + -- | Self-documentation. type Reader = Control.Monad.Reader.Reader SearchOptions + 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 @@ -51,8 +51,7 @@ isCECPManualMode ) where -import BishBosh.Data.Integral() -- For 'HXT.XmlPickler NDecimalDigits'. -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import qualified BishBosh.Data.Either as Data.Either import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.CECPFeatures as Input.CECPFeatures @@ -61,8 +60,8 @@ import qualified BishBosh.Input.Verbosity as Input.Verbosity import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Arboreal as Property.Arboreal -import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Default @@ -82,7 +81,7 @@ nDecimalDigitsTag = "nDecimalDigits" -- | The maximum number of decimal digits that can be represented using a double-precision floating-point number. -maxNDecimalDigits :: Property.ShowFloat.NDecimalDigits +maxNDecimalDigits :: Type.Count.NDecimalDigits maxNDecimalDigits = floor $ fromIntegral ( floatDigits ( undefined :: Double -- CAVEAT: the actual type could be merely 'Float', but that's currently unknown. @@ -90,21 +89,18 @@ ) * (logBase 10 2 :: Double) -- | Self-documentation. -type EitherNativeUIOrCECPOptions row column = Either (Input.NativeUIOptions.NativeUIOptions row column) Input.CECPOptions.CECPOptions +type EitherNativeUIOrCECPOptions = Either Input.NativeUIOptions.NativeUIOptions Input.CECPOptions.CECPOptions -- | Defines the application's user-interface. -data UIOptions row column = MkUIOptions { - getMoveNotation :: Notation.MoveNotation.MoveNotation, -- ^ The notation used to describe /move/s. - getMaybePrintMoveTree :: Maybe Property.Arboreal.Depth, -- ^ Print the move-tree to the specified depth. - getNDecimalDigits :: Property.ShowFloat.NDecimalDigits, -- ^ The precision to which fractional auxiliary data is displayed. - getEitherNativeUIOrCECPOptions :: EitherNativeUIOrCECPOptions row column, -- ^ When a native display is configured some additional style-parameters are required. - getVerbosity :: Input.Verbosity.Verbosity -- ^ Set the threshold for ancillary information-output. +data UIOptions = MkUIOptions { + getMoveNotation :: Notation.MoveNotation.MoveNotation, -- ^ The notation used to describe /move/s. + getMaybePrintMoveTree :: Maybe Property.Arboreal.Depth, -- ^ Print the move-tree to the specified depth. + getNDecimalDigits :: Type.Count.NDecimalDigits, -- ^ The precision to which fractional auxiliary data is displayed. + getEitherNativeUIOrCECPOptions :: EitherNativeUIOrCECPOptions, -- ^ When a native display is configured some additional style-parameters are required. + getVerbosity :: Input.Verbosity.Verbosity -- ^ Set the threshold for ancillary information-output. } deriving Eq -instance ( - Control.DeepSeq.NFData column, - Control.DeepSeq.NFData row - ) => Control.DeepSeq.NFData (UIOptions row column) where +instance Control.DeepSeq.NFData UIOptions where rnf MkUIOptions { getMoveNotation = moveNotation, getMaybePrintMoveTree = maybePrintMoveTree, @@ -119,7 +115,7 @@ verbosity ) -instance (Show row, Show column) => Show (UIOptions row column) where +instance Show UIOptions where showsPrec _ MkUIOptions { getMoveNotation = moveNotation, getMaybePrintMoveTree = maybePrintMoveTree, @@ -136,17 +132,14 @@ nDecimalDigitsTag, shows nDecimalDigits ), - either ( - (,) Input.NativeUIOptions.tag . shows - ) ( - (,) Input.CECPOptions.tag . shows - ) eitherNativeUIOrCECPOptions, ( + (,) Input.NativeUIOptions.tag . shows ||| (,) Input.CECPOptions.tag . shows $ eitherNativeUIOrCECPOptions, + ( Input.Verbosity.tag, shows verbosity ) ] -instance (Num row, Num column) => Data.Default.Default (UIOptions row column) where +instance Data.Default.Default UIOptions where def = MkUIOptions { getMoveNotation = Data.Default.def, getMaybePrintMoveTree = Nothing, @@ -155,14 +148,7 @@ getVerbosity = Data.Default.def } -instance ( - HXT.XmlPickler column, - HXT.XmlPickler row, - Integral column, - Integral row, - Show column, - Show row - ) => HXT.XmlPickler (UIOptions row column) where +instance HXT.XmlPickler UIOptions where xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d, e) -> mkUIOptions a b c d e, -- Construct. \MkUIOptions { @@ -193,21 +179,21 @@ mkUIOptions :: Notation.MoveNotation.MoveNotation -- ^ The chess-notation used to describe /move/s. -> Maybe Property.Arboreal.Depth - -> Property.ShowFloat.NDecimalDigits -- ^ The precision to which fractional auxiliary data is displayed. - -> EitherNativeUIOrCECPOptions row column + -> Type.Count.NDecimalDigits -- ^ The precision to which fractional auxiliary data is displayed. + -> EitherNativeUIOrCECPOptions -> Input.Verbosity.Verbosity -- ^ Set the threshold for logging. - -> UIOptions row column + -> UIOptions mkUIOptions moveNotation maybePrintMoveTree nDecimalDigits eitherNativeUIOrCECPOptions verbosity | Just depth <- maybePrintMoveTree - , depth <= 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . showString printMoveTreeTag . Text.ShowList.showsAssociation $ shows depth " must exceed zero." + , depth <= 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . showString printMoveTreeTag . Text.ShowList.showsAssociation $ shows depth " must exceed zero." | nDecimalDigits < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . showString nDecimalDigitsTag . Text.ShowList.showsAssociation $ shows nDecimalDigits " must exceed zero." | nDecimalDigits > maxNDecimalDigits = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . showString nDecimalDigitsTag . Text.ShowList.showsAssociation . shows nDecimalDigits . showString " shouldn't exceed " $ shows maxNDecimalDigits "." | ( - const False `either` const True - ) eitherNativeUIOrCECPOptions && not ( + const False ||| const True $ eitherNativeUIOrCECPOptions + ) && not ( Notation.MoveNotation.isPureCoordinate moveNotation ) = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . shows Input.CECPOptions.tag . showString " is incompatible with " . showString Notation.MoveNotation.tag . Text.ShowList.showsAssociation $ shows moveNotation "." - | otherwise = MkUIOptions { + | otherwise = MkUIOptions { getMoveNotation = moveNotation, getMaybePrintMoveTree = maybePrintMoveTree, getNDecimalDigits = nDecimalDigits, @@ -216,24 +202,22 @@ } -- | Whether the chess-engine has been temporarily turned-off in order to set-up pieces. -isCECPManualMode :: UIOptions row column -> Bool -isCECPManualMode MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = ( - const False `either` ( - uncurry (||) . (Input.CECPOptions.getEditMode &&& Input.CECPOptions.getForceMode) - ) - ) eitherNativeUIOrCECPOptions +isCECPManualMode :: UIOptions -> Bool +isCECPManualMode MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = const False ||| ( + uncurry (||) . (Input.CECPOptions.getEditMode &&& Input.CECPOptions.getForceMode) + ) $ eitherNativeUIOrCECPOptions -- | The type of a function used to transform 'UIOptions'. -type Transformation row column = UIOptions row column -> UIOptions row column +type Transformation = UIOptions -> UIOptions -- | Mutator. -updateCECPFeature :: Input.CECPFeatures.Feature -> Transformation row column +updateCECPFeature :: Input.CECPFeatures.Feature -> Transformation updateCECPFeature feature uiOptions@MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = uiOptions { getEitherNativeUIOrCECPOptions = Input.CECPOptions.updateFeature feature `fmap` eitherNativeUIOrCECPOptions } -- | Mutator. -deleteCECPFeature :: Input.CECPFeatures.Feature -> Transformation row column +deleteCECPFeature :: Input.CECPFeatures.Feature -> Transformation deleteCECPFeature feature uiOptions@MkUIOptions { getEitherNativeUIOrCECPOptions = eitherNativeUIOrCECPOptions } = uiOptions { getEitherNativeUIOrCECPOptions = Input.CECPOptions.deleteFeature feature `fmap` eitherNativeUIOrCECPOptions } diff --git a/src-lib/BishBosh/Metric/CriterionValue.hs b/src-lib/BishBosh/Metric/CriterionValue.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Metric/CriterionValue.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP #-} +{- + 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 value of a single /criterion/, which quantifies the significance of some concept; + many such criteria may exist, & their weighted-mean drives automated selection of /move/s. + + * Each /criterion-value/ is normalised into the /signed closed unit-interval/. +-} + +module BishBosh.Metric.CriterionValue( +-- * Types +-- ** Data-types + CriterionValue(), +-- ** Constructor +-- mkCriterionValue +) where + +import qualified BishBosh.Type.Mass as Type.Mass + +#ifdef USE_NEWTYPE_WRAPPERS +import qualified BishBosh.Data.Exception as Data.Exception +import qualified Control.Exception + +{- | + * Quantifies some criterion; the larger the signed value, the better. + + * N.B.: the type-constructor is a peg on which to hang class-instances & its data-constructor guards the permissible bounds. +-} +newtype CriterionValue = MkCriterionValue Type.Mass.CriterionValue deriving (Eq, Ord) + +instance Show CriterionValue where + 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 + fromInteger = mkCriterionValue . fromInteger + 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. + fromRational = mkCriterionValue . fromRational + +instance Real CriterionValue where + toRational (MkCriterionValue criterionValue) = toRational criterionValue + +-- | Smart constructor. +mkCriterionValue :: Type.Mass.CriterionValue -> CriterionValue +mkCriterionValue criterionValue + | abs criterionValue > 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Metric.CriterionValue.mkCriterionValue:\t" $ shows criterionValue " must be within the closed interval '[-1,1]'." + | otherwise = MkCriterionValue criterionValue +#else +-- | Quantifies some criterion; the larger the signed value, the better. +type CriterionValue = Type.Mass.CriterionValue +#endif + diff --git a/src-lib/BishBosh/Metric/CriterionWeight.hs b/src-lib/BishBosh/Metric/CriterionWeight.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Metric/CriterionWeight.hs @@ -0,0 +1,96 @@ +{- + 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 weight associated with some 'Metric.CriterionValue.CriterionValue'. + + * Each weighting is constrained to the unsigned /closed unit-interval/; negative values aren't permitted. + + * If the /criterion-value/ is considered unimportant, then its weight can be set to @0@, whilst concepts of great significance can be set to @1@. +-} + +module BishBosh.Metric.CriterionWeight( +-- * Types +-- ** Data-types + CriterionWeight( +-- MkCriterionWeight, +-- deconstruct + ) +-- * Functions +-- ** Constructor +-- mkCriterionWeight +) where + +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Num as Data.Num +import qualified BishBosh.Type.Mass as Type.Mass +import qualified Control.DeepSeq +import qualified Control.Exception +import qualified Data.Default +import qualified Text.XML.HXT.Arrow.Pickle as HXT + +{- | + * Quantifies the relative significance of a /criterion-value/; the larger the weight, the more significant the criterion is relative to other criteria. + + * N.B.: the type-constructor is a peg on which to hang class-instances & its data-constructor guards the permissible bounds. +-} +newtype CriterionWeight = MkCriterionWeight { + deconstruct :: Type.Mass.CriterionWeight +} deriving (Eq, Ord) + +instance Show CriterionWeight where + 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 + fromInteger = mkCriterionWeight . fromInteger + 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. + fromRational = mkCriterionWeight . fromRational + +instance Real CriterionWeight where + toRational (MkCriterionWeight criterionWeight) = toRational criterionWeight + +instance Bounded CriterionWeight where + minBound = MkCriterionWeight 0 + maxBound = MkCriterionWeight 1 + +instance Data.Default.Default CriterionWeight where + def = minBound + +instance Control.DeepSeq.NFData CriterionWeight where + rnf (MkCriterionWeight criterionWeight) = Control.DeepSeq.rnf criterionWeight + +instance HXT.XmlPickler CriterionWeight where + xpickle = HXT.xpWrap (mkCriterionWeight, deconstruct) HXT.xpickle + +-- | Smart constructor. +mkCriterionWeight :: Type.Mass.CriterionWeight -> CriterionWeight +mkCriterionWeight criterionWeight + | Data.Num.inClosedUnitInterval criterionWeight = MkCriterionWeight criterionWeight + | otherwise = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Metric.CriterionWeight.mkCriterionWeight:\t" $ shows criterionWeight " must be within the closed unit-interval '[0,1]'." + diff --git a/src-lib/BishBosh/Metric/RankValue.hs b/src-lib/BishBosh/Metric/RankValue.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Metric/RankValue.hs @@ -0,0 +1,97 @@ +{- + 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@] + + * The relative value of a /rank/ of chess-piece. + + * +-} + +module BishBosh.Metric.RankValue( +-- * Types +-- ** Data-types + RankValue( +-- MkRankValue, +-- deconstruct + ), +-- * Constants +-- tag, +-- * Functions +-- ** Constructor +-- mkRankValue +) where + +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Num as Data.Num +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Type.Mass as Type.Mass +import qualified Control.Arrow +import qualified Control.DeepSeq +import qualified Control.Exception +import qualified Data.List.Extra +import qualified Text.XML.HXT.Arrow.Pickle as HXT + +-- | Used to qualify XML. +tag :: String +tag = "rankValue" + +-- | The constant value associated with a /rank/; the higher, the more valuable it is considered to be. +newtype RankValue = MkRankValue { + deconstruct :: Type.Mass.RankValue +} deriving (Eq, Ord) + +instance Show RankValue where + showsPrec precision MkRankValue { deconstruct = rankValue } = showsPrec precision rankValue + +instance Read RankValue where + 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 + +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 + fromInteger = mkRankValue . fromInteger + 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. + fromRational = mkRankValue . fromRational + +instance Real RankValue where + toRational MkRankValue { deconstruct = rankValue } = toRational rankValue + +instance Control.DeepSeq.NFData RankValue where + rnf MkRankValue { deconstruct = rankValue } = Control.DeepSeq.rnf rankValue + +instance HXT.XmlPickler RankValue where + xpickle = HXT.xpWrap (mkRankValue, deconstruct) $ HXT.xpAttr tag HXT.xpickle + +-- | Smart constructor. +mkRankValue :: Type.Mass.RankValue -> RankValue +mkRankValue rankValue + | Data.Num.inClosedUnitInterval rankValue = MkRankValue rankValue + | otherwise = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Metric.RankValue.mkRankValue:\t" $ shows rankValue " must be within the closed unit-interval [0,1]." + diff --git a/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs b/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Metric/WeightedMeanAndCriterionValues.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{- + 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@] The unweighted values of each criterion used to assess the fitness of a position, & the resulting weighted mean. +-} + +module BishBosh.Metric.WeightedMeanAndCriterionValues( +-- * Types +-- ** Data-types + WeightedMeanAndCriterionValues( +-- MkWeightedMeanAndCriterionValues, + getWeightedMean, + getCriterionValues + ), +-- * Constants + criterionValuesTag, + weightedMeanTag, +-- * Functions + negateWeightedMean, + calculateWeightedMean, +-- ** Constructor + mkWeightedMeanAndCriterionValues +) where + +import Control.Arrow((&&&)) +import qualified BishBosh.Metric.CriterionValue as Metric.CriterionValue +import qualified BishBosh.Metric.CriterionWeight as Metric.CriterionWeight +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Mass as Type.Mass +import qualified Control.DeepSeq +import qualified Factory.Math.Statistics + +#ifdef USE_PARALLEL +import qualified Control.Parallel.Strategies +#endif + +-- | Qualifies output. +criterionValuesTag :: String +criterionValuesTag = "criterion-values" + +-- | Qualifies output. +weightedMeanTag :: String +weightedMeanTag = "weighted-mean" + +-- | A /weighted mean/ & the individual unweighted criterion-values from which it was composed. +data WeightedMeanAndCriterionValues = MkWeightedMeanAndCriterionValues { + getWeightedMean :: Type.Mass.WeightedMean, -- ^ The weighted mean of a list of criterion-values. + getCriterionValues :: [Metric.CriterionValue.CriterionValue] -- ^ The unweighted /CriterionValue/s from which the weighted mean was composed. +} deriving (Eq, Show) + +instance Control.DeepSeq.NFData WeightedMeanAndCriterionValues where + rnf MkWeightedMeanAndCriterionValues { getWeightedMean = weightedMean } = Control.DeepSeq.rnf weightedMean -- The other field is a prerequisite. + +instance Property.ShowFloat.ShowFloat WeightedMeanAndCriterionValues where + showsFloat fromDouble MkWeightedMeanAndCriterionValues { + getWeightedMean = weightedMean, + getCriterionValues = criterionValues + } = Text.ShowList.showsAssociationList' [ + (weightedMeanTag, fromDouble $ realToFrac weightedMean), + (criterionValuesTag, Text.ShowList.showsFormattedList' (fromDouble . realToFrac) criterionValues) + ] + +-- | Constructor. +mkWeightedMeanAndCriterionValues + :: Type.Mass.WeightedMean + -> [Metric.CriterionValue.CriterionValue] + -> WeightedMeanAndCriterionValues +mkWeightedMeanAndCriterionValues = MkWeightedMeanAndCriterionValues + +{- | + * Negate the /weightedMean/, but leave the criterion-values unaltered. + + * This can be used to assess the fitness of a position from the perspective of one's opponent. +-} +negateWeightedMean :: WeightedMeanAndCriterionValues -> WeightedMeanAndCriterionValues +negateWeightedMean weightedMeanAndCriterionValues@MkWeightedMeanAndCriterionValues { getWeightedMean = weightedMean } = weightedMeanAndCriterionValues { getWeightedMean = negate weightedMean } + +{- | + * Calculates the /weighted mean/ of the specified /criterion-value/s using the corresponding /criterion-weight/s. + + * Also writes individual unweighted /criterionValue/s, to facilitate post-analysis; + if the corresponding weight is @0@, evaluation of the criterion is avoided, for efficiency. + + * CAVEAT: if all weights are @0@, then the result is indeterminate. +-} +calculateWeightedMean :: [(Metric.CriterionValue.CriterionValue, Metric.CriterionWeight.CriterionWeight)] -> WeightedMeanAndCriterionValues +{-# INLINABLE calculateWeightedMean #-} +calculateWeightedMean = uncurry mkWeightedMeanAndCriterionValues . ( + Factory.Math.Statistics.getWeightedMean &&& map (realToFrac . fst) + ) +#ifdef USE_PARALLEL + . Control.Parallel.Strategies.withStrategy ( + Control.Parallel.Strategies.parList $ Control.Parallel.Strategies.evalTuple2 Control.Parallel.Strategies.rdeepseq Control.Parallel.Strategies.r0 + ) +#endif + . map ( + \(criterionValue, criterionWeight) -> (realToFrac criterionValue, realToFrac criterionWeight) :: (Type.Mass.CriterionValue, Type.Mass.CriterionWeight) + ) . filter ( + (/= 0) . snd {-criterion-weight-} -- Avoid unnecessaily evaluating criterion-values. + ) + diff --git a/src-lib/BishBosh/Model/DrawReason.hs b/src-lib/BishBosh/Model/DrawReason.hs deleted file mode 100644 --- a/src-lib/BishBosh/Model/DrawReason.hs +++ /dev/null @@ -1,100 +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@] - - * Itemises the ways in which a game may be declared a draw. - - * Each reason corresponds to a rule in chess. --} - -module BishBosh.Model.DrawReason( --- * Types --- ** Data-types - DrawReason(), --- * Constants - maximumConsecutiveRepeatablePlies, - maximumConsecutiveRepeatablePositions, - byAgreement, --- fiftyMoveRule, - seventyFiveMoveRule, - insufficientMaterial, - staleMate, --- threeFoldRepetition, - fiveFoldRepetition -) where - -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified Control.DeepSeq - --- | The sum-type of ways in which a game can be drawn. -data DrawReason - = ByAgreement -- ^ Both players have agreed to a draw. - | FiftyMoveRule -- ^ A draw can be claimed if fifty consecutive full /move/s have occured without any capture or any @Pawn@ being moved. - | SeventyFiveMoveRule -- ^ Seventy-five consecutive full /move/s have occured without either capture or @Pawn@-movement; . - | InsufficientMaterial -- ^ Neither player as the fire-power to force /check-mate/. - | StaleMate -- ^ The next player hasn't any legal moves, but isn't /in check/. - | ThreeFoldRepetition -- ^ A draw can be claimed if the same /position/ has been reached on any three occasions. - | FiveFoldRepetition -- ^ The same /position/ has been reached on five successive occasions. - deriving (Eq, Ord, Read, Show) - -instance Control.DeepSeq.NFData DrawReason where - rnf _ = () - -instance Property.FixedMembership.FixedMembership DrawReason where - members = [ByAgreement, FiftyMoveRule, SeventyFiveMoveRule, InsufficientMaterial, StaleMate, ThreeFoldRepetition, FiveFoldRepetition] - --- | Constant. -byAgreement :: DrawReason -byAgreement = ByAgreement - --- | Constant. -fiftyMoveRule :: DrawReason -fiftyMoveRule = FiftyMoveRule - --- | Constant. -seventyFiveMoveRule :: DrawReason -seventyFiveMoveRule = SeventyFiveMoveRule - --- | Constant. -insufficientMaterial :: DrawReason -insufficientMaterial = InsufficientMaterial - --- | Constant. -staleMate :: DrawReason -staleMate = StaleMate - --- | Constant. -threeFoldRepetition :: DrawReason -threeFoldRepetition = ThreeFoldRepetition - --- | Constant. -fiveFoldRepetition :: DrawReason -fiveFoldRepetition = FiveFoldRepetition - --- | The number of consecutive plies required to trigger a draw by the seventy-five move rule. -maximumConsecutiveRepeatablePlies :: Component.Move.NPlies -maximumConsecutiveRepeatablePlies = Component.Move.nPliesPerMove * 75 - --- | The number of consecutive repeatable positions required for a draw by the five-fold repetition rule. -maximumConsecutiveRepeatablePositions :: Component.Move.NMoves -maximumConsecutiveRepeatablePositions = 5 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 @@ -32,7 +32,6 @@ module BishBosh.Model.Game( -- * Types -- ** Type-synonyms - NGames, -- InstancesByPosition, -- AvailableQualifiedMoves, -- AvailableQualifiedMovesByLogicalColour, @@ -51,7 +50,7 @@ ), -- * Functions -- inferMaybeTerminationReason, - countMovesAvailableTo, + countPliesAvailableTo, rollBack, -- listMaybePromotionRanks, -- listQualifiedMovesAvailableTo, @@ -89,7 +88,7 @@ (/~) ) where -import Control.Arrow((&&&), (***)) +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 @@ -104,9 +103,6 @@ import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Model.DrawReason as Model.DrawReason -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason -import qualified BishBosh.Model.Result as Model.Result import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.Empty as Property.Empty @@ -117,6 +113,9 @@ 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.Rule.DrawReason as Rule.DrawReason +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason +import qualified BishBosh.Rule.Result as Rule.Result import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour @@ -129,7 +128,9 @@ import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -147,9 +148,6 @@ infix 4 =~, /~ -- Same as (==) & (/=). --- | A number of games. -type NGames = Int - {- | * Focus the polymorphic key-type used by 'State.InstancesByPosition.InstancesByPosition'. @@ -193,7 +191,7 @@ 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. getInstancesByPosition :: InstancesByPosition x y, -- ^ The number of instances of various positions since the last unrepeatable move. getAvailableQualifiedMovesByLogicalColour :: AvailableQualifiedMovesByLogicalColour x y, -- ^ 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 Model.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. + getMaybeTerminationReason :: Maybe Rule.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. } instance ( @@ -272,11 +270,11 @@ Show x, Show y ) => Show (Game x y) where - showsPrec _ MkGame { + showsPrec precedence MkGame { getBoard = board, getTurnsByLogicalColour = turnsByLogicalColour, getMaybeTerminationReason = maybeTerminationReason - } = shows ( + } = showsPrec precedence ( board, turnsByLogicalColour, maybeTerminationReason @@ -292,8 +290,8 @@ Show x, Show y ) => Read (Game x y) where - {-# SPECIALISE instance Read (Game T.X T.Y) #-} - readsPrec _ = map ( + {-# SPECIALISE instance Read (Game Type.Length.X Type.Length.Y) #-} + readsPrec precedence = map ( Control.Arrow.first $ \( board, turnsByLogicalColour, @@ -308,7 +306,7 @@ getMaybeTerminationReason = maybeTerminationReason } in game - ) . reads + ) . readsPrec precedence instance ( Enum x, @@ -318,7 +316,7 @@ Show x, Show y ) => Data.Default.Default (Game x y) where - {-# SPECIALISE instance Data.Default.Default (Game T.X T.Y) #-} + {-# SPECIALISE instance Data.Default.Default (Game Type.Length.X Type.Length.Y) #-} def = ( mkGame Attribute.LogicalColour.White Data.Default.def {-castleableRooksByLogicalColour-} Data.Default.def {-board-} Data.Default.def {-turnsByLogicalColour-} ) { @@ -336,7 +334,7 @@ Show x, Show y ) => Property.ExtendedPositionDescription.ReadsEPD (Game x y) where - {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Game T.X T.Y) #-} + {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Game Type.Length.X Type.Length.Y) #-} readsEPD s = [ ( mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour, @@ -350,7 +348,7 @@ s3' -> Control.Arrow.first ( \enPassantDestination -> let opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour - in State.TurnsByLogicalColour.fromAssocs [ + in State.TurnsByLogicalColour.fromAssocs [ ( nextLogicalColour, [] @@ -400,7 +398,7 @@ Show x, Show y ) => Property.ForsythEdwards.ReadsFEN (Game x y) where - {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game T.X T.Y) #-} + {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game Type.Length.X Type.Length.Y) #-} readsFEN s = [ (game, s3) | (game, s1) <- Property.ExtendedPositionDescription.readsEPD s, @@ -431,7 +429,7 @@ Show x, Show y ) => Property.Empty.Empty (Game x y) where - {-# SPECIALISE instance Property.Empty.Empty (Game T.X T.Y) #-} + {-# SPECIALISE instance Property.Empty.Empty (Game Type.Length.X Type.Length.Y) #-} empty = Data.Default.def -- i.e. zero turns have been taken, rather than zero pieces remain (which is illegal). instance Property.Null.Null (Game x y) where @@ -451,7 +449,7 @@ Show x, Show y ) => Property.Reflectable.ReflectableOnX (Game x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Game T.X T.Y) #-} + {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Game Type.Length.X Type.Length.Y) #-} reflectOnX MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -475,7 +473,7 @@ } instance (Data.Array.IArray.Ix x, Enum x, Enum y, Ord y) => Component.Zobrist.Hashable2D Game x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - {-# SPECIALISE instance Component.Zobrist.Hashable2D Game T.X T.Y #-} + {-# SPECIALISE instance Component.Zobrist.Hashable2D Game Type.Length.X Type.Length.Y #-} listRandoms2D game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -506,7 +504,7 @@ -> State.Board.Board x y -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour x y -> Game x y -{-# SPECIALISE mkGame :: Attribute.LogicalColour.LogicalColour -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour T.X -> State.Board.Board T.X T.Y -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour T.X T.Y -> Game T.X T.Y #-} +{-# SPECIALISE mkGame :: Attribute.LogicalColour.LogicalColour -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour Type.Length.X -> State.Board.Board Type.Length.X Type.Length.Y -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y #-} 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 ( @@ -546,7 +544,7 @@ Show x, Show y ) => State.Board.Board x y -> Game x y -{-# SPECIALISE fromBoard :: State.Board.Board T.X T.Y -> Game T.X T.Y #-} +{-# SPECIALISE fromBoard :: State.Board.Board Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y #-} fromBoard board = mkGame Attribute.LogicalColour.White ( State.CastleableRooksByLogicalColour.fromBoard board ) board Property.Empty.empty {-TurnsByLogicalColour-} @@ -586,7 +584,7 @@ Ord x, Ord y ) => Attribute.LogicalColour.LogicalColour -> Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-} +{-# SPECIALISE findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} findAvailableCastlingMoves logicalColour MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, @@ -641,7 +639,7 @@ Show x, Show y ) => Component.Turn.Turn x y -> Transformation x y -{-# SPECIALISE takeTurn :: Component.Turn.Turn T.X T.Y -> Transformation T.X T.Y #-} +{-# SPECIALISE takeTurn :: Component.Turn.Turn Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} takeTurn turn game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -833,7 +831,7 @@ Show x, Show y ) => Component.QualifiedMove.QualifiedMove x y -> Transformation x y -{-# SPECIALISE applyQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Transformation T.X T.Y #-} +{-# SPECIALISE applyQualifiedMove :: Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} 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 @@ -850,11 +848,11 @@ Show x, Show y ) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Transformation x y -{-# SPECIALISE applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Transformation T.X T.Y #-} +{-# SPECIALISE applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} applyEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } = applyQualifiedMove ( - Component.QualifiedMove.mkQualifiedMove move $ either ( - ($ State.Board.getMaybePieceByCoordinates board) . State.MaybePieceByCoordinates.inferMoveType move - ) id $ Component.EitherQualifiedMove.getPromotionRankOrMoveType eitherQualifiedMove + Component.QualifiedMove.mkQualifiedMove move . ( + ($ State.Board.getMaybePieceByCoordinates board) . State.MaybePieceByCoordinates.inferMoveType move ||| id + ) $ Component.EitherQualifiedMove.getPromotionRankOrMoveType eitherQualifiedMove ) game where move = Component.EitherQualifiedMove.getMove eitherQualifiedMove @@ -871,20 +869,18 @@ -> Game x y -- ^ The /game/ to which the /move/s should be sequentially applied. -> [a] -- ^ An ordered sequence of data from which /move/s are constructed. -> Either (a, String) (Game x y) -- ^ Either a rogue datum & the corresponding error-message, or the resulting /game/. -{-# SPECIALISE applyEitherQualifiedMoves :: (a -> Either String (Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y)) -> Game T.X T.Y -> [a] -> Either (a, String) (Game T.X T.Y) #-} +{-# SPECIALISE applyEitherQualifiedMoves :: (a -> Either String (Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y)) -> Game Type.Length.X Type.Length.Y -> [a] -> Either (a, String) (Game Type.Length.X Type.Length.Y) #-} applyEitherQualifiedMoves moveConstructor = Data.List.foldl' ( \eitherGame datum -> eitherGame >>= ( - \game -> either ( - Left . (,) datum -- Constructor failed. - ) ( + \game -> Left . (,) datum {-Constructor failed-} ||| ( \eitherQualifiedMove -> Data.Maybe.maybe ( Right $ applyEitherQualifiedMove eitherQualifiedMove game - ) ( + ) ( \errorMessage -> Left ( datum, showString "board" . Text.ShowList.showsAssociation . shows (getBoard game) . showString " (" $ shows errorMessage ")" ) -- Pair. - ) $ validateEitherQualifiedMove eitherQualifiedMove game + ) $ validateEitherQualifiedMove eitherQualifiedMove game ) $ moveConstructor datum ) ) . Right @@ -905,7 +901,7 @@ => Component.QualifiedMove.QualifiedMove x y -> Game x y -- ^ Prior to playing the /qualified move/. -> Maybe String -- ^ Error-message. -{-# SPECIALISE validateQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Game T.X T.Y -> Maybe String #-} +{-# SPECIALISE validateQualifiedMove :: Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Maybe String #-} validateQualifiedMove qualifiedMove game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, @@ -1115,7 +1111,7 @@ => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Game x y -- ^ Prior to playing the /move/. -> Maybe String -- ^ Error-message. -{-# SPECIALISE validateEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Game T.X T.Y -> Maybe String #-} +{-# SPECIALISE validateEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Maybe String #-} validateEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } | State.MaybePieceByCoordinates.isVacant ( Component.Move.getSource move @@ -1130,7 +1126,7 @@ inferredMoveType :: Attribute.MoveType.MoveType inferredMoveType = State.MaybePieceByCoordinates.inferMoveType move ( - either id Attribute.Rank.getMaybePromotionRank promotionRankOrMoveType -- Discard any move-type. + id ||| Attribute.Rank.getMaybePromotionRank $ promotionRankOrMoveType -- Discard any move-type. ) maybePieceByCoordinates -- | Whether the specified /QualifiedMove/ is valid. @@ -1142,7 +1138,7 @@ Show x, Show y ) => Component.QualifiedMove.QualifiedMove x y -> Game x y -> Bool -{-# SPECIALISE isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Game T.X T.Y -> Bool #-} +{-# SPECIALISE isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} isValidQualifiedMove qualifiedMove = Data.Maybe.isNothing . validateQualifiedMove qualifiedMove -- | Whether the specified /EitherQualifiedMove/ is valid. @@ -1154,7 +1150,7 @@ Show x, Show y ) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Game x y -> Bool -{-# SPECIALISE isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Game T.X T.Y -> Bool #-} +{-# SPECIALISE isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} isValidEitherQualifiedMove eitherQualifiedMove = Data.Maybe.isNothing . validateEitherQualifiedMove eitherQualifiedMove {- | @@ -1170,7 +1166,7 @@ Show x, Show y ) => Game x y -> [(Game x y, Component.Turn.Turn x y)] -{-# SPECIALISE rollBack :: Game T.X T.Y -> [(Game T.X T.Y, Component.Turn.Turn T.X T.Y)] #-} +{-# SPECIALISE rollBack :: Game Type.Length.X Type.Length.Y -> [(Game Type.Length.X Type.Length.Y, Component.Turn.Turn Type.Length.X Type.Length.Y)] #-} rollBack = Data.List.unfoldr ( \game@MkGame { getNextLogicalColour = nextLogicalColour, @@ -1247,7 +1243,7 @@ => Attribute.LogicalColour.LogicalColour -- ^ Define the player for whom the moves are required. -> Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE listQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-} +{-# SPECIALISE listQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} listQualifiedMovesAvailableTo logicalColour game@MkGame { getBoard = board, getMaybeChecked = maybeChecked @@ -1345,7 +1341,7 @@ Show x, Show y ) => Attribute.LogicalColour.LogicalColour -> Game x y -> AvailableQualifiedMoves x y -{-# SPECIALISE mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> AvailableQualifiedMoves T.X T.Y #-} +{-# SPECIALISE mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> AvailableQualifiedMoves Type.Length.X Type.Length.Y #-} mkAvailableQualifiedMovesFor logicalColour = foldr {-maintains destination-order-} ( \qualifiedMove -> let move = Component.QualifiedMove.getMove qualifiedMove @@ -1375,7 +1371,7 @@ => Attribute.LogicalColour.LogicalColour -> Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-} +{-# SPECIALISE findQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} findQualifiedMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } | Just availableQualifiedMoves <- Data.Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [ Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType | @@ -1384,23 +1380,23 @@ ] -- List-comprehension. | otherwise = listQualifiedMovesAvailableTo logicalColour game -- Generate the list of moves for this player. --- | Count the number of moves (plies) available to the specified player. -countMovesAvailableTo :: ( +-- | Count the number of plies available to the specified player. +countPliesAvailableTo :: ( Enum x, Enum y, Ord x, Ord y, Show x, Show y - ) => Attribute.LogicalColour.LogicalColour -> Game x y -> Component.Move.NPlies -{-# SPECIALISE countMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> Component.Move.NPlies #-} -countMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } + ) => Attribute.LogicalColour.LogicalColour -> Game x y -> Type.Count.NPlies +{-# SPECIALISE countPliesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> Type.Count.NPlies #-} +countPliesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } | isTerminated game = 0 | Just availableQualifiedMoves <- Data.Map.lookup logicalColour availableQualifiedMovesByLogicalColour -- N.B.: 'findQualifiedMovesAvailableToNextPlayer' unnecessarily constructs a list. -- = length $ Data.Foldable.concat availableQualifiedMoves -- CAVEAT: terrible performance. -- = Data.Map.foldl' (flip $ (+) . length) 0 availableQualifiedMoves -- CAVEAT: poor performance. - = Data.Map.Strict.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves - | otherwise = length $ listQualifiedMovesAvailableTo logicalColour game + = fromIntegral $ Data.Map.Strict.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves + | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo logicalColour game -- | Retrieve the recorded value, or generate the list of /move/s available to the next player. findQualifiedMovesAvailableToNextPlayer :: ( @@ -1411,7 +1407,7 @@ Show x, Show y ) => Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findQualifiedMovesAvailableToNextPlayer :: Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-} +{-# SPECIALISE findQualifiedMovesAvailableToNextPlayer :: Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo nextLogicalColour game -- | Let the specified player resign. @@ -1419,7 +1415,7 @@ resignationBy logicalColour game | isTerminated game = game -- Already terminated. | otherwise = game { - getMaybeTerminationReason = Just $ Model.GameTerminationReason.mkResignation logicalColour + getMaybeTerminationReason = Just $ Rule.GameTerminationReason.mkResignation logicalColour } -- | Resignation by the player who currently holds the choice of /move/. @@ -1431,7 +1427,7 @@ agreeToADraw game | isTerminated game = game -- Already terminated. | otherwise = game { - getMaybeTerminationReason = Just $ Model.GameTerminationReason.mkDraw Model.DrawReason.byAgreement + getMaybeTerminationReason = Just $ Rule.GameTerminationReason.mkDraw Rule.DrawReason.byAgreement } -- | Whether the game has been terminated. @@ -1450,31 +1446,31 @@ Ord y, Show x, Show y - ) => Game x y -> Maybe Model.GameTerminationReason.GameTerminationReason -{-# SPECIALISE inferMaybeTerminationReason :: Game T.X T.Y -> Maybe Model.GameTerminationReason.GameTerminationReason #-} + ) => Game x y -> Maybe Rule.GameTerminationReason.GameTerminationReason +{-# SPECIALISE inferMaybeTerminationReason :: Game Type.Length.X Type.Length.Y -> Maybe Rule.GameTerminationReason.GameTerminationReason #-} inferMaybeTerminationReason game@MkGame { getBoard = board, getInstancesByPosition = instancesByPosition } | haveZeroMoves - , Just logicalColour <- getMaybeChecked game = Just $ Model.GameTerminationReason.mkCheckMate logicalColour - | otherwise = fmap Model.GameTerminationReason.mkDraw maybeDrawReason + , Just logicalColour <- getMaybeChecked game = Just $ Rule.GameTerminationReason.mkCheckMate logicalColour + | otherwise = fmap Rule.GameTerminationReason.mkDraw maybeDrawReason where haveZeroMoves :: Bool haveZeroMoves = null $ findQualifiedMovesAvailableToNextPlayer game - maybeDrawReason :: Maybe Model.DrawReason.DrawReason + maybeDrawReason :: Maybe Rule.DrawReason.DrawReason maybeDrawReason - | haveZeroMoves = Just Model.DrawReason.staleMate - | State.InstancesByPosition.anyInstancesByPosition (== Model.DrawReason.maximumConsecutiveRepeatablePositions) instancesByPosition = Just Model.DrawReason.fiveFoldRepetition - | State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition == Model.DrawReason.maximumConsecutiveRepeatablePlies = Just Model.DrawReason.seventyFiveMoveRule - | StateProperty.Censor.hasInsufficientMaterial $ State.Board.getCoordinatesByRankByLogicalColour board = Just Model.DrawReason.insufficientMaterial + | haveZeroMoves = Just Rule.DrawReason.staleMate + | State.InstancesByPosition.anyInstancesByPosition (== Rule.DrawReason.maximumConsecutiveRepeatablePositions) instancesByPosition = Just Rule.DrawReason.fiveFoldRepetition + | State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition == Rule.DrawReason.maximumConsecutiveRepeatablePlies = Just Rule.DrawReason.seventyFiveMoveRule + | StateProperty.Censor.hasInsufficientMaterial $ State.Board.getCoordinatesByRankByLogicalColour board = Just Rule.DrawReason.insufficientMaterial | otherwise = Nothing -- | Provided that the game hasn't already terminated, update the termination-reason according to whether the specified result implies either a /draw by agreement/ or a /resignation/. -updateTerminationReasonWith :: Model.Result.Result -> Transformation x y +updateTerminationReasonWith :: Rule.Result.Result -> Transformation x y updateTerminationReasonWith result game - | Just victorsLogicalColour <- Model.Result.findMaybeVictor result = resignationBy (Property.Opposable.getOpposite victorsLogicalColour) game + | Just victorsLogicalColour <- Rule.Result.findMaybeVictor result = resignationBy (Property.Opposable.getOpposite victorsLogicalColour) game | otherwise = agreeToADraw game -- | Forwards request to "State.CastleableRooksByLogicalColour". @@ -1492,7 +1488,7 @@ Ord x, Ord y ) => Game x y -> State.Position.Position x y -{-# SPECIALISE mkPosition :: Game T.X T.Y -> State.Position.Position T.X T.Y #-} +{-# SPECIALISE mkPosition :: Game Type.Length.X Type.Length.Y -> State.Position.Position Type.Length.X Type.Length.Y #-} mkPosition game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, @@ -1508,7 +1504,7 @@ Show x, Show y ) => Game x y -> InstancesByPosition x y -{-# SPECIALISE mkInstancesByPosition :: Game T.X T.Y -> InstancesByPosition T.X T.Y #-} +{-# SPECIALISE mkInstancesByPosition :: Game Type.Length.X Type.Length.Y -> InstancesByPosition Type.Length.X Type.Length.Y #-} mkInstancesByPosition = State.InstancesByPosition.mkInstancesByPosition . uncurry ( foldr $ flip (Data.Map.Strict.insertWith $ const succ) 1 . mkPosition . fst {-game-} ) . ( @@ -1532,7 +1528,7 @@ Ord x, Ord y ) => Game x y -> Game x y -> Bool -{-# SPECIALISE (=~) :: Game T.X T.Y -> Game T.X T.Y -> Bool #-} +{-# SPECIALISE (=~) :: Game Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} game =~ game' = mkPosition game == mkPosition game' -- | Whether the state of the specified /game/s is different. @@ -1557,7 +1553,7 @@ -> Game x y -- ^ The current game. -> Component.Zobrist.Zobrist x y positionHash -> positionHash -{-# SPECIALISE updateIncrementalPositionHash :: Game T.X T.Y -> T.PositionHash -> Game T.X T.Y -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash -> T.PositionHash #-} +{-# SPECIALISE updateIncrementalPositionHash :: Game Type.Length.X Type.Length.Y -> Type.Crypto.PositionHash -> Game Type.Length.X Type.Length.Y -> Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> Type.Crypto.PositionHash #-} updateIncrementalPositionHash game positionHash game' zobrist = Component.Zobrist.combine positionHash . (++) randomsFromMoveType . ( let (castleableRooksByLogicalColour, castleableRooksByLogicalColour') = ($ game) &&& ($ game') $ getCastleableRooksByLogicalColour diff --git a/src-lib/BishBosh/Model/GameTerminationReason.hs b/src-lib/BishBosh/Model/GameTerminationReason.hs deleted file mode 100644 --- a/src-lib/BishBosh/Model/GameTerminationReason.hs +++ /dev/null @@ -1,124 +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@] - - * Itemises the various reasons for terminating a game. - - * Each reason corresponds to a rule in chess. --} - -module BishBosh.Model.GameTerminationReason( --- * Types --- ** Data-types - GameTerminationReason(), --- * Function - toResult, --- ** Constructors - mkCheckMate, - mkResignation, - mkDraw, --- ** Predicates - isCheckMateBy, - isCheckMate, - isResignation, - isDraw, - isDrawByInsufficientMaterial, - isStaleMate -) where - -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Model.DrawReason as Model.DrawReason -import qualified BishBosh.Model.Result as Model.Result -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified Control.DeepSeq - --- | 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. - | Draw Model.DrawReason.DrawReason - deriving (Eq, Ord, Read, Show) - -instance Control.DeepSeq.NFData GameTerminationReason where - rnf (CheckMateOf logicalColour) = Control.DeepSeq.rnf logicalColour - rnf (ResignationBy logicalColour) = Control.DeepSeq.rnf logicalColour - rnf (Draw drawReason) = Control.DeepSeq.rnf drawReason - -instance Property.Opposable.Opposable GameTerminationReason where - getOpposite (CheckMateOf logicalColour) = CheckMateOf $ Property.Opposable.getOpposite logicalColour - getOpposite (ResignationBy logicalColour) = ResignationBy $ Property.Opposable.getOpposite logicalColour - getOpposite draw = draw - -instance Property.FixedMembership.FixedMembership GameTerminationReason where - members = map CheckMateOf Property.FixedMembership.members ++ map ResignationBy Property.FixedMembership.members ++ map Draw Property.FixedMembership.members - --- | Convert to a /result/. -toResult :: GameTerminationReason -> Model.Result.Result -toResult = Property.Opposable.getOpposite . Model.Result.mkResult . \case - CheckMateOf logicalColour -> Just logicalColour - ResignationBy logicalColour -> Just logicalColour - Draw _ -> Nothing - --- | Constructor. -mkCheckMate :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason -mkCheckMate = CheckMateOf - --- | Constructor. -mkResignation :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason -mkResignation = ResignationBy - --- | Constructor. -mkDraw :: Model.DrawReason.DrawReason -> GameTerminationReason -mkDraw = Draw - --- | Whether the game was won by the specified player. -isCheckMateBy :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason -> Bool -isCheckMateBy logicalColour (CheckMateOf logicalColour') = logicalColour /= logicalColour' -isCheckMateBy _ _ = False - --- | Whether the game terminated in check-mate. -isCheckMate :: GameTerminationReason -> Bool -isCheckMate (CheckMateOf _) = True -isCheckMate _ = False - --- | Whether the game was resigned. -isResignation :: GameTerminationReason -> Bool -isResignation (ResignationBy _) = True -isResignation _ = False - --- | Whether the game was drawn. -isDraw :: GameTerminationReason -> Bool -isDraw (Draw _) = True -isDraw _ = False - --- | Predicate. -isDrawByInsufficientMaterial :: GameTerminationReason -> Bool -isDrawByInsufficientMaterial (Draw draw) = draw == Model.DrawReason.insufficientMaterial -isDrawByInsufficientMaterial _ = False - --- | Predicate. -isStaleMate :: GameTerminationReason -> Bool -isStaleMate (Draw draw) = draw == Model.DrawReason.staleMate -isStaleMate _ = False - 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 @@ -44,7 +44,7 @@ -- staticExchangeEvaluation, -- getRankAndMove, countGames, - countMoves, + countPositions, traceRoute, sortGameTree, toMoveFrequency, @@ -67,10 +67,11 @@ import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Property.Empty as Property.Empty -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Null as Property.Null -import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Types as T +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.Default import qualified Data.Foldable @@ -83,8 +84,7 @@ -- | Forwards request to 'Component.Turn.compareByMVVLVA'. compareByMVVLVA - :: Ord rankValue - => Attribute.Rank.EvaluateRank rankValue + :: Attribute.Rank.EvaluateRank -> BareGameTree x y -> BareGameTree x y -> Ordering @@ -106,18 +106,16 @@ * CAVEAT: assumes that the battle continues until either player concludes it's disadvantageous to continue, or fire-power has been exhausted. -} -staticExchangeEvaluation :: ( - Eq x, - Eq y, - Num rankValue, - Ord rankValue - ) - => Attribute.Rank.EvaluateRank rankValue +staticExchangeEvaluation + :: (Eq x, Eq y) + => Attribute.Rank.EvaluateRank -> BareGameTree x y - -> rankValue + -> Type.Mass.RankValue staticExchangeEvaluation evaluateRank node@Data.Tree.Node { Data.Tree.rootLabel = game } = Data.Maybe.maybe 0 {-nothing taken-} (slave node) $ getMaybeImplicitlyTakenRank game where -- Find the rank of any victim. + getMaybeImplicitlyTakenRank :: Model.Game.Game x y -> Maybe Attribute.Rank.Rank getMaybeImplicitlyTakenRank game' = Attribute.MoveType.getMaybeImplicitlyTakenRank . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove =<< Model.Game.maybeLastTurn game' +-- slave :: BareGameTree x y -> 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 ( ( @@ -136,7 +134,7 @@ ) . Model.Game.maybeLastTurn ) forest'' -- Select the least valuable aggressor. in slave node'' . Data.Maybe.fromJust $ getMaybeImplicitlyTakenRank game'' -- Recurse. - ) . evaluateRank {-of victim-} + ) . realToFrac . evaluateRank {-of victim-} -- | Accessor. getRankAndMove :: Model.MoveFrequency.GetRankAndMove (BareGameTree x y) (Component.Move.Move x y) @@ -156,7 +154,7 @@ Show x, Show y ) => Data.Default.Default (GameTree x y) where - {-# SPECIALISE instance Data.Default.Default (GameTree T.X T.Y) #-} + {-# SPECIALISE instance Data.Default.Default (GameTree Type.Length.X Type.Length.Y) #-} def = fromGame Data.Default.def instance Property.Arboreal.Prunable (GameTree x y) where @@ -187,7 +185,7 @@ Show x, Show y ) => Model.Game.Game x y -> GameTree x y -{-# SPECIALISE fromGame :: Model.Game.Game T.X T.Y -> GameTree T.X T.Y #-} +{-# SPECIALISE fromGame :: Model.Game.Game Type.Length.X Type.Length.Y -> GameTree Type.Length.X Type.Length.Y #-} fromGame = MkGameTree . Data.Tree.unfoldTree ( \game -> ( game, @@ -204,12 +202,12 @@ * N.B.: some of the /game-state/s may have identical positions, reached by different sequences of /move/s. -} -countGames :: Property.Arboreal.Depth -> Model.Game.NGames -countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree T.X T.Y) +countGames :: Property.Arboreal.Depth -> Type.Count.NGames +countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree Type.Length.X Type.Length.Y) --- | Counts the number of possible plies in chess, down to the specified depth. -countMoves :: Property.Arboreal.Depth -> Model.Game.NGames -countMoves depth = pred {-the apex is constructed without moving-} . Data.Foldable.length . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree T.X T.Y) +-- | 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 Type.Length.X Type.Length.Y) -- | Trace the route down the tree which matches the specified list of turns. traceRoute @@ -228,21 +226,17 @@ {- | * Independently sorts the forest of moves at each node of the tree, without regard to runtime-data. - * Depending on preferences, the list of moves available to each game is sorted by; either those which capture a valuable piece using a cheap piece, or those which win extended battles at a specific location. + * Depending on preferences, the list of moves available from each position is sorted by; either those which capture a valuable piece using a cheap piece, or those which win extended battles at a specific location. * The above sort-algorithms are stable & can therefore be applied independently. -} -sortGameTree :: ( - Integral x, - Integral y, - Num rankValue, - Ord rankValue - ) +sortGameTree + :: (Integral x, Integral y) => Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm - -> Attribute.Rank.EvaluateRank rankValue + -> Attribute.Rank.EvaluateRank -> MoveFrequency x y -> Transformation x y -{-# SPECIALISE sortGameTree :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank T.RankValue -> MoveFrequency T.X T.Y -> Transformation T.X T.Y #-} +{-# SPECIALISE sortGameTree :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank -> MoveFrequency Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} sortGameTree maybeCaptureMoveSortAlgorithm evaluateRank standardOpeningMoveFrequency MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Data.RoseTree.mapForest ( \game -> Data.Maybe.maybe id ( \case @@ -256,8 +250,10 @@ ) bareGameTree {- | - * Count the instances of each /move/ in the specified tree, including any pre-applied to the apex game. + * Count the instances of each /move/ in the specified tree. + * CAVEAT: assumes that root game hasn't any pre-applied moves; which might occur in a test-case. + * CAVEAT: ambiguity remains regarding the /move-type/ (especially any piece taken). * CAVEAT: a node is counted as just one instance of the move, rather than the number of games which passed through that node. @@ -265,19 +261,11 @@ but then early moves would appear popular rather than just the consequence of limited choice. -} toMoveFrequency :: (Ord x, Ord y) => GameTree x y -> MoveFrequency x y -toMoveFrequency MkGameTree { - deconstruct = bareGameTree@Data.Tree.Node { Data.Tree.rootLabel = rootGame } -} = slave ( - Data.List.foldl' ( - \moveFrequency logicalColour -> Model.MoveFrequency.insertMoves logicalColour ( - Component.Turn.getRank &&& Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove - ) moveFrequency . State.TurnsByLogicalColour.dereference logicalColour $ Model.Game.getTurnsByLogicalColour rootGame - ) Property.Empty.empty {-MoveFrequency-} Property.FixedMembership.members - ) bareGameTree where - slave moveFrequency Data.Tree.Node { - Data.Tree.rootLabel = game, - Data.Tree.subForest = forest - } = Data.List.foldl' slave {-recurse-} ( - Model.MoveFrequency.insertMoves (Model.Game.getNextLogicalColour game) getRankAndMove moveFrequency forest +toMoveFrequency MkGameTree { deconstruct = bareGameTree } = slave maxBound {-logicalColour-} Property.Empty.empty {-MoveFrequency-} bareGameTree where + 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 + ) ( + Model.MoveFrequency.insertMoves logicalColour getRankAndMove moveFrequency forest ) forest 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 @@ -41,12 +41,13 @@ sortByDescendingMoveFrequency ) where +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.Component.Move as Component.Move 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 @@ -54,13 +55,13 @@ import qualified Data.Ord {- | - * Records the number of instances, by /move/, by /rank/, by /logical colour/. + * Records the number of instances, indexed by /move/, by /rank/, by /logical colour/. - * CAVEAT: no record of the /move-type/ is stored. + * CAVEAT: the /move-type/ isn't recorded. -} type InstancesByMoveByRankByLogicalColour move = Attribute.LogicalColour.ArrayByLogicalColour ( Attribute.Rank.ArrayByRank ( - Data.Map.Strict.Map move Component.Move.NMoves + Data.Map.Strict.Map move Type.Count.NPlies ) ) @@ -76,14 +77,14 @@ isNull MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.all (Data.Foldable.all Data.Map.Strict.null) instancesByMoveByRankByLogicalColour -- | Count the total number of entries. -countEntries :: MoveFrequency move -> Component.Move.NMoves +countEntries :: MoveFrequency move -> Type.Count.NPlies countEntries MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.foldl' ( Data.Foldable.foldl' $ \acc -> (acc +) . Data.Foldable.sum ) 0 instancesByMoveByRankByLogicalColour -- | Count the total number of distinct entries. -countDistinctEntries :: MoveFrequency move -> Component.Move.NMoves -countDistinctEntries MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.foldl' ( +countDistinctEntries :: MoveFrequency move -> Type.Count.NPlies +countDistinctEntries MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = fromIntegral $ Data.Foldable.foldl' ( Data.Foldable.foldl' $ \acc -> (acc +) . Data.Map.Strict.size ) 0 instancesByMoveByRankByLogicalColour @@ -102,40 +103,28 @@ -> MoveFrequency move -> [a] -- ^ The data from each of which, /rank/ & /move/ can be extracted. -> MoveFrequency move -insertMoves logicalColour getRankAndMove MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = MkMoveFrequency . \case - [] -> instancesByMoveByRankByLogicalColour +insertMoves logicalColour getRankAndMove MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = MkMoveFrequency . ( + instancesByMoveByRankByLogicalColour // + ) . return {-to List-monad-} . (,) logicalColour . ( + instancesByMoveByRank // + ) . \case [datum] -> let (rank, move) = getRankAndMove datum - instancesByMove = instancesByMoveByRank ! rank - in instancesByMoveByRankByLogicalColour // [ - ( - logicalColour, - instancesByMoveByRank // [ - ( - rank, - Data.Map.Strict.insertWith (+) move 1 instancesByMove - ) -- Pair. - ] -- Singleton. - ) -- Pair. - ] -- Singleton. - l -> instancesByMoveByRankByLogicalColour // [ + in [id &&& incrementMoveCount move . (instancesByMoveByRank !) $ rank] -- Singleton. + l -> [ ( - logicalColour, - instancesByMoveByRank // [ - ( - rank, - foldr ( - \(_, move) -> Data.Map.Strict.insertWith (+) move 1 - ) ( - instancesByMoveByRank ! rank - ) assocs --- ) | assocs@((rank, _) : _) <- Data.List.Extra.groupSortOn fst {-rank-} $ map getRankAndMove l -- CAVEAT: wastes space. - ) | assocs@((rank, _) : _) <- Data.List.Extra.groupSortBy (Data.Ord.comparing fst {-rank-}) $ map getRankAndMove l - ] -- List-comprehension. - ) -- Pair. - ] -- Singleton. + rank, + foldr ( + incrementMoveCount . snd {-move-} + ) ( + instancesByMoveByRank ! rank + ) assocs +-- ) | assocs@((rank, _) : _) <- Data.List.Extra.groupSortOn fst {-rank-} $ map getRankAndMove l -- CAVEAT: wastes space. + ) | assocs@((rank, _) : _) <- Data.List.Extra.groupSortBy (Data.Ord.comparing fst {-rank-}) $ map getRankAndMove l + ] -- List-comprehension. where instancesByMoveByRank = instancesByMoveByRankByLogicalColour ! logicalColour + incrementMoveCount = flip (Data.Map.Strict.insertWith (+)) 1 {- | * Sorts an arbitrary list on the recorded frequency of the /rank/ & /move/ accessible from each list-item. 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 @@ -36,11 +36,12 @@ import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Bits @@ -62,7 +63,7 @@ Data.Bits.FiniteBits positionHash, System.Random.Random positionHash ) => Data.Default.Default (PositionHashTree positionHash) where - def = mkPositionHashTree Data.Default.def (Data.Default.def :: Model.GameTree.GameTree T.X T.Y) + def = mkPositionHashTree Data.Default.def (Data.Default.def :: Model.GameTree.GameTree Type.Length.X Type.Length.Y) -- | Hash the specified 'game-tree/. mkPositionHashTree :: ( @@ -77,16 +78,16 @@ -> PositionHashTree positionHash mkPositionHashTree zobrist = MkPositionHashTree . fmap (`Component.Zobrist.hash2D` zobrist) . Model.GameTree.deconstruct --- | Count the number of distinct games, irrespective of the sequence of moves taken to reach that state. +-- | Count the number of distinct positions, irrespective of the sequence of moves taken to reach that terminal state. countDistinctPositions :: Ord positionHash => Property.Arboreal.Depth -> PositionHashTree positionHash - -> Model.Game.NGames -{-# SPECIALISE countDistinctPositions :: Property.Arboreal.Depth -> PositionHashTree T.PositionHash -> Model.Game.NGames #-} + -> Type.Count.NPositions +{-# SPECIALISE countDistinctPositions :: Property.Arboreal.Depth -> PositionHashTree Type.Crypto.PositionHash -> Type.Count.NPositions #-} countDistinctPositions depth MkPositionHashTree { deconstruct = barePositionHashTree } | depth < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Component.PositionHashTree.countDistinctPositions:\tdepth" . Text.ShowList.showsAssociation $ shows depth "must be positive" - | otherwise = Data.Set.size $ slave depth barePositionHashTree + | otherwise = fromIntegral . Data.Set.size $ slave depth barePositionHashTree where 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 { diff --git a/src-lib/BishBosh/Model/Result.hs b/src-lib/BishBosh/Model/Result.hs deleted file mode 100644 --- a/src-lib/BishBosh/Model/Result.hs +++ /dev/null @@ -1,98 +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 result of a /game/. --} - -module BishBosh.Model.Result( --- * Types --- ** Data-types - Result( --- VictoryBy, --- Draw - ), --- * Function - findMaybeVictor, --- ** Constructor - mkResult, --- ** Predicates - isDraw -) where - -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified Control.DeepSeq -import qualified Data.List.Extra - --- | 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. - | Draw - deriving Eq - -instance Control.DeepSeq.NFData Result where - rnf (VictoryBy logicalColour) = Control.DeepSeq.rnf logicalColour - rnf Draw = () - --- | Convert a game-termination reason into PGN's @Result@ field; . -instance Show Result where - showsPrec _ = ( - \(showsWhiteResult, showsBlackResult) -> showsWhiteResult . showChar '-' . showsBlackResult - ) . \case - VictoryBy Attribute.LogicalColour.Black -> (lose, win) - VictoryBy _ -> (win, lose) - _ -> (draw, draw) - where - lose = showChar '0' - win = showChar '1' - draw = showString "1/2" - -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)] - '1' : '/' : '2' : '-' : '1' : '/' : '2' : remainder -> [(Draw, remainder)] - _ -> [] -- No Parse. - -instance Property.Opposable.Opposable Result where - getOpposite (VictoryBy logicalColour) = VictoryBy $ Property.Opposable.getOpposite logicalColour - getOpposite _ = Draw - -instance Property.FixedMembership.FixedMembership Result where - members = Draw : map VictoryBy Property.FixedMembership.members - --- | Constructor. -mkResult :: Maybe Attribute.LogicalColour.LogicalColour -> Result -mkResult (Just logicalColour) = VictoryBy logicalColour -mkResult _ = Draw - --- | Whether the game was drawn. -isDraw :: Result -> Bool -isDraw Draw = True -isDraw _ = False - --- | Find any winner. -findMaybeVictor :: Result -> Maybe Attribute.LogicalColour.LogicalColour -findMaybeVictor (VictoryBy logicalColour) = Just logicalColour -findMaybeVictor _ = Nothing - diff --git a/src-lib/BishBosh/Notation/MoveNotation.hs b/src-lib/BishBosh/Notation/MoveNotation.hs --- a/src-lib/BishBosh/Notation/MoveNotation.hs +++ b/src-lib/BishBosh/Notation/MoveNotation.hs @@ -58,10 +58,10 @@ import qualified BishBosh.Notation.Smith as Notation.Smith import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Data.Default -import qualified Numeric import qualified Text.XML.HXT.Arrow.Pickle as HXT import qualified Text.XML.HXT.Arrow.Pickle.Schema @@ -162,6 +162,6 @@ showsNotationFloat :: MoveNotation -> (Double -> ShowS) -> a -> ShowS -- | Render the specified data in the specified notation, & to the specified number of decimal digits. -showsNotationFloatToNDecimals :: ShowNotationFloat a => MoveNotation -> Property.ShowFloat.NDecimalDigits -> a -> ShowS -showsNotationFloatToNDecimals moveNotation nDecimalDigits = showsNotationFloat moveNotation (Numeric.showFFloat $ Just nDecimalDigits) +showsNotationFloatToNDecimals :: ShowNotationFloat a => MoveNotation -> Type.Count.NDecimalDigits -> a -> ShowS +showsNotationFloatToNDecimals moveNotation = showsNotationFloat moveNotation . Property.ShowFloat.showsFloatToN' diff --git a/src-lib/BishBosh/Notation/PureCoordinate.hs b/src-lib/BishBosh/Notation/PureCoordinate.hs --- a/src-lib/BishBosh/Notation/PureCoordinate.hs +++ b/src-lib/BishBosh/Notation/PureCoordinate.hs @@ -71,7 +71,7 @@ import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.Exception import qualified Data.Char @@ -128,14 +128,14 @@ #ifdef USE_POLYPARSE -- | Parse an /x/-coordinate. abscissaParser :: Enum x => Text.Poly.TextParser x -{-# SPECIALISE abscissaParser :: Text.Poly.TextParser T.X #-} +{-# SPECIALISE abscissaParser :: Text.Poly.TextParser Type.Length.X #-} abscissaParser = ( toEnum . (+ xOriginOffset) . Data.Char.ord ) `fmap` Poly.satisfyMsg inXRange "Abscissa" -- | Parse a /y/-coordinate. ordinateParser :: Enum y => Text.Poly.TextParser y -{-# SPECIALISE ordinateParser :: Text.Poly.TextParser T.Y #-} +{-# SPECIALISE ordinateParser :: Text.Poly.TextParser Type.Length.Y #-} ordinateParser = ( toEnum . (+ yOriginOffset) . Data.Char.ord ) `fmap` Poly.satisfyMsg inYRange "Ordinate" @@ -147,7 +147,7 @@ Ord x, Ord y ) => Text.Poly.TextParser (Cartesian.Coordinates.Coordinates x y) -{-# SPECIALISE coordinatesParser :: Text.Poly.TextParser (Cartesian.Coordinates.Coordinates T.X T.Y) #-} +{-# SPECIALISE coordinatesParser :: Text.Poly.TextParser (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) #-} coordinatesParser = do x <- abscissaParser y <- ordinateParser @@ -156,12 +156,12 @@ #else /* Parsec */ -- | Parse an /x/-coordinate. abscissaParser :: Enum x => Parsec.Parser x -{-# SPECIALISE abscissaParser :: Parsec.Parser T.X #-} +{-# SPECIALISE abscissaParser :: Parsec.Parser Type.Length.X #-} abscissaParser = toEnum . (+ xOriginOffset) . Data.Char.ord <$> Parsec.satisfy inXRange "Abscissa" -- | Parse a /y/-coordinate. ordinateParser :: Enum y => Parsec.Parser y -{-# SPECIALISE ordinateParser :: Parsec.Parser T.X #-} +{-# SPECIALISE ordinateParser :: Parsec.Parser Type.Length.X #-} ordinateParser = toEnum . (+ yOriginOffset) . Data.Char.ord <$> Parsec.satisfy inYRange "Ordinate" -- | Parse a pair of /coordinates/. @@ -171,7 +171,7 @@ Ord x, Ord y ) => Parsec.Parser (Cartesian.Coordinates.Coordinates x y) -{-# SPECIALISE coordinatesParser :: Parsec.Parser (Cartesian.Coordinates.Coordinates T.X T.Y) #-} +{-# SPECIALISE coordinatesParser :: Parsec.Parser (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) #-} coordinatesParser = Cartesian.Coordinates.mkCoordinates <$> abscissaParser <*> ordinateParser #endif diff --git a/src-lib/BishBosh/Property/Opposable.hs b/src-lib/BishBosh/Property/Opposable.hs --- a/src-lib/BishBosh/Property/Opposable.hs +++ b/src-lib/BishBosh/Property/Opposable.hs @@ -32,3 +32,4 @@ -- | An interface which data which have the concept of an opposite, may implement. class Opposable a where getOpposite :: a -> a + diff --git a/src-lib/BishBosh/Property/SelfValidating.hs b/src-lib/BishBosh/Property/SelfValidating.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Property/SelfValidating.hs @@ -0,0 +1,61 @@ +{- + 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 a class to which data capable of validating itself can confirm. +-} + +module BishBosh.Property.SelfValidating( +-- * Type-classes + SelfValidating(..), +-- * Functions + findErrors, +-- ** Predicates + isValid, + isInvalid + ) where + +{- | + * This class serves data-types which must preserve compatibility beyond that which can be guarded by a smart-constructor. + + * E.g.: data-types which are constructed piece-meal & endure a temporarily invalid state. +-} +class SelfValidating a where + findInvalidity :: a -> [String] + +instance SelfValidating a => SelfValidating [a] where + findInvalidity = concatMap findInvalidity + +-- | Predicate. +isValid :: SelfValidating a => a -> Bool +isValid = null . findInvalidity + +-- | Predicate. +isInvalid :: SelfValidating a => a -> Bool +isInvalid = not . isValid + +-- | Selects relevant error-messages from the specified association-list, to facilitate implementation of 'findInvalidity'. +findErrors :: [(selfValidator -> Bool, String)] -> selfValidator -> [String] +findErrors assocs selfValidator = [ + errorMessage | + (predicate, errorMessage) <- assocs, + predicate selfValidator + ] -- List-comprehension. + diff --git a/src-lib/BishBosh/Property/ShowFloat.hs b/src-lib/BishBosh/Property/ShowFloat.hs --- a/src-lib/BishBosh/Property/ShowFloat.hs +++ b/src-lib/BishBosh/Property/ShowFloat.hs @@ -25,23 +25,23 @@ module BishBosh.Property.ShowFloat( -- * Type-classes ShowFloat(..), --- * Types --- ** Type-synonyms - NDecimalDigits, -- * Functions + showsFloatToN', showsFloatToN ) where +import qualified BishBosh.Type.Count as Type.Count import qualified Numeric --- | A number of decimals digits. -type NDecimalDigits = Int +-- | Render the specified data to the specified number of decimal digits. +showsFloatToN' :: RealFloat a => Type.Count.NDecimalDigits -> a -> ShowS +showsFloatToN' nDecimalDigits = Numeric.showFFloat (Just $ fromIntegral nDecimalDigits) -- | An alternative to 'Show', for floating-point data. class ShowFloat a where showsFloat :: (Double -> ShowS) -> a -> ShowS -- | Render the specified data to the specified number of decimal digits. -showsFloatToN :: ShowFloat a => NDecimalDigits -> a -> ShowS -showsFloatToN nDecimalDigits = showsFloat (Numeric.showFFloat $ Just nDecimalDigits) +showsFloatToN :: ShowFloat a => Type.Count.NDecimalDigits -> a -> ShowS +showsFloatToN nDecimalDigits = showsFloat $ showsFloatToN' nDecimalDigits diff --git a/src-lib/BishBosh/Property/Switchable.hs b/src-lib/BishBosh/Property/Switchable.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Property/Switchable.hs @@ -0,0 +1,53 @@ +{- + 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 a class to which IO data-types which can be switched between binary states, can conform. +-} + +module BishBosh.Property.Switchable( +-- * Type-classes + Switchable(..), +-- * Functions + flick + ) where + +import qualified Data.Foldable + +-- | For data which operate like binary switches. +class Switchable a where + on :: IO a -- ^ Returns a switch in the /on/ state, regardless of any previous state. + + toggle :: a -> IO a -- ^ Switch the binary state. + + switchOff :: a -> IO a -- ^ Turn the switch off, which has no effect if already in the /off/ state. + switchOff a + | isOn a = toggle a + | otherwise = return {-to IO-monad-} a + + isOn :: a -> Bool -- ^ Predicate: whether the switch is currently in the /on/ state. + + isOff :: a -> Bool -- ^ Predicate: whether the switch is currently in the /off/ state. + isOff = not . isOn + +-- | Toggle the switch the specified number of times. +flick :: Switchable switchable => Int -> switchable -> IO switchable +flick n switchable = Data.Foldable.foldrM ($) switchable $ replicate n toggle + diff --git a/src-lib/BishBosh/Rule/DrawReason.hs b/src-lib/BishBosh/Rule/DrawReason.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Rule/DrawReason.hs @@ -0,0 +1,102 @@ +{- + 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@] + + * Itemises the ways in which a game may be declared a draw. + + * Each reason corresponds to a rule in chess. +-} + +module BishBosh.Rule.DrawReason( +-- * Types +-- ** Data-types + DrawReason(), +-- * Constants + maximumConsecutiveRepeatablePlies, + maximumConsecutiveRepeatablePositions, + byAgreement, +-- fiftyMoveRule, + seventyFiveMoveRule, + insufficientMaterial, + staleMate, +-- threeFoldRepetition, + fiveFoldRepetition +) where + +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Type.Count as Type.Count +import qualified Control.DeepSeq + +-- | The sum-type of ways in which a game can be drawn. +data DrawReason + = ByAgreement -- ^ Both players have agreed to a draw. + | FiftyMoveRule -- ^ A draw can be claimed if fifty consecutive full /move/s have occured without any capture or any @Pawn@ being moved. + | SeventyFiveMoveRule -- ^ Seventy-five consecutive full /move/s have occured without either capture or @Pawn@-movement; . + | InsufficientMaterial -- ^ Neither player as the fire-power to force /check-mate/. + | StaleMate -- ^ The next player hasn't any legal moves, but isn't /in check/. + | ThreeFoldRepetition -- ^ A draw can be claimed if the same /position/ has been reached on any three occasions. + | FiveFoldRepetition -- ^ The same /position/ has been reached on five successive occasions. + deriving (Eq, Ord, Read, Show) + +instance Control.DeepSeq.NFData DrawReason where + rnf _ = () + +instance Property.FixedMembership.FixedMembership DrawReason where + members = [ByAgreement, FiftyMoveRule, SeventyFiveMoveRule, InsufficientMaterial, StaleMate, ThreeFoldRepetition, FiveFoldRepetition] + +-- | Constant. +byAgreement :: DrawReason +byAgreement = ByAgreement + +-- | Constant. +fiftyMoveRule :: DrawReason +fiftyMoveRule = FiftyMoveRule + +-- | Constant. +seventyFiveMoveRule :: DrawReason +seventyFiveMoveRule = SeventyFiveMoveRule + +-- | Constant. +insufficientMaterial :: DrawReason +insufficientMaterial = InsufficientMaterial + +-- | Constant. +staleMate :: DrawReason +staleMate = StaleMate + +-- | Constant. +threeFoldRepetition :: DrawReason +threeFoldRepetition = ThreeFoldRepetition + +-- | Constant. +fiveFoldRepetition :: DrawReason +fiveFoldRepetition = FiveFoldRepetition + +-- | The number of consecutive plies required to trigger a draw by the seventy-five move rule. +maximumConsecutiveRepeatablePlies :: Type.Count.NPlies +maximumConsecutiveRepeatablePlies = Component.Move.nPliesPerMove * 75 + +-- | The number of consecutive repeatable positions required for a draw by the five-fold repetition rule. +maximumConsecutiveRepeatablePositions :: Type.Count.NPositions +maximumConsecutiveRepeatablePositions = 5 + diff --git a/src-lib/BishBosh/Rule/GameTerminationReason.hs b/src-lib/BishBosh/Rule/GameTerminationReason.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Rule/GameTerminationReason.hs @@ -0,0 +1,124 @@ +{-# 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@] + + * Itemises the various reasons for terminating a game. + + * Each reason corresponds to a rule in chess. +-} + +module BishBosh.Rule.GameTerminationReason( +-- * Types +-- ** Data-types + GameTerminationReason(), +-- * Function + toResult, +-- ** Constructors + mkCheckMate, + mkResignation, + mkDraw, +-- ** Predicates + isCheckMateBy, + isCheckMate, + isResignation, + isDraw, + isDrawByInsufficientMaterial, + isStaleMate +) where + +import qualified BishBosh.Attribute.LogicalColour as Attribute.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 +import qualified BishBosh.Rule.Result as Rule.Result +import qualified Control.DeepSeq + +-- | 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. + | Draw Rule.DrawReason.DrawReason + deriving (Eq, Ord, Read, Show) + +instance Control.DeepSeq.NFData GameTerminationReason where + rnf (CheckMateOf logicalColour) = Control.DeepSeq.rnf logicalColour + rnf (ResignationBy logicalColour) = Control.DeepSeq.rnf logicalColour + rnf (Draw drawReason) = Control.DeepSeq.rnf drawReason + +instance Property.Opposable.Opposable GameTerminationReason where + getOpposite (CheckMateOf logicalColour) = CheckMateOf $ Property.Opposable.getOpposite logicalColour + getOpposite (ResignationBy logicalColour) = ResignationBy $ Property.Opposable.getOpposite logicalColour + getOpposite draw = draw + +instance Property.FixedMembership.FixedMembership GameTerminationReason where + members = map CheckMateOf Property.FixedMembership.members ++ map ResignationBy Property.FixedMembership.members ++ map Draw Property.FixedMembership.members + +-- | Convert to a /result/. +toResult :: GameTerminationReason -> Rule.Result.Result +toResult = Property.Opposable.getOpposite . Rule.Result.mkResult . \case + CheckMateOf logicalColour -> Just logicalColour + ResignationBy logicalColour -> Just logicalColour + Draw _ -> Nothing + +-- | Constructor. +mkCheckMate :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason +mkCheckMate = CheckMateOf + +-- | Constructor. +mkResignation :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason +mkResignation = ResignationBy + +-- | Constructor. +mkDraw :: Rule.DrawReason.DrawReason -> GameTerminationReason +mkDraw = Draw + +-- | Whether the game was won by the specified player. +isCheckMateBy :: Attribute.LogicalColour.LogicalColour -> GameTerminationReason -> Bool +isCheckMateBy logicalColour (CheckMateOf logicalColour') = logicalColour /= logicalColour' +isCheckMateBy _ _ = False + +-- | Whether the game terminated in check-mate. +isCheckMate :: GameTerminationReason -> Bool +isCheckMate (CheckMateOf _) = True +isCheckMate _ = False + +-- | Whether the game was resigned. +isResignation :: GameTerminationReason -> Bool +isResignation (ResignationBy _) = True +isResignation _ = False + +-- | Whether the game was drawn. +isDraw :: GameTerminationReason -> Bool +isDraw (Draw _) = True +isDraw _ = False + +-- | Predicate. +isDrawByInsufficientMaterial :: GameTerminationReason -> Bool +isDrawByInsufficientMaterial (Draw draw) = draw == Rule.DrawReason.insufficientMaterial +isDrawByInsufficientMaterial _ = False + +-- | Predicate. +isStaleMate :: GameTerminationReason -> Bool +isStaleMate (Draw draw) = draw == Rule.DrawReason.staleMate +isStaleMate _ = False + diff --git a/src-lib/BishBosh/Rule/Result.hs b/src-lib/BishBosh/Rule/Result.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Rule/Result.hs @@ -0,0 +1,98 @@ +{-# 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 result of a /game/. +-} + +module BishBosh.Rule.Result( +-- * Types +-- ** Data-types + Result( +-- VictoryBy, +-- Draw + ), +-- * Function + findMaybeVictor, +-- ** Constructor + mkResult, +-- ** Predicates + isDraw +) where + +import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified Control.DeepSeq +import qualified Data.List.Extra + +-- | 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. + | Draw + deriving Eq + +instance Control.DeepSeq.NFData Result where + rnf (VictoryBy logicalColour) = Control.DeepSeq.rnf logicalColour + rnf Draw = () + +-- | Convert a game-termination reason into PGN's @Result@ field; . +instance Show Result where + showsPrec _ = ( + \(showsWhiteResult, showsBlackResult) -> showsWhiteResult . showChar '-' . showsBlackResult + ) . \case + VictoryBy Attribute.LogicalColour.Black -> (lose, win) + VictoryBy _ -> (win, lose) + _ -> (draw, draw) + where + lose = showChar '0' + win = showChar '1' + draw = showString "1/2" + +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)] + '1' : '/' : '2' : '-' : '1' : '/' : '2' : remainder -> [(Draw, remainder)] + _ -> [] -- No Parse. + +instance Property.Opposable.Opposable Result where + getOpposite (VictoryBy logicalColour) = VictoryBy $ Property.Opposable.getOpposite logicalColour + getOpposite _ = Draw + +instance Property.FixedMembership.FixedMembership Result where + members = Draw : map VictoryBy Property.FixedMembership.members + +-- | Constructor. +mkResult :: Maybe Attribute.LogicalColour.LogicalColour -> Result +mkResult (Just logicalColour) = VictoryBy logicalColour +mkResult _ = Draw + +-- | Whether the game was drawn. +isDraw :: Result -> Bool +isDraw Draw = True +isDraw _ = False + +-- | Find any winner. +findMaybeVictor :: Result -> Maybe Attribute.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 @@ -41,13 +41,12 @@ -- updateTranspositions, negaMax, -- negateFitnessOfResult, --- addNMovesToResult +-- addNPositionsToResult ) where import BishBosh.Model.Game((=~)) import Control.Applicative((<|>)) import Control.Arrow((&&&)) -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Data.Exception as Data.Exception @@ -64,7 +63,9 @@ import qualified BishBosh.Search.TranspositionValue as Search.TranspositionValue import qualified BishBosh.State.InstancesByPosition as State.InstancesByPosition import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Control.Monad.Reader import qualified Data.Default @@ -72,29 +73,29 @@ import qualified Data.Tree -- | The type returned by 'negaMax'. -data Result x y positionHash criterionValue weightedMean = MkResult { +data Result x y positionHash = MkResult { getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData x y positionHash, -- ^ Killer moves & transpositions. - getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean, - getNPliesEvaluated :: Component.Move.NPlies -- ^ The total number of nodes analysed, before making the selection. + getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y, + getNPositionsEvaluated :: Type.Count.NPositions -- ^ The total number of nodes analysed, before making the selection. } {- | - * Drop the specified number of /turn/s; typically those made before starting the search. + * Drop the specified number of plies; typically those made before starting the search. * CAVEAT: abandons the fitness component of the quantified game. -} extractSelectedTurns - :: Component.Move.NPlies - -> Result x y positionHash criterionValue weightedMean - -> (Search.DynamicMoveData.DynamicMoveData x y positionHash, [Component.Turn.Turn x y], Component.Move.NPlies) + :: Type.Count.NPlies + -> Result x y positionHash + -> (Search.DynamicMoveData.DynamicMoveData x y positionHash, [Component.Turn.Turn x y], Type.Count.NPositions) extractSelectedTurns nPlies MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = quantifiedGame, - getNPliesEvaluated = nPliesEvaluated + getNPositionsEvaluated = nPositionsEvaluated } = ( dynamicMoveData, Evaluation.QuantifiedGame.getLatestTurns nPlies quantifiedGame, - nPliesEvaluated + nPositionsEvaluated ) -- | Record the last move as a killer, unless it's a capture move. @@ -126,16 +127,15 @@ Eq y, Enum x, Enum y, - Real weightedMean, Show x, Show y ) - => Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + => Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> Search.TranspositionValue.TranspositionValue (Component.QualifiedMove.QualifiedMove x y) - -> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean + -> Evaluation.QuantifiedGame.QuantifiedGame x y 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" $ ( - Notation.MoveNotation.showsNotationFloatToNDecimals Data.Default.def {-move-notation-} 3 {-decimal digits-} $ Property.Arboreal.prune inferredSearchDepth positionHashQuantifiedGameTree + Notation.MoveNotation.showsNotationFloatToNDecimals Data.Default.def {-move-notation-} 3 {-decimal digits-} $ Property.Arboreal.prune (fromIntegral inferredSearchDepth) positionHashQuantifiedGameTree ) "" ) ( ( @@ -153,15 +153,14 @@ Enum x, Enum y, Ord positionHash, - Real weightedMean, Show x, Show y ) => Search.TranspositionValue.IsOptimal - -> Component.Move.NPlies + -> Type.Count.NPlies -> positionHash -> [Component.Turn.Turn x y] - -> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + -> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> Search.DynamicMoveData.Transformation x y positionHash updateTranspositions isOptimal nPlies positionHash turns positionHashQuantifiedGameTree = Search.DynamicMoveData.updateTranspositions . Search.Transpositions.insert ( Evaluation.QuantifiedGame.getFitness . findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree @@ -177,18 +176,16 @@ negaMax :: ( Enum x, Enum y, - Eq criterionValue, Ord positionHash, Ord x, Ord y, - Real weightedMean, Show x, Show y ) - => Input.SearchOptions.SearchDepth -- ^ The depth to which the tree should be searched; i.e. the number of plies to look-ahead. - -> Search.SearchState.SearchState x y positionHash criterionValue weightedMean - -> Input.SearchOptions.Reader (Result x y positionHash criterionValue weightedMean) -{-# SPECIALISE negaMax :: Input.SearchOptions.SearchDepth -> Search.SearchState.SearchState T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean -> Input.SearchOptions.Reader (Result T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean) #-} + => Type.Count.NPlies -- ^ The depth to which the tree should be searched; i.e. the number of plies to look-ahead. + -> Search.SearchState.SearchState x y positionHash + -> Input.SearchOptions.Reader (Result x y positionHash) +{-# SPECIALISE negaMax :: Type.Count.NPlies -> Search.SearchState.SearchState Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> Input.SearchOptions.Reader (Result Type.Length.X Type.Length.Y Type.Crypto.PositionHash) #-} negaMax initialSearchDepth initialSearchState = do maybeMinimumTranspositionSearchDepth <- Control.Monad.Reader.asks Input.SearchOptions.maybeMinimumTranspositionSearchDepth recordKillerMoves <- Control.Monad.Reader.asks Input.SearchOptions.recordKillerMoves @@ -198,16 +195,16 @@ getNPlies = State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour -- Abbreviate. {- descend - :: Evaluation.QuantifiedGame.OpenInterval x y criterionValue weightedMean - -> Input.SearchOptions.SearchDepth - -> Search.SearchState.SearchState x y positionHash criterionValue weightedMean - -> Result x y positionHash criterionValue weightedMean + :: Evaluation.QuantifiedGame.OpenInterval x y + -> Type.Count.NPlies + -> Search.SearchState.SearchState x y positionHash + -> Result x y positionHash -} descend (maybeAlphaQuantifiedGame, maybeBetaQuantifiedGame) searchDepth searchState | searchDepth == 0 || Model.Game.isTerminated game = MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = Evaluation.QuantifiedGame.negateFitness quantifiedGame, -- CAVEAT: zero new moves have been applied, so the last move was the opponent's. - getNPliesEvaluated = 1 -- Fitness-negation requires evaluation. + getNPositionsEvaluated = 1 -- Fitness-negation requires evaluation. } -- Terminate the recursion. | useTranspositions , Just transpositionValue <- Search.Transpositions.find positionHash $ Search.DynamicMoveData.getTranspositions dynamicMoveData -- Look for a previously encountered position with a matching positionHash. @@ -225,7 +222,7 @@ then MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = Control.Exception.assert (transposedQuantifiedGame == getQuantifiedGame selectMaxUsingTranspositions) transposedQuantifiedGame, - getNPliesEvaluated = 0 + getNPositionsEvaluated = 0 } else Data.Maybe.maybe selectMaxUsingTranspositions ( \betaQuantifiedGame -> if Evaluation.QuantifiedGame.compareFitness transposedQuantifiedGame betaQuantifiedGame == LT @@ -233,7 +230,7 @@ else MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = Control.Exception.assert (betaQuantifiedGame == getQuantifiedGame selectMaxUsingTranspositions) betaQuantifiedGame, - getNPliesEvaluated = 0 + getNPositionsEvaluated = 0 } ) maybeBetaQuantifiedGame | otherwise = selectMaxWithSorter id @@ -259,13 +256,13 @@ {- selectMax :: Search.DynamicMoveData.DynamicMoveData x y positionHash - -> Maybe (Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean) - -> [Evaluation.PositionHashQuantifiedGameTree.BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean] - -> Result x y positionHash criterionValue weightedMean + -> Maybe (Evaluation.QuantifiedGame.QuantifiedGame x y) + -> [Evaluation.PositionHashQuantifiedGameTree.BarePositionHashQuantifiedGameTree x y positionHash] + -> Result x y positionHash -} selectMax dynamicMoveData' maybeAlphaQuantifiedGame' (node : remainingNodes) | trapRepeatedPositions - , nDistinctPositions >= 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 when its 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' ( @@ -285,8 +282,8 @@ ) dynamicMoveData'', getQuantifiedGame = betaQuantifiedGame } -- Beta-cutoff; the solution-space is either zero or negative. - | otherwise = addNMovesToResult ( - getNPliesEvaluated result'' + | otherwise = addNPositionsToResult ( + getNPositionsEvaluated result'' ) $ let isFitter = Data.Maybe.maybe True {-alpha is undefined => anything qualifies-} ( \alphaQuantifiedGame -> case quantifiedGame'' `Evaluation.QuantifiedGame.compareFitness` alphaQuantifiedGame of @@ -327,7 +324,7 @@ Control.Exception.throw . Data.Exception.mkResultUndefined . showString "BishBosh.Search.AlphaBeta.negaMax.descend.selectMax:\tthere are zero nodes to process, but neither alpha nor beta is defined; " $ shows game "." ) maybeBetaQuantifiedGame -- Return the only viable position known. ) maybeAlphaQuantifiedGame', -- Return the fittest viable position found. - getNPliesEvaluated = 0 + getNPositionsEvaluated = 0 } -- Zero moves remain => terminate the recursion. return {-to Reader-monad-} . ( \result@MkResult { @@ -346,17 +343,17 @@ ) $ descend Evaluation.QuantifiedGame.unboundedInterval initialSearchDepth initialSearchState -- | The type of a function which transforms the result. -type Transformation x y positionHash criterionValue weightedMean = Result x y positionHash criterionValue weightedMean -> Result x y positionHash criterionValue weightedMean +type Transformation x y positionHash = Result x y positionHash -> Result x y positionHash -- | Mutator. -negateFitnessOfResult :: Num weightedMean => Transformation x y positionHash criterionValue weightedMean +negateFitnessOfResult :: Transformation x y positionHash negateFitnessOfResult result@MkResult { getQuantifiedGame = quantifiedGame } = result { getQuantifiedGame = Evaluation.QuantifiedGame.negateFitness quantifiedGame } -- | Mutator. -addNMovesToResult :: Component.Move.NPlies -> Transformation x y positionHash criterionValue weightedMean -addNMovesToResult nPlies result@MkResult { getNPliesEvaluated = nPliesEvaluated } = Control.Exception.assert (nPlies > 0) result { - getNPliesEvaluated = nPlies + nPliesEvaluated +addNPositionsToResult :: Type.Count.NPositions -> Transformation x y positionHash +addNPositionsToResult nPositions result@MkResult { getNPositionsEvaluated = nPositionsEvaluated } = Control.Exception.assert (nPositions > 0) result { + getNPositionsEvaluated = nPositions + nPositionsEvaluated } diff --git a/src-lib/BishBosh/Search/DynamicMoveData.hs b/src-lib/BishBosh/Search/DynamicMoveData.hs --- a/src-lib/BishBosh/Search/DynamicMoveData.hs +++ b/src-lib/BishBosh/Search/DynamicMoveData.hs @@ -51,6 +51,7 @@ import qualified BishBosh.Search.EphemeralData as Search.EphemeralData import qualified BishBosh.Search.KillerMoves as Search.KillerMoves import qualified BishBosh.Search.Transpositions as Search.Transpositions +import qualified BishBosh.Type.Count as Type.Count import qualified Data.Maybe {- | @@ -99,6 +100,6 @@ Search.EphemeralData.euthanise . reduceNPlies ) maybeRetireTranspositionsAfter transpositions } where - reduceNPlies :: Component.Move.NMoves -> Component.Move.NPlies - reduceNPlies = (`subtract` nPlies) . (* 2) {-convert full moves to plies-} + reduceNPlies :: Type.Count.NMoves -> Type.Count.NPlies + reduceNPlies = (`subtract` nPlies) . (* Component.Move.nPliesPerMove) . fromIntegral diff --git a/src-lib/BishBosh/Search/EphemeralData.hs b/src-lib/BishBosh/Search/EphemeralData.hs --- a/src-lib/BishBosh/Search/EphemeralData.hs +++ b/src-lib/BishBosh/Search/EphemeralData.hs @@ -28,20 +28,21 @@ MaybeEphemeralData(..) ) where -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Input.SearchOptions as Input.SearchOptions +import qualified BishBosh.Type.Count as Type.Count import Prelude(Int) -- | An interface for short-lived data. class EphemeralData a where - getSize :: a -> Int -- ^ Get the current size of the collection. - euthanise :: Component.Move.NPlies -> a -> a -- ^ Prune data older than the specified number of plies, from the collection. + getSize :: a -> Int -- ^ Get the current size of the collection. + euthanise :: Type.Count.NPlies -> a -> a -- ^ Prune items older than the specified number of plies, from the data. -- | For data which can be killed. class MaybeEphemeralData a where maybeEuthanise - :: Component.Move.NPlies -- ^ The age at which to die. + :: Type.Count.NPlies -- ^ The age at which to die. -> Input.SearchOptions.MaybeRetireAfterNMoves -- ^ The optional age at which to retire killer-moves. -> Input.SearchOptions.MaybeRetireAfterNMoves -- ^ The optional age at which to retire transpositions. -> a -> a + 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 @@ -38,9 +38,9 @@ import Control.Arrow((&&&)) import Data.Array.IArray((!), (//)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.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 @@ -56,7 +56,7 @@ -} type NInstancesByNPliesByKeyByLogicalColour killerMoveKey = Attribute.LogicalColour.ArrayByLogicalColour ( Data.Map.Map killerMoveKey ( - Data.IntMap.Strict.IntMap Component.Move.NPlies + Data.IntMap.Strict.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. ) ) @@ -69,7 +69,7 @@ empty = MkKillerMoves . Attribute.LogicalColour.listArrayByLogicalColour $ repeat Property.Empty.empty instance Search.EphemeralData.EphemeralData (KillerMoves killerMoveKey) where - getSize MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = Data.Foldable.foldl' ( + getSize MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = fromIntegral $ Data.Foldable.foldl' ( Data.Map.foldl' $ Data.IntMap.Strict.foldl' (+) ) 0 nInstancesByNPliesByKeyByLogicalColour @@ -77,7 +77,7 @@ | nPlies <= 0 = killerMoves -- This might occur at the start of the game, because the caller subtracts a fixed value from the current number of plies. | otherwise = MkKillerMoves $ Data.Array.IArray.amap ( Data.Map.mapMaybe $ \m -> let - m' = Data.IntMap.Strict.filterWithKey (\nPlies' _ -> nPlies' > nPlies) m + m' = Data.IntMap.Strict.filterWithKey (\nPlies' _ -> nPlies' > fromIntegral nPlies) m in if Data.IntMap.Strict.null m' then Nothing else Just m' @@ -89,14 +89,14 @@ -- | Insert a killer-move. insert :: Ord killerMoveKey - => Component.Move.NPlies -- ^ The total number of plies applied to the game. + => Type.Count.NPlies -- ^ The total number of plies applied to the game. -> killerMoveKey -> Transformation killerMoveKey insert nPlies killerMoveKey MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = MkKillerMoves $ nInstancesByNPliesByKeyByLogicalColour // [ id &&& Data.Map.insertWith ( Data.IntMap.Strict.unionWith (+) ) killerMoveKey ( - Data.IntMap.Strict.singleton nPlies 1 + Data.IntMap.Strict.singleton (fromIntegral nPlies) 1 ) . ( nInstancesByNPliesByKeyByLogicalColour ! ) $ if even nPlies @@ -118,3 +118,4 @@ ) . ( `Data.Map.lookup` (nInstancesByNPliesByKeyByLogicalColour ! logicalColour) ) . killerMoveKeyConstructor + diff --git a/src-lib/BishBosh/Search/Search.hs b/src-lib/BishBosh/Search/Search.hs --- a/src-lib/BishBosh/Search/Search.hs +++ b/src-lib/BishBosh/Search/Search.hs @@ -29,7 +29,7 @@ -- MkResult, getSearchState, getQuantifiedGames, - getNPliesEvaluated + getNPositionsEvaluated ), -- * Constants showsSeparator, @@ -41,7 +41,6 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame @@ -53,34 +52,36 @@ import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad.Reader import qualified Data.Maybe -- | The type returned by 'search'. -data Result x y positionHash criterionValue weightedMean = MkResult { - getSearchState :: Search.SearchState.SearchState x y positionHash criterionValue weightedMean, - getQuantifiedGames :: [Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean], -- ^ The optimal path down the /positionHashQuantifiedGameTree/. - getNPliesEvaluated :: Component.Move.NPlies -- ^ The total number of nodes in the /positionHashQuantifiedGameTree/ which were analysed. +data Result x y positionHash = MkResult { + getSearchState :: Search.SearchState.SearchState x y positionHash, + getQuantifiedGames :: [Evaluation.QuantifiedGame.QuantifiedGame x y], -- ^ The optimal path down the /positionHashQuantifiedGameTree/. + getNPositionsEvaluated :: Type.Count.NPositions -- ^ The total number of nodes in the /positionHashQuantifiedGameTree/ which were analysed. } -instance Control.DeepSeq.NFData weightedMean => Control.DeepSeq.NFData (Result x y positionHash criterionValue weightedMean) where +instance Control.DeepSeq.NFData (Result x y positionHash) where rnf MkResult { getQuantifiedGames = quantifiedGames } = Control.DeepSeq.rnf quantifiedGames -- CAVEAT: don't evaluate the search-state, since this contains the PositionHashQuantifiedGameTree ! -- | Used to format output. showsSeparator :: ShowS showsSeparator = showString " -> " -instance (Enum x, Enum y, Real criterionValue, Real weightedMean) => Notation.MoveNotation.ShowNotationFloat (Result x y positionHash criterionValue weightedMean) where +instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (Result x y positionHash) where showsNotationFloat moveNotation showsDouble result@MkResult { getQuantifiedGames = quantifiedGames, - getNPliesEvaluated = nPliesEvaluated + getNPositionsEvaluated = nPositionsEvaluated } = Text.ShowList.showsFormattedList showsSeparator ( Notation.MoveNotation.showsNotationFloat moveNotation showsDouble - ) quantifiedGames . showString "; selected after analysing " . shows nPliesEvaluated . showString " nodes" . ( - if null quantifiedGames || nPliesEvaluated == 0 + ) quantifiedGames . showString "; selected after analysing " . shows nPositionsEvaluated . showString " nodes" . ( + if null quantifiedGames || nPositionsEvaluated == 0 then id else showString " (branching-factor" . Text.ShowList.showsAssociation . showsDouble (calculateBranchingFactor result) . showChar ')' ) @@ -94,17 +95,17 @@ Show x, Show y ) - => Search.SearchState.SearchState x y positionHash criterionValue weightedMean - -> [Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean] - -> Component.Move.NPlies - -> Result x y positionHash criterionValue weightedMean -mkResult searchState quantifiedGames nPliesEvaluated + => Search.SearchState.SearchState x y positionHash + -> [Evaluation.QuantifiedGame.QuantifiedGame x y] + -> Type.Count.NPositions + -> Result x y positionHash +mkResult searchState quantifiedGames nPositionsEvaluated | null quantifiedGames = Control.Exception.throw . Data.Exception.mkNullDatum . showString "BishBosh.Search.Search.mkResult:\tnull quantifiedGames; " $ shows game "." - | nPliesEvaluated < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Search.Search.mkResult:\tnPliesEvaluated=" . shows nPliesEvaluated . showString " mustn't be negative; " $ shows game "." + | nPositionsEvaluated < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Search.Search.mkResult:\tnPositionsEvaluated=" . shows nPositionsEvaluated . showString " mustn't be negative; " $ shows game "." | otherwise = MkResult { getSearchState = searchState, getQuantifiedGames = quantifiedGames, - getNPliesEvaluated = nPliesEvaluated + getNPositionsEvaluated = nPositionsEvaluated } where game = Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame $ Search.SearchState.getPositionHashQuantifiedGameTree searchState @@ -113,30 +114,28 @@ search :: ( Enum x, Enum y, - Eq criterionValue, Ord positionHash, Ord x, Ord y, - Real weightedMean, Show x, Show y ) - => Input.SearchOptions.SearchDepth -- ^ How deep down the tree to search. - -> Search.SearchState.SearchState x y positionHash criterionValue weightedMean - -> Input.SearchOptions.Reader (Result x y positionHash criterionValue weightedMean) -{-# SPECIALISE search :: Input.SearchOptions.SearchDepth -> Search.SearchState.SearchState T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean -> Input.SearchOptions.Reader (Result T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean) #-} + => Type.Count.NPlies -- ^ How deep down the tree to search. + -> Search.SearchState.SearchState x y positionHash + -> Input.SearchOptions.Reader (Result x y positionHash) +{-# SPECIALISE search :: Type.Count.NPlies -> Search.SearchState.SearchState Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> Input.SearchOptions.Reader (Result Type.Length.X Type.Length.Y Type.Crypto.PositionHash) #-} search 0 _ = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Search.Search.search:\t" . shows Input.SearchOptions.searchDepthTag . showString " must be at least " $ shows Input.SearchOptions.minimumSearchDepth "." search searchDepth searchState | Just terminationReason <- Model.Game.getMaybeTerminationReason game = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Search.Search.search:\tthe game has already terminated; " $ shows terminationReason "." | otherwise = do - (maybeRetireKillerMovesAfter, maybeRetireTranspositionsAfter) <- Control.Monad.Reader.asks $ Input.SearchOptions.getMaybeRetireKillerMovesAfter &&& Input.SearchOptions.maybeRetireTranspositionsAfter + pair <- Control.Monad.Reader.asks $ Input.SearchOptions.getMaybeRetireKillerMovesAfter &&& Input.SearchOptions.maybeRetireTranspositionsAfter let nPlies = State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game - searchResult <- Search.AlphaBeta.negaMax searchDepth $ Search.EphemeralData.maybeEuthanise nPlies maybeRetireKillerMovesAfter maybeRetireTranspositionsAfter searchState + searchResult <- Search.AlphaBeta.negaMax searchDepth $ uncurry (Search.EphemeralData.maybeEuthanise nPlies) pair searchState case Search.AlphaBeta.extractSelectedTurns nPlies searchResult of - (dynamicMoveData, turns@(turn : _), nPliesEvaluated) -> let + (dynamicMoveData, turns@(turn : _), nPositionsEvaluated) -> let isMatch turn' = (== turn') . Evaluation.QuantifiedGame.getLastTurn . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame in return {-to Reader-monad-} $ mkResult ( Search.SearchState.mkSearchState ( @@ -148,21 +147,21 @@ map Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame . Data.Maybe.fromMaybe ( Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.Search.search:\tEvaluation.PositionHashQuantifiedGameTree.traceRoute failed; " $ shows turns "." ) $ Evaluation.PositionHashQuantifiedGameTree.traceRoute isMatch positionHashQuantifiedGameTree turns - ) nPliesEvaluated + ) nPositionsEvaluated _ -> Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Search.Search.search:\tzero turns selected." where positionHashQuantifiedGameTree = Search.SearchState.getPositionHashQuantifiedGameTree searchState game = Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame positionHashQuantifiedGameTree -- | Calculate the geometric-mean of the number of plies evaluated at each node. -calculateBranchingFactor :: Floating branchingFactor => Result x y positionHash criterionValue weightedMean -> branchingFactor +calculateBranchingFactor :: Floating branchingFactor => Result x y positionHash -> branchingFactor calculateBranchingFactor MkResult { getQuantifiedGames = quantifiedGames, - getNPliesEvaluated = nPliesEvaluated + getNPositionsEvaluated = nPositionsEvaluated } - | null quantifiedGames = Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Search.Search.calculateBranchingFactor:\tnull quantifiedGames." - | nPliesEvaluated == 0 = Control.Exception.throw $ Data.Exception.mkOutOfBounds "BishBosh.Search.Search.calculateBranchingFactor:\tzero plies analysed." - | otherwise = fromIntegral nPliesEvaluated ** recip ( - fromIntegral $ length quantifiedGames -- The search-depth. + | null quantifiedGames = Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Search.Search.calculateBranchingFactor:\tnull quantifiedGames." + | nPositionsEvaluated == 0 = Control.Exception.throw $ Data.Exception.mkOutOfBounds "BishBosh.Search.Search.calculateBranchingFactor:\tzero plies analysed." + | otherwise = fromIntegral nPositionsEvaluated ** recip ( + fromIntegral {-Int-} $ length quantifiedGames -- The search-depth. ) diff --git a/src-lib/BishBosh/Search/SearchState.hs b/src-lib/BishBosh/Search/SearchState.hs --- a/src-lib/BishBosh/Search/SearchState.hs +++ b/src-lib/BishBosh/Search/SearchState.hs @@ -46,33 +46,23 @@ import qualified Control.Exception -- | The data which is both received & returned by 'Search.Search.search', so that it is transported through the entire game. -data SearchState x y positionHash criterionValue weightedMean = MkSearchState { - getPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean, +data SearchState x y positionHash = MkSearchState { + getPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash, getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData x y positionHash } -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y, - Show criterionValue, - Show positionHash, - Show weightedMean - ) => Show (SearchState x y positionHash criterionValue weightedMean) where - showsPrec _ _ = showString "SearchState {...}" +instance Show (SearchState x y positionHash) where + show _ = "SearchState {...}" -- | Constructor. mkSearchState - :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean + :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> Search.DynamicMoveData.DynamicMoveData x y positionHash - -> SearchState x y positionHash criterionValue weightedMean + -> SearchState x y positionHash mkSearchState = MkSearchState -- | Smart constructor. -initialise :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> SearchState x y positionHash criterionValue weightedMean +initialise :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> SearchState x y positionHash initialise positionHashQuantifiedGameTree | Model.Game.isTerminated game = Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Search.SearchState.initialise:\tcan't search for a move from a terminated game." | otherwise = MkSearchState { @@ -82,7 +72,7 @@ where game = Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame positionHashQuantifiedGameTree -instance Search.EphemeralData.MaybeEphemeralData (SearchState x y positionHash criterionValue weightedMean) where +instance Search.EphemeralData.MaybeEphemeralData (SearchState x y positionHash) where maybeEuthanise nPlies maybeRetireKillerMovesAfter maybeRetireTranspositionsAfter searchState@MkSearchState { getDynamicMoveData = dynamicMoveData } = searchState { getDynamicMoveData = Search.EphemeralData.maybeEuthanise nPlies maybeRetireKillerMovesAfter maybeRetireTranspositionsAfter dynamicMoveData -- Forward the request. } diff --git a/src-lib/BishBosh/Search/TranspositionValue.hs b/src-lib/BishBosh/Search/TranspositionValue.hs --- a/src-lib/BishBosh/Search/TranspositionValue.hs +++ b/src-lib/BishBosh/Search/TranspositionValue.hs @@ -42,8 +42,9 @@ isBetter ) where -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.Ord @@ -52,15 +53,15 @@ -- | The type of the values in the transposition-table. data TranspositionValue qualifiedMove = MkTranspositionValue { - getIsOptimal :: IsOptimal, -- ^ Whether the recorded move-sequence is known to be optimal. - getNPlies :: Component.Move.NPlies, -- ^ The number of plies applied to the /game/ before application of any of the specified moves. - getQualifiedMoves :: [qualifiedMove] -- ^ The sequence of qualifiedMoves applied to the /game/, which caused the alpha-beta event. + getIsOptimal :: IsOptimal, -- ^ Whether the recorded move-sequence is known to be optimal. + getNPlies :: Type.Count.NPlies, -- ^ The number of plies applied to the /game/ before application of any of the specified moves. + getQualifiedMoves :: [qualifiedMove] -- ^ The sequence of qualifiedMoves applied to the /game/, which caused the alpha-beta event. } deriving Show -- | Smart constructor. mkTranspositionValue :: IsOptimal - -> Component.Move.NPlies + -> Type.Count.NPlies -> [qualifiedMove] -> TranspositionValue qualifiedMove mkTranspositionValue _ _ [] = Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Search.TranspositionValue.mkTranspositionValue:\tnull list of qualifiedMoves." @@ -73,15 +74,15 @@ } -- | Infer the search-depth from the length of the qualifiedMove-sequence. -inferSearchDepth :: TranspositionValue qualifiedMove -> Component.Move.NPlies -inferSearchDepth = length . getQualifiedMoves +inferSearchDepth :: TranspositionValue qualifiedMove -> Type.Count.NPlies +inferSearchDepth = fromIntegral . length . getQualifiedMoves {- | * The type of a function which can find the fitness of the game resulting from the recorded sequence of qualifiedMoves. * CAVEAT: the fitness this function returns should be from the perspective of the player to make the first move. -} -type FindFitness qualifiedMove weightedMean = TranspositionValue qualifiedMove -> weightedMean +type FindFitness qualifiedMove = TranspositionValue qualifiedMove -> Type.Mass.WeightedMean {- | * Whether a proposed value is better than the incumbent. @@ -89,8 +90,7 @@ * CAVEAT: this is a narrower concept than addressed by 'Ord', which implies 'Eq'. -} isBetter - :: Ord weightedMean - => FindFitness qualifiedMove weightedMean + :: FindFitness qualifiedMove -> TranspositionValue qualifiedMove -- ^ The proposed value. -> TranspositionValue qualifiedMove -- ^ The incumbent value. -> Bool diff --git a/src-lib/BishBosh/Search/Transpositions.hs b/src-lib/BishBosh/Search/Transpositions.hs --- a/src-lib/BishBosh/Search/Transpositions.hs +++ b/src-lib/BishBosh/Search/Transpositions.hs @@ -75,8 +75,8 @@ * If a matching key already exists, it's replaced if the new value is considered to be better. -} insert - :: (Ord positionHash, Ord weightedMean) - => Search.TranspositionValue.FindFitness qualifiedMove weightedMean + :: Ord positionHash + => Search.TranspositionValue.FindFitness qualifiedMove -> positionHash -- ^ Represents the game from which the sequence of qualifiedMoves starts. -> Search.TranspositionValue.TranspositionValue qualifiedMove -- ^ The value to record. -> Transformation qualifiedMove positionHash 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 @@ -39,7 +39,6 @@ -- ** Type-synonyms -- Transformation, -- NDefendersByCoordinatesByLogicalColour, - NBoards, -- ** Data-types Board( -- MkBoard, @@ -66,7 +65,7 @@ exposesKing ) where -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&), (***), (|||)) import Data.Array.IArray((!), (//)) import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour @@ -90,7 +89,9 @@ import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -109,10 +110,7 @@ type Transformation x y = Board x y -> Board x y -- | The number of defenders for each /piece/, belonging to each side. -type NDefendersByCoordinatesByLogicalColour x y = Attribute.LogicalColour.ArrayByLogicalColour (Data.Map.Strict.Map (Cartesian.Coordinates.Coordinates x y) Component.Piece.NPieces) - --- | A number of boards. -type NBoards = Int +type NDefendersByCoordinatesByLogicalColour x y = Attribute.LogicalColour.ArrayByLogicalColour (Data.Map.Strict.Map (Cartesian.Coordinates.Coordinates x y) Type.Count.NPieces) {- | * The board is modelled as two alternative structures representing the same data, but indexed by either /coordinates/ or /piece/. @@ -120,13 +118,13 @@ * For efficiency some ancillary structures are also maintained. -} data Board x y = MkBoard { - getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates x y, -- ^ Defines any /piece/ currently located at each /coordinate/. - getCoordinatesByRankByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByRankByLogicalColour x y, -- ^ The /coordinates/ of each /piece/. - getNDefendersByCoordinatesByLogicalColour :: NDefendersByCoordinatesByLogicalColour x y, -- ^ The number of defenders of each /piece/, indexed by /logical colour/ & then by /coordinates/. - getNPiecesDifferenceByRank :: StateProperty.Censor.NPiecesByRank, -- ^ The difference in the number of /piece/s of each /rank/ held by either side. @White@ /piece/s are arbitrarily considered positive & @Black@ ones negative. - getNPawnsByFileByLogicalColour :: State.CoordinatesByRankByLogicalColour.NPiecesByFileByLogicalColour x, -- ^ The number of @Pawn@s of each /logical colour/, for each /file/. - getNPieces :: Component.Piece.NPieces, -- ^ The total number of pieces on the board, including @Pawn@s. - getPassedPawnCoordinatesByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByLogicalColour x y -- ^ The /coordinates/ of any /passed/ @Pawn@s. + getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates x y, -- ^ Defines any /piece/ currently located at each /coordinate/. + getCoordinatesByRankByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByRankByLogicalColour x y, -- ^ The /coordinates/ of each /piece/. + getNDefendersByCoordinatesByLogicalColour :: NDefendersByCoordinatesByLogicalColour x y, -- ^ The number of defenders of each /piece/, indexed by /logical colour/ & then by /coordinates/. + getNPiecesDifferenceByRank :: StateProperty.Censor.NPiecesByRank, -- ^ The difference in the number of /piece/s of each /rank/ held by either side. @White@ /piece/s are arbitrarily considered positive & @Black@ ones negative. + getNPawnsByFileByLogicalColour :: State.CoordinatesByRankByLogicalColour.NPiecesByFileByLogicalColour x, -- ^ The number of @Pawn@s of each /logical colour/, for each /file/. + getNPieces :: Type.Count.NPieces, -- ^ The total number of pieces on the board, including @Pawn@s. + getPassedPawnCoordinatesByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByLogicalColour x y -- ^ The /coordinates/ of any /passed/ @Pawn@s. } instance ( @@ -145,9 +143,7 @@ getMaybePieceByCoordinates = maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, getNDefendersByCoordinatesByLogicalColour = nDefendersByCoordinatesByLogicalColour, -#ifndef USE_UNBOXED_ARRAYS getNPiecesDifferenceByRank = nPiecesDifferenceByRank, -#endif getNPawnsByFileByLogicalColour = nPawnsByFileByLogicalColour, getNPieces = nPieces, getPassedPawnCoordinatesByLogicalColour = passedPawnCoordinatesByLogicalColour @@ -155,9 +151,7 @@ maybePieceByCoordinates, coordinatesByRankByLogicalColour, nDefendersByCoordinatesByLogicalColour, -#ifndef USE_UNBOXED_ARRAYS nPiecesDifferenceByRank, -#endif nPawnsByFileByLogicalColour, nPieces, passedPawnCoordinatesByLogicalColour @@ -169,7 +163,7 @@ Ord x, Ord y ) => Read (Board x y) where - {-# SPECIALISE instance Read (Board T.X T.Y) #-} + {-# SPECIALISE instance Read (Board Type.Length.X Type.Length.Y) #-} readsPrec _ = Property.ForsythEdwards.readsFEN instance ( @@ -186,7 +180,7 @@ Ord x, Ord y ) => Property.ExtendedPositionDescription.ReadsEPD (Board x y) where - {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Board T.X T.Y) #-} + {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Board Type.Length.X Type.Length.Y) #-} readsEPD = map (Control.Arrow.first fromMaybePieceByCoordinates) . Property.ExtendedPositionDescription.readsEPD instance ( @@ -203,7 +197,7 @@ Ord x, Ord y ) => Property.ForsythEdwards.ReadsFEN (Board x y) where - {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Board T.X T.Y) #-} + {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Board Type.Length.X Type.Length.Y) #-} readsFEN = Property.ExtendedPositionDescription.readsEPD instance ( @@ -219,7 +213,7 @@ Ord x, Ord y ) => Data.Default.Default (Board x y) where - {-# SPECIALISE instance Data.Default.Default (Board T.X T.Y) #-} + {-# SPECIALISE instance Data.Default.Default (Board Type.Length.X Type.Length.Y) #-} def = fromMaybePieceByCoordinates Data.Default.def {-MaybePieceByCoordinates-} instance ( @@ -228,7 +222,7 @@ Ord x, Ord y ) => Property.Reflectable.ReflectableOnX (Board x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Board T.X T.Y) #-} + {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Board Type.Length.X Type.Length.Y) #-} reflectOnX MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ Property.Reflectable.reflectOnX maybePieceByCoordinates instance ( @@ -237,7 +231,7 @@ Ord x, Ord y ) => Property.Reflectable.ReflectableOnY (Board x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnY (Board T.X T.Y) #-} + {-# SPECIALISE instance Property.Reflectable.ReflectableOnY (Board Type.Length.X Type.Length.Y) #-} reflectOnY MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ Property.Reflectable.reflectOnY maybePieceByCoordinates instance ( @@ -246,7 +240,7 @@ Ord x, Ord y ) => Property.Empty.Empty (Board x y) where - {-# SPECIALISE empty :: Board T.X T.Y #-} + {-# SPECIALISE empty :: Board Type.Length.X Type.Length.Y #-} empty = fromMaybePieceByCoordinates Property.Empty.empty {-MaybePieceByCoordinates-} instance (Enum x, Enum y, Ord x, Ord y) => Component.Zobrist.Hashable2D Board x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where @@ -258,7 +252,7 @@ Ord x, Ord y ) => StateProperty.Seeker.Seeker Board x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker Board T.X T.Y #-} + {-# SPECIALISE instance StateProperty.Seeker.Seeker Board Type.Length.X Type.Length.Y #-} 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. @@ -268,7 +262,7 @@ Ord x, Ord y ) => StateProperty.Mutator.Mutator Board x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Mutator.Mutator Board T.X T.Y #-} + {-# SPECIALISE instance StateProperty.Mutator.Mutator Board Type.Length.X Type.Length.Y #-} defineCoordinates maybePiece coordinates MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ StateProperty.Mutator.defineCoordinates maybePiece coordinates maybePieceByCoordinates -- | Constructor. @@ -278,15 +272,15 @@ Ord x, Ord y ) => State.MaybePieceByCoordinates.MaybePieceByCoordinates x y -> Board x y -{-# SPECIALISE fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates T.X T.Y -> Board T.X T.Y #-} +{-# SPECIALISE fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y #-} fromMaybePieceByCoordinates maybePieceByCoordinates = board where board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = State.CoordinatesByRankByLogicalColour.fromMaybePieceByCoordinates maybePieceByCoordinates, -- Infer. getNDefendersByCoordinatesByLogicalColour = countDefendersByCoordinatesByLogicalColour board, -- Infer. - getNPiecesDifferenceByRank = StateProperty.Censor.countPieceDifferenceByRank coordinatesByRankByLogicalColour, -- Infer. + getNPiecesDifferenceByRank = StateProperty.Censor.countPieceDifferenceByRank coordinatesByRankByLogicalColour, -- Infer. getNPawnsByFileByLogicalColour = State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour, -- Infer. - getNPieces = StateProperty.Censor.countPieces coordinatesByRankByLogicalColour, -- Infer. + getNPieces = StateProperty.Censor.countPieces coordinatesByRankByLogicalColour, -- Infer. getPassedPawnCoordinatesByLogicalColour = State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour coordinatesByRankByLogicalColour -- Infer. } @@ -308,7 +302,7 @@ => Component.Move.Move x y -- ^ N.B.: illegal moves are acceptable. -> Maybe Attribute.MoveType.MoveType -- ^ N.B.: this may not be available to the caller, for example during the illegal moves required for rollback. -> Transformation x y -{-# SPECIALISE movePiece :: Component.Move.Move T.X T.Y -> Maybe Attribute.MoveType.MoveType -> Transformation T.X T.Y #-} +{-# SPECIALISE movePiece :: Component.Move.Move Type.Length.X Type.Length.Y -> Maybe Attribute.MoveType.MoveType -> Transformation Type.Length.X Type.Length.Y #-} movePiece move maybeMoveType board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, @@ -342,7 +336,7 @@ board'@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates' } = MkBoard { getMaybePieceByCoordinates = State.MaybePieceByCoordinates.movePiece move destinationPiece ( - either Just (const Nothing) eitherPassingPawnsDestinationOrMaybeTakenRank + Just ||| const Nothing $ eitherPassingPawnsDestinationOrMaybeTakenRank ) maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = State.CoordinatesByRankByLogicalColour.movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank coordinatesByRankByLogicalColour, getNDefendersByCoordinatesByLogicalColour = let @@ -361,26 +355,26 @@ if Attribute.LogicalColour.isBlack logicalColour' then Control.Arrow.first else Control.Arrow.second - ) . Data.Map.Strict.insert affectedCoordinates {-overwrite-} . length $ findAttackersOf ( + ) . Data.Map.Strict.insert affectedCoordinates {-overwrite-} . fromIntegral . length $ findAttackersOf ( Property.Opposable.getOpposite logicalColour' -- Investigate an attack on the affected coordinates by the affected piece's own logical colour, i.e. defence. ) affectedCoordinates board' ) ( (! Attribute.LogicalColour.Black) &&& (! Attribute.LogicalColour.White) $ nDefendersByCoordinatesByLogicalColour // ( let nDefendersByCoordinates = nDefendersByCoordinatesByLogicalColour ! opponentsLogicalColour - in either ( + in ( \passingPawnsDestination -> (:) ( opponentsLogicalColour, Data.Map.Strict.delete passingPawnsDestination nDefendersByCoordinates -- This Pawn has been taken. ) - ) ( + ) ||| ( \maybeExplicitlyTakenRank -> if Data.Maybe.isJust maybeExplicitlyTakenRank then (:) ( opponentsLogicalColour, Data.Map.Strict.delete destination nDefendersByCoordinates -- This piece has been taken. ) else id - ) eitherPassingPawnsDestinationOrMaybeTakenRank + ) $ eitherPassingPawnsDestinationOrMaybeTakenRank ) [ ( logicalColour, @@ -398,7 +392,7 @@ Component.Piece.isFriend knight affectedPiece ] {-list-comprehension-} ++ [ (blockingCoordinates, blockingPiece) | - passingPawnsDestination <- either return {-to List-monad-} (const []) eitherPassingPawnsDestinationOrMaybeTakenRank, + 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') -> [ @@ -421,7 +415,7 @@ _ -> [] ] {-list-comprehension-} ++ (destination, destinationPiece) : [ (blockingCoordinates, blockingPiece) | - let maybeExplicitlyTakenPiece = either (const Nothing) id eitherPassingPawnsDestinationOrMaybeTakenPiece, + let maybeExplicitlyTakenPiece = const Nothing ||| id $ eitherPassingPawnsDestinationOrMaybeTakenPiece, (direction, antiParallelDirection) <- Attribute.Direction.opposites, (coordinates, piece) <- [(source, sourcePiece), (destination, destinationPiece)], (blockingCoordinates, blockingPiece) <- case ($ direction) &&& ($ antiParallelDirection) $ ($ maybePieceByCoordinates') . (`State.MaybePieceByCoordinates.findBlockingPiece` coordinates) of @@ -467,12 +461,12 @@ ) ] ) maybePromotionRank, - getNPawnsByFileByLogicalColour = if Component.Piece.isPawn sourcePiece && ( + getNPawnsByFileByLogicalColour = if Component.Piece.isPawn sourcePiece && ( Cartesian.Coordinates.getX source /= Cartesian.Coordinates.getX destination {-includes En-passant-} || Attribute.MoveType.isPromotion moveType ) || Attribute.MoveType.getMaybeExplicitlyTakenRank moveType == Just Attribute.Rank.Pawn then State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour' else getNPawnsByFileByLogicalColour board, - getNPieces = Attribute.MoveType.nPiecesMutator moveType nPieces, + getNPieces = Attribute.MoveType.nPiecesMutator moveType nPieces, getPassedPawnCoordinatesByLogicalColour = if Component.Piece.isPawn sourcePiece {-includes En-passant & promotion-} || Attribute.MoveType.getMaybeExplicitlyTakenRank moveType == Just Attribute.Rank.Pawn then State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour coordinatesByRankByLogicalColour' else getPassedPawnCoordinatesByLogicalColour board @@ -505,15 +499,15 @@ #endif pieceSquareValue {-# SPECIALISE sumPieceSquareValueByLogicalColour - :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank T.X T.Y T.PieceSquareValue - -> Board T.X T.Y + :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue + -> Board Type.Length.X Type.Length.Y -> #ifdef USE_UNBOXED_ARRAYS Attribute.LogicalColour.UArrayByLogicalColour #else Attribute.LogicalColour.ArrayByLogicalColour #endif - T.PieceSquareValue + Type.Mass.PieceSquareValue #-} sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, @@ -543,7 +537,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ The defender's location. -> Board x y -> [(Cartesian.Coordinates.Coordinates x y, Attribute.Rank.Rank)] -- ^ The locations from which the specified square can be attacked by the opposite /logical colour/. -{-# SPECIALISE findAttackersOf :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates T.X T.Y -> Board T.X T.Y -> [(Cartesian.Coordinates.Coordinates T.X T.Y, Attribute.Rank.Rank)] #-} +{-# SPECIALISE findAttackersOf :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y -> [(Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y, Attribute.Rank.Rank)] #-} findAttackersOf destinationLogicalColour destination board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = [ (coordinates, Attribute.Rank.Knight) | coordinates <- StateProperty.Seeker.findProximateKnights (Property.Opposable.getOpposite destinationLogicalColour) destination board @@ -568,7 +562,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ The defender's location. -> Board x y -> [Cartesian.Coordinates.Coordinates x y] -- ^ The sources from which the specified attacker could strike. -{-# SPECIALISE findAttacksBy :: Component.Piece.Piece -> Cartesian.Coordinates.Coordinates T.X T.Y -> Board T.X T.Y -> [Cartesian.Coordinates.Coordinates T.X T.Y] #-} +{-# SPECIALISE findAttacksBy :: Component.Piece.Piece -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] #-} findAttacksBy piece destination board | rank == Attribute.Rank.Knight = StateProperty.Seeker.findProximateKnights logicalColour destination board | otherwise = filter ( @@ -593,7 +587,7 @@ => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ in question. -> Board x y -> Bool -{-# SPECIALISE isKingChecked :: Attribute.LogicalColour.LogicalColour -> Board T.X T.Y -> Bool #-} +{-# SPECIALISE isKingChecked :: Attribute.LogicalColour.LogicalColour -> Board Type.Length.X Type.Length.Y -> Bool #-} isKingChecked logicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = not . null $ findAttackersOf logicalColour (State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour) board {- | @@ -613,7 +607,7 @@ -> Component.Move.Move x y -- ^ The /move/. -> Board x y -- ^ The original /board/, i.e. prior to the /move/. -> Bool -{-# SPECIALISE exposesKing :: Attribute.LogicalColour.LogicalColour -> Component.Move.Move T.X T.Y -> Board T.X T.Y -> Bool #-} +{-# SPECIALISE exposesKing :: Attribute.LogicalColour.LogicalColour -> Component.Move.Move Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y -> 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 ( @@ -640,22 +634,22 @@ Ord x, Ord y ) => Board x y -> NDefendersByCoordinatesByLogicalColour x y -{-# SPECIALISE countDefendersByCoordinatesByLogicalColour :: Board T.X T.Y -> NDefendersByCoordinatesByLogicalColour T.X T.Y #-} +{-# SPECIALISE countDefendersByCoordinatesByLogicalColour :: Board Type.Length.X Type.Length.Y -> NDefendersByCoordinatesByLogicalColour Type.Length.X Type.Length.Y #-} countDefendersByCoordinatesByLogicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour [ Data.Map.Strict.fromList [ ( coordinates, - length $ findAttackersOf ( + fromIntegral . length $ findAttackersOf ( Property.Opposable.getOpposite logicalColour -- Investigate an attack on these coordinates by one's own logical colour. ) coordinates board ) | - rank <- Attribute.Rank.expendable, + rank <- Attribute.Rank.expendable, -- CAVEAT: there's no point defending one's own King. coordinates <- State.CoordinatesByRankByLogicalColour.dereference logicalColour rank coordinatesByRankByLogicalColour ] {-list-comprehension-} | logicalColour <- Property.FixedMembership.members ] -- List-comprehension. -- | Collapses 'NDefendersByCoordinatesByLogicalColour' into the total number of defenders on either side. -summariseNDefendersByLogicalColour :: Board x y -> Attribute.LogicalColour.ArrayByLogicalColour Component.Piece.NPieces +summariseNDefendersByLogicalColour :: Board x y -> Attribute.LogicalColour.ArrayByLogicalColour Type.Count.NPieces summariseNDefendersByLogicalColour MkBoard { getNDefendersByCoordinatesByLogicalColour = nDefendersByCoordinatesByLogicalColour } = Data.Array.IArray.amap ( Data.Map.Strict.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 @@ -76,7 +76,7 @@ import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -136,7 +136,7 @@ } deriving (Eq, Ord) instance Show x => Show (CastleableRooksByLogicalColour x) where - showsPrec _ MkCastleableRooksByLogicalColour { getAssocs = assocs } = shows assocs + showsPrec precedence MkCastleableRooksByLogicalColour { getAssocs = assocs } = showsPrec precedence assocs instance ( Enum x, @@ -144,7 +144,7 @@ Read x, Show x ) => Read (CastleableRooksByLogicalColour x) where - readsPrec _ s = Control.Arrow.first fromAssocs `map` reads s + readsPrec precedence s = Control.Arrow.first fromAssocs `map` readsPrec precedence s instance Control.DeepSeq.NFData x => Control.DeepSeq.NFData (CastleableRooksByLogicalColour x) where rnf MkCastleableRooksByLogicalColour { getAssocs = assocs } = Control.DeepSeq.rnf assocs @@ -372,7 +372,7 @@ => Attribute.LogicalColour.LogicalColour -- ^ Defines the side who took the specified turn. -> Component.Turn.Turn x y -> Transformation x -{-# SPECIALISE takeTurn :: Attribute.LogicalColour.LogicalColour -> Component.Turn.Turn T.X T.Y -> Transformation T.X #-} +{-# SPECIALISE takeTurn :: Attribute.LogicalColour.LogicalColour -> Component.Turn.Turn Type.Length.X Type.Length.Y -> Transformation Type.Length.X #-} takeTurn logicalColour turn MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ ( case lookup logicalColour assocs of Just [] -> id -- This is a terminal state. 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 @@ -57,7 +57,7 @@ sortCoordinates ) where -import Control.Arrow((&&&)) +import Control.Arrow((&&&), (|||)) import Data.Array.IArray((!), (//)) import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour @@ -74,7 +74,9 @@ import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -103,17 +105,17 @@ rnf MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour instance (Enum x, Enum y) => StateProperty.Censor.Censor (CoordinatesByRankByLogicalColour x y) where - countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Attribute.LogicalColour.Black) &&& ($ Attribute.LogicalColour.White) $ Data.List.foldl' (\acc -> (+ acc) . length) 0 . (byLogicalColour !) + countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Attribute.LogicalColour.Black) &&& ($ Attribute.LogicalColour.White) $ Data.List.foldl' (\acc -> (+ acc) . fromIntegral . length) 0 . (byLogicalColour !) countPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.foldl' ( - Data.List.foldl' $ \acc -> (+ acc) . length + Data.List.foldl' $ \acc -> (+ acc) . fromIntegral . length ) 0 byLogicalColour countPieceDifferenceByRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.Rank.listArrayByRank . uncurry ( zipWith (-) ) . ( ($ Attribute.LogicalColour.White) &&& ($ Attribute.LogicalColour.Black) - ) $ map length . Data.Array.IArray.elems . (byLogicalColour !) + ) $ map (fromIntegral . length) . Data.Array.IArray.elems . (byLogicalColour !) hasInsufficientMaterial MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.all ( \byRank -> all ( @@ -153,7 +155,7 @@ Ord x, Ord y ) => StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour T.X T.Y #-} + {-# SPECIALISE instance StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour Type.Length.X Type.Length.Y #-} findProximateKnights logicalColour destination MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = filter ( \source -> source /= destination {-guard against attempting to constructing a null vector-} && Cartesian.Vector.isKnightsMove ( Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt @@ -223,7 +225,7 @@ coordinates = byLogicalColour ! logicalColour ! Attribute.Rank.King -- | The number of /piece/s in each file, for each /logical colour/. -type NPiecesByFileByLogicalColour x = Attribute.LogicalColour.ArrayByLogicalColour (Data.Map.Strict.Map x Component.Piece.NPieces) +type NPiecesByFileByLogicalColour x = Attribute.LogicalColour.ArrayByLogicalColour (Data.Map.Strict.Map x Type.Count.NPieces) {- | * Counts the number of @Pawn@s of each /logical colour/ with similar /x/-coordinates; their /y/-coordinate is irrelevant. @@ -288,7 +290,7 @@ => Component.PieceSquareByCoordinatesByRank.FindPieceSquareValues x y pieceSquareValue -> CoordinatesByRankByLogicalColour x y -> [pieceSquareValue] -{-# SPECIALISE sumPieceSquareValueByLogicalColour :: Component.PieceSquareByCoordinatesByRank.FindPieceSquareValues T.X T.Y T.PieceSquareValue -> CoordinatesByRankByLogicalColour T.X T.Y -> [T.PieceSquareValue] #-} +{-# SPECIALISE sumPieceSquareValueByLogicalColour :: Component.PieceSquareByCoordinatesByRank.FindPieceSquareValues Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue -> CoordinatesByRankByLogicalColour Type.Length.X Type.Length.Y -> [Type.Mass.PieceSquareValue] #-} sumPieceSquareValueByLogicalColour findPieceSquareValues MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = map ( \(logicalColour, byRank) -> Data.List.foldl' ( \acc -> Data.List.foldl' (+) acc . uncurry (findPieceSquareValues logicalColour) @@ -315,11 +317,11 @@ -> Maybe Attribute.Rank.Rank -- ^ The (possibly promoted) rank to place at the destination. -> Either (Cartesian.Coordinates.Coordinates x y) (Maybe Attribute.Rank.Rank) -- ^ Either the destination of any passed @Pawn@, or the /rank/ of any /piece/ taken. -> Transformation x y -movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ byLogicalColour // either ( - (:) . (`deleteOpponentsCoordinates` Attribute.Rank.Pawn) - ) ( - Data.Maybe.maybe id {-quiet move-} $ (:) . deleteOpponentsCoordinates destination - ) eitherPassingPawnsDestinationOrMaybeTakenRank [ +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 ( @@ -343,3 +345,4 @@ -- | Independently sort each list of /coordinates/. sortCoordinates :: (Ord x, Ord y) => Transformation x y sortCoordinates MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ Data.Array.IArray.amap (Data.Array.IArray.amap Data.List.sort) byLogicalColour + 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 @@ -43,7 +43,7 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Data.Array.IArray import qualified Data.Maybe @@ -70,7 +70,7 @@ -> State.MaybePieceByCoordinates.MaybePieceByCoordinates x y -> Component.Turn.Turn x y -- ^ The last /turn/ taken. -> Maybe (EnPassantAbscissa x) -{-# SPECIALISE mkMaybeEnPassantAbscissa :: Attribute.LogicalColour.LogicalColour -> State.MaybePieceByCoordinates.MaybePieceByCoordinates T.X T.Y -> Component.Turn.Turn T.X T.Y -> Maybe (EnPassantAbscissa T.X) #-} +{-# SPECIALISE mkMaybeEnPassantAbscissa :: Attribute.LogicalColour.LogicalColour -> State.MaybePieceByCoordinates.MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Component.Turn.Turn Type.Length.X Type.Length.Y -> Maybe (EnPassantAbscissa Type.Length.X) #-} mkMaybeEnPassantAbscissa nextLogicalColour maybePieceByCoordinates lastTurn | Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) lastTurn , let lastMoveDestination = Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove lastTurn diff --git a/src-lib/BishBosh/State/InstancesByPosition.hs b/src-lib/BishBosh/State/InstancesByPosition.hs --- a/src-lib/BishBosh/State/InstancesByPosition.hs +++ b/src-lib/BishBosh/State/InstancesByPosition.hs @@ -25,7 +25,6 @@ module BishBosh.State.InstancesByPosition( -- * Types -- ** Type-synonyms --- NBoardsByPosition, -- Transformation. -- * Constants leastCyclicPlies, @@ -46,49 +45,43 @@ anyInstancesByPosition ) where -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.Type.Count as Type.Count import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Foldable import qualified Data.Map.Strict --- | The smallest number of repeatable plies required to form a cycle. -leastCyclicPlies :: Component.Move.NPlies +-- | The smallest number of repeatable plies (applied by alternating players) required to form a cycle. +leastCyclicPlies :: Type.Count.NPlies leastCyclicPlies = 4 {- | - * The number of times each /position/ has been encountered. - - * The /position/ can either be represented by a physical 'State.Position.Position', or by proxy using a hash. --} -type NBoardsByPosition position = Data.Map.Strict.Map position State.Board.NBoards - -{- | * A count of the number of instances of /position/s which have occurred. * N.B.: a number greater than @1@ represents repetition. + + * The /position/ can either be represented by a physical 'State.Position.Position', or by proxy using a hash. -} newtype InstancesByPosition position = MkInstancesByPosition { - getNBoardsByPosition :: NBoardsByPosition position + getNPositionsByPosition :: Data.Map.Strict.Map position Type.Count.NPositions } deriving Eq instance Control.DeepSeq.NFData position => Control.DeepSeq.NFData (InstancesByPosition position) where - rnf MkInstancesByPosition { getNBoardsByPosition = m } = Control.DeepSeq.rnf m + rnf MkInstancesByPosition { getNPositionsByPosition = m } = Control.DeepSeq.rnf m instance ( Ord position, Property.Reflectable.ReflectableOnX position ) => Property.Reflectable.ReflectableOnX (InstancesByPosition position) where - reflectOnX MkInstancesByPosition { getNBoardsByPosition = m } = MkInstancesByPosition $ Data.Map.Strict.mapKeys Property.Reflectable.reflectOnX m + reflectOnX MkInstancesByPosition { getNPositionsByPosition = m } = MkInstancesByPosition $ Data.Map.Strict.mapKeys Property.Reflectable.reflectOnX m -- | Smart constructor. -mkInstancesByPosition :: NBoardsByPosition position -> InstancesByPosition position -mkInstancesByPosition nBoardsByPosition - | Data.Foldable.any (< 1) nBoardsByPosition = Control.Exception.throw $ Data.Exception.mkOutOfBounds "BishBosh.State.InstancesByPosition.mkInstancesByPosition:\teach specified position must have been visited at least once." - | otherwise = MkInstancesByPosition nBoardsByPosition +mkInstancesByPosition :: Data.Map.Strict.Map position Type.Count.NPositions -> InstancesByPosition position +mkInstancesByPosition nPositionsByPosition + | Data.Foldable.any (< 1) nPositionsByPosition = Control.Exception.throw $ Data.Exception.mkOutOfBounds "BishBosh.State.InstancesByPosition.mkInstancesByPosition:\teach specified position must have been visited at least once." + | otherwise = MkInstancesByPosition nPositionsByPosition -- | Constructor. mkSingleton :: position -> InstancesByPosition position @@ -99,35 +92,35 @@ * This is equivalent to the number of entries in the map, since adding a non-repeatable move triggers a purge. -} -countConsecutiveRepeatablePlies :: InstancesByPosition position -> Component.Move.NPlies -countConsecutiveRepeatablePlies MkInstancesByPosition { getNBoardsByPosition = m } = Data.Map.Strict.foldl' (+) ( +countConsecutiveRepeatablePlies :: InstancesByPosition position -> Type.Count.NPlies +countConsecutiveRepeatablePlies MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Map.Strict.foldl' (+) ( negate 1 -- The map is never empty, since before the first move a singleton is constructed with the initial position. ) m -- | Count the total number of repetitions of /position/s. -countPositionRepetitions :: InstancesByPosition position -> State.Board.NBoards -countPositionRepetitions MkInstancesByPosition { getNBoardsByPosition = m } = Data.Map.Strict.foldl' ( +countPositionRepetitions :: InstancesByPosition position -> Type.Count.NPositions +countPositionRepetitions MkInstancesByPosition { getNPositionsByPosition = m } = Data.Map.Strict.foldl' ( (+) . pred -- The initial instance isn't a repetition. ) 0 m -- | The number of distinct /position/s. -getNDistinctPositions :: InstancesByPosition position -> State.Board.NBoards -getNDistinctPositions MkInstancesByPosition { getNBoardsByPosition = m } = Data.Map.Strict.size m +getNDistinctPositions :: InstancesByPosition position -> Type.Count.NPositions +getNDistinctPositions MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Map.Strict.size m {-the number of keys-} -- | Predicate: apply the specified predicate to the map. anyInstancesByPosition - :: (State.Board.NBoards -> Bool) + :: (Type.Count.NPositions -> Bool) -> InstancesByPosition position -> Bool -anyInstancesByPosition predicate MkInstancesByPosition { getNBoardsByPosition = m } = Data.Foldable.any predicate m +anyInstancesByPosition predicate MkInstancesByPosition { getNPositionsByPosition = m } = Data.Foldable.any predicate m {- | * Find the maximum number of times any one position has already been visited. * CAVEAT: only those positions that can still be reached are considered. -} -findMaximumInstances :: InstancesByPosition position -> State.Board.NBoards -findMaximumInstances MkInstancesByPosition { getNBoardsByPosition = m } +findMaximumInstances :: InstancesByPosition position -> Type.Count.NPositions +findMaximumInstances MkInstancesByPosition { getNPositionsByPosition = m } | Data.Map.Strict.null m = 0 -- CAVEAT: this shouldn't happen. | otherwise = Data.Foldable.maximum m @@ -140,14 +133,15 @@ => Bool -- ^ Whether the /turn/ which led to the specified /position/, was repeatable. -> position -> Transformation position -insertPosition isRepeatable position MkInstancesByPosition { getNBoardsByPosition = m } +insertPosition isRepeatable position MkInstancesByPosition { getNPositionsByPosition = m } | isRepeatable = MkInstancesByPosition $ Data.Map.Strict.insertWith (const succ) position 1 m -- Include this position. | otherwise = mkSingleton position -- The previous position can't be revisited without rolling-back. -- | Remove a /position/ from the collection, as required to implement rollback. deletePosition :: Ord position => position -> Transformation position -deletePosition position MkInstancesByPosition { getNBoardsByPosition = m } = MkInstancesByPosition . Data.Map.Strict.update ( +deletePosition position MkInstancesByPosition { getNPositionsByPosition = m } = MkInstancesByPosition . Data.Map.Strict.update ( \n -> if n == 1 then Nothing -- Delete the entry. else Just $ pred n -- Decrement the number of instances. ) position $ Control.Exception.assert (Data.Map.Strict.member position m) m + 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 @@ -62,6 +62,7 @@ import Control.Applicative((<|>)) import Control.Arrow((&&&), (***)) +import Control.Category((>>>)) import Data.Array.IArray((!), (//)) import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme import qualified BishBosh.Attribute.Direction as Attribute.Direction @@ -90,7 +91,8 @@ import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -168,7 +170,7 @@ Ord y ) => Property.ExtendedPositionDescription.ShowsEPD (MaybePieceByCoordinates x y) where showsEPD MkMaybePieceByCoordinates { deconstruct = byCoordinates } = foldr1 ( - flip (.) -- Render the line with the highest y-coordinate first. + >>> -- Render the line with the highest y-coordinate first. ) . Data.List.intersperse ( showChar rankSeparator -- Separate the lines. ) . map ( @@ -263,7 +265,7 @@ in nBlack `seq` nWhite `seq` acc' ) (0, 0) . getPieces - countPieces = length . getPieces + countPieces = fromIntegral . length . getPieces countPieceDifferenceByRank = Data.Array.IArray.accumArray (+) 0 (minBound, maxBound) . map ( Component.Piece.getRank &&& ( @@ -300,7 +302,12 @@ ([_], [_]) -> True _ -> False -instance (Enum x, Enum y, Ord x, Ord y) => Component.Zobrist.Hashable2D MaybePieceByCoordinates x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where +instance ( + Enum x, + Enum y, + Ord x, + Ord y + ) => Component.Zobrist.Hashable2D MaybePieceByCoordinates x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where listRandoms2D MkMaybePieceByCoordinates { deconstruct = byCoordinates } zobrist = [ Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (Component.Piece.getLogicalColour piece, Component.Piece.getRank piece, coordinates) zobrist | (coordinates, Just piece) <- Data.Array.IArray.assocs byCoordinates @@ -319,7 +326,7 @@ Ord x, Ord y ) => StateProperty.Seeker.Seeker MaybePieceByCoordinates x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker MaybePieceByCoordinates T.X T.Y #-} + {-# SPECIALISE instance StateProperty.Seeker.Seeker MaybePieceByCoordinates Type.Length.X Type.Length.Y #-} findProximateKnights logicalColour destination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = filter ( (== Just knight) . (byCoordinates !) ) $ Component.Piece.findAttackDestinations destination knight where @@ -337,7 +344,7 @@ Ord x, Ord y ) => StateProperty.Mutator.Mutator MaybePieceByCoordinates x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Mutator.Mutator MaybePieceByCoordinates T.X T.Y #-} + {-# SPECIALISE instance StateProperty.Mutator.Mutator MaybePieceByCoordinates Type.Length.X Type.Length.Y #-} defineCoordinates maybePiece coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( Data.Maybe.isJust maybePiece || Data.Maybe.isJust (byCoordinates ! coordinates) ) . MkMaybePieceByCoordinates $ byCoordinates // [(coordinates, maybePiece)] @@ -368,7 +375,7 @@ -> Maybe Attribute.Rank.Rank -- ^ The /rank/ to which a @Pawn@ should be promoted; defaulting to @Queen@. -> MaybePieceByCoordinates x y -> Attribute.MoveType.MoveType -{-# SPECIALISE inferMoveType :: Component.Move.Move T.X T.Y -> Maybe Attribute.Rank.Rank -> MaybePieceByCoordinates T.X T.Y -> Attribute.MoveType.MoveType #-} +{-# SPECIALISE inferMoveType :: Component.Move.Move Type.Length.X Type.Length.Y -> Maybe Attribute.Rank.Rank -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Attribute.MoveType.MoveType #-} inferMoveType move maybePromotionRank maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } | Just sourcePiece <- byCoordinates ! Component.Move.getSource move = Data.Maybe.maybe ( if isEnPassantMove move maybePieceByCoordinates @@ -410,7 +417,7 @@ -> Component.Piece.Piece -- ^ The /piece/ at the specified source. -> MaybePieceByCoordinates x y -> [(Cartesian.Coordinates.Coordinates x y, Maybe Attribute.Rank.Rank)] -- ^ The destination & the rank of any piece taken. -{-# SPECIALISE listDestinationsFor :: Cartesian.Coordinates.Coordinates T.X T.Y -> Component.Piece.Piece -> MaybePieceByCoordinates T.X T.Y -> [(Cartesian.Coordinates.Coordinates T.X T.Y, Maybe Attribute.Rank.Rank)] #-} +{-# SPECIALISE listDestinationsFor :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Component.Piece.Piece -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> [(Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y, Maybe Attribute.Rank.Rank)] #-} listDestinationsFor source piece maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( byCoordinates ! source == Just piece ) $ if Component.Piece.getRank piece `elem` Attribute.Rank.fixedAttackRange @@ -460,13 +467,12 @@ -- | Show the /board/ in two dimensions, with /x/ & /y/ indexes. shows2D :: ( - Enum x, - Enum y, - Integral column, - Ord x, - Ord y + Enum x, + Enum y, + Ord x, + Ord y ) - => column -- ^ The column-magnification. + => Type.Length.Column -- ^ The column-magnification. -> Attribute.ColourScheme.ColourScheme -> (Int, Int) -- ^ The origin from which axes are labelled. -> MaybePieceByCoordinates x y @@ -513,13 +519,12 @@ -- | Show the board using a two-dimensional representation. show2D :: ( - Enum x, - Enum y, - Integral column, - Ord x, - Ord y + Enum x, + Enum y, + Ord x, + Ord y ) - => column -- ^ The column-magnification. + => Type.Length.Column -- ^ The column-magnification. -> Attribute.ColourScheme.ColourScheme -> (Int, Int) -- ^ The origin from which axes are labelled. -> MaybePieceByCoordinates x y @@ -550,7 +555,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ The starting point. -> MaybePieceByCoordinates x y -> Maybe (Component.Piece.LocatedPiece x y) -{-# SPECIALISE findBlockingPiece :: Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates T.X T.Y -> MaybePieceByCoordinates T.X T.Y -> Maybe (Component.Piece.LocatedPiece T.X T.Y) #-} +{-# SPECIALISE findBlockingPiece :: Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Maybe (Component.Piece.LocatedPiece Type.Length.X Type.Length.Y) #-} {- CAVEAT: too slow. findBlockingPiece direction source MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.listToMaybe . Data.Maybe.mapMaybe ( uncurry fmap . ((,) &&& (byCoordinates !)) @@ -590,7 +595,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ The defender's square. -> MaybePieceByCoordinates x y -> Maybe (Cartesian.Coordinates.Coordinates x y, Attribute.Rank.Rank) -- ^ Any opposing /piece/ which can attack the specified square from the specified /direction/. -{-# SPECIALISE findAttackerInDirection :: Attribute.LogicalColour.LogicalColour -> Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates T.X T.Y -> MaybePieceByCoordinates T.X T.Y -> Maybe (Cartesian.Coordinates.Coordinates T.X T.Y, Attribute.Rank.Rank) #-} +{-# SPECIALISE findAttackerInDirection :: Attribute.LogicalColour.LogicalColour -> Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Maybe (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y, Attribute.Rank.Rank) #-} findAttackerInDirection destinationLogicalColour direction destination = (=<<) ( \(source, sourcePiece) -> if Component.Piece.getLogicalColour sourcePiece /= destinationLogicalColour && Component.Piece.canAttackAlong source destination sourcePiece then Just (source, Component.Piece.getRank sourcePiece) @@ -641,7 +646,7 @@ -> MaybePieceByCoordinates x y -> Bool {-# INLINABLE isClear #-} -- N.B.: required to ensure specialisation of 'Cartesian.Coordinates.interpolate'. -{-# SPECIALISE isClear :: Cartesian.Coordinates.Coordinates T.X T.Y -> Cartesian.Coordinates.Coordinates T.X T.Y -> MaybePieceByCoordinates T.X T.Y -> Bool #-} +{-# SPECIALISE isClear :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Bool #-} isClear source destination maybePieceByCoordinates = 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 @@ -657,7 +662,7 @@ -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. -> MaybePieceByCoordinates x y -> Bool -{-# SPECIALISE isObstructed :: Cartesian.Coordinates.Coordinates T.X T.Y -> Cartesian.Coordinates.Coordinates T.X T.Y -> MaybePieceByCoordinates T.X T.Y -> Bool #-} +{-# SPECIALISE isObstructed :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Bool #-} isObstructed source destination = not . isClear source destination {- | @@ -675,7 +680,7 @@ => Component.Move.Move x y -> MaybePieceByCoordinates x y -> Bool -{-# SPECIALISE isEnPassantMove :: Component.Move.Move T.X T.Y -> MaybePieceByCoordinates T.X T.Y -> Bool #-} +{-# SPECIALISE isEnPassantMove :: Component.Move.Move Type.Length.X Type.Length.Y -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Bool #-} isEnPassantMove move maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } | Just piece <- byCoordinates ! source , let logicalColour = Component.Piece.getLogicalColour piece @@ -702,7 +707,7 @@ -> Component.Piece.Piece -- ^ The (possibly promoted) piece to place at the destination. -> Maybe (Cartesian.Coordinates.Coordinates x y) -- ^ Destination of any En-passant @Pawn@. -> Transformation x y -{-# SPECIALISE movePiece :: Component.Move.Move T.X T.Y -> Component.Piece.Piece -> Maybe (Cartesian.Coordinates.Coordinates T.X T.Y) -> Transformation T.X T.Y #-} +{-# SPECIALISE movePiece :: Component.Move.Move Type.Length.X Type.Length.Y -> Component.Piece.Piece -> Maybe (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) -> Transformation Type.Length.X Type.Length.Y #-} movePiece move destinationPiece maybeEnPassantDestination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = MkMaybePieceByCoordinates $ byCoordinates // Data.Maybe.maybe id ( (:) . flip (,) Nothing -- Take the Pawn en-passant. ) maybeEnPassantDestination [ @@ -726,7 +731,7 @@ => Component.PieceSquareByCoordinatesByRank.FindPieceSquareValue x y pieceSquareValue -> MaybePieceByCoordinates x y -> [pieceSquareValue] -{-# SPECIALISE sumPieceSquareValueByLogicalColour :: Component.PieceSquareByCoordinatesByRank.FindPieceSquareValue T.X T.Y T.PieceSquareValue -> MaybePieceByCoordinates T.X T.Y -> [T.PieceSquareValue] #-} +{-# SPECIALISE sumPieceSquareValueByLogicalColour :: Component.PieceSquareByCoordinatesByRank.FindPieceSquareValue Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue -> MaybePieceByCoordinates Type.Length.X Type.Length.Y -> [Type.Mass.PieceSquareValue] #-} sumPieceSquareValueByLogicalColour findPieceSquareValue = ( \(b, w) -> [b, w] ) . Data.List.foldl' ( 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 @@ -52,7 +52,7 @@ import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour import qualified BishBosh.State.EnPassantAbscissa as State.EnPassantAbscissa import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Data.Array.IArray import qualified Data.Maybe @@ -71,7 +71,7 @@ Ord x, Ord y ) => Ord (Position x y) where - {-# SPECIALISE instance Ord (Position T.X T.Y) #-} + {-# SPECIALISE instance Ord (Position Type.Length.X Type.Length.Y) #-} position@MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates @@ -143,7 +143,7 @@ -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x -> Maybe (Component.Turn.Turn x y) -- ^ The last /turn/ made. -> Position x y -{-# SPECIALISE mkPosition :: Attribute.LogicalColour.LogicalColour -> State.MaybePieceByCoordinates.MaybePieceByCoordinates T.X T.Y -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour T.X -> Maybe (Component.Turn.Turn T.X T.Y) -> Position T.X T.Y #-} +{-# SPECIALISE mkPosition :: Attribute.LogicalColour.LogicalColour -> State.MaybePieceByCoordinates.MaybePieceByCoordinates Type.Length.X Type.Length.Y -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour Type.Length.X -> Maybe (Component.Turn.Turn Type.Length.X Type.Length.Y) -> Position Type.Length.X Type.Length.Y #-} mkPosition nextLogicalColour maybePieceByCoordinates castleableRooksByLogicalColour maybeLastTurn = MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates, -- N.B.: one could have used 'State.CoordinatesByRankByLogicalColour.CoordinatesByRankByLogicalColour', except that the coordinates have an undefined order. 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 @@ -46,12 +46,12 @@ import Control.Arrow((&&&), (***)) import Data.Array.IArray((!), (//)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.Null as Property.Null import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -63,17 +63,17 @@ -- | The type used to hold a record of each player's /turn/s. data TurnsByLogicalColour turn = MkTurnsByLogicalColour { getTurnsByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [turn], - getNPlies :: Component.Move.NPlies -- ^ The number of plies applied to the game; this could alternatively be derived using 'countPlies'. + getNPlies :: Type.Count.NPlies -- ^ The total number of plies applied to the game for both players; this could alternatively be derived using 'countPlies'. } instance Eq turn => Eq (TurnsByLogicalColour turn) where MkTurnsByLogicalColour { getTurnsByLogicalColour = aL } == MkTurnsByLogicalColour { getTurnsByLogicalColour = aR } = aL == aR instance (Read turn, Show turn) => Read (TurnsByLogicalColour turn) where - readsPrec _ s = Control.Arrow.first fromAssocs `map` reads s + readsPrec precedence s = Control.Arrow.first fromAssocs `map` readsPrec precedence s instance Show turn => Show (TurnsByLogicalColour turn) where - showsPrec _ MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = shows $ Data.Array.IArray.assocs byLogicalColour + showsPrec precedence MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = showsPrec precedence $ Data.Array.IArray.assocs byLogicalColour instance Control.DeepSeq.NFData turn => Control.DeepSeq.NFData (TurnsByLogicalColour turn) where rnf MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour @@ -101,7 +101,9 @@ -- | Smart constructor. fromAssocs :: Show turn => [(Attribute.LogicalColour.LogicalColour, [turn])] -> TurnsByLogicalColour turn fromAssocs assocs - | length assocs /= Attribute.LogicalColour.nDistinctLogicalColours = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.State.TurnsByLogicalColour.fromAssocs:\tboth logical colours must be defined; " $ shows assocs "." + | 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 "." | (> 1) . abs {-allow for Property.Reflectable.reflectOnX-} . uncurry (-) $ ( length . (! Attribute.LogicalColour.White) &&& length . (! Attribute.LogicalColour.Black) @@ -125,12 +127,12 @@ | otherwise = Attribute.LogicalColour.Black {- | - * Count the number of plies. + * Count the total number of plies, regardless of the player. * CAVEAT: 'getNPlies' is more efficient. -} -countPlies :: TurnsByLogicalColour turn -> Component.Move.NPlies -countPlies MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 byLogicalColour +countPlies :: TurnsByLogicalColour turn -> Type.Count.NPlies +countPlies MkTurnsByLogicalColour { getTurnsByLogicalColour = byLogicalColour } = fromIntegral $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 byLogicalColour -- | Dereference. dereference :: Attribute.LogicalColour.LogicalColour -> TurnsByLogicalColour turn -> [turn] 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -31,28 +30,22 @@ Censor(..) ) where -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Attribute.Rank as Attribute.Rank +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 = -#ifdef USE_UNBOXED_ARRAYS - Attribute.Rank.UArrayByRank -#else - Attribute.Rank.ArrayByRank -#endif - Component.Piece.NPieces +type NPiecesByRank = Attribute.Rank.ArrayByRank Type.Count.NPieces -- | An interface which may be implemented by data which can perform a census of the /piece/s on the /board/. class Censor censor where - countPiecesByLogicalColour :: censor -> (Component.Piece.NPieces, Component.Piece.NPieces) -- ^ The total number of /piece/s, partitioned into @Black@ & @White@ respectively. + countPiecesByLogicalColour :: censor -> (Type.Count.NPieces, Type.Count.NPieces) -- ^ The total number of /piece/s, partitioned into @Black@ & @White@ respectively. - countPieces :: censor -> Component.Piece.NPieces -- ^ The total number of /piece/s on the board, regardless of logical colour. + countPieces :: censor -> Type.Count.NPieces -- ^ The total number of /piece/s on the board, regardless of logical colour. countPieces = uncurry (+) . countPiecesByLogicalColour -- Default implementation. - countPieceDifferenceByRank :: censor -> NPiecesByRank -- ^ Finds the difference between the number of /piece/s of each /rank/ held by each side. N.B. for this purpose, @White@ is arbitrarily considered positive & @Black@ negative. + countPieceDifferenceByRank :: censor -> NPiecesByRank -- ^ Finds the difference between the number of /piece/s of each /rank/ held by each side. N.B. for this purpose, @White@ is arbitrarily considered positive & @Black@ negative. - hasInsufficientMaterial :: censor -> Bool -- ^ Whether insufficient material remains on the board, to force check-mate; . + 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/. + hasBothKings :: censor -> Bool -- ^ Whether there's exactly one @King@ of each /logical colour/. diff --git a/src-lib/BishBosh/Text/Case.hs b/src-lib/BishBosh/Text/Case.hs --- a/src-lib/BishBosh/Text/Case.hs +++ b/src-lib/BishBosh/Text/Case.hs @@ -43,3 +43,4 @@ -- | Convert the initial letter of the specified string to upper-case. toUpperInitial :: String -> String toUpperInitial = translateInitial Data.Char.toUpper + diff --git a/src-lib/BishBosh/Text/ShowPrefix.hs b/src-lib/BishBosh/Text/ShowPrefix.hs --- a/src-lib/BishBosh/Text/ShowPrefix.hs +++ b/src-lib/BishBosh/Text/ShowPrefix.hs @@ -40,3 +40,4 @@ -- | Used to qualify output. showsPrefixError :: ShowS showsPrefixError = showString "ERROR:\t" + diff --git a/src-lib/BishBosh/Time/GameClock.hs b/src-lib/BishBosh/Time/GameClock.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Time/GameClock.hs @@ -0,0 +1,88 @@ +{- + 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 two stop-watches, exactly one of which is running at any time. +-} + +module BishBosh.Time.GameClock( +-- * Types +-- ** Data-types + GameClock( +-- MkGameClock, + deconstruct + ), +-- * Functions + showsElapsedTimes + ) where + +import Control.Arrow((***)) +import qualified BishBosh.Attribute.LogicalColour as Attribute.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.Switchable as Property.Switchable +import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Time.StopWatch as Time.StopWatch +import qualified BishBosh.Type.Count as Type.Count +import qualified Control.Exception +import qualified Data.Array.IArray +import qualified Data.Default +import qualified Data.Foldable + +-- | 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. +} + +instance Property.Switchable.Switchable GameClock where + on = fmap ( + MkGameClock . Attribute.LogicalColour.listArrayByLogicalColour . ( + Data.Default.def : -- A stopped watch for Black. + ) . return {-to List-monad-} + ) Property.Switchable.on -- A running watch for White. + + 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 + ) . mapM Property.Switchable.toggle . Data.Array.IArray.elems $ deconstruct gameClock + + switchOff = fmap ( + MkGameClock . Attribute.LogicalColour.listArrayByLogicalColour + ) . mapM Property.Switchable.switchOff . Data.Array.IArray.elems . 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. + + isOff = Data.Foldable.all Property.Switchable.isOff . deconstruct + +instance Property.SelfValidating.SelfValidating GameClock where + findInvalidity = Property.SelfValidating.findErrors [ + ((/= 1) . length . filter Property.Switchable.isOn . Data.Array.IArray.elems . deconstruct, "The two stop-watches must be in opposite states") + ] + +-- | Show the elapsed times. +showsElapsedTimes :: Type.Count.NDecimalDigits -> GameClock -> IO ShowS +showsElapsedTimes nDecimalDigits = fmap ( + Text.ShowList.showsAssociationList' . map ( + show *** Property.ShowFloat.showsFloatToN nDecimalDigits + ) . Data.Array.IArray.assocs . deconstruct + ) . Property.Switchable.switchOff + diff --git a/src-lib/BishBosh/Time/StopWatch.hs b/src-lib/BishBosh/Time/StopWatch.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Time/StopWatch.hs @@ -0,0 +1,82 @@ +{- + 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 a stop-watch for use by a single player; so two independent instances will be required to construct a game-clock. +-} + +module BishBosh.Time.StopWatch( +-- * Types +-- ** Data-types + StopWatch( +-- MkStopWatch, +-- deconstruct + ), +-- * Functions + getElapsedTime, +-- ** Constructor + mkStoppedWatch + ) where + +import Control.Arrow((&&&), (|||)) +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Property.ShowFloat as Property.ShowFloat +import qualified BishBosh.Property.Switchable as Property.Switchable +import qualified Control.DeepSeq +import qualified Control.Exception +import qualified Data.Default +import qualified Data.Time.Clock + +-- | The watch is either running & records the time at which it was started, or is stopped & records the elapsed duration. +newtype StopWatch = MkStopWatch { + deconstruct :: Either Data.Time.Clock.UTCTime Data.Time.Clock.NominalDiffTime -- ^ Either the start-time or the previously elapsed duration. +} deriving (Eq, Show) + +instance Control.DeepSeq.NFData StopWatch where + rnf MkStopWatch { deconstruct = e } = Control.DeepSeq.rnf ||| Control.DeepSeq.rnf $ e + +instance Data.Default.Default StopWatch where + def = mkStoppedWatch 0 + +instance Property.ShowFloat.ShowFloat StopWatch where + showsFloat fromDouble = fromDouble . getElapsedTime + +instance Property.Switchable.Switchable StopWatch where + on = Property.Switchable.toggle Data.Default.def + + toggle MkStopWatch { deconstruct = e } = do + (diffUTCTime', addUTCTime') <- fmap (Data.Time.Clock.diffUTCTime &&& flip Data.Time.Clock.addUTCTime) Data.Time.Clock.getCurrentTime -- Partially apply the functions to the current time. + + return {-to IO-monad-} . MkStopWatch $ (Right . diffUTCTime' ||| Left . addUTCTime' . negate) e -- Complete the function-application. N.B.: Right & Left are reflected. + + isOn MkStopWatch { deconstruct = Left _ } = True + isOn _ = False + +-- | Constructor. +mkStoppedWatch :: Data.Time.Clock.NominalDiffTime -> StopWatch +mkStoppedWatch = MkStopWatch . Right + +-- | Extract the elapsed time from a stopped watch. +getElapsedTime :: Fractional f => StopWatch -> f +getElapsedTime MkStopWatch { + deconstruct = Right nominalDiffTime +} = realToFrac nominalDiffTime +getElapsedTime _ = Control.Exception.throw $ Data.Exception.mkRequestFailure "BishBosh.Time.StopWatch.getElapsedTime:\tthe watch is still running." + diff --git a/src-lib/BishBosh/Type/Count.hs b/src-lib/BishBosh/Type/Count.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Type/Count.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{- + 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 distinct types for various countable quantities to prevent accidental conflation between conceptually different quantities. + + * Nothing but the type is exported, facilitating reversion to unwrapped types. +-} + +module BishBosh.Type.Count( +-- * Types +-- ** Type-synonyms +-- Base, +-- ** Data-types + NDecimalDigits, + NDirections, + NGames, + NLogicalColours, + NMoves, + NPieces, + NPlies, + NPositions, + NRanks, + NSeconds, +) where + +#ifdef USE_NEWTYPE_WRAPPERS +import qualified Control.DeepSeq +import qualified Data.Array.IArray +import qualified Text.XML.HXT.Arrow.Pickle as HXT +#endif + +-- | The private type which is wrapped by countable data-types. +type Base = Int + +-- | A number of decimal digits. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NDecimalDigits = MkNDecimalDigits Base deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Real) + +instance Show NDecimalDigits where + showsPrec precedence (MkNDecimalDigits n) = showsPrec precedence n +#else +type NDecimalDigits = Base +#endif + +-- | A number of decimal digits. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NDirections = MkNDirections Base deriving (Enum, Eq, Integral, Num, Ord, Real) +#else +type NDirections = Base +#endif + +-- | A number of /game/s. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NGames = MkNGames Base deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Real) + +instance Show NGames where + showsPrec precedence (MkNGames n) = showsPrec precedence n +#else +type NGames = Base +#endif + +-- | A number of /logical colour/s. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NLogicalColours = MkNLogicalColours Base deriving (Enum, Eq, Integral, Num, Ord, Real) + +instance Show NLogicalColours where + showsPrec precedence (MkNLogicalColours n) = showsPrec precedence n +#else +type NLogicalColours = Base +#endif + +-- | A number of /move/s, i.e. each player takes one turn. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NMoves = MkNMoves Base deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Real) + +instance Show NMoves where + showsPrec precedence (MkNMoves n) = showsPrec precedence n +#else +type NMoves = Base +#endif + +-- | A number of /piece/s. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NPieces = MkNPieces Base deriving (Control.DeepSeq.NFData, Data.Array.IArray.Ix, Enum, Eq, Integral, Num, Ord, Real) + +instance Show NPieces where + showsPrec precedence (MkNPieces n) = showsPrec precedence n +#else +type NPieces = Base +#endif + +{- | + * A number of /plies/. + + * CAVEAT: conceptually similar to /NPositions/ in that a ply (half a move) defines a step down the move-tree to a new position; the difference is that positions don't necessarily relate to a consecutive sequence resulting from a game. + + * CAVEAT: arguably the same type as /NMoves/, just double the value. +-} +#ifdef USE_NEWTYPE_WRAPPERS +newtype NPlies = MkNPlies Base deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Read, Real) + +instance Show NPlies where + showsPrec precedence (MkNPlies n) = showsPrec precedence n +#else +type NPlies = Base +#endif + +-- | A number of /position/s. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NPositions = MkNPositions Base deriving (Control.DeepSeq.NFData, Enum, Eq, Integral, Num, Ord, Real) + +instance Show NPositions where + showsPrec precedence (MkNPositions n) = showsPrec precedence n +#else +type NPositions = Base +#endif + +-- | A number of /rank/s. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NRanks = MkNRanks Base deriving (Enum, Eq, Integral, Num, Ord, Real) +#else +type NRanks = Base +#endif + +-- | A number of seconds. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NSeconds = MkNSeconds Base deriving (Enum, Eq, Integral, Num, Ord, Real) + +instance Show NSeconds where + showsPrec precedence (MkNSeconds n) = showsPrec precedence n +#else +type NSeconds = Base +#endif + diff --git a/src-lib/BishBosh/Type/Crypto.hs b/src-lib/BishBosh/Type/Crypto.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Type/Crypto.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +{- + 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 suitable concrete types with which to specialise miscellaneous type-parameters. + + * CAVEAT: use of narrow numeric types, results in marginally slower performance without any reduction in space-requirements. +-} + +module BishBosh.Type.Crypto( +-- * Types +-- ** Type-synonyms + PositionHash, +) where + +import qualified Data.Word + +-- | The type of the hash used to uniquely represent a /position/. +type PositionHash = +#ifdef USE_NARROW_NUMBERS + Data.Word.Word32 -- CAVEAT: hash-collisions become almost inevitable after @ sqrt bits @ trials. +#else + Data.Word.Word +#endif + diff --git a/src-lib/BishBosh/Type/Length.hs b/src-lib/BishBosh/Type/Length.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Type/Length.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} +{-# 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@] + + * Defines suitable concrete types with which to specialise length-related type-parameters. + + * CAVEAT: use of narrow numeric types, results in marginally slower performance without any reduction in space-requirements. +-} + +module BishBosh.Type.Length( +-- * Types +-- ** Type-synonyms +-- Base, + Distance, + X, + Y, + Row(), + Column() +) where + +#if defined(USE_NARROW_NUMBERS) || defined(USE_NEWTYPE_WRAPPERS) +# ifdef USE_NARROW_NUMBERS +import qualified Data.Int +# endif + +# ifdef USE_NEWTYPE_WRAPPERS +import qualified Control.DeepSeq +# endif +import qualified Text.XML.HXT.Arrow.Pickle as HXT +#endif + +-- | The preferred type by which to represent the abscissa. CAVEAT: while conceptually unsigned, various unguarded calls to 'pred' prevent this. +type Base = +#ifdef USE_NARROW_NUMBERS + Data.Int.Int8 + +instance HXT.XmlPickler Data.Int.Int8 where + xpickle = HXT.xpPrim +#else + Int +#endif + +{- | + * The preferred type by which to represent the signed distance of a move. + + * N.B.: since /distance/ is used to represent only the horizontal or vertical component of a move, rather than a diagonal length, it can be represented by an integral value. +-} +type Distance = Base -- N.B.: conceptually independent of both 'X' & 'Y' which could be unsigned. + +-- | The distance along the abscissa. +type X = Base + +-- | The distance along the ordinate. +type Y = Base -- N.B.: it can be independent of 'X'. + +-- | Indexes screen-coordinates in the vertical direction. +#ifdef USE_NEWTYPE_WRAPPERS +newtype Row = MkRow Y deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Real) + +instance Show Row where + showsPrec precision (MkRow row) = showsPrec precision row +#else +type Row = Y +#endif + +-- | Indexes screen-coordinates in the horizontal direction. +#ifdef USE_NEWTYPE_WRAPPERS +newtype Column = MkColumn X deriving (Control.DeepSeq.NFData, Enum, Eq, HXT.XmlPickler, Integral, Num, Ord, Real) + +instance Show Column where + showsPrec precision (MkColumn column) = showsPrec precision column +#else +type Column = X +#endif + diff --git a/src-lib/BishBosh/Type/Mass.hs b/src-lib/BishBosh/Type/Mass.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Type/Mass.hs @@ -0,0 +1,72 @@ +{-# 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@] + + * Defines distinct types for various mass (uncountable) quantities. + + * These prevent accidental conflation between conceptually different quantities. +-} + +module BishBosh.Type.Mass( +-- * Types +-- ** Type-synonyms + CriterionWeight, + CriterionValue, + WeightedMean, + RankValue, + PieceSquareValue +) where + +import qualified Text.XML.HXT.Arrow.Pickle as HXT + +-- | The preferred type by which to weight criteria. +type CriterionWeight = +#ifdef USE_NARROW_NUMBERS + Float + +instance HXT.XmlPickler Float where + xpickle = HXT.xpPrim +#else + Double -- N.B.: 'Rational' is a more accurate, but slower alternative. + +instance HXT.XmlPickler Double where + xpickle = HXT.xpPrim +#endif + +-- | The preferred type by which to value criteria. +type CriterionValue = CriterionWeight + +-- | The preferred 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 preferred type by which to represent a /piece-square/ value. + + * CAVEAT: performance of 'BishBosh.Evaluation.Fitness.interpolatePieceSquareValues' suffers from use of 'Rational'. +-} +type PieceSquareValue = CriterionValue + diff --git a/src-lib/BishBosh/Types.hs b/src-lib/BishBosh/Types.hs deleted file mode 100644 --- a/src-lib/BishBosh/Types.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE CPP #-} -{- - 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 suitable concrete types with which to specialise type-parameters. - - * CAVEAT: use of the narrow set of numeric types, results in marginally slower performance without any reduction in space-requirements. --} - -module BishBosh.Types( --- * Types --- ** Type-synonyms - CriterionWeight, - CriterionValue, - WeightedMean, - X, - Y, - Distance, - RankValue, - PieceSquareValue, - PositionHash -) where - -import qualified Data.Word - -#ifdef USE_NARROW_NUMBERS -import qualified Data.Int -#endif - --- | The preferred type by which to weight criteria. -type CriterionWeight = -#ifdef USE_NARROW_NUMBERS - Float -#else - Double -- N.B.: 'Rational' is more accurate, but slower alternative. -#endif - --- | The preferred type by which to value criteria. -type CriterionValue = CriterionWeight - --- | The preferred type by which to represent fitness. -type WeightedMean = CriterionValue - --- | The preferred type by which to represent the abscissa. CAVEAT: while conceptually unsigned, various unguarded calls to 'pred' prevent this. -type X = -#ifdef USE_NARROW_NUMBERS - Data.Int.Int8 -#else - Int -#endif - --- | The preferred type by which to represent the ordinate. -type Y = X -- N.B.: it can be independent of 'X'. - -{- | - * The preferred type by which to represent the signed distance of a move. - - * N.B.: since /distance/ is used to represent only the horizontal or vertical component of a move, rather than a diagonal length, it can be represented by an integral value. --} -type Distance = X -- N.B.: conceptually independent of both 'X' & 'Y' which could be unsigned. - --- | The preferred type by which to represent the value of a /rank/. -type RankValue = CriterionValue - -{- | - * The preferred type by which to represent a /piece-square/ value. - - * CAVEAT: performance of 'BishBosh.Evaluation.Fitness.interpolatePieceSquareValues' suffers from use of 'Rational'. --} -type PieceSquareValue = CriterionValue - --- | The type of the hash used to uniquely represent a /position/. -type PositionHash = -#ifdef USE_NARROW_NUMBERS - Data.Word.Word32 -- CAVEAT: hash-collisions become almost inevitable after @ sqrt bits @ trials. -#else - Data.Word.Word -#endif - diff --git a/src-lib/BishBosh/UI/Command.hs b/src-lib/BishBosh/UI/Command.hs --- a/src-lib/BishBosh/UI/Command.hs +++ b/src-lib/BishBosh/UI/Command.hs @@ -51,11 +51,11 @@ autoComplete ) where -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.List import qualified BishBosh.Input.Options as Input.Options import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Text.AutoComplete as Text.AutoComplete +import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.UI.PrintObject as UI.PrintObject import qualified BishBosh.UI.ReportObject as UI.ReportObject import qualified BishBosh.UI.SetObject as UI.SetObject @@ -136,7 +136,7 @@ | Report UI.ReportObject.ReportObject -- ^ Report on the requested dynamic data. | Resign -- ^ Admit defeat. | Restart -- ^ Abandon the current game, & start afresh. - | RollBack (Maybe Component.Move.NPlies) -- ^ Roll-back the optionally specified number of plies. + | RollBack (Maybe Type.Count.NPlies) -- ^ Roll-back the optionally specified number of plies. | Save -- ^ Persist the current game-state. | Set UI.SetObject.SetObject -- ^ I.E. mutate a configuration-value. | Swap -- ^ Swap options between the two sides; which causes the players to swap sides. @@ -234,9 +234,9 @@ [("rollback", s')] -> case Data.List.Extra.trimStart s' of [] -> Right (RollBack Nothing, s') s'' -> case reads s'' of - [(nMoves, s''')] - | nMoves <= 0 -> Left . showString "the specified number of plies (" $ shows nMoves ") must exceed zero" - | otherwise -> Right (RollBack (Just nMoves), s''') + [(nPlies, s''')] + | nPlies <= 0 -> Left . showString "the specified number of plies (" $ shows nPlies ") must exceed zero" + | otherwise -> Right (RollBack (Just $ fromInteger nPlies), s''') _ -> Left . showString "failed to read the integral number of plies to " . showString rollBackTag . showString " from " $ show s'' [("swap", s')] -> Right (Swap, s') (command, _) : _ -> Left . showString "failed to read a command from " . shows s . showString "; did you mean " . show . BishBosh.Data.List.findClosest command $ map (\(tag, _, _) -> tag) commands @@ -261,3 +261,4 @@ autoComplete = Text.AutoComplete.autoComplete $ "help" : map ( \(tag, _, _) -> tag ) commands + diff --git a/src-lib/BishBosh/UI/PrintObject.hs b/src-lib/BishBosh/UI/PrintObject.hs --- a/src-lib/BishBosh/UI/PrintObject.hs +++ b/src-lib/BishBosh/UI/PrintObject.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -59,9 +58,8 @@ rnf _ = () instance Show PrintObject where - showsPrec _ = showString . \case - Configuration -> configurationTag - Help -> helpTag + show Configuration = configurationTag + show Help = helpTag instance Read PrintObject where readsPrec _ s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of diff --git a/src-lib/BishBosh/UI/ReportObject.hs b/src-lib/BishBosh/UI/ReportObject.hs --- a/src-lib/BishBosh/UI/ReportObject.hs +++ b/src-lib/BishBosh/UI/ReportObject.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {- Copyright (C) 2021 Dr. Alistair Ward @@ -101,16 +100,15 @@ rnf _ = () instance Show ReportObject where - showsPrec _ = showString . \case - AvailableMoves -> availableMovesTag - Board -> boardTag - EPD -> epdTag - FEN -> fenTag - Game -> gameTag - MaxPositionInstances -> maxPositionInstancesTag - Moves -> movesTag - PGN -> pgnTag - ReversiblePlyCount -> reversiblePlyCountTag + show AvailableMoves = availableMovesTag + show Board = boardTag + show EPD = epdTag + show FEN = fenTag + show Game = gameTag + show MaxPositionInstances = maxPositionInstancesTag + show Moves = movesTag + show PGN = pgnTag + show ReversiblePlyCount = reversiblePlyCountTag instance Read ReportObject where readsPrec _ s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of diff --git a/src-lib/BishBosh/UI/SetObject.hs b/src-lib/BishBosh/UI/SetObject.hs --- a/src-lib/BishBosh/UI/SetObject.hs +++ b/src-lib/BishBosh/UI/SetObject.hs @@ -35,13 +35,14 @@ import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Text.AutoComplete as Text.AutoComplete +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.List.Extra -- | The fields a user can mutate; currently there's only one. -newtype SetObject = SearchDepth Input.SearchOptions.SearchDepth deriving Eq +newtype SetObject = SearchDepth Type.Count.NPlies deriving Eq instance Control.DeepSeq.NFData SetObject where rnf (SearchDepth searchDepth) = Control.DeepSeq.rnf searchDepth @@ -51,11 +52,11 @@ instance Read SetObject where readsPrec _ s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of - [("searchdepth", s')] -> Control.Arrow.first mkSearchDepth `map` reads s' + [("searchdepth", s')] -> Control.Arrow.first (mkSearchDepth . fromInteger) `map` reads s' _ -> [] -- No parse. -- | Smart constructor. -mkSearchDepth :: Input.SearchOptions.SearchDepth -> SetObject +mkSearchDepth :: Type.Count.NPlies -> SetObject mkSearchDepth searchDepth | searchDepth < Input.SearchOptions.minimumSearchDepth = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.UI.SetObject.mkSearchDepth:\t" $ shows Input.SearchOptions.searchDepthTag " must be positive." | otherwise = SearchDepth searchDepth 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 @@ -33,14 +33,14 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.List import qualified Test.HUnit import Test.HUnit((~?), (~?=), (~:)) -- | Defines a concrete type for testing. -type Coordinates = Cartesian.Coordinates.Coordinates T.X T.Y +type Coordinates = Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test @@ -57,7 +57,7 @@ Property.FixedMembership.members :: [Coordinates] ) ~?= Cartesian.Coordinates.nSquares, "instance 'Data.Array.IArray.Ix Coordinates' is incompatible with instance 'Ord Coordinates'." ~: Data.Array.IArray.indices ( - Cartesian.Coordinates.listArrayByCoordinates [0 .. ] :: Cartesian.Coordinates.ArrayByCoordinates T.X T.Y Int + Cartesian.Coordinates.listArrayByCoordinates [0 .. ] :: Cartesian.Coordinates.ArrayByCoordinates Type.Length.X Type.Length.Y Int ) ~?= Property.FixedMembership.members ] diff --git a/src-test/BishBosh/Test/HUnit/Cartesian/Vector.hs b/src-test/BishBosh/Test/HUnit/Cartesian/Vector.hs --- a/src-test/BishBosh/Test/HUnit/Cartesian/Vector.hs +++ b/src-test/BishBosh/Test/HUnit/Cartesian/Vector.hs @@ -32,13 +32,13 @@ import Control.Arrow((&&&)) import qualified BishBosh.Cartesian.Vector as Cartesian.Vector import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Maybe import qualified Test.HUnit import Test.HUnit((~?)) -- | Sum the absolute value of /x/ & /y/ distances. -measureLength :: Cartesian.Vector.VectorInt -> T.Distance +measureLength :: Cartesian.Vector.VectorInt -> Type.Length.Distance measureLength = uncurry (+) . (abs . Cartesian.Vector.getXDistance &&& abs . Cartesian.Vector.getYDistance) -- | Check the sanity of the implementation, by validating a list of static test-cases. diff --git a/src-test/BishBosh/Test/HUnit/Component/CastlingMove.hs b/src-test/BishBosh/Test/HUnit/Component/CastlingMove.hs --- a/src-test/BishBosh/Test/HUnit/Component/CastlingMove.hs +++ b/src-test/BishBosh/Test/HUnit/Component/CastlingMove.hs @@ -34,13 +34,13 @@ import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Test.HUnit.Component.Move as Test.HUnit.Component.Move -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.List import qualified Test.HUnit import Test.HUnit((~?)) -- | Give the constant a concrete type. -kingsMoveLength :: T.X +kingsMoveLength :: Type.Length.X kingsMoveLength = Component.CastlingMove.kingsMoveLength -- | Check the sanity of the implementation, by validating a list of static test-cases. 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 @@ -35,12 +35,12 @@ import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Notation.Smith as Notation.Smith -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.HUnit import Test.HUnit((~?)) -- | Defines a concrete type for testing. -type Move = Component.Move.Move T.X T.Y +type Move = Component.Move.Move Type.Length.X Type.Length.Y -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test diff --git a/src-test/BishBosh/Test/HUnit/Component/Zobrist.hs b/src-test/BishBosh/Test/HUnit/Component/Zobrist.hs --- a/src-test/BishBosh/Test/HUnit/Component/Zobrist.hs +++ b/src-test/BishBosh/Test/HUnit/Component/Zobrist.hs @@ -31,14 +31,15 @@ ) where import qualified BishBosh.Component.Zobrist as Component.Zobrist -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Default import qualified Data.Foldable import qualified Test.HUnit import Test.HUnit((~:), (~?=)) -- | Defines a concrete type for testing. -type Zobrist = Component.Zobrist.Zobrist T.X T.Y T.PositionHash +type Zobrist = Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test diff --git a/src-test/BishBosh/Test/HUnit/ContextualNotation/PGN.hs b/src-test/BishBosh/Test/HUnit/ContextualNotation/PGN.hs --- a/src-test/BishBosh/Test/HUnit/ContextualNotation/PGN.hs +++ b/src-test/BishBosh/Test/HUnit/ContextualNotation/PGN.hs @@ -32,19 +32,21 @@ ) where import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.HUnit import Test.HUnit((~?)) #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 import qualified Data.Char import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# else /* Plain */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# endif #else /* Parsec */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec as Parsec #endif @@ -54,32 +56,30 @@ #endif -- | Test-subject. -type PGN = ContextualNotation.PGN.PGN T.X T.Y +type PGN = ContextualNotation.PGN.PGN Type.Length.X Type.Length.Y -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test $ map ( \(isStrictlySequential, validateMoves, s) -> #ifdef USE_POLYPARSE -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 ( \s' -> all Data.Char.isSpace s' ~? showString "Unparsed input: " (show s') ) . snd -#else /* Plain */ - either ( - Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.PGN.testCases:\tfailed: " . show - ) ( - const $ True ~? "" +# else /* Plain */ + ( + Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.PGN.testCases:\tfailed: " . show ||| const ( + True ~? "" + ) ) . fst -#endif +# endif $ Poly.runParser ( ContextualNotation.PGN.parser isStrictlySequential validateMoves [] :: Text.Poly.TextParser PGN ) #else /* Parsec */ - either ( - Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.PGN.testCases:\tfailed: " . show - ) ( - const $ True ~? "" + Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.PGN.testCases:\tfailed: " . show ||| const ( + True ~? "" ) $ Parsec.parse ( ContextualNotation.PGN.parser isStrictlySequential validateMoves [] :: Parsec.Parser PGN ) "PGN-parser" 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 @@ -43,7 +43,8 @@ import qualified BishBosh.Test.HUnit.Component.Move as Test.HUnit.Component.Move import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Default import qualified Test.HUnit @@ -92,7 +93,7 @@ ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches ( mkGame s ) . ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest False {-incrementalEvaluation-} ( - Data.Default.def :: Component.Zobrist.Zobrist T.X T.Y T.PositionHash + Data.Default.def :: Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash ) $ ContextualNotation.QualifiedMoveForest.fromPGNDatabase [ ContextualNotation.PGN.mkPGN' [] [ (ContextualNotation.PGN.dateTag, "2018.01.01") 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 @@ -47,12 +47,13 @@ #ifdef USE_POLYPARSE import Test.HUnit((~?=)) -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# else /* Plain */ import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# endif #else /* Parsec */ +import Control.Arrow((|||)) import Test.HUnit((~?=), (~?)) import qualified Text.ParserCombinators.Parsec #endif @@ -65,13 +66,13 @@ in #ifdef USE_POLYPARSE fst (Poly.runParser parser san) ~?= -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 standardAlgebraic -#else /* Plain */ +# else /* Plain */ Right standardAlgebraic -#endif +# endif #else /* Parsec */ - either (\parseError -> False ~? show parseError) (~?= standardAlgebraic) $ Text.ParserCombinators.Parsec.parse parser "SAN-parser" san + (\parseError -> False ~? show parseError) ||| (~?= standardAlgebraic) $ Text.ParserCombinators.Parsec.parse parser "SAN-parser" san #endif ) $ map ( \s -> let 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 @@ -23,15 +23,11 @@ -} module BishBosh.Test.HUnit.Evaluation.Fitness( --- * Types --- ** Type-synonyms --- CriterionValue, -- * Constants testCases ) where -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.CriterionValue as Attribute.CriterionValue +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 @@ -46,15 +42,11 @@ import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game import qualified BishBosh.Test.HUnit.State.Board as Test.HUnit.State.Board import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T import qualified Control.Exception import qualified Data.Default import qualified Test.HUnit import Test.HUnit((~:), (~?=)) --- | A suitable concrete type. -type CriterionValue = Attribute.CriterionValue.CriterionValue T.CriterionValue - -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ @@ -63,9 +55,7 @@ Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( Data.Default.def :: Test.HUnit.Model.Game.Game ) - ) ~?= ( - minBound :: CriterionValue - ) + ) ~?= negate 1 _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed to parse move.", "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving Rooks." ~: Evaluation.Fitness.measureValueOfCastlingPotential ( Model.Game.fromBoard . foldr ( @@ -77,16 +67,14 @@ ) ( Data.Default.def :: Test.HUnit.State.Board.Board ) $ Cartesian.Coordinates.rooksStartingCoordinates Attribute.LogicalColour.White - ) ~?= ( - maxBound :: CriterionValue - ), + ) ~?= 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 ( Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( Data.Default.def :: Test.HUnit.Model.Game.Game ) - ) ~?= ( - Attribute.CriterionValue.mkCriterionValue . negate $ recip 2 :: CriterionValue -- Moving Queen's Rook still permits castling on the King's side. + ) ~?= negate ( + fromRational $ recip 2 -- Moving Queen's Rook still permits castling on the King's side. ) _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed to parse move.", "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after taking Black Queen's Rook." ~: case Notation.MoveNotation.readsQualifiedMove Data.Default.def "a2a8" {-take Queen's Rook (illegally)-} of @@ -94,14 +82,14 @@ Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( Data.Default.def :: Test.HUnit.Model.Game.Game ) - ) ~?= ( - Attribute.CriterionValue.mkCriterionValue $ recip 2 :: CriterionValue -- Taking Queen's Rook still permits castling on the King's side. + ) ~?= fromRational ( + recip 2 -- Taking Queen's Rook still permits castling on the King's side. ) _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed to parse move.", - "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving one Rook from either side." ~: either ( + "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving one Rook from either side." ~: ( \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." - ) ( - \game -> Evaluation.Fitness.measureValueOfCastlingPotential game ~?= (Attribute.CriterionValue.zero :: CriterionValue) + ) ||| ( + \game -> Evaluation.Fitness.measureValueOfCastlingPotential game ~?= 0 ) $ Test.HUnit.Model.Game.applyMoves [ "a2a3", "g8f6", @@ -112,37 +100,27 @@ Model.Game.fromBoard ( read "4k3/p6p/8/3PP3/3PP3/3PP3/3PP3/4K3" :: Test.HUnit.State.Board.Board ) - ) ~?= ( - maxBound :: CriterionValue -- White is the next player, so Black is assumed to have just moved to an optimal position. - ), + ) ~?= 1, -- White is the next player, so Black is assumed to have just moved to an optimal position. "'BishBosh.Evaluation.Fitness.measureValueOfIsolatedPawns' failed for four columns of two rows of Pawns." ~: Evaluation.Fitness.measureValueOfIsolatedPawns ( Model.Game.fromBoard ( read "4k3/pppppppp/8/8/P1P1P1P1/8/P1P1P1P1/4K3" :: Test.HUnit.State.Board.Board ) - ) ~?= ( - maxBound :: CriterionValue -- White is the next player, so Black is assumed to have just moved to an optimal position. - ), + ) ~?= 1, -- White is the next player, so Black is assumed to have just moved to an optimal position. "'BishBosh.Evaluation.Fitness.measureValueOfIsolatedPawns' failed for two columns of two four of Pawns." ~: Evaluation.Fitness.measureValueOfIsolatedPawns ( Model.Game.fromBoard ( read "4k3/pppppppp/8/2P2P2/2P2P2/2P2P2/2P2P2/4K3" :: Test.HUnit.State.Board.Board ) - ) ~?= ( - maxBound :: CriterionValue -- White is the next player, so Black is assumed to have just moved to an optimal position. - ), + ) ~?= 1, -- White is the next player, so Black is assumed to have just moved to an optimal position. "'BishBosh.Evaluation.Fitness.measureValueOfPassedPawns' failed." ~: Evaluation.Fitness.measureValueOfPassedPawns ( Model.Game.fromBoard ( read "4k3/8/8/8/8/8/pppppppp/4K3" :: Test.HUnit.State.Board.Board ) - ) ~?= ( - maxBound :: CriterionValue -- White is the next player, so Black is assumed to have just moved to an optimal position. - ), + ) ~?= 1, -- White is the next player, so Black is assumed to have just moved to an optimal position. "'BishBosh.Evaluation.Fitness.measureValueOfPassedPawns' failed." ~: Evaluation.Fitness.measureValueOfPassedPawns ( Model.Game.fromBoard ( read "8/PPPPPPPP/8/8/8/8/8/k3K3" :: Test.HUnit.State.Board.Board ) - ) ~?= ( - minBound :: CriterionValue -- White is the next player, so Black is assumed to have just moved to the worst possible position. - ), + ) ~?= negate 1, -- White is the next player, so Black is assumed to have just moved to the worst possible position. "'BishBosh.Evaluation.Fitness.measureValueOfDefence' failed for default board." ~: Evaluation.Fitness.measureValueOfDefence ( Model.Game.fromBoard . uncurry ( foldr $ \(coordinates, _) -> StateProperty.Mutator.removePiece coordinates @@ -153,22 +131,32 @@ ) ( Data.Default.def :: Test.HUnit.State.Board.Board ) - ) ~?= Attribute.CriterionValue.mkCriterionValue ( - 19 / fromIntegral Evaluation.Fitness.maximumDefended :: T.CriterionValue + ) ~?= fromRational ( + 19 / fromIntegral {-NPieces-} Evaluation.Fitness.maximumDefended ), "'BishBosh.Evaluation.Fitness.measureValueOfDefence' failed after Pawn-advance." ~: case Notation.MoveNotation.readsQualifiedMove Data.Default.def "g2g3" {-advance King's Knight's Pawn-} of [(eitherQualifiedMove, "")] -> Evaluation.Fitness.measureValueOfDefence ( Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( Data.Default.def :: Test.HUnit.Model.Game.Game ) - ) ~?= Attribute.CriterionValue.mkCriterionValue (recip $ fromIntegral Evaluation.Fitness.maximumDefended :: T.CriterionValue) + ) ~?= fromRational ( + recip $ fromIntegral {-NPieces-} Evaluation.Fitness.maximumDefended + ) _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed to parse move.", - "'BishBosh.Evaluation.Fitness.measureValueOfDefence' failed after Pawn advance & Knight move." ~: either ( + "'BishBosh.Evaluation.Fitness.measureValueOfDefence' failed after Pawn advance & Knight move." ~: ( \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." - ) ( - \game -> Evaluation.Fitness.measureValueOfDefence game ~?= Attribute.CriterionValue.mkCriterionValue (3 / fromIntegral Evaluation.Fitness.maximumDefended :: T.CriterionValue) + ) ||| ( + \game -> Evaluation.Fitness.measureValueOfDefence game ~?= fromRational ( + 3 / fromIntegral {-NPieces-} Evaluation.Fitness.maximumDefended + ) ) $ Test.HUnit.Model.Game.applyMoves [ "g2g3", -- Advance King's Knight's Pawn. "b8c6" -- Advance Queen's Knight. - ] + ], + "'BishBosh.Evaluation.Fitness.measureValueOfDefence' failed." ~: Evaluation.Fitness.measureValueOfDefence ( + Model.Game.fromBoard ( + read "k7/8/2p5/8/4RQQB/4QQQN/4NQQK/4BQQR" :: Test.HUnit.State.Board.Board + ) + ) ~?= negate 1 -- White is the next player. ] + 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 @@ -27,11 +27,12 @@ testCases ) where -import BishBosh.Data.Float() -- HXT.XmlPickler. +--import BishBosh.Data.Ratio() -- Required if either Type.Mass.CriterionWeight or Type.Mass.CriterionValue is Rational. import Control.Category((>>>)) import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.Options as Input.Options -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.List import qualified Data.Maybe @@ -55,9 +56,6 @@ HXT.withValidate HXT.yes -- Validate against any DTD referenced from the XML-file. ] - maximumTraceLevel :: Int - maximumTraceLevel = 0 - fileName :: System.FilePath.FilePath fileName = "bishbosh_both" <.> "xml" in do @@ -79,12 +77,12 @@ Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Test.HUnit.Input.Options.testCases:\tfailed to locate " . shows fileName . showString " in " $ shows searchPath "." ) ( \path -> do - optionsList <- HXT.runX {-which returns a list-} $ HXT.setTraceLevel maximumTraceLevel >>> HXT.xunpickleDocument HXT.xpickle inputSysConfig path + optionsList <- HXT.runX {-which returns a list-} $ HXT.setTraceLevel 0 >>> HXT.xunpickleDocument HXT.xpickle inputSysConfig path (== Just (head optionsList)) ( (HXT.unpickleDoc HXT.xpickle . HXT.pickleDoc HXT.xpickle) =<< Data.Maybe.listToMaybe ( optionsList :: [ - Input.Options.Options T.Y {-column-} T.CriterionWeight T.PieceSquareValue T.RankValue T.X {-row-} T.X T.Y + Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y ] ) ) @? "Input.Options.pickler failed." 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 @@ -33,7 +33,7 @@ ) where import BishBosh.Model.Game((/~)) -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&), (***), (|||)) import Data.Map((!)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType @@ -43,14 +43,14 @@ import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Notation.Smith as Notation.Smith import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Default import qualified Data.Maybe @@ -58,7 +58,7 @@ import Test.HUnit((~?), (~:), (~?=)) -- | Defines a concrete type for testing. -type Game = Model.Game.Game T.X T.Y +type Game = Model.Game.Game Type.Length.X Type.Length.Y -- | Apply moves specified in Smith-notation, to the default opening board. applyMoves :: [String] -> Either (String, String) Game @@ -145,9 +145,9 @@ "e1g1c", "e1c1C" ] ~? "'BishBosh.Model.Game.rollback' failed to undo castling", - either ( + ( \(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." _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t /~ " $ Notation.MoveNotation.showsMoveSyntax Data.Default.def "" @@ -157,9 +157,9 @@ "a4a5", -- White: Queen's Rook's Pawn. "b7b5" -- Black: Queen's Knight's Pawn. ], - either ( + ( \(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." _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse move." @@ -170,13 +170,13 @@ "a5a4", -- Black: Queen's Rook's Pawn. "b2b4" -- White: Queen's Knight's Pawn. ], - Data.Maybe.maybe False Model.GameTerminationReason.isStaleMate ( + Data.Maybe.maybe False Rule.GameTerminationReason.isStaleMate ( Model.Game.getMaybeTerminationReason ( Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "rnbqk2r/pppppp2/8/8/8/7p/6np/6bK" :: Game ) ) ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Stale-mate\".", all ( - \s -> Data.Maybe.maybe False Model.GameTerminationReason.isDrawByInsufficientMaterial $ Model.Game.getMaybeTerminationReason ( + \s -> Data.Maybe.maybe False Rule.GameTerminationReason.isDrawByInsufficientMaterial $ Model.Game.getMaybeTerminationReason ( Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Game ) ) [ @@ -185,7 +185,7 @@ "8/8/2KB4/8/7k/2B5/5b2/8" ] ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Draw by Insufficient Material\".", all ( - \s -> Data.Maybe.maybe True (not . Model.GameTerminationReason.isDrawByInsufficientMaterial) $ Model.Game.getMaybeTerminationReason ( + \s -> Data.Maybe.maybe True (not . Rule.GameTerminationReason.isDrawByInsufficientMaterial) $ Model.Game.getMaybeTerminationReason ( Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Game ) ) [ @@ -210,7 +210,7 @@ either ( \(moveString, s) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t" . showString moveString . showString "; " $ showString s "." ) ( - Data.Maybe.maybe False Model.GameTerminationReason.isDraw . Model.Game.getMaybeTerminationReason + Data.Maybe.maybe False Rule.GameTerminationReason.isDraw . Model.Game.getMaybeTerminationReason ) ( applyMoves . concat . replicate 4 $ words "g1f3 g8f6 f3g1 f6g8" ) ~? "'BishBosh.Model.Game./~' failed to account for Draw by Five-fold Repetition.", 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 @@ -30,15 +30,15 @@ ) where import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Input.RankValues as Input.RankValues import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Default import qualified Data.Maybe import qualified Data.Tree @@ -51,18 +51,18 @@ let maxDepth = 4 in "'BishBosh.Model.GameTree.countGames' failed" ~: map Model.GameTree.countGames [0 .. maxDepth] ~?= take (succ maxDepth) [1, 20, 400, 8902, 197281, 4865609], -- - "'BishBosh.Model.GameTree.countMoves' failed" ~: map ( - \searchDepth -> Model.GameTree.countMoves searchDepth ~?= foldr ( + "'BishBosh.Model.GameTree.countPositions' failed" ~: map ( + \searchDepth -> fromIntegral (Model.GameTree.countPositions searchDepth) ~?= foldr ( (+) . Model.GameTree.countGames ) 0 [1 .. searchDepth] ) [1 .. 4], "'BishBosh.Model.GameTree.sortGameTree/MVVLVA' failed" ~: map ( - \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn T.X T.Y) + \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn Type.Length.X Type.Length.Y) ) ( 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"], "'BishBosh.Model.GameTree.sortGameTree/SEE' failed" ~: map ( - \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn T.X T.Y) + \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn Type.Length.X Type.Length.Y) ) ( 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"] @@ -76,9 +76,11 @@ sortAvailableMoves maybeSortAlgorithm = Data.Maybe.mapMaybe ( Model.Game.maybeLastTurn . Data.Tree.rootLabel ) . Data.Tree.subForest . Model.GameTree.deconstruct . Model.GameTree.sortGameTree maybeSortAlgorithm ( - `Attribute.RankValues.findRankValue` Attribute.RankValues.fromAssocs ( - zip Property.FixedMembership.members $ map (/ 10) [ - 1 :: T.RankValue, + `Input.RankValues.findRankValue` Input.RankValues.fromAssocs ( + zip Property.FixedMembership.members $ map ( + fromRational . (/ 10) -- Map into the closed unit-interval. + ) [ + 1, -- P 5, -- R 3, -- N 7 / 2, -- B diff --git a/src-test/BishBosh/Test/HUnit/Model/PositionHashTree.hs b/src-test/BishBosh/Test/HUnit/Model/PositionHashTree.hs --- a/src-test/BishBosh/Test/HUnit/Model/PositionHashTree.hs +++ b/src-test/BishBosh/Test/HUnit/Model/PositionHashTree.hs @@ -30,7 +30,7 @@ ) where import qualified BishBosh.Model.PositionHashTree as Model.PositionHashTree -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto import qualified Data.Default import qualified Test.HUnit import Test.HUnit((~:), (~?=)) @@ -41,6 +41,7 @@ let maxDepth = 4 in "'BishBosh.Model.PositionhashTree.countDistinctPositions' failed" ~: map ( - \i -> Model.PositionHashTree.countDistinctPositions i (Data.Default.def :: Model.PositionHashTree.PositionHashTree T.PositionHash) - ) [0 .. maxDepth] ~?= take (succ maxDepth) [1, 20, 400, 5362, 72078, 822518, 9417681, 96400068, 988187354, 9183421888, 85375278064, 726155461002] -- . CAVEAT: the point at which this test fails, depends on the square-root of the bits in 'T.PositionHash'. + \i -> Model.PositionHashTree.countDistinctPositions i (Data.Default.def :: Model.PositionHashTree.PositionHashTree Type.Crypto.PositionHash) + ) [0 .. maxDepth] ~?= take (succ maxDepth) [1, 20, 400, 5362, 72078, 822518, 9417681, 96400068, 988187354, 9183421888, 85375278064, 726155461002] -- . CAVEAT: the point at which this test fails, depends on the square-root of the bits in 'Crypto.PositionHash'. ] + 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 @@ -30,7 +30,6 @@ ) where import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm -import qualified BishBosh.Attribute.CriterionWeight as Attribute.CriterionWeight import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame @@ -42,7 +41,9 @@ import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Control.Monad.Reader import qualified Data.Default @@ -53,18 +54,12 @@ -- | Constant. evaluationOptions :: ( Fractional pieceSquareValue, - Fractional criterionWeight, - Fractional rankValue, Integral x, - Integral y, - Ord criterionWeight, - Ord rankValue, - Show criterionWeight, - Show rankValue - ) => Input.EvaluationOptions.EvaluationOptions criterionWeight pieceSquareValue rankValue x y + Integral y + ) => Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y evaluationOptions = Input.EvaluationOptions.mkEvaluationOptions Data.Default.def {-rankValues-} Data.Default.def { - Input.CriteriaWeights.getWeightOfMobility = Attribute.CriterionWeight.mkCriterionWeight $ 24 / 1000, - Input.CriteriaWeights.getWeightOfCastlingPotential = Attribute.CriterionWeight.mkCriterionWeight $ 5 / 1000 + Input.CriteriaWeights.getWeightOfMobility = 24 / 1000, + Input.CriteriaWeights.getWeightOfCastlingPotential = 5 / 1000 } False {-IncrementalEvaluation-} Nothing {-Maybe PieceSquareTable-} -- | Constant. @@ -83,8 +78,8 @@ 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 T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y - ) searchOptions Data.Default.def {-Zobrist-} Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean + evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y + ) searchOptions Data.Default.def {-Zobrist-} Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash ) ) searchOptions of quantifiedGame : _ -> Evaluation.QuantifiedGame.getLastTurn quantifiedGame @@ -124,3 +119,4 @@ (4, "r1bqk2r/pp2bppp/2p5/3pP3/P2Q1P2/2N1B3/1PP3PP/R4RK1 b kq -", "f7f6"), -- c8f5. (4, "r2qnrnk/p2b2b1/1p1p2pp/2pPpp2/1PP1P3/PRNBB3/3QNPPP/5RK1 w - -", "f2f4") -- e4f5p. ] + 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 @@ -47,7 +47,7 @@ import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Data.Array.IArray import qualified Data.Default @@ -59,7 +59,7 @@ import Test.HUnit((~:), (~?=), (~?)) -- | Defines a concrete type for testing. -type Board = State.Board.Board T.X T.Y +type Board = State.Board.Board Type.Length.X Type.Length.Y -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test diff --git a/src-test/BishBosh/Test/HUnit/Time/GameClock.hs b/src-test/BishBosh/Test/HUnit/Time/GameClock.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/HUnit/Time/GameClock.hs @@ -0,0 +1,83 @@ +{- + 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@] Static tests. +-} + +module BishBosh.Test.HUnit.Time.GameClock( +-- * Constants + testCases +) where + +import qualified BishBosh.Time.GameClock as Time.GameClock +import qualified BishBosh.Time.StopWatch as Time.StopWatch +import qualified BishBosh.Property.SelfValidating as Property.SelfValidating +import qualified BishBosh.Property.Switchable as Property.Switchable +import qualified Control.Concurrent +import qualified Data.Array.IArray +import qualified Data.Foldable +import qualified System.Random +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 $ map Test.HUnit.TestCase [ + do + stoppedGameClock <- Property.Switchable.switchOff =<< Property.Switchable.on + + Property.Switchable.isOff (stoppedGameClock :: Time.GameClock.GameClock) @? "Property.Switchable.switchOff failed.", + do + runningGameClock <- flick 2 + + Property.Switchable.isOn runningGameClock @? "Property.Switchable.Property.Switchable.flick (double) failed.", + do + runningGameClock <- flick 3 + + Property.Switchable.isOn runningGameClock @? "Property.Switchable.Property.Switchable.flick (triple) failed.", + do + runningGameClock <- flick 3 + + Property.SelfValidating.isValid runningGameClock @? "Property.Switchable.Property.SelfValidating.isValid failed.", + let + delayedFlick :: [Int] -> Time.GameClock.GameClock -> IO Time.GameClock.GameClock + delayedFlick (t : ts) gameClock = do + Control.Concurrent.threadDelay t + + Property.Switchable.toggle gameClock >>= delayedFlick ts + delayedFlick _ gameClock = return {-to IO-monad-} gameClock + in do + randomGenerator <- System.Random.getStdGen + runningWatch <- Property.Switchable.on + stoppedGameClock <- Property.Switchable.switchOff =<< delayedFlick (take 16 $ System.Random.randomRs (1, 100000 {-uS-}) randomGenerator) =<< Property.Switchable.on + stoppedWatch <- Property.Switchable.switchOff runningWatch + + let + relativeError :: Rational + relativeError = pred . (/ Time.StopWatch.getElapsedTime stoppedWatch) . Data.Foldable.sum . Data.Array.IArray.amap Time.StopWatch.getElapsedTime $ Time.GameClock.deconstruct stoppedGameClock + + abs relativeError < recip 50000 @? showString "Time.GameClock.GameClock:\trelative error between sum of game-clock times & stop-watch time = " ( + shows (realToFrac relativeError :: Double) "." + ) + ] where + flick :: Int -> IO Time.GameClock.GameClock + flick n = Property.Switchable.on >>= Property.Switchable.flick n + diff --git a/src-test/BishBosh/Test/HUnit/Time/StopWatch.hs b/src-test/BishBosh/Test/HUnit/Time/StopWatch.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/HUnit/Time/StopWatch.hs @@ -0,0 +1,63 @@ +{- + 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@] Static tests. +-} + +module BishBosh.Test.HUnit.Time.StopWatch( +-- * Constants + testCases +) where + +import Control.Arrow((&&&)) +import qualified BishBosh.Time.StopWatch as Time.StopWatch +import qualified BishBosh.Property.Switchable as Property.Switchable +import qualified Data.Default +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 $ map Test.HUnit.TestCase [ + do + stoppedWatch' <- Property.Switchable.switchOff =<< Property.Switchable.on + + Property.Switchable.isOff (stoppedWatch' :: Time.StopWatch.StopWatch) @? "Property.Switchable.switchOff failed.", + do + runningWatch <- Property.Switchable.flick 2 =<< Property.Switchable.on + + Property.Switchable.isOn (runningWatch :: Time.StopWatch.StopWatch) @? "Property.Switchable.Property.Switchable.flick (double) failed.", + do + runningWatch <- Property.Switchable.flick 3 stoppedWatch + + uncurry (/=) ( + ($ stoppedWatch) &&& ($ runningWatch) $ Property.Switchable.isOn + ) @? "Property.Switchable.Property.Switchable.flick (triple) failed.", + do + stoppedWatch' <- Property.Switchable.flick 2 stoppedWatch + + uncurry (==) ( + ($ stoppedWatch) &&& ($ stoppedWatch') $ Property.Switchable.isOn + ) @? "Property.Switchable.Property.Switchable.flick (double) failed." + ] where + stoppedWatch :: Time.StopWatch.StopWatch + stoppedWatch = Data.Default.def + diff --git a/src-test/BishBosh/Test/QuickCheck/Attribute/CriterionWeight.hs b/src-test/BishBosh/Test/QuickCheck/Attribute/CriterionWeight.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Attribute/CriterionWeight.hs +++ /dev/null @@ -1,37 +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'. --} - -module BishBosh.Test.QuickCheck.Attribute.CriterionWeight() where - -import qualified BishBosh.Attribute.CriterionWeight as Attribute.CriterionWeight -import qualified Test.QuickCheck - -instance ( - Fractional criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => Test.QuickCheck.Arbitrary (Attribute.CriterionWeight.CriterionWeight criterionWeight) where - arbitrary = (Attribute.CriterionWeight.mkCriterionWeight . (/ 10) . fromInteger) `fmap` Test.QuickCheck.elements [0 .. 9] - diff --git a/src-test/BishBosh/Test/QuickCheck/Attribute/MoveType.hs b/src-test/BishBosh/Test/QuickCheck/Attribute/MoveType.hs --- a/src-test/BishBosh/Test/QuickCheck/Attribute/MoveType.hs +++ b/src-test/BishBosh/Test/QuickCheck/Attribute/MoveType.hs @@ -63,3 +63,4 @@ ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64} f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Attribute/RankValues.hs b/src-test/BishBosh/Test/QuickCheck/Attribute/RankValues.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Attribute/RankValues.hs +++ /dev/null @@ -1,49 +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'. --} - -module BishBosh.Test.QuickCheck.Attribute.RankValues( --- * Types --- ** Type-synonyms - RankValues -) where - -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Types as T -import qualified Test.QuickCheck - -instance ( - Fractional rankValue, - Ord rankValue, - Show rankValue - ) => Test.QuickCheck.Arbitrary (Attribute.RankValues.RankValues rankValue) where - arbitrary = Attribute.RankValues.fromAssocs . zip Property.FixedMembership.members . map ( - recip . fromInteger . succ . (`mod` 100) -- Normalise to the half open unit-interval (0,1]. - ) <$> Test.QuickCheck.vector Attribute.Rank.nDistinctRanks - --- | Defines a concrete type for testing. -type RankValues = Attribute.RankValues.RankValues T.RankValue - 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 @@ -42,7 +42,7 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.List import qualified Data.List.Extra @@ -52,7 +52,7 @@ import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type Coordinates = Cartesian.Coordinates.Coordinates T.X T.Y +type Coordinates = Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y instance (Enum x, Enum y) => Test.QuickCheck.Arbitrary (Cartesian.Coordinates.Coordinates x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Coordinates #-} 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 @@ -36,11 +36,11 @@ import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Orientated as Property.Orientated import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import Test.QuickCheck((==>)) -instance Integral distance => Test.QuickCheck.Arbitrary (Cartesian.Vector.Vector distance) where +instance (Num distance, Ord distance) => Test.QuickCheck.Arbitrary (Cartesian.Vector.Vector distance) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Cartesian.Vector.VectorInt #-} arbitrary = do source <- Test.QuickCheck.arbitrary :: Test.QuickCheck.Gen Test.QuickCheck.Cartesian.Coordinates.Coordinates @@ -64,18 +64,18 @@ f vector = not (Property.Orientated.isStraight vector) ==> Test.QuickCheck.label "Vector.prop_straight" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) vector in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: (T.Distance, T.Distance) -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f :: (Type.Length.Distance, Type.Length.Distance) -> Test.QuickCheck.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 :: T.X -> T.X + deltaX :: Type.Length.X -> Type.Length.X deltaX = ( + fromIntegral ( (distanceX `mod` Cartesian.Abscissa.xLength) - (Cartesian.Abscissa.xLength `div` 2) ) ) - deltaY :: T.Y -> T.Y + deltaY :: Type.Length.Y -> Type.Length.Y deltaY = ( + fromIntegral ( (distanceY `mod` Cartesian.Ordinate.yLength) - (Cartesian.Ordinate.yLength `div` 2) @@ -95,3 +95,4 @@ ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } 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 @@ -38,19 +38,19 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type Move = Component.Move.Move T.X T.Y +type Move = Component.Move.Move Type.Length.X Type.Length.Y instance ( Enum x, Enum y, - Ord x, - Ord y + Eq x, + Eq y ) => Test.QuickCheck.Arbitrary (Component.Move.Move x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Move #-} arbitrary = fmap (uncurry Component.Move.mkMove) . Test.QuickCheck.suchThat Test.QuickCheck.arbitrary $ uncurry (/=) @@ -99,3 +99,4 @@ f = Test.QuickCheck.label "Move.prop_reflectOnY" . uncurry (==) . (id &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnY) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] + 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 @@ -36,18 +36,18 @@ import Control.Arrow((&&&)) import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type QualifiedMove = Component.QualifiedMove.QualifiedMove T.X T.Y +type QualifiedMove = Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y instance ( Enum x, Enum y, - Ord x, - Ord y + Eq x, + Eq y ) => Test.QuickCheck.Arbitrary (Component.QualifiedMove.QualifiedMove x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary QualifiedMove #-} arbitrary = uncurry Component.QualifiedMove.mkQualifiedMove `fmap` Test.QuickCheck.arbitrary -- CAVEAT: the move & moveType are unlikely to be compatible. @@ -74,3 +74,4 @@ f = Test.QuickCheck.label "QualifiedMove.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] + 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 @@ -36,18 +36,18 @@ import BishBosh.Test.QuickCheck.Attribute.MoveType() import BishBosh.Test.QuickCheck.Component.Move() import BishBosh.Test.QuickCheck.Component.Piece() +import BishBosh.Test.QuickCheck.Input.RankValues() import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.MoveType as Attribute.MoveType -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Attribute.RankValues as Attribute.RankValues -import qualified BishBosh.Component.CastlingMove as Component.CastlingMove -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.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.Test.QuickCheck.Attribute.RankValues as Test.QuickCheck.Attribute.RankValues -import qualified BishBosh.Types as T +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Component.CastlingMove as Component.CastlingMove +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.Input.RankValues as Input.RankValues +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Data.List import qualified Data.Maybe @@ -56,7 +56,7 @@ import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type Turn = Component.Turn.Turn T.X T.Y +type Turn = Component.Turn.Turn Type.Length.X Type.Length.Y instance ( Enum x, @@ -78,8 +78,8 @@ return {-to Gen-monad-} . Component.Turn.mkTurn (Component.QualifiedMove.mkQualifiedMove move moveType) $ Component.Piece.getRank piece -- | Distinct rank-values designed for a predictable sort-order. -rankValues :: Test.QuickCheck.Attribute.RankValues.RankValues -rankValues = Attribute.RankValues.fromAssocs . zip Property.FixedMembership.members $ map (/ 10) [1, 5, 3, 4, 9, 0] +rankValues :: Input.RankValues.RankValues +rankValues = Input.RankValues.fromAssocs . zip Property.FixedMembership.members $ map (fromRational . (/ 10)) [1, 5, 3, 4, 9, 0] -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] @@ -103,10 +103,10 @@ f = Test.QuickCheck.label "Turn.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Test.QuickCheck.Attribute.RankValues.RankValues -> [Turn] -> Test.QuickCheck.Property + f :: Input.RankValues.RankValues -> [Turn] -> Test.QuickCheck.Property f rankValues' = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/quiet" . uncurry (==) . ( dropWhile Component.Turn.isCapture . Data.List.sortBy ( - Component.Turn.compareByMVVLVA (`Attribute.RankValues.findRankValue` rankValues') + Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues') ) &&& filter ( not . Component.Turn.isCapture ) @@ -116,12 +116,12 @@ f :: [Turn] -> Test.QuickCheck.Property f = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/MVV" . ( \ranks -> Data.List.sortOn ( - negate . (`Attribute.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 (`Attribute.RankValues.findRankValue` rankValues) + Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues) ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let @@ -130,14 +130,14 @@ ( \ranks -> uncurry (++) ( Control.Arrow.first ( - Data.List.sortOn (`Attribute.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 (`Attribute.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/Component/Zobrist.hs b/src-test/BishBosh/Test/QuickCheck/Component/Zobrist.hs --- a/src-test/BishBosh/Test/QuickCheck/Component/Zobrist.hs +++ b/src-test/BishBosh/Test/QuickCheck/Component/Zobrist.hs @@ -35,7 +35,8 @@ import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.List @@ -43,22 +44,20 @@ import qualified Test.QuickCheck -- | Defines a concrete type for testing. -type Zobrist = Component.Zobrist.Zobrist T.X T.Y T.PositionHash +type Zobrist = Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash instance ( Data.Array.IArray.Ix x, Data.Bits.FiniteBits positionHash, Enum x, Enum y, - Num positionHash, Ord y, - Show positionHash, System.Random.Random positionHash ) => Test.QuickCheck.Arbitrary (Component.Zobrist.Zobrist x y positionHash) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Zobrist #-} arbitrary = Component.Zobrist.mkZobrist <$> fmap ( fmap ( - `mod` 3 -- CAVEAT: this value is limited by the width of 'T.PositionHash'. + `mod` 3 -- CAVEAT: this value is limited by the width of 'Crypto.PositionHash'. ) ) Test.QuickCheck.arbitrary <*> fmap System.Random.mkStdGen Test.QuickCheck.arbitrary diff --git a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGN.hs b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGN.hs --- a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGN.hs +++ b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGN.hs @@ -42,15 +42,17 @@ import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Word import qualified Test.QuickCheck #ifndef USE_POLYPARSE +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec #elif USE_POLYPARSE == 1 import qualified Text.ParserCombinators.Poly.Lazy as Poly #else /* Plain */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly #endif @@ -72,7 +74,7 @@ return {-to Gen-monad-} [c, i, j] -- | Defines a concrete type for testing. -type PGN = ContextualNotation.PGN.PGN T.X T.Y +type PGN = ContextualNotation.PGN.PGN Type.Length.X Type.Length.Y instance ( Enum x, @@ -125,14 +127,14 @@ f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property f isStrictlySequential validateMoves game = Test.QuickCheck.label "PGN.prop_moveTextParser" . #ifdef USE_POLYPARSE -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 (Model.Game.listTurns game ==) . Model.Game.listTurns -#else /* Plain */ - either (const False) ((Model.Game.listTurns game ==) . Model.Game.listTurns) -#endif +# else /* Plain */ + (const False ||| (Model.Game.listTurns game ==) . Model.Game.listTurns) +# endif . fst {-discard unparsed text-} . Poly.runParser moveTextParser #else /* Parsec */ - either (const False) ((Model.Game.listTurns game ==) . Model.Game.listTurns) . Text.ParserCombinators.Parsec.parse moveTextParser "Move-text parser" + (const False ||| (Model.Game.listTurns game ==) . Model.Game.listTurns) . Text.ParserCombinators.Parsec.parse moveTextParser "Move-text parser" #endif $ ContextualNotation.PGN.showsMoveText game "" where @@ -142,14 +144,14 @@ f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> PGN -> [ContextualNotation.PGNComment.PGNComment] -> Test.QuickCheck.Property f isStrictlySequential validateMoves pgn pgnComments = Test.QuickCheck.label "PGN.prop_pgnParser" . #ifdef USE_POLYPARSE -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 (== pgn) -#else /* Plain */ - either (const False) (== pgn) -#endif +# else /* Plain */ + (const False ||| (== pgn)) +# endif . fst {-discard unparsed text-} . Poly.runParser parser #else /* Parsec */ - either (const False) (== pgn) . Text.ParserCombinators.Parsec.parse parser "PGN parser" + (const False ||| (== pgn)) . Text.ParserCombinators.Parsec.parse parser "PGN parser" #endif . unlines . ( \l -> zipWith (++) l $ map (showChar '\t' . show) pgnComments ++ repeat "" {-pad comment-list with null lines-} @@ -158,3 +160,4 @@ parser = ContextualNotation.PGN.parser isStrictlySequential validateMoves [ficsGamesDBGameNoTag, ecoCodeTag] in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGNComment.hs b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGNComment.hs --- a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGNComment.hs +++ b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/PGNComment.hs @@ -33,10 +33,12 @@ import qualified Test.QuickCheck #ifndef USE_POLYPARSE +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec #elif USE_POLYPARSE == 1 import qualified Text.ParserCombinators.Poly.Lazy as Poly #else /* Plain */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly #endif @@ -54,17 +56,18 @@ f :: ContextualNotation.PGNComment.PGNComment -> Test.QuickCheck.Property f pgnComment = Test.QuickCheck.label "PGNComment.prop_io" . #ifdef USE_POLYPARSE -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 (== s) -#else /* Plain */ - either (const False) (== s) -#endif +# else /* Plain */ + (const False ||| (== s)) +# endif . fst {-discard unparsed text-} . Poly.runParser ContextualNotation.PGNComment.parser #else /* Parsec */ - either (const False) (== s) . Text.ParserCombinators.Parsec.parse ContextualNotation.PGNComment.parser "PGN parser" + (const False ||| (== s)) . Text.ParserCombinators.Parsec.parse ContextualNotation.PGNComment.parser "PGN parser" #endif $ show pgnComment where s = ContextualNotation.PGNComment.getString pgnComment in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } 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 @@ -42,7 +42,8 @@ import qualified BishBosh.Property.Null as Property.Null import qualified BishBosh.Test.QuickCheck.Component.Zobrist as Test.QuickCheck.Component.Zobrist import qualified BishBosh.Test.QuickCheck.ContextualNotation.QualifiedMoveForest as Test.QuickCheck.ContextualNotation.QualifiedMoveForest -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.List @@ -53,7 +54,7 @@ import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type PositionHashQualifiedMoveTree = ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree T.X T.Y T.PositionHash +type PositionHashQualifiedMoveTree = ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash instance ( Data.Array.IArray.Ix x, @@ -61,9 +62,7 @@ Enum x, Enum y, Num positionHash, - Ord x, Ord y, - Show positionHash, Show x, Show y, System.Random.Random positionHash @@ -87,3 +86,4 @@ ) . 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/ContextualNotation/QualifiedMoveForest.hs b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/QualifiedMoveForest.hs --- a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/QualifiedMoveForest.hs +++ b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/QualifiedMoveForest.hs @@ -38,7 +38,7 @@ import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Property.Null as Property.Null import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Foldable import qualified Data.Tree import qualified Test.QuickCheck @@ -56,7 +56,7 @@ arbitrary = fmap ContextualNotation.QualifiedMoveForest.fromPGNDatabase Test.QuickCheck.arbitrary -- | Defines a concrete type for testing. -type QualifiedMoveForest = ContextualNotation.QualifiedMoveForest.QualifiedMoveForest T.X T.Y +type QualifiedMoveForest = ContextualNotation.QualifiedMoveForest.QualifiedMoveForest Type.Length.X Type.Length.Y -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] @@ -72,7 +72,7 @@ let f :: QualifiedMoveForest -> Test.QuickCheck.Property f qualifiedMoveForest = not (Property.Null.isNull qualifiedMoveForest) ==> Test.QuickCheck.label "QualifiedMoveForest.prop_count" . uncurry (==) $ ( - snd {-nMoves-} . ContextualNotation.QualifiedMoveForest.count &&& length . tail {-remove the apex-} . Data.Tree.flatten . Model.GameTree.deconstruct . ContextualNotation.QualifiedMoveForest.toGameTree + snd {-nPositions-} . ContextualNotation.QualifiedMoveForest.count &&& fromIntegral . length . tail {-remove the apex-} . Data.Tree.flatten . Model.GameTree.deconstruct . ContextualNotation.QualifiedMoveForest.toGameTree ) qualifiedMoveForest in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/StandardAlgebraic.hs b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/StandardAlgebraic.hs --- a/src-test/BishBosh/Test/QuickCheck/ContextualNotation/StandardAlgebraic.hs +++ b/src-test/BishBosh/Test/QuickCheck/ContextualNotation/StandardAlgebraic.hs @@ -38,12 +38,14 @@ #ifdef USE_POLYPARSE import Control.Arrow((***)) -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# else /* Plain */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# endif #else /* Parsec */ +import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec #endif @@ -62,19 +64,19 @@ in #ifdef USE_POLYPARSE uncurry (&&) . ( -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 1 (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove *** null {-unparsed input-} -#else /* Plain */ - either (const False) ( - (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove +# else /* Plain */ + ( + const False ||| (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove ) *** null {-unparsed input-} -#endif +# endif ) . Poly.runParser ( ContextualNotation.StandardAlgebraic.parser explicitEnPassant validateMoves game' ) #else /* Parsec */ - either (const False) ( - (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove + ( + const False ||| (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove ) . Text.ParserCombinators.Parsec.parse ( ContextualNotation.StandardAlgebraic.parser explicitEnPassant validateMoves game' ) "SAN-parser" @@ -83,3 +85,4 @@ ) $ Model.Game.rollBack game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } 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 @@ -39,7 +39,9 @@ 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.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.List.Extra import qualified Data.Ord import qualified Data.Tree @@ -60,7 +62,7 @@ f evaluationOptions searchOptions zobrist game = Test.QuickCheck.label "PositionHashQuantifiedGameTree.prop_mkPositionHashQuantifiedGameTree" $ prune ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree evaluationOptions { Input.EvaluationOptions.getIncrementalEvaluation = False - } searchOptions zobrist Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean + } searchOptions zobrist Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash ) == prune ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree evaluationOptions { Input.EvaluationOptions.getIncrementalEvaluation = True -- CAVEAT: unrealistic given rounding-errors in incremental calculation of pieceSquareValue. @@ -78,7 +80,7 @@ -> Test.QuickCheck.Property f evaluationOptions searchOptions zobrist game = not (null matches) ==> Test.QuickCheck.label "PositionHashQuantifiedGameTree.prop_hashCollisions" $ all ( Data.List.Extra.allSame . map ( - Model.Game.mkPosition . Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean -> State.Position.Position T.X T.Y + Model.Game.mkPosition . Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> State.Position.Position Type.Length.X Type.Length.Y ) ) matches where matches = filter ( @@ -97,7 +99,8 @@ f evaluationOptions searchOptions zobrist = Test.QuickCheck.label "PositionHashQuantifiedGameTree.prop_fitness" . all ( (<= 1) . abs ) . take 10000 . map ( - Evaluation.QuantifiedGame.getFitness . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean -> T.WeightedMean + Evaluation.QuantifiedGame.getFitness . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> Type.Mass.WeightedMean ) . Data.Tree.flatten . Evaluation.PositionHashQuantifiedGameTree.deconstruct . Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree evaluationOptions searchOptions zobrist Property.Empty.empty {-MoveFrequency-} in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Input/CECPFeatures.hs b/src-test/BishBosh/Test/QuickCheck/Input/CECPFeatures.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/CECPFeatures.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/CECPFeatures.hs @@ -25,7 +25,7 @@ module BishBosh.Test.QuickCheck.Input.CECPFeatures() where -import Control.Arrow((***)) +import Control.Arrow((***), (+++)) import qualified BishBosh.Input.CECPFeatures as Input.CECPFeatures import qualified Data.Char import qualified Data.List @@ -40,10 +40,8 @@ ) . filter ( not . null . fst {-key-} ) . map ( - filter Data.Char.isAlpha *** either ( - Left . (`mod` 3) - ) ( - Right . filter Data.Char.isAlphaNum + filter Data.Char.isAlpha *** ( + (`mod` 3) +++ filter Data.Char.isAlphaNum ) ) <$> Test.QuickCheck.arbitrary ) <*> Test.QuickCheck.arbitrary {-done-} diff --git a/src-test/BishBosh/Test/QuickCheck/Input/CECPOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/CECPOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/CECPOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/CECPOptions.hs @@ -26,9 +26,10 @@ module BishBosh.Test.QuickCheck.Input.CECPOptions() where import BishBosh.Test.QuickCheck.Input.CECPFeatures() +import BishBosh.Test.QuickCheck.Time.StopWatch() import qualified BishBosh.Input.CECPOptions as Input.CECPOptions import qualified Test.QuickCheck instance Test.QuickCheck.Arbitrary Input.CECPOptions.CECPOptions where - arbitrary = Input.CECPOptions.mkCECPOptions <$> Test.QuickCheck.arbitrary {-analyseMode-} <*> Test.QuickCheck.arbitrary {-displaySAN-} <*> Test.QuickCheck.arbitrary {-editMode-} <*> Test.QuickCheck.arbitrary {-forceMode-} <*> fmap (fmap $ toEnum . abs) Test.QuickCheck.arbitrary {-Maybe pause-} <*> Test.QuickCheck.arbitrary {-ponderMode-} <*> Test.QuickCheck.arbitrary {-postMode-} <*> Test.QuickCheck.elements [1 .. 3] {-protocolVersion-} <*> Test.QuickCheck.arbitrary {-CECPFeatures-} + arbitrary = Input.CECPOptions.mkCECPOptions <$> Test.QuickCheck.arbitrary {-analyseMode-} <*> Test.QuickCheck.arbitrary {-displaySAN-} <*> Test.QuickCheck.arbitrary {-editMode-} <*> Test.QuickCheck.arbitrary {-forceMode-} <*> Test.QuickCheck.arbitrary {-Maybe pause-} <*> Test.QuickCheck.arbitrary {-ponderMode-} <*> Test.QuickCheck.arbitrary {-postMode-} <*> Test.QuickCheck.elements [1 .. 3] {-protocolVersion-} <*> Test.QuickCheck.arbitrary {-CECPFeatures-} diff --git a/src-test/BishBosh/Test/QuickCheck/Input/CriteriaWeights.hs b/src-test/BishBosh/Test/QuickCheck/Input/CriteriaWeights.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/CriteriaWeights.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/CriteriaWeights.hs @@ -25,33 +25,30 @@ -} module BishBosh.Test.QuickCheck.Input.CriteriaWeights( --- * Types --- ** Type-synonyms --- CriteriaWeights, -- * Constants results ) where -import BishBosh.Test.QuickCheck.Attribute.CriterionWeight() +import BishBosh.Test.QuickCheck.Metric.CriterionWeight() import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights -import qualified BishBosh.Types as T import qualified Test.QuickCheck -instance ( - Fractional criterionWeight, - Ord criterionWeight, - Show criterionWeight - ) => Test.QuickCheck.Arbitrary (Input.CriteriaWeights.CriteriaWeights criterionWeight) where - arbitrary = Input.CriteriaWeights.mkCriteriaWeights <$> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary - --- | Defines a concrete type for testing. -type CriteriaWeights = Input.CriteriaWeights.CriteriaWeights T.CriterionWeight +instance Test.QuickCheck.Arbitrary Input.CriteriaWeights.CriteriaWeights where + arbitrary = Input.CriteriaWeights.mkCriteriaWeights + <$> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary + <*> Test.QuickCheck.arbitrary -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: CriteriaWeights -> Test.QuickCheck.Property + f :: Input.CriteriaWeights.CriteriaWeights -> Test.QuickCheck.Property f criteriaWeights = Test.QuickCheck.label "CriteriaWeights.prop_normalise" . (== maxBound) . maximum $ map ($ criteriaWeights') [ Input.CriteriaWeights.getWeightOfMaterial, Input.CriteriaWeights.getWeightOfMobility, @@ -66,3 +63,4 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f ] + 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 @@ -33,9 +33,9 @@ import BishBosh.Data.Bool() import BishBosh.Test.QuickCheck.Attribute.Rank() -import BishBosh.Test.QuickCheck.Attribute.RankValues() import BishBosh.Test.QuickCheck.Input.CriteriaWeights() import BishBosh.Test.QuickCheck.Input.PieceSquareTable() +import BishBosh.Test.QuickCheck.Input.RankValues() import Control.Arrow((&&&)) import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights @@ -46,7 +46,8 @@ import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.Test.QuickCheck.State.Board as Test.QuickCheck.State.Board -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.Array.IArray import qualified Data.List import qualified Data.Map @@ -55,24 +56,17 @@ import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type EvaluationOptions = Input.EvaluationOptions.EvaluationOptions T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y +type EvaluationOptions = Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y instance ( - Enum x, - Enum y, - Fractional criterionWeight, - Fractional pieceSquareValue, - Fractional rankValue, - Ord pieceSquareValue, - Ord rankValue, - Ord x, - Ord y, - Real criterionWeight, - Show criterionWeight, - Show pieceSquareValue, - Show rankValue, - Test.QuickCheck.Arbitrary rankValue - ) => Test.QuickCheck.Arbitrary (Input.EvaluationOptions.EvaluationOptions criterionWeight pieceSquareValue rankValue x y) where + Enum x, + Enum y, + Fractional pieceSquareValue, + Ord pieceSquareValue, + Ord x, + Ord y, + Show pieceSquareValue + ) => Test.QuickCheck.Arbitrary (Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary EvaluationOptions #-} arbitrary = do criteriaWeights <- Test.QuickCheck.arbitrary @@ -101,7 +95,7 @@ sumPieceSquareValueByLogicalColour = State.Board.sumPieceSquareValueByLogicalColour $ Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Input.EvaluationOptions.EvaluationOptions T.CriterionWeight Rational {-precision is required-} T.RankValue T.X T.Y -> Test.QuickCheck.State.Board.Board -> Test.QuickCheck.Property + f :: Input.EvaluationOptions.EvaluationOptions Rational {-precision is required-} Type.Length.X Type.Length.Y -> Test.QuickCheck.State.Board.Board -> Test.QuickCheck.Property f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour" . uncurry (==) $ ( State.CoordinatesByRankByLogicalColour.sumPieceSquareValueByLogicalColour ( \logicalColour rank coordinatesList -> Component.PieceSquareByCoordinatesByRank.findPieceSquareValues nPieces logicalColour rank coordinatesList pieceSquareByCoordinatesByRank diff --git a/src-test/BishBosh/Test/QuickCheck/Input/IOOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/IOOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/IOOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/IOOptions.hs @@ -34,12 +34,7 @@ import qualified Test.QuickCheck import System.FilePath((), (<.>)) -instance ( - Integral column, - Integral row, - Show column, - Show row - ) => Test.QuickCheck.Arbitrary (Input.IOOptions.IOOptions row column) where +instance Test.QuickCheck.Arbitrary Input.IOOptions.IOOptions where arbitrary = do maybePGNOptions <- Test.QuickCheck.arbitrary diff --git a/src-test/BishBosh/Test/QuickCheck/Input/NativeUIOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/NativeUIOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/NativeUIOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/NativeUIOptions.hs @@ -30,13 +30,10 @@ import qualified Data.Default import qualified Test.QuickCheck -instance ( - Integral column, - Integral row, - Show column, - Show row - ) => Test.QuickCheck.Arbitrary (Input.NativeUIOptions.NativeUIOptions row column) where +instance Test.QuickCheck.Arbitrary Input.NativeUIOptions.NativeUIOptions where arbitrary = Input.NativeUIOptions.mkNativeUIOptions <$> fmap ( - fromInteger . succ . (* 2) . (`mod` 3) *** fromInteger . succ . (* 2) . (`mod` 3) - ) Test.QuickCheck.arbitrary {-BoardMagnification-} <*> return {-to Gen-monad-} Data.Default.def {-ColourScheme-} + mkOddNaturalNumber *** mkOddNaturalNumber + ) Test.QuickCheck.arbitrary {-BoardMagnification-} <*> return {-to Gen-monad-} Data.Default.def {-ColourScheme-} where + mkOddNaturalNumber :: Num n => Integer -> n + mkOddNaturalNumber = fromInteger . succ . (* 2) . (`mod` 3) 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 @@ -26,8 +26,6 @@ module BishBosh.Test.QuickCheck.Input.Options( -- * Types -- ** Type-synonyms --- Row, --- Column, Options, -- * Constants results @@ -37,46 +35,28 @@ import BishBosh.Test.QuickCheck.Input.IOOptions() import BishBosh.Test.QuickCheck.Input.SearchOptions() import qualified BishBosh.Input.Options as Input.Options -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Test.QuickCheck -- | Defines a concrete type for testing. -type Row = T.Y - --- | Defines a concrete type for testing. -type Column = T.X - --- | Defines a concrete type for testing. -type Options = Input.Options.Options Column T.CriterionWeight T.PieceSquareValue T.RankValue Row T.X T.Y +type Options = Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y instance ( - Enum pieceSquareValue, - Fractional criterionWeight, - Fractional pieceSquareValue, - Fractional rankValue, - Integral column, - Integral row, - Ord pieceSquareValue, - Ord rankValue, - Enum x, - Enum y, - Ord x, - Ord y, - Real criterionWeight, - Show column, - Show criterionWeight, - Show pieceSquareValue, - Show rankValue, - Show row, - Test.QuickCheck.Arbitrary pieceSquareValue, - Test.QuickCheck.Arbitrary rankValue - ) => Test.QuickCheck.Arbitrary (Input.Options.Options column criterionWeight pieceSquareValue rankValue row x y) where + Enum x, + Enum y, + Fractional pieceSquareValue, + Ord pieceSquareValue, + Ord x, + Ord y, + Show pieceSquareValue + ) => Test.QuickCheck.Arbitrary (Input.Options.Options pieceSquareValue x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Options #-} arbitrary = do (maybeMaximumPlies, maybeRandomSeed, evaluationOptions, searchOptions, ioOptions) <- Test.QuickCheck.arbitrary return {-to Gen-monad-} $ Input.Options.mkOptions ( - fmap (succ . abs) maybeMaximumPlies + fmap (fromInteger . succ . abs) maybeMaximumPlies ) maybeRandomSeed evaluationOptions searchOptions ioOptions -- | The constant test-results for this data-type. diff --git a/src-test/BishBosh/Test/QuickCheck/Input/PGNOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/PGNOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/PGNOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/PGNOptions.hs @@ -40,5 +40,5 @@ ["FICSGamesDBGameNo"], ["ECO"], ["FICSGamesDBGameNo", "ECO"] - ] <*> fmap (`mod` 128) Test.QuickCheck.arbitrary {-minimumPlies-} <*> Test.QuickCheck.elements (Nothing : map Just [1 .. 10]) {-maybeMaximumGames-} + ] <*> fmap (fromInteger . (`mod` 128)) Test.QuickCheck.arbitrary {-minimumPlies-} <*> Test.QuickCheck.elements (Nothing : map Just [1 .. 10]) {-maybeMaximumGames-} 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 @@ -37,13 +37,14 @@ 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.Types as T +import qualified BishBosh.Type.Length as Type.Length +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 T.X T.Y T.PieceSquareValue +type PieceSquareTable = Input.PieceSquareTable.PieceSquareTable Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue instance ( Enum x, @@ -76,7 +77,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Input.PieceSquareTable.Assocs Attribute.Rank.Rank T.PieceSquareValue -> Test.QuickCheck.Property + 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 diff --git a/src-test/BishBosh/Test/QuickCheck/Input/RankValues.hs b/src-test/BishBosh/Test/QuickCheck/Input/RankValues.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Input/RankValues.hs @@ -0,0 +1,37 @@ +{-# 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'. +-} + +module BishBosh.Test.QuickCheck.Input.RankValues() where + +import BishBosh.Test.QuickCheck.Metric.RankValue() +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Input.RankValues as Input.RankValues +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified Data.List +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Input.RankValues.RankValues where + arbitrary = Input.RankValues.fromAssocs . zip Property.FixedMembership.members . Data.List.sort {-ensures Q is most valuable (except K)-} <$> Test.QuickCheck.vector (fromIntegral Attribute.Rank.nDistinctRanks) + 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 @@ -37,24 +37,24 @@ instance Test.QuickCheck.Arbitrary Input.SearchOptions.SearchOptions where arbitrary = do searchDepthByLogicalColour <- Data.Map.map ( - (+ Input.SearchOptions.minimumSearchDepth) . (`mod` 4) + (+ Input.SearchOptions.minimumSearchDepth) . fromInteger . (`mod` 4) ) <$> Test.QuickCheck.arbitrary Input.SearchOptions.mkSearchOptions <$> Test.QuickCheck.arbitrary {-SortOnStandardOpeningMoveFrequency-} <*> Test.QuickCheck.arbitrary {-maybeCaptureMoveSortAlgorithm-} <*> ( fmap (succ . (`mod` 3)) <$> Test.QuickCheck.arbitrary -- maybeMinimumHammingDistance. ) <*> ( - fmap (`mod` 4) <$> Test.QuickCheck.arbitrary -- maybeRetireKillerMovesAfter. + fmap (fromInteger . (`mod` 4)) <$> Test.QuickCheck.arbitrary -- maybeRetireKillerMovesAfter. ) <*> Test.QuickCheck.arbitrary {-trapRepeatedPositions-} <*> ( if Data.Map.size searchDepthByLogicalColour == 1 then Test.QuickCheck.arbitrary else return {-to Gen-monad-} False -- UsePondering. ) <*> ( fmap ( - (`mod` 3) *** ( + fromInteger . (`mod` 3) *** ( if Data.Map.null searchDepthByLogicalColour then id else min $ Data.Foldable.maximum searchDepthByLogicalColour - ) . succ . (`mod` 3) + ) . fromInteger . succ . (`mod` 3) ) <$> Test.QuickCheck.arbitrary {-maybeUseTranspositions-} ) <*> Test.QuickCheck.arbitrary {-standardOpeningOptions-} <*> return {-to Gen-monad-} searchDepthByLogicalColour diff --git a/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs @@ -29,19 +29,15 @@ import BishBosh.Test.QuickCheck.Input.NativeUIOptions() import BishBosh.Test.QuickCheck.Input.Verbosity() import BishBosh.Test.QuickCheck.Notation.MoveNotation() +import Control.Arrow((|||)) import qualified BishBosh.Input.UIOptions as Input.UIOptions import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified Test.QuickCheck -instance ( - Integral column, - Integral row, - Show column, - Show row - ) => Test.QuickCheck.Arbitrary (Input.UIOptions.UIOptions row column) where +instance Test.QuickCheck.Arbitrary Input.UIOptions.UIOptions where arbitrary = do eitherNativeUIOrCECPOptions <- Test.QuickCheck.arbitrary - moveNotation <- const Test.QuickCheck.arbitrary `either` const (return {-to Gen-monad-} Notation.MoveNotation.pureCoordinate) $ eitherNativeUIOrCECPOptions + moveNotation <- const Test.QuickCheck.arbitrary ||| const (return {-to Gen-monad-} Notation.MoveNotation.pureCoordinate) $ eitherNativeUIOrCECPOptions Input.UIOptions.mkUIOptions moveNotation <$> fmap ( fmap $ succ . (`mod` 3) -- maybePrintMoveTree. diff --git a/src-test/BishBosh/Test/QuickCheck/Input/Verbosity.hs b/src-test/BishBosh/Test/QuickCheck/Input/Verbosity.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/Verbosity.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/Verbosity.hs @@ -31,3 +31,4 @@ instance Test.QuickCheck.Arbitrary Input.Verbosity.Verbosity where arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + diff --git a/src-test/BishBosh/Test/QuickCheck/Metric/CriterionWeight.hs b/src-test/BishBosh/Test/QuickCheck/Metric/CriterionWeight.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Metric/CriterionWeight.hs @@ -0,0 +1,33 @@ +{-# 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'. +-} + +module BishBosh.Test.QuickCheck.Metric.CriterionWeight() where + +import qualified BishBosh.Metric.CriterionWeight as Metric.CriterionWeight +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Metric.CriterionWeight.CriterionWeight where + arbitrary = Test.QuickCheck.elements $ map fromRational [0, recip 10 .. 1] + diff --git a/src-test/BishBosh/Test/QuickCheck/Metric/RankValue.hs b/src-test/BishBosh/Test/QuickCheck/Metric/RankValue.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Metric/RankValue.hs @@ -0,0 +1,56 @@ +{-# 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' & defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.Metric.RankValue( +-- * Constants + results +) where + +import qualified BishBosh.Metric.RankValue as Metric.RankValue +import qualified Test.QuickCheck +import qualified ToolShed.Test.ReversibleIO + +instance Test.QuickCheck.Arbitrary Metric.RankValue.RankValue where + arbitrary = Test.QuickCheck.elements $ map fromRational [0, recip 10 .. 1] + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Metric.RankValue.RankValue -> Test.QuickCheck.Property + f = Test.QuickCheck.label "RankValue.prop_readPrependedWhiteSpace" . ToolShed.Test.ReversibleIO.readPrependedWhiteSpace + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, + let + f :: String -> Test.QuickCheck.Property + f garbage = Test.QuickCheck.label "RankValue.prop_read" $ case (reads garbage :: [(Metric.RankValue.RankValue, 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 :: Metric.RankValue.RankValue -> String -> Test.QuickCheck.Property + f rankValue = Test.QuickCheck.label "RankValue.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` ".-+eEoOxX" ++ ['0' .. '9']) rankValue + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Model/DrawReason.hs b/src-test/BishBosh/Test/QuickCheck/Model/DrawReason.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Model/DrawReason.hs +++ /dev/null @@ -1,34 +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'. --} - -module BishBosh.Test.QuickCheck.Model.DrawReason() where - -import qualified BishBosh.Model.DrawReason as Model.DrawReason -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified Test.QuickCheck - -instance Test.QuickCheck.Arbitrary Model.DrawReason.DrawReason where - arbitrary = Test.QuickCheck.elements Property.FixedMembership.members - 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 @@ -41,20 +41,21 @@ 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.Model.DrawReason as Model.DrawReason 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.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.Default import qualified Data.Foldable @@ -70,7 +71,7 @@ import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type Game = Model.Game.Game T.X T.Y +type Game = Model.Game.Game Type.Length.X Type.Length.Y instance ( Enum x, @@ -118,16 +119,16 @@ let f :: Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen/Half move clock" $ uncurry (&&) . ( - (>= 0) &&& (<= Model.DrawReason.maximumConsecutiveRepeatablePlies) - ) . read . ( + (>= 0) &&& (<= Rule.DrawReason.maximumConsecutiveRepeatablePlies) + ) . fromInteger . read . ( !! 4 -- Half-move Clock. ) . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen/Full move counter" $ ( - > (0 :: Component.Move.NMoves) - ) . read . ( + > (0 :: Type.Count.NMoves) + ) . fromInteger . read . ( !! 5 -- Full Move Counter. ) . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, @@ -208,11 +209,11 @@ in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let f :: Game -> Test.QuickCheck.Property - f game = Test.QuickCheck.label "Game.prop_(findQualifiedMovesAvailableTo => countMovesAvailableTo)" $ all ( - \logicalColour -> Model.Game.countMovesAvailableTo logicalColour game == ( + f game = Test.QuickCheck.label "Game.prop_(findQualifiedMovesAvailableTo => countPliesAvailableTo)" $ all ( + \logicalColour -> Model.Game.countPliesAvailableTo logicalColour game == ( if Model.Game.isTerminated game then 0 - else length $ Model.Game.findQualifiedMovesAvailableTo logicalColour game + else fromIntegral . length $ Model.Game.findQualifiedMovesAvailableTo logicalColour game ) ) Property.FixedMembership.members in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, @@ -237,8 +238,8 @@ let f :: Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(getCoordinatesByRankByLogicalColour => getNPawnsByFileByLogicalColour)" . all ( - \(logicalColour, nPawnsByFile) -> Data.Foldable.sum nPawnsByFile == length ( - State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn $ State.Board.getCoordinatesByRankByLogicalColour board + \(logicalColour, nPawnsByFile) -> Data.Foldable.sum nPawnsByFile == fromIntegral ( + length . State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn $ State.Board.getCoordinatesByRankByLogicalColour board ) ) . Data.Array.IArray.assocs $ State.Board.getNPawnsByFileByLogicalColour board where board = Model.Game.getBoard game diff --git a/src-test/BishBosh/Test/QuickCheck/Model/GameTerminationReason.hs b/src-test/BishBosh/Test/QuickCheck/Model/GameTerminationReason.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Model/GameTerminationReason.hs +++ /dev/null @@ -1,48 +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.Model.GameTerminationReason( --- * Constants - results -) where - -import Control.Arrow((&&&)) -import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified Test.QuickCheck - -instance Test.QuickCheck.Arbitrary Model.GameTerminationReason.GameTerminationReason 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 :: Model.GameTerminationReason.GameTerminationReason -> Test.QuickCheck.Property - f = Test.QuickCheck.label "GameTerminationReason.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 8 } 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 @@ -35,7 +35,7 @@ import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Default import qualified Data.Maybe import qualified Test.QuickCheck @@ -47,7 +47,7 @@ fmap (Property.Arboreal.prune depth . Model.GameTree.fromGame) Test.QuickCheck.arbitrary -- | Define a concrete type for testing. -type GameTree = Model.GameTree.GameTree T.X T.Y +type GameTree = Model.GameTree.GameTree Type.Length.X Type.Length.Y -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] @@ -61,3 +61,4 @@ ) . Model.Game.listTurnsChronologically in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Model/MoveFrequency.hs b/src-test/BishBosh/Test/QuickCheck/Model/MoveFrequency.hs --- a/src-test/BishBosh/Test/QuickCheck/Model/MoveFrequency.hs +++ b/src-test/BishBosh/Test/QuickCheck/Model/MoveFrequency.hs @@ -27,13 +27,10 @@ results ) where -import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Model.MoveFrequency as Model.MoveFrequency -import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Test.QuickCheck.Model.GameTree as Test.QuickCheck.Model.GameTree import qualified Data.Foldable -import qualified Data.Tree import qualified Test.QuickCheck -- | The constant test-results for this data-type. @@ -43,10 +40,9 @@ f :: Test.QuickCheck.Model.GameTree.GameTree -> Test.QuickCheck.Property f gameTree = Test.QuickCheck.label "MoveFrequency.prop_countMoves" $ Model.MoveFrequency.countEntries ( Model.GameTree.toMoveFrequency gameTree - ) == State.TurnsByLogicalColour.getNPlies ( - Model.Game.getTurnsByLogicalColour . Data.Tree.rootLabel $ Model.GameTree.deconstruct gameTree - ) + pred {-the apex is counted in 'getNPlies'-} ( - Data.Foldable.length $ Model.GameTree.deconstruct gameTree + ) == pred {-the apex is counted in 'getNPlies'-} ( + fromIntegral . Data.Foldable.length $ Model.GameTree.deconstruct gameTree ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Model/Result.hs b/src-test/BishBosh/Test/QuickCheck/Model/Result.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Model/Result.hs +++ /dev/null @@ -1,63 +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.Model.Result( --- * Constants - results -) where - -import BishBosh.Test.QuickCheck.Attribute.LogicalColour() -import Control.Arrow((&&&)) -import qualified BishBosh.Model.Result as Model.Result -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified Test.QuickCheck -import qualified ToolShed.Test.ReversibleIO - -instance Test.QuickCheck.Arbitrary Model.Result.Result where - arbitrary = Model.Result.mkResult `fmap` 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] -results = sequence [ - let - f :: Model.Result.Result -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Result.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 "Result.prop_read" $ case (reads garbage :: [(Model.Result.Result, 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 :: Model.Result.Result -> String -> Test.QuickCheck.Property - f result = Test.QuickCheck.label "Result.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) result - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: Model.Result.Result -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Result.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 8 } f - ] - 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 @@ -39,12 +39,12 @@ import qualified BishBosh.Cartesian.Vector as Cartesian.Vector import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Notation.ICCFNumeric as Notation.ICCFNumeric -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type ICCFNumeric = Notation.ICCFNumeric.ICCFNumeric T.X T.Y +type ICCFNumeric = Notation.ICCFNumeric.ICCFNumeric Type.Length.X Type.Length.Y instance ( Enum x, @@ -92,3 +92,4 @@ ) coordinate in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f ] + 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 @@ -31,3 +31,4 @@ instance Test.QuickCheck.Arbitrary Notation.MoveNotation.MoveNotation where arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + 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 @@ -39,13 +39,13 @@ import qualified BishBosh.Cartesian.Vector as Cartesian.Vector import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.Char import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type PureCoordinate = Notation.PureCoordinate.PureCoordinate T.X T.Y +type PureCoordinate = Notation.PureCoordinate.PureCoordinate Type.Length.X Type.Length.Y instance ( Enum x, @@ -95,3 +95,4 @@ ) coordinate in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/Smith.hs b/src-test/BishBosh/Test/QuickCheck/Notation/Smith.hs --- a/src-test/BishBosh/Test/QuickCheck/Notation/Smith.hs +++ b/src-test/BishBosh/Test/QuickCheck/Notation/Smith.hs @@ -34,12 +34,12 @@ import BishBosh.Test.QuickCheck.Component.QualifiedMove() import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Notation.Smith as Notation.Smith -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type Smith = Notation.Smith.Smith T.X T.Y +type Smith = Notation.Smith.Smith Type.Length.X Type.Length.Y instance ( Enum x, @@ -70,3 +70,4 @@ f smith = Test.QuickCheck.label "Smith.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` ("cCE" ++ Component.Piece.showPieces)) smith in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Rule/DrawReason.hs b/src-test/BishBosh/Test/QuickCheck/Rule/DrawReason.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Rule/DrawReason.hs @@ -0,0 +1,34 @@ +{-# 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'. +-} + +module BishBosh.Test.QuickCheck.Rule.DrawReason() where + +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Rule.DrawReason as Rule.DrawReason +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Rule.DrawReason.DrawReason where + arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + diff --git a/src-test/BishBosh/Test/QuickCheck/Rule/GameTerminationReason.hs b/src-test/BishBosh/Test/QuickCheck/Rule/GameTerminationReason.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Rule/GameTerminationReason.hs @@ -0,0 +1,48 @@ +{-# 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.Rule.GameTerminationReason( +-- * Constants + results +) where + +import Control.Arrow((&&&)) +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Rule.GameTerminationReason.GameTerminationReason 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 :: Rule.GameTerminationReason.GameTerminationReason -> Test.QuickCheck.Property + f = Test.QuickCheck.label "GameTerminationReason.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 8 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs b/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Rule/Result.hs @@ -0,0 +1,63 @@ +{-# 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.Rule.Result( +-- * Constants + results +) where + +import BishBosh.Test.QuickCheck.Attribute.LogicalColour() +import Control.Arrow((&&&)) +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Rule.Result as Rule.Result +import qualified Test.QuickCheck +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] + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Rule.Result.Result -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Result.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 "Result.prop_read" $ case (reads garbage :: [(Rule.Result.Result, 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 :: Rule.Result.Result -> String -> Test.QuickCheck.Property + f result = Test.QuickCheck.label "Result.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) result + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Rule.Result.Result -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Result.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 8 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Search/KillerMoves.hs b/src-test/BishBosh/Test/QuickCheck/Search/KillerMoves.hs --- a/src-test/BishBosh/Test/QuickCheck/Search/KillerMoves.hs +++ b/src-test/BishBosh/Test/QuickCheck/Search/KillerMoves.hs @@ -37,41 +37,38 @@ import BishBosh.Test.QuickCheck.Component.Turn() import Control.Arrow((&&&)) -import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Search.DynamicMoveData as Search.DynamicMoveData import qualified BishBosh.Search.EphemeralData as Search.EphemeralData import qualified BishBosh.Search.KillerMoves as Search.KillerMoves -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck -- | Defines a concrete type for testing. -type KillerMoveKey = Search.DynamicMoveData.KillerMoveKey T.X T.Y +type KillerMoveKey = Search.DynamicMoveData.KillerMoveKey Type.Length.X Type.Length.Y instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Test.QuickCheck.Arbitrary x, - Test.QuickCheck.Arbitrary y + Enum x, + Enum y, + Ord x, + Ord y ) => Test.QuickCheck.Arbitrary (Search.DynamicMoveData.KillerMoveKey x y) where -- {-# SPECIALISE instance Test.QuickCheck.Arbitrary KillerMoveKey #-} arbitrary = fmap Search.DynamicMoveData.mkKillerMoveKeyFromTurn Test.QuickCheck.arbitrary --- | -normalise :: Int -> Component.Move.NPlies -normalise = succ . (`mod` 4) +-- | Map the integer-domain into a smaller non-negative number of plies. +normalise :: Integral i => i -> Type.Count.NPlies +normalise = fromIntegral . succ . (`mod` 4) -- | -populate :: Ord key => [(Component.Move.NPlies, key)] -> Search.KillerMoves.KillerMoves key +populate :: Ord key => [(Int, key)] -> Search.KillerMoves.KillerMoves key populate = foldr (\(nPlies, killerMoveKey) -> Search.KillerMoves.insert (normalise nPlies) killerMoveKey) Property.Empty.empty {-KillerMoves-} -- | Defines a concrete type for testing. type KillerMoves = Search.KillerMoves.KillerMoves KillerMoveKey instance ( - Enum key, Ord key, Test.QuickCheck.Arbitrary key ) => Test.QuickCheck.Arbitrary (Search.KillerMoves.KillerMoves key) where @@ -81,7 +78,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: [(Component.Move.NPlies, KillerMoveKey)] -> Test.QuickCheck.Property + f :: [(Int, KillerMoveKey)] -> Test.QuickCheck.Property f = Test.QuickCheck.label "KillerMoves.prop_insert/getNMoves" . uncurry (==) . (Search.EphemeralData.getSize . populate &&& length) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f ] 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 @@ -50,7 +50,7 @@ let f :: Input.SearchOptions.SearchOptions - -> Input.SearchOptions.SearchDepth + -> Int -- ^ Search-depth. -> Test.QuickCheck.Search.SearchState.SearchState -> Test.QuickCheck.Property f searchOptions searchDepth searchState = searchOptions /= Data.Default.def && not ( @@ -65,7 +65,7 @@ } - getQuantifiedGames = Search.Search.getQuantifiedGames . Control.Monad.Reader.runReader (Search.Search.search (Input.SearchOptions.minimumSearchDepth + mod searchDepth 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,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -38,48 +38,37 @@ 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.Types as T +import qualified BishBosh.Type.Crypto as Type.Crypto +import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.Array.IArray import qualified Data.Bits import qualified System.Random import qualified Test.QuickCheck -#ifdef USE_PARALLEL -import qualified Control.DeepSeq -#endif - -- | A suitable concrete type for testing. -type SearchState = Search.SearchState.SearchState T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean +type SearchState = Search.SearchState.SearchState Type.Length.X Type.Length.Y Type.Crypto.PositionHash -instance forall x y positionHash criterionValue weightedMean. ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData criterionValue, -#endif +instance forall x y positionHash. ( Data.Array.IArray.Ix x, Data.Bits.FiniteBits positionHash, - Fractional criterionValue, - Fractional weightedMean, Integral x, Integral y, Num positionHash, - Real criterionValue, - Real weightedMean, Show positionHash, Show x, Show y, System.Random.Random positionHash, - Test.QuickCheck.Arbitrary criterionValue, - Test.QuickCheck.Arbitrary weightedMean, Test.QuickCheck.Arbitrary x, Test.QuickCheck.Arbitrary y - ) => Test.QuickCheck.Arbitrary (Search.SearchState.SearchState x y positionHash criterionValue weightedMean) where + ) => Test.QuickCheck.Arbitrary (Search.SearchState.SearchState x y positionHash) where {-# SPECIALISE instance Test.QuickCheck.Arbitrary SearchState #-} arbitrary = do evaluationOptions <- Test.QuickCheck.arbitrary Search.SearchState.initialise <$> ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree ( - evaluationOptions :: Input.EvaluationOptions.EvaluationOptions T.CriterionWeight T.PieceSquareValue T.RankValue x y + evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue x y ) <$> 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 @@ -52,7 +52,7 @@ import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Monad import qualified Data.Foldable import qualified Data.List @@ -64,7 +64,7 @@ import qualified ToolShed.Test.ReversibleIO -- | Defines a concrete type for testing. -type Board = State.Board.Board T.X T.Y +type Board = State.Board.Board Type.Length.X Type.Length.Y instance ( Enum x, @@ -196,7 +196,7 @@ uncurry (==) . ( Data.Foldable.sum . ( State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour ! - ) &&& length . ( + ) &&& fromIntegral . length . ( \logicalColour -> State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour ) ) 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 @@ -41,7 +41,7 @@ import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Data.List import qualified Data.List.Extra import qualified Test.QuickCheck @@ -62,7 +62,7 @@ ] -- List-comprehension. -- | Defines a concrete type for testing. -type CastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour T.X +type CastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour Type.Length.X -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] diff --git a/src-test/BishBosh/Test/QuickCheck/State/InstancesByPosition.hs b/src-test/BishBosh/Test/QuickCheck/State/InstancesByPosition.hs --- a/src-test/BishBosh/Test/QuickCheck/State/InstancesByPosition.hs +++ b/src-test/BishBosh/Test/QuickCheck/State/InstancesByPosition.hs @@ -40,7 +40,7 @@ f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "InstancesByPosition.prop_countPositionRepetitions" . uncurry (==) . ( State.InstancesByPosition.countPositionRepetitions &&& uncurry (-) . ( - succ . State.InstancesByPosition.countConsecutiveRepeatablePlies &&& State.InstancesByPosition.getNDistinctPositions + succ . fromIntegral . State.InstancesByPosition.countConsecutiveRepeatablePlies &&& State.InstancesByPosition.getNDistinctPositions ) ) . Model.Game.getInstancesByPosition in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, diff --git a/src-test/BishBosh/Test/QuickCheck/State/TurnsByLogicalColour.hs b/src-test/BishBosh/Test/QuickCheck/State/TurnsByLogicalColour.hs --- a/src-test/BishBosh/Test/QuickCheck/State/TurnsByLogicalColour.hs +++ b/src-test/BishBosh/Test/QuickCheck/State/TurnsByLogicalColour.hs @@ -39,12 +39,12 @@ import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -- | Define a concrete type for testing. -type TurnsByLogicalColour = State.TurnsByLogicalColour.TurnsByLogicalColour (Component.Turn.Turn T.X T.Y) +type TurnsByLogicalColour = State.TurnsByLogicalColour.TurnsByLogicalColour (Component.Turn.Turn Type.Length.X Type.Length.Y) instance ( Show a, diff --git a/src-test/BishBosh/Test/QuickCheck/Time/StopWatch.hs b/src-test/BishBosh/Test/QuickCheck/Time/StopWatch.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Time/StopWatch.hs @@ -0,0 +1,33 @@ +{-# 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.Time.StopWatch() where + +import qualified BishBosh.Time.StopWatch as Time.StopWatch +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Time.StopWatch.StopWatch where + arbitrary = Time.StopWatch.mkStoppedWatch . toEnum <$> Test.QuickCheck.arbitrary + 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 @@ -33,12 +33,12 @@ import BishBosh.Test.QuickCheck.UI.PrintObject() import BishBosh.Test.QuickCheck.UI.SetObject() -import qualified BishBosh.Types as T +import qualified BishBosh.Type.Length as Type.Length import qualified BishBosh.UI.Command as UI.Command import qualified Test.QuickCheck -- | Define a concrete type for testing. -type Command = UI.Command.Command T.X T.Y +type Command = UI.Command.Command Type.Length.X Type.Length.Y instance Test.QuickCheck.Arbitrary (UI.Command.Command x y) where arbitrary = Test.QuickCheck.oneof [ diff --git a/src-test/BishBosh/Test/QuickCheck/UI/PrintObject.hs b/src-test/BishBosh/Test/QuickCheck/UI/PrintObject.hs --- a/src-test/BishBosh/Test/QuickCheck/UI/PrintObject.hs +++ b/src-test/BishBosh/Test/QuickCheck/UI/PrintObject.hs @@ -58,3 +58,4 @@ ) printObject in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/UI/ReportObject.hs b/src-test/BishBosh/Test/QuickCheck/UI/ReportObject.hs --- a/src-test/BishBosh/Test/QuickCheck/UI/ReportObject.hs +++ b/src-test/BishBosh/Test/QuickCheck/UI/ReportObject.hs @@ -58,3 +58,4 @@ ) reportObject in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f ] + diff --git a/src-test/BishBosh/Test/QuickCheck/UI/SetObject.hs b/src-test/BishBosh/Test/QuickCheck/UI/SetObject.hs --- a/src-test/BishBosh/Test/QuickCheck/UI/SetObject.hs +++ b/src-test/BishBosh/Test/QuickCheck/UI/SetObject.hs @@ -34,7 +34,7 @@ import qualified ToolShed.Test.ReversibleIO instance Test.QuickCheck.Arbitrary UI.SetObject.SetObject where - arbitrary = fmap (UI.SetObject.SearchDepth . (+ Input.SearchOptions.minimumSearchDepth) . (`mod` 4)) Test.QuickCheck.arbitrary + arbitrary = fmap (UI.SetObject.mkSearchDepth . (+ Input.SearchOptions.minimumSearchDepth) . fromInteger . (`mod` 4)) Test.QuickCheck.arbitrary -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] diff --git a/src-test/HUnit.hs b/src-test/HUnit.hs --- a/src-test/HUnit.hs +++ b/src-test/HUnit.hs @@ -44,6 +44,8 @@ import qualified BishBosh.Test.HUnit.Model.PositionHashTree as Test.HUnit.Model.PositionHashTree import qualified BishBosh.Test.HUnit.State.Board as Test.HUnit.State.Board import qualified BishBosh.Test.HUnit.Text.AutoComplete as Test.HUnit.Text.AutoComplete +import qualified BishBosh.Test.HUnit.Time.GameClock as Test.HUnit.Time.GameClock +import qualified BishBosh.Test.HUnit.Time.StopWatch as Test.HUnit.Time.StopWatch import qualified Test.HUnit #ifdef USE_SEARCH @@ -63,6 +65,8 @@ Test.HUnit.Component.Move.testCases, Test.HUnit.Component.CastlingMove.testCases, Test.HUnit.Component.Zobrist.testCases, + Test.HUnit.Time.StopWatch.testCases, + Test.HUnit.Time.GameClock.testCases, Test.HUnit.State.Board.testCases, Test.HUnit.Model.Game.testCases, Test.HUnit.Model.GameTree.testCases, diff --git a/src-test/QuickCheck.hs b/src-test/QuickCheck.hs --- a/src-test/QuickCheck.hs +++ b/src-test/QuickCheck.hs @@ -47,14 +47,15 @@ import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions import qualified BishBosh.Test.QuickCheck.Input.Options as Test.QuickCheck.Input.Options import qualified BishBosh.Test.QuickCheck.Input.PieceSquareTable as Test.QuickCheck.Input.PieceSquareTable +import qualified BishBosh.Test.QuickCheck.Metric.RankValue as Test.QuickCheck.Metric.RankValue import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Test.QuickCheck.Model.GameTerminationReason as Test.QuickCheck.Model.GameTerminationReason import qualified BishBosh.Test.QuickCheck.Model.GameTree as Test.QuickCheck.Model.GameTree import qualified BishBosh.Test.QuickCheck.Model.MoveFrequency as Test.QuickCheck.Model.MoveFrequency -import qualified BishBosh.Test.QuickCheck.Model.Result as Test.QuickCheck.Model.Result import qualified BishBosh.Test.QuickCheck.Notation.ICCFNumeric as Test.QuickCheck.Notation.ICCFNumeric import qualified BishBosh.Test.QuickCheck.Notation.PureCoordinate as Test.QuickCheck.Notation.PureCoordinate import qualified BishBosh.Test.QuickCheck.Notation.Smith as Test.QuickCheck.Notation.Smith +import qualified BishBosh.Test.QuickCheck.Rule.GameTerminationReason as Test.QuickCheck.Rule.GameTerminationReason +import qualified BishBosh.Test.QuickCheck.Rule.Result as Test.QuickCheck.Rule.Result import qualified BishBosh.Test.QuickCheck.Search.KillerMoves as Test.QuickCheck.Search.KillerMoves -- import qualified BishBosh.Test.QuickCheck.Search.Search as Test.QuickCheck.Search.Search import qualified BishBosh.Test.QuickCheck.State.Board as Test.QuickCheck.State.Board @@ -83,7 +84,6 @@ Test.QuickCheck.Attribute.Direction.results, Test.QuickCheck.Attribute.Rank.results, Test.QuickCheck.Attribute.MoveType.results, - Test.QuickCheck.Input.CriteriaWeights.results, Test.QuickCheck.Input.EvaluationOptions.results, Test.QuickCheck.Input.Options.results, Test.QuickCheck.Input.PieceSquareTable.results, @@ -93,11 +93,11 @@ Test.QuickCheck.Component.Move.results, Test.QuickCheck.Component.QualifiedMove.results, Test.QuickCheck.Component.Turn.results, + Test.QuickCheck.Rule.GameTerminationReason.results, + Test.QuickCheck.Rule.Result.results, Test.QuickCheck.Notation.ICCFNumeric.results, Test.QuickCheck.Notation.PureCoordinate.results, Test.QuickCheck.Notation.Smith.results, - Test.QuickCheck.Model.GameTerminationReason.results, - Test.QuickCheck.Model.Result.results, Test.QuickCheck.State.CastleableRooksByLogicalColour.results, Test.QuickCheck.State.Position.results, Test.QuickCheck.State.InstancesByPosition.results, @@ -113,6 +113,8 @@ Test.QuickCheck.ContextualNotation.PGNComment.results, Test.QuickCheck.ContextualNotation.PGN.results, Test.QuickCheck.ContextualNotation.QualifiedMoveForest.results, + Test.QuickCheck.Input.CriteriaWeights.results, + Test.QuickCheck.Metric.RankValue.results, Test.QuickCheck.Evaluation.PositionHashQuantifiedGameTree.results, Test.QuickCheck.Search.KillerMoves.results, Test.QuickCheck.UI.PrintObject.results,