diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -2,8 +2,9 @@ [![Build Status](https://travis-ci.com/functionalley/BishBosh.svg?branch=master)](https://travis-ci.com/functionalley/BishBosh) [![Hackage](https://img.shields.io/hackage/v/bishbosh.svg)](https://hackage.haskell.org/package/bishbosh) +[![GitHub top language](https://img.shields.io/github/languages/top/functionalley/BishBosh?color=yellow)](https://github.com/functionalley/BishBosh) +[![GitHub code size in bytes](https://img.shields.io/github/languages/code-size/functionalley/BishBosh?color=violet)](https://github.com/functionalley/BishBosh) [![License: GPL v3](https://img.shields.io/badge/License-GPL%20v3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0) -[![Haskell](https://b.repl.ca/v1/language-haskell-yellow.png)](https://haskell.org) This is "**BishBosh**", a chess-game which can be rendered in a terminal (emulator) using raw ASCII, or used as an engine by [xboard](https://www.gnu.org/software/xboard/). diff --git a/bishbosh.cabal b/bishbosh.cabal --- a/bishbosh.cabal +++ b/bishbosh.cabal @@ -16,7 +16,7 @@ -- along with BishBosh. If not, see . Name: bishbosh -Version: 0.1.1.0 +Version: 0.1.2.0 Copyright: (C) 2018 Dr. Alistair Ward License: GPL-3.0-or-later License-file: LICENSE @@ -24,9 +24,9 @@ Stability: stable Synopsis: Plays chess. Build-type: Simple -Description: A chess-game which can be rendered in a terminal (emulator) in raw ASCII, or used as an engine by xboard. +Description: A chess-game which can be rendered in a terminal (emulator) in raw ASCII, or used as an engine by @xboard@. Category: Game -Tested-with: GHC == 8.0, GHC == 8.4, GHC == 8.8, GHC == 8.10 +Tested-with: GHC == 8.0, GHC == 8.2, GHC == 8.4, GHC == 8.6, GHC == 8.8, GHC == 8.10 Homepage: https://functionalley.com/BishBosh/bishbosh.html Maintainer: mailto:bishbosh@functionalley.com Bug-reports: mailto:bishbosh@functionalley.com @@ -64,14 +64,6 @@ Default: False -- Automatically disabled when the required package isn't available. --- To access Parsec's more precise error-messages, manually disable using one of: --- runhaskell Setup configure -f -polyparse --verbose; --- stack build --flag 'bishbosh:-polyparse' --cabal-verbose; -flag polyparse - Description: Link with package "polyparse" when available, rather than "parsec". - Default: True - --- Automatically disabled when the required package isn't available. -- To force validation of the XML-configuration against the packaged DTD, manually disable using one of: -- runhaskell Setup configure -f -hxtrelaxng --verbose; -- stack build --flag 'bishbosh:-hxtrelaxng' --cabal-verbose; @@ -80,6 +72,7 @@ Default: True -- Whether to use narrower numerical types than machine-defaults. CAVEAT: this option increases both the space allocated & the execution-time. +-- CAVEAT: incompatble with the flag 'precision'. flag narrownumbers Description: Use narrow numerical types. Manual: True @@ -91,6 +84,20 @@ Manual: True Default: False +-- Automatically disabled when the required package isn't available. +-- To access Parsec's more precise error-messages, manually disable using one of: +-- runhaskell Setup configure -f -polyparse --verbose; +-- stack build --flag 'bishbosh:-polyparse' --cabal-verbose; +flag polyparse + Description: Link with package "polyparse" when available, rather than "parsec". + Default: True + +-- Whether to use precise (rational) types rather than floating-point. CAVEAT: incompatible with 'narrownumbers'. +flag precision + Description: Use precise numerical types. CAVEAT: this is incompatible with either 'unboxedarrays' or 'narrownumbers'. + 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. @@ -98,6 +105,7 @@ Default: True -- Whether to use unboxed arrays where possible. +-- CAVEAT: incompatble with the flag 'precision'. flag unboxedarrays Description: Use unboxed arrays. Manual: True @@ -109,12 +117,60 @@ Description: Link with package "unix" when available. Default: True -Library +common commonStanza Default-language: Haskell2010 - GHC-options: -O2 -Wall -fno-warn-tabs -fno-warn-unused-top-binds -Wno-all-missed-specialisations + + Build-depends: + base == 4.*, + containers ^>= 0.6.2, + data-default ^>= 0.7.1, + filepath + + GHC-options: -Wall -Wredundant-constraints -fno-warn-tabs + +common exeStanza + Hs-source-dirs: src-exe + GHC-options: -O2 + Autogen-modules: Paths_bishbosh + Other-modules: Paths_bishbosh + Build-depends: + bishbosh, + hxt ^>= 9.3.1 + + if impl(ghc >= 7.0) && flag(llvm) + GHC-options: -fllvm + +common profStanza + if impl(ghc >= 7.4.1) + GHC-prof-options: -fprof-auto -fprof-cafs + + if flag(threaded) + GHC-prof-options: -fno-prof-count-entries + else + GHC-prof-options: -auto-all -caf-all + +common testStanza + Hs-source-dirs: src-test + Build-depends: + array ^>= 0.5.1.1, + bishbosh, + mtl ^>= 2.2.2, + random, + toolshed ^>= 0.18.0 + + if flag(polyparse) + Build-depends: polyparse ^>= 1.13 + CPP-Options: -DUSE_POLYPARSE='L' + else + Build-depends: parsec ^>= 3.1.14.0 + +Library + Import: commonStanza, profStanza + GHC-options: -O2 -fno-warn-unused-top-binds -Wno-all-missed-specialisations Hs-source-dirs: src-lib Exposed-modules: + BishBosh.Attribute.ANSIColourCode BishBosh.Attribute.CaptureMoveSortAlgorithm BishBosh.Attribute.ColourScheme BishBosh.Attribute.Direction @@ -127,6 +183,7 @@ BishBosh.Cartesian.Coordinates BishBosh.Cartesian.Ordinate BishBosh.Cartesian.Vector + BishBosh.Component.Accountant BishBosh.Component.CastlingMove BishBosh.Component.EitherQualifiedMove BishBosh.Component.Move @@ -143,7 +200,6 @@ BishBosh.ContextualNotation.StandardAlgebraic BishBosh.Data.Bool BishBosh.Data.Either - BishBosh.Data.Enum BishBosh.Data.Exception BishBosh.Data.Foldable BishBosh.Data.Integral @@ -178,8 +234,10 @@ BishBosh.Model.GameTree BishBosh.Model.MoveFrequency BishBosh.Model.PositionHashTree + BishBosh.Notation.Figurine BishBosh.Notation.ICCFNumeric BishBosh.Notation.MoveNotation + BishBosh.Notation.Notation BishBosh.Notation.PureCoordinate BishBosh.Notation.Smith BishBosh.Property.Arboreal @@ -214,12 +272,14 @@ BishBosh.State.MaybePieceByCoordinates BishBosh.State.Position BishBosh.StateProperty.Censor + BishBosh.StateProperty.Hashable BishBosh.StateProperty.Mutator BishBosh.StateProperty.Seeker BishBosh.State.TurnsByLogicalColour BishBosh.Text.AutoComplete BishBosh.Text.Case BishBosh.Text.Encoding + BishBosh.Text.ShowColouredPrefix BishBosh.Text.ShowList BishBosh.Text.ShowPrefix BishBosh.Time.GameClock @@ -234,168 +294,110 @@ BishBosh.UI.SetObject Build-depends: - array >= 0.5.1.1, - base >= 4.9 && < 5.0, - containers, - data-default, - deepseq >= 1.4.1, - extra, - factory >= 0.3.1, - filepath, - hxt, - mtl, - process >= 1.6.4, + array ^>= 0.5.1.1, + deepseq ^>= 1.4.1, + extra ^>= 1.7.4, + factory ^>= 0.3.1, + hxt ^>= 9.3.1, + mtl ^>= 2.2.2, + process >= 1.6.4, random, time, - toolshed >= 0.18 + toolshed ^>= 0.18.0 - if impl(ghc >= 7.0) - if flag(llvm) - GHC-options: -fllvm + if impl(ghc >= 7.0) && flag(llvm) + GHC-options: -fllvm - if impl(ghc >= 7.4.1) - GHC-prof-options: -fprof-auto -fprof-cafs + if flag(precision) + CPP-Options: -DUSE_PRECISION + else + if flag(narrownumbers) + CPP-Options: -DUSE_NARROW_NUMBERS - if flag(threaded) - GHC-prof-options: -fno-prof-count-entries + if flag(unboxedarrays) + CPP-Options: -DUSE_UNBOXED_ARRAYS - if impl(ghc >= 8.0) - GHC-options: -Wredundant-constraints - else - GHC-prof-options: -auto-all -caf-all + if flag(newtypewrappers) + CPP-Options: -DUSE_NEWTYPE_WRAPPERS if flag(polyparse) - Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=2 + Build-depends: polyparse ^>= 1.13 + CPP-Options: -DUSE_POLYPARSE='L' Exposed-modules: BishBosh.Text.Poly else - Build-depends: parsec - - if flag(narrownumbers) - CPP-Options: -DUSE_NARROW_NUMBERS - - if flag(newtypewrappers) - CPP-Options: -DUSE_NEWTYPE_WRAPPERS + Build-depends: parsec ^>= 3.1.14.0 if flag(threaded) Build-depends: parallel >= 3.0 CPP-Options: -DUSE_PARALLEL - if flag(unboxedarrays) - CPP-Options: -DUSE_UNBOXED_ARRAYS - Executable bishbosh - Default-language: Haskell2010 - GHC-options: -O2 -Wall -fno-warn-tabs - Hs-source-dirs: src-exe - Main-is: Main.hs - Autogen-modules: Paths_bishbosh + Import: commonStanza, exeStanza, profStanza + Main-is: Main.hs Other-modules: BishBosh.Concurrent.Pondering BishBosh.Play BishBosh.State.ApplicationTerminationReason BishBosh.State.PlayState - BishBosh.Text.ShowColouredPrefix BishBosh.UI.CECP BishBosh.UI.Raw - Paths_bishbosh if flag(unix) Other-modules: BishBosh.Concurrent.SignalHandlers Build-depends: - array >= 0.5.1.1, - base >= 4.9 && < 5.0, - bishbosh, - containers, - data-default, - deepseq >= 1.4.1, + array ^>= 0.5.1.1, + deepseq ^>= 1.4.1, directory, - extra, - factory >= 0.3.1, - filepath, - hxt, - mtl, + extra ^>= 1.7.4, + factory ^>= 0.3.1, + mtl ^>= 2.2.2, random, - toolshed >= 0.18 + toolshed ^>= 0.18.0 if impl(ghc >= 7.0) - if flag(llvm) - GHC-options: -fllvm - if flag(threaded) GHC-options: -rtsopts "-with-rtsopts=-N -H100M" if impl(ghc >= 7.4.1) - GHC-prof-options: -fprof-auto -fprof-cafs -rtsopts -with-rtsopts=-H100M - - if flag(threaded) - GHC-prof-options: -fno-prof-count-entries - - if impl(ghc >= 8.0) - GHC-options: -Wredundant-constraints - else - GHC-prof-options: -auto-all -caf-all + GHC-prof-options: -rtsopts -with-rtsopts=-H100M if flag(hxtrelaxng) - Build-depends: hxt-relaxng + Build-depends: hxt-relaxng ^>= 9.1.5 CPP-Options: -DUSE_HXTRELAXNG - if flag(narrownumbers) - CPP-Options: -DUSE_NARROW_NUMBERS - if flag(threaded) - CPP-Options: -DUSE_PARALLEL GHC-options: -threaded - if flag(unboxedarrays) + if flag(unboxedarrays) && !flag(precision) CPP-Options: -DUSE_UNBOXED_ARRAYS -- N.B.: The Haskell package 'unix' may be available on MS-Windows, but building it will probably be laborious. if flag(unix) Other-modules: BishBosh.Concurrent.SignalHandlers - Build-depends: unix + Build-depends: unix ^>= 2.7.2 + CPP-Options: -DUSE_UNIX -- This application coordinates a duel between two independently configured instances of 'bishbosh'. Executable duel - Default-language: Haskell2010 - GHC-options: -O2 -Wall -fno-warn-tabs - Hs-source-dirs: src-exe - Main-is: Duel.hs - Autogen-modules: Paths_bishbosh + Import: commonStanza, exeStanza + Main-is: Duel.hs Other-modules: Duel.Data.Options Duel.IO.Logger Duel.Process.Handles Duel.Process.Intermediary - Paths_bishbosh - Build-depends: - base >= 4.9 && < 5.0, - bishbosh, - containers, - data-default, - filepath, - hxt, - process >= 1.6.4 + Build-depends: process >= 1.6.4 CPP-Options: -DMOVE_NOTATION='S' - if impl(ghc >= 7.0) - if flag(llvm) - GHC-options: -fllvm - - if impl(ghc >= 8.0) - GHC-options: -Wredundant-constraints - -- Static unit-tests of the library. Test-Suite hunit-tests - Default-language: Haskell2010 - GHC-options: -Wall -fno-warn-tabs - Hs-source-dirs: src-test + Import: commonStanza, testStanza Main-is: HUnit.hs Type: exitcode-stdio-1.0 Autogen-modules: Paths_bishbosh @@ -426,34 +428,16 @@ Paths_bishbosh Build-depends: - array >= 0.5.1.1, - base >= 4.9 && < 5.0, - bishbosh, - containers, - data-default, - filepath, HUnit, - hxt, - mtl, - random, - toolshed >= 0.18 - - if impl(ghc >= 8.0) - GHC-options: -Wredundant-constraints + hxt ^>= 9.3.1 - if flag(polyparse) - Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=2 - else - Build-depends: parsec +-- CPP-Options: -DUSE_BRATKO_KOPEC -- Random unit-tests of the library. Test-Suite quickcheck-tests - Default-language: Haskell2010 - GHC-options: -Wall -fno-warn-tabs - Hs-source-dirs: src-test - Main-is: QuickCheck.hs - Type: exitcode-stdio-1.0 + Import: commonStanza, testStanza + Main-is: QuickCheck.hs + Type: exitcode-stdio-1.0 Other-modules: BishBosh.Test.QuickCheck.Attribute.CaptureMoveSortAlgorithm @@ -495,6 +479,7 @@ BishBosh.Test.QuickCheck.Model.Game BishBosh.Test.QuickCheck.Model.GameTree BishBosh.Test.QuickCheck.Model.MoveFrequency + BishBosh.Test.QuickCheck.Notation.Figurine BishBosh.Test.QuickCheck.Notation.ICCFNumeric BishBosh.Test.QuickCheck.Notation.MoveNotation BishBosh.Test.QuickCheck.Notation.PureCoordinate @@ -510,38 +495,31 @@ BishBosh.Test.QuickCheck.State.InstancesByPosition BishBosh.Test.QuickCheck.State.Position BishBosh.Test.QuickCheck.StateProperty.Censor + BishBosh.Test.QuickCheck.StateProperty.Hashable + BishBosh.Test.QuickCheck.StateProperty.Seeker BishBosh.Test.QuickCheck.State.TurnsByLogicalColour BishBosh.Test.QuickCheck.Text.Encoding BishBosh.Test.QuickCheck.Time.StopWatch + BishBosh.Test.QuickCheck.Type.Count + BishBosh.Test.QuickCheck.Type.Length BishBosh.Test.QuickCheck.UI.Command BishBosh.Test.QuickCheck.UI.PrintObject BishBosh.Test.QuickCheck.UI.ReportObject BishBosh.Test.QuickCheck.UI.SetObject Build-depends: - array >= 0.5.1.1, - base >= 4.9 && < 5.0, - bishbosh, - containers, - data-default, - deepseq >= 1.4.1, - extra, - filepath, - mtl, - QuickCheck >= 2.8.2, - random, - toolshed >= 0.18 + deepseq ^>= 1.4.1, + extra ^>= 1.7.4, + QuickCheck ^>= 2.13.2 - if impl(ghc >= 8.0) - GHC-options: -Wredundant-constraints + if flag(newtypewrappers) + CPP-Options: -DUSE_NEWTYPE_WRAPPERS - if flag(polyparse) - Build-depends: polyparse - CPP-Options: -DUSE_POLYPARSE=2 - else - Build-depends: parsec + if flag(precision) + CPP-Options: -DUSE_PRECISION + elif flag(narrownumbers) + CPP-Options: -DUSE_NARROW_NUMBERS if flag(threaded) - CPP-Options: -DUSE_PARALLEL GHC-options: -threaded 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.1.0 +Version: 0.1.2.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 @@ -90,17 +90,17 @@ ## 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. +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**. @@ -115,4 +115,34 @@ * 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**. + +## 0.1.2.0 +* Features: + + Added a Boolean configuration-option **BishBosh.Input.NativeUIOptions.getDepictFigurine** to specify whether the native UI should depict pieces using Unicode figurines rather than merely ASCII letters. + + **duel** now accumulates the frequency-distribution of games played in order to detect duplicates & warn when there's insufficient randomness. + + Added the runtime ability to set the position using *Extended Position Description*. +* Efficiency: + + Reimplemented function **BishBosh.Cartesian.Abscissa.getAdjacents** to promote memoisation. + + Made **BishBosh.Cartesian.Coordinates** & **BishBosh.Attribute.Direction** strict. + + Changed to use **Double** rather than **Rational** to perform the calculations defined by **BishBosh.Evaluation.Fitness**, before conversion to **BishBosh.Metric.CriterionValue.CriterionValue**. + + Added a Boolean switch **preferVictories** to **standardOpeningOptions** to govern whether from all matching positions extracted from the PGN-database, to prefer moves which result in a greater probability of victory, for the player who has the next move. Turning this off reduces the evaluation required of the PGN-parser; & there's no down-side if the PGN-database is known not to actually record any victories. + + Improved **BishBosh.ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMovesForPosition**, by independently comparing the pieces of each player, between the target game & a node of the tree, allowing earlier termination of the search. +* Bug-fixes: + + Avoided potential divide-by-zero @ **BishBosh.Input.CriteriaWeights.getWeightOfMaterial** / **BishBosh.Input.RankValues.calculateMaximumTotalValue** @. + + Guarded against starting from a persisted, but terminated, game. + + Added guards to function **BishBosh.Component.Piece.promote**. + + Amended **BishBosh.Evaluation.Fitness.measurePieceSquareValueIncrementally** to forward Castling moves to **measurePieceSquareValue**. + + Polymorphism: + * Replaced the polymorphic type **distance** in **BishBosh.Component.Vector**, with two concrete types **BishBosh.Type.Length.[XY]**. Removed the type **BishBosh.Type.Length.Distance**. + * Replaced the polymorphic type-parameters **x** & **y** with newtypes to: + + eliminate the fragile **RULE** pragmas required to switch to memoised function-implementations for specific type-parameters, + + eliminate chains of **SPECIALISE** pragmas down the call-stack to hot-spots. + + allow external calls from [**Text.ParserCombinators.Poly.Lazy.runParser**, **Text.ParserCombinators.Parsec.parse**], to access specialised implementations (see previous items), + + permit unification of the similar type-classes **BishBosh.Component.Zobrist.Hashable[12]D**, & to avoid the requirement for the **MultiParameterTypeClasses** pragma. +* Structural: + + Moved the type-class from module **BishBosh.Component.Zobrist** into a new module **BishBosh.StateProperty.Hashable**. + + Replaced non-specific type @ (Int, Int) @ coordinates in **BishBosh.Notation.{ICCFNumeric, PureCoordinate, Smith}** with @ (**BishBosh.Type.Length.X**, **BishBosh.Type.Length.Y**) @, & moved common code into a new module **BishBosh.Notation.Notation**. + + Added type **BishBosh.Type.Count.NCoordinates** for use by function **BishBosh.Cartesian.Coordinates.nSquares**. + + Added a method **BishBosh.StateProperty.Seeker.countPawnsByFileByLogicalColour** including a default implementation, & relocated the implementation from module **BishBosh.State.CoordinatesByRankByLogicalColour**. + + Added a type-class **BishBosh.Component.Account.Accountant**, with a single method used to sum piece-square values; thus permiting a common interface between the implementations in **BishBosh.State.CoordinatesByRankByLogicalColour** & **BishBosh.State.MaybePieceByCoordinates**. diff --git a/config/CECP/bishbosh_black.xml b/config/CECP/bishbosh_black.xml --- a/config/CECP/bishbosh_black.xml +++ b/config/CECP/bishbosh_black.xml @@ -26,8 +26,9 @@ &criteriaWeights; &pieceSquareTables_symmetric; - + &transpositions; + diff --git a/config/Raw/bishbosh_black.xml b/config/Raw/bishbosh_black.xml --- a/config/Raw/bishbosh_black.xml +++ b/config/Raw/bishbosh_black.xml @@ -26,8 +26,9 @@ &criteriaWeights; &pieceSquareTables_symmetric; - + &transpositions; + diff --git a/config/Raw/bishbosh_black_figurine.xml b/config/Raw/bishbosh_black_figurine.xml new file mode 100644 --- /dev/null +++ b/config/Raw/bishbosh_black_figurine.xml @@ -0,0 +1,45 @@ + + + + + + &rankValues_Kaufman; + &criteriaWeights; + &pieceSquareTables_symmetric; + + + &transpositions; + + + + + + + &pgnOptions_SCID; + + + + + + + + diff --git a/config/Raw/bishbosh_both.xml b/config/Raw/bishbosh_both.xml --- a/config/Raw/bishbosh_both.xml +++ b/config/Raw/bishbosh_both.xml @@ -26,8 +26,9 @@ &criteriaWeights; &pieceSquareTables_symmetric; - + &transpositions; + diff --git a/config/Raw/bishbosh_duel_black.xml b/config/Raw/bishbosh_duel_black.xml --- a/config/Raw/bishbosh_duel_black.xml +++ b/config/Raw/bishbosh_duel_black.xml @@ -31,16 +31,17 @@ &pieceSquareTables_Rofchade; - + &transpositions; + - &pgnOptions_SCID; + &pgnOptions_SCID; &pgnOptions_FICS; - + diff --git a/config/Raw/bishbosh_duel_white.xml b/config/Raw/bishbosh_duel_white.xml --- a/config/Raw/bishbosh_duel_white.xml +++ b/config/Raw/bishbosh_duel_white.xml @@ -31,16 +31,17 @@ &pieceSquareTables_symmetric; - + &transpositions; + - &pgnOptions_SCID; + &pgnOptions_SCID; &pgnOptions_FICS; - + diff --git a/config/Raw/bishbosh_prof.xml b/config/Raw/bishbosh_prof.xml --- a/config/Raw/bishbosh_prof.xml +++ b/config/Raw/bishbosh_prof.xml @@ -26,8 +26,9 @@ &pieceSquareTables_symmetric; - + &transpositions; + diff --git a/config/Raw/bishbosh_white.xml b/config/Raw/bishbosh_white.xml --- a/config/Raw/bishbosh_white.xml +++ b/config/Raw/bishbosh_white.xml @@ -26,8 +26,9 @@ &criteriaWeights; &pieceSquareTables_symmetric; - + &transpositions; + diff --git a/config/bishbosh.dtd b/config/bishbosh.dtd --- a/config/bishbosh.dtd +++ b/config/bishbosh.dtd @@ -80,6 +80,7 @@ tryToMatchMoves (False | True) #IMPLIED tryToMatchViaJoiningMove (False | True) #IMPLIED tryToMatchColourFlippedPosition (False | True) #IMPLIED + preferVictories (False | True) #IMPLIED > @@ -127,6 +128,9 @@ verbosity (Silent | Normal | Verbose | Deafening) #IMPLIED > + + + + + @@ -220,6 +224,10 @@ + + + + diff --git a/makefile b/makefile --- a/makefile +++ b/makefile @@ -13,7 +13,7 @@ # You should have received a copy of the GNU General Public License # along with BishBosh. If not, see . -.PHONY: cabalCheck duel findOmissions graphmod haddock hlint prof randomTest sdist test xboard +.PHONY: cabalCheck duel findOmissions graphmod haddock hlint prof profN2 randomTest sdist test xboard PACKAGE_NAME = bishbosh SHELL = /bin/bash @@ -29,45 +29,50 @@ # Groom sourcecode. hlint: $(BIN_DIR)/hlint - @$@ -j --no-exit-code\ + @$@ -j --no-exit-code\ + --cpp-define 'USE_NEWTYPE_WRAPPERS'\ --cpp-define 'USE_PARALLEL'\ - --cpp-define 'USE_POLYPARSE=1'\ + --cpp-define 'USE_POLYPARSE=L'\ --cpp-define 'USE_UNBOXED_ARRAYS'\ - --cpp-define 'USE_NEWTYPE_WRAPPERS'\ --ignore 'Use tuple-section'\ src-lib/ +RTS -N -RTS - @$@ -j --no-exit-code\ + @$@ -j --no-exit-code\ + --cpp-define 'MOVE_NOTATION=S'\ --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 - @$@ -j --cpp-define 'USE_PARALLEL'\ - --cpp-define 'USE_POLYPARSE=1'\ - --cpp-define 'USE_SEARCH'\ + @$@ -j --cpp-define 'USE_NEWTYPE_WRAPPERS'\ + --cpp-define 'USE_POLYPARSE=L'\ + --cpp-define 'USE_BRATKO_KOPEC'\ --ignore 'Use tuple-section'\ src-test/ +RTS -N -RTS # Serially compile with various CPP-flags & run the test-suites. test: - @for FLAG in -polyparse newtypewrappers -hxtrelaxng narrownumbers unboxedarrays -threaded; do\ + @for FLAG in -polyparse newtypewrappers narrownumbers unboxedarrays -hxtrelaxng -threaded precision; 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;\ + FLAGS=$$(shuf --echo -- hxtrelaxng narrownumbers newtypewrappers polyparse precision threaded unboxedarrays | head --lines=3 | sed -e '1s/^/-/' -e 's/\(.*\)/--flag=$(PACKAGE_NAME):\1/');\ + echo $${FLAGS};\ stack test $${FLAGS} $(GHC_OPTIONS) -# Profile. +# Profile a single-threaded build, to access entry-counts. prof: - @stack install --library-profiling --executable-profiling $(GHC_OPTIONS) - @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_$@.xml' +RTS -p -N2 -RTS + @stack install --profile --flag='bishbosh:-threaded' $(GHC_OPTIONS); + sleep 16; # Let the test-machine reach a quiescent state. + @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_$@.xml' +RTS -p -RTS +# Profile. +profN2: + @stack install --profile $(GHC_OPTIONS); + @$(PACKAGE_NAME) -i 'config/Raw/$(PACKAGE_NAME)_prof.xml' +RTS -p -N2 -RTS + # Install this product. $(BIN_DIR)/$(PACKAGE_NAME) $(BIN_DIR)/duel: @stack install $(GHC_OPTIONS) @@ -94,5 +99,5 @@ # 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 <(find src-* -type f -name '*.hs' | sed 's!^\./!!' | sort) <(tar -ztf `find dist* -mtime 0 -name '$(PACKAGE_NAME)-*.tar.gz' -print` | grep '\.hs$$' | grep -v 'Setup.hs' | sed 's!^$(PACKAGE_NAME)-[0-9.]*/!!' | sort) diff --git a/man/man1/bishbosh.1 b/man/man1/bishbosh.1 --- a/man/man1/bishbosh.1 +++ b/man/man1/bishbosh.1 @@ -110,7 +110,7 @@ :restart Start a new game. :rollBack [Int] Roll-back the optionally specified number of plies (half moves), defaulting to "\fB2\fR" when there's one manual player & "\fB1\fR" when both players are manual. :save Save the current game-state in "\fB~/.bishbosh\fR"; this is automatic unless explicitly un-configured. -:set \fBsearchDepth\fR \fIInt\fR Mutate the value of "\fBsearchDepth\fR", (see "\fBsearchOptions\fR" in \fBsection-5\fR of the man-pages). +:set object Specify "\fBEPD\fR " to define the position using \fBExtended Position Description\fR or "\fBsearchDepth\fR " to define the number of plies to search. :swap Swap sides. If the moves of one side were automated, then this will cause automation of the moves of the other side. .TE .SS Hardware-requirements. diff --git a/man/man1/duel.1 b/man/man1/duel.1 --- a/man/man1/duel.1 +++ b/man/man1/duel.1 @@ -11,6 +11,11 @@ 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. +.PP +CAVEAT: the population of games resulting from this statistical experiment must be diverse, but this application's logic is largely deterministic (& both players are configured to use it). +In order to introduce some randomness, PGN-databases must be configured in which the application may search for positions matching the current game. +When more than one match for the current position is found, one of them is \fIrandomly\fR selected at the source of the next move. +If the specified PGN-databases fail to provide such move-options, deterministic play will result. .SH OPTIONS .TP \fB--verbosity=\fR(\fBSilent\fR|\fBNormal\fR|\fBVerbose\fR|\fBDeafening\fR), defaulting to "\fBNormal\fR". @@ -88,6 +93,9 @@ .SH AUTHOR Written by Dr. Alistair Ward. .SH BUGS +.PP +In the absence of any configured \fBpgnOptions\fR, the game is completely deterministic & will reproduce the previous result endlessly. +Even when PGN-databases have been configured, they may introduce insufficient randomness to produce a large population of unique games on which to perform statistical analysis. .SS "REPORTING BUGS" Report bugs to "\fBbishbosh@functionalley.com\fR". .SH COPYRIGHT diff --git a/man/man5/bishbosh.5 b/man/man5/bishbosh.5 --- a/man/man5/bishbosh.5 +++ b/man/man5/bishbosh.5 @@ -140,6 +140,7 @@ tryToMatchMoves Bool True whether to attempt to exactly match the moves already made, with a standard opening; i.e. without matching transpositions. tryToMatchViaJoiningMove Bool True whether to attempt to join the current position (irrespective of the means by which it was achieved) to a standard opening that's only one move away. tryToMatchColourFlippedPosition Bool True whether to attempt to match a colour-flipped (<\fBhttps://www.chessprogramming.org/Color_Flipping\fR>) version of the current position with a standard opening. +preferVictories Bool True whether from all matching positions extracted from the PGN-database, to prefer moves which result in a greater probability of victory, for the player who has the next move. .TE .IP \(bu \fBsearchDepth\fR \fIInt\fR, defaulting to "\fB4\fR" (minimum "\fB1\fR"): the number of plies (half moves) to search ahead, when selecting the next move. @@ -220,6 +221,9 @@ darkSquareColour (\fBBlack\fR|\fBRed\fR|\fBGreen\fR|\fBBlue\fR|\fBMagenta\fR|\fBCyan\fR) lightSquareColour (\fBRed\fR|\fBGreen\fR|\fBYellow\fR|\fBMagenta\fR|\fBCyan\fR|\fBWhite\fR) .TE +.IP \(bu +\fBdepictFigurine\fR: specifies whether to depict pieces as Unicode figurines, or merely ASCII letters. +This will require a terminal configured to render Unicode. .SH FILES .TS lb lb 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 @@ -47,7 +47,10 @@ 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.GameTree as Model.GameTree +import qualified BishBosh.Model.MoveFrequency as Model.MoveFrequency import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Property.Empty as Property.Empty @@ -55,13 +58,12 @@ import qualified BishBosh.State.PlayState as State.PlayState import qualified BishBosh.Text.ShowColouredPrefix as Text.ShowColouredPrefix import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.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 import qualified Control.Exception -import qualified Data.Array.IArray +import qualified Control.Monad import qualified Data.Bits import qualified Data.Default import qualified Data.Maybe @@ -76,39 +78,32 @@ -- | Plays the game according to the specified configuration. play :: ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, - Data.Array.IArray.Ix x, + Control.DeepSeq.NFData pieceSquareValue, #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.FiniteBits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Ord positionHash, - Read x, - Read y, - Real pieceSquareValue, - Show pieceSquareValue, - Show x, - Show y, - System.Random.Random positionHash, - System.Random.RandomGen randomGen + Data.Bits.FiniteBits positionHash, + Fractional pieceSquareValue, + Ord positionHash, + Real pieceSquareValue, + Show pieceSquareValue, + System.Random.Random positionHash, + System.Random.RandomGen randomGen ) - => randomGen - -> Input.Options.Options pieceSquareValue x y - -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y -- ^ Standard openings. - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + => Input.Verbosity.Verbosity + -> randomGen + -> Input.Options.Options pieceSquareValue + -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -- ^ Standard openings. + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) {-# SPECIALISE play :: System.Random.RandomGen randomGen - => randomGen - -> 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) + => Input.Verbosity.Verbosity + -> randomGen + -> Input.Options.Options Type.Mass.PieceSquareValue + -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) #-} -play randomGen options qualifiedMoveForest = Data.Maybe.maybe ( +play verbosity randomGen options qualifiedMoveForest = Data.Maybe.maybe ( return {-to IO-monad-} Data.Default.def {-game-} ) ( \(filePath, _) -> if any (System.FilePath.equalFilePath filePath) [ @@ -118,9 +113,16 @@ then return {-to IO-monad-} Data.Default.def {-game-} else Control.Exception.catch ( do - s <- readFile filePath + game <- read <$> readFile filePath - return {-to IO-monad-} $! read s -- Force evaluation, to trigger any exception thrown from within 'catch'. + Data.Maybe.maybe ( + return {-to IO-monad-} $! game -- Force evaluation, to trigger any exception thrown from within 'catch'. + ) ( + \terminationReason -> do + Control.Monad.when (verbosity > minBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixWarning . showString "persisted game had terminated (" $ shows terminationReason "); restarting game." + + return {-to IO-monad-} Data.Default.def + ) $ Model.Game.getMaybeTerminationReason game ) $ \e -> do System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixWarning . showString "'readFile' failed; " $ shows (e :: Control.Exception.SomeException) "." @@ -128,9 +130,18 @@ ) ( Input.IOOptions.getMaybePersistence ioOptions ) >>= ( - ( + let + sortOnStandardOpeningMoveFrequency = Input.SearchOptions.getSortOnStandardOpeningMoveFrequency searchOptions + + moveFrequency + | sortOnStandardOpeningMoveFrequency = Model.GameTree.toMoveFrequency $ ContextualNotation.QualifiedMoveForest.toGameTree qualifiedMoveForest + | otherwise = Property.Empty.empty + in ( \playState -> Data.Maybe.maybe ( - return {-to IO-monad-} playState + do + Control.Monad.when (sortOnStandardOpeningMoveFrequency && verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . shows (Model.MoveFrequency.countEntries moveFrequency) . showString " plies are recorded in the tree, of which " $ shows (Model.MoveFrequency.countDistinctEntries moveFrequency) " are distinct." + + return {-to IO-monad-} playState ) ( \depth -> do System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "Move-tree:\n" $ ( @@ -141,11 +152,7 @@ return {-to IO-monad-} playState ) $ Input.UIOptions.getMaybePrintMoveTree uiOptions - ) . State.PlayState.initialise options zobrist ( - if Input.SearchOptions.getSortOnStandardOpeningMoveFrequency searchOptions - then Model.GameTree.toMoveFrequency $ ContextualNotation.QualifiedMoveForest.toGameTree qualifiedMoveForest - else Property.Empty.empty {-MoveFrequency-} - ) + ) . State.PlayState.initialise options zobrist moveFrequency ) >>= ( const UI.Raw.takeTurns ||| const UI.CECP.takeTurns $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- Select a user-interface. ) ( 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 @@ -73,10 +73,8 @@ import qualified BishBosh.State.ApplicationTerminationReason as State.ApplicationTerminationReason import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour 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 import qualified Data.Default import qualified Data.List @@ -89,40 +87,35 @@ #endif -- | The type threaded through the sequence of /game/s during play. -data PlayState pieceSquareValue positionHash x y = MkPlayState { +data PlayState pieceSquareValue positionHash = 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. + getZobrist :: Component.Zobrist.Zobrist positionHash, -- ^ The constant hash-codes used to construct position-hashes. + getMoveFrequency :: Model.GameTree.MoveFrequency, -- ^ The constant frequency of moves extracted from file. + getSearchState :: Search.SearchState.SearchState positionHash, + getOptions :: Input.Options.Options pieceSquareValue, -- ^ The constant options by which the game is configured. getMaybeApplicationTerminationReason :: Maybe State.ApplicationTerminationReason.ApplicationTerminationReason -- ^ Whether the game has terminated. } -- | Constructor. initialise :: ( - 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). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Real pieceSquareValue, - Show x, - Show y + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Real pieceSquareValue ) - => Input.Options.Options pieceSquareValue x y - -> Component.Zobrist.Zobrist x y positionHash - -> Model.GameTree.MoveFrequency x y - -> Model.Game.Game x y - -> PlayState pieceSquareValue positionHash x y + => Input.Options.Options pieceSquareValue + -> Component.Zobrist.Zobrist positionHash + -> Model.GameTree.MoveFrequency + -> Model.Game.Game + -> PlayState pieceSquareValue positionHash {-# SPECIALISE initialise - :: 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 + :: Input.Options.Options Type.Mass.PieceSquareValue + -> Component.Zobrist.Zobrist Type.Crypto.PositionHash + -> Model.GameTree.MoveFrequency + -> Model.Game.Game + -> PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash #-} initialise options zobrist moveFrequency game = MkPlayState { getCriterionValues = [], @@ -136,32 +129,27 @@ } -- | Accessor. -getGame :: PlayState pieceSquareValue positionHash x y -> Model.Game.Game x y +getGame :: PlayState pieceSquareValue positionHash -> Model.Game.Game getGame MkPlayState { getSearchState = searchState } = Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame $ Search.SearchState.getPositionHashQuantifiedGameTree searchState -- | The type of a function used to transform a 'PlayState'. -type Transformation pieceSquareValue positionHash x y = PlayState pieceSquareValue positionHash x y -> PlayState pieceSquareValue positionHash x y +type Transformation pieceSquareValue positionHash = PlayState pieceSquareValue positionHash -> PlayState pieceSquareValue positionHash -- | Mutator. -setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> Transformation pieceSquareValue positionHash x y +setPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash -> Transformation pieceSquareValue positionHash setPositionHashQuantifiedGameTree positionHashQuantifiedGameTree playState@MkPlayState { getSearchState = searchState } = playState { getSearchState = searchState { Search.SearchState.getPositionHashQuantifiedGameTree = positionHashQuantifiedGameTree } } -- | Reconstruct the /positionHashQuantifiedGameTree/ (in the /searchState/), with the apex set to the specified game. reconstructPositionHashQuantifiedGameTree :: ( - 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). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Real pieceSquareValue, - Show x, - Show y - ) => Model.Game.Game x y -> Transformation pieceSquareValue positionHash x y + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Real pieceSquareValue + ) => Model.Game.Game -> Transformation pieceSquareValue positionHash reconstructPositionHashQuantifiedGameTree game playState@MkPlayState { getZobrist = zobrist, getMoveFrequency = moveFrequency, @@ -174,18 +162,13 @@ -- | Reset to the initial state. resetPositionHashQuantifiedGameTree :: ( - 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). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Real pieceSquareValue, - Show x, - Show y - ) => Transformation pieceSquareValue positionHash x y + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Real pieceSquareValue + ) => Transformation pieceSquareValue positionHash resetPositionHashQuantifiedGameTree playState = reconstructPositionHashQuantifiedGameTree Data.Default.def playState { getCriterionValues = [], getMaybeApplicationTerminationReason = Nothing @@ -194,15 +177,15 @@ -- | Mutator. updateWithAutomaticMove :: [Metric.CriterionValue.CriterionValue] - -> Search.SearchState.SearchState x y positionHash - -> Transformation pieceSquareValue positionHash x y + -> Search.SearchState.SearchState positionHash + -> Transformation pieceSquareValue positionHash updateWithAutomaticMove criterionValues searchState playState = playState { getCriterionValues = criterionValues : getCriterionValues playState, getSearchState = searchState } -- | Mutator. -updateWithManualMove :: (Eq x, Eq y) => Model.Game.Game x y -> Transformation pieceSquareValue positionHash x y +updateWithManualMove :: Model.Game.Game -> Transformation pieceSquareValue positionHash updateWithManualMove game playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.State.PlayState.updateWithManualMove:\tEvaluation.PositionHashQuantifiedGameTree.reduce failed." @@ -222,7 +205,7 @@ Floating standardDeviation, Fractional mean ) - => PlayState pieceSquareValue positionHash x y + => PlayState pieceSquareValue positionHash -> [(mean, standardDeviation)] calculateCriterionValueStatistics MkPlayState { getCriterionValues = criterionValues } = map ( ( @@ -233,22 +216,15 @@ ) $ Data.List.transpose criterionValues -- | Resignation by the player who currently holds the choice of move. -resign :: Transformation pieceSquareValue positionHash x y +resign :: Transformation pieceSquareValue positionHash resign playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Evaluation.PositionHashQuantifiedGameTree.resign $ Search.SearchState.getPositionHashQuantifiedGameTree searchState ) playState -- | Given a string from which either a /move/ can't be parsed or the one that can is illegal, returns the closest matches amongst the currently available /move/s. -suggestCorrections :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => String -- ^ Move-string. - -> PlayState pieceSquareValue positionHash x y +suggestCorrections + :: String -- ^ Move-string. + -> PlayState pieceSquareValue positionHash -> [String] -- ^ Suggested corrections. suggestCorrections moveString playState@MkPlayState { getOptions = options } | Model.Game.isTerminated game = [] @@ -260,12 +236,12 @@ -- | Whether the game in the first /play-state/ has more plies than that in the second. hasMorePlies - :: PlayState pieceSquareValue positionHash x y - -> PlayState pieceSquareValue positionHash x y + :: PlayState pieceSquareValue positionHash + -> PlayState pieceSquareValue positionHash -> Bool hasMorePlies playState playState' = Data.Ord.comparing (State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour . getGame) playState playState' == GT -- | Whether the user has requested application-termination, or the configured maximum number of turns has been reached. -hasApplicationTerminationBeenRequested :: PlayState pieceSquareValue positionHash x y -> Bool +hasApplicationTerminationBeenRequested :: PlayState pieceSquareValue positionHash -> Bool hasApplicationTerminationBeenRequested MkPlayState { getMaybeApplicationTerminationReason = maybeApplicationTerminationReason } = Data.Maybe.isJust maybeApplicationTerminationReason diff --git a/src-exe/BishBosh/Text/ShowColouredPrefix.hs b/src-exe/BishBosh/Text/ShowColouredPrefix.hs deleted file mode 100644 --- a/src-exe/BishBosh/Text/ShowColouredPrefix.hs +++ /dev/null @@ -1,52 +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@] Define standard prefixes for log-messages. --} - -module BishBosh.Text.ShowColouredPrefix( --- * Constants - showsPrefixInfo, - showsPrefixWarning, - showsPrefixError - ) where - -import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour -import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix - --- | Show the prefix used to denote an information-message. -showsPrefixInfo :: ShowS -showsPrefixInfo = Attribute.PhysicalColour.bracket ( - Attribute.PhysicalColour.selectGraphicsRendition False $ Attribute.PhysicalColour.mkFgColourCode Attribute.PhysicalColour.green - ) $ Text.ShowPrefix.showsPrefixInfo "" - --- | Show the prefix used to denote a warning-message. -showsPrefixWarning :: ShowS -showsPrefixWarning = Attribute.PhysicalColour.bracket ( - Attribute.PhysicalColour.selectGraphicsRendition True $ Attribute.PhysicalColour.mkFgColourCode Attribute.PhysicalColour.yellow - ) $ Text.ShowPrefix.showsPrefixWarning "" - --- | Show the prefix used to denote an error-message. -showsPrefixError :: ShowS -showsPrefixError = Attribute.PhysicalColour.bracket ( - Attribute.PhysicalColour.selectGraphicsRendition True $ Attribute.PhysicalColour.mkFgColourCode Attribute.PhysicalColour.red - ) $ Text.ShowPrefix.showsPrefixError "" - 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 @@ -85,7 +85,6 @@ import qualified BishBosh.Time.StopWatch as Time.StopWatch import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.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 @@ -96,12 +95,12 @@ import qualified Control.Exception import qualified Control.Monad import qualified Control.Monad.Reader -import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.Default +import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified System.IO import qualified System.Random @@ -170,7 +169,7 @@ showsThinking :: Property.ShowFloat.ShowFloat stoppedWatch => Type.Count.NPlies -- ^ Search-depth. - -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y + -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue -> Type.Mass.WeightedMean -> stoppedWatch -> Type.Count.NPositions -- ^ Nodes searched. @@ -192,37 +191,30 @@ * Since the user can also request roll-back to an earlier game before then requesting a new move, a new game is returned rather than just the requested move. -} -readMove :: forall pieceSquareValue positionHash randomGen x y. ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, - Data.Array.IArray.Ix x, +readMove :: forall pieceSquareValue positionHash randomGen. ( + Control.DeepSeq.NFData pieceSquareValue, #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - Show x, - Show y, - System.Random.RandomGen randomGen + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Ord positionHash, + Real pieceSquareValue, + Show pieceSquareValue, + System.Random.RandomGen randomGen ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) {-# SPECIALISE readMove :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> randomGen -> 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) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) #-} readMove positionHashQualifiedMoveTree randomGen = slave where slave runningWatch playState = let @@ -230,7 +222,7 @@ (searchOptions, ioOptions) = Input.Options.getSearchOptions &&& Input.Options.getIOOptions $ options (searchDepthByLogicalColour, tryToMatchSwitches) = Input.SearchOptions.getSearchDepthByLogicalColour &&& Input.StandardOpeningOptions.getMatchSwitches . Input.SearchOptions.getStandardOpeningOptions $ searchOptions - fullyManual = Data.Map.null searchDepthByLogicalColour + fullyManual = Data.Foldable.null searchDepthByLogicalColour uiOptions = Input.IOOptions.getUIOptions ioOptions @@ -243,7 +235,7 @@ \cecpOptions -> let displaySAN = Input.CECPOptions.getDisplaySAN cecpOptions - onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState pieceSquareValue positionHash) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -261,13 +253,15 @@ ) ( 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) + else Notation.MoveNotation.showNotation moveNotation $ Evaluation.QuantifiedGame.getLastTurn (quantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame) _ -> Control.Exception.throwIO . Data.Exception.mkRequestFailure . showString "BishBosh.UI.CECP.readMove.slave.onCommand:\tunexpectedly failed to find any moves; " $ shows game "." -- CAVEAT: the game should have been terminated. ) ( \(qualifiedMove, _) -> putStrLn . showString hintTag . showChar ' ' $ if displaySAN then ContextualNotation.StandardAlgebraic.showMove explicitEnpassant qualifiedMove game else Notation.MoveNotation.showNotation moveNotation qualifiedMove - ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen tryToMatchSwitches game positionHashQualifiedMoveTree + ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen ( + Input.StandardOpeningOptions.getPreferVictories . Input.SearchOptions.getStandardOpeningOptions $ searchOptions + ) tryToMatchSwitches game positionHashQualifiedMoveTree return {-to IO-monad-} playState -- N.B.: though one could merely call "eventLoop", a new random-generator is desirable in case an alternative hint is requested. onCommand (UI.Command.Print printObject) = do @@ -293,9 +287,7 @@ UI.ReportObject.FEN -> return {-to IO-monad-} . Property.ForsythEdwards.showFEN UI.ReportObject.Game -> return {-to IO-monad-} . show UI.ReportObject.MaxPositionInstances -> return {-to IO-monad-} . show . State.InstancesByPosition.findMaximumInstances . Model.Game.getInstancesByPosition - UI.ReportObject.Moves -> return {-to IO-monad-} . showString ( - showString Component.Move.tag "s" - ) . Text.ShowList.showsAssociation . ($ ".") . Text.ShowList.showsFormattedList' ( + UI.ReportObject.Moves -> return {-to IO-monad-} . ($ "") . Text.ShowList.showsFormattedList' ( Notation.MoveNotation.showsNotation moveNotation ) . Model.Game.listTurnsChronologically UI.ReportObject.PGN -> fmap ($ ".") . ContextualNotation.PGN.showsGame @@ -316,16 +308,7 @@ else showString " & leaving " . shows modeNames ) "." - Data.Maybe.maybe ( - return {-to IO-monad-} () - ) ( - \(filePath, _) -> Control.Exception.catch ( - do - 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) - ) $ Input.IOOptions.getMaybePersistence ioOptions + Input.IOOptions.persist ioOptions False (Data.Default.def :: Model.Game.Game) return {-to IO-monad-} $ State.PlayState.resetPositionHashQuantifiedGameTree playState { State.PlayState.getOptions = options { @@ -337,14 +320,14 @@ } } onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash) rollBack nPlies | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = return {-to IO-monad-} $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState | otherwise = onCommand UI.Command.Restart in Data.Maybe.maybe ( let 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. + nPlies = fromIntegral . succ $ Data.Foldable.length 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." @@ -367,31 +350,32 @@ ) >>= System.IO.hPutStrLn System.IO.stderr eventLoop - onCommand (UI.Command.Set setObject) - | fullyManual = do - Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixWarning $ shows UI.Command.setTag " requires an automated opponent." + onCommand (UI.Command.Set setObject) = Control.Exception.catchJust ( + \e -> if Data.Exception.isBadData e + then Just $ show e + else Nothing + ) ( + do + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." - return {-to IO-monad-} playState - | otherwise = Control.Exception.catchJust ( - \e -> if Data.Exception.isBadData e - then Just $ show e - else Nothing - ) ( - do - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." + case setObject of + UI.SetObject.EPD game' -> slave runningWatch $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState -- Recurse. + UI.SetObject.SearchDepth searchDepth + | fullyManual -> do + Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixWarning $ shows UI.Command.setTag " requires an automated opponent." - slave runningWatch playState { - State.PlayState.getOptions = Control.DeepSeq.force $ case setObject of - UI.SetObject.SearchDepth searchDepth -> options { + eventLoop + | otherwise -> slave runningWatch playState { + State.PlayState.getOptions = Control.DeepSeq.force $ options { Input.Options.getSearchOptions = Input.SearchOptions.setSearchDepth searchDepth $ Input.Options.getSearchOptions options } - } - ) ( - \s -> do - Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowPrefix.showsPrefixError s + } -- Recurse. + ) ( + \s -> do + Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowPrefix.showsPrefixError s - eventLoop - ) + eventLoop + ) onCommand UI.Command.Swap | fullyManual = do 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." @@ -402,7 +386,7 @@ return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash) eventLoop = getLine >>= \line -> do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "received \"" $ showString line "\"." @@ -532,7 +516,7 @@ eventLoop else let nextLogicalColour = Model.Game.getNextLogicalColour game - in if nextLogicalColour `Data.Map.member` searchDepthByLogicalColour + in if nextLogicalColour `Map.member` searchDepthByLogicalColour then return {-to IO-monad-} playState { State.PlayState.getOptions = options' } else do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "swapping to play " $ shows nextLogicalColour ", i.e. next." @@ -557,7 +541,7 @@ \playState' -> let engineLogicalColour = minBound options' = State.PlayState.getOptions playState' - in if Data.Map.member engineLogicalColour . Input.SearchOptions.getSearchDepthByLogicalColour $ Input.Options.getSearchOptions options' + in if Map.member engineLogicalColour . Input.SearchOptions.getSearchDepthByLogicalColour $ Input.Options.getSearchOptions options' then return {-to IO-monad-} playState' else do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixInfo . showString "swapping to play " $ shows engineLogicalColour "." @@ -811,7 +795,7 @@ ] ++ map show [ Data.Maybe.fromMaybe ( Control.Exception.throw . Data.Exception.mkNullDatum . showString "BishBosh.UI.CECP.readMove.slave.eventLoop:\tundefined " $ shows Input.Options.tag "." - ) . Data.Maybe.listToMaybe $ Data.Map.elems searchDepthByLogicalColour, + ) . Data.Maybe.listToMaybe $ Data.Foldable.toList searchDepthByLogicalColour, Input.SearchOptions.minimumSearchDepth, 7 -- Arbitrary maximum. ] @@ -989,7 +973,7 @@ maybePaused = Input.CECPOptions.getMaybePaused cecpOptions - moveCommand :: String -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + moveCommand :: String -> IO (State.PlayState.PlayState pieceSquareValue positionHash) moveCommand moveString = case Notation.MoveNotation.readsQualifiedMove moveNotation moveString of [(eitherQualifiedMove, "")] | Just errorMessage <- Model.Game.validateEitherQualifiedMove eitherQualifiedMove game -> do @@ -1039,35 +1023,28 @@ ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall pieceSquareValue positionHash randomGen x y. ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, - Data.Array.IArray.Ix x, +takeTurns :: forall pieceSquareValue positionHash randomGen. ( + Control.DeepSeq.NFData pieceSquareValue, #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Ord positionHash, - Real pieceSquareValue, - Show pieceSquareValue, - Show x, - Show y, - System.Random.RandomGen randomGen + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Ord positionHash, + Real pieceSquareValue, + Show pieceSquareValue, + System.Random.RandomGen randomGen ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) {-# SPECIALISE takeTurns :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> randomGen - -> 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) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = do mVar <- Control.Concurrent.newEmptyMVar @@ -1086,11 +1063,11 @@ verbosity = Input.UIOptions.getVerbosity uiOptions slave - :: Maybe (Concurrent.Pondering.Pondering (Component.Move.Move x y)) + :: Maybe (Concurrent.Pondering.Pondering Component.Move.Move) -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) slave maybePondering maybeMaximumPlies ~(randomGen' : randomGens) playState' = let (game', (searchOptions', uiOptions')) = State.PlayState.getGame &&& (Input.Options.getSearchOptions &&& Input.IOOptions.getUIOptions . Input.Options.getIOOptions) . State.PlayState.getOptions $ playState' -- Deconstruct. (ponderMode, isPostMode) = const ( @@ -1157,7 +1134,7 @@ then Property.ShowFloat.showsFloatToN nDecimalDigits ( Control.Monad.Reader.runReader ( Evaluation.Fitness.evaluateFitness Nothing game' - ) evaluationOptions :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues + ) evaluationOptions ) . Search.Search.showsSeparator -- Prepend the fitness of the original game prior to the result. else id ) . Notation.MoveNotation.showsNotationFloatToNDecimals moveNotation nDecimalDigits searchResult' . showString " in " $ Property.ShowFloat.showsFloatToN nDecimalDigits stoppedWatch "s." @@ -1232,24 +1209,18 @@ putStrLn . showString moveTag . showChar ' ' $ Notation.MoveNotation.showNotation moveNotation qualifiedMove -- Send the move to the GUI. return {-to IO-monad-} (State.PlayState.updateWithManualMove selectedGame playState', Nothing) -- N.B.: one could ponder, but would have to construct a game-tree, & the chance of a subsequent standard-opening move is high. - ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' ( - Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions + ) $ uncurry ( + ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' + ) ( + Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions ) game' positionHashQualifiedMoveTree -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. ) ( if Input.UIOptions.isCECPManualMode uiOptions' then Nothing - else Model.Game.getNextLogicalColour game' `Data.Map.lookup` Input.SearchOptions.getSearchDepthByLogicalColour searchOptions' + else Model.Game.getNextLogicalColour game' `Map.lookup` Input.SearchOptions.getSearchDepthByLogicalColour searchOptions' ) >>= ( \(playState'', maybePondering') -> do - Data.Maybe.maybe ( - return {-to IO-monad-} () - ) ( - \(filePath, automatic) -> let - game'' = State.PlayState.getGame playState'' - in Control.Monad.when automatic . Control.Exception.catch ( - System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` game'') - ) $ \e -> System.IO.hPutStrLn System.IO.stderr . Text.ShowPrefix.showsPrefixError $ show (e :: Control.Exception.SomeException) - ) $ Input.IOOptions.getMaybePersistence ioOptions + Input.IOOptions.persist ioOptions False $ State.PlayState.getGame playState'' if State.PlayState.hasApplicationTerminationBeenRequested playState'' then return {-to IO-monad-} playState'' 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 @@ -68,7 +68,6 @@ import qualified BishBosh.Time.StopWatch as Time.StopWatch import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.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 @@ -79,11 +78,11 @@ import qualified Control.Exception import qualified Control.Monad import qualified Control.Monad.Reader -import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.Default +import qualified Data.Foldable import qualified Data.List.Extra -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified System.IO import qualified System.Random @@ -98,46 +97,37 @@ * Since the user can also request roll-back to an earlier game before then requesting a new move, a new game is returned rather than just the requested move. -} -readMove :: forall pieceSquareValue positionHash randomGen x y. ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, - Data.Array.IArray.Ix x, +readMove :: forall pieceSquareValue positionHash randomGen. ( + Control.DeepSeq.NFData pieceSquareValue, #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Ord positionHash, - Read x, - Read y, - Real pieceSquareValue, - Show pieceSquareValue, - Show x, - Show y, - System.Random.RandomGen randomGen + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Ord positionHash, + Real pieceSquareValue, + Show pieceSquareValue, + System.Random.RandomGen randomGen ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen -> Time.StopWatch.StopWatch - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) {-# SPECIALISE readMove :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> randomGen -> 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) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) #-} readMove positionHashQualifiedMoveTree randomGen runningWatch playState = let (game, options) = State.PlayState.getGame &&& State.PlayState.getOptions $ playState (searchOptions, ioOptions) = Input.Options.getSearchOptions &&& Input.Options.getIOOptions $ options searchDepthByLogicalColour = Input.SearchOptions.getSearchDepthByLogicalColour searchOptions - fullyManual = Data.Map.null searchDepthByLogicalColour + fullyManual = Data.Foldable.null searchDepthByLogicalColour (uiOptions, maybeMaximumPGNNames) = Input.IOOptions.getUIOptions &&& Input.IOOptions.getMaybeMaximumPGNNames $ ioOptions @@ -146,14 +136,18 @@ verbosity = Input.UIOptions.getVerbosity uiOptions in ( \nativeUIOptions -> let - show2D :: Model.Game.Game x y -> String - show2D = uncurry State.MaybePieceByCoordinates.show2D ( - snd {-columns-} . Input.NativeUIOptions.getBoardMagnification &&& Input.NativeUIOptions.getColourScheme $ nativeUIOptions + show2D :: Model.Game.Game -> String + show2D = State.MaybePieceByCoordinates.show2D ( + snd {-columns-} $ Input.NativeUIOptions.getBoardMagnification nativeUIOptions ) ( + Input.NativeUIOptions.getColourScheme nativeUIOptions + ) ( + Input.NativeUIOptions.getDepictFigurine nativeUIOptions + ) ( Notation.MoveNotation.getOrigin moveNotation ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard - onCommand :: UI.Command.Command x y -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + onCommand :: UI.Command.Command -> IO (State.PlayState.PlayState pieceSquareValue positionHash) onCommand UI.Command.Hint = do Control.Monad.unless (Model.Game.isTerminated game) . Data.Maybe.maybe ( do @@ -175,8 +169,10 @@ _ -> Control.Exception.throwIO . Data.Exception.mkRequestFailure . showString "BishBosh.UI.Raw.readMove.onCommand:\tunexpectedly failed to find any moves; " $ shows game "." -- CAVEAT: the game should have terminated. ) ( \(qualifiedMove, names) -> putStrLn . Text.ShowColouredPrefix.showsPrefixInfo . showString "Try \"" . Notation.MoveNotation.showsNotation moveNotation qualifiedMove . showString "\" from:" $ ContextualNotation.QualifiedMoveForest.showsNames maybeMaximumPGNNames names "" - ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen ( - Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions + ) $ uncurry ( + ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen + ) ( + Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions ) game positionHashQualifiedMoveTree return {-to IO-monad-} playState -- N.B.: though one could merely call "eventLoop", a new random-generator is desirable in case an alternative hint is requested. @@ -202,9 +198,7 @@ UI.ReportObject.FEN -> putStrLn . Property.ForsythEdwards.showFEN UI.ReportObject.Game -> print UI.ReportObject.MaxPositionInstances -> print . State.InstancesByPosition.findMaximumInstances . Model.Game.getInstancesByPosition - UI.ReportObject.Moves -> putStrLn . showString ( - showString Component.Move.tag "s" - ) . Text.ShowList.showsAssociation . ($ ".") . Text.ShowList.showsFormattedList' ( + UI.ReportObject.Moves -> putStrLn . ($ "") . Text.ShowList.showsFormattedList' ( Notation.MoveNotation.showsNotation moveNotation ) . Model.Game.listTurnsChronologically UI.ReportObject.PGN -> putStrLn . ($ ".") <=< ContextualNotation.PGN.showsGame @@ -218,20 +212,11 @@ onCommand UI.Command.Restart = do Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowColouredPrefix.showsPrefixInfo "restarting game." - Data.Maybe.maybe ( - return {-to IO-monad-} () - ) ( - \(filePath, _) -> Control.Exception.catch ( - do - 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) - ) $ Input.IOOptions.getMaybePersistence ioOptions + Input.IOOptions.persist ioOptions (verbosity == maxBound) (Data.Default.def :: Model.Game.Game) return {-to IO-monad-} $ State.PlayState.resetPositionHashQuantifiedGameTree playState onCommand (UI.Command.RollBack maybeNPlies) = let - rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + rollBack :: Type.Count.NPlies -> IO (State.PlayState.PlayState pieceSquareValue positionHash) rollBack nPlies | (game', _) : _ <- drop (fromIntegral $ pred nPlies) $ Model.Game.rollBack game = do Control.Monad.when (verbosity == maxBound) . putStrLn $ show2D game' @@ -241,7 +226,7 @@ in Data.Maybe.maybe ( let 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. + nPlies = fromIntegral . succ $ Data.Foldable.length 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." @@ -264,31 +249,35 @@ ) >>= System.IO.hPutStrLn System.IO.stderr eventLoop - onCommand (UI.Command.Set setObject) - | fullyManual = do - System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixWarning $ shows UI.Command.setTag " requires an automated opponent." + onCommand (UI.Command.Set setObject) = Control.Exception.catchJust ( + \e -> if Data.Exception.isBadData e + then Just $ show e + else Nothing + ) ( + do + Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." - return {-to IO-monad-} playState - | otherwise = Control.Exception.catchJust ( - \e -> if Data.Exception.isBadData e - then Just $ show e - else Nothing - ) ( - do - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "setting " $ shows setObject "." + case setObject of + UI.SetObject.EPD game' -> do + Control.Monad.when (verbosity == maxBound) . putStrLn $ show2D game' - readMove positionHashQualifiedMoveTree randomGen runningWatch playState { - State.PlayState.getOptions = Control.DeepSeq.force $ case setObject of - UI.SetObject.SearchDepth searchDepth -> options { + readMove positionHashQualifiedMoveTree randomGen runningWatch $ State.PlayState.reconstructPositionHashQuantifiedGameTree game' playState -- Recurse. + UI.SetObject.SearchDepth searchDepth + | fullyManual -> do + System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixWarning $ shows setObject " requires an automated opponent." + + eventLoop + | otherwise -> readMove positionHashQualifiedMoveTree randomGen runningWatch playState { + State.PlayState.getOptions = Control.DeepSeq.force $ options { Input.Options.getSearchOptions = Input.SearchOptions.setSearchDepth searchDepth $ Input.Options.getSearchOptions options } - } -- Recurse. - ) ( - \s -> do - Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowColouredPrefix.showsPrefixError s + } -- Recurse. + ) ( + \s -> do + Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr $ Text.ShowColouredPrefix.showsPrefixError s - eventLoop - ) + eventLoop + ) onCommand UI.Command.Swap | fullyManual = do Control.Monad.when (verbosity >= Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixWarning . showString " there aren't any " $ shows Input.SearchOptions.searchDepthTag " to swap." @@ -299,7 +288,7 @@ return {-to IO-monad-} playState { State.PlayState.getOptions = Input.Options.swapSearchDepth options } - eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + eventLoop :: IO (State.PlayState.PlayState pieceSquareValue positionHash) eventLoop = getLine >>= \line -> case Data.List.Extra.trim line of "?" -> onCommand $ UI.Command.Print UI.PrintObject.Help ':' : s -> ( @@ -370,37 +359,28 @@ ) $ Input.UIOptions.getEitherNativeUIOrCECPOptions uiOptions -- | Plays the game. -takeTurns :: forall pieceSquareValue positionHash randomGen x y. ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, - Data.Array.IArray.Ix x, +takeTurns :: forall pieceSquareValue positionHash randomGen. ( + Control.DeepSeq.NFData pieceSquareValue, #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Ord positionHash, - Read x, - Read y, - Real pieceSquareValue, - Show pieceSquareValue, - Show x, - Show y, - System.Random.RandomGen randomGen + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Ord positionHash, + Real pieceSquareValue, + Show pieceSquareValue, + System.Random.RandomGen randomGen ) - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash -> randomGen - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) {-# SPECIALISE takeTurns :: System.Random.RandomGen randomGen - => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Length.X Type.Length.Y Type.Crypto.PositionHash + => ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash -> randomGen - -> 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) + -> State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash + -> IO (State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) #-} takeTurns positionHashQualifiedMoveTree randomGen playState = let options = State.PlayState.getOptions playState @@ -417,19 +397,23 @@ mVar <- Control.Concurrent.newEmptyMVar let - show2D :: Model.Game.Game x y -> String - show2D = uncurry State.MaybePieceByCoordinates.show2D ( - snd {-columns-} . Input.NativeUIOptions.getBoardMagnification &&& Input.NativeUIOptions.getColourScheme $ nativeUIOptions + show2D :: Model.Game.Game -> String + show2D = State.MaybePieceByCoordinates.show2D ( + snd {-columns-} $ Input.NativeUIOptions.getBoardMagnification nativeUIOptions ) ( + Input.NativeUIOptions.getColourScheme nativeUIOptions + ) ( + Input.NativeUIOptions.getDepictFigurine nativeUIOptions + ) ( Notation.MoveNotation.getOrigin moveNotation ) . State.Board.getMaybePieceByCoordinates . Model.Game.getBoard slave - :: Maybe (Concurrent.Pondering.Pondering (Component.Move.Move x y)) + :: Maybe (Concurrent.Pondering.Pondering Component.Move.Move) -> Maybe Type.Count.NPlies -> [randomGen] - -> State.PlayState.PlayState pieceSquareValue positionHash x y - -> IO (State.PlayState.PlayState pieceSquareValue positionHash x y) + -> State.PlayState.PlayState pieceSquareValue positionHash + -> IO (State.PlayState.PlayState pieceSquareValue positionHash) slave maybePondering maybeMaximumPlies ~(randomGen' : randomGens) playState' = let (game', searchOptions') = State.PlayState.getGame &&& Input.Options.getSearchOptions . State.PlayState.getOptions $ playState' -- Deconstruct. in Data.Maybe.maybe ( @@ -495,7 +479,7 @@ then Property.ShowFloat.showsFloatToN nDecimalDigits ( Control.Monad.Reader.runReader ( Evaluation.Fitness.evaluateFitness Nothing game' - ) $ Input.Options.getEvaluationOptions options :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues + ) $ Input.Options.getEvaluationOptions options ) . Search.Search.showsSeparator -- Prepend the fitness of the original game prior to the new result. else id ) $ if verbosity > Data.Default.def @@ -550,25 +534,16 @@ putStrLn $ show2D selectedGame return {-to IO-monad-} (State.PlayState.updateWithManualMove selectedGame playState', Nothing) -- N.B.: one could ponder, but would have to construct a game-tree, & the chance of a subsequent standard-opening move is high. - ) $ ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' ( - Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions + ) $ uncurry ( + ContextualNotation.PositionHashQualifiedMoveTree.maybeRandomlySelectOnymousQualifiedMove randomGen' + ) ( + Input.StandardOpeningOptions.getPreferVictories &&& Input.StandardOpeningOptions.getMatchSwitches $ Input.SearchOptions.getStandardOpeningOptions searchOptions ) game' positionHashQualifiedMoveTree -- Determine whether the automated player's move can be decided by a search of recorded games or we must decide ourself. ) ( - Model.Game.getNextLogicalColour game' `Data.Map.lookup` Input.SearchOptions.getSearchDepthByLogicalColour searchOptions' -- Determinate whether the next player is manual. + Model.Game.getNextLogicalColour game' `Map.lookup` Input.SearchOptions.getSearchDepthByLogicalColour searchOptions' -- Determinate whether the next player is manual. ) >>= ( \(playState'', maybePondering') -> do - Data.Maybe.maybe ( - return {-to IO-monad-} () - ) ( - \(filePath, automatic) -> let - game'' = State.PlayState.getGame playState'' - in Control.Monad.when automatic . Control.Exception.catch ( - do - System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` game'') - - Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixInfo . showString "the game-state has been saved in " $ shows filePath "." - ) $ \e -> System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.showsPrefixError $ show (e :: Control.Exception.SomeException) - ) $ Input.IOOptions.getMaybePersistence ioOptions + Input.IOOptions.persist ioOptions (verbosity == maxBound) $ State.PlayState.getGame playState'' if State.PlayState.hasApplicationTerminationBeenRequested playState'' then return {-to IO-monad-} playState'' 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 @@ -26,7 +26,9 @@ module Duel.Process.Intermediary ( -- * Types -- ** Type-synonyms +-- MoveNotation, -- IOHandles, +-- MoveSequence, -- GameTerminationReasonsMap, -- * Functions -- runBishBosh, @@ -47,10 +49,12 @@ 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.PGNOptions as Input.PGNOptions 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.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.SelfValidating as Property.SelfValidating import qualified BishBosh.Property.Switchable as Property.Switchable @@ -58,13 +62,14 @@ 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 BishBosh.UI.ReportObject as UI.ReportObject import qualified Control.Exception import qualified Control.Monad import qualified Data.Default -import qualified Data.Map.Strict +import qualified Data.Foldable +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified Duel.Data.Options as Data.Options import qualified Duel.IO.Logger as IO.Logger @@ -85,7 +90,7 @@ import qualified BishBosh.Notation.Smith as Notation.Smith type MoveNotation = Notation.Smith.Smith # else -# error "MOVE_NOTATION ill-defined" +# error "MOVE_NOTATION invalid" # endif #else # error "MOVE_NOTATION undefined" @@ -116,7 +121,7 @@ -> 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 Rule.GameTerminationReason.GameTerminationReason (MoveNotation Type.Length.X Type.Length.Y)) + -> IO (Either Rule.GameTerminationReason.GameTerminationReason MoveNotation) readMove verbosity readTimeout logicalColour stdOut = do Control.Monad.when (verbosity == maxBound) . IO.Logger.printInfo . showString "Waiting " . ( if readTimeout < 0 @@ -132,7 +137,7 @@ case reads line of [(gameTerminationReason, "")] -> do - Control.Monad.when (verbosity > minBound) . IO.Logger.printInfo $ shows gameTerminationReason " => game over." + Control.Monad.when (verbosity /= minBound) . IO.Logger.printInfo $ shows gameTerminationReason " => game over." return {-to IO-monad-} $ Left gameTerminationReason -- Return the result. _ -> case reads line of @@ -161,6 +166,9 @@ -- | Contains /stdin/ & /stdout/ handles respectively. type IOHandles = (System.IO.Handle, System.IO.Handle) +-- | The chronological sequence of moves which occurred in a game. +type MoveSequence = String + -- | Shuttle moves between the two child processes until the game terminates. play :: Property.Switchable.Switchable gameClock @@ -169,7 +177,7 @@ -> IOHandles -> IOHandles -> gameClock - -> IO (Rule.GameTerminationReason.GameTerminationReason, gameClock) + -> IO (MoveSequence, Rule.GameTerminationReason.GameTerminationReason, gameClock) play verbosity readTimeout = slave maxBound where slave logicalColour producer@(_, stdOut) consumer@(stdIn', stdOut') gameClock = copyMove verbosity readTimeout logicalColour stdOut stdIn' >>= Data.Maybe.maybe ( do @@ -182,7 +190,11 @@ \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, gameClock) + System.IO.hPutStrLn stdIn' $ UI.Command.issueCommand (UI.Command.Report UI.ReportObject.Moves) "" -- Request the move-sequence, for comparison with the other games in this trial. + + moveSequence <- System.IO.hGetLine stdOut' -- CAVEAT: no attempt is made to parse the move-sequence. + + return {-to IO-monad-} (moveSequence, 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 "'." ) @@ -195,12 +207,8 @@ Control.Monad.when isReady . Control.Monad.void $ System.IO.hGetLine handle -{- | - * 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.Rule.GameTerminationReason'. --} -type GameTerminationReasonsMap = Data.Map.Strict.Map Rule.GameTerminationReason.GameTerminationReason Type.Count.NGames +-- | Accumulates the frequency-distribution of game-termination reasons. +type GameTerminationReasonsMap = Map.Map Rule.GameTerminationReason.GameTerminationReason Type.Count.NGames {- | * Constructs a game-clock. @@ -214,6 +222,8 @@ * 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. + + * Reports games which are duplicated; transpositions are considered to be different. -} startGame :: Input.Verbosity.Verbosity @@ -224,16 +234,25 @@ -> GameTerminationReasonsMap -> Type.Count.NGames -> IO GameTerminationReasonsMap -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 +startGame verbosity nDecimalDigits readTimeout producer consumer gameTerminationReasonsMap nGames = Property.Switchable.on >>= slave Property.Empty.empty gameTerminationReasonsMap nGames where + accumulateFrequencyDistribution :: (Enum i, Num i, Ord k) => k -> Map.Map k i -> Map.Map k i + accumulateFrequencyDistribution = flip (Map.insertWith $ const succ) 1 + + slave :: Map.Map MoveSequence Type.Count.NGames -> GameTerminationReasonsMap -> Type.Count.NGames -> Time.GameClock.GameClock -> IO GameTerminationReasonsMap + slave moveSequenceMap gameTerminationReasonsMap' 0 gameClock = do Time.GameClock.showsElapsedTimes nDecimalDigits gameClock >>= IO.Logger.printInfo . showString "Elapsed time" . Text.ShowList.showsAssociation . ($ ".") + let duplicatedMovesMap = Map.filter (> 1) moveSequenceMap + + if Data.Foldable.null duplicatedMovesMap + then Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "All games were composed from unique move-sequences." + else Control.Monad.unless (verbosity == minBound) . IO.Logger.printWarning . showString "Duplicated move-sequences:\t" $ shows (Map.toList duplicatedMovesMap) "." + return {-to IO-monad-} gameTerminationReasonsMap' - slave gameTerminationReasonsMap' nGames' gameClock = do + slave moveSequenceMap gameTerminationReasonsMap' nGames' gameClock = do Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Starting game." - (gameTerminationReason, gameClock') <- play verbosity readTimeout producer consumer gameClock + (moveSequence, gameTerminationReason, gameClock') <- play verbosity readTimeout producer consumer gameClock sequence_ $ [ \(_, stdOut) -> do @@ -243,12 +262,14 @@ \(stdIn, _) -> do Control.Monad.when (verbosity == maxBound) $ IO.Logger.printInfo "Requesting restart." - System.IO.hPutStrLn stdIn $ UI.Command.commandPrefix : UI.Command.restartTag + System.IO.hPutStrLn stdIn $ UI.Command.issueCommand UI.Command.Restart "" ] <*> [consumer, producer] slave ( - Data.Map.Strict.insertWith (const succ) gameTerminationReason 1 gameTerminationReasonsMap' + accumulateFrequencyDistribution moveSequence moveSequenceMap ) ( + accumulateFrequencyDistribution gameTerminationReason gameTerminationReasonsMap' + ) ( pred nGames' -- Recurse. ) gameClock' @@ -301,7 +322,7 @@ in Control.Exception.catch ( do Control.Monad.when (Data.Options.getVerifyConfiguration options) $ do - [(logicalColoursFirst, moveNotationFirst), (logicalColoursSecond, moveNotationSecond)] <- mapM ( + [(logicalColoursFirst, moveNotationFirst, unspecifiedPGNOptionsFirst), (logicalColoursSecond, moveNotationSecond, unspecifiedPGNOptionsSecond)] <- mapM ( \configFilePath -> do [pair] <- HXT.runX $ HXT.setTraceLevel hxtTraceLevel >>> HXT.xunpickleDocument HXT.xpickle [ @@ -309,9 +330,13 @@ 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. - ) + \inputOptions -> ( + Input.SearchOptions.identifyAutomatedPlayers $ Input.Options.getSearchOptions ( + inputOptions :: Input.Options.Options Type.Mass.PieceSquareValue -- Arbitrary concrete type. + ), + Input.UIOptions.getMoveNotation . Input.IOOptions.getUIOptions $ Input.Options.getIOOptions inputOptions, + null . Input.IOOptions.getPGNOptionsList $ Input.Options.getIOOptions inputOptions + ) ) -- Lift function into an arrow. return {-to IO-monad-} pair @@ -321,13 +346,15 @@ 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) "." + Control.Monad.when (unspecifiedPGNOptionsFirst && unspecifiedPGNOptionsSecond) . Control.Exception.throwIO . Data.Exception.mkNullDatum . showString "Duel.Process.Intermediary.initialise:\tto introduce randomness, at least one configuration-file must define '" . showString Input.PGNOptions.tag . showChar '.' $ showString Input.PGNOptions.databaseFilePathTag "'." + 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 ( + ) Property.Empty.empty ( Data.Options.getNGames options - ) >>= IO.Logger.printInfo . show . Data.Map.Strict.toList + ) >>= IO.Logger.printInfo . show . Map.toList ) $ \e -> do IO.Logger.printError . showString "caught " $ show (e :: Control.Exception.SomeException) diff --git a/src-exe/Main.hs b/src-exe/Main.hs --- a/src-exe/Main.hs +++ b/src-exe/Main.hs @@ -29,7 +29,6 @@ module Main(main) where ---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((!)) @@ -43,6 +42,7 @@ 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.PieceSquareTable as Input.PieceSquareTable import qualified BishBosh.Input.PGNOptions as Input.PGNOptions import qualified BishBosh.Input.UIOptions as Input.UIOptions import qualified BishBosh.Input.Verbosity as Input.Verbosity @@ -59,7 +59,6 @@ import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix 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 @@ -95,7 +94,7 @@ #endif -- Define concrete types to resolve the underlying polymorphic functions. -type Options = Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y +type Options = Input.Options.Options Type.Mass.PieceSquareValue writeXMLToFile :: HXT.XmlPickler pickleable @@ -277,7 +276,11 @@ ) ["Opening", "End"] ) $ map ( \selector -> Component.PieceSquareByCoordinatesByRank.formatForGNUPlot ( - Property.ShowFloat.showsFloatToN' . 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. + ) . ( + realToFrac :: Type.Mass.PieceSquareValue -> Input.PieceSquareTable.IOFormat -- N.B.: required when compiled with 'USE_PRECISION'. + ) ) ( showChar '\t' -- Column-delimiter. ) ( @@ -381,12 +384,12 @@ System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering -- CAVEAT: required when the output is another process instead of a terminal. - playState <- uncurry (Play.play randomGen) . (,) options' =<< ( -- CAVEAT: artificially construct a pair, to reduce the strictness & thus allow the UI to be rendered while PGN-databases are evaluated in the background. + playState <- uncurry (Play.play verbosity randomGen) . (,) options' =<< ( -- CAVEAT: artificially construct a pair, to reduce the strictness & thus allow the UI to be rendered while PGN-databases are evaluated in the background. \qualifiedMoveForest -> do Control.Monad.when (verbosity == maxBound && not (Property.Null.isNull qualifiedMoveForest)) $ mapM_ ( System.IO.hPutStrLn System.IO.stderr . showsInfoPrefix . ($ ".") ) [ - showString "resulting tree contains (nGames, nMoves)" . Text.ShowList.showsAssociation . shows (ContextualNotation.QualifiedMoveForest.count qualifiedMoveForest), -- CAVEAT: application stalls during this call. + showString "resulting tree contains (nGames, nPositions)" . Text.ShowList.showsAssociation . shows (ContextualNotation.QualifiedMoveForest.count qualifiedMoveForest), -- CAVEAT: application stalls during this call. showString "the minimum number of pieces remaining in any of the archived games" . Text.ShowList.showsAssociation . shows (ContextualNotation.QualifiedMoveForest.findMinimumPieces qualifiedMoveForest) ] @@ -446,7 +449,7 @@ ) Property.Empty.empty {-QualifiedMoveForest-} (Input.IOOptions.getPGNOptionsList ioOptions) let - maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash Type.Length.X Type.Length.Y) + maybeApplicationTerminationReason = State.PlayState.getMaybeApplicationTerminationReason (playState :: State.PlayState.PlayState Type.Mass.PieceSquareValue Type.Crypto.PositionHash) in Control.Monad.when ( verbosity /= minBound && Data.Maybe.isJust maybeApplicationTerminationReason ) . System.IO.hPutStrLn System.IO.stderr . showsInfoPrefix . showString "application terminated " $ shows (Data.Maybe.fromJust maybeApplicationTerminationReason) "." diff --git a/src-lib/BishBosh/Attribute/ANSIColourCode.hs b/src-lib/BishBosh/Attribute/ANSIColourCode.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Attribute/ANSIColourCode.hs @@ -0,0 +1,76 @@ +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines the encoding of colours for rendering on a terminal; . +-} + +module BishBosh.Attribute.ANSIColourCode( +-- * Types +-- ** Type-synonyms +-- ANSIColourCode(), +-- IsBold, + GraphicsRendition, +-- * Functions + selectGraphicsRendition, + bracket, +-- ** Constructors + mkFgColourCode, + mkBgColourCode +) where + +import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour +import qualified Data.Default + +-- | A colour-code as used by terminal-emulators. +newtype ANSIColourCode = MkANSIColourCode { + deconstruct :: Int +} + +instance Show ANSIColourCode where + showsPrec precedence MkANSIColourCode { deconstruct = i } = showsPrec precedence i + +instance Data.Default.Default ANSIColourCode where + def = MkANSIColourCode 0 + +-- | The font-weight of a character. +type IsBold = Bool + +-- | An escape-sequence used to control a terminal. +type GraphicsRendition = String + +-- | Constructor: offset the specified colour-code, so that it applies to the foreground. +mkFgColourCode :: Attribute.PhysicalColour.PhysicalColour -> ANSIColourCode +mkFgColourCode = MkANSIColourCode . (+ 30) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} + +-- | Constructor: offset the specified colour-code, so that it applies to the background. +mkBgColourCode :: Attribute.PhysicalColour.PhysicalColour -> ANSIColourCode +mkBgColourCode = MkANSIColourCode . (+ 40) . fromEnum {-CAVEAT: relies on the PhysicalColour's constructor-order-} + +-- | Generate the escape-sequence required to change a terminal to the specified physical colour. +selectGraphicsRendition :: IsBold -> ANSIColourCode -> GraphicsRendition +selectGraphicsRendition isBold parameter = showString "\x1b[" . shows parameter $ (if isBold then showString ";1" else id) "m" + +-- | Render the specified string according to instructions, then revert to the default. +bracket :: GraphicsRendition -> String -> ShowS +bracket graphicsRendition s = showString graphicsRendition . showString s . showString ( + selectGraphicsRendition False Data.Default.def + ) + diff --git a/src-lib/BishBosh/Attribute/ColourScheme.hs b/src-lib/BishBosh/Attribute/ColourScheme.hs --- a/src-lib/BishBosh/Attribute/ColourScheme.hs +++ b/src-lib/BishBosh/Attribute/ColourScheme.hs @@ -19,7 +19,7 @@ {- | [@AUTHOR@] Dr. Alistair Ward - [@DESCRIPTION@] Defines the physical colour used to represent each component of the display. + [@DESCRIPTION@] Defines the physical colour used to represent each component of the board. -} module BishBosh.Attribute.ColourScheme ( @@ -45,6 +45,7 @@ import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.Arrow import qualified Control.DeepSeq @@ -105,9 +106,9 @@ instance Data.Default.Default ColourScheme where def = MkColourScheme { getDarkPieceColour = Attribute.PhysicalColour.blue, - getLightPieceColour = Attribute.PhysicalColour.yellow, + getLightPieceColour = Property.Opposable.getOpposite $ getDarkPieceColour Data.Default.def, getDarkSquareColour = Attribute.PhysicalColour.black, - getLightSquareColour = Attribute.PhysicalColour.white + getLightSquareColour = Property.Opposable.getOpposite $ getDarkSquareColour Data.Default.def } instance HXT.XmlPickler ColourScheme where 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 @@ -55,7 +55,7 @@ -- range, opposites, -- * Functions --- reverseOrdering, +-- getOpposite, advanceDirection, attackDirectionsForPawn, listArrayByDirection, @@ -118,8 +118,8 @@ -- | Define a /direction/ by the sense of change to /x/ & /y/ coordinates. data Direction = MkDirection { - getXDirection :: Ordering, -- ^ The sense of the change in the /x/-coordinate. - getYDirection :: Ordering -- ^ The sense of the change in the /y/-coordinate. + getXDirection :: ! Ordering, -- ^ The sense of the change in the /x/-coordinate. + getYDirection :: ! Ordering -- ^ The sense of the change in the /y/-coordinate. } deriving (Eq, Ord) instance Bounded Direction where @@ -164,19 +164,13 @@ 'E' : _ -> [(e, tail s')] _ -> [] -- No parse. --- | Get the opposite. -reverseOrdering :: Ordering -> Ordering -reverseOrdering LT = GT -reverseOrdering GT = LT -reverseOrdering _ = EQ - instance Property.Opposable.Opposable Direction where getOpposite MkDirection { getXDirection = xDirection, getYDirection = yDirection } = MkDirection { - getXDirection = reverseOrdering xDirection, - getYDirection = reverseOrdering yDirection + getXDirection = Property.Opposable.getOpposite xDirection, + getYDirection = Property.Opposable.getOpposite yDirection } instance Property.Orientated.Orientated Direction where @@ -186,12 +180,12 @@ instance Property.Reflectable.ReflectableOnX Direction where reflectOnX direction@MkDirection { getYDirection = yDirection } = direction { - getYDirection = reverseOrdering yDirection + getYDirection = Property.Opposable.getOpposite yDirection } instance Property.Reflectable.ReflectableOnY Direction where reflectOnY direction@MkDirection { getXDirection = xDirection } = direction { - getXDirection = reverseOrdering xDirection + getXDirection = Property.Opposable.getOpposite xDirection } instance HXT.XmlPickler Direction where 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 @@ -49,6 +49,7 @@ isCapture, isPromotion, isQuiet, + isSimple, isAcyclic, -- ** Query getMaybeExplicitlyTakenRank, @@ -232,6 +233,14 @@ getMaybePromotionRank = Nothing } = True isQuiet moveType = isCastle moveType + +-- | The simplest type of move. +isSimple :: MoveType -> Bool +isSimple Normal { + getMaybeTakenRank = Nothing, + getMaybePromotionRank = Nothing +} = True +isSimple _ = False -- Neither Castling nor En-passant qualifies. {- | * Whether the /move/ can't be a member of a repeated cycle. diff --git a/src-lib/BishBosh/Attribute/PhysicalColour.hs b/src-lib/BishBosh/Attribute/PhysicalColour.hs --- a/src-lib/BishBosh/Attribute/PhysicalColour.hs +++ b/src-lib/BishBosh/Attribute/PhysicalColour.hs @@ -29,11 +29,10 @@ module BishBosh.Attribute.PhysicalColour( -- * Types --- ** Type-synonyms --- ANSIColourCode, -- ** Data-types - PhysicalColour(..), + PhysicalColour(), -- * Constants +-- range, black, red, green, @@ -41,22 +40,20 @@ blue, magenta, cyan, - white, --- range, --- * Functions --- toANSIColourCode, - mkFgColourCode, - mkBgColourCode, - selectGraphicsRendition, - bracket + white ) where import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable import qualified Control.DeepSeq import qualified Text.XML.HXT.Arrow.Pickle as HXT import qualified Text.XML.HXT.Arrow.Pickle.Schema --- | Defines the sum-type of physical colours which can typically be rendered by a terminal. +{- | + * Defines the sum-type of physical colours which can typically be rendered by a terminal. + + * CAVEAT: the constructor-order both facilitates conversion to an ANSI Colour-code & the derivation of the complementary colour. +-} data PhysicalColour = Black | Red @@ -78,6 +75,9 @@ instance HXT.XmlPickler PhysicalColour where xpickle = HXT.xpWrap (read, show) . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range +instance Property.Opposable.Opposable PhysicalColour where + getOpposite physicalColour = toEnum $ fromEnum (maxBound :: PhysicalColour) - fromEnum physicalColour -- N.B. the complementary colour + -- | The constant complete range of values. range :: [PhysicalColour] range = [minBound .. maxBound] @@ -116,29 +116,4 @@ -- | Constant. white :: PhysicalColour white = White - --- | A colour-code, as used by terminal-emulators; . -type ANSIColourCode = Int - --- | Offset the specified colour-code, so that it applies to the foreground. -mkFgColourCode :: PhysicalColour -> ANSIColourCode -mkFgColourCode = (+ 30) . toANSIColourCode - --- | Offset the specified colour-code, so that it applies to the background. -mkBgColourCode :: PhysicalColour -> ANSIColourCode -mkBgColourCode = (+ 40) . toANSIColourCode - --- | Translate. -toANSIColourCode :: PhysicalColour -> ANSIColourCode -toANSIColourCode = fromEnum -- CAVEAT: the order of the data-constructors has been defined with this in mind. - --- | Generate the escape-sequence required to change a terminal to the specified physical colour. -selectGraphicsRendition :: Bool -> ANSIColourCode -> String -selectGraphicsRendition isBold parameter = showString "\x1b[" . shows parameter $ (if isBold then showString ";1" else id) "m" - --- | Render the specified string according to instructions, then revert to default. -bracket :: String -> String -> ShowS -bracket graphicsRendition s = showString graphicsRendition . showString s . showString ( - selectGraphicsRendition False 0 - ) 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 @@ -49,7 +49,7 @@ earthBound, expendable, nDistinctRanks, --- allocationPerSide, + initialAllocationByRankPerSide, -- * Functions compareByLVA, findUndefinedRanks, @@ -202,9 +202,9 @@ 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] +-- | The constant number of each rank per side, at the conventional opening position. +initialAllocationByRankPerSide :: ArrayByRank Type.Count.NPieces +initialAllocationByRankPerSide = 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/Cartesian/Abscissa.hs b/src-lib/BishBosh/Cartesian/Abscissa.hs --- a/src-lib/BishBosh/Cartesian/Abscissa.hs +++ b/src-lib/BishBosh/Cartesian/Abscissa.hs @@ -29,15 +29,15 @@ -} module BishBosh.Cartesian.Abscissa( --- * Types - ArrayByAbscissa, -- * Constants - xOrigin, xLength, xMin, xMax, xBounds, xRange, + bishopsFiles, + kingsFile, +-- adjacents, -- * Functions toIx, fromIx, @@ -45,68 +45,66 @@ translate, maybeTranslate, getAdjacents, +-- getAdjacents', -- ** Constructors listArrayByAbscissa, -- ** Predicates inBounds ) where -import qualified BishBosh.Data.Enum as Data.Enum +import Data.Array.IArray((!)) import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray --- | The position of the origin on the /x/-axis. -xOrigin :: Int -xOrigin = 0 - -- | The constant length of the /x/-axis. -xLength :: Type.Length.Distance +xLength :: Type.Length.X xLength = 8 --- | The constant lower bound of abscissae. -xMin :: Enum x => x -xMin = toEnum xOrigin - --- | The constant upper bound of abscissae. -xMax :: Enum x => x -xMax = toEnum $ xOrigin + fromIntegral (pred {-fence-post-} xLength) - -- | The constant bounds of abscissae. -xBounds :: Enum x => (x, x) -xBounds = (xMin, xMax) +xBounds :: (Type.Length.X, Type.Length.X) +xMin, xMax :: Type.Length.X +xBounds@(xMin, xMax) = (0, xMin + pred {-fence-post-} xLength) -- | The constant list of all abscissae. -xRange :: Enum x => [x] +xRange :: [Type.Length.X] xRange = uncurry enumFromTo xBounds +-- | The conventional starting /file/s for the @Bishops@ of either /logical colour/. +bishopsFiles :: [Type.Length.X] +bishopsFiles = map fromIx [2, 5] + +-- | The conventional starting /file/ for the @King@ of either /logical colour/. +kingsFile :: Type.Length.X +kingsFile = fromIx 4 + -- | Convert to an array-index. -toIx :: Enum x => x -> Int +toIx :: Type.Length.X -> Int {-# INLINE toIx #-} -toIx = subtract xOrigin . fromEnum +toIx = fromIntegral . subtract xMin -- | Convert from an array-index. -fromIx :: Enum x => Int -> x +fromIx :: Int -> Type.Length.X {-# INLINE fromIx #-} -fromIx = toEnum . (+ xOrigin) +fromIx = (+ xMin) . fromIntegral -- | Reflects about the mid-point of the axis. -reflect :: Enum x => x -> x -reflect = Data.Enum.translate $ ( - + (2 * xOrigin + fromIntegral (pred xLength)) +reflect :: Type.Length.X -> Type.Length.X +reflect = ( + + (2 * xMin + pred xLength) ) . negate -- | Predicate. -inBounds :: (Enum x, Ord x) => x -> Bool +inBounds :: Type.Length.X -> Bool {-# INLINE inBounds #-} inBounds x = x >= xMin && x <= xMax -- | Translate the specified ordinate. -translate :: (Enum x, Ord x) => (x -> x) -> x -> x +translate :: (Type.Length.X -> Type.Length.X) -> Type.Length.X -> Type.Length.X translate transformation = (\x -> Control.Exception.assert (inBounds x) x) . transformation -- | Where legal, translate the specified abscissa. -maybeTranslate :: (Enum x, Ord x) => (x -> x) -> x -> Maybe x +maybeTranslate :: (Type.Length.X -> Type.Length.X) -> Type.Length.X -> Maybe Type.Length.X maybeTranslate transformation = ( \x -> if inBounds x then Just x @@ -114,21 +112,21 @@ ) . transformation -- | Get the abscissae immediately left & right. -getAdjacents :: (Enum x, Eq x) => x -> [x] -{-# INLINE getAdjacents #-} -getAdjacents x +getAdjacents' :: Type.Length.X -> [Type.Length.X] +getAdjacents' x | x == xMin = [succ xMin] | x == xMax = [pred xMax] | otherwise = [pred x, succ x] --- | A boxed array indexed by /coordinates/, of arbitrary elements. -type ArrayByAbscissa x = Data.Array.IArray.Array {-Boxed-} x +-- | The constant abscissae either side of each value. +adjacents :: Data.Array.IArray.Array Type.Length.X [Type.Length.X] +adjacents = listArrayByAbscissa $ map getAdjacents' xRange +-- | Get the abscissae immediately left & right. +getAdjacents :: Type.Length.X -> [Type.Length.X] +getAdjacents = (adjacents !) + -- | Array-constructor. -listArrayByAbscissa :: ( - Data.Array.IArray.IArray a e, - Data.Array.IArray.Ix x, - Enum x - ) => [e] -> a x e +listArrayByAbscissa :: Data.Array.IArray.IArray a e => [e] -> a Type.Length.X e listArrayByAbscissa = Data.Array.IArray.listArray xBounds 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -45,9 +45,7 @@ -- * Functions -- extrapolate', extrapolate, --- extrapolateInt, interpolate, --- interpolateInt, getLogicalColourOfSquare, kingsStartingCoordinates, rooksStartingCoordinates, @@ -79,7 +77,7 @@ areSquaresIsochromatic ) 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 @@ -92,13 +90,15 @@ import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.Property.Rotatable as Property.Rotatable import qualified BishBosh.Text.ShowList as Text.ShowList +import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Array.Unboxed +import qualified Data.Foldable import qualified Data.List -import qualified Data.Map +import qualified Data.Map as Map import qualified Data.Maybe #ifdef USE_PARALLEL @@ -110,39 +110,28 @@ tag = "coordinates" -- | The /coordinates/ of a square on the board. -data Coordinates x y = MkCoordinates { - getX :: x, -- ^ Abscissa. - getY :: y -- ^ Ordinate. +data Coordinates = MkCoordinates { + getX :: ! Type.Length.X, -- ^ Abscissa. + getY :: ! Type.Length.Y -- ^ Ordinate. } deriving Eq -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Coordinates x y) where +instance Control.DeepSeq.NFData Coordinates where rnf MkCoordinates { getX = x, getY = y } = Control.DeepSeq.rnf (x, y) -instance (Show x, Show y) => Show (Coordinates x y) where +instance Show Coordinates where showsPrec precedence MkCoordinates { getX = x, getY = y } = showsPrec precedence (x, y) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Read x, - Read y - ) => Read (Coordinates x y) where +instance Read Coordinates where readsPrec precedence s = [ (coordinates, remainder) | ((x, y), remainder) <- readsPrec precedence s, coordinates <- Data.Maybe.maybeToList $ mkMaybeCoordinates x y ] -- List-comprehension. -instance (Ord x, Ord y) => Ord (Coordinates x y) where - {-# SPECIALISE instance Ord (Coordinates Type.Length.X Type.Length.Y) #-} +instance Ord Coordinates where MkCoordinates { getX = x, getY = y } `compare` MkCoordinates { getX = x', getY = y' } = (y, x) `compare` (y', x') -- N.B.: x is less significant than y, as required by the implementation of 'Data.Array.IArray.Ix.inRange'. -instance (Enum x, Enum y) => Bounded (Coordinates x y) where +instance Bounded Coordinates where minBound = MkCoordinates { getX = Cartesian.Abscissa.xMin, getY = Cartesian.Ordinate.yMin @@ -152,48 +141,41 @@ getY = Cartesian.Ordinate.yMax } -- Top Right. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Data.Array.IArray.Ix (Coordinates x y) where - {-# SPECIALISE instance Data.Array.IArray.Ix (Coordinates Type.Length.X Type.Length.Y) #-} +instance Data.Array.IArray.Ix Coordinates where range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) Property.FixedMembership.members inRange (lower, upper) coordinates = Control.Exception.assert (coordinates >= lower && coordinates <= upper) True index (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) . toIx -instance Enum y => Property.Reflectable.ReflectableOnX (Coordinates x y) where +instance Property.Reflectable.ReflectableOnX Coordinates where reflectOnX coordinates@MkCoordinates { getY = y } = coordinates { getY = Cartesian.Ordinate.reflect y } -instance Enum x => Property.Reflectable.ReflectableOnY (Coordinates x y) where +instance Property.Reflectable.ReflectableOnY Coordinates where reflectOnY coordinates@MkCoordinates { getX = x } = coordinates { getX = Cartesian.Abscissa.reflect x } -instance (Enum x, Enum y) => Property.Rotatable.Rotatable (Coordinates x y) where +instance Property.Rotatable.Rotatable Coordinates where rotate90 = rotate Attribute.Direction.w rotate180 = rotate Attribute.Direction.s rotate270 = rotate Attribute.Direction.e -- | Constant. -topLeft :: (Enum x, Enum y) => Coordinates x y +topLeft :: Coordinates topLeft = MkCoordinates { getX = Cartesian.Abscissa.xMin, getY = Cartesian.Ordinate.yMax } -- | Constant. -bottomRight :: (Enum x, Enum y) => Coordinates x y +bottomRight :: Coordinates bottomRight = MkCoordinates { getX = Cartesian.Abscissa.xMax, getY = Cartesian.Ordinate.yMin } -- | The constant number of squares on the board. -nSquares :: Int -nSquares = fromIntegral $ Cartesian.Abscissa.xLength * Cartesian.Ordinate.yLength +nSquares :: Type.Count.NCoordinates +nSquares = fromIntegral Cartesian.Abscissa.xLength * fromIntegral Cartesian.Ordinate.yLength -instance (Enum x, Enum y) => Property.FixedMembership.FixedMembership (Coordinates x y) where - {-# SPECIALISE instance Property.FixedMembership.FixedMembership (Coordinates Type.Length.X Type.Length.Y) #-} +instance Property.FixedMembership.FixedMembership Coordinates where members = [ MkCoordinates { getX = x, @@ -204,47 +186,30 @@ ] -- List-comprehension. -- | Predicate. -inBounds :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => x -- ^ Abscissa. - -> y -- ^ Ordinate. +inBounds + :: Type.Length.X -- ^ Abscissa. + -> Type.Length.Y -- ^ Ordinate. -> Bool -{-# INLINABLE inBounds #-} inBounds x y = Cartesian.Abscissa.inBounds x && Cartesian.Ordinate.inBounds y -- | Constructor. -mkCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => x -- ^ Abscissa. - -> y -- ^ Ordinate. - -> Coordinates x y +mkCoordinates + :: Type.Length.X -- ^ Abscissa. + -> Type.Length.Y -- ^ Ordinate. + -> Coordinates mkCoordinates x y = Control.Exception.assert (inBounds x y) $ MkCoordinates x y -- | Safe constructor. -mkMaybeCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => x -- ^ Abscissa. - -> y -- ^ Ordinate. - -> Maybe (Coordinates x y) +mkMaybeCoordinates + :: Type.Length.X -- ^ Abscissa. + -> Type.Length.Y -- ^ Ordinate. + -> Maybe Coordinates mkMaybeCoordinates x y | inBounds x y = Just MkCoordinates { getX = x, getY = y } | otherwise = Nothing -- | Convert to an array-index. -toIx :: (Enum x, Enum y) => Coordinates x y -> Int -{-# SPECIALISE toIx :: Coordinates Type.Length.X Type.Length.Y -> Int #-} +toIx :: Coordinates -> Int toIx MkCoordinates { getX = x, getY = y @@ -255,7 +220,7 @@ * CAVEAT: assumes that the array is indexed by the whole range of /coordinates/. -} -fromIx :: (Enum x, Enum y) => Int -> Coordinates x y +fromIx :: Int -> Coordinates fromIx = ( \(y, x) -> MkCoordinates { getX = Cartesian.Abscissa.fromIx x, @@ -268,28 +233,14 @@ * CAVEAT: the caller must ensure that the results are legal. -} -translate :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => ((x, y) -> (x, y)) -> Coordinates x y -> Coordinates x y +translate :: ((Type.Length.X, Type.Length.Y) -> (Type.Length.X, Type.Length.Y)) -> Coordinates -> Coordinates translate transformation MkCoordinates { getX = x, getY = y } = uncurry mkCoordinates $ transformation (x, y) -- | Where legal, translate the specified /coordinates/. -maybeTranslate :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => ((x, y) -> (x, y)) -- ^ Translation. - -> Coordinates x y - -> Maybe (Coordinates x y) -{-# INLINABLE maybeTranslate #-} +maybeTranslate :: ((Type.Length.X, Type.Length.Y) -> (Type.Length.X, Type.Length.Y)) -> Coordinates -> Maybe Coordinates maybeTranslate transformation MkCoordinates { getX = x, getY = y @@ -300,15 +251,14 @@ * CAVEAT: the caller must ensure that the results are legal. -} -translateX :: (Enum x, Ord x) => (x -> x) -> Transformation x y +translateX :: (Type.Length.X -> Type.Length.X) -> Transformation translateX transformation coordinates@MkCoordinates { getX = x } = coordinates { getX = Cartesian.Abscissa.translate transformation x } -- | Where legal, translate the /x/-component of the specified /coordinates/. maybeTranslateX - :: (Enum x, Ord x) - => (x -> x) -- ^ Translation. - -> Coordinates x y - -> Maybe (Coordinates x y) + :: (Type.Length.X -> Type.Length.X) -- ^ Translation. + -> Coordinates + -> Maybe Coordinates maybeTranslateX transformation coordinates@MkCoordinates { getX = x } = (\x' -> coordinates { getX = x' }) `fmap` Cartesian.Abscissa.maybeTranslate transformation x {- | @@ -316,15 +266,14 @@ * CAVEAT: the caller must ensure that the results are legal. -} -translateY :: (Enum y, Ord y) => (y -> y) -> Transformation x y +translateY :: (Type.Length.Y -> Type.Length.Y) -> Transformation translateY transformation coordinates@MkCoordinates { getY = y } = coordinates { getY = Cartesian.Ordinate.translate transformation y } -- | Where legal, translate the /y/-component of the specified /coordinates/. maybeTranslateY - :: (Enum y, Ord y) - => (y -> y) -- ^ Translation. - -> Coordinates x y - -> Maybe (Coordinates x y) + :: (Type.Length.Y -> Type.Length.Y) -- ^ Translation. + -> Coordinates + -> Maybe Coordinates maybeTranslateY transformation coordinates@MkCoordinates { getY = y } = (\y' -> coordinates { getY = y' }) `fmap` Cartesian.Ordinate.maybeTranslate transformation y {- | @@ -332,14 +281,7 @@ * CAVEAT: the caller must ensure that the results are legal. -} -mkRelativeCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => ((x, y) -> (x, y)) -- ^ Translation. - -> Coordinates x y +mkRelativeCoordinates :: ((Type.Length.X, Type.Length.Y) -> (Type.Length.X, Type.Length.Y)) -> Coordinates mkRelativeCoordinates = (`translate` minBound) {- | @@ -348,20 +290,17 @@ * CAVEAT: the caller must ensure that the results are legal. -} advance - :: (Enum y, Ord y) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. - -> Transformation x y -{-# INLINE advance #-} + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. + -> Transformation advance logicalColour = translateY $ if Attribute.LogicalColour.isBlack logicalColour then pred else succ -- | Where legal, move one step towards the opponent. maybeAdvance - :: (Enum y, Ord y) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. - -> Coordinates x y -- ^ The location from which to advanced. - -> Maybe (Coordinates x y) + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to advance. + -> Coordinates -- ^ The location from which to advanced. + -> Maybe Coordinates maybeAdvance logicalColour = maybeTranslateY $ if Attribute.LogicalColour.isBlack logicalColour then pred else succ @@ -372,29 +311,26 @@ * CAVEAT: the caller must ensure that the results are legal. -} retreat - :: (Enum y, Ord y) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. - -> Transformation x y + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. + -> Transformation retreat = advance . Property.Opposable.getOpposite -- | Where legal, move one step away from the opponent. maybeRetreat - :: (Enum y, Ord y) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. - -> Coordinates x y -- ^ The location from which to retreat. - -> Maybe (Coordinates x y) + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/ which is to retreat. + -> Coordinates -- ^ The location from which to retreat. + -> Maybe Coordinates maybeRetreat = maybeAdvance . Property.Opposable.getOpposite -- | Get the /coordinates/ immediately left & right. -getAdjacents :: (Enum x, Eq x) => Coordinates x y -> [Coordinates x y] +getAdjacents :: Coordinates -> [Coordinates] getAdjacents coordinates@MkCoordinates { getX = x } = map (\x' -> coordinates { getX = x' }) $ Cartesian.Abscissa.getAdjacents x -- | Generates a line of /coordinates/, starting just after the specified source & proceeding in the specified /direction/ to the edge of the board. extrapolate' - :: (Enum x, Enum y) - => Attribute.Direction.Direction -- ^ The direction in which to proceed. - -> Coordinates x y -- ^ The point from which to start. - -> [Coordinates x y] + :: Attribute.Direction.Direction -- ^ The direction in which to proceed. + -> Coordinates -- ^ The point from which to start. + -> [Coordinates] extrapolate' direction MkCoordinates { getX = x, getY = y @@ -417,30 +353,13 @@ In consequence, it is typically automatically avoided using a rewrite-rule to lookup an array of the results from all possible calls. -} extrapolate - :: (Enum x, Enum y) - => Attribute.Direction.Direction -- ^ The direction in which to proceed. - -> Coordinates x y -- ^ The point from which to start. - -> [Coordinates x y] -{-# NOINLINE extrapolate #-} -- Ensure the rewrite-rule triggers. -{-# RULES "extrapolate/Int" extrapolate = extrapolateInt #-} -- CAVEAT: the call-stack leading here must be specialised to ensure this rule triggers. -extrapolate = extrapolate' - --- | A specialisation of 'extrapolate'. -extrapolateInt :: Attribute.Direction.Direction -> Coordinates Type.Length.X Type.Length.Y -> [Coordinates Type.Length.X Type.Length.Y] -extrapolateInt direction coordinates = extrapolationsByDirectionByCoordinates ! coordinates ! direction + :: Attribute.Direction.Direction -- ^ The direction in which to proceed. + -> Coordinates -- ^ The point from which to start. + -> [Coordinates] +extrapolate direction coordinates = extrapolationsByDirectionByCoordinates ! coordinates ! direction -- | The constant lists of /coordinates/, extrapolated from every /coordinate/ in the /board/, in every /direction/. -extrapolationsByDirectionByCoordinates :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Enum x, - Enum y, - Ord x, - Ord y - ) => ArrayByCoordinates x y (Attribute.Direction.ArrayByDirection [Coordinates x y]) -{-# SPECIALISE extrapolationsByDirectionByCoordinates :: ArrayByCoordinates Type.Length.X Type.Length.Y (Attribute.Direction.ArrayByDirection [Coordinates Type.Length.X Type.Length.Y]) #-} -- To promote memoisation. +extrapolationsByDirectionByCoordinates :: ArrayByCoordinates (Attribute.Direction.ArrayByDirection [Coordinates]) extrapolationsByDirectionByCoordinates = listArrayByCoordinates #ifdef USE_PARALLEL . Control.Parallel.Strategies.withStrategy (Control.Parallel.Strategies.parList Control.Parallel.Strategies.rdeepseq) @@ -450,23 +369,13 @@ ) Property.FixedMembership.members -- | The list of /coordinates/, between every permutation of source & valid destination on the /board/. -interpolationsByDestinationBySource :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Enum x, - Enum y, - Ord x, - Ord y - ) => ArrayByCoordinates x y (Data.Map.Map (Coordinates x y) [Coordinates x y]) -{-# 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 :: ArrayByCoordinates (Map.Map Coordinates [Coordinates]) interpolationsByDestinationBySource = Data.Array.IArray.amap ( - Data.Map.fromList . map ( + Map.fromList . map ( last {-destination-} &&& id {-interpolation-} ) . concatMap ( tail {-remove null list-} . Data.List.inits -- Generate all possible interpolations from this extrapolation. - ) . Data.Array.IArray.elems + ) . Data.Foldable.toList ) extrapolationsByDirectionByCoordinates -- Derive from extrapolations. {- | @@ -474,77 +383,41 @@ * CAVEAT: the destination-/coordinates/ must be a valid @Queen@'s /move/ from the source; so that all intermediate points lie on a square of the board. -} -interpolate :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Coordinates x y -- ^ Source. - -> Coordinates x y -- ^ Destination. - -> [Coordinates x y] -{-# NOINLINE interpolate #-} -- Ensure the rewrite-rule triggers. -{-# RULES "interpolate/Int" interpolate = interpolateInt #-} -- CAVEAT: the call-stack leading here must be specialised to ensure this rule triggers. -interpolate source@MkCoordinates { - getX = x, - getY = y -} destination@MkCoordinates { - getX = x', - getY = y' -} - | source == destination = [] -- CAVEAT: an invalid move. - | otherwise = Control.Exception.assert ( - x == x' || y == y' || ( - let - distanceX, distanceY :: Type.Length.Distance - (distanceX, distanceY) = measureDistance source destination - in abs distanceX == abs distanceY - ) -- Check that the move is straight. - ) $ zipWith MkCoordinates (x `spanInterval` x') (y `spanInterval` y') - where - spanInterval :: (Enum a, Ord a) => a -> a -> [a] - spanInterval fromAfter to = case to `compare` fromAfter of - GT -> [succ fromAfter .. to] - LT -> let startFromAfter = pred fromAfter in startFromAfter `seq` [startFromAfter, pred startFromAfter .. to] - EQ -> repeat fromAfter - --- | A specialisation of 'interpolate'. -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 +interpolate :: Coordinates -> Coordinates -> [Coordinates] +interpolate coordinatesSource coordinatesDestination = interpolationsByDestinationBySource ! coordinatesSource Map.! coordinatesDestination -- | The type of a function which changes one set of /coordinates/ to another. -type Transformation x y = Coordinates x y -> Coordinates x y +type Transformation = Coordinates -> Coordinates {- | * Rotates the specified /coordinates/, so that the @Black@ pieces start on the specified side of the board; a /direction/ of @N@ involves no change. * CAVEAT: one can only request an integral multiple of 90 degrees. -} -rotate :: (Enum x, Enum y) => Attribute.Direction.Direction -> Transformation x y +rotate :: Attribute.Direction.Direction -> Transformation rotate direction coordinates@MkCoordinates { getX = x, getY = y } = case Attribute.Direction.getXDirection &&& Attribute.Direction.getYDirection $ direction of (EQ, GT) -> coordinates (LT, EQ) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx $ fromIntegral yDistance', - getY = Cartesian.Ordinate.fromIx $ fromIntegral xDistance + getX = Cartesian.Abscissa.fromIx yDistance', + getY = Cartesian.Ordinate.fromIx xDistance } -- +90 degrees, i.e. anti-clockwise. (EQ, LT) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx $ fromIntegral xDistance', - getY = Cartesian.Ordinate.fromIx $ fromIntegral yDistance' + getX = Cartesian.Abscissa.fromIx xDistance', + getY = Cartesian.Ordinate.fromIx yDistance' } -- 180 degrees. (GT, EQ) -> MkCoordinates { - getX = Cartesian.Abscissa.fromIx $ fromIntegral yDistance, - getY = Cartesian.Ordinate.fromIx $ fromIntegral xDistance' + getX = Cartesian.Abscissa.fromIx yDistance, + getY = Cartesian.Ordinate.fromIx xDistance' } -- -90 degrees, i.e. clockwise. _ -> Control.Exception.throw . Data.Exception.mkRequestFailure . showString "BishBosh.Cartesian.Coordinates.rotate:\tunable to rotate to direction" . Text.ShowList.showsAssociation $ shows direction "." where - xDistance, xDistance', yDistance, yDistance' :: Type.Length.Distance - xDistance = fromIntegral $ Cartesian.Abscissa.toIx x - yDistance = fromIntegral $ Cartesian.Ordinate.toIx y - xDistance' = pred Cartesian.Abscissa.xLength - xDistance - yDistance' = pred Cartesian.Ordinate.yLength - yDistance + xDistance = Cartesian.Abscissa.toIx x + yDistance = Cartesian.Ordinate.toIx y + xDistance' = fromIntegral (pred Cartesian.Abscissa.xLength) - xDistance + yDistance' = fromIntegral (pred Cartesian.Ordinate.yLength) - yDistance {- | * Measures the signed distance between source & destination /coordinates/. @@ -553,88 +426,61 @@ * CAVEAT: beware the potential fence-post error. -} -measureDistance :: ( - Enum x, - Enum y, - Num distance - ) - => Coordinates x y -- ^ Source. - -> Coordinates x y -- ^ Destination. - -> (distance, distance) -- ^ (X-distance, Y-distance) -{-# INLINE measureDistance #-} +measureDistance + :: Coordinates -- ^ Source. + -> Coordinates -- ^ Destination. + -> (Type.Length.X, Type.Length.Y) measureDistance MkCoordinates { getX = x, getY = y } MkCoordinates { getX = x', getY = y' -} = (fromIntegral $ fromEnum x' - fromEnum x, fromIntegral $ fromEnum y' - fromEnum y) +} = (x' - x, y' - y) -- | The /logical colour/ of the specified square. -getLogicalColourOfSquare :: (Enum x, Enum y) => Coordinates x y -> Attribute.LogicalColourOfSquare.LogicalColourOfSquare +getLogicalColourOfSquare :: Coordinates -> Attribute.LogicalColourOfSquare.LogicalColourOfSquare getLogicalColourOfSquare coordinates - | even $ uncurry (+) distance = Attribute.LogicalColourOfSquare.black - | otherwise = Attribute.LogicalColourOfSquare.white - where - distance :: (Type.Length.Distance, Type.Length.Distance) - distance = measureDistance minBound coordinates + | uncurry (==) . ( + even *** even + ) $ measureDistance minBound coordinates = Attribute.LogicalColourOfSquare.black + | otherwise = Attribute.LogicalColourOfSquare.white -- | Whether the specified squares have the same /logical colour/. -areSquaresIsochromatic :: (Enum x, Enum y) => [Coordinates x y] -> Bool +areSquaresIsochromatic :: [Coordinates] -> Bool areSquaresIsochromatic = uncurry (||) . (all (== minBound) &&& all (== maxBound)) . map getLogicalColourOfSquare -- | The conventional starting /coordinates/ for the @King@ of the specified /logical colour/. -kingsStartingCoordinates :: (Enum x, Enum y) => Attribute.LogicalColour.LogicalColour -> Coordinates x y +kingsStartingCoordinates :: Attribute.LogicalColour.LogicalColour -> Coordinates kingsStartingCoordinates logicalColour = MkCoordinates { - getX = Cartesian.Abscissa.fromIx 4, + getX = Cartesian.Abscissa.kingsFile, getY = Cartesian.Ordinate.firstRank logicalColour } -- | The conventional starting /coordinates/ for each @Rook@. -rooksStartingCoordinates :: (Enum x, Enum y) => Attribute.LogicalColour.LogicalColour -> [Coordinates x y] +rooksStartingCoordinates :: Attribute.LogicalColour.LogicalColour -> [Coordinates] rooksStartingCoordinates Attribute.LogicalColour.Black = [topLeft, maxBound] rooksStartingCoordinates _ = [minBound, bottomRight] -- | Whether the specified /coordinates/ are where a @Pawn@ of the specified /logical colour/ starts. -isPawnsFirstRank - :: (Enum y, Eq y) - => Attribute.LogicalColour.LogicalColour - -> Coordinates x y - -> Bool -{-# INLINE isPawnsFirstRank #-} +isPawnsFirstRank :: Attribute.LogicalColour.LogicalColour -> Coordinates -> Bool isPawnsFirstRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.pawnsFirstRank logicalColour -- | Whether a @Pawn@ is currently on the appropriate /rank/ to take an opponent's @Pawn@ /en-passant/. -isEnPassantRank - :: (Enum y, Eq y) - => Attribute.LogicalColour.LogicalColour - -> Coordinates x y - -> Bool +isEnPassantRank :: Attribute.LogicalColour.LogicalColour -> Coordinates -> Bool isEnPassantRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.enPassantRank logicalColour -- | A boxed array indexed by /coordinates/, of arbitrary elements. -type ArrayByCoordinates x y = Data.Array.IArray.Array (Coordinates x y) +type ArrayByCoordinates = Data.Array.IArray.Array Coordinates -- | An unboxed array indexed by /coordinates/, of fixed-size elements. -type UArrayByCoordinates x y = Data.Array.Unboxed.UArray (Coordinates x y) +type UArrayByCoordinates = Data.Array.Unboxed.UArray Coordinates -- | Array-constructor from an ordered list of elements. -listArrayByCoordinates :: ( - Data.Array.IArray.IArray a e, - Enum x, - Enum y, - Ord x, - Ord y - ) => [e] -> a (Coordinates x y) e +listArrayByCoordinates :: Data.Array.IArray.IArray a e => [e] -> a Coordinates e listArrayByCoordinates = Data.Array.IArray.listArray (minBound, maxBound) -- | Array-constructor from an association-list. -arrayByCoordinates :: ( - Data.Array.IArray.IArray a e, - Enum x, - Enum y, - Ord x, - Ord y - ) => [(Coordinates x y, e)] -> a (Coordinates x y) e +arrayByCoordinates :: Data.Array.IArray.IArray a e => [(Coordinates, e)] -> a Coordinates e arrayByCoordinates = Data.Array.IArray.array (minBound, maxBound) 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 @@ -29,10 +29,7 @@ -} module BishBosh.Cartesian.Ordinate( --- * Types --- ArrayByOrdinate, -- * Constants - yOrigin, yLength, yMin, yMax, @@ -48,107 +45,80 @@ reflect, translate, maybeTranslate, --- ** Constructors --- listArrayByOrdinate, -- ** Predicates inBounds ) where import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour 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.Type.Length as Type.Length import qualified Control.Exception -import qualified Data.Array.IArray --- | The position of the origin on the /y/-axis. -yOrigin :: Int -yOrigin = Cartesian.Abscissa.xOrigin -- N.B. it doesn't need to be the same. - -- | The constant length of the /y/-axis. -yLength :: Type.Length.Distance -yLength = Cartesian.Abscissa.xLength -- Because the board is square. - --- | The constant lower bound of ordinates. -yMin :: Enum y => y -yMin = toEnum yOrigin - --- | The constant upper bound of ordinates. -yMax :: Enum y => y -yMax = toEnum $ yOrigin + fromIntegral (pred {-fence-post-} yLength) +yLength :: Type.Length.Y +yLength = fromIntegral Cartesian.Abscissa.xLength -- I.E.: the board is square. -- | The constant bounds of ordinates. -yBounds :: Enum y => (y, y) -yBounds = (yMin, yMax) +yBounds :: (Type.Length.Y, Type.Length.Y) +yMin, yMax :: Type.Length.Y +yBounds@(yMin, yMax) = (0, yMin + pred {-fence-post-} yLength) -- | The constant list of all ordinates. -yRange :: Enum y => [y] +yRange :: [Type.Length.Y] yRange = uncurry enumFromTo yBounds -- | Convert to an array-index. -toIx :: Enum y => y -> Int +toIx :: Type.Length.Y -> Int {-# INLINE toIx #-} -toIx = subtract yOrigin . fromEnum +toIx = fromIntegral . subtract yMin -- | Convert from an array-index. -fromIx :: Enum y => Int -> y +fromIx :: Int -> Type.Length.Y {-# INLINE fromIx #-} -fromIx = toEnum . (+ yOrigin) +fromIx = (+ yMin) . fromIntegral -- | The /rank/ from which /piece/s conventionally start. -firstRank :: Enum y => Attribute.LogicalColour.LogicalColour -> y +firstRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y firstRank Attribute.LogicalColour.Black = yMax firstRank _ = yMin -- | The final /rank/; i.e. the one on which a @Pawn@ is promoted. -lastRank :: Enum y => Attribute.LogicalColour.LogicalColour -> y +lastRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y lastRank = firstRank . Property.Opposable.getOpposite -- | The /rank/ from which @Pawn@s conventionally start. -pawnsFirstRank :: Enum y => Attribute.LogicalColour.LogicalColour -> y +pawnsFirstRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y {-# INLINE pawnsFirstRank #-} pawnsFirstRank Attribute.LogicalColour.Black = pred yMax pawnsFirstRank _ = succ yMin -- | The /rank/ from which a @Pawn@ may capture /en-passant/. -enPassantRank :: Enum y => Attribute.LogicalColour.LogicalColour -> y +enPassantRank :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y {-# INLINE enPassantRank #-} -enPassantRank Attribute.LogicalColour.Black = toEnum $ yOrigin + 3 -enPassantRank _ = toEnum $ yOrigin + 4 +enPassantRank Attribute.LogicalColour.Black = fromIx 3 +enPassantRank _ = fromIx 4 -- | Reflects about the mid-point of the axis. -reflect :: Enum y => y -> y -reflect = Data.Enum.translate $ ( - + (2 * yOrigin + fromIntegral (pred yLength)) +reflect :: Type.Length.Y -> Type.Length.Y +reflect = ( + + (2 * yMin + pred yLength) ) . negate -- | Predicate. -inBounds :: (Enum y, Ord y) => y -> Bool +inBounds :: Type.Length.Y -> Bool {-# INLINE inBounds #-} inBounds y = y >= yMin && y <= yMax -- | Translate the specified ordinate. -translate :: (Enum y, Ord y) => (y -> y) -> y -> y +translate :: (Type.Length.Y -> Type.Length.Y) -> Type.Length.Y -> Type.Length.Y translate transformation = (\y -> Control.Exception.assert (inBounds y) y) . transformation -- | Where legal, translate the specified ordinate. -maybeTranslate :: (Enum y, Ord y) => (y -> y) -> y -> Maybe y +maybeTranslate :: (Type.Length.Y -> Type.Length.Y) -> Type.Length.Y -> Maybe Type.Length.Y maybeTranslate transformation = ( \y -> if inBounds y then Just y else Nothing ) . transformation - - --- | A boxed array indexed by /coordinates/, of arbitrary elements. -type ArrayByOrdinate y = Data.Array.IArray.Array {-Boxed-} y - --- | Array-constructor. -listArrayByOrdinate :: ( - Data.Array.IArray.IArray a e, - Data.Array.IArray.Ix y, - Enum y - ) => [e] -> a y e -listArrayByOrdinate = Data.Array.IArray.listArray yBounds 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 @@ -19,13 +19,10 @@ {- | [@AUTHOR@] Dr. Alistair Ward - [@DESCRIPTION@] Describes a line's magnitude & direction, irrespective of its position. + [@DESCRIPTION@] Describes a line's magnitude & direction, irrespective of its position; cf. 'Component.Move.Move'. -} module BishBosh.Cartesian.Vector( --- * Types --- ** Type-synonyms - VectorInt, -- ** Data-types Vector( -- MkVector, @@ -41,7 +38,6 @@ maybeTranslate, toMaybeDirection, -- ** Constructor - mkVector, measureDistance, -- ** Predicates -- hasDistance, @@ -54,129 +50,127 @@ matchesPawnDoubleAdvance ) where -import Control.Arrow((***)) +import Control.Arrow((&&&), (***)) import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -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.Type.Length as Type.Length import qualified Control.DeepSeq -import qualified Control.Exception -- | The distance between two /coordinates/. -data Vector distance = MkVector { - getXDistance :: !distance, - getYDistance :: !distance +data Vector = MkVector { + getXDistance :: ! Type.Length.X, + getYDistance :: ! Type.Length.Y } deriving (Eq, Show) -instance Num distance => Property.Opposable.Opposable (Vector distance) where - getOpposite (MkVector xDistance yDistance) = MkVector (negate xDistance) (negate yDistance) +instance Control.DeepSeq.NFData Vector where + rnf MkVector { + getXDistance = xDistance, + getYDistance = yDistance + } = Control.DeepSeq.rnf (xDistance, yDistance) --- | Whether the vector has a non-zero length (or a well-defined direction). -hasDistance :: (Eq distance, Num distance) => distance -> distance -> Bool -hasDistance xDistance yDistance = xDistance /= 0 || yDistance /= 0 +instance Property.Opposable.Opposable Vector where + getOpposite MkVector { + getXDistance = xDistance, + getYDistance = yDistance + } = MkVector (negate xDistance) (negate yDistance) --- | Smart constructor. -mkVector :: (Num distance, Ord distance) => distance -> distance -> Vector distance -{-# INLINE mkVector #-} -mkVector xDistance yDistance = Control.Exception.assert ( - hasDistance xDistance yDistance && abs xDistance < fromIntegral Cartesian.Abscissa.xLength && abs yDistance < fromIntegral Cartesian.Ordinate.yLength - ) $ MkVector xDistance yDistance +instance Property.Orientated.Orientated Vector where + isDiagonal = isDiagonal + isParallel = isParallel +-- | Whether the vector has a non-zero length (or a well-defined direction). +hasDistance :: Type.Length.X -> Type.Length.Y -> Bool +hasDistance 0 0 = False +hasDistance _ _ = True + -- | Construct a /vector/ by measuring the signed distance between source-/coordinates/ & destination. -measureDistance :: ( - Enum x, - Enum y, - Num distance, - Ord distance - ) - => Cartesian.Coordinates.Coordinates x y -- ^ Source. - -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. - -> Vector distance -{-# INLINE measureDistance #-} -measureDistance source destination = uncurry mkVector $ Cartesian.Coordinates.measureDistance source destination +measureDistance + :: Cartesian.Coordinates.Coordinates -- ^ Source. + -> Cartesian.Coordinates.Coordinates -- ^ Destination. + -> Vector +measureDistance source destination = uncurry MkVector $ Cartesian.Coordinates.measureDistance source destination -- | Whether the specified /vector/ is at 45 degrees to an edge of the board, i.e. any move a @Bishop@ could make. -isDiagonal :: (Eq distance, Num distance) => Vector distance -> Bool -{-# INLINE isDiagonal #-} -- N.B.: highly effective. -isDiagonal (MkVector xDistance yDistance) = abs xDistance == abs yDistance +isDiagonal :: Vector -> Bool +{-# INLINE isDiagonal #-} +isDiagonal MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = fromEnum (abs xDistance) == fromEnum (abs yDistance) -- | Whether the specified /vector/ is parallel to an edge of the board, i.e. any move a @Rook@ could make. -isParallel :: (Eq distance, Num distance) => Vector distance -> Bool +isParallel :: Vector -> Bool {-# INLINE isParallel #-} -isParallel (MkVector xDistance yDistance) = xDistance == 0 || yDistance == 0 +isParallel MkVector { getXDistance = 0 } = True +isParallel MkVector { getYDistance = 0 } = True +isParallel _ = False -- | Whether the specified /vector/ is either parallel or at 45 degrees to an edge of the board, i.e. any move a @Queen@ could make. -isStraight :: (Eq distance, Num distance) => Vector distance -> Bool -{-# INLINE isStraight #-} -isStraight vector = isParallel vector || isDiagonal vector - --- | A suitable concrete type. -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) - -instance (Eq distance, Num distance) => Property.Orientated.Orientated (Vector distance) where - {-# SPECIALISE instance Property.Orientated.Orientated VectorInt #-} - isDiagonal = isDiagonal - isParallel = isParallel +isStraight :: Vector -> Bool +isStraight = uncurry (||) . (isParallel &&& isDiagonal) {- | * The list of attack-vectors for a @Pawn@. * N.B.: the @Pawn@'s ability to advance without taking, isn't dealt with here. -} -attackVectorsForPawn :: Num distance => Attribute.LogicalColour.LogicalColour -> [Vector distance] +attackVectorsForPawn :: Attribute.LogicalColour.LogicalColour -> [Vector] attackVectorsForPawn logicalColour = [ - MkVector x $ ( - if Attribute.LogicalColour.isBlack logicalColour - then negate -- Black moves down. - else id -- White moves up. - ) 1 | x <- [negate 1, 1] + MkVector { + getXDistance = x, + getYDistance = ( + if Attribute.LogicalColour.isBlack logicalColour + then negate -- Black moves down. + else id -- White moves up. + ) 1 + } | x <- [negate 1, 1] ] -- List-comprehension. -- | The constant list of attack-vectors for a @Knight@. -attackVectorsForKnight :: Num distance => [Vector distance] +attackVectorsForKnight :: [Vector] attackVectorsForKnight = [ - MkVector (fX xDistance) (fY $ 3 - xDistance) | - fX <- negateOrNot, - fY <- negateOrNot, + MkVector { + getXDistance = fX xDistance, + getYDistance = fY $ 3 - fromIntegral xDistance + } | + fX <- [negate, id], + fY <- [negate, id], xDistance <- [1, 2] - ] where - negateOrNot = [negate, id] + ] -- | The constant list of attack-vectors for a @King@. -attackVectorsForKing :: (Eq distance, Num distance) => [Vector distance] +attackVectorsForKing :: [Vector] attackVectorsForKing = [ MkVector xDistance yDistance | - xDistance <- signumValues, - yDistance <- signumValues, + xDistance <- [negate 1, 0, 1], + yDistance <- [negate 1, 0, 1], hasDistance xDistance yDistance - ] where - signumValues = [negate 1, 0, 1] + ] {- | * Whether the specified /vector/ might represent an attack (rather than an advance) by a @Pawn@. * CAVEAT: if the move started at the first rank, then it can't be a @Pawn@, but that's beyond the scope of this module (since a /Vector/ doesn't define absolute /coordinate/s). -} -isPawnAttack :: (Eq distance, Num distance) => Attribute.LogicalColour.LogicalColour -> Vector distance -> Bool +isPawnAttack :: Attribute.LogicalColour.LogicalColour -> Vector -> Bool {-# INLINE isPawnAttack #-} -isPawnAttack logicalColour (MkVector xDistance yDistance) = abs xDistance == 1 && yDistance == ( - if Attribute.LogicalColour.isBlack logicalColour - then negate - else id - ) 1 +isPawnAttack logicalColour MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = abs xDistance == 1 && yDistance == if Attribute.LogicalColour.isBlack logicalColour + then negate 1 + else 1 -- | Whether the specified /vector/ represents a move a @Knight@ could make. -isKnightsMove :: (Eq distance, Num distance) => Vector distance -> Bool +isKnightsMove :: Vector -> Bool {-# INLINE isKnightsMove #-} -isKnightsMove (MkVector xDistance yDistance) = case abs xDistance of +isKnightsMove MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = case abs xDistance of 1 -> absYDistance == 2 2 -> absYDistance == 1 _ -> False @@ -184,65 +178,45 @@ absYDistance = abs yDistance -- | Whether the specified /vector/ represents a move a @King@ could make. -isKingsMove :: (Num distance, Ord distance) => Vector distance -> Bool -isKingsMove (MkVector 0 0) = False -isKingsMove (MkVector xDistance yDistance) = abs xDistance <= 1 && abs yDistance <= 1 +isKingsMove :: Vector -> Bool +isKingsMove MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = abs xDistance <= 1 && abs yDistance <= 1 {- | * Whether the specified /vector/ matches a @Pawn@'s initial double-advance move. * CAVEAT: passing this test doesn't guarantee that it is a @Pawn@'s double-advance move, since the move may not relate to a @Pawn@, or could be invalid. -} -matchesPawnDoubleAdvance - :: (Eq distance, Num distance) - => Attribute.LogicalColour.LogicalColour - -> Vector distance - -> Bool -matchesPawnDoubleAdvance logicalColour (MkVector xDistance yDistance) = xDistance == 0 && yDistance == ( - if Attribute.LogicalColour.isBlack logicalColour - then negate - else id - ) 2 +matchesPawnDoubleAdvance :: Attribute.LogicalColour.LogicalColour -> Vector -> Bool +matchesPawnDoubleAdvance logicalColour MkVector { + getXDistance = 0, + getYDistance = yDistance +} = yDistance == if Attribute.LogicalColour.isBlack logicalColour then negate 2 else 2 +matchesPawnDoubleAdvance _ _ = False -- | Translate the specified /coordinates/ by the specified /vector/. -translate :: ( - Enum x, - Enum y, - Integral distance, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y - -> Vector distance - -> Cartesian.Coordinates.Coordinates x y -translate coordinates (MkVector xDistance yDistance) = Cartesian.Coordinates.translate ( - Data.Enum.translate (+ fromIntegral xDistance) *** Data.Enum.translate (+ fromIntegral yDistance) - ) coordinates +translate :: Cartesian.Coordinates.Coordinates -> Vector -> Cartesian.Coordinates.Coordinates +translate coordinates MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = Cartesian.Coordinates.translate ((+ xDistance) *** (+ yDistance)) coordinates -- | Where legal, translate the specified /coordinates/ by the specified /vector/. -maybeTranslate :: ( - Enum x, - Enum y, - Integral distance, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y - -> Vector distance - -> Maybe (Cartesian.Coordinates.Coordinates x 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 +maybeTranslate :: Cartesian.Coordinates.Coordinates -> Vector -> Maybe Cartesian.Coordinates.Coordinates +maybeTranslate coordinates MkVector { + getXDistance = xDistance, + getYDistance = yDistance +} = Cartesian.Coordinates.maybeTranslate ((+ xDistance) *** (+ yDistance)) coordinates {- | * Where possible, converts the specified /vector/ into a /direction/. * @Nothing@ is returned for those /vector/s which don't translate into a legal /direction/ (e.g. a @Knight@'s move). -} -toMaybeDirection :: (Num distance, Ord distance) => Vector distance -> Maybe Attribute.Direction.Direction -{-# INLINE toMaybeDirection #-} +toMaybeDirection :: Vector -> Maybe Attribute.Direction.Direction toMaybeDirection vector@(MkVector xDistance yDistance) - | isStraight vector = Just $ Attribute.Direction.mkDirection (compare xDistance 0) (compare yDistance 0) + | isStraight vector = Just $ Attribute.Direction.mkDirection (xDistance `compare` 0) (yDistance `compare` 0) | otherwise = Nothing diff --git a/src-lib/BishBosh/Component/Accountant.hs b/src-lib/BishBosh/Component/Accountant.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Component/Accountant.hs @@ -0,0 +1,42 @@ +{- + 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@] Sum the relative values of /rank/ of piece, based on their location on the board, at a specific stage in the game. +-} + +module BishBosh.Component.Accountant( +-- * Type-classes + Accountant(..) +) where + +import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank +import qualified BishBosh.Type.Count as Type.Count + +-- | An interface which may be implemented by data which can total piece-square values. +class Accountant accountant where + -- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side. + sumPieceSquareValueByLogicalColour + :: Num pieceSquareValue + => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue + -> Type.Count.NPieces -- ^ The number of pieces (of any logical colour or rank) remaining on the board; used to gauge progress through the game. + -> accountant + -> [pieceSquareValue] + 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 @@ -38,8 +38,7 @@ -- defineCastlingMoves, getLongAndShortMoves, -- ** Accessors - getCastlingMoves, --- getCastlingMovesInt + getCastlingMoves ) where import Control.Arrow((&&&)) @@ -48,41 +47,35 @@ import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Data.Enum as Data.Enum import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception -- | Defines a castling-move. -data CastlingMove x y = MkCastlingMove { +data CastlingMove = MkCastlingMove { getMoveType :: Attribute.MoveType.MoveType, -- ^ CAVEAT: should only be a castling-move type. - getKingsMove :: Component.Move.Move x y, - getRooksMove :: Component.Move.Move x y + getKingsMove :: Component.Move.Move, + getRooksMove :: Component.Move.Move } --- | The constant number of files over which the King always travels when castling. -kingsMoveLength :: Num x => x +-- | The constant number of files over which the @King@ always travels when castling. +kingsMoveLength :: Type.Length.X kingsMoveLength = 2 -- | Define all possible castling-moves for the specified /logical colour/. -defineCastlingMoves :: ( - Enum x, - Enum y, - Eq y, - Ord x - ) => Attribute.LogicalColour.LogicalColour -> [CastlingMove x y] +defineCastlingMoves :: Attribute.LogicalColour.LogicalColour -> [CastlingMove] defineCastlingMoves logicalColour = [ MkCastlingMove { getMoveType = Attribute.MoveType.longCastle, getKingsMove = kingsMove $ subtract kingsMoveLength, - getRooksMove = uncurry Component.Move.mkMove . (id &&& translateX (+ 3)) $ if isBlack + getRooksMove = uncurry Component.Move.mkMove . (id &&& Cartesian.Coordinates.translateX (+ 3)) $ if isBlack then Cartesian.Coordinates.topLeft else minBound }, MkCastlingMove { getMoveType = Attribute.MoveType.shortCastle, getKingsMove = kingsMove (+ kingsMoveLength), - getRooksMove = uncurry Component.Move.mkMove . (id &&& translateX (subtract 2)) $ if isBlack + getRooksMove = uncurry Component.Move.mkMove . (id &&& Cartesian.Coordinates.translateX (subtract 2)) $ if isBlack then maxBound else Cartesian.Coordinates.bottomRight } @@ -90,19 +83,10 @@ isBlack :: Bool isBlack = Attribute.LogicalColour.isBlack logicalColour - kingsStartingCoordinates = Cartesian.Coordinates.kingsStartingCoordinates logicalColour - kingsMove translation = Component.Move.mkMove kingsStartingCoordinates $ translateX translation kingsStartingCoordinates - - translateX :: (Enum x, Ord x) => (Int -> Int) -> Cartesian.Coordinates.Coordinates x y -> Cartesian.Coordinates.Coordinates x y - translateX = Cartesian.Coordinates.translateX . Data.Enum.translate + kingsMove translation = uncurry ($) . (Component.Move.mkMove &&& Cartesian.Coordinates.translateX translation) $ Cartesian.Coordinates.kingsStartingCoordinates logicalColour -- | Defines by /logical colour/, the constant list of all possible castling-moves. -castlingMovesByLogicalColour :: ( - Enum x, - Enum y, - Eq y, - Ord x - ) => Attribute.LogicalColour.ArrayByLogicalColour [CastlingMove x y] +castlingMovesByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [CastlingMove] castlingMovesByLogicalColour = Attribute.LogicalColour.listArrayByLogicalColour $ map defineCastlingMoves Property.FixedMembership.members {- | @@ -110,28 +94,11 @@ * CAVEAT: the moves are returned in unspecified order. -} -getCastlingMoves :: ( - Enum x, - Enum y, - Eq y, - Ord x - ) => Attribute.LogicalColour.LogicalColour -> [CastlingMove x y] -{-# NOINLINE getCastlingMoves #-} -- Ensure the rewrite-rule triggers. -{-# RULES "getCastlingMoves/Int" getCastlingMoves = getCastlingMovesInt #-} -getCastlingMoves = defineCastlingMoves - --- | A specialisation of 'getCastlingMoves'. -getCastlingMovesInt :: Attribute.LogicalColour.LogicalColour -> [CastlingMove Type.Length.X Type.Length.Y] -getCastlingMovesInt = (castlingMovesByLogicalColour !) +getCastlingMoves :: Attribute.LogicalColour.LogicalColour -> [CastlingMove] +getCastlingMoves = (castlingMovesByLogicalColour !) -- | Break-down the two castling-moves for the specified /logical colour/ into a long & a short castling-move. -getLongAndShortMoves :: ( - Enum x, - Enum y, - Eq y, - Ord x - ) => Attribute.LogicalColour.LogicalColour -> (CastlingMove x y, CastlingMove x y) -{-# SPECIALISE getLongAndShortMoves :: Attribute.LogicalColour.LogicalColour -> (CastlingMove Type.Length.X Type.Length.Y, CastlingMove Type.Length.X Type.Length.Y) #-} +getLongAndShortMoves :: Attribute.LogicalColour.LogicalColour -> (CastlingMove, CastlingMove) getLongAndShortMoves logicalColour | [longCastlingMove, shortCastlingMove] <- getCastlingMoves logicalColour = (longCastlingMove, shortCastlingMove) | otherwise = Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.Component.CastlingMove.getLongAndShortMoves:\tunexpected list-length." diff --git a/src-lib/BishBosh/Component/EitherQualifiedMove.hs b/src-lib/BishBosh/Component/EitherQualifiedMove.hs --- a/src-lib/BishBosh/Component/EitherQualifiedMove.hs +++ b/src-lib/BishBosh/Component/EitherQualifiedMove.hs @@ -49,16 +49,16 @@ import qualified BishBosh.Component.Move as Component.Move -- | As returned by 'Notation.MoveNotation.readsQualifiedMove'. -data EitherQualifiedMove x y = MkEitherQualifiedMove { - getMove :: Component.Move.Move x y, +data EitherQualifiedMove = MkEitherQualifiedMove { + getMove :: Component.Move.Move, getPromotionRankOrMoveType :: Either (Maybe Attribute.Rank.Rank) Attribute.MoveType.MoveType -- ^ Either the optional /rank/ to which a @Pawn@ should be promoted, or the complete /move-type/. } -- | Constructor for notations which don't encode sufficient information to reliably re-construct the /move-type/, but merely the /rank/ to which a @Pawn@ is to be promoted. -mkPartiallyQualifiedMove :: Component.Move.Move x y -> Maybe Attribute.Rank.Rank -> EitherQualifiedMove x y +mkPartiallyQualifiedMove :: Component.Move.Move -> Maybe Attribute.Rank.Rank -> EitherQualifiedMove mkPartiallyQualifiedMove move = MkEitherQualifiedMove move . Left -- | Constructor for notations which encode sufficient information to reliably re-construct the /move-type/. -mkFullyQualifiedMove :: Component.Move.Move x y -> Attribute.MoveType.MoveType -> EitherQualifiedMove x y +mkFullyQualifiedMove :: Component.Move.Move -> Attribute.MoveType.MoveType -> EitherQualifiedMove mkFullyQualifiedMove move = MkEitherQualifiedMove move . Right 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 @@ -19,7 +19,11 @@ {- | [@AUTHOR@] Dr. Alistair Ward - [@DESCRIPTION@] Defines one move (actually just a half move AKA "ply") of a /piece/. + [@DESCRIPTION@] + + * Defines one move (actually just a half move AKA "ply") of a /piece/. + + * Similar to 'Cartesian.Vector.Vector', but the position is fixed. -} module BishBosh.Component.Move( @@ -49,7 +53,6 @@ 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 BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception @@ -68,50 +71,45 @@ * Most modern chess-notations (except Standard Algebraic) start with similar information, but also define ancillary information which is captured in /MoveType/. -} -data Move x y = MkMove { - getSource :: Cartesian.Coordinates.Coordinates x y, - getDestination :: Cartesian.Coordinates.Coordinates x y +data Move = MkMove { + getSource :: Cartesian.Coordinates.Coordinates, + getDestination :: Cartesian.Coordinates.Coordinates } deriving Eq -instance (Ord x, Ord y) => Ord (Move x y) where - {-# SPECIALISE instance Ord (Move Type.Length.X Type.Length.Y) #-} +instance Ord Move where move@MkMove { getSource = source } `compare` move'@MkMove { getSource = source' } = case source `compare` source' of EQ -> Data.Ord.comparing getDestination move move' ordering -> ordering -instance (Control.DeepSeq.NFData x, Control.DeepSeq.NFData y) => Control.DeepSeq.NFData (Move x y) where +instance Control.DeepSeq.NFData Move where rnf MkMove { getSource = source, getDestination = destination } = Control.DeepSeq.rnf (source, destination) -instance (Show x, Show y) => Show (Move x y) where +instance Show Move where showsPrec precedence MkMove { getSource = source, getDestination = destination } = showsPrec precedence (source, destination) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Read x, - Read y - ) => Read (Move x y) where +instance Read Move where readsPrec precedence = map (Control.Arrow.first $ uncurry mkMove) . readsPrec precedence -instance Property.Opposable.Opposable (Move x y) where - getOpposite (MkMove source destination) = MkMove { +instance Property.Opposable.Opposable Move where + getOpposite MkMove { + getSource = source, + getDestination = destination + } = MkMove { getSource = destination, getDestination = source } -instance (Enum x, Enum y) => Property.Orientated.Orientated (Move x y) where - isDiagonal = (Property.Orientated.isDiagonal :: Cartesian.Vector.VectorInt -> Bool) . measureDistance - isParallel = (Property.Orientated.isParallel :: Cartesian.Vector.VectorInt -> Bool) . measureDistance +instance Property.Orientated.Orientated Move where + isDiagonal = Property.Orientated.isDiagonal . measureDistance + isParallel = Property.Orientated.isParallel . measureDistance -instance Enum y => Property.Reflectable.ReflectableOnX (Move x y) where +instance Property.Reflectable.ReflectableOnX Move where reflectOnX MkMove { getSource = source, getDestination = destination @@ -120,7 +118,7 @@ getDestination = Property.Reflectable.reflectOnX destination } -instance Enum x => Property.Reflectable.ReflectableOnY (Move x y) where +instance Property.Reflectable.ReflectableOnY Move where reflectOnY MkMove { getSource = source, getDestination = destination @@ -131,10 +129,9 @@ -- | Smart constructor. mkMove - :: (Eq x, Eq y) - => Cartesian.Coordinates.Coordinates x y - -> Cartesian.Coordinates.Coordinates x y - -> Move x y + :: Cartesian.Coordinates.Coordinates + -> Cartesian.Coordinates.Coordinates + -> Move {-# INLINE mkMove #-} mkMove source destination = Control.Exception.assert (source /= destination) MkMove { getSource = source, @@ -142,26 +139,14 @@ } -- | Measures the signed distance between the ends of the move. -measureDistance :: ( - Enum x, - Enum y, - Num distance, - Ord distance - ) => Move x y -> Cartesian.Vector.Vector distance -{-# SPECIALISE measureDistance :: Move Type.Length.X Type.Length.Y -> Cartesian.Vector.VectorInt #-} +measureDistance :: Move -> Cartesian.Vector.Vector measureDistance MkMove { getSource = source, getDestination = destination } = Cartesian.Vector.measureDistance source destination -- | Generates a line of /coordinates/ covering the half open interval @(source, destination]@. -interpolate :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Move x y -> [Cartesian.Coordinates.Coordinates x y] -{-# SPECIALISE interpolate :: Move Type.Length.X Type.Length.Y -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] #-} +interpolate :: Move -> [Cartesian.Coordinates.Coordinates] interpolate move@MkMove { getSource = source, getDestination = destination @@ -174,13 +159,10 @@ but passing only guarantees that it is, if it was a @Pawn@ which moved & that the /move/ is valid. -} isPawnDoubleAdvance - :: (Enum x, Enum y, Eq y) - => Attribute.LogicalColour.LogicalColour -- Defines the side whose move is referenced. - -> Move x y + :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side whose move is referenced. + -> Move -> Bool -isPawnDoubleAdvance logicalColour move = Cartesian.Coordinates.isPawnsFirstRank logicalColour ( - getSource move - ) && Cartesian.Vector.matchesPawnDoubleAdvance logicalColour ( - measureDistance move :: Cartesian.Vector.VectorInt +isPawnDoubleAdvance logicalColour move@MkMove { getSource = source } = Cartesian.Coordinates.isPawnsFirstRank logicalColour source && Cartesian.Vector.matchesPawnDoubleAdvance logicalColour ( + measureDistance move ) diff --git a/src-lib/BishBosh/Component/Piece.hs b/src-lib/BishBosh/Component/Piece.hs --- a/src-lib/BishBosh/Component/Piece.hs +++ b/src-lib/BishBosh/Component/Piece.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP, LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -29,7 +28,7 @@ -- ** Type-synonyms -- ByRankByLogicalColour, -- AttackDestinationsByCoordinatesByRankByLogicalColour, --- ArrayByPiece, + ArrayByPiece, LocatedPiece, -- ** Data-types Piece( @@ -39,15 +38,15 @@ ), -- * Constants -- tag, - nPiecesPerSide, range, + nPiecesPerSide, + epdCharacterSet, -- attackVectorsByRankByLogicalColour, -- attackDirectionsByRankByLogicalColour, -- attackDestinationsByCoordinatesByRankByLogicalColour, -- * Functions -- findAttackDestinations', findAttackDestinations, --- findAttackDestinationsInt, showPieces, -- ** Accessors getAttackDirections, @@ -62,7 +61,7 @@ mkPiece, mkQueen, mkRook, --- listArrayByPiece, + listArrayByPiece, -- ** Predicates canAttackAlong, canMoveBetween, @@ -83,22 +82,22 @@ import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Type.Count as Type.Count -import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Char +import qualified Data.Foldable import qualified Data.List.Extra -import qualified Data.Map +import qualified Data.Map as Map import qualified Data.Maybe import qualified Text.XML.HXT.Arrow.Pickle as HXT import qualified Text.XML.HXT.Arrow.Pickle.Schema @@ -111,9 +110,9 @@ tag :: String tag = "piece" --- | The initial number of pieces per side in a standard opening position; some of which are duplicates. +-- | The constant number of pieces per side at the conventional opening position; some of which are duplicates. nPiecesPerSide :: Type.Count.NPieces -nPiecesPerSide = fromIntegral $ Cartesian.Abscissa.xLength * 2 {-rows-} +nPiecesPerSide = Data.Foldable.foldl' (+) 0 Attribute.Rank.initialAllocationByRankPerSide -- | A Chess-piece has a /logical colour/ & a /rank/. data Piece = MkPiece { @@ -141,6 +140,10 @@ instance Show Piece where showsPrec _ = Property.ForsythEdwards.showsFEN +-- | The constant set of permissible characters in an EPD. +epdCharacterSet :: Property.ExtendedPositionDescription.EPD +epdCharacterSet = concatMap Property.ExtendedPositionDescription.showEPD range + instance Property.ExtendedPositionDescription.ReadsEPD Piece where readsEPD s = case Data.List.Extra.trimStart s of c : remainder -> ( @@ -197,11 +200,11 @@ -- | Constructor. mkPawn :: Attribute.LogicalColour.LogicalColour -> Piece -mkPawn = (`MkPiece` Attribute.Rank.Pawn) +mkPawn = (`MkPiece` Attribute.Rank.Pawn) -- | Constructor. mkRook :: Attribute.LogicalColour.LogicalColour -> Piece -mkRook = (`MkPiece` Attribute.Rank.Rook) +mkRook = (`MkPiece` Attribute.Rank.Rook) -- | Constructor. mkKnight :: Attribute.LogicalColour.LogicalColour -> Piece @@ -213,22 +216,21 @@ -- | Constructor. mkQueen :: Attribute.LogicalColour.LogicalColour -> Piece -mkQueen = (`MkPiece` Attribute.Rank.Queen) +mkQueen = (`MkPiece` Attribute.Rank.Queen) -- | Constructor. mkKing :: Attribute.LogicalColour.LogicalColour -> Piece -mkKing = (`MkPiece` Attribute.Rank.King) - -{- | - * Changes the specified /piece/ to the specified /rank/ leaving its /logical colour/ unchanged. +mkKing = (`MkPiece` Attribute.Rank.King) - * CAVEAT: only legal if the unspecifed original /rank/ was a @Pawn@, & becomes neither a @Pawn@ nor a @King@. --} +-- | Changes the specified /piece/ to the specified /rank/ leaving its /logical colour/ unchanged. promote :: Attribute.Rank.Rank -> Piece -> Piece -promote newRank piece = piece { getRank = newRank } +promote newRank piece + | not $ isPawn piece = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Component.Piece.promote:\tcan't promote a " $ shows piece "." + | newRank `notElem` Attribute.Rank.promotionProspects = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Component.Piece.promote:\tcan't promote to a " $ shows newRank "." + | otherwise = piece { getRank = newRank } -- | The structure of a container of arbitrary data, indexed by /logicalColour/ & some /rank/s. -type ByRankByLogicalColour element = Attribute.LogicalColour.ArrayByLogicalColour (Data.Map.Map Attribute.Rank.Rank element) +type ByRankByLogicalColour element = Attribute.LogicalColour.ArrayByLogicalColour (Map.Map Attribute.Rank.Rank element) -- | Constructor of a certain shape of container, but with arbitrary contents. mkByRankByLogicalColour :: @@ -241,7 +243,7 @@ . Control.Parallel.Strategies.withStrategy (Control.Parallel.Strategies.parList Control.Parallel.Strategies.rdeepseq) #endif $ map ( - \logicalColour -> Data.Map.fromList $ map (id &&& mkElement logicalColour) ranks + \logicalColour -> Map.fromList $ map (id &&& mkElement logicalColour) ranks ) Property.FixedMembership.members {- | @@ -251,13 +253,7 @@ * CAVEAT: it doesn't identify @Pawn@-advances, since these aren't attacks. -} -attackVectorsByRankByLogicalColour :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData distance, -#endif - Num distance, - Ord distance - ) => ByRankByLogicalColour [Cartesian.Vector.Vector distance] +attackVectorsByRankByLogicalColour :: ByRankByLogicalColour [Cartesian.Vector.Vector] attackVectorsByRankByLogicalColour = mkByRankByLogicalColour Attribute.Rank.fixedAttackRange $ \logicalColour -> \case Attribute.Rank.Pawn -> Cartesian.Vector.attackVectorsForPawn logicalColour Attribute.Rank.Knight -> Cartesian.Vector.attackVectorsForKnight @@ -265,8 +261,22 @@ rank -> error . showString "BishBosh.Component.Piece.attackVectorsByRankByLogicalColour:\trank must attack over fixed range; " $ shows rank "." -- These ranks attack over any distance. -- | The destinations available to those pieces with attack-vectors; @Pawn@, @Knight@, @King@. -type AttackDestinationsByCoordinatesByRankByLogicalColour x y = ByRankByLogicalColour (Cartesian.Coordinates.ArrayByCoordinates x y [Cartesian.Coordinates.Coordinates x y]) +type AttackDestinationsByCoordinatesByRankByLogicalColour = ByRankByLogicalColour (Cartesian.Coordinates.ArrayByCoordinates [Cartesian.Coordinates.Coordinates]) +-- | Calls 'attackVectorsByRankByLogicalColour' to find the destinations which the specified /piece/ can attack from the specified position. +findAttackDestinations' + :: Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. + -> Piece + -> [Cartesian.Coordinates.Coordinates] -- ^ The destinations which can be attacked. +findAttackDestinations' source MkPiece { + getLogicalColour = logicalColour, + getRank = rank +} = Data.Maybe.mapMaybe ( + Cartesian.Vector.maybeTranslate source + ) ( + attackVectorsByRankByLogicalColour ! logicalColour Map.! rank + ) + {- | * The destinations available to those pieces with attack-vectors; @Pawn@, @Knight@, @King@. @@ -274,60 +284,20 @@ * CAVEAT: this function has no knowledge of the /board/, & therefore of the position of any other piece. -} -attackDestinationsByCoordinatesByRankByLogicalColour :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Enum x, - Enum y, - Ord x, - Ord y - ) => AttackDestinationsByCoordinatesByRankByLogicalColour x y -{-# SPECIALISE attackDestinationsByCoordinatesByRankByLogicalColour :: AttackDestinationsByCoordinatesByRankByLogicalColour Type.Length.X Type.Length.Y #-} -- To promote memoisation. +attackDestinationsByCoordinatesByRankByLogicalColour :: AttackDestinationsByCoordinatesByRankByLogicalColour attackDestinationsByCoordinatesByRankByLogicalColour = mkByRankByLogicalColour Attribute.Rank.fixedAttackRange $ \logicalColour rank -> Cartesian.Coordinates.listArrayByCoordinates $ map ( `findAttackDestinations'` mkPiece logicalColour rank ) Property.FixedMembership.members --- | Calls 'attackVectorsByRankByLogicalColour' to find the destinations which the specified /piece/ can attack from the specified position. -findAttackDestinations' :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ The source from which the attack originates. - -> Piece - -> [Cartesian.Coordinates.Coordinates x y] -- ^ The destinations which can be attacked. -findAttackDestinations' source MkPiece { - getLogicalColour = logicalColour, - getRank = rank -} = Data.Maybe.mapMaybe ( - Cartesian.Vector.maybeTranslate source - ) ( - attackVectorsByRankByLogicalColour ! logicalColour Data.Map.! rank :: [Cartesian.Vector.VectorInt] - ) - -- | Find the destinations which the specified /piece/ can attack from the specified position. -findAttackDestinations :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ The source from which the attack originates. +findAttackDestinations + :: Cartesian.Coordinates.Coordinates -- ^ The source from which the attack originates. -> Piece - -> [Cartesian.Coordinates.Coordinates x y] -- ^ The destinations which can be attacked. -{-# NOINLINE findAttackDestinations #-} -- Ensure the rewrite-rule triggers. -{-# RULES "findAttackDestinations/Int" findAttackDestinations = findAttackDestinationsInt #-} -- CAVEAT: the call-stack leading to this function must be specialised to ensure this triggers. -findAttackDestinations = findAttackDestinations' - --- | A specialisation of 'findAttackDestinations', more efficiently implemented by calling 'attackDestinationsByCoordinatesByRankByLogicalColour'. -findAttackDestinationsInt :: Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y -> Piece -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] -findAttackDestinationsInt coordinates MkPiece { + -> [Cartesian.Coordinates.Coordinates] -- ^ The destinations which can be attacked. +findAttackDestinations coordinates MkPiece { getLogicalColour = logicalColour, getRank = rank -} = attackDestinationsByCoordinatesByRankByLogicalColour ! logicalColour Data.Map.! rank ! coordinates +} = attackDestinationsByCoordinatesByRankByLogicalColour ! logicalColour Map.! rank ! coordinates -- The constant /direction/s of the straight lines along which each type of /piece/ can attack. @@ -353,7 +323,7 @@ getAttackDirections MkPiece { getLogicalColour = logicalColour, getRank = rank -} = attackDirectionsByRankByLogicalColour ! logicalColour Data.Map.! rank +} = attackDirectionsByRankByLogicalColour ! logicalColour Map.! rank {- | * Whether a /piece/ at the specified /coordinates/ could attack the target at the specified /coordinates/. @@ -365,12 +335,10 @@ * CAVEAT: it won't confirm the ability of a @Pawn@ to advance, since that doesn't constitute an attack. -} canAttackAlong - :: (Enum x, Enum y) - => Cartesian.Coordinates.Coordinates x y -- ^ Source (attacker's location). - -> Cartesian.Coordinates.Coordinates x y -- ^ Destination (victim's location). - -> Piece -- ^ Attacker. + :: Cartesian.Coordinates.Coordinates -- ^ Source (attacker's location). + -> Cartesian.Coordinates.Coordinates -- ^ Destination (victim's location). + -> Piece -- ^ Attacker. -> 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 @@ -380,7 +348,7 @@ Attribute.Rank.Queen -> Cartesian.Vector.isStraight Attribute.Rank.King -> Cartesian.Vector.isKingsMove ) ( - Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt + Cartesian.Vector.measureDistance source destination ) {- | @@ -388,16 +356,11 @@ * N.B.: can't detect any blocking pieces. -} -canMoveBetween :: ( - Enum x, - Enum y, - Eq y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ Source. - -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. +canMoveBetween + :: Cartesian.Coordinates.Coordinates -- ^ Source. + -> Cartesian.Coordinates.Coordinates -- ^ Destination. -> 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 @@ -417,13 +380,12 @@ Attribute.Rank.Queen -> Cartesian.Vector.isStraight Attribute.Rank.King -> Cartesian.Vector.isKingsMove ) ( - Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt + Cartesian.Vector.measureDistance source destination ) -- | Whether a move qualifies for @Pawn@-promotion. isPawnPromotion - :: (Enum y, Eq y) - => Cartesian.Coordinates.Coordinates x y -- ^ Destination. + :: Cartesian.Coordinates.Coordinates -- ^ Destination. -> Piece -> Bool isPawnPromotion destination MkPiece { @@ -488,5 +450,5 @@ listArrayByPiece = Data.Array.IArray.listArray (minBound, maxBound) -- | A /piece/ at specific /coordinates/. -type LocatedPiece x y = (Cartesian.Coordinates.Coordinates x y, Piece) +type LocatedPiece = (Cartesian.Coordinates.Coordinates, Piece) 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 @@ -27,8 +27,6 @@ -- ** Type-synonyms -- PieceSquareValueByNPieces, -- EitherPieceSquareValueByNPiecesByCoordinates, - FindPieceSquareValue, - FindPieceSquareValues, -- ** Data-types PieceSquareByCoordinatesByRank( -- MkPieceSquareByCoordinatesByRank, @@ -39,7 +37,6 @@ gnuPlotComment, -- * Functions findPieceSquareValue, - findPieceSquareValues, interpolatePieceSquareValues, formatForGNUPlot, -- ** Constructor @@ -57,10 +54,9 @@ import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Type.Count as Type.Count -import qualified BishBosh.Type.Length as Type.Length -import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.DeepSeq import qualified Data.Array.IArray +import qualified Data.Foldable import qualified Data.List -- | The piece-square value may vary as the game progresses. @@ -74,105 +70,41 @@ ) -- | Self-documentation. -type EitherPieceSquareValueByNPiecesByCoordinates x y pieceSquareValue = Either ( - Cartesian.Coordinates.ArrayByCoordinates x y pieceSquareValue -- Uninterpolated. +type EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue = Either ( + Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue -- Uninterpolated. ) ( - Cartesian.Coordinates.ArrayByCoordinates x y (PieceSquareValueByNPieces pieceSquareValue) -- Interpolated. + Cartesian.Coordinates.ArrayByCoordinates (PieceSquareValueByNPieces pieceSquareValue) -- Interpolated. ) -- | The value for each type of /piece/ of occupying each coordinate, at each stage in the lifetime of the game. -newtype PieceSquareByCoordinatesByRank x y pieceSquareValue = MkPieceSquareByCoordinatesByRank { - deconstruct :: Attribute.Rank.ArrayByRank (EitherPieceSquareValueByNPiecesByCoordinates x y pieceSquareValue) +newtype PieceSquareByCoordinatesByRank pieceSquareValue = MkPieceSquareByCoordinatesByRank { + deconstruct :: Attribute.Rank.ArrayByRank (EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue) } deriving (Eq, Show) -instance ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (PieceSquareByCoordinatesByRank x y pieceSquareValue) where +instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (PieceSquareByCoordinatesByRank pieceSquareValue) where rnf MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = Control.DeepSeq.rnf byRank -- | Constructor. mkPieceSquareByCoordinatesByRank - :: (Attribute.Rank.Rank -> EitherPieceSquareValueByNPiecesByCoordinates x y pieceSquareValue) -- ^ Convert a /rank/ into either (a /pieceSquareValue/ or a /pieceSquareValue/ which linearly varies with the number of /piece/s remaining) by /coordinates/. - -> PieceSquareByCoordinatesByRank x y pieceSquareValue + :: (Attribute.Rank.Rank -> EitherPieceSquareValueByNPiecesByCoordinates pieceSquareValue) -- ^ Convert a /rank/ into either (a /pieceSquareValue/ or a /pieceSquareValue/ which linearly varies with the number of /piece/s remaining) by /coordinates/. + -> PieceSquareByCoordinatesByRank pieceSquareValue mkPieceSquareByCoordinatesByRank = MkPieceSquareByCoordinatesByRank . Attribute.Rank.listArrayByRank . (`map` Property.FixedMembership.members) --- | The type of a function which can find the required piece-square value. -type FindPieceSquareValue x y pieceSquareValue - = Attribute.LogicalColour.LogicalColour -- ^ The /piece/'s /logical colour/. - -> Attribute.Rank.Rank -- ^ The /piece/'s /rank/. - -> Cartesian.Coordinates.Coordinates x y -- ^ The /piece/'s location. - -> pieceSquareValue - -- | Find the piece-square value, at a stage in the game's lifetime defined by the total number of pieces remaining, for the specified /rank/ & /coordinates/. -findPieceSquareValue :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Type.Count.NPieces -- ^ The progress through the game. +findPieceSquareValue + :: PieceSquareByCoordinatesByRank pieceSquareValue + -> Type.Count.NPieces -- ^ The progress through the game. -> Attribute.LogicalColour.LogicalColour -- ^ The /piece/'s /logical colour/. -> Attribute.Rank.Rank -- ^ The /piece/'s /rank/. - -> Cartesian.Coordinates.Coordinates x y -- ^ The /piece/'s location. - -> PieceSquareByCoordinatesByRank x y pieceSquareValue + -> Cartesian.Coordinates.Coordinates -- ^ The /piece/'s location. -> pieceSquareValue -{-# SPECIALISE findPieceSquareValue - :: Type.Count.NPieces - -> Attribute.LogicalColour.LogicalColour - -> Attribute.Rank.Rank - -> 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 } = ( - (!) ||| ( - \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) - ) $ byRank ! rank - ) $ ( - if Attribute.LogicalColour.isBlack logicalColour - then Property.Reflectable.reflectOnX - else id - ) coordinates - --- | The type of a function which can find the required piece-square values. -type FindPieceSquareValues x y pieceSquareValue - = 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 /piece/. - -> [pieceSquareValue] - --- | Find the piece-square values, at a stage in the game's lifetime defined by the total number of pieces remaining, for the specified /rank/ & list of /coordinates/. -findPieceSquareValues :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => 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 - :: Type.Count.NPieces - -> Attribute.LogicalColour.LogicalColour - -> Attribute.Rank.Rank - -> [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 } = ( +findPieceSquareValue MkPieceSquareByCoordinatesByRank { deconstruct = byRank } nPieces logicalColour rank = ( (!) ||| ( \byNPiecesByCoordinates -> (! nPieces) . (byNPiecesByCoordinates !) ) $ byRank ! rank - ) `map` ( - if Attribute.LogicalColour.isBlack logicalColour - then map Property.Reflectable.reflectOnX - else id - ) coordinatesList + ) . if Attribute.LogicalColour.isBlack logicalColour + then Property.Reflectable.reflectOnX + else id -- | Given the bounds over which two piece-square values vary as the game progresses from opening to end, return linearly interpolated values for all stages. interpolatePieceSquareValues @@ -197,16 +129,11 @@ gnuPlotComment = '#' -- | Format the data for input to __GNUPlot__. -formatForGNUPlot :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => (pieceSquareValue -> ShowS) -- ^ Format a /pieceSquareValue/. +formatForGNUPlot + :: (pieceSquareValue -> ShowS) -- ^ Format a /pieceSquareValue/. -> ShowS -- ^ The column-delimiter. -> (PieceSquareValueByNPieces pieceSquareValue -> pieceSquareValue) -- ^ Select one /pieceSquareValue/ from interpolated values. - -> PieceSquareByCoordinatesByRank x y pieceSquareValue + -> PieceSquareByCoordinatesByRank pieceSquareValue -> ShowS formatForGNUPlot pieceSquareValueFormatter columnDelimiter selector MkPieceSquareByCoordinatesByRank { deconstruct = byRank } = ( showsRow ( @@ -223,10 +150,10 @@ else id ) . showS ) id . zip ( - Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] + Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates] ) . Data.List.transpose . map ( - Data.Array.IArray.elems ||| map selector {-select one pieceSquareValue from interpolated values-} . Data.Array.IArray.elems {-ByCoordinates-} - ) $ Data.Array.IArray.elems {-ByRank-} byRank where + Data.Foldable.toList ||| map selector {-select one pieceSquareValue from interpolated values-} . Data.Foldable.toList {-ByCoordinates-} + ) $ Data.Foldable.toList {-ByRank-} byRank where terminateRow = showChar '\n' showsRow = Text.ShowList.showsDelimitedList columnDelimiter id terminateRow diff --git a/src-lib/BishBosh/Component/QualifiedMove.hs b/src-lib/BishBosh/Component/QualifiedMove.hs --- a/src-lib/BishBosh/Component/QualifiedMove.hs +++ b/src-lib/BishBosh/Component/QualifiedMove.hs @@ -42,37 +42,30 @@ import qualified Control.DeepSeq -- | A move qualified by its /movetype/. -data QualifiedMove x y = MkQualifiedMove { - getMove :: Component.Move.Move x y, +data QualifiedMove = MkQualifiedMove { + getMove :: Component.Move.Move, getMoveType :: Attribute.MoveType.MoveType } deriving Eq -instance (Show x, Show y) => Show (QualifiedMove x y) where +instance Show QualifiedMove where showsPrec precedence MkQualifiedMove { getMove = move, getMoveType = moveType } = showsPrec precedence (move, moveType) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Read x, - Read y - ) => Read (QualifiedMove x y) where +instance Read QualifiedMove where 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 +instance Control.DeepSeq.NFData QualifiedMove where rnf MkQualifiedMove { getMove = move, getMoveType = moveType } = Control.DeepSeq.rnf (move, moveType) -instance Enum y => Property.Reflectable.ReflectableOnX (QualifiedMove x y) where +instance Property.Reflectable.ReflectableOnX QualifiedMove where reflectOnX qualifiedMove@MkQualifiedMove { getMove = move } = qualifiedMove { getMove = Property.Reflectable.reflectOnX move } -- | Constructor. -mkQualifiedMove :: Component.Move.Move x y -> Attribute.MoveType.MoveType -> QualifiedMove x y +mkQualifiedMove :: Component.Move.Move -> Attribute.MoveType.MoveType -> QualifiedMove mkQualifiedMove = 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 @@ -58,13 +58,13 @@ * Additional data is recorded to facilitate both rollback & recording of the /move/ in various conventional notations. -} -data Turn x y = MkTurn { - getQualifiedMove :: Component.QualifiedMove.QualifiedMove x y, +data Turn = MkTurn { + getQualifiedMove :: Component.QualifiedMove.QualifiedMove, getRank :: Attribute.Rank.Rank, -- ^ The /rank/ of /piece/ that was moved, prior to any promotion. getIsRepeatableMove :: Bool -- ^ Whether this move can ever recur; without rolling-back. } -instance (Eq x, Eq y) => Eq (Turn x y) where +instance Eq Turn where MkTurn { getQualifiedMove = qualifiedMove, getRank = rank @@ -73,14 +73,14 @@ getRank = rank' } = (qualifiedMove, rank) == (qualifiedMove', rank') -- 'getIsRepeatableMove' can be derived. -instance (Control.DeepSeq.NFData x, Control.DeepSeq.NFData y) => Control.DeepSeq.NFData (Turn x y) where +instance Control.DeepSeq.NFData Turn where rnf MkTurn { getQualifiedMove = qualifiedMove, getRank = rank, getIsRepeatableMove = isRepeatableMove } = Control.DeepSeq.rnf (qualifiedMove, rank, isRepeatableMove) -instance (Show x, Show y) => Show (Turn x y) where +instance Show Turn where showsPrec precedence MkTurn { getQualifiedMove = qualifiedMove, getRank = rank @@ -91,24 +91,17 @@ -- isRepeatableMove -- Derived. ) -- Represent as a tuple. -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Read x, - Read y - ) => Read (Turn x y) where +instance Read Turn where readsPrec precedence = map (Control.Arrow.first $ uncurry mkTurn) . readsPrec precedence -instance Enum y => Property.Reflectable.ReflectableOnX (Turn x y) where +instance Property.Reflectable.ReflectableOnX Turn where reflectOnX turn@MkTurn { getQualifiedMove = qualifiedMove } = turn { getQualifiedMove = Property.Reflectable.reflectOnX qualifiedMove } -- | Smart constructor. mkTurn - :: Component.QualifiedMove.QualifiedMove x y + :: Component.QualifiedMove.QualifiedMove -> Attribute.Rank.Rank - -> Turn x y + -> Turn mkTurn qualifiedMove rank = MkTurn { getQualifiedMove = qualifiedMove, getRank = rank, @@ -118,17 +111,13 @@ } -- | Convenience. -isCapture :: Turn x y -> Bool +isCapture :: Turn -> Bool isCapture MkTurn { getQualifiedMove = qualifiedMove } = Attribute.MoveType.isCapture $ Component.QualifiedMove.getMoveType qualifiedMove -- | Whether the /turn/ represents a @Pawn@'s initial two-square advance. -isPawnDoubleAdvance :: ( - Enum x, - Enum y, - Eq y - ) - => Attribute.LogicalColour.LogicalColour -- Defines the side whose /turn/ is referenced. - -> Turn x y +isPawnDoubleAdvance + :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side whose /turn/ is referenced. + -> Turn -> Bool isPawnDoubleAdvance logicalColour MkTurn { getRank = Attribute.Rank.Pawn, @@ -139,8 +128,8 @@ -- | Forwards the request to 'Attribute.Rank.compareByLVA'. compareByLVA :: Attribute.Rank.EvaluateRank - -> Turn x y - -> Turn x y + -> Turn + -> Turn -> Ordering compareByLVA evaluateRank MkTurn { getRank = rankL } MkTurn { getRank = rankR } = Attribute.Rank.compareByLVA evaluateRank rankL rankR @@ -155,8 +144,8 @@ -} compareByMVVLVA :: Attribute.Rank.EvaluateRank - -> Turn x y - -> Turn x y + -> Turn + -> Turn -> Ordering compareByMVVLVA evaluateRank turnL@MkTurn { getQualifiedMove = qualifiedMoveL diff --git a/src-lib/BishBosh/Component/Zobrist.hs b/src-lib/BishBosh/Component/Zobrist.hs --- a/src-lib/BishBosh/Component/Zobrist.hs +++ b/src-lib/BishBosh/Component/Zobrist.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -30,9 +29,6 @@ -} module BishBosh.Component.Zobrist( --- * Type-classes - Hashable1D(..), - Hashable2D(..), -- * Types -- ** Type-synonyms -- Index, @@ -44,15 +40,11 @@ -- getRandomByCastleableRooksXByLogicalColour, -- getRandomByEnPassantAbscissa ), --- * Constants --- combiningOp, -- * Functions -- measureHammingDistances, dereferenceRandomByCoordinatesByRankByLogicalColour, dereferenceRandomByCastleableRooksXByLogicalColour, dereferenceRandomByEnPassantAbscissa, - hash2D, - combine, -- ** Constructors mkZobrist ) where @@ -64,28 +56,28 @@ import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.Default import qualified Data.Foldable -import qualified Data.List import qualified System.Random import qualified ToolShed.System.Random -- | Used as an index into 'getRandomByCoordinatesByRankByLogicalColour'. -type Index x y = (Attribute.LogicalColour.LogicalColour, Attribute.Rank.Rank, Cartesian.Coordinates.Coordinates x y) +type Index = (Attribute.LogicalColour.LogicalColour, Attribute.Rank.Rank, Cartesian.Coordinates.Coordinates) -- | The random numbers used to generate a hash, which almost uniquely represent a /position/. -data Zobrist x y positionHash = MkZobrist { - getRandomForBlacksMove :: positionHash, -- ^ Defines a random number to apply when the next move is @Black@'s. - getRandomByCoordinatesByRankByLogicalColour :: Data.Array.IArray.Array {-Boxed-} (Index x y) positionHash, -- ^ Defines random numbers to represent all combinations of each piece at each coordinate; though @Pawn@s can't exist on the terminal ranks. N.B.: regrettably the array can't be unboxed, because 'Data.Array.Unboxed.UArray' isn't 'Foldable'; cf. 'Data.Array.IArray.Array'. +data Zobrist positionHash = MkZobrist { + getRandomForBlacksMove :: positionHash, -- ^ Defines a random number to apply when the next move is @Black@'s. + getRandomByCoordinatesByRankByLogicalColour :: Data.Array.IArray.Array {-Boxed-} Index positionHash, -- ^ Defines random numbers to represent all combinations of each piece at each coordinate; though @Pawn@s can't exist on the terminal ranks. N.B.: regrettably the array can't be unboxed, because 'Data.Array.Unboxed.UArray' isn't 'Foldable'; cf. 'Data.Array.IArray.Array'. - getRandomByCastleableRooksXByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [(x, positionHash)], -- ^ Defines random numbers to represent all combinations of castleable @Rook@s. - getRandomByEnPassantAbscissa :: Cartesian.Abscissa.ArrayByAbscissa x positionHash -- ^ Defines random numbers to represent any file on which capture en-passant might be available. + getRandomByCastleableRooksXByLogicalColour :: Attribute.LogicalColour.ArrayByLogicalColour [(Type.Length.X, positionHash)], -- ^ Defines random numbers to represent all combinations of castleable @Rook@s. + getRandomByEnPassantAbscissa :: Data.Array.IArray.Array Type.Length.X positionHash -- ^ Defines random numbers to represent any file on which capture en-passant might be available. } deriving Show -instance Foldable (Zobrist x y) where +instance Foldable Zobrist where foldr f i MkZobrist { getRandomForBlacksMove = randomForBlacksMove, getRandomByCoordinatesByRankByLogicalColour = randomByCoordinatesByRankByLogicalColour, @@ -102,13 +94,9 @@ ) randomByEnPassantAbscissa instance ( - Data.Array.IArray.Ix x, Data.Bits.FiniteBits positionHash, - Enum x, - Enum y, - Ord y, System.Random.Random positionHash - ) => Data.Default.Default (Zobrist x y positionHash) where + ) => Data.Default.Default (Zobrist positionHash) where def = mkZobrist Nothing $ System.Random.mkStdGen 0 {- | @@ -118,7 +106,7 @@ * CAVEAT: a better measure of the suitability of the selected random numbers -} -measureHammingDistances :: Data.Bits.Bits positionHash => Zobrist x y positionHash -> [Int] +measureHammingDistances :: Data.Bits.Bits positionHash => Zobrist positionHash -> [Int] measureHammingDistances = map (Data.Bits.popCount . uncurry Data.Bits.xor) . getCombinations . Data.Foldable.toList where getCombinations :: [a] -> [(a, a)] getCombinations (x : remainder) = map ((,) x) remainder ++ getCombinations remainder -- CAVEAT: O(n^2) time-complexity. @@ -126,17 +114,13 @@ -- | Smart constructor. mkZobrist :: ( - Data.Array.IArray.Ix x, Data.Bits.FiniteBits positionHash, - Enum x, - Enum y, - Ord y, System.Random.RandomGen randomGen, System.Random.Random positionHash ) => Maybe Int -- ^ The optional minimum acceptable Hamming-distance between any two of the selected random numbers. -> randomGen - -> Zobrist x y positionHash + -> Zobrist positionHash mkZobrist maybeMinimumHammingDistance randomGen | Just minimumHammingDistance <- maybeMinimumHammingDistance , let minimumHammingDistance' = minimum $ measureHammingDistances zobrist @@ -163,57 +147,18 @@ } -- | Dereferences 'getRandomByCoordinatesByRankByLogicalColour' using the specified index. -dereferenceRandomByCoordinatesByRankByLogicalColour :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Index x y - -> Zobrist x y positionHash - -> positionHash +dereferenceRandomByCoordinatesByRankByLogicalColour :: Index -> Zobrist positionHash -> positionHash dereferenceRandomByCoordinatesByRankByLogicalColour index MkZobrist { getRandomByCoordinatesByRankByLogicalColour = randomByCoordinatesByRankByLogicalColour } = randomByCoordinatesByRankByLogicalColour ! index -- | Dereferences 'getRandomByCastleableRooksXByLogicalColour' using the specified abscissa. dereferenceRandomByCastleableRooksXByLogicalColour - :: Eq x - => Attribute.LogicalColour.LogicalColour - -> x - -> Zobrist x y positionHash + :: Attribute.LogicalColour.LogicalColour + -> Type.Length.X + -> Zobrist positionHash -> Maybe positionHash -- ^ The existence of a result depends on whether there remain any Rooks which can castle. dereferenceRandomByCastleableRooksXByLogicalColour logicalColour x MkZobrist { getRandomByCastleableRooksXByLogicalColour = randomByCastleableRooksXByLogicalColour } = lookup x $ randomByCastleableRooksXByLogicalColour ! logicalColour -- | Dereferences 'getRandomByEnPassantAbscissa' using the specified abscissa. -dereferenceRandomByEnPassantAbscissa - :: Data.Array.IArray.Ix x - => x - -> Zobrist x y positionHash - -> positionHash +dereferenceRandomByEnPassantAbscissa :: Type.Length.X -> Zobrist positionHash -> positionHash dereferenceRandomByEnPassantAbscissa x MkZobrist { getRandomByEnPassantAbscissa = randomByEnPassantAbscissa } = randomByEnPassantAbscissa ! x - --- | An interface to which 1-D hashable data can conform. -class Hashable1D hashable x {-CAVEAT: MultiParamTypeClasses-} where - listRandoms1D :: hashable x -> Zobrist x y positionHash -> [positionHash] - --- | An interface to which 2-D hashable data can conform. -class Hashable2D hashable x y {-CAVEAT: MultiParamTypeClasses-} where - listRandoms2D :: hashable x y -> Zobrist x y positionHash -> [positionHash] - --- | The operator used when combining random numbers to compose a hash. -combiningOp :: Data.Bits.Bits positionHash => positionHash -> positionHash -> positionHash -combiningOp = Data.Bits.xor - --- | Resolve a hashable into a hash. -hash2D :: ( - Data.Bits.Bits positionHash, - Hashable2D hashable x y - ) - => hashable x y - -> Zobrist x y positionHash - -> positionHash -hash2D hashable = Data.List.foldl1' combiningOp . listRandoms2D hashable - --- | Include a list of random numbers in the hash. -combine :: Data.Bits.Bits positionHash => positionHash -> [positionHash] -> positionHash -combine = Data.List.foldl' combiningOp 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 @@ -68,9 +68,7 @@ parser, -- ** Constructors mkPGN, - mkPGN', --- ** Mutators - setGame + mkPGN' ) where import Control.Arrow((&&&), (***)) @@ -85,7 +83,6 @@ import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour 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.Applicative import qualified Control.Arrow import qualified Control.DeepSeq @@ -93,7 +90,7 @@ import qualified Data.Char import qualified Data.Default import qualified Data.List -import qualified Data.Map +import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Time.Calendar import qualified Data.Time.Clock @@ -101,11 +98,13 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# else +# error "USE_POLYPARSE invalid" +# endif #else /* Parsec */ import qualified BishBosh.Data.Integral as Data.Integral import qualified Text.ParserCombinators.Parsec as Parsec @@ -196,7 +195,7 @@ * The first six fields are mandatory according to the PGN-specification, though none are used by this application. The seventh mandatory field /Result/ can be derived from 'getGame'. -} -data PGN x y = MkPGN { +data PGN = MkPGN { getMaybeEventName :: Maybe Value, getMaybeSiteName :: Maybe Value, getDay :: Data.Time.Calendar.Day, @@ -204,18 +203,10 @@ getMaybeWhitePlayerName :: Maybe Value, getMaybeBlackPlayerName :: Maybe Value, getIdentificationTagPairs :: [TagPair], -- ^ Arbitrary tagged values. - getGame :: Model.Game.Game x y -- ^ Defines the turn-sequence & the result. + getGame :: Model.Game.Game -- ^ Defines the turn-sequence & the result. } deriving Eq -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Show (PGN x y) where - {-# SPECIALISE instance Show (PGN Type.Length.X Type.Length.Y) #-} +instance Show PGN where showsPrec _ MkPGN { getMaybeEventName = maybeEventName, getMaybeSiteName = maybeSiteName, @@ -254,10 +245,7 @@ representUnknownTagValue :: Maybe Value -> ShowS representUnknownTagValue = quote . Data.Maybe.maybe (showChar unknownTagValue) showString -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (PGN x y) where +instance Control.DeepSeq.NFData PGN where rnf MkPGN { getIdentificationTagPairs = identificationTagPairs, getGame = game @@ -272,8 +260,8 @@ -> Maybe Value -- ^ Name of White player. -> Maybe Value -- ^ Name of Black player. -> [TagPair] -- ^ Arbitrary tag-pairs. - -> Model.Game.Game x y - -> PGN x y + -> Model.Game.Game + -> PGN mkPGN maybeEventName maybeSiteName day maybeRoundName maybeWhitePlayerName maybeBlackPlayerName identificationTagPairs game | any ( (== [unknownTagValue]) . snd {-tag-value-} @@ -304,16 +292,12 @@ ] -- Those tags for which an unknown value is represented by 'unknownTagValue'. ] -- List-comprehension. --- | Mutator. -setGame :: Model.Game.Game x y -> PGN x y -> PGN x y -setGame game pgn = pgn { getGame = game } - -- | Smart constructor. mkPGN' :: [Tag] -- ^ Identify fields used to form a unique composite game-identifier. -> [TagPair] -- ^ The data from which to extract the required values. - -> Model.Game.Game x y - -> PGN x y + -> Model.Game.Game + -> PGN mkPGN' identificationTags tagPairs = mkPGN maybeEventName maybeSiteName ( let #ifdef USE_POLYPARSE @@ -325,11 +309,11 @@ in Data.Maybe.maybe ( Control.Exception.throw . Data.Exception.mkSearchFailure . showString "failed to find " $ show dateTag -- N.B.: this will only terminate the application when the date is evaluated. ) ( -#if USE_POLYPARSE != 1 +# if USE_POLYPARSE != 'L' either ( Control.Exception.throw . Data.Exception.mkParseFailure . showString "failed to parse " . shows dateTag . showString "; " . show ) id . -#endif +# endif fst . Poly.runParser dateParser #else /* Parsec */ dateParser :: Parsec.Parser Data.Time.Calendar.Day @@ -349,7 +333,7 @@ (`elem` identificationTags) . fst {-tag-} ) tagPairs where [maybeEventName, maybeSiteName, maybeDate, maybeRoundName, maybeWhitePlayerName, maybeBlackPlayerName] = map ( - `Data.Map.lookup` Data.Map.fromList tagPairs + `Map.lookup` Map.fromList tagPairs ) [ eventNameTag, siteNameTag, @@ -364,15 +348,7 @@ * This function is only responsible for the line defining the numbered sequence of /move/s represented in SAN. -} -showsMoveText :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> ShowS -{-# SPECIALISE showsMoveText :: Model.Game.Game Type.Length.X Type.Length.Y -> ShowS #-} +showsMoveText :: Model.Game.Game -> ShowS showsMoveText game = foldr (.) ( Data.Maybe.maybe ( showsBlockComment "Game unfinished" . showChar ' ' . showChar inProgressFlag @@ -408,15 +384,7 @@ showsBlockComment = shows . ContextualNotation.PGNComment.BlockComment -- | Shows PGN for the specified /game/, with defaults for other fields. -showsGame :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> IO ShowS -{-# SPECIALISE showsGame :: Model.Game.Game Type.Length.X Type.Length.Y -> IO ShowS #-} +showsGame :: Model.Game.Game -> IO ShowS showsGame game = do utcTime <- Data.Time.Clock.getCurrentTime @@ -495,28 +463,13 @@ #endif -- | Parses a /game/ from PGN move-text. -moveTextParser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) +moveTextParser #ifdef USE_POLYPARSE - => IsStrictlySequential + :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves - -> Text.Poly.TextParser (Model.Game.Game x y) -{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Text.Poly.TextParser (Model.Game.Game Type.Length.X Type.Length.Y) #-} + -> Text.Poly.TextParser Model.Game.Game moveTextParser isStrictlySequential validateMoves = let - elementSequenceParser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> Text.Poly.TextParser (Model.Game.Game x y) + elementSequenceParser :: Model.Game.Game -> Text.Poly.TextParser Model.Game.Game elementSequenceParser game = let expectedMoveNumber :: Type.Count.NMoves expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game @@ -551,19 +504,11 @@ in do game <- fmap (Data.Maybe.fromMaybe Data.Default.def {-game-}) . Control.Applicative.optional $ elementSequenceParser Data.Default.def {-game-} #else /* Parsec */ - => IsStrictlySequential + :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves - -> Parsec.Parser (Model.Game.Game x y) -{-# SPECIALISE moveTextParser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Parsec.Parser (Model.Game.Game Type.Length.X Type.Length.Y) #-} + -> Parsec.Parser Model.Game.Game moveTextParser isStrictlySequential validateMoves = let - elementSequenceParser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> Parsec.Parser (Model.Game.Game x y) + elementSequenceParser :: Model.Game.Game -> Parsec.Parser Model.Game.Game elementSequenceParser game = let expectedMoveNumber :: Type.Count.NMoves expectedMoveNumber = fromIntegral . succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game @@ -603,25 +548,17 @@ * CAVEAT: this function doesn't /produce/ when using either "Parsec" or "Poly.Plain", since it returns 'Either' the appropriate constructor for which may be unknown until the last character is parsed. Equally for these parsers, all data must be strictly evaluated before any data can retrieved. -} -parser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => IsStrictlySequential +parser + :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [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 Type.Length.X Type.Length.Y) #-} + -> Text.Poly.TextParser PGN parser isStrictlySequential validateMoves identificationTags = do tagPairs <- Control.Applicative.many $ tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser - moveText <- moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser + game <- moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser - return {-to Parser-monad-} $ mkPGN' identificationTags (removeUnknownTagValues tagPairs) moveText + return {-to Parser-monad-} $ mkPGN' identificationTags (removeUnknownTagValues tagPairs) game where tagPairParser :: Text.Poly.TextParser TagPair @@ -643,8 +580,7 @@ return {-to Parser-monad-} (tagName, tagValue) ) #else /* Parsec */ - -> Parsec.Parser (PGN x y) -{-# SPECIALISE parser :: IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [Tag] -> Parsec.Parser (PGN Type.Length.X Type.Length.Y) #-} + -> Parsec.Parser PGN parser isStrictlySequential validateMoves identificationTags = mkPGN' identificationTags <$> ( removeUnknownTagValues <$> Control.Applicative.many ( tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser diff --git a/src-lib/BishBosh/ContextualNotation/PGNComment.hs b/src-lib/BishBosh/ContextualNotation/PGNComment.hs --- a/src-lib/BishBosh/ContextualNotation/PGNComment.hs +++ b/src-lib/BishBosh/ContextualNotation/PGNComment.hs @@ -45,11 +45,13 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# else +# error "USE_POLYPARSE invalid" +# endif #else /* Parsec */ import qualified Control.Monad import qualified Text.ParserCombinators.Parsec as Parsec 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 @@ -47,7 +47,6 @@ import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic import qualified BishBosh.Data.Exception as Data.Exception 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 @@ -58,11 +57,13 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -# else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Control.Arrow import qualified Text.ParserCombinators.Poly.Plain as Poly +# else +# error "USE_POLYPARSE invalid" # endif #else /* Parsec */ import qualified Control.Arrow @@ -71,61 +72,46 @@ #endif -- | Self-documentation. -type PGNDatabase x y = [ContextualNotation.PGN.PGN x y] +type PGNDatabase = [ContextualNotation.PGN.PGN] -- | Parse a PGN-database. -parser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ContextualNotation.PGN.IsStrictlySequential +parser + :: ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [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 Type.Length.X Type.Length.Y) #-} + -> Text.Poly.TextParser PGNDatabase 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 Type.Length.X Type.Length.Y) #-} + -> Parsec.Parser PGNDatabase parser isStrictlySequential validateMoves identificationTags = Parsec.manyTill parser' (Parsec.try $ Parsec.spaces >> Parsec.try Parsec.eof) "PGN-database" #endif where parser' = ContextualNotation.PGN.parser isStrictlySequential validateMoves identificationTags -- | PGNPredicate used to filter the database. -type PGNPredicate x y = ContextualNotation.PGN.PGN x y -> Bool +type PGNPredicate = ContextualNotation.PGN.PGN -> Bool -- | The optional maximum number of games to read. type MaybeMaximumGames = Maybe Type.Count.NGames -- | Parses a PGN-database from the specified string. -parse :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => String -- ^ The name of the specified database. +parse + :: String -- ^ The name of the specified database. -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> [ContextualNotation.PGN.Tag] - -> PGNPredicate x y -- ^ Used to filter entries from the database. + -> PGNPredicate -- ^ Used to filter entries from the database. -> 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 Type.Length.X Type.Length.Y -> MaybeMaximumGames -> String -> Either String (PGNDatabase Type.Length.X Type.Length.Y) #-} + -> Either String PGNDatabase #ifdef USE_POLYPARSE -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' 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 */ +# elif USE_POLYPARSE == 'P' parse name isStrictlySequential validateMoves identificationTags pgnPredicate maybeMaximumGames = Control.Arrow.left (showString "regarding " . shows name . showString ", ") +# else +# error "USE_POLYPARSE invalid" # endif . fst {-discard unparsed data-} . Poly.runParser parser' #else /* Parsec */ @@ -140,24 +126,16 @@ type Decompressor = String -- | Reads a PGN-database from the (optionally compressed) file-path & passes it to the parser. -parseIO :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => System.FilePath.FilePath -- ^ The PGN-file's location. +parseIO + :: System.FilePath.FilePath -- ^ The PGN-file's location. -> Maybe Decompressor -- ^ An Optional executable by which to decompress the PGN-file. -> ContextualNotation.PGN.IsStrictlySequential -> ContextualNotation.StandardAlgebraic.ValidateMoves -> System.IO.TextEncoding -- ^ The conversion-scheme between byte-sequences & Unicode characters. -> [ContextualNotation.PGN.Tag] - -> PGNPredicate x y -- ^ Used to filter entries from the database. + -> PGNPredicate -- ^ 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 Type.Length.X Type.Length.Y -> MaybeMaximumGames -> IO (Either String (PGNDatabase Type.Length.X Type.Length.Y)) #-} + -> IO (Either String PGNDatabase) 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 @@ -27,8 +27,13 @@ -- * Types -- ** Type-synonyms -- Tree, - OnymousQualifiedMove, +-- OnymousQualifiedMove, -- FindMatch, + TryToMatchMoves, + TryToMatchViaJoiningMove, + TryToMatchColourFlippedPosition, + PreferVictories, + MatchSwitches, -- ** Data-types NodeLabel(), PositionHashQualifiedMoveTree(), @@ -38,6 +43,7 @@ findNextOnymousQualifiedMovesForPosition, -- findNextJoiningOnymousQualifiedMovesFromPosition, findNextOnymousQualifiedMoves, +-- shortListMostVictorious, maybeRandomlySelectOnymousQualifiedMove, -- ** Constructors fromQualifiedMoveForest, @@ -47,6 +53,7 @@ ) where import Control.Arrow((&&&), (***)) +import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -57,64 +64,66 @@ 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.StateProperty.Censor as StateProperty.Censor +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable 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 import qualified Data.Bits import qualified Data.Default +import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra import qualified Data.Maybe import qualified Data.Tree -import qualified Factory.Math.Statistics import qualified System.Random import qualified ToolShed.System.Random #ifdef USE_PARALLEL -import qualified Control.DeepSeq import qualified Control.Parallel.Strategies #endif -- | Each label of the tree contains a /Zobrist-hash/ of the current position, augmented (except in the case of the apex-game) by the last /move/ that was played, & any conclusive result. -data NodeLabel x y positionHash = MkNodeLabel { +data NodeLabel positionHash = MkNodeLabel { getPositionHash :: positionHash, - getMaybeQualifiedMoveWithOnymousResult :: Maybe (Component.QualifiedMove.QualifiedMove x y, Maybe ContextualNotation.QualifiedMoveForest.OnymousResult) + getMaybeQualifiedMoveWithOnymousResult :: Maybe (Component.QualifiedMove.QualifiedMove, Maybe ContextualNotation.QualifiedMoveForest.OnymousResult) } -- | The tree of /qualified move/s. -type Tree x y positionHash = Data.Tree.Tree (NodeLabel x y positionHash) +type Tree positionHash = Data.Tree.Tree (NodeLabel positionHash) -- | Constructor. -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 :: Type.Count.NPieces -- ^ The minimum number of /piece/s remaining after the last /move/ in any game defined in the tree. +data PositionHashQualifiedMoveTree positionHash = MkPositionHashQualifiedMoveTree { + getZobrist :: Component.Zobrist.Zobrist positionHash, -- ^ Used to hash each position in the tree. + getTree :: Tree positionHash, + getMinimumPieces :: ! Type.Count.NPieces, -- ^ The minimum number of /piece/s remaining after the last /move/ in any game defined in the tree. + getHasAnyVictories :: Bool -- ^ Whether a victory has been recorded for any game in the tree; which won't be the case if it was constructed from a PGN-database containing standard-openings. } -- | Augment the specified /qualified-move forest/ with a /Zobrist-hash/ of the /position/ & include the default initial game at the apex. -fromQualifiedMoveForest :: ( - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y, - Show x, - Show y - ) +fromQualifiedMoveForest + :: Data.Bits.Bits positionHash => Bool -- ^ IncrementalEvaluation. - -> Component.Zobrist.Zobrist x y positionHash - -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y - -> PositionHashQualifiedMoveTree x y 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 #-} + -> Component.Zobrist.Zobrist positionHash + -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest + -> PositionHashQualifiedMoveTree positionHash +{-# SPECIALISE fromQualifiedMoveForest :: Bool -> Component.Zobrist.Zobrist Type.Crypto.PositionHash -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> PositionHashQualifiedMoveTree Type.Crypto.PositionHash #-} fromQualifiedMoveForest incrementalEvaluation zobrist qualifiedMoveForest = MkPositionHashQualifiedMoveTree { getZobrist = zobrist, - getTree = let - initialGame = Data.Default.def - initialPositionHash = Component.Zobrist.hash2D initialGame zobrist - in Data.Tree.Node { + getTree = tree, + getMinimumPieces = ContextualNotation.QualifiedMoveForest.findMinimumPieces qualifiedMoveForest, + getHasAnyVictories = Data.Foldable.any ( + Data.Maybe.maybe False {-no QualifiedMove-} ( + Data.Maybe.maybe False {-no OnymousResult-} ( + not . Rule.Result.isDraw . snd {-Result-} + ) . snd {-Maybe OnymousResult-} + ) . getMaybeQualifiedMoveWithOnymousResult + ) tree +} where + initialGame = Data.Default.def + initialPositionHash = StateProperty.Hashable.hash initialGame zobrist + tree = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel initialPositionHash Nothing, Data.Tree.subForest = map ( if incrementalEvaluation @@ -134,18 +143,16 @@ Data.Tree.rootLabel = label@(qualifiedMove, _), Data.Tree.subForest = qualifiedMoveForest' } = Data.Tree.Node { - Data.Tree.rootLabel = MkNodeLabel (Component.Zobrist.hash2D game' zobrist) $ Just label, -- Hash the game after applying the move. + Data.Tree.rootLabel = MkNodeLabel (StateProperty.Hashable.hash game' zobrist) $ Just label, -- Hash the game after applying the move. Data.Tree.subForest = map (slave game') qualifiedMoveForest' -- Recurse. } where game' = Model.Game.applyQualifiedMove qualifiedMove game in slave initialGame ) $ ContextualNotation.QualifiedMoveForest.deconstruct qualifiedMoveForest - }, - getMinimumPieces = ContextualNotation.QualifiedMoveForest.findMinimumPieces qualifiedMoveForest -} + } -- | Predicate. -isTerminal :: PositionHashQualifiedMoveTree x y positionHash -> Bool +isTerminal :: PositionHashQualifiedMoveTree positionHash -> Bool isTerminal MkPositionHashQualifiedMoveTree { getTree = Data.Tree.Node { Data.Tree.subForest = [] } } = True isTerminal _ = False @@ -154,14 +161,14 @@ * CAVEAT: a negative result doesn't imply that convergence is possible, since other factors may prevent it. -} -cantConverge :: Model.Game.Game x y -> PositionHashQualifiedMoveTree x y positionHash -> Bool +cantConverge :: Model.Game.Game -> PositionHashQualifiedMoveTree positionHash -> Bool cantConverge game MkPositionHashQualifiedMoveTree { getMinimumPieces = minimumPieces } = State.Board.getNPieces (Model.Game.getBoard game) < minimumPieces -- | A /qualified move/ annotated by the name & ultimate /result/, of each /game/ from which it could have originated. -type OnymousQualifiedMove x y = (Component.QualifiedMove.QualifiedMove x y, [ContextualNotation.QualifiedMoveForest.OnymousResult]) +type OnymousQualifiedMove = (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.OnymousResult]) -- | Find the /onymous result/s for all /game/s originating from the specified tree. -onymiseQualifiedMove :: Tree x y positionHash -> OnymousQualifiedMove x y +onymiseQualifiedMove :: Tree positionHash -> OnymousQualifiedMove onymiseQualifiedMove = ( fst {-qualifiedMove-} . head &&& Data.Maybe.mapMaybe snd {-Maybe OnymousResult-} ) . ( @@ -171,10 +178,10 @@ ) . Data.Tree.flatten -- | The type of a function used to locate a match in the tree. -type FindMatch x y positionHash = Model.Game.Game x y -> PositionHashQualifiedMoveTree x y positionHash -> [OnymousQualifiedMove x y] +type FindMatch positionHash = Model.Game.Game -> PositionHashQualifiedMoveTree positionHash -> [OnymousQualifiedMove] -- | For any exactly matching /game/ in the tree, return the subsequent /qualifiedMove/s. -findNextOnymousQualifiedMovesForGame :: (Eq x, Eq y) => FindMatch x y positionHash +findNextOnymousQualifiedMovesForGame :: FindMatch positionHash findNextOnymousQualifiedMovesForGame requiredGame = slave ( Model.Game.listTurnsChronologically requiredGame ) . Data.Tree.subForest {-remove the apex which lacks a founding move-} . getTree where @@ -192,59 +199,47 @@ * By matching the /position/ rather than the precise sequence of /move/s, transpositions can also be identified. + * N.B.: a comparison between the number of pieces in the game we're required to match & the decreasing number of pieces down the tree, permits early termination of the search. + * CAVEAT: a null list can result from either match-failure, or a match with the final /move/ of a /game/. -} -findNextOnymousQualifiedMovesForPosition :: ( - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y - ) => FindMatch x y positionHash -{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} -findNextOnymousQualifiedMovesForPosition requiredGame positionHashQualifiedMoveTree@MkPositionHashQualifiedMoveTree { - getZobrist = zobrist, - getTree = tree -} - | cantConverge requiredGame positionHashQualifiedMoveTree = [] -- The specified game has fewer pieces than any defined in the tree. - | otherwise = slave (2 * Component.Piece.nPiecesPerSide) tree +findNextOnymousQualifiedMovesForPosition :: Data.Bits.Bits positionHash => FindMatch positionHash +{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch Type.Crypto.PositionHash #-} +findNextOnymousQualifiedMovesForPosition requiredGame positionHashQualifiedMoveTree + | cantConverge requiredGame positionHashQualifiedMoveTree = [] -- The game we're required to match has fewer pieces than any defined in the tree. + | otherwise = slave nPiecesDiffByLogicalColour $ getTree positionHashQualifiedMoveTree where - (requiredPositionHash, requiredNPieces) = (`Component.Zobrist.hash2D` zobrist) &&& State.Board.getNPieces . Model.Game.getBoard $ requiredGame + nPiecesDiffByLogicalColour :: (Type.Count.NPieces, Type.Count.NPieces) + (requiredPositionHash, nPiecesDiffByLogicalColour) = (`StateProperty.Hashable.hash` getZobrist positionHashQualifiedMoveTree) &&& ( + uncurry (***) . (id &&& id) $ (Component.Piece.nPiecesPerSide -) -- Find the excess pieces on either side, to be taken before a match can be found. + ) . StateProperty.Censor.countPiecesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard $ requiredGame - slave nPieces Data.Tree.Node { + slave (nPiecesDiffOpponent, nPiecesDiffMover) Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash }, Data.Tree.subForest = forest } = ( - if positionHash == requiredPositionHash - then ( - map onymiseQualifiedMove forest ++ -- The position matches, so one can select any move from the forest. - ) -- Section. - else id + case nPiecesDiffMover `compare` 0 of -- N.B. equivalent to 'signum' to slightly better performance. + GT -> id -- This node can't match, but there may be a match further down the tree. + EQ + | positionHash == requiredPositionHash -> (map onymiseQualifiedMove forest ++) -- The position matches, so one can select any move from the forest. + | otherwise -> id -- This node doesn't match, but there may be a match further down the tree. + _ -> const [] -- Terminate the recursion, since from here down the tree, the mover has insufficient pieces to match the required game. ) $ 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. + } -> slave ( + nPiecesDiffMover, + ( + if Attribute.MoveType.isCapture $! Component.QualifiedMove.getMoveType qualifiedMove + then pred + else id + ) nPiecesDiffOpponent + ) {-swap pair-} node -- Recurse. ) forest -- | Finds any single /move/s which can join the current /position/ with a member of the forest. -findNextJoiningOnymousQualifiedMovesFromPosition :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y, - Show x, - Show y - ) => FindMatch x y positionHash -{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} +findNextJoiningOnymousQualifiedMovesFromPosition :: Data.Bits.Bits positionHash => FindMatch positionHash +{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch Type.Crypto.PositionHash #-} findNextJoiningOnymousQualifiedMovesFromPosition game positionHashQualifiedMoveTree | Model.Game.isTerminated game = [] | otherwise = [ @@ -260,6 +255,21 @@ ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game ] -- List-comprehension. +-- | Whether to attempt to exactly match moves with a standard opening; transpositions won't be matched. +type TryToMatchMoves = Bool + +-- | Whether to attempt to join the current position to a standard opening that's only one ply away. +type TryToMatchViaJoiningMove = Bool + +-- | Whether to attempt to match a colour-flipped version of the current position with a standard opening +type TryToMatchColourFlippedPosition = Bool + +-- | The switches used to control attempts to find a match amongst standard openings. +type MatchSwitches = (TryToMatchMoves, TryToMatchViaJoiningMove, TryToMatchColourFlippedPosition) + +-- | Whether from all matching positions extracted from the tree, to prefer moves which result in a greater probability of victory, for the player who has the next move. +type PreferVictories = Bool + {- | * Calls 'findNextOnymousQualifiedMovesForGame' to find an exact match for the current /game/ in the tree. @@ -273,22 +283,11 @@ * CAVEAT: the order of these searches has been hard-coded. -} -findNextOnymousQualifiedMoves :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y, - Show x, - Show y - ) - => (Bool, Bool, Bool) -- ^ MatchSwitches. - -> FindMatch x y positionHash -{-# SPECIALISE findNextOnymousQualifiedMoves :: (Bool, Bool, Bool) -> FindMatch Type.Length.X Type.Length.Y Type.Crypto.PositionHash #-} +findNextOnymousQualifiedMoves + :: Data.Bits.Bits positionHash + => MatchSwitches + -> FindMatch positionHash +{-# SPECIALISE findNextOnymousQualifiedMoves :: MatchSwitches -> FindMatch Type.Crypto.PositionHash #-} findNextOnymousQualifiedMoves (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) game positionHashQualifiedMoveTree | cantConverge game positionHashQualifiedMoveTree = [] -- The specified game is smaller than any defined in the tree. | otherwise = Data.Maybe.fromMaybe [] . Data.List.find ( @@ -311,49 +310,46 @@ ] -- Transform an arbitrary match-function to operate on either the original or the colour-flipped game. ] -- List-comprehension. +-- | Shortlist matching moves extracted from the tree, prefering those after which the player who makes it, has the greatest recorded incidence of victory. +shortListMostVictorious + :: Attribute.LogicalColour.LogicalColour -- ^ The player who is next to move. + -> [OnymousQualifiedMove] + -> [OnymousQualifiedMove] +shortListMostVictorious nextLogicalColour = last {-highest scoring group-} . Data.List.Extra.groupSortOn ( + Data.List.foldl' ( + \acc -> ($ acc) . Data.Maybe.maybe id {-draw-} ( + \victorsLogicalColour -> if victorsLogicalColour == nextLogicalColour then succ else pred -- Score the result, according to which side we'd like to win. + ) . Rule.Result.findMaybeVictor . snd {-result-} + ) (0 :: Int) . snd {-[OnymousResult]-} + ) + -- | Randomly select a /qualifiedMove/ from matching /position/s in the tree, & supply the names of those archived games from which it originated. maybeRandomlySelectOnymousQualifiedMove :: ( -#ifdef USE_PARALLEL - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y, -#endif - Data.Array.IArray.Ix x, Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y, - Show x, - Show y, System.Random.RandomGen randomGen ) => randomGen - -> (Bool, Bool, Bool) -- ^ MatchSwitches. - -> Model.Game.Game x y - -> PositionHashQualifiedMoveTree x y positionHash - -> Maybe (Component.QualifiedMove.QualifiedMove x y, [ContextualNotation.QualifiedMoveForest.Name]) + -> PreferVictories + -> MatchSwitches + -> Model.Game.Game + -> PositionHashQualifiedMoveTree positionHash + -> Maybe (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.Name]) {-# SPECIALISE maybeRandomlySelectOnymousQualifiedMove :: System.Random.RandomGen randomGen => randomGen - -> (Bool, Bool, Bool) - -> 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]) + -> PreferVictories + -> MatchSwitches + -> Model.Game.Game + -> PositionHashQualifiedMoveTree Type.Crypto.PositionHash + -> Maybe (Component.QualifiedMove.QualifiedMove, [ContextualNotation.QualifiedMoveForest.Name]) #-} -maybeRandomlySelectOnymousQualifiedMove randomGen matchSwitches game positionHashQualifiedMoveTree = case findNextOnymousQualifiedMoves matchSwitches game positionHashQualifiedMoveTree of +maybeRandomlySelectOnymousQualifiedMove randomGen preferVictories matchSwitches game positionHashQualifiedMoveTree = case findNextOnymousQualifiedMoves matchSwitches game positionHashQualifiedMoveTree of [] -> Nothing onymousQualifiedMoves -> fmap ( Control.Arrow.second $ Data.List.nub . map fst {-Name-} - ) . ToolShed.System.Random.select randomGen . last {-highest scoring group-} $ Data.List.Extra.groupSortOn ( - ( - Factory.Math.Statistics.getMean :: [Int] -> Rational - ) . map ( - Data.Maybe.maybe 0 {-a draw-} ( - \victorsLogicalColour -> ( - if victorsLogicalColour == Model.Game.getNextLogicalColour game - then id - else negate - ) 1 {-victory-} - ) . Rule.Result.findMaybeVictor . snd {-result-} -- Score the result, according to which side we'd like to win. - ) . snd {-[OnymousResult]-} + ) . ToolShed.System.Random.select randomGen $ ( + if preferVictories && getHasAnyVictories positionHashQualifiedMoveTree + then shortListMostVictorious $ Model.Game.getNextLogicalColour game + else id ) 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 @@ -51,6 +51,7 @@ import Control.Applicative((<|>)) import Control.Arrow((&&&), (***)) import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +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 @@ -63,10 +64,8 @@ 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 @@ -88,7 +87,7 @@ * CAVEAT: since zero moves have been made in the default initial game, the move-tree for the whole game of chess has no apex, so a forest is a more natural structure; though sub-trees can exist. -} -type QualifiedMoveTree x y = Data.Tree.Tree (Component.QualifiedMove.QualifiedMove x y, Maybe OnymousResult) +type QualifiedMoveTree = Data.Tree.Tree (Component.QualifiedMove.QualifiedMove, Maybe OnymousResult) {- | * A representation of a PGN-database, where initial /move/s shared between /game/s are merged into the trunk of a tree from which they each branch. @@ -97,21 +96,21 @@ * Since there are many different initial moves, the structure is a flat-topped /forest/ rather than a single apex /tree/. -} -newtype QualifiedMoveForest x y = MkQualifiedMoveForest { - deconstruct :: [QualifiedMoveTree x y] +newtype QualifiedMoveForest = MkQualifiedMoveForest { + deconstruct :: [QualifiedMoveTree] } deriving ( Eq, Show -- CAVEAT: required by QuickCheck, but shouldn't actually be called. ) -instance Property.Empty.Empty (QualifiedMoveForest x y) where +instance Property.Empty.Empty QualifiedMoveForest where empty = MkQualifiedMoveForest Property.Empty.empty -instance Property.Null.Null (QualifiedMoveForest x y) where +instance Property.Null.Null QualifiedMoveForest where isNull MkQualifiedMoveForest { deconstruct = [] } = True isNull _ = False -instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotation (QualifiedMoveForest x y) where +instance Notation.MoveNotation.ShowNotation QualifiedMoveForest where showsNotation moveNotation MkQualifiedMoveForest { deconstruct = forest } = showString $ Data.RoseTree.drawForest ( \(qualifiedMove, maybeOnymousResult) -> Notation.MoveNotation.showsNotation moveNotation qualifiedMove $ Data.Maybe.maybe id ( \onymousResult -> showChar ' ' . shows onymousResult @@ -136,10 +135,9 @@ -- | Include the specified PGN-database into the /forest/, thus allowing more than one 'ContextualNotation.PGNDatabase.PGNDatabase' to be read. mergePGNDatabase - :: (Eq x, Eq y) - => ContextualNotation.PGNDatabase.PGNDatabase x y - -> QualifiedMoveForest x y - -> QualifiedMoveForest x y + :: ContextualNotation.PGNDatabase.PGNDatabase + -> QualifiedMoveForest + -> QualifiedMoveForest mergePGNDatabase pgnDatabase MkQualifiedMoveForest { deconstruct = initialForest } = MkQualifiedMoveForest $ foldr ( \pgn -> merge ( mkCompositeIdentifier &&& Data.Maybe.maybe ( @@ -149,15 +147,14 @@ map Component.Turn.getQualifiedMove . Model.Game.listTurnsChronologically $ ContextualNotation.PGN.getGame pgn -- Extract the list of qualified moves defining this game. ) ) initialForest pgnDatabase where - mkCompositeIdentifier :: ContextualNotation.PGN.PGN x y -> Name + mkCompositeIdentifier :: ContextualNotation.PGN.PGN -> Name mkCompositeIdentifier = unwords . map snd {-value-} . ContextualNotation.PGN.getIdentificationTagPairs merge - :: (Eq x, Eq y) - => OnymousResult -- ^ The name of this move-sequence, & the result. - -> [Component.QualifiedMove.QualifiedMove x y] -- ^ A chronological sequence of /qualified move/s. - -> [QualifiedMoveTree x y] - -> [QualifiedMoveTree x y] + :: OnymousResult -- ^ The name of this move-sequence, & the result. + -> [Component.QualifiedMove.QualifiedMove] -- ^ A chronological sequence of /qualified move/s. + -> [QualifiedMoveTree] + -> [QualifiedMoveTree] merge onymousResult qualifiedMoves@(qualifiedMove : remainingQualifiedMoves) forest = case span ( \Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove', _) } -> Component.QualifiedMove.getMove qualifiedMove /= Component.QualifiedMove.getMove qualifiedMove' ) forest of @@ -175,7 +172,7 @@ _ {-no match-} -> mkLinkedList onymousResult qualifiedMoves : forest merge _ [] forest = forest - mkLinkedList :: OnymousResult -> [Component.QualifiedMove.QualifiedMove x y] -> QualifiedMoveTree x y + mkLinkedList :: OnymousResult -> [Component.QualifiedMove.QualifiedMove] -> QualifiedMoveTree mkLinkedList onymousResult ~(qualifiedMove : remainingQualifiedMoves) | null remainingQualifiedMoves = Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove, Just onymousResult), @@ -187,28 +184,32 @@ } -- | Constructor. -fromPGNDatabase :: (Eq x, Eq y) => ContextualNotation.PGNDatabase.PGNDatabase x y -> QualifiedMoveForest x y +fromPGNDatabase :: ContextualNotation.PGNDatabase.PGNDatabase -> QualifiedMoveForest fromPGNDatabase = (`mergePGNDatabase` Property.Empty.empty {-QualifiedMoveForest-}) --- | Find the minimum number of /piece/s in any of the recorded /game/s. -findMinimumPieces :: QualifiedMoveForest x y -> Type.Count.NPieces +{- | + * Find the minimum total number of /piece/s in any of the recorded /game/s, in order to determining whether a sample game is too small to converge on anything in the tree. + + * CAVEAT: no attempt is made to partition this total by logical colour, because there's no clear concept of the /minimum/ amongst the pairs discovered at each leaf-node. + + * N.B.: one call also measure other monotonically changing quantities (number of Pawns, number of Castleable Rooks, least advanced Pawn), but this is cheap. +-} +findMinimumPieces :: QualifiedMoveForest -> Type.Count.NPieces findMinimumPieces = slave ( - State.Board.getNPieces ( - 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. - ) + 2 * Component.Piece.nPiecesPerSide -- CAVEAT: assuming a conventional starting position. ) . deconstruct where slave nPieces [] = nPieces slave nPieces forest = minimum $ map ( \Data.Tree.Node { Data.Tree.rootLabel = (qualifiedMove, _), Data.Tree.subForest = subForest - } -> slave ( - Attribute.MoveType.nPiecesMutator (Component.QualifiedMove.getMoveType qualifiedMove) nPieces - ) subForest -- Recurse. + } -> let + nPieces' = Attribute.MoveType.nPiecesMutator (Component.QualifiedMove.getMoveType qualifiedMove) nPieces + in nPieces' `seq` slave nPieces' subForest -- Recurse. ) forest -- | Count the number of /game/s & distinct /positions/. -count :: QualifiedMoveForest x y -> (Type.Count.NGames, Type.Count.NPositions) +count :: QualifiedMoveForest -> (Type.Count.NGames, Type.Count.NPositions) count = slave . deconstruct where slave = Data.List.foldl' ( \(nGames, nPositions) Data.Tree.Node { @@ -230,15 +231,7 @@ * N.B.: to construct a tree from the specified forest, the default initial /game/ is included at the apex. -} -toGameTree :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => QualifiedMoveForest x y -> Model.GameTree.GameTree x y -{-# SPECIALISE toGameTree :: QualifiedMoveForest Type.Length.X Type.Length.Y -> Model.GameTree.GameTree Type.Length.X Type.Length.Y #-} +toGameTree :: QualifiedMoveForest -> Model.GameTree.GameTree toGameTree MkQualifiedMoveForest { deconstruct = qualifiedMoveForest } = Model.GameTree.fromBareGameTree Data.Tree.Node { Data.Tree.rootLabel = initialGame, Data.Tree.subForest = map (slave initialGame) qualifiedMoveForest diff --git a/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs b/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs --- a/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs +++ b/src-lib/BishBosh/ContextualNotation/StandardAlgebraic.hs @@ -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.Notation.Notation as Notation.Notation 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.Type.Length as Type.Length import qualified Control.Applicative import qualified Control.Exception import qualified Control.Monad @@ -85,11 +85,13 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# else +# error "USE_POLYPARSE invalid" +# endif #else /* Parsec */ import qualified Text.ParserCombinators.Parsec as Parsec import Text.ParserCombinators.Parsec((), (<|>)) @@ -137,31 +139,23 @@ moveSuffixAnnotations = "!?" -- | Defines a /move/, to enable i/o in /StandardAlgebraic/-notation. -newtype StandardAlgebraic x y = MkStandardAlgebraic { - getQualifiedMove :: Component.QualifiedMove.QualifiedMove x y +newtype StandardAlgebraic = MkStandardAlgebraic { + getQualifiedMove :: Component.QualifiedMove.QualifiedMove } deriving (Eq, Show) -- | Constructor. -fromQualifiedMove :: Component.QualifiedMove.QualifiedMove x y -> StandardAlgebraic x y +fromQualifiedMove :: Component.QualifiedMove.QualifiedMove -> StandardAlgebraic fromQualifiedMove = MkStandardAlgebraic -- | Whether en-passant moves are tagged, or implicit. type ExplicitEnPassant = Bool -- | Represent the specified /turn/ in SAN. -showsTurn :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ExplicitEnPassant - -> Component.Turn.Turn x y - -> Model.Game.Game x y -- ^ The /game/ prior to application of the specified /turn/. +showsTurn + :: ExplicitEnPassant + -> Component.Turn.Turn + -> Model.Game.Game -- ^ The /game/ prior to application of the specified /turn/. -> 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 @@ -205,7 +199,7 @@ else checkFlag else id ) - | otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.ContextualNotation.StandardAlgebraic.showsTurn:\tno piece exists at " . Notation.PureCoordinate.showsCoordinates source . showString "; " $ Property.ForsythEdwards.showsFEN game "." + | otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.ContextualNotation.StandardAlgebraic.showsTurn:\tno piece exists at " . Notation.Notation.showsCoordinates Notation.PureCoordinate.notation source . showString "; " $ Property.ForsythEdwards.showsFEN game "." where ((source, destination), moveType) = (Component.Move.getSource &&& Component.Move.getDestination) . Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ Component.Turn.getQualifiedMove turn board = Model.Game.getBoard game @@ -218,42 +212,25 @@ showsRank rank = showChar $ fromRank rank showsCapture, showsX, showsY, showsDestination :: ShowS - showsCapture = showChar captureFlag - (showsX, showsY) = Notation.PureCoordinate.encode source - showsDestination = Notation.PureCoordinate.showsCoordinates destination + showsCapture = showChar captureFlag + ((showsX, showsY), showsDestination) = (`Notation.Notation.encode` source) &&& (`Notation.Notation.showsCoordinates` destination) $ Notation.PureCoordinate.notation game' = Model.Game.takeTurn turn game -- | Calls 'showsTurn'. -showTurn :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ExplicitEnPassant - -> Component.Turn.Turn x y - -> Model.Game.Game x y -- ^ The /game/ prior to application of the specified /turn/. +showTurn + :: ExplicitEnPassant + -> Component.Turn.Turn + -> Model.Game.Game -- ^ The /game/ prior to application of the specified /turn/. -> 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'. -showsMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ExplicitEnPassant - -> Component.QualifiedMove.QualifiedMove x y - -> Model.Game.Game x y +showsMove + :: ExplicitEnPassant + -> Component.QualifiedMove.QualifiedMove + -> Model.Game.Game -> 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." @@ -261,31 +238,15 @@ ) game -- | Calls 'showsMove'. -showMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ExplicitEnPassant - -> Component.QualifiedMove.QualifiedMove x y - -> Model.Game.Game x y +showMove + :: ExplicitEnPassant + -> Component.QualifiedMove.QualifiedMove + -> Model.Game.Game -> 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/. -movePiece :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => StandardAlgebraic x y -> Model.Game.Transformation x y -{-# SPECIALISE movePiece :: StandardAlgebraic Type.Length.X Type.Length.Y -> Model.Game.Transformation Type.Length.X Type.Length.Y #-} +movePiece :: StandardAlgebraic -> Model.Game.Transformation movePiece MkStandardAlgebraic { getQualifiedMove = qualifiedMove } = Model.Game.applyQualifiedMove qualifiedMove #ifdef USE_POLYPARSE @@ -319,20 +280,12 @@ #endif -- | Parses a /move/ from SAN, & optionally validates it against the specified /game/. -parser :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => ExplicitEnPassant +parser + :: ExplicitEnPassant -> ValidateMoves - -> Model.Game.Game x y + -> Model.Game.Game #ifdef USE_POLYPARSE - -> Text.Poly.TextParser (StandardAlgebraic x y) -{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game Type.Length.X Type.Length.Y -> Text.Poly.TextParser (StandardAlgebraic Type.Length.X Type.Length.Y) #-} + -> Text.Poly.TextParser StandardAlgebraic parser explicitEnPassant validateMoves game = let nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour @@ -482,8 +435,7 @@ then Data.Maybe.maybe (return {-to Parser-monad-} qualifiedMove) (Poly.failBad . showString "failed: ") $ Model.Game.validateQualifiedMove qualifiedMove game else return {-to Parser-monad-} qualifiedMove #else /* Parsec */ - -> Parsec.Parser (StandardAlgebraic x y) -{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game Type.Length.X Type.Length.Y -> Parsec.Parser (StandardAlgebraic Type.Length.X Type.Length.Y) #-} + -> Parsec.Parser StandardAlgebraic parser explicitEnPassant validateMoves game = let nextLogicalColour = Model.Game.getNextLogicalColour game (longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour diff --git a/src-lib/BishBosh/Data/Enum.hs b/src-lib/BishBosh/Data/Enum.hs deleted file mode 100644 --- a/src-lib/BishBosh/Data/Enum.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- - Copyright (C) 2021 Dr. Alistair Ward - - This file is part of BishBosh. - - BishBosh is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - BishBosh is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with BishBosh. If not, see . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Defines a translation between enumerable types. --} - -module BishBosh.Data.Enum( --- * Functions - translate - ) where - --- | Translate between enumerable types. -translate :: (Enum a, Enum b) => (Int -> Int) -> a -> b -{-# INLINE translate #-} -translate f = toEnum . f . fromEnum - diff --git a/src-lib/BishBosh/Data/Foldable.hs b/src-lib/BishBosh/Data/Foldable.hs --- a/src-lib/BishBosh/Data/Foldable.hs +++ b/src-lib/BishBosh/Data/Foldable.hs @@ -27,11 +27,11 @@ ) where import qualified Data.Foldable -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map -- | Returns a unique instance of any item which has been specified more than once. findDuplicates :: (Foldable foldable, Ord a) => foldable a -> [a] -findDuplicates = Data.Map.Strict.keys . Data.Map.Strict.filter (> 1) . Data.Foldable.foldr ( - flip (Data.Map.Strict.insertWith $ const succ) (1 :: Int) -- Count instances. - ) Data.Map.Strict.empty +findDuplicates = Map.keys . Map.filter (> 1) . Data.Foldable.foldr ( + flip (Map.insertWith $ const succ) (1 :: Int) -- Count instances. + ) Map.empty diff --git a/src-lib/BishBosh/Evaluation/Fitness.hs b/src-lib/BishBosh/Evaluation/Fitness.hs --- a/src-lib/BishBosh/Evaluation/Fitness.hs +++ b/src-lib/BishBosh/Evaluation/Fitness.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -29,11 +29,11 @@ -} module BishBosh.Evaluation.Fitness( +-- * Types -- * Constants -- maximumDestinations, maximumDefended, -- * Functions --- mkPieceSquareCriterionValue, measurePieceSquareValue, measurePieceSquareValueIncrementally, measureValueOfMaterial, @@ -70,45 +70,35 @@ import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour 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.Foldable import qualified Data.List -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map import qualified Data.Maybe #ifdef USE_UNBOXED_ARRAYS import qualified Data.Array.Unboxed #endif --- | Construct a criterion-value from a piece-square value. -mkPieceSquareCriterionValue :: Real pieceSquareValue => pieceSquareValue -> Metric.CriterionValue.CriterionValue -mkPieceSquareCriterionValue = fromRational . ( - / fromIntegral Component.Piece.nPiecesPerSide - ) . toRational - -- | Measures the piece-square value from the perspective of the last player to move. measurePieceSquareValue :: ( #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + 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, - Num pieceSquareValue, - Ord x, - Ord y + Num pieceSquareValue ) - => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue - -> Model.Game.Game x y + => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue + -> Model.Game.Game -> 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. - where - [blacksPieceSquareValue, whitesPieceSquareValue] = Data.Array.IArray.elems . State.Board.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank $ Model.Game.getBoard game - difference = whitesPieceSquareValue - blacksPieceSquareValue +{-# SPECIALISE measurePieceSquareValue :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue -> Model.Game.Game -> Type.Mass.PieceSquareValue #-} +measurePieceSquareValue pieceSquareByCoordinatesByRank game = ( + if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game + then id + else negate -- Represent the piece-square value from Black's perspective. + ) $ whitesPieceSquareValue - blacksPieceSquareValue where + [blacksPieceSquareValue, whitesPieceSquareValue] = Data.Array.IArray.elems . State.Board.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank $ Model.Game.getBoard game {- | * Measures the piece-square value from the perspective of the last player to move. @@ -119,33 +109,28 @@ -} measurePieceSquareValueIncrementally :: ( #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + 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, - Num pieceSquareValue, - Ord x, - Ord y + Num pieceSquareValue ) => pieceSquareValue -- ^ The value before the last move was applied, & therefore also from the perspective of the previous player. - -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue - -> Model.Game.Game x y + -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue + -> Model.Game.Game -> 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 #-} +{-# SPECIALISE measurePieceSquareValueIncrementally :: Type.Mass.PieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue -> Model.Game.Game -> Type.Mass.PieceSquareValue #-} measurePieceSquareValueIncrementally previousPieceSquareValue pieceSquareByCoordinatesByRank game - | Attribute.MoveType.isQuiet $ Component.QualifiedMove.getMoveType qualifiedMove = let - findPieceSquareValues coordinatesList = Component.PieceSquareByCoordinatesByRank.findPieceSquareValues ( - State.Board.getNPieces $ Model.Game.getBoard game -- N.B.: no capture occurred. + | Attribute.MoveType.isSimple $ Component.QualifiedMove.getMoveType qualifiedMove = let + findPieceSquareValue = uncurry ( + Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank ) ( - Property.Opposable.getOpposite $ Model.Game.getNextLogicalColour game -- The last player to move. + State.Board.getNPieces {- N.B.: no capture occurred-} . Model.Game.getBoard &&& Property.Opposable.getOpposite . Model.Game.getNextLogicalColour $ game {-the last player to move-} ) ( Component.Turn.getRank turn -- N.B.: no promotion occurred. - ) coordinatesList pieceSquareByCoordinatesByRank - - (destination, source) = Component.Move.getDestination &&& Component.Move.getSource $ Component.QualifiedMove.getMove qualifiedMove - [destinationPieceSquareValue, sourcePiecesquareValue] = findPieceSquareValues [destination, source] - in (destinationPieceSquareValue - sourcePiecesquareValue) - previousPieceSquareValue {-from the previous player's perspective-} - | otherwise = measurePieceSquareValue pieceSquareByCoordinatesByRank game -- N.B.: though Castling, En-passant, & promotion, can also be calculated, the returns don't justify the effort. + ) + in uncurry (-) ( + findPieceSquareValue . Component.Move.getDestination &&& findPieceSquareValue . Component.Move.getSource $ Component.QualifiedMove.getMove qualifiedMove + ) - previousPieceSquareValue {-from the previous player's perspective-} + | otherwise = measurePieceSquareValue pieceSquareByCoordinatesByRank game -- N.B.: though non-simple (Castling, En-passant, promotion) can be calculated, the returns don't justify the effort. where Just turn = Model.Game.maybeLastTurn game qualifiedMove = Component.Turn.getQualifiedMove turn @@ -154,11 +139,10 @@ measureValueOfMaterial :: Input.RankValues.RankValues -> Type.Mass.RankValue -- ^ Maximum total rank-value. - -> Model.Game.Game x y + -> Model.Game.Game -> 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. +measureValueOfMaterial rankValues maximumTotalRankValue game = realToFrac . ( + / maximumTotalRankValue -- Normalise. ) . ( if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game then id -- White just moved. @@ -166,7 +150,7 @@ ) . Data.List.foldl' ( \acc (rank, nPiecesDifference) -> if nPiecesDifference == 0 then acc -- Avoid calling 'Input.RankValues.findRankValue'. - else acc + toRational ( + else acc + realToFrac ( 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 @@ -191,26 +175,19 @@ This presents a paradox ! -} -measureValueOfMobility :: ( - 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 (-) . ( +measureValueOfMobility :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfMobility game = realToFrac . uncurry (-) . ( measureConstriction &&& measureConstriction . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where + measureConstriction :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue measureConstriction logicalColour = recip . fromIntegral {-NPlies-} . succ {-avoid divide-by-zero-} $ Model.Game.countPliesAvailableTo logicalColour game -- | Measure the arithmetic difference between the potential to /Castle/, on either side. -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 (-) . ( +measureValueOfCastlingPotential :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfCastlingPotential game = realToFrac . uncurry (-) . ( castlingPotential . Property.Opposable.getOpposite {-recent mover-} &&& castlingPotential ) $ Model.Game.getNextLogicalColour game where + castlingPotential :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue castlingPotential = Data.Maybe.maybe 1 {-have Castled-} ( (/ 2) . fromIntegral . length ) . ( @@ -224,15 +201,17 @@ * 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 :: 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. +measureValueOfDoubledPawns :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfDoubledPawns game = realToFrac . ( + / ( + 6 :: Type.Mass.CriterionValue -- 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 {-NPieces-} . uncurry (-) . ( countDoubledPawns &&& countDoubledPawns . Property.Opposable.getOpposite {-recent mover-} ) $ Model.Game.getNextLogicalColour game where + countDoubledPawns :: Attribute.LogicalColour.LogicalColour -> Type.Count.NPieces countDoubledPawns logicalColour = uncurry (-) . ( - 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-} + Data.Foldable.foldl' (+) 0 &&& fromIntegral . Data.Foldable.length {-one Pawn can't be considered to be doubled, so substract one Pawn per column-} ) $ State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour {- | @@ -240,37 +219,34 @@ * 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, 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, ...). +measureValueOfIsolatedPawns :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfIsolatedPawns game = realToFrac . ( + / ( + fromIntegral {-X-} Cartesian.Abscissa.xLength :: Type.Mass.CriterionValue -- 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 -> Type.Count.NPieces - countIsolatedPawns logicalColour = Data.Map.Strict.foldlWithKey' ( - \acc x nPawns -> ( - if (`Data.Map.Strict.member` nPawnsByFile) `any` Cartesian.Abscissa.getAdjacents x - then id -- This file has at least one neighbouring Pawn which can (if at a suitable rank) be used to protect any of those in this file. - else (+ nPawns) -- All the Pawns on this file are isolated & thus lack the protection that may be offered by adjacent Pawns. - ) acc + countIsolatedPawns logicalColour = Map.foldlWithKey' ( + \acc x nPawns -> if (`Map.member` nPawnsByFile) `any` Cartesian.Abscissa.getAdjacents x + then acc -- This file has at least one neighbouring Pawn which can (if at a suitable rank) be used to protect any of those in this file. + else acc + nPawns -- All the Pawns on this file are isolated & thus lack the protection that may be offered by adjacent Pawns. ) 0 nPawnsByFile where 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. 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]. +measureValueOfPassedPawns :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfPassedPawns game = realToFrac . ( + / fromIntegral {-X-} Cartesian.Abscissa.xLength -- Normalise to [-1 .. 1]; the optimal scenario is all files containing exactly one Pawn, of one's own logical colour, on the 7th rank. ) . uncurry (-) . ( valuePassedPawns . Property.Opposable.getOpposite {-recent mover-} &&& valuePassedPawns ) $ Model.Game.getNextLogicalColour game where + valuePassedPawns :: Attribute.LogicalColour.LogicalColour -> Type.Mass.CriterionValue valuePassedPawns logicalColour = Data.List.foldl' ( - \acc -> (acc +) . recip {-value increases exponentially as distance to promotion decreases-} . fromIntegral {-Int-} . abs . subtract ( - fromEnum ( - Cartesian.Ordinate.lastRank logicalColour :: y -- N.B.: ScopedTypeVariables. - ) - ) . fromEnum . Cartesian.Coordinates.getY -- Measure the distance to promotion. + \acc -> (acc +) . recip {-value increases exponentially as distance to promotion decreases-} . fromIntegral . abs . subtract ( + Cartesian.Ordinate.lastRank logicalColour + ) . Cartesian.Coordinates.getY -- Measure the distance to promotion. ) 0 $ State.Board.getPassedPawnCoordinatesByLogicalColour (Model.Game.getBoard game) ! logicalColour {- | @@ -301,10 +277,11 @@ * CAVEAT: this criterion competes with /mobility/, since each defended /piece/ blocks the path of the defender. -} -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. +measureValueOfDefence :: Model.Game.Game -> Metric.CriterionValue.CriterionValue +measureValueOfDefence game = realToFrac . ( + / ( + fromIntegral {-NPieces-} maximumDefended :: Type.Mass.CriterionValue -- Normalise. + ) ) . fromIntegral {-NPieces-} . uncurry (-) . ( (! Property.Opposable.getOpposite {-recent mover-} nextLogicalColour) &&& (! nextLogicalColour) ) . State.Board.summariseNDefendersByLogicalColour $ Model.Game.getBoard game where @@ -323,21 +300,15 @@ -} evaluateFitness :: ( #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + 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 pieceSquareValue, - Ord x, - Ord y, - Real pieceSquareValue, - Show x, - Show y + Fractional pieceSquareValue, + Real pieceSquareValue ) => Maybe pieceSquareValue -- ^ An optional value for the specified game. - -> Model.Game.Game x y - -> 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 #-} + -> Model.Game.Game + -> Input.EvaluationOptions.Reader pieceSquareValue Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues +{-# SPECIALISE evaluateFitness :: Maybe Type.Mass.PieceSquareValue -> Model.Game.Game -> Input.EvaluationOptions.Reader Type.Mass.PieceSquareValue Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues #-} evaluateFitness maybePieceSquareValue game | Just gameTerminationReason <- Model.Game.getMaybeTerminationReason game = return {-to Reader-monad-} $ Metric.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues ( if Rule.GameTerminationReason.isCheckMate gameTerminationReason @@ -354,9 +325,9 @@ ) ( measureValueOfMobility game ) ( - Data.Maybe.maybe 0 mkPieceSquareCriterionValue $ maybePieceSquareValue <|> fmap ( - `measurePieceSquareValue` game - ) maybePieceSquareByCoordinatesByRank + Data.Maybe.maybe 0 ( + realToFrac . (/ fromIntegral Component.Piece.nPiecesPerSide) + ) $ maybePieceSquareValue <|> fmap (`measurePieceSquareValue` game) maybePieceSquareByCoordinatesByRank ) ( measureValueOfCastlingPotential game ) ( diff --git a/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs b/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs --- a/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs +++ b/src-lib/BishBosh/Evaluation/PositionHashQuantifiedGameTree.hs @@ -81,12 +81,11 @@ 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.StateProperty.Hashable as StateProperty.Hashable 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 import qualified Data.Bits import qualified Data.Maybe import qualified Data.Tree @@ -96,43 +95,43 @@ #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 = MkNodeLabel { +data NodeLabel positionHash = MkNodeLabel { getPositionHash :: positionHash, -- ^ The hash of the /game/ contained in 'getQuantifiedGame'. - getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y + getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame } deriving (Eq, Show) -instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (NodeLabel x y positionHash) where +instance Notation.MoveNotation.ShowNotationFloat (NodeLabel positionHash) where showsNotationFloat moveNotation showsDouble MkNodeLabel { getQuantifiedGame = quantifiedGame } = Notation.MoveNotation.showsNotation moveNotation ( Evaluation.QuantifiedGame.getLastTurn quantifiedGame ) . showString "\t=> " . showsDouble ( realToFrac . Metric.WeightedMeanAndCriterionValues.getWeightedMean $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame ) -instance Property.Null.Null (NodeLabel x y positionHash) where +instance Property.Null.Null (NodeLabel 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) +equalsLastQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Data.RoseTree.IsMatch (NodeLabel 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 = Data.Tree.Tree (NodeLabel x y positionHash) +type BarePositionHashQuantifiedGameTree positionHash = Data.Tree.Tree (NodeLabel positionHash) -- | Accessor. -getRootQuantifiedGame' :: BarePositionHashQuantifiedGameTree x y positionHash -> Evaluation.QuantifiedGame.QuantifiedGame x y +getRootQuantifiedGame' :: BarePositionHashQuantifiedGameTree positionHash -> Evaluation.QuantifiedGame.QuantifiedGame getRootQuantifiedGame' Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame } } = quantifiedGame -- | Wrap the bare tree. -newtype PositionHashQuantifiedGameTree x y positionHash = MkPositionHashQuantifiedGameTree { - deconstruct :: BarePositionHashQuantifiedGameTree x y positionHash +newtype PositionHashQuantifiedGameTree positionHash = MkPositionHashQuantifiedGameTree { + deconstruct :: BarePositionHashQuantifiedGameTree positionHash } deriving Eq -instance Property.Arboreal.Prunable (PositionHashQuantifiedGameTree x y positionHash) where +instance Property.Arboreal.Prunable (PositionHashQuantifiedGameTree positionHash) where prune depth MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree $ Property.Arboreal.prune depth barePositionHashQuantifiedGameTree -instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree x y positionHash) where +instance Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree 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 @@ -141,41 +140,36 @@ toString nodeLabel = Notation.MoveNotation.showsNotationFloat moveNotation showsDouble nodeLabel "" -- | Constructor. -fromBarePositionHashQuantifiedGameTree :: BarePositionHashQuantifiedGameTree x y positionHash -> PositionHashQuantifiedGameTree x y positionHash +fromBarePositionHashQuantifiedGameTree :: BarePositionHashQuantifiedGameTree positionHash -> PositionHashQuantifiedGameTree positionHash fromBarePositionHashQuantifiedGameTree = MkPositionHashQuantifiedGameTree -- | Constructor. mkPositionHashQuantifiedGameTree :: ( - 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). + Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). #endif - Data.Bits.Bits positionHash, - Fractional pieceSquareValue, - Integral x, - Integral y, - Real pieceSquareValue, - Show x, - Show y + Data.Bits.Bits positionHash, + Fractional pieceSquareValue, + Real pieceSquareValue ) - => Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y + => Input.EvaluationOptions.EvaluationOptions pieceSquareValue -> 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 + -> Component.Zobrist.Zobrist positionHash + -> Model.GameTree.MoveFrequency + -> Model.Game.Game -- ^ The current state of the /game/. + -> PositionHashQuantifiedGameTree positionHash {-# SPECIALISE mkPositionHashQuantifiedGameTree - :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y + :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue -> Input.SearchOptions.SearchOptions - -> 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 + -> Component.Zobrist.Zobrist Type.Crypto.PositionHash + -> Model.GameTree.MoveFrequency + -> Model.Game.Game + -> PositionHashQuantifiedGameTree Type.Crypto.PositionHash #-} mkPositionHashQuantifiedGameTree evaluationOptions searchOptions zobrist moveFrequency seedGame = MkPositionHashQuantifiedGameTree ( if Input.EvaluationOptions.getIncrementalEvaluation evaluationOptions then let - apexPositionHash = Component.Zobrist.hash2D seedGame zobrist + apexPositionHash = StateProperty.Hashable.hash seedGame zobrist in Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel apexPositionHash $ Control.Monad.Reader.runReader ( Evaluation.QuantifiedGame.fromGame Nothing seedGame @@ -215,7 +209,7 @@ } else fmap ( uncurry MkNodeLabel . ( - (`Component.Zobrist.hash2D` zobrist) &&& (`Control.Monad.Reader.runReader` evaluationOptions) . Evaluation.QuantifiedGame.fromGame Nothing + (`StateProperty.Hashable.hash` zobrist) &&& (`Control.Monad.Reader.runReader` evaluationOptions) . Evaluation.QuantifiedGame.fromGame Nothing ) ) bareGameTree ) where @@ -226,7 +220,7 @@ ) moveFrequency $ Model.GameTree.fromGame seedGame -- | Accessor. -getRootPositionHash :: PositionHashQuantifiedGameTree x y positionHash -> positionHash +getRootPositionHash :: PositionHashQuantifiedGameTree positionHash -> positionHash getRootPositionHash MkPositionHashQuantifiedGameTree { deconstruct = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash } @@ -234,7 +228,7 @@ } = positionHash -- | Accessor. -getRootQuantifiedGame :: PositionHashQuantifiedGameTree x y positionHash -> Evaluation.QuantifiedGame.QuantifiedGame x y +getRootQuantifiedGame :: PositionHashQuantifiedGameTree positionHash -> Evaluation.QuantifiedGame.QuantifiedGame getRootQuantifiedGame MkPositionHashQuantifiedGameTree { deconstruct = Data.Tree.Node { Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame } @@ -243,29 +237,28 @@ -- | Forward request. reduce - :: Data.RoseTree.IsMatch (NodeLabel x y positionHash) - -> PositionHashQuantifiedGameTree x y positionHash - -> Maybe (PositionHashQuantifiedGameTree x y positionHash) + :: Data.RoseTree.IsMatch (NodeLabel positionHash) + -> PositionHashQuantifiedGameTree positionHash + -> Maybe (PositionHashQuantifiedGameTree 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)) - -> PositionHashQuantifiedGameTree x y positionHash - -> [Component.Turn.Turn x y] - -> Maybe [NodeLabel x y positionHash] + :: (Component.Turn.Turn -> Data.RoseTree.IsMatch (NodeLabel positionHash)) + -> PositionHashQuantifiedGameTree positionHash + -> [Component.Turn.Turn] + -> Maybe [NodeLabel 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 - -> [Component.QualifiedMove.QualifiedMove x y] - -> Maybe [NodeLabel x y positionHash] -- ^ Returns 'Nothing', on failure to match a move. + :: PositionHashQuantifiedGameTree positionHash + -> [Component.QualifiedMove.QualifiedMove] + -> Maybe [NodeLabel 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 -> PositionHashQuantifiedGameTree x y positionHash +resign :: PositionHashQuantifiedGameTree positionHash -> PositionHashQuantifiedGameTree positionHash resign MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree@Data.Tree.Node { Data.Tree.rootLabel = nodeLabel@MkNodeLabel { getQuantifiedGame = quantifiedGame } @@ -277,7 +270,7 @@ } -- | Self-documentation. -type Forest x y positionHash = [BarePositionHashQuantifiedGameTree x y positionHash] +type Forest positionHash = [BarePositionHashQuantifiedGameTree positionHash] {- | * Promotes the first matching /move/ to the head of the forest, then descends & recursively promotes the next matching move in the sub-forest. @@ -285,10 +278,9 @@ * N.B.: this can be used to dynamically re-order the forest when a transposition is detected. -} 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 - -> Maybe (Forest x y positionHash) -- ^ Returns 'Nothing' on failure to match a move. + :: [Component.QualifiedMove.QualifiedMove] -- ^ The list of qualifiedMoves, which should be promoted at successively deeper levels in the tree. + -> Forest positionHash + -> Maybe (Forest positionHash) -- ^ Returns 'Nothing' on failure to match a move. promoteMatchingMoves = Data.RoseTree.promote equalsLastQualifiedMove {- | @@ -297,9 +289,9 @@ * N.B.: this can be used to dynamically re-order the forest using the killer heuristic. -} sortNonCaptureMoves - :: (Forest x y positionHash -> Forest x y positionHash) - -> Forest x y positionHash - -> Forest x y positionHash + :: (Forest positionHash -> Forest positionHash) + -> Forest positionHash + -> Forest 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 @@ -65,7 +65,6 @@ 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 @@ -77,50 +76,43 @@ #endif -- | The selected /game/ & the criteria against which it was quantified. -data QuantifiedGame x y = MkQuantifiedGame { - getGame :: Model.Game.Game x y, -- ^ The /game/ resulting from a sequence of /turn/s. +data QuantifiedGame = MkQuantifiedGame { + getGame :: Model.Game.Game, -- ^ The /game/ resulting from a sequence of /turn/s. getWeightedMeanAndCriterionValues :: Metric.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues } deriving (Eq, Show) -instance Control.DeepSeq.NFData (QuantifiedGame x y) where +instance Control.DeepSeq.NFData QuantifiedGame where rnf MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Control.DeepSeq.rnf weightedMeanAndCriterionValues -- The other field is a prerequisite. -instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotationFloat (QuantifiedGame x y) where +instance Notation.MoveNotation.ShowNotationFloat QuantifiedGame where showsNotationFloat moveNotation showsDouble quantifiedGame = Text.ShowList.showsAssociationList Text.ShowList.showsSeparator $ map ($ quantifiedGame) [ (,) Component.Move.tag . Notation.MoveNotation.showsNotation moveNotation . getLastTurn, (,) 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) where +instance Property.Null.Null QuantifiedGame where isNull MkQuantifiedGame { getGame = game } = Property.Null.isNull game -- | Accessor. -getFitness :: QuantifiedGame x y -> Type.Mass.WeightedMean +getFitness :: QuantifiedGame -> Type.Mass.WeightedMean getFitness MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = Metric.WeightedMeanAndCriterionValues.getWeightedMean weightedMeanAndCriterionValues -- | Constructor. fromGame :: ( #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + 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 pieceSquareValue, - Ord x, - Ord y, - Real pieceSquareValue, - Show x, - Show y + Fractional pieceSquareValue, + Real pieceSquareValue ) => Maybe pieceSquareValue -- ^ The value for the specified game. - -> Model.Game.Game x y -- ^ The current state of the /game/. - -> 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) #-} + -> Model.Game.Game -- ^ The current state of the /game/. + -> Input.EvaluationOptions.Reader pieceSquareValue QuantifiedGame fromGame maybePieceSquareValue game = MkQuantifiedGame game `fmap` Evaluation.Fitness.evaluateFitness maybePieceSquareValue game -- | Retrieve the /turn/ used to generate the selected /game/. -getLastTurn :: QuantifiedGame x y -> Component.Turn.Turn x y +getLastTurn :: QuantifiedGame -> Component.Turn.Turn 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 @@ -128,16 +120,16 @@ -- | Drop the specified number of plies from the start of the chronological sequence, leaving the most recent. getLatestTurns :: Type.Count.NPlies -- ^ The number of plies to drop from the start of the chronological sequence. - -> QuantifiedGame x y - -> [Component.Turn.Turn x y] + -> QuantifiedGame + -> [Component.Turn.Turn] 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 :: QuantifiedGame x y -> QuantifiedGame x y +negateFitness :: QuantifiedGame -> QuantifiedGame negateFitness quantifiedGame@MkQuantifiedGame { getWeightedMeanAndCriterionValues = weightedMeanAndCriterionValues } = quantifiedGame { getWeightedMeanAndCriterionValues = Metric.WeightedMeanAndCriterionValues.negateWeightedMean weightedMeanAndCriterionValues } -- | Compares fitness. -compareFitness :: QuantifiedGame x y -> QuantifiedGame x y -> Ordering +compareFitness :: QuantifiedGame -> QuantifiedGame -> Ordering compareFitness = Data.Ord.comparing getFitness {- | @@ -145,13 +137,13 @@ * N.B.: 'Nothing' is interpreted as unbounded. -} -type OpenInterval x y = (Maybe (QuantifiedGame x y), Maybe (QuantifiedGame x y)) +type OpenInterval = (Maybe QuantifiedGame, Maybe QuantifiedGame) -- | Constant. -unboundedInterval :: OpenInterval x y +unboundedInterval :: OpenInterval unboundedInterval = (Nothing, Nothing) -- | Reflect the interval about zero. -negateInterval :: OpenInterval x y -> OpenInterval x y +negateInterval :: OpenInterval -> OpenInterval negateInterval (maybeAlpha, maybeBeta) = ($ maybeBeta) &&& ($ maybeAlpha) $ fmap negateFitness 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 @@ -48,11 +48,9 @@ -- weightOfDoubledPawnsTag, -- weightOfIsolatedPawnsTag, -- weightOfPassedPawnsTag, --- onymousOperators, -- * Functions calculateWeightedMean, normalise, --- perturbWeights, -- ** Constructor mkCriteriaWeights ) where @@ -63,12 +61,10 @@ 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 -- | Used to qualify the XML. @@ -320,81 +316,4 @@ 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 - :: System.Random.RandomGen randomGen - => randomGen - -> Type.Mass.CriterionWeight -- ^ Change-magnitude. - -> Transformation -perturbWeights _ 0 criteriaWeights = criteriaWeights -perturbWeights randomGen changeMagnitude MkCriteriaWeights { - getWeightOfMaterial = weightOfMaterial, - getWeightOfMobility = weightOfMobility, - getWeightOfPieceSquareValue = weightOfPieceSquareValue, - getWeightOfCastlingPotential = weightOfCastlingPotential, - getWeightOfDefence = weightOfDefence, - getWeightOfDoubledPawns = weightOfDoubledPawns, - getWeightOfIsolatedPawns = weightOfIsolatedPawns, - getWeightOfPassedPawns = weightOfPassedPawns -} = Control.Exception.assert (changeMagnitude > 0) $ normalise MkCriteriaWeights { - getWeightOfMaterial = reduceBy a weightOfMaterial, - getWeightOfMobility = reduceBy b weightOfMobility, - getWeightOfPieceSquareValue = reduceBy c weightOfPieceSquareValue, - getWeightOfCastlingPotential = reduceBy d weightOfCastlingPotential, - getWeightOfDefence = reduceBy e weightOfDefence, - getWeightOfDoubledPawns = reduceBy f weightOfDoubledPawns, - getWeightOfIsolatedPawns = reduceBy g weightOfIsolatedPawns, - getWeightOfPassedPawns = reduceBy h weightOfPassedPawns -} where - (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 -> Metric.CriterionWeight.CriterionWeight, -- Accessor. - Metric.CriterionWeight.CriterionWeight -> Transformation -- Mutator. - ) -- Triple. - ] -onymousOperators = [ - ( - weightOfMaterialTag, - getWeightOfMaterial, - \w criteriaWeights -> criteriaWeights { getWeightOfMaterial = w } - ), ( - weightOfMobilityTag, - getWeightOfMobility, - \w criteriaWeights -> criteriaWeights { getWeightOfMobility = w } - ), ( - weightOfPieceSquareValueTag, - getWeightOfPieceSquareValue, - \w criteriaWeights -> criteriaWeights { getWeightOfPieceSquareValue = w } - ), ( - weightOfCastlingPotentialTag, - getWeightOfCastlingPotential, - \w criteriaWeights -> criteriaWeights { getWeightOfCastlingPotential = w } - ), ( - weightOfDefenceTag, - getWeightOfDefence, - \w criteriaWeights -> criteriaWeights { getWeightOfDefence = w } - ), ( - weightOfDoubledPawnsTag, - getWeightOfDoubledPawns, - \w criteriaWeights -> criteriaWeights { getWeightOfDoubledPawns = w } - ), ( - weightOfIsolatedPawnsTag, - getWeightOfIsolatedPawns, - \w criteriaWeights -> criteriaWeights { getWeightOfIsolatedPawns = w } - ), ( - weightOfPassedPawnsTag, - getWeightOfPassedPawns, - \w criteriaWeights -> criteriaWeights { getWeightOfPassedPawns = w } - ) - ] diff --git a/src-lib/BishBosh/Input/EvaluationOptions.hs b/src-lib/BishBosh/Input/EvaluationOptions.hs --- a/src-lib/BishBosh/Input/EvaluationOptions.hs +++ b/src-lib/BishBosh/Input/EvaluationOptions.hs @@ -69,10 +69,9 @@ import qualified Control.DeepSeq import qualified Control.Exception import qualified Control.Monad.Reader -import qualified Data.Array.IArray import qualified Data.Default +import qualified Data.Foldable import qualified Data.Maybe -import qualified Data.Set import qualified Text.XML.HXT.Arrow.Pickle as HXT -- | Used to qualify XML. @@ -95,25 +94,21 @@ type IncrementalEvaluation = Bool -- | A pair of piece-square tables representing the opening & end-games respectively. -type PieceSquareTablePair x y pieceSquareValue = (Input.PieceSquareTable.PieceSquareTable x y pieceSquareValue, Input.PieceSquareTable.PieceSquareTable x y pieceSquareValue) +type PieceSquareTablePair pieceSquareValue = (Input.PieceSquareTable.PieceSquareTable pieceSquareValue, Input.PieceSquareTable.PieceSquareTable pieceSquareValue) -- | Defines the options related to the automatic selection of /move/s. -data EvaluationOptions pieceSquareValue x y = MkEvaluationOptions { +data EvaluationOptions pieceSquareValue = MkEvaluationOptions { getRankValues :: Input.RankValues.RankValues, -- ^ The static value associated with each /piece/'s /rank/. getMaximumTotalRankValue :: Type.Mass.RankValue, -- ^ Used to normalise the total value of pieces. Derived from 'getRankValues'. getCriteriaWeights :: Input.CriteriaWeights.CriteriaWeights, -- ^ The weights applied to each of the heterogeneous criterion-values used to select a /move/. getIncrementalEvaluation :: IncrementalEvaluation, -- ^ Whether to generate position-hashes & evaluate the piece-square value, from the previous value or from scratch. - getMaybePieceSquareTablePair :: Maybe (PieceSquareTablePair x y pieceSquareValue), -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. + getMaybePieceSquareTablePair :: Maybe (PieceSquareTablePair pieceSquareValue), -- ^ A optional pair of piece-square tables representing the opening & end-games respectively. getMaybePieceSquareByCoordinatesByRank :: Maybe ( - Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue + Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue ) -- ^ The optional value for each rank of /piece/, when occupying each coordinate, at each phase of the game. } deriving (Eq, Show) -instance ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (EvaluationOptions pieceSquareValue x y) where +instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (EvaluationOptions pieceSquareValue) where rnf MkEvaluationOptions { -- getRankValues = rankValues, getMaximumTotalRankValue = maximumTotalValue, @@ -123,14 +118,7 @@ getMaybePieceSquareByCoordinatesByRank = maybePieceSquareByCoordinatesByRank } = Control.DeepSeq.rnf (maximumTotalValue, criteriaWeights, incrementalEvaluation, maybePieceSquareByCoordinatesByRank) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Real pieceSquareValue, - Show pieceSquareValue - ) => Property.ShowFloat.ShowFloat (EvaluationOptions pieceSquareValue x y) where +instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (EvaluationOptions pieceSquareValue) where showsFloat fromDouble MkEvaluationOptions { getRankValues = rankValues, -- getMaximumTotalRankValue = maximumTotalValue, @@ -158,7 +146,7 @@ ] ) maybePieceSquareTablePair -instance Data.Default.Default (EvaluationOptions pieceSquareValue x y) where +instance Data.Default.Default (EvaluationOptions pieceSquareValue) where def = MkEvaluationOptions { getRankValues = rankValues, getMaximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues, @@ -170,15 +158,11 @@ rankValues = Data.Default.def instance ( - Enum x, - Enum y, Fractional pieceSquareValue, Ord pieceSquareValue, - Ord x, - Ord y, Real pieceSquareValue, Show pieceSquareValue - ) => HXT.XmlPickler (EvaluationOptions pieceSquareValue x y) where + ) => HXT.XmlPickler (EvaluationOptions pieceSquareValue) where xpickle = HXT.xpDefault def . HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d) -> mkEvaluationOptions a b c d, -- Construct. \MkEvaluationOptions { @@ -200,55 +184,46 @@ def = Data.Default.def -- | Convert a /PieceSquareTablePair/ to a single linearly interpolated array. -fromPieceSquareTablePair :: ( - Enum x, - Enum y, - Fractional pieceSquareValue, - Ord x, - Ord y - ) => PieceSquareTablePair x y pieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue +fromPieceSquareTablePair :: Fractional pieceSquareValue => PieceSquareTablePair pieceSquareValue -> Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue fromPieceSquareTablePair pieceSquareTablePair = Component.PieceSquareByCoordinatesByRank.mkPieceSquareByCoordinatesByRank $ \rank -> ( \(openingGamePieceSquareValuesByCoordinates, maybeEndGamePieceSquareValuesByCoordinates) -> Data.Maybe.maybe ( Left openingGamePieceSquareValuesByCoordinates ) ( Right . Cartesian.Coordinates.listArrayByCoordinates . zipWith Component.PieceSquareByCoordinatesByRank.interpolatePieceSquareValues ( - Data.Array.IArray.elems openingGamePieceSquareValuesByCoordinates - ) . Data.Array.IArray.elems + Data.Foldable.toList openingGamePieceSquareValuesByCoordinates + ) . Data.Foldable.toList ) maybeEndGamePieceSquareValuesByCoordinates ) $ ( Data.Maybe.fromJust {-values for the openingGame must be specified-} . Input.PieceSquareTable.dereference rank *** Input.PieceSquareTable.dereference rank ) pieceSquareTablePair -- | Smart constructor. -mkEvaluationOptions :: ( - Enum x, - Enum y, - Fractional pieceSquareValue, - Ord x, - Ord y - ) +mkEvaluationOptions + :: Fractional pieceSquareValue => Input.RankValues.RankValues -- ^ The static value associated with each /piece/'s /rank/. -> Input.CriteriaWeights.CriteriaWeights -- ^ The weights applied to the values of the criteria used to select a /move/. -> IncrementalEvaluation - -> 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 + -> Maybe (PieceSquareTablePair pieceSquareValue) -- ^ The value to each type of piece, of each square, during normal play & the end-game. + -> EvaluationOptions pieceSquareValue mkEvaluationOptions rankValues criteriaWeights incrementalEvaluation maybePieceSquareTablePair | Just (pieceSquareTable, _) <- maybePieceSquareTablePair , let undefinedRanks = Input.PieceSquareTable.findUndefinedRanks pieceSquareTable - , not $ Data.Set.null undefinedRanks - = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.Input.EvaluationOptions.mkEvaluationOptions:\tranks" . Text.ShowList.showsAssociation $ shows (Data.Set.toList undefinedRanks) " are undefined." + , not $ Data.Foldable.null undefinedRanks + = Control.Exception.throw . Data.Exception.mkInsufficientData . showString "BishBosh.Input.EvaluationOptions.mkEvaluationOptions:\tranks" . Text.ShowList.showsAssociation $ shows (Data.Foldable.toList undefinedRanks) " are undefined." | Input.CriteriaWeights.getWeightOfPieceSquareValue criteriaWeights /= minBound , Data.Maybe.isNothing maybePieceSquareTablePair = 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." + | maximumTotalRankValue == 0 && Input.CriteriaWeights.getWeightOfMaterial criteriaWeights /= 0 = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.EvaluationOptions.mkEvaluationOptions:\tweight of " . shows Input.CriteriaWeights.weightOfMaterialTag . showString " is non-zero, but the maximum total rank-value is " $ shows rankValues "." | otherwise = MkEvaluationOptions { getRankValues = rankValues, - getMaximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues, -- Infer. + getMaximumTotalRankValue = maximumTotalRankValue, getCriteriaWeights = criteriaWeights, getIncrementalEvaluation = incrementalEvaluation, getMaybePieceSquareTablePair = maybePieceSquareTablePair, getMaybePieceSquareByCoordinatesByRank = fromPieceSquareTablePair `fmap` maybePieceSquareTablePair -- Infer. - } + } where + maximumTotalRankValue = Input.RankValues.calculateMaximumTotalValue rankValues -- | Self-documentation. -type Reader pieceSquareValue x y = Control.Monad.Reader.Reader (EvaluationOptions pieceSquareValue x y) +type Reader pieceSquareValue = Control.Monad.Reader.Reader (EvaluationOptions pieceSquareValue) 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 @@ -25,6 +25,7 @@ module BishBosh.Input.IOOptions( -- * Types -- ** Type-synonyms +-- PersistenceSpecification, -- Transformation, -- ** Data-types IOOptions( @@ -43,6 +44,7 @@ -- filePathTag, -- automaticTag, -- * Functions + persist, -- ** Constructor mkIOOptions, -- ** Mutators @@ -54,22 +56,26 @@ setVerbosity ) where -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Data.Foldable as Data.Foldable -import qualified BishBosh.Input.CECPFeatures as Input.CECPFeatures -import qualified BishBosh.Input.PGNOptions as Input.PGNOptions -import qualified BishBosh.Input.UIOptions as Input.UIOptions -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 BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Data.Foldable as Data.Foldable +import qualified BishBosh.Input.CECPFeatures as Input.CECPFeatures +import qualified BishBosh.Input.PGNOptions as Input.PGNOptions +import qualified BishBosh.Input.UIOptions as Input.UIOptions +import qualified BishBosh.Input.Verbosity as Input.Verbosity +import qualified BishBosh.Property.Arboreal as Property.Arboreal +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.Type.Count as Type.Count import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception +import qualified Control.Monad import qualified Data.Default import qualified Data.Maybe import qualified System.FilePath -import qualified Text.XML.HXT.Arrow.Pickle as HXT +import qualified System.IO +import qualified Text.XML.HXT.Arrow.Pickle as HXT -- | Used to qualify XML. tag :: String @@ -95,13 +101,16 @@ automaticTag :: String automaticTag = "automatic" +-- | The path to a file, into which game-state can be persisted (obliterating any existing content), & whether to save this state automatically after each move. +type PersistenceSpecification = (System.FilePath.FilePath, Bool) + -- | Defines options related to i/o. 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 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 -- ^ Options which define the user-interface. + 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 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 PersistenceSpecification, -- ^ 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 -- ^ Options which define the user-interface. } deriving Eq instance Control.DeepSeq.NFData IOOptions where @@ -179,10 +188,10 @@ -- | 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 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. + :: 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 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 PersistenceSpecification -- ^ 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 -> IOOptions mkIOOptions maybeOutputConfigFilePath maybeMaximumPGNNames pgnOptionsList maybePersistence uiOptions @@ -206,6 +215,26 @@ } where duplicateFilePaths = Data.Foldable.findDuplicates $ map (System.FilePath.normalise . Input.PGNOptions.getDatabaseFilePath) pgnOptionsList + +-- | Persist the specified game to file. +persist + :: Show game + => IOOptions + -> Bool -- ^ Verbose. + -> game + -> IO () +persist MkIOOptions { + getMaybePersistence = maybePersistence +} verbose game = Data.Maybe.maybe ( + return {-to IO-monad-} () + ) ( + \(filePath, automatic) -> Control.Monad.when automatic . Control.Exception.catch ( + do + System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPrint` game) + + Control.Monad.when verbose . System.IO.hPutStrLn System.IO.stderr . Text.ShowColouredPrefix.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) + ) maybePersistence -- | The type of a function used to transform 'IOOptions'. type Transformation = IOOptions -> IOOptions 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 @@ -26,11 +26,13 @@ -- * Types -- ** Type-synonyms -- ScreenCoordinates, +-- DepictFigurine, -- ** Data-types NativeUIOptions( -- MkNativeUIOptions, getBoardMagnification, - getColourScheme + getColourScheme, + getDepictFigurine ), -- * Constants tag, @@ -42,6 +44,7 @@ mkNativeUIOptions ) where +import BishBosh.Data.Bool() import Control.Arrow((***)) import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme import qualified BishBosh.Data.Exception as Data.Exception @@ -61,6 +64,10 @@ boardMagnificationTag = "boardMagnification" -- | Used to qualify XML. +depictFigurineTag :: String +depictFigurineTag = "depictFigurine" + +-- | Used to qualify XML. nRowsTag :: String nRowsTag = "nRows" @@ -71,25 +78,32 @@ -- | 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) +-- | Whether to a depict a piece using a Unicode figurine. +type DepictFigurine = Bool + -- | Constructor. data NativeUIOptions = MkNativeUIOptions { getBoardMagnification :: ScreenCoordinates, -- ^ The factor by which the dimensions of the board are stretched when displayed. - getColourScheme :: Attribute.ColourScheme.ColourScheme + getColourScheme :: Attribute.ColourScheme.ColourScheme, + getDepictFigurine :: DepictFigurine -- ^ Whether to a depict pieces using Unicode figurines. } deriving Eq instance Control.DeepSeq.NFData NativeUIOptions where rnf MkNativeUIOptions { getBoardMagnification = boardMagnification, - getColourScheme = colourScheme + getColourScheme = colourScheme, + getDepictFigurine = depictFigurine } = Control.DeepSeq.rnf ( boardMagnification, - colourScheme + colourScheme, + depictFigurine ) instance Show NativeUIOptions where showsPrec precision MkNativeUIOptions { getBoardMagnification = boardMagnification, - getColourScheme = colourScheme + getColourScheme = colourScheme, + getDepictFigurine = depictFigurine } = Text.ShowList.showsAssociationList' [ ( boardMagnificationTag, @@ -97,31 +111,39 @@ ), ( Attribute.ColourScheme.tag, showsPrec precision colourScheme + ), ( + depictFigurineTag, + showsPrec precision depictFigurine ) ] instance Data.Default.Default NativeUIOptions where def = MkNativeUIOptions { getBoardMagnification = (1, 1), - getColourScheme = Data.Default.def + getColourScheme = Data.Default.def, + getDepictFigurine = False } instance HXT.XmlPickler NativeUIOptions where xpickle = HXT.xpElem tag . HXT.xpWrap ( - uncurry mkNativeUIOptions, -- Construct. + \(a, b, c) -> mkNativeUIOptions a b c, -- Construct. \MkNativeUIOptions { getBoardMagnification = boardMagnification, - getColourScheme = colourScheme + getColourScheme = colourScheme, + getDepictFigurine = depictFigurine } -> ( boardMagnification, - colourScheme + colourScheme, + depictFigurine ) - ) $ HXT.xpPair ( + ) $ HXT.xpTriple ( getBoardMagnification def `HXT.xpDefault` HXT.xpElem boardMagnificationTag ( HXT.xpAttr nRowsTag HXT.xpickle `HXT.xpPair` HXT.xpAttr nColumnsTag HXT.xpickle ) ) ( getColourScheme def `HXT.xpDefault` HXT.xpickle + ) ( + getDepictFigurine def `HXT.xpDefault` HXT.xpAttr depictFigurineTag HXT.xpickle ) where def = Data.Default.def @@ -129,8 +151,9 @@ mkNativeUIOptions :: ScreenCoordinates -- ^ The factor by which the dimensions of the board are stretched when displayed. -> Attribute.ColourScheme.ColourScheme + -> DepictFigurine -> NativeUIOptions -mkNativeUIOptions boardMagnification colourScheme +mkNativeUIOptions boardMagnification colourScheme depictFigurine | uncurry (||) $ ( (< 1) *** (< 1) ) boardMagnification = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.NativeUIOptions.mkNativeUIOptions:\t" . showString boardMagnificationTag . Text.ShowList.showsAssociation $ shows boardMagnification " must both exceed zero." @@ -139,6 +162,7 @@ ) boardMagnification = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.NativeUIOptions.mkNativeUIOptions:\t" . showString boardMagnificationTag . Text.ShowList.showsAssociation $ shows boardMagnification " must both be odd." | otherwise = MkNativeUIOptions { getBoardMagnification = boardMagnification, - getColourScheme = colourScheme + getColourScheme = colourScheme, + getDepictFigurine = depictFigurine } diff --git a/src-lib/BishBosh/Input/Options.hs b/src-lib/BishBosh/Input/Options.hs --- a/src-lib/BishBosh/Input/Options.hs +++ b/src-lib/BishBosh/Input/Options.hs @@ -62,6 +62,7 @@ import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.IOOptions as Input.IOOptions +import qualified BishBosh.Input.PGNOptions as Input.PGNOptions import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Input.UIOptions as Input.UIOptions import qualified BishBosh.Input.Verbosity as Input.Verbosity @@ -92,19 +93,15 @@ type RandomSeed = Int -- | Defines the application's options. -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. +data Options pieceSquareValue = MkOptions { + getMaybeMaximumPlies :: Maybe Type.Count.NPlies, -- ^ The maximum number of plies before the game is terminated; required for profiling the application. + getMaybeRandomSeed :: Maybe RandomSeed, -- ^ Optionally seed the pseudo-random number-generator to produce a repeatable sequence. + getEvaluationOptions :: Input.EvaluationOptions.EvaluationOptions pieceSquareValue, -- ^ The single set of options by which all automated /move/s are evaluated. + getSearchOptions :: Input.SearchOptions.SearchOptions, -- ^ The options by which to automatically select /move/s. + getIOOptions :: Input.IOOptions.IOOptions -- ^ The /ioOptions/ by which to receive commands & present results. } deriving (Eq, Show) -instance ( - Control.DeepSeq.NFData pieceSquareValue, - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Options pieceSquareValue x y) where +instance Control.DeepSeq.NFData pieceSquareValue => Control.DeepSeq.NFData (Options pieceSquareValue) where rnf MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -113,14 +110,7 @@ getIOOptions = ioOptions } = Control.DeepSeq.rnf (maybeMaximumPlies, maybeRandomSeed, evaluationOptions, searchOptions, ioOptions) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Real pieceSquareValue, - Show pieceSquareValue - ) => Property.ShowFloat.ShowFloat (Options pieceSquareValue x y) where +instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (Options pieceSquareValue) where showsFloat fromDouble MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -144,7 +134,7 @@ ) ] -instance Data.Default.Default (Options pieceSquareValue x y) where +instance Data.Default.Default (Options pieceSquareValue) where def = MkOptions { getMaybeMaximumPlies = Nothing, getMaybeRandomSeed = Nothing, @@ -154,15 +144,11 @@ } instance ( - Enum x, - Enum y, Fractional pieceSquareValue, Ord pieceSquareValue, - Ord x, - Ord y, Real pieceSquareValue, Show pieceSquareValue - ) => HXT.XmlPickler (Options pieceSquareValue x y) where + ) => HXT.XmlPickler (Options pieceSquareValue) where xpickle = HXT.xpElem tag . HXT.xpWrap ( \(a, b, c, d, e) -> mkOptions a b c d e, -- Construct. \MkOptions { @@ -188,13 +174,16 @@ mkOptions :: Maybe Type.Count.NPlies -- ^ The maximum number of plies before the game is terminated; required for profiling the application. -> Maybe RandomSeed -- ^ Optionally seed the pseudo-random number-generator to produce a repeatable sequence. - -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y + -> Input.EvaluationOptions.EvaluationOptions pieceSquareValue -> Input.SearchOptions.SearchOptions -> Input.IOOptions.IOOptions - -> Options pieceSquareValue x y + -> Options pieceSquareValue 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." + | Input.SearchOptions.getSortOnStandardOpeningMoveFrequency searchOptions && null ( + Input.IOOptions.getPGNOptionsList ioOptions + ) = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.Options.mkOptions:\tcan't implement '" . showString Input.SearchOptions.tag . showChar '.' . showString Input.SearchOptions.sortOnStandardOpeningMoveFrequencyTag . showString "' without any '" . showString Input.PGNOptions.tag . showChar '.' $ showString Input.PGNOptions.databaseFilePathTag "'" | otherwise = MkOptions { getMaybeMaximumPlies = maybeMaximumPlies, getMaybeRandomSeed = maybeRandomSeed, @@ -204,22 +193,22 @@ } -- | The type of a function used to transform 'Options'. -type Transformation pieceSquareValue x y = Options pieceSquareValue x y -> Options pieceSquareValue x y +type Transformation pieceSquareValue = Options pieceSquareValue -> Options pieceSquareValue -- | Mutator. -setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation pieceSquareValue x y +setMaybeOutputConfigFilePath :: Maybe System.FilePath.FilePath -> Transformation pieceSquareValue setMaybeOutputConfigFilePath maybeOutputConfigFilePath options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybeOutputConfigFilePath maybeOutputConfigFilePath ioOptions } -- | Mutator. -setMaybeRandomSeed :: Maybe RandomSeed -> Transformation pieceSquareValue x y +setMaybeRandomSeed :: Maybe RandomSeed -> Transformation pieceSquareValue setMaybeRandomSeed maybeRandomSeed options = options { getMaybeRandomSeed = maybeRandomSeed } -- | Mutator. -setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation pieceSquareValue x y +setMaybePersistence :: Maybe (System.FilePath.FilePath, Bool) -> Transformation pieceSquareValue setMaybePersistence maybePersistence options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = ioOptions { Input.IOOptions.getMaybePersistence = maybePersistence @@ -227,25 +216,25 @@ } -- | Mutator. -setVerbosity :: Input.Verbosity.Verbosity -> Transformation pieceSquareValue x y +setVerbosity :: Input.Verbosity.Verbosity -> Transformation pieceSquareValue setVerbosity verbosity options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setVerbosity verbosity ioOptions } -- | Mutator. -setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation pieceSquareValue x y +setEitherNativeUIOrCECPOptions :: Input.UIOptions.EitherNativeUIOrCECPOptions -> Transformation pieceSquareValue setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setEitherNativeUIOrCECPOptions eitherNativeUIOrCECPOptions ioOptions } -- | Mutator. -setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation pieceSquareValue x y +setMaybePrintMoveTree :: Maybe Property.Arboreal.Depth -> Transformation pieceSquareValue setMaybePrintMoveTree maybePrintMoveTree options@MkOptions { getIOOptions = ioOptions } = options { getIOOptions = Input.IOOptions.setMaybePrintMoveTree maybePrintMoveTree ioOptions } -- | Mutator. -swapSearchDepth :: Transformation pieceSquareValue x y +swapSearchDepth :: Transformation pieceSquareValue swapSearchDepth options@MkOptions { getSearchOptions = searchOptions } = options { getSearchOptions = Input.SearchOptions.swapSearchDepth searchOptions } diff --git a/src-lib/BishBosh/Input/PieceSquareTable.hs b/src-lib/BishBosh/Input/PieceSquareTable.hs --- a/src-lib/BishBosh/Input/PieceSquareTable.hs +++ b/src-lib/BishBosh/Input/PieceSquareTable.hs @@ -40,6 +40,7 @@ -- ** Type-synonyms -- Normalise, -- ReflectOnY, + IOFormat, Assocs, -- ** Data-types PieceSquareTable( @@ -71,16 +72,16 @@ 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.Empty as Property.Empty import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Text.Case as Text.Case import qualified BishBosh.Text.ShowList as Text.ShowList -import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Arrow import qualified Control.Exception -import qualified Data.Array.IArray import qualified Data.Default -import qualified Data.Map.Strict +import qualified Data.Foldable +import qualified Data.Map.Strict as Map import qualified Data.Set import qualified Text.XML.HXT.Arrow.Pickle as HXT @@ -103,22 +104,15 @@ type ReflectOnY = Bool -- | Defines the value for each type of piece, of occupying each square. -data PieceSquareTable x y pieceSquareValue = MkPieceSquareTable { +data PieceSquareTable pieceSquareValue = MkPieceSquareTable { getNormalise :: Normalise, -- ^ Whether to map the specified values into the closed unit-interval. CAVEAT: incompatible with RelaxNG, the specification for which already constrains values to the unit-interval. getReflectOnY :: ReflectOnY, -- ^ Whether values for the RHS of the board should be inferred by reflection about the y-axis. - getPieceSquareValueByCoordinatesByRank :: Data.Map.Strict.Map Attribute.Rank.Rank ( - Cartesian.Coordinates.ArrayByCoordinates x y pieceSquareValue + getPieceSquareValueByCoordinatesByRank :: Map.Map Attribute.Rank.Rank ( + Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue ) -- ^ N.B.: on the assumption that the values for Black pieces are the reflection of those for White, merely the /rank/ of each /piece/ need be defined. } deriving (Eq, Show) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Real pieceSquareValue, - Show pieceSquareValue - ) => Property.ShowFloat.ShowFloat (PieceSquareTable x y pieceSquareValue) where +instance (Real pieceSquareValue, Show pieceSquareValue) => Property.ShowFloat.ShowFloat (PieceSquareTable pieceSquareValue) where showsFloat fromDouble MkPieceSquareTable { getNormalise = normalise, getReflectOnY = reflectOnY, @@ -136,28 +130,27 @@ if reflectOnY then unmirror else id - ) . Data.Array.IArray.elems + ) . Data.Foldable.toList ) ( - Data.Map.Strict.assocs byRank + Map.toList byRank ) -instance Data.Default.Default (PieceSquareTable x y pieceSquareValue) where +instance Data.Default.Default (PieceSquareTable pieceSquareValue) where def = MkPieceSquareTable { getNormalise = False, getReflectOnY = True, - getPieceSquareValueByCoordinatesByRank = Data.Map.Strict.empty + getPieceSquareValueByCoordinatesByRank = Property.Empty.empty } +-- | The format of the values when read or written. +type IOFormat = Double + instance ( - Enum x, - Enum y, Fractional pieceSquareValue, Ord pieceSquareValue, - Ord x, - Ord y, Real pieceSquareValue, Show pieceSquareValue - ) => HXT.XmlPickler (PieceSquareTable x y pieceSquareValue) where + ) => HXT.XmlPickler (PieceSquareTable pieceSquareValue) where xpickle = HXT.xpWrap ( \(a, b, c) -> mkPieceSquareTable a b c, -- Construct. \MkPieceSquareTable { @@ -167,12 +160,12 @@ } -> ( normalise, reflectOnY, - Data.Map.Strict.assocs $ Data.Map.Strict.map ( + Map.toList $ Map.map ( ( if reflectOnY then unmirror else id - ) . Data.Array.IArray.elems + ) . Data.Foldable.toList ) byRank ) -- Deconstruct to tuple. ) . HXT.xpTriple ( @@ -184,11 +177,11 @@ showString "by" $ Text.Case.toUpperInitial Attribute.Rank.tag ) $ HXT.xpickle {-rank-} `HXT.xpPair` HXT.xpWrap ( \s -> [ - realToFrac (pieceSquareValue :: Type.Mass.PieceSquareValue) | + realToFrac (pieceSquareValue :: IOFormat) | word <- words s, (pieceSquareValue, "") <- reads word ], -- List-comprehension. - unwords . map (show . (\pieceSquareValue -> realToFrac pieceSquareValue :: Type.Mass.PieceSquareValue)) + unwords . map (show . (\pieceSquareValue -> realToFrac pieceSquareValue :: IOFormat)) ) ( HXT.xpTextAttr . showString "by" $ Text.Case.toUpperInitial Cartesian.Coordinates.tag ) @@ -233,28 +226,24 @@ -- | Smart constructor. mkPieceSquareTable :: ( - Enum x, - Enum y, Fractional pieceSquareValue, Ord pieceSquareValue, - Ord x, - Ord y, Show pieceSquareValue ) => Normalise -- ^ Whether to normalise the specified values into the closed unit interval. -> ReflectOnY -- ^ Whether values for the RHS of the board are inferred by reflection about the y-axis. -> Assocs Attribute.Rank.Rank pieceSquareValue - -> PieceSquareTable x y pieceSquareValue + -> PieceSquareTable pieceSquareValue mkPieceSquareTable normalise reflectOnY assocs | any ( - (/= nValuesRequired) . length . snd {-pieceSquareValues-} + (/= nValuesRequired) . fromIntegral . length . snd {-pieceSquareValues-} ) assocs = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\texactly " . shows nValuesRequired . showString " values must be defined for each type of piece; " $ shows assocs "." | not $ null duplicateRanks = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\tranks must be distinct; " $ shows duplicateRanks "." | not $ normalise || inClosedUnitInterval assocs = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.PieceSquareTable.mkPieceSquareTable:\tall values must be within the closed unit-interval [0,1]; " $ shows assocs "." | otherwise = MkPieceSquareTable { getNormalise = normalise, getReflectOnY = reflectOnY, - getPieceSquareValueByCoordinatesByRank = Data.Map.Strict.fromList . map ( + getPieceSquareValueByCoordinatesByRank = Map.fromList . map ( Control.Arrow.second Cartesian.Coordinates.listArrayByCoordinates ) . ( if reflectOnY @@ -276,13 +265,13 @@ ) Cartesian.Coordinates.nSquares -- | Identify any /rank/ lacking a definition. -findUndefinedRanks :: PieceSquareTable x y pieceSquareValue -> Data.Set.Set Attribute.Rank.Rank -findUndefinedRanks MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Data.Set.fromAscList Property.FixedMembership.members `Data.Set.difference` Data.Map.Strict.keysSet pieceSquareValueByCoordinatesByRank +findUndefinedRanks :: PieceSquareTable pieceSquareValue -> Data.Set.Set Attribute.Rank.Rank +findUndefinedRanks MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Data.Set.fromAscList Property.FixedMembership.members `Data.Set.difference` Map.keysSet pieceSquareValueByCoordinatesByRank -- | Lookup the values for all /coordinates/, corresponding to the specified /rank/. dereference :: Attribute.Rank.Rank - -> PieceSquareTable x y pieceSquareValue - -> Maybe (Cartesian.Coordinates.ArrayByCoordinates x y pieceSquareValue) -dereference rank MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Data.Map.Strict.lookup rank pieceSquareValueByCoordinatesByRank + -> PieceSquareTable pieceSquareValue + -> Maybe (Cartesian.Coordinates.ArrayByCoordinates pieceSquareValue) +dereference rank MkPieceSquareTable { getPieceSquareValueByCoordinatesByRank = pieceSquareValueByCoordinatesByRank } = Map.lookup rank pieceSquareValueByCoordinatesByRank 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 @@ -51,7 +51,7 @@ ), -- * Constants tag, --- sortOnStandardOpeningMoveFrequencyTag + sortOnStandardOpeningMoveFrequencyTag, -- minimumHammingDistanceTag, -- retireKillerMovesAfterTag, -- trapRepeatedPositionsTag, @@ -85,6 +85,7 @@ 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.Empty as Property.Empty import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Text.Case as Text.Case import qualified BishBosh.Text.ShowList as Text.ShowList @@ -94,7 +95,7 @@ import qualified Control.Monad.Reader import qualified Data.Default import qualified Data.Foldable -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified Text.XML.HXT.Arrow.Pickle as HXT @@ -169,7 +170,7 @@ 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 Type.Count.NPlies +type SearchDepthByLogicalColour = Map.Map Attribute.LogicalColour.LogicalColour Type.Count.NPlies -- | Defines options related to searching for a move. data SearchOptions = MkSearchOptions { @@ -245,13 +246,13 @@ shows standardOpeningOptions ), ( searchDepthByLogicalColourTag, - Text.ShowList.showsAssociationList' . map (show *** shows) $ Data.Map.Strict.assocs searchDepthByLogicalColour + Text.ShowList.showsAssociationList' . map (show *** shows) $ Map.toList searchDepthByLogicalColour ) ] instance Data.Default.Default SearchOptions where def = MkSearchOptions { - getSortOnStandardOpeningMoveFrequency = False, + getSortOnStandardOpeningMoveFrequency = False, -- CAVEAT: this can only be True if a PGN database has been defined; which is currently unknown. getMaybeCaptureMoveSortAlgorithm = Nothing, getMaybeMinimumHammingDistance = Nothing, getMaybeRetireKillerMovesAfter = Nothing, @@ -259,7 +260,7 @@ getUsePondering = False, getMaybeUseTranspositions = Nothing, getStandardOpeningOptions = Data.Default.def, - getSearchDepthByLogicalColour = Data.Map.Strict.empty -- Manual. + getSearchDepthByLogicalColour = Property.Empty.empty -- Manual play. } instance HXT.XmlPickler SearchOptions where @@ -302,14 +303,14 @@ 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 . ( + Map.fromList . ( \l -> let duplicateLogicalColours = BishBosh.Data.Foldable.findDuplicates $ map fst {-logicalColour-} l in if null duplicateLogicalColours then l else Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.Input.SearchOptions.xpickle:\t" . showString Attribute.LogicalColour.tag . showString "s must be distinct; " $ shows duplicateLogicalColours "." ), -- Construct from a List. - Data.Map.Strict.toList -- Deconstruct to a List. + Map.toList -- Deconstruct to an association-list. ) . HXT.xpList {-potentially null-} . HXT.xpElem ( showString "by" $ Text.Case.toUpperInitial Attribute.LogicalColour.tag ) $ HXT.xpickle {-LogicalColour-} `HXT.xpPair` HXT.xpAttr searchDepthTag HXT.xpickle {-NPlies-} @@ -333,7 +334,7 @@ , minimumHammingDistance < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumHammingDistanceTag . Text.ShowList.showsAssociation $ shows minimumHammingDistance " must exceed zero." | Just retireKillerMovesAfter <- maybeRetireKillerMovesAfter , retireKillerMovesAfter < 0 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString retireKillerMovesAfterTag . Text.ShowList.showsAssociation $ shows retireKillerMovesAfter " can't be negative." - | let nAutomatedPlayers = Data.Map.Strict.size searchDepthByLogicalColour + | let nAutomatedPlayers = Data.Foldable.length searchDepthByLogicalColour , usePondering && nAutomatedPlayers /= 1 = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\tpondering is pointless unless there's an automated player who can use the unused CPU-time during a manual player's move, but there're " $ shows nAutomatedPlayers " automated players." | Just (retireTranspositionsAfter, _) <- maybeUseTranspositions @@ -341,10 +342,10 @@ | Just (_, minimumTranspositionSearchDepth) <- maybeUseTranspositions , minimumTranspositionSearchDepth < 1 = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumTranspositionSearchDepthTag . Text.ShowList.showsAssociation $ shows minimumTranspositionSearchDepth " must exceed zero." | Just (_, minimumTranspositionSearchDepth) <- maybeUseTranspositions - , not $ Data.Map.Strict.null searchDepthByLogicalColour + , not $ Data.Foldable.null searchDepthByLogicalColour , Data.Foldable.all ( minimumTranspositionSearchDepth > - ) searchDepthByLogicalColour = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumTranspositionSearchDepthTag . Text.ShowList.showsAssociation $ shows minimumTranspositionSearchDepth . showString " exceeds " . showString searchDepthTag . Text.ShowList.showsAssociation $ shows (Data.Map.Strict.toList searchDepthByLogicalColour) "." + ) searchDepthByLogicalColour = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" . showString minimumTranspositionSearchDepthTag . Text.ShowList.showsAssociation $ shows minimumTranspositionSearchDepth . showString " exceeds " . showString searchDepthTag . Text.ShowList.showsAssociation $ shows (Map.toList searchDepthByLogicalColour) "." | Data.Foldable.any ( < minimumSearchDepth ) searchDepthByLogicalColour = Control.Exception.throw . Data.Exception.mkOutOfBounds . showString "BishBosh.Input.SearchOptions.mkSearchOptions:\t" $ showString searchDepthTag " must be positive." @@ -362,7 +363,7 @@ -- | Get either player's search-depth, using a default value when none are defined. 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. +getSearchDepth MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } = Data.Maybe.fromMaybe defaultSearchDepth . Data.Maybe.listToMaybe $ Data.Foldable.toList searchDepthByLogicalColour -- Manual players don't have a searchDepth, so use the opponent's settings. -- | Self-documentation. type RecordKillerMoves = Bool @@ -386,21 +387,21 @@ 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 } + | otherwise = searchOptions { getSearchDepthByLogicalColour = Map.map (const searchDepth) searchDepthByLogicalColour } -- | Swap the /logical colour/ associated with any /searchDepth/ currently assigned. swapSearchDepth :: Transformation swapSearchDepth searchOptions@MkSearchOptions { getSearchDepthByLogicalColour = searchDepthByLogicalColour } = searchOptions { - getSearchDepthByLogicalColour = Data.Map.Strict.mapKeys Property.Opposable.getOpposite searchDepthByLogicalColour + getSearchDepthByLogicalColour = Map.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 +} = Map.keys searchDepthByLogicalColour -- | Self-documentation. type Reader = Control.Monad.Reader.Reader SearchOptions diff --git a/src-lib/BishBosh/Input/StandardOpeningOptions.hs b/src-lib/BishBosh/Input/StandardOpeningOptions.hs --- a/src-lib/BishBosh/Input/StandardOpeningOptions.hs +++ b/src-lib/BishBosh/Input/StandardOpeningOptions.hs @@ -24,23 +24,20 @@ module BishBosh.Input.StandardOpeningOptions( -- * Types --- ** Type-synonyms --- TryToMatchMoves, --- TryToMatchViaJoiningMove, --- TryToMatchColourFlippedPosition, - MatchSwitches, -- ** Data-types StandardOpeningOptions( -- MkStandardOpeningOptions, -- getTryToMatchMoves, -- getTryToMatchViaJoiningMove, --- getTryToMatchColourFlippedPosition +-- getTryToMatchColourFlippedPosition, + getPreferVictories ), -- * Constants tag, -- tryToMatchMovesTag, -- tryToMatchViaJoiningMoveTag, -- tryToMatchColourFlippedPositionTag, +-- preferVictoriesTag, -- * Functions -- ** Constructor mkStandardOpeningOptions, @@ -48,11 +45,12 @@ getMatchSwitches ) where -import BishBosh.Data.Bool() -- For 'HXT.xpickle'. -import qualified BishBosh.Text.ShowList as Text.ShowList +import BishBosh.Data.Bool() -- For 'HXT.xpickle'. +import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.DeepSeq import qualified Data.Default -import qualified Text.XML.HXT.Arrow.Pickle as HXT +import qualified BishBosh.ContextualNotation.PositionHashQualifiedMoveTree as ContextualNotation.PositionHashQualifiedMoveTree +import qualified Text.XML.HXT.Arrow.Pickle as HXT -- | Used to qualify XML. tag :: String @@ -70,37 +68,32 @@ tryToMatchColourFlippedPositionTag :: String tryToMatchColourFlippedPositionTag = "tryToMatchColourFlippedPosition" --- | Whether to attempt to exactly match moves with a standard opening; transpositions won't be matched. -type TryToMatchMoves = Bool - --- | Whether to attempt to join the current position to a standard opening that's only one ply away. -type TryToMatchViaJoiningMove = Bool - --- | Whether to attempt to match a colour-flipped version of the current position with a standard opening -type TryToMatchColourFlippedPosition = Bool - --- | The switches used to control attempts to find a match amongst standard openings. -type MatchSwitches = (TryToMatchMoves, TryToMatchViaJoiningMove, TryToMatchColourFlippedPosition) +-- | Used to qualify XML. +preferVictoriesTag :: String +preferVictoriesTag = "preferVictories" -- | Defines options related to searching for a move. data StandardOpeningOptions = MkStandardOpeningOptions { - getTryToMatchMoves :: TryToMatchMoves, -- ^ Whether to attempt to exactly match moves with a standard opening; transpositions won't be matched. - getTryToMatchViaJoiningMove :: TryToMatchViaJoiningMove, -- ^ Whether to attempt to join the current position to a standard opening that's only one ply away. - getTryToMatchColourFlippedPosition :: TryToMatchColourFlippedPosition -- ^ Whether to attempt to match a colour-flipped version of the current position with a standard opening. + getTryToMatchMoves :: ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchMoves, -- ^ Whether to attempt to exactly match moves with a standard opening; transpositions won't be matched. + getTryToMatchViaJoiningMove :: ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchViaJoiningMove, -- ^ Whether to attempt to join the current position to a standard opening that's only one ply away. + getTryToMatchColourFlippedPosition :: ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchColourFlippedPosition, -- ^ Whether to attempt to match a colour-flipped version of the current position with a standard opening. + getPreferVictories :: ContextualNotation.PositionHashQualifiedMoveTree.PreferVictories -- ^ Whether from all matching positions extracted from PGN-Databases, to prefer moves which result in a greater probability of victory, for the player who has the next move. } deriving Eq instance Control.DeepSeq.NFData StandardOpeningOptions where rnf MkStandardOpeningOptions { getTryToMatchMoves = tryToMatchMoves, getTryToMatchViaJoiningMove = tryToMatchViaJoiningMove, - getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition - } = Control.DeepSeq.rnf (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) + getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition, + getPreferVictories = preferVictories + } = Control.DeepSeq.rnf (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition, preferVictories) instance Show StandardOpeningOptions where showsPrec _ MkStandardOpeningOptions { getTryToMatchMoves = tryToMatchMoves, getTryToMatchViaJoiningMove = tryToMatchViaJoiningMove, - getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition + getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition, + getPreferVictories = preferVictories } = Text.ShowList.showsAssociationList' [ ( tryToMatchMovesTag, @@ -111,6 +104,9 @@ ), ( tryToMatchColourFlippedPositionTag, shows tryToMatchColourFlippedPosition + ), ( + preferVictoriesTag, + shows preferVictories ) ] @@ -118,40 +114,46 @@ def = MkStandardOpeningOptions { getTryToMatchMoves = True, getTryToMatchViaJoiningMove = True, - getTryToMatchColourFlippedPosition = True + getTryToMatchColourFlippedPosition = True, + getPreferVictories = True } instance HXT.XmlPickler StandardOpeningOptions where xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag . HXT.xpWrap ( - \(a, b, c) -> mkStandardOpeningOptions a b c, -- Construct. + \(a, b, c, d) -> mkStandardOpeningOptions a b c d, -- Construct. \MkStandardOpeningOptions { getTryToMatchMoves = tryToMatchMoves, getTryToMatchViaJoiningMove = tryToMatchViaJoiningMove, - getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition - } -> (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) -- Deconstruct. - ) $ HXT.xpTriple( + getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition, + getPreferVictories = preferVictories + } -> (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition, preferVictories) -- Deconstruct. + ) $ HXT.xp4Tuple ( getTryToMatchMoves def `HXT.xpDefault` HXT.xpAttr tryToMatchMovesTag HXT.xpickle ) ( getTryToMatchViaJoiningMove def `HXT.xpDefault` HXT.xpAttr tryToMatchViaJoiningMoveTag HXT.xpickle ) ( getTryToMatchColourFlippedPosition def `HXT.xpDefault` HXT.xpAttr tryToMatchColourFlippedPositionTag HXT.xpickle + ) ( + getPreferVictories def `HXT.xpDefault` HXT.xpAttr preferVictoriesTag HXT.xpickle ) where def = Data.Default.def -- | Smart constructor. mkStandardOpeningOptions - :: TryToMatchMoves - -> TryToMatchViaJoiningMove - -> TryToMatchColourFlippedPosition + :: ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchMoves + -> ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchViaJoiningMove + -> ContextualNotation.PositionHashQualifiedMoveTree.TryToMatchColourFlippedPosition + -> ContextualNotation.PositionHashQualifiedMoveTree.PreferVictories -> StandardOpeningOptions -mkStandardOpeningOptions tryToMatchMoves tryToMatchViaJoiningMove tryToMatchColourFlippedPosition = MkStandardOpeningOptions { +mkStandardOpeningOptions tryToMatchMoves tryToMatchViaJoiningMove tryToMatchColourFlippedPosition preferVictories = MkStandardOpeningOptions { getTryToMatchMoves = tryToMatchMoves, getTryToMatchViaJoiningMove = tryToMatchViaJoiningMove, - getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition + getTryToMatchColourFlippedPosition = tryToMatchColourFlippedPosition, + getPreferVictories = preferVictories } -- | Accessor. -getMatchSwitches :: StandardOpeningOptions -> MatchSwitches +getMatchSwitches :: StandardOpeningOptions -> ContextualNotation.PositionHashQualifiedMoveTree.MatchSwitches getMatchSwitches MkStandardOpeningOptions { getTryToMatchMoves = tryToMatchMoves, getTryToMatchViaJoiningMove = tryToMatchViaJoiningMove, 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -104,6 +103,7 @@ import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Notation.Notation as Notation.Notation import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription @@ -124,24 +124,22 @@ import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.State.Position as State.Position import qualified BishBosh.StateProperty.Censor as StateProperty.Censor +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Text.ShowList as Text.ShowList 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 -import qualified Data.Array.IArray import qualified Data.Bits import qualified Data.Default import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra -import qualified Data.Map -import qualified Data.Map.Strict +import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Ord import qualified ToolShed.Data.List @@ -157,24 +155,24 @@ Building 'Component.Zobrist.Zobrist' into 'Game' would break the instance of 'Eq'. Building a hash-constructor into 'Game' would break the instance of @ (Eq, Read, Show) @. -} -type InstancesByPosition x y = State.InstancesByPosition.InstancesByPosition (State.Position.Position x y) +type InstancesByPosition = State.InstancesByPosition.InstancesByPosition State.Position.Position -- | The /move/s available to one player, indexed by the source-/coordinates/ of the /move/. -type AvailableQualifiedMoves x y = ( - Data.Map.Map (Cartesian.Coordinates.Coordinates x y) -- Source. +type AvailableQualifiedMoves = ( + Map.Map Cartesian.Coordinates.Coordinates -- Source. ) [ ( - Cartesian.Coordinates.Coordinates x y, -- Destination. + Cartesian.Coordinates.Coordinates, -- Destination. Attribute.MoveType.MoveType ) ] -- | Sort the lists of destinations to faciliate testing for equality. -sortAvailableQualifiedMoves :: (Ord x, Ord y) => AvailableQualifiedMoves x y -> AvailableQualifiedMoves x y -sortAvailableQualifiedMoves = Data.Map.map . Data.List.sortBy $ Data.Ord.comparing fst {-destination-} +sortAvailableQualifiedMoves :: AvailableQualifiedMoves -> AvailableQualifiedMoves +sortAvailableQualifiedMoves = Map.map . Data.List.sortBy $ Data.Ord.comparing fst {-destination-} -- | The /move/s available to both players. -type AvailableQualifiedMovesByLogicalColour x y = Data.Map.Map Attribute.LogicalColour.LogicalColour (AvailableQualifiedMoves x y) +type AvailableQualifiedMovesByLogicalColour = Map.Map Attribute.LogicalColour.LogicalColour AvailableQualifiedMoves {- | * The first three fields represent the state of the /game/. @@ -183,23 +181,18 @@ * For efficiency the list of available /move/s is stored. -} -data Game x y = MkGame { - getNextLogicalColour :: Attribute.LogicalColour.LogicalColour, -- ^ N.B.: can be derived from 'getTurnsByLogicalColour', unless 'Property.Reflectable.reflectOnX' has been called. - getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x, -- ^ Those @Rook@s which can still participate in castling. - getBoard :: State.Board.Board x y, -- ^ The current state of the /board/. - getTurnsByLogicalColour :: State.CastleableRooksByLogicalColour.TurnsByLogicalColour x y, -- ^ Successive /move/s & any /piece/ taken, recorded by player. - getMaybeChecked :: Maybe Attribute.LogicalColour.LogicalColour, -- ^ The player (if any), whose currently /checked/; which will typically be 'getNextLogicalColour', but 'listQualifiedMovesAvailableTo' can be called for either player. - 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 Rule.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. +data Game = MkGame { + getNextLogicalColour :: Attribute.LogicalColour.LogicalColour, -- ^ N.B.: can be derived from 'getTurnsByLogicalColour', unless 'Property.Reflectable.reflectOnX' has been called. + getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, -- ^ Those @Rook@s which can still participate in castling. + getBoard :: State.Board.Board, -- ^ The current state of the /board/. + getTurnsByLogicalColour :: State.CastleableRooksByLogicalColour.TurnsByLogicalColour, -- ^ Successive /move/s & any /piece/ taken, recorded by player. + getMaybeChecked :: Maybe Attribute.LogicalColour.LogicalColour, -- ^ The player (if any), whose currently /checked/; which will typically be 'getNextLogicalColour', but 'listQualifiedMovesAvailableTo' can be called for either player. + getInstancesByPosition :: InstancesByPosition, -- ^ The number of instances of various positions since the last unrepeatable move. + getAvailableQualifiedMovesByLogicalColour :: AvailableQualifiedMovesByLogicalColour, -- ^ The /move/s available to each player. Since this is merely required for efficiency, it needn't have an entry for both players; & typically doesn't when checked, since radical pruning would otherwise be required. CAVEAT: doesn't account for game-termination. + getMaybeTerminationReason :: Maybe Rule.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. } -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Eq (Game x y) where +instance Eq Game where MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -225,7 +218,7 @@ turnsByLogicalColour, maybeChecked, instancesByPosition, - Data.Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour, + Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour, maybeTerminationReason ) == ( nextLogicalColour', @@ -234,14 +227,11 @@ turnsByLogicalColour', maybeChecked', instancesByPosition', - Data.Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour', + Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour', maybeTerminationReason' ) -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Game x y) where +instance Control.DeepSeq.NFData Game where rnf MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -262,14 +252,7 @@ maybeTerminationReason ) -- Represent as a tuple. -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Show (Game x y) where +instance Show Game where showsPrec precedence MkGame { getBoard = board, getTurnsByLogicalColour = turnsByLogicalColour, @@ -280,17 +263,7 @@ maybeTerminationReason ) -- Represent as a tuple those fields which can't be inferred. -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Read x, - Read y, - Show x, - Show y - ) => Read (Game x y) where - {-# SPECIALISE instance Read (Game Type.Length.X Type.Length.Y) #-} +instance Read Game where readsPrec precedence = map ( Control.Arrow.first $ \( board, @@ -308,33 +281,17 @@ in game ) . readsPrec precedence -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Data.Default.Default (Game x y) where - {-# SPECIALISE instance Data.Default.Default (Game Type.Length.X Type.Length.Y) #-} +instance Data.Default.Default Game where def = ( mkGame Attribute.LogicalColour.White Data.Default.def {-castleableRooksByLogicalColour-} Data.Default.def {-board-} Data.Default.def {-turnsByLogicalColour-} ) { getMaybeChecked = Nothing, - getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList $ map ( + getAvailableQualifiedMovesByLogicalColour = Map.fromAscList $ map ( id &&& (`mkAvailableQualifiedMovesFor` Data.Default.def {-game-}) ) Property.FixedMembership.members } -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Property.ExtendedPositionDescription.ReadsEPD (Game x y) where - {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Game Type.Length.X Type.Length.Y) #-} +instance Property.ExtendedPositionDescription.ReadsEPD Game where readsEPD s = [ ( mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour, @@ -365,15 +322,10 @@ ] -- Singleton. ) -- Pair. ] - ) `map` Notation.PureCoordinate.readsCoordinates s3' -- En-passant destination. + ) `map` Notation.Notation.readsCoordinates Notation.PureCoordinate.notation s3' -- En-passant destination. ] -- List-comprehension. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ExtendedPositionDescription.ShowsEPD (Game x y) where +instance Property.ExtendedPositionDescription.ShowsEPD Game where showsEPD game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -390,15 +342,7 @@ ] -- CAVEAT: some information is lost during 'showsFEN', which can't subsequently be recovered by 'readsFEN'. -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Property.ForsythEdwards.ReadsFEN (Game x y) where - {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game Type.Length.X Type.Length.Y) #-} +instance Property.ForsythEdwards.ReadsFEN Game where readsFEN s = [ (game, s3) | (game, s1) <- Property.ExtendedPositionDescription.readsEPD s, @@ -406,12 +350,7 @@ (_fullMoveCounter, s3) <- reads s2 :: [(Int, String)] ] -- List-comprehension. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ForsythEdwards.ShowsFEN (Game x y) where +instance Property.ForsythEdwards.ShowsFEN Game where showsFEN game@MkGame { getTurnsByLogicalColour = turnsByLogicalColour, getInstancesByPosition = instancesByPosition @@ -421,18 +360,10 @@ shows . succ {-the full-move counter starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference Attribute.LogicalColour.Black turnsByLogicalColour -- 6. Full move counter. ] -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Property.Empty.Empty (Game x y) where - {-# SPECIALISE instance Property.Empty.Empty (Game Type.Length.X Type.Length.Y) #-} +instance Property.Empty.Empty Game where 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 +instance Property.Null.Null Game where isNull MkGame { getTurnsByLogicalColour = turnsByLogicalColour } = Property.Null.isNull turnsByLogicalColour {- | @@ -441,15 +372,7 @@ * N.B.: 'Property.Reflectable.ReflectableOnY' isn't implemented, since /reflectOnY/ produces a mirror-image /board/ in which the royal /piece/s start in a non-standard position & castling occurs the wrong way. -} -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Property.Reflectable.ReflectableOnX (Game x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Game Type.Length.X Type.Length.Y) #-} +instance Property.Reflectable.ReflectableOnX Game where reflectOnX MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -472,9 +395,8 @@ getMaybeTerminationReason = fmap Property.Opposable.getOpposite maybeTerminationReason } -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 Type.Length.X Type.Length.Y #-} - listRandoms2D game@MkGame { +instance StateProperty.Hashable.Hashable Game where + listRandoms game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board @@ -483,28 +405,20 @@ then (Component.Zobrist.getRandomForBlacksMove zobrist :) else id ) . Data.Maybe.maybe id ( - (++) . (`Component.Zobrist.listRandoms1D` zobrist) + (++) . (`StateProperty.Hashable.listRandoms` zobrist) ) ( maybeLastTurn game >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa nextLogicalColour ( State.Board.getMaybePieceByCoordinates board ) - ) $ Component.Zobrist.listRandoms1D castleableRooksByLogicalColour zobrist ++ Component.Zobrist.listRandoms2D board zobrist + ) $ StateProperty.Hashable.listRandoms castleableRooksByLogicalColour zobrist ++ StateProperty.Hashable.listRandoms board zobrist -- | Smart constructor. -mkGame :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The player who is required to move next. - -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x - -> State.Board.Board x y - -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour x y - -> Game x 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 + :: Attribute.LogicalColour.LogicalColour -- ^ The player who is required to move next. + -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour + -> State.Board.Board + -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour + -> Game mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour | not . StateProperty.Censor.hasBothKings $ State.Board.getCoordinatesByRankByLogicalColour board = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tboth Kings must exist; " $ shows board "." | State.Board.isKingChecked ( @@ -519,7 +433,7 @@ getTurnsByLogicalColour = turnsByLogicalColour, getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board) Property.FixedMembership.members, getInstancesByPosition = State.InstancesByPosition.mkSingleton $ mkPosition game, - getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList [ + getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ (logicalColour, mkAvailableQualifiedMovesFor logicalColour game) | logicalColour <- Property.FixedMembership.members, getMaybeChecked game /= Just logicalColour -- Define the available qualified moves for unchecked players only. @@ -536,21 +450,13 @@ * There're zero previous turns. -} -fromBoard :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => State.Board.Board x y -> Game x y -{-# SPECIALISE fromBoard :: State.Board.Board Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y #-} +fromBoard :: State.Board.Board -> Game fromBoard board = mkGame Attribute.LogicalColour.White ( State.CastleableRooksByLogicalColour.fromBoard board ) board Property.Empty.empty {-TurnsByLogicalColour-} -- | Gets the sequence of /turn/s, with the latest at the head & the opening one last. -listTurns :: Game x y -> [Component.Turn.Turn x y] +listTurns :: Game -> [Component.Turn.Turn] listTurns MkGame { getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour @@ -559,11 +465,11 @@ ) turnsByLogicalColour -- | Gets the sequence of /turn/s in the order they occured. -listTurnsChronologically :: Game x y -> [Component.Turn.Turn x y] +listTurnsChronologically :: Game -> [Component.Turn.Turn] listTurnsChronologically = reverse . listTurns -- | The last /turn/, if there was one. -maybeLastTurn :: Game x y -> Maybe (Component.Turn.Turn x y) +maybeLastTurn :: Game -> Maybe Component.Turn.Turn maybeLastTurn MkGame { getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour @@ -578,13 +484,7 @@ * CAVEAT: this is a performance-hotspot; refactor => re-profile. -} -findAvailableCastlingMoves :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Attribute.LogicalColour.LogicalColour -> Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} +findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game -> [Component.QualifiedMove.QualifiedMove] findAvailableCastlingMoves logicalColour MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, @@ -610,8 +510,7 @@ -- | List any /rank/s to which the specified /piece/ can be promoted on moving to the specified /destination/. listMaybePromotionRanks - :: (Enum y, Eq y) - => Cartesian.Coordinates.Coordinates x y -- ^ Destination. + :: Cartesian.Coordinates.Coordinates -- ^ Destination. -> Component.Piece.Piece -> [Maybe Attribute.Rank.Rank] {-# INLINE listMaybePromotionRanks #-} @@ -620,7 +519,7 @@ | otherwise = [Nothing] -- | The type of a function which transforms a /game/. -type Transformation x y = Game x y -> Game x y +type Transformation = Game -> Game {- | * Moves the referenced /piece/ between the specified /coordinates/. @@ -631,15 +530,7 @@ * CAVEAT: doesn't account for any previous game-termination when updating 'getAvailableQualifiedMovesByLogicalColour'. -} -takeTurn :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Component.Turn.Turn x y -> Transformation x y -{-# SPECIALISE takeTurn :: Component.Turn.Turn Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} +takeTurn :: Component.Turn.Turn -> Transformation takeTurn turn game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -725,16 +616,12 @@ (blockingCoordinates, blockingPiece) | (kingsCoordinates, _) <- kingsByCoordinates, moveEndpoint <- moveEndpoints, - direction <- Data.Maybe.maybeToList $ Cartesian.Vector.toMaybeDirection ( - Cartesian.Vector.measureDistance kingsCoordinates moveEndpoint :: Cartesian.Vector.VectorInt - ), -- N.B. null when the King isn't aligned with any move-endpoint. + direction <- Data.Maybe.maybeToList . Cartesian.Vector.toMaybeDirection $ Cartesian.Vector.measureDistance kingsCoordinates moveEndpoint, -- N.B. null when the King isn't aligned with any move-endpoint. let findBlockingPieceFrom coordinates = State.MaybePieceByCoordinates.findBlockingPiece direction coordinates maybePieceByCoordinates', (blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ ( \pair@(coordinates, _) -> if coordinates /= destination then Just pair - else {-blocker is destination-} if Cartesian.Vector.toMaybeDirection ( - Cartesian.Vector.measureDistance kingsCoordinates source :: Cartesian.Vector.VectorInt - ) == Just direction + else {-blocker is destination-} if Cartesian.Vector.toMaybeDirection (Cartesian.Vector.measureDistance kingsCoordinates source) == Just direction then Nothing else findBlockingPieceFrom coordinates -- Look through the destination to the previous blocker; which might be the source. ) =<< findBlockingPieceFrom kingsCoordinates @@ -774,13 +661,13 @@ isSafeDestination destination', maybePromotionRank <- listMaybePromotionRanks destination' piece' ] {-list-comprehension-} of - [] -> Data.Map.delete source' -- There're zero moves from here. - qualifiedDestinations -> Data.Map.insert source' qualifiedDestinations -- Overwrite any existing moves. + [] -> Map.delete source' -- There're zero moves from here. + qualifiedDestinations -> Map.insert source' qualifiedDestinations -- Overwrite any existing moves. insertCastlingMoves logicalColour = case findAvailableCastlingMoves logicalColour game' of [] -> id validCastlingMoves -> uncurry ( - Data.Map.insertWith (++) + Map.insertWith (++) ) $ ( Component.Move.getSource {-the King-} . Component.QualifiedMove.getMove . head &&& map ( Component.Move.getDestination . Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType @@ -788,19 +675,19 @@ ) validCastlingMoves in ( \availableQualifiedMovesByLogicalColour' -> ( - case (Data.Map.member opponentsLogicalColour availableQualifiedMovesByLogicalColour', Data.Maybe.isJust $ getMaybeChecked game') of - (True, True) -> Data.Map.delete opponentsLogicalColour -- Many changes result from the King being checked. - (True, _) -> Data.Map.adjust ( + case (Map.member opponentsLogicalColour availableQualifiedMovesByLogicalColour', Data.Maybe.isJust $ getMaybeChecked game') of + (True, True) -> Map.delete opponentsLogicalColour -- Many changes result from the King being checked. + (True, _) -> Map.adjust ( insertCastlingMoves opponentsLogicalColour . ( `insertMovesFrom` affected' -- Reconstruct any moves for affected pieces. ) . ( if Attribute.MoveType.isEnPassant moveType - then Data.Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination + then Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination else id - ) . Data.Map.delete destination -- Delete the moves originally available to any taken piece. + ) . Map.delete destination -- Delete the moves originally available to any taken piece. ) opponentsLogicalColour (_, True) -> id -- We neither want an entry in the map, nor is there one. - _ -> Data.Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor opponentsLogicalColour game' -- Reconstruct. + _ -> Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor opponentsLogicalColour game' -- Reconstruct. ) availableQualifiedMovesByLogicalColour' ) $ ( if Data.Maybe.maybe True {-not a member-} ( @@ -811,27 +698,19 @@ ) {-only required for efficiency-} && Data.Foldable.any ( any $ Attribute.MoveType.isEnPassant . snd {-moveType-} ) availableQualifiedMoves - ) $ Data.Map.lookup nextLogicalColour availableQualifiedMovesByLogicalColour - then Data.Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor nextLogicalColour game' -- Reconstruct. - else Data.Map.adjust ( + ) $ Map.lookup nextLogicalColour availableQualifiedMovesByLogicalColour + then Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor nextLogicalColour game' -- Reconstruct. + else Map.adjust ( insertCastlingMoves nextLogicalColour . ( `insertMovesFrom` affected -- Reconstruct any moves for affected pieces. - ) . Data.Map.delete source -- Delete the moves originally available to the moved piece. + ) . Map.delete source -- Delete the moves originally available to the moved piece. ) nextLogicalColour ) availableQualifiedMovesByLogicalColour, getMaybeTerminationReason = inferMaybeTerminationReason game' -- CAVEAT: this will overwrite any previous resignation. } -- | Construct a /turn/ & relay the request to 'takeTurn'. -applyQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Component.QualifiedMove.QualifiedMove x y -> Transformation x y -{-# SPECIALISE applyQualifiedMove :: Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} +applyQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Transformation applyQualifiedMove qualifiedMove game@MkGame { getBoard = board } | Just piece <- State.MaybePieceByCoordinates.dereference (Component.Move.getSource move) $ State.Board.getMaybePieceByCoordinates board = takeTurn (Component.Turn.mkTurn qualifiedMove $ Component.Piece.getRank piece) game @@ -840,15 +719,7 @@ move = Component.QualifiedMove.getMove qualifiedMove -- | Construct a /qualifiedMove/ & relay the request to "applyQualifiedMove". -applyEitherQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Transformation x y -{-# SPECIALISE applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} +applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove -> Transformation applyEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } = applyQualifiedMove ( Component.QualifiedMove.mkQualifiedMove move . ( ($ State.Board.getMaybePieceByCoordinates board) . State.MaybePieceByCoordinates.inferMoveType move ||| id @@ -857,20 +728,12 @@ move = Component.EitherQualifiedMove.getMove eitherQualifiedMove -- | Constructs /eitherQualifiedMove/s from the data provided, validating & applying each in the specified order. -applyEitherQualifiedMoves :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => (a -> Either String (Component.EitherQualifiedMove.EitherQualifiedMove x y)) -- ^ A constructor which can return an error-message. - -> Game x y -- ^ The /game/ to which the /move/s should be sequentially applied. +applyEitherQualifiedMoves + :: (a -> Either String Component.EitherQualifiedMove.EitherQualifiedMove) -- ^ A constructor which can return an error-message. + -> Game -- ^ 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 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' ( + -> Either (a, String) Game -- ^ Either a rogue datum & the corresponding error-message, or the resulting /game/. +applyEitherQualifiedMoves moveConstructor = Data.Foldable.foldl' ( \eitherGame datum -> eitherGame >>= ( \game -> Left . (,) datum {-Constructor failed-} ||| ( \eitherQualifiedMove -> Data.Maybe.maybe ( @@ -890,18 +753,10 @@ * N.B.: it is considered valid to take a @King@, one just never has the opportunity, since the game terminates the move before. -} -validateQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Component.QualifiedMove.QualifiedMove x y - -> Game x y -- ^ Prior to playing the /qualified move/. +validateQualifiedMove + :: Component.QualifiedMove.QualifiedMove + -> Game -- ^ Prior to playing the /qualified move/. -> Maybe String -- ^ Error-message. -{-# 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, @@ -1092,26 +947,16 @@ (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board maybeDestinationPiece = State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates -- Query. - - distance :: Cartesian.Vector.VectorInt - distance = Component.Move.measureDistance move + distance = Component.Move.measureDistance move isObstructed :: Bool isObstructed = State.MaybePieceByCoordinates.isObstructed source destination maybePieceByCoordinates -- | Validates the /move-type/ then forwards the request to 'validateQualifiedMove'. -validateEitherQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Component.EitherQualifiedMove.EitherQualifiedMove x y - -> Game x y -- ^ Prior to playing the /move/. +validateEitherQualifiedMove + :: Component.EitherQualifiedMove.EitherQualifiedMove + -> Game -- ^ Prior to playing the /move/. -> Maybe String -- ^ Error-message. -{-# 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,27 +975,11 @@ ) maybePieceByCoordinates -- | Whether the specified /QualifiedMove/ is valid. -isValidQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Component.QualifiedMove.QualifiedMove x y -> Game x y -> Bool -{-# SPECIALISE isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} +isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Game -> Bool isValidQualifiedMove qualifiedMove = Data.Maybe.isNothing . validateQualifiedMove qualifiedMove -- | Whether the specified /EitherQualifiedMove/ is valid. -isValidEitherQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Game x y -> Bool -{-# SPECIALISE isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} +isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove -> Game -> Bool isValidEitherQualifiedMove eitherQualifiedMove = Data.Maybe.isNothing . validateEitherQualifiedMove eitherQualifiedMove {- | @@ -1158,15 +987,7 @@ * The list-head contains the most recent /ply/, while the tail contains the first. -} -rollBack :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Game x y -> [(Game x y, Component.Turn.Turn x 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 :: Game -> [(Game, Component.Turn.Turn)] rollBack = Data.List.unfoldr ( \game@MkGame { getNextLogicalColour = nextLogicalColour, @@ -1216,7 +1037,7 @@ getInstancesByPosition = if Component.Turn.getIsRepeatableMove turn then State.InstancesByPosition.deletePosition (mkPosition game) instancesByPosition else mkInstancesByPosition game', -- Reconstruct the map prior to the unrepeatable move. - getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList [ + getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ (logicalColour, mkAvailableQualifiedMovesFor logicalColour game') | logicalColour <- Property.FixedMembership.members, maybeChecked' /= Just logicalColour @@ -1232,18 +1053,10 @@ * CAVEAT: to avoid an infinite loop, this doesn't check whether the game has already terminated. -} -listQualifiedMovesAvailableTo :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => 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 Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} +listQualifiedMovesAvailableTo + :: Attribute.LogicalColour.LogicalColour -- ^ Define the player for whom the moves are required. + -> Game + -> [Component.QualifiedMove.QualifiedMove] listQualifiedMovesAvailableTo logicalColour game@MkGame { getBoard = board, getMaybeChecked = maybeChecked @@ -1333,19 +1146,11 @@ isSafeQualifiedMove qualifiedMove = not $ State.Board.exposesKing logicalColour (Component.QualifiedMove.getMove qualifiedMove) board -- | Construct 'AvailableQualifiedMoves' for the player of the specified /logical colour/. -mkAvailableQualifiedMovesFor :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Attribute.LogicalColour.LogicalColour -> Game x y -> AvailableQualifiedMoves x y -{-# SPECIALISE mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> AvailableQualifiedMoves Type.Length.X Type.Length.Y #-} +mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game -> AvailableQualifiedMoves mkAvailableQualifiedMovesFor logicalColour = foldr {-maintains destination-order-} ( \qualifiedMove -> let move = Component.QualifiedMove.getMove qualifiedMove - in Data.Map.insertWith (++) ( + in Map.insertWith (++) ( Component.Move.getSource move -- Key. ) [ ( @@ -1353,65 +1158,39 @@ Component.QualifiedMove.getMoveType qualifiedMove ) -- Pair. ] {-singleton-} - ) Data.Map.empty . listQualifiedMovesAvailableTo logicalColour + ) Property.Empty.empty . listQualifiedMovesAvailableTo logicalColour {- | * Retrieve the recorded value, or generate the list of /move/s available to the player of the specified /logical colour/. * CAVEAT: doesn't account for game-termination. -} -findQualifiedMovesAvailableTo :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Attribute.LogicalColour.LogicalColour - -> Game x y - -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} +findQualifiedMovesAvailableTo + :: Attribute.LogicalColour.LogicalColour + -> Game + -> [Component.QualifiedMove.QualifiedMove] findQualifiedMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } - | Just availableQualifiedMoves <- Data.Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [ + | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [ Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType | - (source, qualifiedDestinations) <- Data.Map.assocs availableQualifiedMoves, + (source, qualifiedDestinations) <- Map.toList availableQualifiedMoves, (destination, moveType) <- qualifiedDestinations ] -- List-comprehension. | otherwise = listQualifiedMovesAvailableTo logicalColour game -- Generate the list of moves for this player. -- | 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 -> Type.Count.NPlies -{-# SPECIALISE countPliesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game Type.Length.X Type.Length.Y -> Type.Count.NPlies #-} +countPliesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game -> 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. - = fromIntegral $ Data.Map.Strict.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves - | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo logicalColour game + | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour -- N.B.: 'findQualifiedMovesAvailableToNextPlayer' unnecessarily constructs a list. + = fromIntegral $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves + | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo logicalColour game -- | Retrieve the recorded value, or generate the list of /move/s available to the next player. -findQualifiedMovesAvailableToNextPlayer :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Game x y -> [Component.QualifiedMove.QualifiedMove x y] -{-# SPECIALISE findQualifiedMovesAvailableToNextPlayer :: Game Type.Length.X Type.Length.Y -> [Component.QualifiedMove.QualifiedMove Type.Length.X Type.Length.Y] #-} +findQualifiedMovesAvailableToNextPlayer :: Game -> [Component.QualifiedMove.QualifiedMove] findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo nextLogicalColour game -- | Let the specified player resign. -resignationBy :: Attribute.LogicalColour.LogicalColour -> Transformation x y +resignationBy :: Attribute.LogicalColour.LogicalColour -> Transformation resignationBy logicalColour game | isTerminated game = game -- Already terminated. | otherwise = game { @@ -1419,11 +1198,11 @@ } -- | Resignation by the player who currently holds the choice of /move/. -resign :: Transformation x y +resign :: Transformation resign game@MkGame { getNextLogicalColour = nextLogicalColour } = resignationBy nextLogicalColour game -- | Agree to a draw. -agreeToADraw :: Transformation x y +agreeToADraw :: Transformation agreeToADraw game | isTerminated game = game -- Already terminated. | otherwise = game { @@ -1431,7 +1210,7 @@ } -- | Whether the game has been terminated. -isTerminated :: Game x y -> Bool +isTerminated :: Game -> Bool isTerminated MkGame { getMaybeTerminationReason = maybeTerminationReason } = Data.Maybe.isJust maybeTerminationReason {- | @@ -1439,15 +1218,7 @@ * N.B.: resignation isn't included, because it leaves no evidence on the board. -} -inferMaybeTerminationReason :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Game x y -> Maybe Rule.GameTerminationReason.GameTerminationReason -{-# SPECIALISE inferMaybeTerminationReason :: Game Type.Length.X Type.Length.Y -> Maybe Rule.GameTerminationReason.GameTerminationReason #-} +inferMaybeTerminationReason :: Game -> Maybe Rule.GameTerminationReason.GameTerminationReason inferMaybeTerminationReason game@MkGame { getBoard = board, getInstancesByPosition = instancesByPosition @@ -1468,13 +1239,13 @@ | 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 :: Rule.Result.Result -> Transformation x y +updateTerminationReasonWith :: Rule.Result.Result -> Transformation updateTerminationReasonWith result game | Just victorsLogicalColour <- Rule.Result.findMaybeVictor result = resignationBy (Property.Opposable.getOpposite victorsLogicalColour) game | otherwise = agreeToADraw game -- | Forwards request to "State.CastleableRooksByLogicalColour". -cantConverge :: Game x y -> Game x y -> Bool +cantConverge :: Game -> Game -> Bool cantConverge MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour } MkGame { @@ -1482,13 +1253,7 @@ } = State.CastleableRooksByLogicalColour.cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour' -- | Constructor. -mkPosition :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Game x y -> State.Position.Position x y -{-# SPECIALISE mkPosition :: Game Type.Length.X Type.Length.Y -> State.Position.Position Type.Length.X Type.Length.Y #-} +mkPosition :: Game -> State.Position.Position mkPosition game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, @@ -1496,22 +1261,10 @@ } = State.Position.mkPosition nextLogicalColour (State.Board.getMaybePieceByCoordinates board) castleableRooksByLogicalColour $ maybeLastTurn game -- | Constructor. Count the instances of each repeatable /position/. -mkInstancesByPosition :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Game x y -> InstancesByPosition x 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-} - ) . ( - (`Data.Map.Strict.singleton` 1) . mkPosition &&& takeWhile ( - Component.Turn.getIsRepeatableMove . snd {-turn-} - ) . rollBack - ) +mkInstancesByPosition :: Game -> InstancesByPosition +mkInstancesByPosition game = State.InstancesByPosition.mkInstancesByPosition mkPosition . (game :) . map fst {-game-} . takeWhile ( + Component.Turn.getIsRepeatableMove . snd {-turn-} + ) $ rollBack game {- | * Whether the specified /game/'s /position/s have converged, & despite perhaps having reached this /position/ from different /move/-sequences, now have equal opportunities. @@ -1522,39 +1275,23 @@ * CAVEAT: though convenient, this function shouldn't be called for repeated tests against a constant /position/, resulting in unnecessary repeated construction of that /position/. -} -(=~) :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Game x y -> Game x y -> Bool -{-# SPECIALISE (=~) :: Game Type.Length.X Type.Length.Y -> Game Type.Length.X Type.Length.Y -> Bool #-} +(=~) :: Game -> Game -> Bool game =~ game' = mkPosition game == mkPosition game' -- | Whether the state of the specified /game/s is different. -(/~) :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Game x y -> Game x y -> Bool +(/~) :: Game -> Game -> Bool game /~ game' = not $ game =~ game' -- | Update the /position-hash/ of the /game/ prior to application of the last /move/. -updateIncrementalPositionHash :: ( - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y - ) - => Game x y -- ^ The /game/ before application of the last move. - -> positionHash -- ^ The value before application of the last move. - -> Game x y -- ^ The current game. - -> Component.Zobrist.Zobrist x y positionHash +updateIncrementalPositionHash + :: Data.Bits.Bits positionHash + => Game -- ^ The /game/ before application of the last move. + -> positionHash -- ^ The value before application of the last move. + -> Game -- ^ The current game. + -> Component.Zobrist.Zobrist positionHash -> 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 . ( +{-# SPECIALISE updateIncrementalPositionHash :: Game -> Type.Crypto.PositionHash -> Game -> Component.Zobrist.Zobrist Type.Crypto.PositionHash -> Type.Crypto.PositionHash #-} +updateIncrementalPositionHash game positionHash game' zobrist = StateProperty.Hashable.combine positionHash . (++) randomsFromMoveType . ( let (castleableRooksByLogicalColour, castleableRooksByLogicalColour') = ($ game) &&& ($ game') $ getCastleableRooksByLogicalColour in if isCastle || castleableRooksByLogicalColour /= castleableRooksByLogicalColour' @@ -1571,7 +1308,7 @@ State.Board.getMaybePieceByCoordinates $ getBoard g ) -- CAVEAT: accounts for any change to the En-passant option, rather than the act of taking En-passant. ) [game, game'], - random <- Component.Zobrist.listRandoms1D enPassantAbscissa zobrist + random <- StateProperty.Hashable.listRandoms enPassantAbscissa zobrist ] {-list-comprehension-} ++ Component.Zobrist.getRandomForBlacksMove zobrist : [ Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (lastLogicalColour, rankAccessor turn, coordinatesAccessor move) zobrist | (rankAccessor, coordinatesAccessor) <- zip [Component.Turn.getRank, (`Data.Maybe.fromMaybe` Attribute.Rank.getMaybePromotionRank moveType) . Component.Turn.getRank] coordinatesAccessors 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 @@ -70,7 +70,6 @@ import qualified BishBosh.Property.Null as Property.Null 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 @@ -80,13 +79,13 @@ import qualified Data.Tree -- | Each node defines the state of the game. -type BareGameTree x y = Data.Tree.Tree (Model.Game.Game x y) +type BareGameTree = Data.Tree.Tree Model.Game.Game -- | Forwards request to 'Component.Turn.compareByMVVLVA'. compareByMVVLVA :: Attribute.Rank.EvaluateRank - -> BareGameTree x y - -> BareGameTree x y + -> BareGameTree + -> BareGameTree -> Ordering compareByMVVLVA evaluateRank Data.Tree.Node { Data.Tree.rootLabel = gameL } Data.Tree.Node { Data.Tree.rootLabel = gameR } = uncurry ( Component.Turn.compareByMVVLVA evaluateRank @@ -95,7 +94,7 @@ ) $ Data.Maybe.fromJust . Model.Game.maybeLastTurn -- | Get the last move responsible for the current position. -getLastMove :: BareGameTree x y -> Component.Move.Move x y +getLastMove :: BareGameTree -> Component.Move.Move {-# INLINE getLastMove #-} getLastMove Data.Tree.Node { Data.Tree.rootLabel = game } = Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove . Data.Maybe.fromJust $ Model.Game.maybeLastTurn game @@ -107,15 +106,14 @@ * 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) - => Attribute.Rank.EvaluateRank - -> BareGameTree x y + :: Attribute.Rank.EvaluateRank + -> BareGameTree -> 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 :: Model.Game.Game -> 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 :: BareGameTree -> Attribute.Rank.Rank -> Type.Mass.RankValue slave node'@Data.Tree.Node { Data.Tree.subForest = forest' } = max 0 {-this player shouldn't progress the battle-} . subtract ( case filter ( ( @@ -137,30 +135,22 @@ ) . realToFrac . evaluateRank {-of victim-} -- | Accessor. -getRankAndMove :: Model.MoveFrequency.GetRankAndMove (BareGameTree x y) (Component.Move.Move x y) +getRankAndMove :: Model.MoveFrequency.GetRankAndMove BareGameTree Component.Move.Move {-# INLINE getRankAndMove #-} getRankAndMove Data.Tree.Node { Data.Tree.rootLabel = game } = (Component.Turn.getRank &&& Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove) . Data.Maybe.fromJust $ Model.Game.maybeLastTurn game -- | Wrap a 'BareGameTree'. -newtype GameTree x y = MkGameTree { - deconstruct :: BareGameTree x y +newtype GameTree = MkGameTree { + deconstruct :: BareGameTree } deriving Show {-CAVEAT: required by QuickCheck, but shouldn't actually be called-} -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Data.Default.Default (GameTree x y) where - {-# SPECIALISE instance Data.Default.Default (GameTree Type.Length.X Type.Length.Y) #-} +instance Data.Default.Default GameTree where def = fromGame Data.Default.def -instance Property.Arboreal.Prunable (GameTree x y) where +instance Property.Arboreal.Prunable GameTree where prune depth MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Property.Arboreal.prune depth bareGameTree -instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotation (GameTree x y) where +instance Notation.MoveNotation.ShowNotation GameTree where showsNotation moveNotation MkGameTree { deconstruct = bareGameTree@Data.Tree.Node { Data.Tree.rootLabel = game, @@ -173,19 +163,11 @@ toString = Notation.MoveNotation.showNotation moveNotation . Data.Maybe.fromJust . Model.Game.maybeLastTurn -- | Constructor. -fromBareGameTree :: BareGameTree x y -> GameTree x y +fromBareGameTree :: BareGameTree -> GameTree fromBareGameTree = MkGameTree -- | Constructs a game-tree with the specified game at its root. -fromGame :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Model.Game.Game x y -> GameTree x y -{-# SPECIALISE fromGame :: Model.Game.Game Type.Length.X Type.Length.Y -> GameTree Type.Length.X Type.Length.Y #-} +fromGame :: Model.Game.Game -> GameTree fromGame = MkGameTree . Data.Tree.unfoldTree ( \game -> ( game, @@ -203,25 +185,24 @@ * N.B.: some of the /game-state/s may have identical positions, reached by different sequences of /move/s. -} countGames :: Property.Arboreal.Depth -> Type.Count.NGames -countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree Type.Length.X Type.Length.Y) +countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree) -- | Counts the number of possible positions in chess, down to the specified depth. N.B.: some of these may be transpositions. countPositions :: Property.Arboreal.Depth -> Type.Count.NPositions -countPositions depth = fromIntegral . pred {-the apex is constructed without moving-} . Data.Foldable.length . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree Type.Length.X Type.Length.Y) +countPositions depth = fromIntegral . pred {-the apex is constructed without moving-} . Data.Foldable.length . deconstruct $ Property.Arboreal.prune depth (Data.Default.def :: GameTree) -- | Trace the route down the tree which matches the specified list of turns. traceRoute - :: (Eq x, Eq y) - => GameTree x y - -> [Component.Turn.Turn x y] -- ^ The data against which, nodes from the tree should be matched. - -> Maybe [Model.Game.Game x y] -- ^ Returns 'Nothing' on match-failure. + :: GameTree + -> [Component.Turn.Turn] -- ^ The data against which, nodes from the tree should be matched. + -> Maybe [Model.Game.Game] -- ^ Returns 'Nothing' on match-failure. traceRoute MkGameTree { deconstruct = bareGameTree } = Data.RoseTree.traceRoute (\turn -> (== Just turn) . Model.Game.maybeLastTurn) bareGameTree -- | Focus the underlying type. -type MoveFrequency x y = Model.MoveFrequency.MoveFrequency (Component.Move.Move x y) +type MoveFrequency = Model.MoveFrequency.MoveFrequency Component.Move.Move -- | Self-documentation. -type Transformation x y = GameTree x y -> GameTree x y +type Transformation = GameTree -> GameTree {- | * Independently sorts the forest of moves at each node of the tree, without regard to runtime-data. @@ -231,12 +212,10 @@ * The above sort-algorithms are stable & can therefore be applied independently. -} sortGameTree - :: (Integral x, Integral y) - => Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm + :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank - -> MoveFrequency x y - -> Transformation x y -{-# SPECIALISE sortGameTree :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank -> MoveFrequency Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-} + -> MoveFrequency + -> Transformation sortGameTree maybeCaptureMoveSortAlgorithm evaluateRank standardOpeningMoveFrequency MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Data.RoseTree.mapForest ( \game -> Data.Maybe.maybe id ( \case @@ -260,7 +239,7 @@ Had the move-frequency been derived from a list of games, a different distribution would result, 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 :: GameTree -> MoveFrequency 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' ( 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 @@ -22,7 +22,7 @@ [@DESCRIPTION@] - * The instances of various moves, categorised by /logical colour/ & /rank/, are recorded from a large resource of games. + * The instances of various moves, categorised by /logical colour/ & /rank/, are recorded from recorded games. * The frequency-distribution can then be used to sort the moves in the current game, to prioritise evaluation of likely candidates. -} @@ -36,7 +36,7 @@ MoveFrequency(), -- * Functions countEntries, --- countDistinctEntries, + countDistinctEntries, insertMoves, sortByDescendingMoveFrequency ) where @@ -51,7 +51,7 @@ import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map import qualified Data.Ord {- | @@ -61,7 +61,7 @@ -} type InstancesByMoveByRankByLogicalColour move = Attribute.LogicalColour.ArrayByLogicalColour ( Attribute.Rank.ArrayByRank ( - Data.Map.Strict.Map move Type.Count.NPlies + Map.Map move Type.Count.NPlies ) ) @@ -74,7 +74,7 @@ empty = MkMoveFrequency . Attribute.LogicalColour.listArrayByLogicalColour . repeat . Attribute.Rank.listArrayByRank $ repeat Property.Empty.empty instance Property.Null.Null (MoveFrequency move) where - isNull MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.all (Data.Foldable.all Data.Map.Strict.null) instancesByMoveByRankByLogicalColour + isNull MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.Foldable.all (Data.Foldable.all Data.Foldable.null) instancesByMoveByRankByLogicalColour -- | Count the total number of entries. countEntries :: MoveFrequency move -> Type.Count.NPlies @@ -82,10 +82,16 @@ Data.Foldable.foldl' $ \acc -> (acc +) . Data.Foldable.sum ) 0 instancesByMoveByRankByLogicalColour --- | Count the total number of distinct entries. +{- | + * Count the total number of distinct entries. + + * N.B.: in this context, a distinct move is one which wasn't made in any other branch of the tree. + E.g.: many recorded games will start with the same move, which becomes just one node in the game-tree from which this structure is derived, & so will only have a count of one in this structure. + If this same move is also made subsequently (i.e. after a different opening), then it exists on a different branch of the tree, & increases the move's count to 2 but doesn't increase the number of distinct moves. +-} countDistinctEntries :: MoveFrequency move -> Type.Count.NPlies countDistinctEntries MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = fromIntegral $ Data.Foldable.foldl' ( - Data.Foldable.foldl' $ \acc -> (acc +) . Data.Map.Strict.size + Data.Foldable.foldl' $ \acc -> (acc +) . Data.Foldable.length ) 0 instancesByMoveByRankByLogicalColour -- | The type of a function which can extract the /rank/ & /move/ from a datum. @@ -124,7 +130,7 @@ ] -- List-comprehension. where instancesByMoveByRank = instancesByMoveByRankByLogicalColour ! logicalColour - incrementMoveCount = flip (Data.Map.Strict.insertWith (+)) 1 + incrementMoveCount = flip (Map.insertWith (+)) 1 {- | * Sorts an arbitrary list on the recorded frequency of the /rank/ & /move/ accessible from each list-item. @@ -140,6 +146,6 @@ -> [a] {-# INLINE sortByDescendingMoveFrequency #-} sortByDescendingMoveFrequency logicalColour getRankAndMove MkMoveFrequency { deconstruct = instancesByMoveByRankByLogicalColour } = Data.List.sortOn $ negate {-most frequent first-} . ( - \(rank, move) -> Data.Map.Strict.findWithDefault 0 move $ instancesByMoveByRankByLogicalColour ! logicalColour ! rank + \(rank, move) -> Map.findWithDefault 0 move $ instancesByMoveByRankByLogicalColour ! logicalColour ! rank ) . getRankAndMove 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 @@ -38,12 +38,12 @@ import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Model.GameTree as Model.GameTree import qualified BishBosh.Property.Arboreal as Property.Arboreal +import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.Text.ShowList as Text.ShowList 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 import qualified Data.Default import qualified Data.List @@ -63,20 +63,15 @@ 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 Type.Length.X Type.Length.Y) + def = mkPositionHashTree Data.Default.def (Data.Default.def :: Model.GameTree.GameTree) -- | Hash the specified 'game-tree/. -mkPositionHashTree :: ( - Data.Array.IArray.Ix x, - Data.Bits.Bits positionHash, - Enum x, - Enum y, - Ord y - ) - => Component.Zobrist.Zobrist x y positionHash - -> Model.GameTree.GameTree x y +mkPositionHashTree + :: Data.Bits.Bits positionHash + => Component.Zobrist.Zobrist positionHash + -> Model.GameTree.GameTree -> PositionHashTree positionHash -mkPositionHashTree zobrist = MkPositionHashTree . fmap (`Component.Zobrist.hash2D` zobrist) . Model.GameTree.deconstruct +mkPositionHashTree zobrist = MkPositionHashTree . fmap (`StateProperty.Hashable.hash` zobrist) . Model.GameTree.deconstruct -- | Count the number of distinct positions, irrespective of the sequence of moves taken to reach that terminal state. countDistinctPositions @@ -96,5 +91,5 @@ } = Data.Set.singleton hash -- Being unable to descend further, include the terminal game's hash. slave depth' Data.Tree.Node { Data.Tree.subForest = forest } = Data.List.foldl' ( \s -> Data.Set.union s . slave (pred depth') {-recurse-} - ) Data.Set.empty forest + ) Property.Empty.empty forest diff --git a/src-lib/BishBosh/Notation/Figurine.hs b/src-lib/BishBosh/Notation/Figurine.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Notation/Figurine.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 the translation between /piece/s & Unicode figurines; . +-} + +module BishBosh.Notation.Figurine( +-- * Types +-- ** Type-synonyms +-- Figurine, +-- * Constants +-- figurinesByPiece, +-- piecesByFigurine, +-- * Functions + toFigurine, + fromFigurine +) where + +import Data.Array.IArray((!)) +import qualified BishBosh.Component.Piece as Component.Piece +import qualified Data.Array.IArray +import qualified Data.Map.Strict as Map +import qualified Data.Tuple + +-- | A Unicode character depicting a piece. +type Figurine = Char + +-- | The constant Unicode by which to depict each piece. +figurinesByPiece :: Component.Piece.ArrayByPiece Figurine +figurinesByPiece = Component.Piece.listArrayByPiece "\x265F\x265C\x265E\x265D\x265B\x265A\x2659\x2656\x2658\x2657\x2655\x2654" + +-- | Returns the Unicode-character for the specified piece. +toFigurine :: Component.Piece.Piece -> Figurine +toFigurine = (figurinesByPiece !) + +-- | The constant piece corresponding to each Unicode figurine. +piecesByFigurine :: Map.Map Figurine Component.Piece.Piece +piecesByFigurine = Map.fromList . map Data.Tuple.swap $ Data.Array.IArray.assocs figurinesByPiece + +-- | Returns any piece which corresponds to the specified Unicode character. +fromFigurine :: Figurine -> Maybe Component.Piece.Piece +fromFigurine = (`Map.lookup` piecesByFigurine) + diff --git a/src-lib/BishBosh/Notation/ICCFNumeric.hs b/src-lib/BishBosh/Notation/ICCFNumeric.hs --- a/src-lib/BishBosh/Notation/ICCFNumeric.hs +++ b/src-lib/BishBosh/Notation/ICCFNumeric.hs @@ -31,40 +31,29 @@ -- getMaybePromotionRank ), -- * Constants - origin, --- xOriginOffset, --- yOriginOffset, + notation, regexSyntax, toRank, -- * Functions --- encode, - showsCoordinates, -- ** Constructors mkICCFNumeric, mkICCFNumeric' ) where -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&)) import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Notation.Notation as Notation.Notation import qualified Control.Arrow import qualified Control.Exception -import qualified Data.Char import qualified Data.List.Extra import qualified Data.Maybe import qualified Data.Tuple --- | The origin. -origin :: (Int, Int) -origin = Data.Char.ord &&& Data.Char.ord $ '1' - --- | The offset of the application's internal coordinate-system from this conventional one. -xOriginOffset, yOriginOffset :: Int -(xOriginOffset, yOriginOffset) = (Cartesian.Abscissa.xOrigin -) *** (Cartesian.Ordinate.yOrigin -) $ origin +-- | Define the parameters of the notation, using the minimum permissible values for /x/ & /y/ coordinates. +notation :: Notation.Notation.Notation +notation = Notation.Notation.mkNotation $ (id &&& id) '1' -- | Defines using a regex, the required syntax. regexSyntax :: String @@ -80,16 +69,16 @@ ] -- | Defines a /move/, to enable i/o in /ICCF Numeric/-notation. -data ICCFNumeric x y = MkICCFNumeric { - getMove :: Component.Move.Move x y, +data ICCFNumeric = MkICCFNumeric { + getMove :: Component.Move.Move, getMaybePromotionRank :: Maybe Attribute.Rank.Rank } deriving Eq -- | Smart constructor. mkICCFNumeric - :: Component.Move.Move x y + :: Component.Move.Move -> Maybe Attribute.Rank.Rank -- ^ The optional promotion-rank. - -> ICCFNumeric x y + -> ICCFNumeric mkICCFNumeric move maybePromotionRank | Just rank <- maybePromotionRank , rank `notElem` Attribute.Rank.promotionProspects = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Notation.ICCFNumeric.mkICCFNumeric:\tcan't promote to a " $ shows rank "." @@ -101,46 +90,27 @@ -- | Smart constructor. mkICCFNumeric' :: Attribute.Rank.Promotable promotable - => Component.Move.Move x y + => Component.Move.Move -> promotable -- ^ The datum from which to extract the optional promotion-rank. - -> ICCFNumeric x y + -> ICCFNumeric mkICCFNumeric' move = mkICCFNumeric move . Attribute.Rank.getMaybePromotionRank --- | Encodes the ordinate & abscissa. -encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS) -encode = showChar . Data.Char.chr . subtract xOriginOffset . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . subtract yOriginOffset . fromEnum . Cartesian.Coordinates.getY - --- | Shows the specified /coordinates/. -showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS -showsCoordinates = uncurry (.) . encode - -instance (Enum x, Enum y) => Show (ICCFNumeric x y) where +instance Show ICCFNumeric where showsPrec _ MkICCFNumeric { getMove = move, getMaybePromotionRank = maybePromotionRank - } = showsCoordinates ( + } = Notation.Notation.showsCoordinates notation ( Component.Move.getSource move - ) . showsCoordinates ( + ) . Notation.Notation.showsCoordinates notation ( Component.Move.getDestination move ) . Data.Maybe.maybe id ( shows . Data.Maybe.fromJust . (`lookup` map Data.Tuple.swap toRank) ) maybePromotionRank -- N.B. this merely validates the syntax, leaving any semantic errors to 'Model.Game.validate'. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Read (ICCFNumeric x y) where +instance Read ICCFNumeric where readsPrec _ s = case Data.List.Extra.trimStart s of - x : y : x' : y' : remainder -> let - fromICCFNumeric x'' y'' = Cartesian.Coordinates.mkMaybeCoordinates ( - toEnum $ Data.Char.ord x'' + xOriginOffset - ) ( - toEnum $ Data.Char.ord y'' + yOriginOffset - ) - in [ + x : y : x' : y' : remainder -> [ Control.Arrow.first ( mkICCFNumeric $ Component.Move.mkMove source destination ) ( @@ -150,12 +120,13 @@ | otherwise -> (Nothing, remainder) _ -> (Nothing, remainder) ) | - source <- Data.Maybe.maybeToList $ fromICCFNumeric x y, - destination <- Data.Maybe.maybeToList $ fromICCFNumeric x' y', + let mkCoordinatesList = Data.Maybe.maybeToList . Notation.Notation.mkMaybeCoordinates notation, + source <- mkCoordinatesList (x, y), + destination <- mkCoordinatesList (x', y'), source /= destination ] -- List-comprehension. _ -> [] -- No parse. -instance Attribute.Rank.Promotable (ICCFNumeric x y) where +instance Attribute.Rank.Promotable ICCFNumeric where getMaybePromotionRank = getMaybePromotionRank 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 @@ -41,6 +41,7 @@ readsQualifiedMove, showNotation, showsMoveSyntax, + getNotation, getOrigin, showsNotationFloatToNDecimals, -- ** Predicates @@ -54,6 +55,7 @@ import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Notation.ICCFNumeric as Notation.ICCFNumeric +import qualified BishBosh.Notation.Notation as Notation.Notation import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Notation.Smith as Notation.Smith import qualified BishBosh.Property.FixedMembership as Property.FixedMembership @@ -101,17 +103,10 @@ pureCoordinate = PureCoordinate -- | Reads a /move/ & /move-type/ from the specified 'MoveNotation'. -readsQualifiedMove :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => MoveNotation - -> ReadS (Component.EitherQualifiedMove.EitherQualifiedMove x y) -readsQualifiedMove ICCFNumeric = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkPartiallyQualifiedMove . (Notation.ICCFNumeric.getMove &&& Attribute.Rank.getMaybePromotionRank)) . reads +readsQualifiedMove :: MoveNotation -> ReadS Component.EitherQualifiedMove.EitherQualifiedMove +readsQualifiedMove ICCFNumeric = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkPartiallyQualifiedMove . (Notation.ICCFNumeric.getMove &&& Attribute.Rank.getMaybePromotionRank)) . reads readsQualifiedMove PureCoordinate = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkPartiallyQualifiedMove . (Notation.PureCoordinate.getMove &&& Attribute.Rank.getMaybePromotionRank)) . reads -readsQualifiedMove Smith = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkFullyQualifiedMove . (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Notation.Smith.getQualifiedMove) . reads +readsQualifiedMove Smith = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkFullyQualifiedMove . (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Notation.Smith.getQualifiedMove) . reads -- | Show the syntax required by a specific 'MoveNotation'. showsMoveSyntax :: MoveNotation -> ShowS @@ -122,11 +117,15 @@ Smith -> Notation.Smith.regexSyntax ) . showChar '/' +-- | Returns the notation-parameters. +getNotation :: MoveNotation -> Notation.Notation.Notation +getNotation ICCFNumeric = Notation.ICCFNumeric.notation +getNotation PureCoordinate = Notation.PureCoordinate.notation +getNotation Smith = Notation.Smith.notation + -- | Returns the origin of the specified coordinate-system. -getOrigin :: MoveNotation -> (Int, Int) -getOrigin ICCFNumeric = Notation.ICCFNumeric.origin -getOrigin PureCoordinate = Notation.PureCoordinate.origin -getOrigin Smith = Notation.Smith.origin +getOrigin :: MoveNotation -> Notation.Notation.CoordinatePairI +getOrigin = Notation.Notation.getOrigin . getNotation -- | Predicate. isPureCoordinate :: MoveNotation -> Bool @@ -137,7 +136,7 @@ class ShowNotation a where showsNotation :: MoveNotation -> a -> ShowS -instance (Enum x, Enum y) => ShowNotation (Component.QualifiedMove.QualifiedMove x y) where +instance ShowNotation Component.QualifiedMove.QualifiedMove where showsNotation moveNotation qualifiedMove = case moveNotation of ICCFNumeric -> shows $ Notation.ICCFNumeric.mkICCFNumeric' move moveType PureCoordinate -> shows $ Notation.PureCoordinate.mkPureCoordinate' move moveType @@ -145,13 +144,11 @@ where (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove -instance (Enum x, Enum y) => ShowNotation (Component.Turn.Turn x y) where +instance ShowNotation Component.Turn.Turn where showsNotation moveNotation = showsNotation moveNotation . Component.Turn.getQualifiedMove -instance (Enum x, Enum y) => ShowNotation (Cartesian.Coordinates.Coordinates x y) where - showsNotation ICCFNumeric = Notation.ICCFNumeric.showsCoordinates - showsNotation PureCoordinate = Notation.PureCoordinate.showsCoordinates - showsNotation Smith = Notation.Smith.showsCoordinates +instance ShowNotation Cartesian.Coordinates.Coordinates where + showsNotation = Notation.Notation.showsCoordinates . getNotation -- | Show an arbitrary datum using the specified notation. showNotation :: (ShowNotation a) => MoveNotation -> a -> String diff --git a/src-lib/BishBosh/Notation/Notation.hs b/src-lib/BishBosh/Notation/Notation.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Notation/Notation.hs @@ -0,0 +1,157 @@ +{- + 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 common basis for standard notations. + + * CAVEAT: this module is only concerned with the representation of /x/ & /y/ coordinates, not any additional move-feature like enpassant, promotion or castling. + +-} + +module BishBosh.Notation.Notation( +-- * Types +-- ** Type-synonyms +-- CoordinatePairC, + CoordinatePairI, +-- ** Data-types + Notation( +-- MkNotation, + getMinC, + getMaxC, + getOrigin, + getOriginOffset + ), +-- * Functions + encode, + mkMaybeCoordinates, + showsCoordinates, + readsCoordinates, +-- ** Constructors + mkNotation, +-- ** Predicates + inXRange, + inYRange +-- inRange +) where + +import Control.Arrow((&&&), (***)) +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Type.Length as Type.Length +import qualified Control.Exception +import qualified Data.Char +import qualified Data.List.Extra +import qualified Data.Maybe + +-- | The characters used in a standard notation to denote a 'CoordinatePairI'. +type CoordinatePairC = (Char, Char) + +-- | A numeric representation of some coordinates in the standard notation. +type CoordinatePairI = (Type.Length.X, Type.Length.Y) + +-- | The parameters defining a generic chess-notation. +data Notation = MkNotation { + getMinC :: CoordinatePairC, -- ^ The character which a standard notation uses to represent the minimum value on each axis. + getMaxC :: CoordinatePairC, -- ^ The character which a standard notation uses to represent the maximum value on each axis. + getOrigin :: CoordinatePairI, -- ^ The numeric pair corresponding to the character-pair. + getOriginOffset :: CoordinatePairI -- ^ The offset of the application's internal coordinate-system from a standard one. +} + +-- | Smart constructor. +mkNotation :: CoordinatePairC -> Notation +mkNotation pair + | not . uncurry (&&) $ (ok *** ok) pair = Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.Notation.Notation.mkNotation:\tASCII character required." + | otherwise = notation + where + ok = uncurry (&&) . (Data.Char.isAscii &&& Data.Char.isAlphaNum) + + notation = MkNotation { + getMinC = pair, + getMaxC = ( + Data.Char.chr . fromIntegral . ( + + pred {-fence-post-} Cartesian.Abscissa.xLength + ) *** Data.Char.chr . fromIntegral . ( + + pred {-fence-post-} Cartesian.Ordinate.yLength + ) + ) $ getOrigin notation, + getOrigin = ( + fromIntegral . Data.Char.ord *** fromIntegral . Data.Char.ord + ) $ getMinC notation, + getOriginOffset = ( + (Cartesian.Abscissa.xMin -) *** (Cartesian.Ordinate.yMin -) + ) $ getOrigin notation + } + +-- | Whether the specified character falls within a standard notation's range. +inXRange :: Notation -> Char -> Bool +inXRange notation c = uncurry (&&) $ ((<= c) . fst {-x-} . getMinC &&& (>= c) . fst {-x-} . getMaxC) notation + +-- | Whether the specified character falls within a standard notation's range. +inYRange :: Notation -> Char -> Bool +inYRange notation c = uncurry (&&) $ ((<= c) . snd {-y-} . getMinC &&& (>= c) . snd {-y-} . getMaxC) notation + +-- | Whether the specified pair of characters fall within a standard notation's range. +inRange :: Notation -> CoordinatePairC -> Bool +inRange notation = uncurry (&&) . ( + uncurry (&&) . ( + (>= xMinC) &&& (<= xMaxC) + ) *** uncurry (&&) . ( + (>= yMinC) &&& (<= yMaxC) + ) + ) where + ((xMinC, yMinC), (xMaxC, yMaxC)) = getMinC &&& getMaxC $ notation + +-- | Encodes the ordinate & abscissa. +encode :: Notation -> Cartesian.Coordinates.Coordinates -> (ShowS, ShowS) +encode notation = showChar . Data.Char.chr . fromIntegral . subtract xOriginOffset . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . fromIntegral . subtract yOriginOffset . Cartesian.Coordinates.getY where + (xOriginOffset, yOriginOffset) = getOriginOffset notation + +{- | + * Attempt to construct coordinates from the specified characters. + + * A check that the specified characters are in the permissible bounds is performed before conversion incase the numeric type has a narrower range than 'Char'. +-} +mkMaybeCoordinates :: Notation -> CoordinatePairC -> Maybe Cartesian.Coordinates.Coordinates +mkMaybeCoordinates notation pair + | inRange notation pair = uncurry Cartesian.Coordinates.mkMaybeCoordinates $ ( + (+ xOriginOffset) . fromIntegral . Data.Char.ord *** (+ yOriginOffset) . fromIntegral . Data.Char.ord + ) pair + | otherwise = Nothing + where + (xOriginOffset, yOriginOffset) = getOriginOffset notation + +-- | Shows the specified /coordinates/. +showsCoordinates :: Notation -> Cartesian.Coordinates.Coordinates -> ShowS +showsCoordinates notation = uncurry (.) . encode notation + +-- | Reads coordinates. +readsCoordinates :: Notation -> ReadS Cartesian.Coordinates.Coordinates +readsCoordinates notation s = case Data.List.Extra.trimStart s of + x : y : remainder + | inRange notation coordinatePairC -> map (flip (,) remainder) . Data.Maybe.maybeToList $ mkMaybeCoordinates notation coordinatePairC + | otherwise -> [] -- No parse. + where + coordinatePairC = (x, y) + _ -> [] -- Mo parse. + 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 @@ -40,19 +40,11 @@ -- getMaybePromotionRank ), -- * Constants --- min', --- xMin, --- xMax, --- yMin, --- yMax, - origin, + notation, -- xOriginOffset, -- yOriginOffset, regexSyntax, -- * Functions - encode, - showsCoordinates, - readsCoordinates, abscissaParser, ordinateParser, coordinatesParser, @@ -60,18 +52,14 @@ mkPureCoordinate, mkPureCoordinate' -- ** Predicates --- inXRange, --- inYRange ) where -import Control.Arrow((&&&), (***)) -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Data.Exception as Data.Exception -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Notation.Notation as Notation.Notation +import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.Exception import qualified Data.Char @@ -80,44 +68,26 @@ #ifdef USE_POLYPARSE import qualified BishBosh.Text.Poly as Text.Poly -#if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly -#endif +# else +# error "USE_POLYPARSE invalid" +# endif #else /* Parsec */ import qualified Text.ParserCombinators.Parsec as Parsec import Text.ParserCombinators.Parsec(()) #endif --- | The minimum permissible values for /x/ & /y/ coordinates. -min' :: (Char, Char) -xMin, yMin :: Char -min'@(xMin, yMin) = ('a', '1') - --- | The origin of the coordinate-system. -origin :: (Int, Int) -origin = Data.Char.ord *** Data.Char.ord $ min' +-- | Define the parameters of the notation, using the minimum permissible values for /x/ & /y/ coordinates. +notation :: Notation.Notation.Notation +notation = Notation.Notation.mkNotation ('a', '1') -- | The offset of the application's internal coordinate-system from this conventional one. -xOriginOffset, yOriginOffset :: Int -(xOriginOffset, yOriginOffset) = (Cartesian.Abscissa.xOrigin -) *** (Cartesian.Ordinate.yOrigin -) $ origin - --- | The maximum permissible values for /x/ & /y/ coordinates. -xMax, yMax :: Char -(xMax, yMax) = Data.Char.chr . ( - + pred {-fence-post-} (fromIntegral Cartesian.Abscissa.xLength) - ) *** Data.Char.chr . ( - + pred {-fence-post-} (fromIntegral Cartesian.Ordinate.yLength) - ) $ origin - --- | Whether the specified character is a valid abscissa. -inXRange :: Char -> Bool -inXRange = uncurry (&&) . ((>= xMin) &&& (<= xMax)) - --- | Whether the specified character is a valid ordinate. -inYRange :: Char -> Bool -inYRange = uncurry (&&) . ((>= yMin) &&& (<= yMax)) +xOriginOffset :: Type.Length.X +yOriginOffset :: Type.Length.Y +(xOriginOffset, yOriginOffset) = Notation.Notation.getOriginOffset notation -- | Defines using a regex, the required syntax. regexSyntax :: String @@ -127,27 +97,15 @@ #ifdef USE_POLYPARSE -- | Parse an /x/-coordinate. -abscissaParser :: Enum x => Text.Poly.TextParser x -{-# SPECIALISE abscissaParser :: Text.Poly.TextParser Type.Length.X #-} -abscissaParser = ( - toEnum . (+ xOriginOffset) . Data.Char.ord - ) `fmap` Poly.satisfyMsg inXRange "Abscissa" +abscissaParser :: Text.Poly.TextParser Type.Length.X +abscissaParser = ((+ xOriginOffset) . fromIntegral . Data.Char.ord) `fmap` Poly.satisfyMsg (Notation.Notation.inXRange notation) "Abscissa" -- | Parse a /y/-coordinate. -ordinateParser :: Enum y => Text.Poly.TextParser y -{-# SPECIALISE ordinateParser :: Text.Poly.TextParser Type.Length.Y #-} -ordinateParser = ( - toEnum . (+ yOriginOffset) . Data.Char.ord - ) `fmap` Poly.satisfyMsg inYRange "Ordinate" +ordinateParser :: Text.Poly.TextParser Type.Length.Y +ordinateParser = ((+ yOriginOffset) . fromIntegral . Data.Char.ord) `fmap` Poly.satisfyMsg (Notation.Notation.inYRange notation) "Ordinate" -- | Parse a pair of /coordinates/. -coordinatesParser :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Text.Poly.TextParser (Cartesian.Coordinates.Coordinates x y) -{-# SPECIALISE coordinatesParser :: Text.Poly.TextParser (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) #-} +coordinatesParser :: Text.Poly.TextParser Cartesian.Coordinates.Coordinates coordinatesParser = do x <- abscissaParser y <- ordinateParser @@ -155,37 +113,29 @@ return {-to Parser-monad-} $ Cartesian.Coordinates.mkCoordinates x y #else /* Parsec */ -- | Parse an /x/-coordinate. -abscissaParser :: Enum x => Parsec.Parser x -{-# SPECIALISE abscissaParser :: Parsec.Parser Type.Length.X #-} -abscissaParser = toEnum . (+ xOriginOffset) . Data.Char.ord <$> Parsec.satisfy inXRange "Abscissa" +abscissaParser :: Parsec.Parser Type.Length.X +abscissaParser = (+ xOriginOffset) . fromIntegral . Data.Char.ord <$> Parsec.satisfy (Notation.Notation.inXRange notation) "Abscissa" -- | Parse a /y/-coordinate. -ordinateParser :: Enum y => Parsec.Parser y -{-# SPECIALISE ordinateParser :: Parsec.Parser Type.Length.X #-} -ordinateParser = toEnum . (+ yOriginOffset) . Data.Char.ord <$> Parsec.satisfy inYRange "Ordinate" +ordinateParser :: Parsec.Parser Type.Length.Y +ordinateParser = (+ yOriginOffset) . fromIntegral . Data.Char.ord <$> Parsec.satisfy (Notation.Notation.inYRange notation) "Ordinate" -- | Parse a pair of /coordinates/. -coordinatesParser :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Parsec.Parser (Cartesian.Coordinates.Coordinates x y) -{-# SPECIALISE coordinatesParser :: Parsec.Parser (Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y) #-} +coordinatesParser :: Parsec.Parser Cartesian.Coordinates.Coordinates coordinatesParser = Cartesian.Coordinates.mkCoordinates <$> abscissaParser <*> ordinateParser #endif -- | Defines a /move/, to enable i/o in /PureCoordinate/-notation. -data PureCoordinate x y = MkPureCoordinate { - getMove :: Component.Move.Move x y, +data PureCoordinate = MkPureCoordinate { + getMove :: Component.Move.Move, getMaybePromotionRank :: Maybe Attribute.Rank.Rank } deriving Eq -- | Smart constructor. mkPureCoordinate - :: Component.Move.Move x y + :: Component.Move.Move -> Maybe Attribute.Rank.Rank -- ^ The optional promotion-rank. - -> PureCoordinate x y + -> PureCoordinate mkPureCoordinate move maybePromotionRank | Just rank <- maybePromotionRank , rank `notElem` Attribute.Rank.promotionProspects = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Notation.PureCoordinate.mkPureCoordinate:\tcan't promote to a " $ shows rank "." @@ -197,61 +147,25 @@ -- | Smart constructor. mkPureCoordinate' :: Attribute.Rank.Promotable promotable - => Component.Move.Move x y + => Component.Move.Move -> promotable -- ^ The datum from which to extract the optional promotion-rank. - -> PureCoordinate x y + -> PureCoordinate mkPureCoordinate' move = mkPureCoordinate move . Attribute.Rank.getMaybePromotionRank --- | Encodes the ordinate & abscissa. -encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS) -encode = showChar . Data.Char.chr . subtract xOriginOffset . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . subtract yOriginOffset . fromEnum . Cartesian.Coordinates.getY - --- | Shows the specified /coordinates/. -showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS -showsCoordinates = uncurry (.) . encode - --- | Reads coordinates. -readsCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => ReadS (Cartesian.Coordinates.Coordinates x y) -readsCoordinates s = case Data.List.Extra.trimStart s of - x : y : remainder -> map ( - flip (,) remainder - ) . Data.Maybe.maybeToList $ Cartesian.Coordinates.mkMaybeCoordinates ( - toEnum $ Data.Char.ord x + xOriginOffset - ) ( - toEnum $ Data.Char.ord y + yOriginOffset - ) - _ -> [] -- Mo parse. - -instance (Enum x, Enum y) => Show (PureCoordinate x y) where +instance Show PureCoordinate where showsPrec _ MkPureCoordinate { getMove = move, getMaybePromotionRank = maybePromotionRank - } = showsCoordinates ( + } = Notation.Notation.showsCoordinates notation ( Component.Move.getSource move - ) . showsCoordinates ( + ) . Notation.Notation.showsCoordinates notation ( Component.Move.getDestination move ) . Data.Maybe.maybe id shows maybePromotionRank -- N.B. this merely validates the syntax, leaving any semantic errors to 'Model.Game.validate'. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Read (PureCoordinate x y) where +instance Read PureCoordinate where readsPrec _ s = case Data.List.Extra.trimStart s of - x : y : x' : y' : remainder -> let - translate x'' y'' = Cartesian.Coordinates.mkMaybeCoordinates ( - toEnum $ Data.Char.ord x'' + xOriginOffset - ) ( - toEnum $ Data.Char.ord y'' + yOriginOffset - ) - in [ + x : y : x' : y' : remainder -> [ Control.Arrow.first ( mkPureCoordinate $ Component.Move.mkMove source destination ) ( @@ -261,12 +175,13 @@ else (Nothing, remainder) _ -> (Nothing, remainder) ) | - source <- Data.Maybe.maybeToList $ translate x y, - destination <- Data.Maybe.maybeToList $ translate x' y', + let mkCoordinatesList = Data.Maybe.maybeToList . Notation.Notation.mkMaybeCoordinates notation, + source <- mkCoordinatesList (x, y), + destination <- mkCoordinatesList (x', y'), source /= destination ] -- List-comprehension. _ -> [] -- No parse. -instance Attribute.Rank.Promotable (PureCoordinate x y) where +instance Attribute.Rank.Promotable PureCoordinate where getMaybePromotionRank = getMaybePromotionRank diff --git a/src-lib/BishBosh/Notation/Smith.hs b/src-lib/BishBosh/Notation/Smith.hs --- a/src-lib/BishBosh/Notation/Smith.hs +++ b/src-lib/BishBosh/Notation/Smith.hs @@ -30,77 +30,75 @@ getQualifiedMove ), -- * Constants - origin, --- xOriginOffset, --- yOriginOffset, + notation, +-- enpassantTag, +-- shortCastleTag, +-- longCastleTag, regexSyntax, -- * Functions --- encode, - showsCoordinates, -- ** Constructor fromQualifiedMove ) where -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&)) import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Notation.Notation as Notation.Notation +import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified Control.Arrow import qualified Data.Char import qualified Data.Default import qualified Data.List.Extra import qualified Data.Maybe --- | The origin. -origin :: (Int, Int) -origin = ($ 'a') &&& ($ '1') $ Data.Char.ord +-- | Define the parameters of the notation, using the minimum permissible values for /x/ & /y/ coordinates. +notation :: Notation.Notation.Notation +notation = Notation.PureCoordinate.notation -- CAVEAT: the encoding of coordinates is only coincidentally identical. --- | The offset of the application's internal coordinate-system from this conventional one. -xOriginOffset, yOriginOffset :: Int -(xOriginOffset, yOriginOffset) = (Cartesian.Abscissa.xOrigin -) *** (Cartesian.Ordinate.yOrigin -) $ origin +-- | Token. +enpassantTag :: Char +enpassantTag = 'E' +-- | Token. +shortCastleTag :: Char +shortCastleTag = 'c' + +-- | Token. +longCastleTag :: Char +longCastleTag = 'C' + -- | Defines using a regex, the required syntax. regexSyntax :: String regexSyntax = showString "([a-h][1-8]){2}[" . showString ( concatMap show Attribute.Rank.range - ) . showString "EcC]?[" $ showString ( - Data.List.Extra.upper $ map (head . show) Attribute.Rank.promotionProspects + ) . showChar enpassantTag . showChar shortCastleTag . showChar longCastleTag . showString "]?[" $ showString ( + Data.List.Extra.upper $ concatMap show Attribute.Rank.promotionProspects ) "]?" -- | Defines a /move/, to enable i/o in /Smith/-notation. -newtype Smith x y = MkSmith { - getQualifiedMove :: Component.QualifiedMove.QualifiedMove x y +newtype Smith = MkSmith { + getQualifiedMove :: Component.QualifiedMove.QualifiedMove } deriving Eq -- | Constructor. -fromQualifiedMove :: Component.QualifiedMove.QualifiedMove x y -> Smith x y +fromQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Smith fromQualifiedMove = MkSmith --- | Encodes the ordinate & abscissa. -encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS) -encode = showChar . Data.Char.chr . subtract xOriginOffset . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . subtract yOriginOffset . fromEnum . Cartesian.Coordinates.getY - --- | Shows the specified /coordinates/. -showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS -showsCoordinates = uncurry (.) . encode - -instance (Enum x, Enum y) => Show (Smith x y) where +instance Show Smith where showsPrec _ MkSmith { getQualifiedMove = qualifiedMove } = let (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove - in showsCoordinates ( + in Notation.Notation.showsCoordinates notation ( Component.Move.getSource move - ) . showsCoordinates ( + ) . Notation.Notation.showsCoordinates notation ( Component.Move.getDestination move ) . ( case moveType of Attribute.MoveType.Castle isShort -> showChar $ if isShort - then 'c' - else 'C' - Attribute.MoveType.EnPassant -> showChar 'E' + then shortCastleTag + else longCastleTag + Attribute.MoveType.EnPassant -> showChar enpassantTag _ {-normal-} -> Data.Maybe.maybe id shows ( Attribute.MoveType.getMaybeExplicitlyTakenRank moveType ) . Data.Maybe.maybe id ( @@ -111,26 +109,16 @@ ) -- N.B. this merely validates the syntax, leaving any semantic errors to 'Model.Game.validate'. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Read (Smith x y) where +instance Read Smith where readsPrec _ s = case Data.List.Extra.trimStart s of - x : y : x' : y' : remainder -> let - fromSmith x'' y'' = Cartesian.Coordinates.mkMaybeCoordinates ( - toEnum $ Data.Char.ord x'' + xOriginOffset - ) ( - toEnum $ Data.Char.ord y'' + yOriginOffset - ) - in [ + x : y : x' : y' : remainder -> [ ( fromQualifiedMove $ Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType, remainder' ) | - source <- Data.Maybe.maybeToList $ fromSmith x y, - destination <- Data.Maybe.maybeToList $ fromSmith x' y', + let mkCoordinatesList = Data.Maybe.maybeToList . Notation.Notation.mkMaybeCoordinates notation, + source <- mkCoordinatesList (x, y), + destination <- mkCoordinatesList (x', y'), source /= destination, (moveType, remainder') <- case remainder of [] -> [(Data.Default.def, remainder)] @@ -157,6 +145,6 @@ ] -- List-comprehension. _ -> [] -- No parse. -instance Attribute.Rank.Promotable (Smith x y) where +instance Attribute.Rank.Promotable Smith where getMaybePromotionRank MkSmith { getQualifiedMove = qualifiedMove } = Attribute.Rank.getMaybePromotionRank $ Component.QualifiedMove.getMoveType qualifiedMove diff --git a/src-lib/BishBosh/Property/Empty.hs b/src-lib/BishBosh/Property/Empty.hs --- a/src-lib/BishBosh/Property/Empty.hs +++ b/src-lib/BishBosh/Property/Empty.hs @@ -33,12 +33,13 @@ Empty(..) ) where -import qualified Data.IntMap -import qualified Data.Map +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Set -- | An interface which data which can support the concept of being empty, may implement. class Empty a where - empty :: a -- ^ Constant. + empty :: a -- ^ A constant empty state. instance (Empty a, Empty b) => Empty (a, b) where empty = (empty, empty) @@ -49,9 +50,12 @@ instance Empty [a] where empty = [] -instance Empty (Data.Map.Map i e) where - empty = Data.Map.empty +instance Empty (IntMap.IntMap e) where + empty = IntMap.empty -instance Empty (Data.IntMap.IntMap e) where - empty = Data.IntMap.empty +instance Empty (Map.Map i e) where + empty = Map.empty + +instance Empty (Data.Set.Set i) where + empty = Data.Set.empty diff --git a/src-lib/BishBosh/Property/ExtendedPositionDescription.hs b/src-lib/BishBosh/Property/ExtendedPositionDescription.hs --- a/src-lib/BishBosh/Property/ExtendedPositionDescription.hs +++ b/src-lib/BishBosh/Property/ExtendedPositionDescription.hs @@ -25,10 +25,15 @@ -} module BishBosh.Property.ExtendedPositionDescription( +-- * Types +-- ** Type-synonyms + EPD, -- * Type-classes ReadsEPD(..), ShowsEPD(..), -- * Constants + tag, + rankSeparator, showsNullField, showsSeparator, -- * Functions @@ -44,14 +49,25 @@ class ShowsEPD a where showsEPD :: a -> ShowS -- ^ Stringify a EPD-datum. +-- | Self-documentation. +type EPD = String + +-- | Input-format. +tag :: String +tag = "epd" + +-- | The delimiter between each row of data. +rankSeparator :: Char +rankSeparator = '/' + -- | Read from EPD. -readEPD :: ReadsEPD a => String -> a -readEPD s = case readsEPD s of +readEPD :: ReadsEPD a => EPD -> a +readEPD epd = case readsEPD epd of [(a, _)] -> a - _ -> error . showString "BishBosh.Property.ExtendedPositionDescription.readEPD:\tfailed to parse " $ shows s "." + _ -> error . showString "BishBosh.Property.ExtendedPositionDescription.readEPD:\tfailed to parse " $ shows epd "." -- | Display in EPD. -showEPD :: ShowsEPD a => a -> String +showEPD :: ShowsEPD a => a -> EPD showEPD a = showsEPD a "" -- | The standard way to denote the absence of a field. diff --git a/src-lib/BishBosh/Property/ForsythEdwards.hs b/src-lib/BishBosh/Property/ForsythEdwards.hs --- a/src-lib/BishBosh/Property/ForsythEdwards.hs +++ b/src-lib/BishBosh/Property/ForsythEdwards.hs @@ -27,6 +27,9 @@ -} module BishBosh.Property.ForsythEdwards( +-- * Types +-- ** Type-synonyms +-- FEN, -- * Type-classes ReadsFEN(..), ShowsFEN(..), @@ -47,13 +50,16 @@ showsFEN :: a -> ShowS -- ^ Stringify a FEN-datum. showsFEN = Property.ExtendedPositionDescription.showsEPD -- Default implementation. +-- | Self-documentation. +type FEN = String + -- | Read from FEN. -readFEN :: ReadsFEN a => String -> a -readFEN s = case readsFEN s of +readFEN :: ReadsFEN a => FEN -> a +readFEN fen = case readsFEN fen of [(a, _)] -> a - _ -> error . showString "BishBosh.Property.ForsythEdwards.readFEN:\tfailed to parse " $ shows s "." + _ -> error . showString "BishBosh.Property.ForsythEdwards.readFEN:\tfailed to parse " $ shows fen "." -- | Display in FEN. -showFEN :: ShowsFEN a => a -> String +showFEN :: ShowsFEN a => a -> FEN showFEN a = showsFEN a "" diff --git a/src-lib/BishBosh/Property/Null.hs b/src-lib/BishBosh/Property/Null.hs --- a/src-lib/BishBosh/Property/Null.hs +++ b/src-lib/BishBosh/Property/Null.hs @@ -33,5 +33,5 @@ -- | An interface for data which can support the concept of being null. class Null a where - isNull :: a -> Bool -- ^ Predicate, cf. 'Prelude.null' for a 'Prelude.Foldable'. + isNull :: a -> Bool -- ^ Predicate. N.B.: similar to 'Data.Foldable.null', but for unfoldable types. 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 @@ -27,9 +27,14 @@ Opposable(..) ) where -import Prelude() +import Prelude(Ordering(..)) -- | An interface which data which have the concept of an opposite, may implement. class Opposable a where getOpposite :: a -> a + +instance Opposable Ordering where + getOpposite LT = GT + getOpposite GT = LT + getOpposite _ = EQ 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 @@ -65,7 +65,6 @@ import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour 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 @@ -73,10 +72,10 @@ import qualified Data.Tree -- | The type returned by 'negaMax'. -data Result x y positionHash = MkResult { - getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData x y positionHash, -- ^ Killer moves & transpositions. - getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y, - getNPositionsEvaluated :: Type.Count.NPositions -- ^ The total number of nodes analysed, before making the selection. +data Result positionHash = MkResult { + getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData positionHash, -- ^ Killer moves & transpositions. + getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame, + getNPositionsEvaluated :: Type.Count.NPositions -- ^ The total number of nodes analysed, before making the selection. } {- | @@ -86,8 +85,8 @@ -} extractSelectedTurns :: Type.Count.NPlies - -> Result x y positionHash - -> (Search.DynamicMoveData.DynamicMoveData x y positionHash, [Component.Turn.Turn x y], Type.Count.NPositions) + -> Result positionHash + -> (Search.DynamicMoveData.DynamicMoveData positionHash, [Component.Turn.Turn], Type.Count.NPositions) extractSelectedTurns nPlies MkResult { getDynamicMoveData = dynamicMoveData, getQuantifiedGame = quantifiedGame, @@ -99,16 +98,7 @@ ) -- | Record the last move as a killer, unless it's a capture move. -updateKillerMoves :: ( - Ord x, - Ord y, - Enum x, - Enum y, - Show x, - Show y - ) - => Model.Game.Game x y - -> Search.DynamicMoveData.Transformation x y positionHash +updateKillerMoves :: Model.Game.Game -> Search.DynamicMoveData.Transformation positionHash updateKillerMoves game | Just lastTurn <- Model.Game.maybeLastTurn game = if Component.Turn.isCapture lastTurn then id -- This move was (assuming appropriate Search-options) statically sorted. @@ -122,17 +112,10 @@ * CAVEAT: the return-value, is quantified from the perspective of the player who is about to move. -} -findTranspositionTerminalQuantifiedGame :: ( - Eq x, - Eq y, - Enum x, - Enum y, - Show x, - Show y - ) - => Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash - -> Search.TranspositionValue.TranspositionValue (Component.QualifiedMove.QualifiedMove x y) - -> Evaluation.QuantifiedGame.QuantifiedGame x y +findTranspositionTerminalQuantifiedGame + :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash + -> Search.TranspositionValue.TranspositionValue Component.QualifiedMove.QualifiedMove + -> Evaluation.QuantifiedGame.QuantifiedGame findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree transpositionValue = Data.Maybe.maybe ( Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Search.AlphaBeta.findTranspositionTerminalQuantifiedGame:\tEvaluation.PositionHashQuantifiedGameTree.traceMatchingMoves failed; " . shows transpositionValue . showString ":\n" $ ( Notation.MoveNotation.showsNotationFloatToNDecimals Data.Default.def {-move-notation-} 3 {-decimal digits-} $ Property.Arboreal.prune (fromIntegral inferredSearchDepth) positionHashQuantifiedGameTree @@ -147,21 +130,14 @@ inferredSearchDepth = Search.TranspositionValue.inferSearchDepth transpositionValue -- | Record a qualifiedMove-sequence in the transposition-table. -updateTranspositions :: ( - Eq x, - Eq y, - Enum x, - Enum y, - Ord positionHash, - Show x, - Show y - ) +updateTranspositions + :: Ord positionHash => Search.TranspositionValue.IsOptimal -> Type.Count.NPlies -> positionHash - -> [Component.Turn.Turn x y] - -> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash - -> Search.DynamicMoveData.Transformation x y positionHash + -> [Component.Turn.Turn] + -> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash + -> Search.DynamicMoveData.Transformation positionHash updateTranspositions isOptimal nPlies positionHash turns positionHashQuantifiedGameTree = Search.DynamicMoveData.updateTranspositions . Search.Transpositions.insert ( Evaluation.QuantifiedGame.getFitness . findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree ) positionHash {-the hash of the game before the first move in the sequence-} . Search.TranspositionValue.mkTranspositionValue isOptimal nPlies $ map Component.Turn.getQualifiedMove turns @@ -173,19 +149,12 @@ * /beta/ is the maximum fitness of which the minimising player is assured. -} -negaMax :: ( - Enum x, - Enum y, - Ord positionHash, - Ord x, - Ord y, - Show x, - Show y - ) +negaMax + :: Ord positionHash => 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) #-} + -> Search.SearchState.SearchState positionHash + -> Input.SearchOptions.Reader (Result positionHash) +{-# SPECIALISE negaMax :: Type.Count.NPlies -> Search.SearchState.SearchState Type.Crypto.PositionHash -> Input.SearchOptions.Reader (Result Type.Crypto.PositionHash) #-} negaMax initialSearchDepth initialSearchState = do maybeMinimumTranspositionSearchDepth <- Control.Monad.Reader.asks Input.SearchOptions.maybeMinimumTranspositionSearchDepth recordKillerMoves <- Control.Monad.Reader.asks Input.SearchOptions.recordKillerMoves @@ -195,10 +164,10 @@ getNPlies = State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour -- Abbreviate. {- descend - :: Evaluation.QuantifiedGame.OpenInterval x y + :: Evaluation.QuantifiedGame.OpenInterval -> Type.Count.NPlies - -> Search.SearchState.SearchState x y positionHash - -> Result x y positionHash + -> Search.SearchState.SearchState positionHash + -> Result positionHash -} descend (maybeAlphaQuantifiedGame, maybeBetaQuantifiedGame) searchDepth searchState | searchDepth == 0 || Model.Game.isTerminated game = MkResult { @@ -255,10 +224,10 @@ ) . Data.Tree.subForest $ Evaluation.PositionHashQuantifiedGameTree.deconstruct positionHashQuantifiedGameTree {- selectMax - :: Search.DynamicMoveData.DynamicMoveData x y positionHash - -> Maybe (Evaluation.QuantifiedGame.QuantifiedGame x y) - -> [Evaluation.PositionHashQuantifiedGameTree.BarePositionHashQuantifiedGameTree x y positionHash] - -> Result x y positionHash + :: Search.DynamicMoveData.DynamicMoveData positionHash + -> Maybe Evaluation.QuantifiedGame.QuantifiedGame + -> [Evaluation.PositionHashQuantifiedGameTree.BarePositionHashQuantifiedGameTree positionHash] + -> Result positionHash -} selectMax dynamicMoveData' maybeAlphaQuantifiedGame' (node : remainingNodes) | trapRepeatedPositions @@ -343,16 +312,16 @@ ) $ descend Evaluation.QuantifiedGame.unboundedInterval initialSearchDepth initialSearchState -- | The type of a function which transforms the result. -type Transformation x y positionHash = Result x y positionHash -> Result x y positionHash +type Transformation positionHash = Result positionHash -> Result positionHash -- | Mutator. -negateFitnessOfResult :: Transformation x y positionHash +negateFitnessOfResult :: Transformation positionHash negateFitnessOfResult result@MkResult { getQuantifiedGame = quantifiedGame } = result { getQuantifiedGame = Evaluation.QuantifiedGame.negateFitness quantifiedGame } -- | Mutator. -addNPositionsToResult :: Type.Count.NPositions -> Transformation x y positionHash +addNPositionsToResult :: Type.Count.NPositions -> Transformation 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 @@ -59,36 +59,36 @@ * CAVEAT: there's still ambiguity in this /key/, since it may match either a different piece of the same /rank/ or have a different /move-type/ (though typically only quiet moves are recorded), in sibling games. -} -data KillerMoveKey x y = MkKillerMoveKey (Component.Move.Move x y) Attribute.Rank.Rank deriving (Eq, Ord, Show) +data KillerMoveKey = MkKillerMoveKey Component.Move.Move Attribute.Rank.Rank deriving (Eq, Ord, Show) -- | Constructor. -mkKillerMoveKeyFromTurn :: Component.Turn.Turn x y -> KillerMoveKey x y +mkKillerMoveKeyFromTurn :: Component.Turn.Turn -> KillerMoveKey mkKillerMoveKeyFromTurn = uncurry MkKillerMoveKey . (Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove &&& Component.Turn.getRank) -- | The data on /move/s, gathered while searching. -data DynamicMoveData x y positionHash = MkDynamicMoveData { - getKillerMoves :: Search.KillerMoves.KillerMoves (KillerMoveKey x y), - getTranspositions :: Search.Transpositions.Transpositions (Component.QualifiedMove.QualifiedMove x y) positionHash -- ^ N.B. a qualifiedMove is used to additionally record any promotion-rank. +data DynamicMoveData positionHash = MkDynamicMoveData { + getKillerMoves :: Search.KillerMoves.KillerMoves KillerMoveKey, + getTranspositions :: Search.Transpositions.Transpositions Component.QualifiedMove.QualifiedMove positionHash -- ^ N.B. a qualifiedMove is used to additionally record any promotion-rank. } -instance Property.Empty.Empty (DynamicMoveData x y positionHash) where +instance Property.Empty.Empty (DynamicMoveData positionHash) where empty = MkDynamicMoveData { getKillerMoves = Property.Empty.empty, getTranspositions = Property.Empty.empty } -- | The type of a function which transforms the dynamic move-data. -type Transformation x y positionHash = DynamicMoveData x y positionHash -> DynamicMoveData x y positionHash +type Transformation positionHash = DynamicMoveData positionHash -> DynamicMoveData positionHash -- | Mutator. -updateKillerMoves :: Search.KillerMoves.Transformation (KillerMoveKey x y) -> Transformation x y positionHash +updateKillerMoves :: Search.KillerMoves.Transformation KillerMoveKey -> Transformation positionHash updateKillerMoves f dynamicMoveData@MkDynamicMoveData { getKillerMoves = killerMoves } = dynamicMoveData { getKillerMoves = f killerMoves } -- | Mutator. -updateTranspositions :: Search.Transpositions.Transformation (Component.QualifiedMove.QualifiedMove x y) positionHash -> Transformation x y positionHash +updateTranspositions :: Search.Transpositions.Transformation Component.QualifiedMove.QualifiedMove positionHash -> Transformation positionHash updateTranspositions f dynamicMoveData@MkDynamicMoveData { getTranspositions = transpositions } = dynamicMoveData { getTranspositions = f transpositions } -instance Search.EphemeralData.MaybeEphemeralData (DynamicMoveData x y positionHash) where +instance Search.EphemeralData.MaybeEphemeralData (DynamicMoveData positionHash) where maybeEuthanise nPlies maybeRetireKillerMovesAfter maybeRetireTranspositionsAfter MkDynamicMoveData { getKillerMoves = killerMoves, getTranspositions = transpositions 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 @@ -43,9 +43,9 @@ import qualified BishBosh.Type.Count as Type.Count import qualified Data.Array.IArray import qualified Data.Foldable -import qualified Data.IntMap.Strict +import qualified Data.IntMap.Strict as IntMap import qualified Data.List -import qualified Data.Map +import qualified Data.Map as Map import qualified Data.Maybe {- | @@ -55,8 +55,8 @@ & the logical colour of the player making the move. -} type NInstancesByNPliesByKeyByLogicalColour killerMoveKey = Attribute.LogicalColour.ArrayByLogicalColour ( - Data.Map.Map killerMoveKey ( - 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. + Map.Map killerMoveKey ( + IntMap.IntMap Type.Count.NPlies {-NInstances-} -- CAVEAT: 'Int' is used to represent the number of plies into the game (in order to utilise 'IntMap') though it ought to be NPlies also. ) ) @@ -70,15 +70,15 @@ instance Search.EphemeralData.EphemeralData (KillerMoves killerMoveKey) where getSize MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = fromIntegral $ Data.Foldable.foldl' ( - Data.Map.foldl' $ Data.IntMap.Strict.foldl' (+) + Data.Foldable.foldl' $ Data.Foldable.foldl' (+) ) 0 nInstancesByNPliesByKeyByLogicalColour euthanise nPlies killerMoves@MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } | 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' > fromIntegral nPlies) m - in if Data.IntMap.Strict.null m' + Map.mapMaybe $ \m -> let + m' = IntMap.filterWithKey (\nPlies' _ -> nPlies' > fromIntegral nPlies) m + in if Data.Foldable.null m' then Nothing else Just m' ) nInstancesByNPliesByKeyByLogicalColour @@ -93,10 +93,10 @@ -> killerMoveKey -> Transformation killerMoveKey insert nPlies killerMoveKey MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = MkKillerMoves $ nInstancesByNPliesByKeyByLogicalColour // [ - id &&& Data.Map.insertWith ( - Data.IntMap.Strict.unionWith (+) + id &&& Map.insertWith ( + IntMap.unionWith (+) ) killerMoveKey ( - Data.IntMap.Strict.singleton (fromIntegral nPlies) 1 + IntMap.singleton (fromIntegral nPlies) 1 ) . ( nInstancesByNPliesByKeyByLogicalColour ! ) $ if even nPlies @@ -114,8 +114,8 @@ -> [a] {-# INLINABLE sortByHistoryHeuristic #-} sortByHistoryHeuristic logicalColour killerMoveKeyConstructor MkKillerMoves { deconstruct = nInstancesByNPliesByKeyByLogicalColour } = Data.List.sortOn $ Data.Maybe.maybe 0 ( - negate {-largest first-} . Data.IntMap.Strict.foldl' (+) 0 + negate {-largest first-} . Data.Foldable.foldl' (+) 0 ) . ( - `Data.Map.lookup` (nInstancesByNPliesByKeyByLogicalColour ! logicalColour) + `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 @@ -54,27 +54,26 @@ import qualified BishBosh.Text.ShowList as Text.ShowList 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 = 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. +data Result positionHash = MkResult { + getSearchState :: Search.SearchState.SearchState positionHash, + getQuantifiedGames :: [Evaluation.QuantifiedGame.QuantifiedGame], -- ^ 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 (Result x y positionHash) where +instance Control.DeepSeq.NFData (Result 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) => Notation.MoveNotation.ShowNotationFloat (Result x y positionHash) where +instance Notation.MoveNotation.ShowNotationFloat (Result positionHash) where showsNotationFloat moveNotation showsDouble result@MkResult { getQuantifiedGames = quantifiedGames, getNPositionsEvaluated = nPositionsEvaluated @@ -87,18 +86,11 @@ ) -- | Smart constructor. -mkResult :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Search.SearchState.SearchState x y positionHash - -> [Evaluation.QuantifiedGame.QuantifiedGame x y] +mkResult + :: Search.SearchState.SearchState positionHash + -> [Evaluation.QuantifiedGame.QuantifiedGame] -> Type.Count.NPositions - -> Result x y positionHash + -> Result positionHash mkResult searchState quantifiedGames nPositionsEvaluated | null quantifiedGames = Control.Exception.throw . Data.Exception.mkNullDatum . showString "BishBosh.Search.Search.mkResult:\tnull quantifiedGames; " $ 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 "." @@ -111,19 +103,12 @@ game = Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame $ Search.SearchState.getPositionHashQuantifiedGameTree searchState -- | Initiates the recursive function 'Search.AlphaBeta.negaMax', then unpacks the results. -search :: ( - Enum x, - Enum y, - Ord positionHash, - Ord x, - Ord y, - Show x, - Show y - ) +search + :: Ord positionHash => 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.SearchState.SearchState positionHash + -> Input.SearchOptions.Reader (Result positionHash) +{-# SPECIALISE search :: Type.Count.NPlies -> Search.SearchState.SearchState Type.Crypto.PositionHash -> Input.SearchOptions.Reader (Result 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 "." @@ -154,7 +139,7 @@ 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 -> branchingFactor +calculateBranchingFactor :: Floating branchingFactor => Result positionHash -> branchingFactor calculateBranchingFactor MkResult { getQuantifiedGames = quantifiedGames, getNPositionsEvaluated = nPositionsEvaluated 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,23 +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 = MkSearchState { - getPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash, - getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData x y positionHash +data SearchState positionHash = MkSearchState { + getPositionHashQuantifiedGameTree :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash, + getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData positionHash } -instance Show (SearchState x y positionHash) where +instance Show (SearchState positionHash) where show _ = "SearchState {...}" -- | Constructor. mkSearchState - :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash - -> Search.DynamicMoveData.DynamicMoveData x y positionHash - -> SearchState x y positionHash + :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash + -> Search.DynamicMoveData.DynamicMoveData positionHash + -> SearchState positionHash mkSearchState = MkSearchState -- | Smart constructor. -initialise :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash -> SearchState x y positionHash +initialise :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree positionHash -> SearchState 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 { @@ -72,7 +72,7 @@ where game = Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame positionHashQuantifiedGameTree -instance Search.EphemeralData.MaybeEphemeralData (SearchState x y positionHash) where +instance Search.EphemeralData.MaybeEphemeralData (SearchState 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/Transpositions.hs b/src-lib/BishBosh/Search/Transpositions.hs --- a/src-lib/BishBosh/Search/Transpositions.hs +++ b/src-lib/BishBosh/Search/Transpositions.hs @@ -43,20 +43,21 @@ import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Search.EphemeralData as Search.EphemeralData import qualified BishBosh.Search.TranspositionValue as Search.TranspositionValue -import qualified Data.Map +import qualified Data.Foldable +import qualified Data.Map as Map import qualified Data.Maybe -- | Stores the result of an alpha-beta search from a /position/. newtype Transpositions qualifiedMove positionHash = MkTranspositions { - deconstruct :: Data.Map.Map positionHash (Search.TranspositionValue.TranspositionValue qualifiedMove) + deconstruct :: Map.Map positionHash (Search.TranspositionValue.TranspositionValue qualifiedMove) } instance Property.Empty.Empty (Transpositions qualifiedMove positionHash) where empty = MkTranspositions Property.Empty.empty instance Search.EphemeralData.EphemeralData (Transpositions qualifiedMove positionHash) where - getSize MkTranspositions { deconstruct = byPositionHash } = Data.Map.size byPositionHash - euthanise nPlies MkTranspositions { deconstruct = byPositionHash } = MkTranspositions $ Data.Map.filter ((> nPlies) . Search.TranspositionValue.getNPlies) byPositionHash + getSize MkTranspositions { deconstruct = byPositionHash } = Data.Foldable.length byPositionHash + euthanise nPlies MkTranspositions { deconstruct = byPositionHash } = MkTranspositions $ Map.filter ((> nPlies) . Search.TranspositionValue.getNPlies) byPositionHash -- | Returns any value previously recorded when searching from the specified /position/. find @@ -64,7 +65,7 @@ => positionHash -> Transpositions qualifiedMove positionHash -> Maybe (Search.TranspositionValue.TranspositionValue qualifiedMove) -find positionHash MkTranspositions { deconstruct = byPositionHash } = Data.Map.lookup positionHash byPositionHash +find positionHash MkTranspositions { deconstruct = byPositionHash } = Map.lookup positionHash byPositionHash -- | The type of a function which transforms 'Transpositions'. type Transformation qualifiedMove positionHash = Transpositions qualifiedMove positionHash -> Transpositions qualifiedMove positionHash @@ -80,7 +81,7 @@ -> positionHash -- ^ Represents the game from which the sequence of qualifiedMoves starts. -> Search.TranspositionValue.TranspositionValue qualifiedMove -- ^ The value to record. -> Transformation qualifiedMove positionHash -insert findFitness positionHash proposedValue MkTranspositions { deconstruct = byPositionHash } = MkTranspositions $ Data.Map.alter ( +insert findFitness positionHash proposedValue MkTranspositions { deconstruct = byPositionHash } = MkTranspositions $ Map.alter ( Data.Maybe.maybe (Just proposedValue) {-there's no incumbent-} $ \incumbentValue -> if Search.TranspositionValue.isBetter findFitness proposedValue incumbentValue then Just proposedValue -- Upgrade. else Nothing -- Leave incumbent. diff --git a/src-lib/BishBosh/State/Board.hs b/src-lib/BishBosh/State/Board.hs --- a/src-lib/BishBosh/State/Board.hs +++ b/src-lib/BishBosh/State/Board.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, FlexibleContexts #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -73,10 +73,10 @@ import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank -import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription @@ -87,18 +87,19 @@ import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Censor as StateProperty.Censor +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.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 import qualified Data.Array.IArray import qualified Data.Default +import qualified Data.Foldable import qualified Data.List -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified ToolShed.Data.List @@ -107,38 +108,30 @@ #endif -- | The type of a function which transforms a /board/. -type Transformation x y = Board x y -> Board x y +type Transformation = Board -> Board -- | 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) Type.Count.NPieces) +type NDefendersByCoordinatesByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour (Map.Map Cartesian.Coordinates.Coordinates Type.Count.NPieces) {- | * The board is modelled as two alternative structures representing the same data, but indexed by either /coordinates/ or /piece/. * 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/. +data Board = MkBoard { + getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates, -- ^ Defines any /piece/ currently located at each /coordinate/. + getCoordinatesByRankByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByRankByLogicalColour, -- ^ The /coordinates/ of each /piece/. + getNDefendersByCoordinatesByLogicalColour :: NDefendersByCoordinatesByLogicalColour, -- ^ 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/. + getNPawnsByFileByLogicalColour :: StateProperty.Seeker.NPiecesByFileByLogicalColour, -- ^ 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. + getPassedPawnCoordinatesByLogicalColour :: State.CoordinatesByRankByLogicalColour.CoordinatesByLogicalColour -- ^ The /coordinates/ of any /passed/ @Pawn@s. } -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Eq (Board x y) where +instance Eq Board where MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } == MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates' } = maybePieceByCoordinates == maybePieceByCoordinates' -- N.B.: the remaining fields are implied. -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Board x y) where +instance Control.DeepSeq.NFData Board where rnf MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, @@ -157,129 +150,55 @@ passedPawnCoordinatesByLogicalColour ) -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Read (Board x y) where - {-# SPECIALISE instance Read (Board Type.Length.X Type.Length.Y) #-} +instance Read Board where readsPrec _ = Property.ForsythEdwards.readsFEN -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Show (Board x y) where +instance Show Board where showsPrec _ = Property.ForsythEdwards.showsFEN -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ExtendedPositionDescription.ReadsEPD (Board x y) where - {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Board Type.Length.X Type.Length.Y) #-} +instance Property.ExtendedPositionDescription.ReadsEPD Board where readsEPD = map (Control.Arrow.first fromMaybePieceByCoordinates) . Property.ExtendedPositionDescription.readsEPD -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ExtendedPositionDescription.ShowsEPD (Board x y) where +instance Property.ExtendedPositionDescription.ShowsEPD Board where showsEPD MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = Property.ExtendedPositionDescription.showsEPD maybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ForsythEdwards.ReadsFEN (Board x y) where - {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Board Type.Length.X Type.Length.Y) #-} +instance Property.ForsythEdwards.ReadsFEN Board where readsFEN = Property.ExtendedPositionDescription.readsEPD -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ForsythEdwards.ShowsFEN (Board x y) +instance Property.ForsythEdwards.ShowsFEN Board -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Data.Default.Default (Board x y) where - {-# SPECIALISE instance Data.Default.Default (Board Type.Length.X Type.Length.Y) #-} +instance Data.Default.Default Board where def = fromMaybePieceByCoordinates Data.Default.def {-MaybePieceByCoordinates-} -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Reflectable.ReflectableOnX (Board x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Board Type.Length.X Type.Length.Y) #-} +instance Property.Empty.Empty Board where + empty = fromMaybePieceByCoordinates Property.Empty.empty {-MaybePieceByCoordinates-} + +instance Property.Reflectable.ReflectableOnX Board where reflectOnX MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ Property.Reflectable.reflectOnX maybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Reflectable.ReflectableOnY (Board x y) where - {-# SPECIALISE instance Property.Reflectable.ReflectableOnY (Board Type.Length.X Type.Length.Y) #-} +instance Property.Reflectable.ReflectableOnY Board where reflectOnY MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ Property.Reflectable.reflectOnY maybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Empty.Empty (Board x y) where - {-# SPECIALISE empty :: Board Type.Length.X Type.Length.Y #-} - empty = fromMaybePieceByCoordinates Property.Empty.empty {-MaybePieceByCoordinates-} +instance StateProperty.Hashable.Hashable Board where + listRandoms MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Hashable.listRandoms coordinatesByRankByLogicalColour -instance (Enum x, Enum y, Ord x, Ord y) => Component.Zobrist.Hashable2D Board x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms2D MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = Component.Zobrist.listRandoms2D coordinatesByRankByLogicalColour +instance StateProperty.Mutator.Mutator Board where + defineCoordinates maybePiece coordinates MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = fromMaybePieceByCoordinates $ StateProperty.Mutator.defineCoordinates maybePiece coordinates maybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Seeker.Seeker Board x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker Board Type.Length.X Type.Length.Y #-} +instance StateProperty.Seeker.Seeker Board where findProximateKnights logicalColour coordinates MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.findProximateKnights logicalColour coordinates coordinatesByRankByLogicalColour -- Forward the request. findPieces predicate MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.findPieces predicate coordinatesByRankByLogicalColour -- Forward the request. - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Mutator.Mutator Board x y {-CAVEAT: MultiParamTypeClasses-} where - {-# 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 + countPawnsByFileByLogicalColour MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour -- Forward the request. -- | Constructor. -fromMaybePieceByCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => State.MaybePieceByCoordinates.MaybePieceByCoordinates x y -> Board x y -{-# SPECIALISE fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y #-} +fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates -> Board 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. - getNPawnsByFileByLogicalColour = State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour, -- Infer. + getNPawnsByFileByLogicalColour = StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour, -- Infer. getNPieces = StateProperty.Censor.countPieces coordinatesByRankByLogicalColour, -- Infer. getPassedPawnCoordinatesByLogicalColour = State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour coordinatesByRankByLogicalColour -- Infer. } @@ -291,18 +210,10 @@ * CAVEAT: /castling/ must be implemented by making two calls. -} -movePiece :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Component.Move.Move x y -- ^ N.B.: illegal moves are acceptable. +movePiece + :: Component.Move.Move -- ^ 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 Type.Length.X Type.Length.Y -> Maybe Attribute.MoveType.MoveType -> Transformation Type.Length.X Type.Length.Y #-} + -> Transformation movePiece move maybeMoveType board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, @@ -310,41 +221,37 @@ getNPiecesDifferenceByRank = nPiecesDifferenceByRank, getNPieces = nPieces } - | Just sourcePiece <- State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates = let - logicalColour = Component.Piece.getLogicalColour sourcePiece + | Just sourcePiece <- State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates = let + oppositePiece = Property.Opposable.getOpposite sourcePiece + (logicalColour, opponentsLogicalColour) = ($ sourcePiece) &&& ($ oppositePiece) $ Component.Piece.getLogicalColour moveType :: Attribute.MoveType.MoveType - moveType -- CAVEAT: one can't call 'State.MaybePieceByCoordinates.inferMoveType', since that performs some validation of the move, which isn't the role of this module. + moveType -- CAVEAT: one can't call 'State.MaybePieceByCoordinates.inferMoveType', since that performs some move-validation, & therefore exceeds the remit of this module. | Just explicitMoveType <- maybeMoveType = explicitMoveType | State.MaybePieceByCoordinates.isEnPassantMove move maybePieceByCoordinates = Attribute.MoveType.enPassant -- N.B.: if this move is valid, then one's opponent must have just double-advanced an adjacent Pawn. | otherwise = Attribute.MoveType.mkNormalMoveType ( - Component.Piece.getRank `fmap` State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates + Component.Piece.getRank <$> State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates ) $ if Component.Piece.isPawnPromotion destination sourcePiece then Just Attribute.Rank.defaultPromotionRank else Nothing -- Derive the required values from moveType. + (maybePromotionRank, maybeExplicitlyTakenRank) = Attribute.Rank.getMaybePromotionRank &&& Attribute.MoveType.getMaybeExplicitlyTakenRank $ moveType -- Deconstruct. + destinationPiece = Data.Maybe.maybe id Component.Piece.promote maybePromotionRank sourcePiece + wasPawnTakenExplicitly = maybeExplicitlyTakenRank == Just Attribute.Rank.Pawn + eitherPassingPawnsDestinationOrMaybeTakenRank | Attribute.MoveType.isEnPassant moveType = Left $ Cartesian.Coordinates.retreat logicalColour destination - | otherwise = Right $ Attribute.MoveType.getMaybeExplicitlyTakenRank moveType - - maybePromotionRank :: Maybe Attribute.Rank.Rank - maybePromotionRank = Attribute.Rank.getMaybePromotionRank moveType + | otherwise = Right maybeExplicitlyTakenRank - destinationPiece :: Component.Piece.Piece - destinationPiece = Data.Maybe.maybe id Component.Piece.promote maybePromotionRank sourcePiece + eitherPassingPawnsDestinationOrMaybeTakenPiece = fmap (Component.Piece.mkPiece opponentsLogicalColour) <$> eitherPassingPawnsDestinationOrMaybeTakenRank board'@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates' } = MkBoard { getMaybePieceByCoordinates = State.MaybePieceByCoordinates.movePiece move destinationPiece ( Just ||| const Nothing $ eitherPassingPawnsDestinationOrMaybeTakenRank ) maybePieceByCoordinates, getCoordinatesByRankByLogicalColour = State.CoordinatesByRankByLogicalColour.movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank coordinatesByRankByLogicalColour, - getNDefendersByCoordinatesByLogicalColour = let - oppositePiece = Property.Opposable.getOpposite sourcePiece - opponentsLogicalColour = Component.Piece.getLogicalColour oppositePiece - eitherPassingPawnsDestinationOrMaybeTakenPiece = fmap (Component.Piece.mkPiece opponentsLogicalColour) `fmap` eitherPassingPawnsDestinationOrMaybeTakenRank - - in ( + getNDefendersByCoordinatesByLogicalColour = ( \(nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates) -> Attribute.LogicalColour.listArrayByLogicalColour [nBlackDefendersByCoordinates, nWhiteDefendersByCoordinates] ) . foldr ( \(affectedCoordinates, affectedPiece) -> if Component.Piece.isKing affectedPiece @@ -355,7 +262,7 @@ if Attribute.LogicalColour.isBlack logicalColour' then Control.Arrow.first else Control.Arrow.second - ) . Data.Map.Strict.insert affectedCoordinates {-overwrite-} . fromIntegral . length $ findAttackersOf ( + ) . Map.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' ) ( @@ -365,29 +272,29 @@ in ( \passingPawnsDestination -> (:) ( opponentsLogicalColour, - Data.Map.Strict.delete passingPawnsDestination nDefendersByCoordinates -- This Pawn has been taken. + Map.delete passingPawnsDestination nDefendersByCoordinates -- This Pawn has been taken. ) ) ||| ( - \maybeExplicitlyTakenRank -> if Data.Maybe.isJust maybeExplicitlyTakenRank + \maybeExplicitlyTakenRank' -> if Data.Maybe.isJust maybeExplicitlyTakenRank' then (:) ( opponentsLogicalColour, - Data.Map.Strict.delete destination nDefendersByCoordinates -- This piece has been taken. + Map.delete destination nDefendersByCoordinates -- This piece has been taken. ) else id ) $ eitherPassingPawnsDestinationOrMaybeTakenRank ) [ ( logicalColour, - Data.Map.Strict.delete source $ nDefendersByCoordinatesByLogicalColour ! logicalColour -- This piece has been moved. + Map.delete source $ nDefendersByCoordinatesByLogicalColour ! logicalColour -- This piece has been moved. ) -- Pair. ] -- Singleton. ) . Data.List.nubBy ( ToolShed.Data.List.equalityBy fst {-coordinates-} ) $ [ (affectedCoordinates, affectedPiece) | - (knightsCoordinates, knight) <- (source, sourcePiece) : map ((,) destination) (destinationPiece : either (const []) Data.Maybe.maybeToList eitherPassingPawnsDestinationOrMaybeTakenPiece), + (knightsCoordinates, knight) <- (source, sourcePiece) : (,) destination `map` (destinationPiece : (const [] ||| Data.Maybe.maybeToList) eitherPassingPawnsDestinationOrMaybeTakenPiece), Component.Piece.isKnight knight, - Just affectedCoordinates <- Cartesian.Vector.maybeTranslate knightsCoordinates `map` (Cartesian.Vector.attackVectorsForKnight :: [Cartesian.Vector.VectorInt]), + Just affectedCoordinates <- Cartesian.Vector.maybeTranslate knightsCoordinates `map` Cartesian.Vector.attackVectorsForKnight, affectedPiece <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.dereference affectedCoordinates maybePieceByCoordinates', Component.Piece.isFriend knight affectedPiece ] {-list-comprehension-} ++ [ @@ -448,9 +355,7 @@ then [(Attribute.Rank.Pawn, 1)] -- Increment relative number of Pawns. else Data.Maybe.maybe id ( (:) . flip (,) 1 -- Increment. - ) ( - Attribute.MoveType.getMaybeExplicitlyTakenRank moveType - ) $ Data.Maybe.maybe [] ( + ) maybeExplicitlyTakenRank $ Data.Maybe.maybe [] ( \promotionRank -> [ ( promotionRank, @@ -461,14 +366,12 @@ ) ] ) maybePromotionRank, - 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' + getNPawnsByFileByLogicalColour = if Component.Piece.isPawn sourcePiece && not (Attribute.MoveType.isQuiet moveType) || wasPawnTakenExplicitly + then StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour' -- Recalculate. else getNPawnsByFileByLogicalColour board, 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' + getPassedPawnCoordinatesByLogicalColour = if Component.Piece.isPawn sourcePiece || wasPawnTakenExplicitly + then State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour coordinatesByRankByLogicalColour' -- Recalculate. else getPassedPawnCoordinatesByLogicalColour board } @@ -481,16 +384,12 @@ -- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side, at a stage in the game's life-span defined by the total number of pieces remaining. sumPieceSquareValueByLogicalColour :: ( #ifdef USE_UNBOXED_ARRAYS - Data.Array.Unboxed.IArray Data.Array.Unboxed.UArray pieceSquareValue, -- Requires 'FlexibleContexts'. The unboxed representation of the array-element must be defined (& therefore must be of fixed size). + 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, - Num pieceSquareValue, - Ord x, - Ord y + Num pieceSquareValue ) - => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank x y pieceSquareValue - -> Board x y + => Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank pieceSquareValue + -> Board -> #ifdef USE_UNBOXED_ARRAYS Attribute.LogicalColour.UArrayByLogicalColour @@ -499,8 +398,8 @@ #endif pieceSquareValue {-# SPECIALISE sumPieceSquareValueByLogicalColour - :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue - -> Board Type.Length.X Type.Length.Y + :: Component.PieceSquareByCoordinatesByRank.PieceSquareByCoordinatesByRank Type.Mass.PieceSquareValue + -> Board -> #ifdef USE_UNBOXED_ARRAYS Attribute.LogicalColour.UArrayByLogicalColour @@ -512,9 +411,7 @@ sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour, getNPieces = nPieces -} = Attribute.LogicalColour.listArrayByLogicalColour $ State.CoordinatesByRankByLogicalColour.sumPieceSquareValueByLogicalColour ( - \logicalColour rank coordinatesList -> Component.PieceSquareByCoordinatesByRank.findPieceSquareValues nPieces logicalColour rank coordinatesList pieceSquareByCoordinatesByRank - ) coordinatesByRankByLogicalColour +} = Attribute.LogicalColour.listArrayByLogicalColour $ Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces coordinatesByRankByLogicalColour {- | * Lists the source-/coordinates/ from which the referenced destination can be attacked. @@ -527,17 +424,11 @@ * CAVEAT: can't detect an en-passant attack, since this depends both on whether the previous move was a double advance & that the defender is a @Pawn@. -} -findAttackersOf :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. - -> 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 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 + :: Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. + -> Cartesian.Coordinates.Coordinates -- ^ The defender's location. + -> Board + -> [(Cartesian.Coordinates.Coordinates, Attribute.Rank.Rank)] -- ^ The locations from which the specified square can be attacked by the opposite /logical colour/. findAttackersOf destinationLogicalColour destination board@MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = [ (coordinates, Attribute.Rank.Knight) | coordinates <- StateProperty.Seeker.findProximateKnights (Property.Opposable.getOpposite destinationLogicalColour) destination board @@ -552,17 +443,11 @@ * CAVEAT: can't detect an en-passant attack, since this depends both on whether the previous move was a double advance & that the defender is a @Pawn@. -} -findAttacksBy :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Component.Piece.Piece -- ^ The type of attacker. - -> 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 Type.Length.X Type.Length.Y -> Board Type.Length.X Type.Length.Y -> [Cartesian.Coordinates.Coordinates Type.Length.X Type.Length.Y] #-} +findAttacksBy + :: Component.Piece.Piece -- ^ The type of attacker. + -> Cartesian.Coordinates.Coordinates -- ^ The defender's location. + -> Board + -> [Cartesian.Coordinates.Coordinates] -- ^ The sources from which the specified attacker could strike. findAttacksBy piece destination board | rank == Attribute.Rank.Knight = StateProperty.Seeker.findProximateKnights logicalColour destination board | otherwise = filter ( @@ -578,16 +463,10 @@ * CAVEAT: assumes there's exactly one @King@ of the specified /logical colour/. -} -isKingChecked :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ in question. - -> Board x y +isKingChecked + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ in question. + -> Board -> 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 {- | @@ -597,29 +476,19 @@ * CAVEAT: this function is a performance-hotspot. -} -exposesKing :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player proposing to move. - -> Component.Move.Move x y -- ^ The /move/. - -> Board x y -- ^ The original /board/, i.e. prior to the /move/. +exposesKing + :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the player proposing to move. + -> Component.Move.Move -- ^ The /move/. + -> Board -- ^ The original /board/, i.e. prior to the /move/. -> 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 ( - Cartesian.Vector.measureDistance kingsCoordinates source :: Cartesian.Vector.VectorInt - ) -- Confirm that one's own King is on a straight line with the start of the move. + | Just directionFromKing <- Cartesian.Vector.toMaybeDirection $ Cartesian.Vector.measureDistance kingsCoordinates source -- Confirm that one's own King is on a straight line with the start of the move. , let maybePieceByCoordinates = getMaybePieceByCoordinates board , State.MaybePieceByCoordinates.isClear kingsCoordinates source maybePieceByCoordinates -- Confirm that the straight line from one's own King to the start of the move, is clear. , Data.Maybe.maybe True {-Knight's move-} ( not . Attribute.Direction.areAligned directionFromKing -- The blocking piece has revealed any attacker. - ) $ Cartesian.Vector.toMaybeDirection ( - Component.Move.measureDistance move :: Cartesian.Vector.VectorInt - ) + ) . Cartesian.Vector.toMaybeDirection $ Component.Move.measureDistance move , Just (_, attackersRank) <- State.MaybePieceByCoordinates.findAttackerInDirection logicalColour directionFromKing source maybePieceByCoordinates -- Confirm the existence of an obscured attacker. = attackersRank `notElem` Attribute.Rank.plodders -- Confirm sufficient range to bridge the vacated space. | otherwise = False @@ -628,15 +497,9 @@ kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour -- | Count the number of defenders of each /piece/ on the /board/. -countDefendersByCoordinatesByLogicalColour :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Board x y -> NDefendersByCoordinatesByLogicalColour x y -{-# SPECIALISE countDefendersByCoordinatesByLogicalColour :: Board Type.Length.X Type.Length.Y -> NDefendersByCoordinatesByLogicalColour Type.Length.X Type.Length.Y #-} +countDefendersByCoordinatesByLogicalColour :: Board -> NDefendersByCoordinatesByLogicalColour countDefendersByCoordinatesByLogicalColour board@MkBoard { getCoordinatesByRankByLogicalColour = coordinatesByRankByLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour [ - Data.Map.Strict.fromList [ + Map.fromList [ ( coordinates, fromIntegral . length $ findAttackersOf ( @@ -649,8 +512,8 @@ ] -- List-comprehension. -- | Collapses 'NDefendersByCoordinatesByLogicalColour' into the total number of defenders on either side. -summariseNDefendersByLogicalColour :: Board x y -> Attribute.LogicalColour.ArrayByLogicalColour Type.Count.NPieces +summariseNDefendersByLogicalColour :: Board -> 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. + Data.Foldable.foldl' (+) 0 -- CAVEAT: 'Data.Foldable.sum' is too slow. ) nDefendersByCoordinatesByLogicalColour diff --git a/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs b/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs --- a/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs +++ b/src-lib/BishBosh/State/CastleableRooksByLogicalColour.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -66,7 +65,6 @@ 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.Enum as Data.Enum import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.FixedMembership as Property.FixedMembership @@ -75,12 +73,12 @@ import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Type.Length as Type.Length import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception -import qualified Data.Array.IArray import qualified Data.Char import qualified Data.Default import qualified Data.List @@ -95,18 +93,18 @@ * N.B.: both the outer list (indexed by logical colour) & the inner list of abscissae, are kept ordered, otherwise the derived instance of 'Eq' would be unpredictable. -} -type AbscissaeByLogicalColour x = [(Attribute.LogicalColour.LogicalColour, [x])] +type AbscissaeByLogicalColour = [(Attribute.LogicalColour.LogicalColour, [Type.Length.X])] -- | Ensure a predictable order, to facilitate '(==)'. -sortByLogicalColour :: AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x +sortByLogicalColour :: AbscissaeByLogicalColour -> AbscissaeByLogicalColour sortByLogicalColour = Data.List.sortBy $ Data.Ord.comparing fst {-logicalColour-} -- | Update to account for the specified player castling. -castle :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x +castle :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour castle logicalColour = filter $ (/= logicalColour) . fst {-logicalColour-} -- N.B.: if 'Data.List.deleteBy' took a simple predicate, it would have been ideal. -- | Update to account for the specified player losing the right to castle. -relinquishCastlingRights :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x +relinquishCastlingRights :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour -> AbscissaeByLogicalColour relinquishCastlingRights logicalColour = map $ \pair@(logicalColour', _) -> ( if logicalColour' == logicalColour then Control.Arrow.second $ const [] @@ -114,7 +112,11 @@ ) pair -- | Remove the right to castle, from the referenced @Rook@. -removeX :: Eq x => Attribute.LogicalColour.LogicalColour -> x -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x +removeX + :: Attribute.LogicalColour.LogicalColour + -> Type.Length.X + -> AbscissaeByLogicalColour + -> AbscissaeByLogicalColour removeX logicalColour x = map $ \pair@(logicalColour', _) -> ( if logicalColour' == logicalColour then Control.Arrow.second $ Data.List.delete x @@ -123,47 +125,37 @@ -- | Predicate. canCastleWith' - :: Eq x - => Attribute.LogicalColour.LogicalColour - -> x -- ^ @Rook@'s abscissa. - -> AbscissaeByLogicalColour x + :: Attribute.LogicalColour.LogicalColour + -> Type.Length.X -- ^ @Rook@'s abscissa. + -> AbscissaeByLogicalColour -> Bool canCastleWith' logicalColour x = Data.Maybe.maybe False {-has castled-} (elem x) . lookup logicalColour -- | For the players of each /logical colour/, identifies the abscissae of those @Rook@s which can still participate in castling (when other constraints are removed). -newtype CastleableRooksByLogicalColour x = MkCastleableRooksByLogicalColour { - getAssocs :: AbscissaeByLogicalColour x +newtype CastleableRooksByLogicalColour = MkCastleableRooksByLogicalColour { + getAssocs :: AbscissaeByLogicalColour } deriving (Eq, Ord) -instance Show x => Show (CastleableRooksByLogicalColour x) where +instance Show CastleableRooksByLogicalColour where showsPrec precedence MkCastleableRooksByLogicalColour { getAssocs = assocs } = showsPrec precedence assocs -instance ( - Enum x, - Ord x, - Read x, - Show x - ) => Read (CastleableRooksByLogicalColour x) where +instance Read CastleableRooksByLogicalColour where readsPrec precedence s = Control.Arrow.first fromAssocs `map` readsPrec precedence s -instance Control.DeepSeq.NFData x => Control.DeepSeq.NFData (CastleableRooksByLogicalColour x) where +instance Control.DeepSeq.NFData CastleableRooksByLogicalColour where rnf MkCastleableRooksByLogicalColour { getAssocs = assocs } = Control.DeepSeq.rnf assocs -instance Enum x => Data.Default.Default (CastleableRooksByLogicalColour x) where +instance Data.Default.Default CastleableRooksByLogicalColour where def = MkCastleableRooksByLogicalColour $ map ( flip (,) [Cartesian.Abscissa.xMin, Cartesian.Abscissa.xMax] ) Property.FixedMembership.members -instance Property.Reflectable.ReflectableOnX (CastleableRooksByLogicalColour x) where +instance Property.Reflectable.ReflectableOnX CastleableRooksByLogicalColour where reflectOnX MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour . reverse $ map ( Control.Arrow.first Property.Opposable.getOpposite ) assocs -instance ( - Enum x, - Ord x, - Show x - ) => Property.ExtendedPositionDescription.ReadsEPD (CastleableRooksByLogicalColour x) where +instance Property.ExtendedPositionDescription.ReadsEPD CastleableRooksByLogicalColour where readsEPD s = case Data.List.Extra.trimStart s of '-' : remainder -> [ ( @@ -198,7 +190,7 @@ [([], _)] -> [] -- Zero pieces were read => parse-failure. l -> Control.Arrow.first (fromAssocs . Data.List.Extra.groupSort) `map` l -instance (Enum x, Eq x) => Property.ExtendedPositionDescription.ShowsEPD (CastleableRooksByLogicalColour x) where +instance Property.ExtendedPositionDescription.ShowsEPD CastleableRooksByLogicalColour where showsEPD MkCastleableRooksByLogicalColour { getAssocs = assocs } | all (null . snd) assocs = Property.ExtendedPositionDescription.showsNullField | otherwise = foldr ( @@ -210,28 +202,20 @@ canCastleWith' logicalColour rooksX assocs ] -- List-comprehension. -instance ( - Enum x, - Ord x, - Show x - ) => Property.ForsythEdwards.ReadsFEN (CastleableRooksByLogicalColour x) +instance Property.ForsythEdwards.ReadsFEN CastleableRooksByLogicalColour -instance (Enum x, Eq x) => Property.ForsythEdwards.ShowsFEN (CastleableRooksByLogicalColour x) +instance Property.ForsythEdwards.ShowsFEN CastleableRooksByLogicalColour -- | Get the list of random numbers required to represent the current castling potential. -instance Eq x => Component.Zobrist.Hashable1D CastleableRooksByLogicalColour x {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms1D MkCastleableRooksByLogicalColour { getAssocs = assocs } zobrist = Data.Maybe.catMaybes [ +instance StateProperty.Hashable.Hashable CastleableRooksByLogicalColour where + listRandoms MkCastleableRooksByLogicalColour { getAssocs = assocs } zobrist = Data.Maybe.catMaybes [ Component.Zobrist.dereferenceRandomByCastleableRooksXByLogicalColour logicalColour x zobrist | logicalColour <- Property.FixedMembership.members, x <- Data.Maybe.fromMaybe [] $ lookup logicalColour assocs ] -- List-comprehension. -- | Smart constructor. -fromAssocs :: ( - Enum x, - Ord x, - Show x - ) => AbscissaeByLogicalColour x -> CastleableRooksByLogicalColour x +fromAssocs :: AbscissaeByLogicalColour -> CastleableRooksByLogicalColour fromAssocs assocs | Data.List.Extra.anySame $ map fst {-logicalColour-} assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.CastleableRooksByLogicalColour.fromAssocs:\tduplicate logical colours have been defined; " $ shows assocs "." | any (Data.List.Extra.anySame . snd) assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.CastleableRooksByLogicalColour.fromAssocs:\tduplicate abscissae have been defined; " $ shows assocs "." @@ -247,13 +231,7 @@ * CAVEAT: doesn't know the move-history, so the wrong answer is possible. -} -fromBoard :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x - ) => State.Board.Board x y -> CastleableRooksByLogicalColour x +fromBoard :: State.Board.Board -> CastleableRooksByLogicalColour fromBoard board | any ( \logicalColour -> hasCastled logicalColour castleableRooksByLogicalColour && all ( @@ -262,10 +240,7 @@ Cartesian.Coordinates.mkCoordinates x ( Cartesian.Ordinate.pawnsFirstRank logicalColour ) | - bishopsAbscissa <- [ - Cartesian.Abscissa.translate (Data.Enum.translate (+ 2)) Cartesian.Abscissa.xMin, - Cartesian.Abscissa.translate (Data.Enum.translate $ subtract 2) Cartesian.Abscissa.xMax - ], + bishopsAbscissa <- Cartesian.Abscissa.bishopsFiles, x <- Cartesian.Abscissa.getAdjacents bishopsAbscissa ] -- List-comprehension. ) Property.FixedMembership.members = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.State.CastleableRooksByLogicalColourFromBoard.fromBoard:\tfor castling to have occurred, a Bishop must have been moved, which can only happen when a blocking Pawn is moved; " $ shows (castleableRooksByLogicalColour, board) "." @@ -285,15 +260,10 @@ ) Property.FixedMembership.members -- | Narrow the type, so the /turn/ can be queried. -type TurnsByLogicalColour x y = State.TurnsByLogicalColour.TurnsByLogicalColour (Component.Turn.Turn x y) +type TurnsByLogicalColour = State.TurnsByLogicalColour.TurnsByLogicalColour Component.Turn.Turn -- | Constructor. -fromTurnsByLogicalColour :: ( - Enum x, - Enum y, - Eq x, - Eq y - ) => TurnsByLogicalColour x y -> CastleableRooksByLogicalColour x +fromTurnsByLogicalColour :: TurnsByLogicalColour -> CastleableRooksByLogicalColour fromTurnsByLogicalColour turnsByLogicalColour = MkCastleableRooksByLogicalColour $ foldr ( \logicalColour -> let turns = State.TurnsByLogicalColour.dereference logicalColour turnsByLogicalColour @@ -309,49 +279,44 @@ ] -- List-comprehension. ) -- Pair. ) [] Property.FixedMembership.members where - haveMovedFrom, haveMovedTo :: (Eq x, Eq y) => Cartesian.Coordinates.Coordinates x y -> [Component.Turn.Turn x y] -> Bool + haveMovedFrom, haveMovedTo :: Cartesian.Coordinates.Coordinates -> [Component.Turn.Turn] -> Bool haveMovedFrom coordinates = any $ (== coordinates) . Component.Move.getSource . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove haveMovedTo coordinates = any $ (== coordinates) . Component.Move.getDestination . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove -- | Predicate. -hasCastled :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Bool +hasCastled :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Bool hasCastled logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = all ((/= logicalColour) . fst) assocs -- | Predicate. -canCastle :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Bool +canCastle :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Bool canCastle logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False {-has castled-} (not . null) $ lookup logicalColour assocs -- | Infer the @Rook@'s ordinate from the /piece/'s /logical colour/. -inferRooksOrdinate :: Enum y => Attribute.LogicalColour.LogicalColour -> y +inferRooksOrdinate :: Attribute.LogicalColour.LogicalColour -> Type.Length.Y inferRooksOrdinate logicalColour | Attribute.LogicalColour.isBlack logicalColour = Cartesian.Ordinate.yMax | otherwise = Cartesian.Ordinate.yMin -- | Predicate. -canCastleWith :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour - -> Cartesian.Coordinates.Coordinates x y -- ^ @Rook@'s coordinates. - -> CastleableRooksByLogicalColour x +canCastleWith + :: Attribute.LogicalColour.LogicalColour + -> Cartesian.Coordinates.Coordinates -- ^ @Rook@'s coordinates. + -> CastleableRooksByLogicalColour -> Bool canCastleWith logicalColour rookSource MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False {-has castled-} ( any $ (== rookSource) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate logicalColour) ) $ lookup logicalColour assocs -- | Find the abscissae of all @Rook@s of the specified /logical colour/, which can still participate in castling. -locateForLogicalColour :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Maybe [x] +locateForLogicalColour :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour -> Maybe [Type.Length.X] {-# INLINE locateForLogicalColour #-} locateForLogicalColour logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = lookup logicalColour assocs -- | Self-documentation. -type Transformation x = CastleableRooksByLogicalColour x -> CastleableRooksByLogicalColour x +type Transformation = CastleableRooksByLogicalColour -> CastleableRooksByLogicalColour -- | Relinquish the ability to disambiguate between "have Castled" (& therefore can't subsequently), & "Have lost the option to castle". -unify :: Transformation x +unify :: Transformation unify MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ foldr ( \logicalColour assocs' -> ( if any ((== logicalColour) . fst) assocs @@ -363,16 +328,10 @@ ) assocs Property.FixedMembership.members -- | Update with the latest /turn/. -takeTurn :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => 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 Type.Length.X Type.Length.Y -> Transformation Type.Length.X #-} +takeTurn + :: Attribute.LogicalColour.LogicalColour -- ^ Defines the side who took the specified turn. + -> Component.Turn.Turn + -> Transformation takeTurn logicalColour turn MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ ( case lookup logicalColour assocs of Just [] -> id -- This is a terminal state. @@ -384,7 +343,7 @@ (== source) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate logicalColour) ) rooksXs -> removeX logicalColour $ Cartesian.Coordinates.getX source | otherwise -> id - _ -> id -- This is a terminal state. + _ -> id -- This is a terminal state. ) $ ( let opponentsLogicalColour = Property.Opposable.getOpposite logicalColour @@ -418,8 +377,8 @@ * CAVEAT: this function depends on one side having lost the right to castle, when the other side already has; this is quite rare. -} cantConverge - :: CastleableRooksByLogicalColour x - -> CastleableRooksByLogicalColour x + :: CastleableRooksByLogicalColour + -> CastleableRooksByLogicalColour -> Bool cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour' = any ( \logicalColour -> case ($ castleableRooksByLogicalColour) &&& ($ castleableRooksByLogicalColour') $ locateForLogicalColour logicalColour of @@ -430,14 +389,13 @@ -- | Generate the additional random-numbers required to correct the hash resulting from a change to the castleable @Rook@s. listIncrementalRandoms - :: Data.Array.IArray.Ix x - => CastleableRooksByLogicalColour x -- ^ The old value. - -> CastleableRooksByLogicalColour x -- ^ The new value. - -> Component.Zobrist.Zobrist x y random + :: CastleableRooksByLogicalColour -- ^ The old value. + -> CastleableRooksByLogicalColour -- ^ The new value. + -> Component.Zobrist.Zobrist random -> [random] listIncrementalRandoms castleableRooksByLogicalColour castleableRooksByLogicalColour' zobrist = [ random | hashable <- [castleableRooksByLogicalColour, castleableRooksByLogicalColour'], - random <- Component.Zobrist.listRandoms1D hashable zobrist + random <- StateProperty.Hashable.listRandoms hashable zobrist ] -- List-comprehension. 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -30,7 +29,6 @@ module BishBosh.State.CoordinatesByRankByLogicalColour( -- * Types -- ** Type-synonyms - NPiecesByFileByLogicalColour, -- CoordinatesByRank, CoordinatesByLogicalColour, -- Transformation, @@ -40,11 +38,8 @@ deconstruct ), -- * Functions - countPawnsByFileByLogicalColour, findPassedPawnCoordinatesByLogicalColour, findPiecesOfColour, - sumPieceSquareValueByLogicalColour, --- deleteCoordinates, assocs, listCoordinates, -- ** Accessors @@ -53,6 +48,7 @@ -- ** Constructor fromMaybePieceByCoordinates, -- ** Mutators +-- deleteCoordinates, movePiece, sortCoordinates ) where @@ -65,46 +61,43 @@ import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Component.Zobrist as Component.Zobrist +import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates import qualified BishBosh.StateProperty.Censor as StateProperty.Censor +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -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 import qualified Data.Array.IArray import qualified Data.Foldable import qualified Data.List -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map import qualified Data.Maybe -- | The /coordinate/s of all the pieces of one /rank/. -type CoordinatesByRank x y = Attribute.Rank.ArrayByRank [Cartesian.Coordinates.Coordinates x y] +type CoordinatesByRank = Attribute.Rank.ArrayByRank [Cartesian.Coordinates.Coordinates] {- | * This structure allows one to determine the set of /coordinates/ where a type of /piece/ is located. * CAVEAT: the list of /coordinates/ is unordered, so test for equality using @ deconstruct . sortCoordinates @. -} -newtype CoordinatesByRankByLogicalColour x y = MkCoordinatesByRankByLogicalColour { - deconstruct :: Attribute.LogicalColour.ArrayByLogicalColour (CoordinatesByRank x y) +newtype CoordinatesByRankByLogicalColour = MkCoordinatesByRankByLogicalColour { + deconstruct :: Attribute.LogicalColour.ArrayByLogicalColour CoordinatesByRank } -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (CoordinatesByRankByLogicalColour x y) where +instance Control.DeepSeq.NFData CoordinatesByRankByLogicalColour where rnf MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour -instance (Enum x, Enum y) => StateProperty.Censor.Censor (CoordinatesByRankByLogicalColour x y) where +instance StateProperty.Censor.Censor CoordinatesByRankByLogicalColour where countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Attribute.LogicalColour.Black) &&& ($ Attribute.LogicalColour.White) $ Data.List.foldl' (\acc -> (+ acc) . fromIntegral . length) 0 . (byLogicalColour !) countPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.foldl' ( @@ -115,7 +108,7 @@ zipWith (-) ) . ( ($ Attribute.LogicalColour.White) &&& ($ Attribute.LogicalColour.Black) - ) $ map (fromIntegral . length) . Data.Array.IArray.elems . (byLogicalColour !) + ) $ map (fromIntegral . length) . Data.Foldable.toList . (byLogicalColour !) hasInsufficientMaterial MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.all ( \byRank -> all ( @@ -128,7 +121,7 @@ where [blackKnights, blackBishops, whiteKnights, whiteBishops] = [ byRank ! rank | - byRank <- Data.Array.IArray.elems byLogicalColour, + byRank <- Data.Foldable.toList byLogicalColour, rank <- [Attribute.Rank.Knight, Attribute.Rank.Bishop] ] -- List-comprehension. @@ -136,8 +129,8 @@ hasBothKings MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = not $ Data.Foldable.any (null . (! Attribute.Rank.King)) byLogicalColour -- CAVEAT: true for more than one King per side also. -instance (Enum x, Enum y, Ord x, Ord y) => Component.Zobrist.Hashable2D CoordinatesByRankByLogicalColour x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms2D MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } zobrist = [ +instance StateProperty.Hashable.Hashable CoordinatesByRankByLogicalColour where + listRandoms MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } zobrist = [ Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour (logicalColour, rank, coordinates) zobrist | (logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour, (rank, coordinatesList) <- Data.Array.IArray.assocs byRank, @@ -149,16 +142,10 @@ * CAVEAT: nothing is said about whether any /piece/ at the specified /coordinates/ belongs to the opponent, as one might expect. -} -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour Type.Length.X Type.Length.Y #-} +instance StateProperty.Seeker.Seeker CoordinatesByRankByLogicalColour {-CAVEAT: MultiParamTypeClasses-} where 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 + Cartesian.Vector.measureDistance source destination ) ) $ byLogicalColour ! logicalColour ! Attribute.Rank.Knight @@ -171,13 +158,23 @@ coordinates <- coordinatesList ] -- List-comprehension. + countPawnsByFileByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Array.IArray.amap ( + Data.List.foldl' ( + \m coordinates -> StateProperty.Seeker.accumulatePawnsByFile (Cartesian.Coordinates.getX coordinates) m + ) Property.Empty.empty . (! Attribute.Rank.Pawn) + ) byLogicalColour + +instance Component.Accountant.Accountant CoordinatesByRankByLogicalColour where + sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = map ( + \(logicalColour, byRank) -> Data.List.foldl' ( + \acc (rank, coordinatesList) -> Data.List.foldl' ( + \acc' -> (+ acc') . Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour rank + ) acc coordinatesList + ) 0 $ Data.Array.IArray.assocs byRank + ) $ Data.Array.IArray.assocs byLogicalColour + -- | Constructor. -fromMaybePieceByCoordinates :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => State.MaybePieceByCoordinates.MaybePieceByCoordinates x y -> CoordinatesByRankByLogicalColour x y +fromMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates -> CoordinatesByRankByLogicalColour fromMaybePieceByCoordinates maybePieceByCoordinates = MkCoordinatesByRankByLogicalColour . ( \(b, w) -> Attribute.LogicalColour.listArrayByLogicalColour $ map ( Data.Array.IArray.accumArray (++) [] (minBound, maxBound) . map (Control.Arrow.first Component.Piece.getRank) @@ -193,13 +190,13 @@ dereference :: Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank - -> CoordinatesByRankByLogicalColour x y - -> [Cartesian.Coordinates.Coordinates x y] + -> CoordinatesByRankByLogicalColour + -> [Cartesian.Coordinates.Coordinates] {-# INLINE dereference #-} dereference logicalColour rank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = byLogicalColour ! logicalColour ! rank -- | Build an association-list. -assocs :: CoordinatesByRankByLogicalColour x y -> [(Component.Piece.Piece, [Cartesian.Coordinates.Coordinates x y])] +assocs :: CoordinatesByRankByLogicalColour -> [(Component.Piece.Piece, [Cartesian.Coordinates.Coordinates])] assocs MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [ (Component.Piece.mkPiece logicalColour rank, coordinatesList) | (logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour, @@ -207,44 +204,28 @@ ] -- List-comprehension. -- | Access the coordinate-lists. -listCoordinates :: CoordinatesByRankByLogicalColour x y -> [Cartesian.Coordinates.Coordinates x y] +listCoordinates :: CoordinatesByRankByLogicalColour -> [Cartesian.Coordinates.Coordinates] listCoordinates MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [ coordinates | - byRank <- Data.Array.IArray.elems byLogicalColour, - coordinatesList <- Data.Array.IArray.elems byRank, + byRank <- Data.Foldable.toList byLogicalColour, + coordinatesList <- Data.Foldable.toList byRank, coordinates <- coordinatesList ] -- List-comprehension. -- | Get the /coordinates/ of the @King@ of the specified /logical colour/. getKingsCoordinates :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @King@ to find. - -> CoordinatesByRankByLogicalColour x y - -> Cartesian.Coordinates.Coordinates x y + -> CoordinatesByRankByLogicalColour + -> Cartesian.Coordinates.Coordinates {-# INLINE getKingsCoordinates #-} getKingsCoordinates logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.Exception.assert (not $ null coordinates) $ head coordinates {-there should be exactly one-} where coordinates = byLogicalColour ! logicalColour ! Attribute.Rank.King --- | The number of /piece/s in each file, for each /logical colour/. -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. - - * N.B.: files lacking any @Pawn@, don't feature in the results. --} -countPawnsByFileByLogicalColour :: Ord x => CoordinatesByRankByLogicalColour x y -> NPiecesByFileByLogicalColour x -{-# INLINABLE countPawnsByFileByLogicalColour #-} -countPawnsByFileByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Array.IArray.amap ( - Data.List.foldl' ( - \m coordinates -> Data.Map.Strict.insertWith (const succ) (Cartesian.Coordinates.getX coordinates) 1 m - ) Data.Map.Strict.empty . (! Attribute.Rank.Pawn) - ) byLogicalColour - -- | Locate all /piece/s of the specified /logical colour/. findPiecesOfColour :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the /piece/s to find. - -> CoordinatesByRankByLogicalColour x y - -> [Component.Piece.LocatedPiece x y] + -> CoordinatesByRankByLogicalColour + -> [Component.Piece.LocatedPiece] findPiecesOfColour logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [ (coordinates, Component.Piece.mkPiece logicalColour rank) | (rank, coordinatesList) <- Data.Array.IArray.assocs $ byLogicalColour ! logicalColour, @@ -252,31 +233,31 @@ ] -- List-comprehension. -- | A list of /coordinates/ for each /logical colour/. -type CoordinatesByLogicalColour x y = Attribute.LogicalColour.ArrayByLogicalColour [Cartesian.Coordinates.Coordinates x y] +type CoordinatesByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour [Cartesian.Coordinates.Coordinates] -- | For each /logical colour/, find the /coordinates/ of any passed @Pawn@s (). -findPassedPawnCoordinatesByLogicalColour :: (Enum x, Ord x, Ord y) => CoordinatesByRankByLogicalColour x y -> CoordinatesByLogicalColour x y +findPassedPawnCoordinatesByLogicalColour :: CoordinatesByRankByLogicalColour -> CoordinatesByLogicalColour findPassedPawnCoordinatesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour $ map ( \logicalColour -> let opponentsLogicalColour = Property.Opposable.getOpposite logicalColour opposingPawnYByX = Data.List.foldl' ( \m coordinates -> uncurry ( - Data.Map.Strict.insertWith $ if Attribute.LogicalColour.isBlack opponentsLogicalColour + Map.insertWith $ if Attribute.LogicalColour.isBlack opponentsLogicalColour then max else min ) {-only compare with the least advanced opposing Pawn in each file-} ( Cartesian.Coordinates.getX &&& Cartesian.Coordinates.getY $ coordinates ) m - ) Data.Map.Strict.empty $ findPawns opponentsLogicalColour + ) Property.Empty.empty $ findPawns opponentsLogicalColour in filter ( \coordinates -> all ( - Data.Maybe.maybe True {-the absence of an opposing Pawn doesn't impede advancement-} ( + Data.Maybe.maybe True {-absence of opposition doesn't impede advance-} ( ( /= Attribute.Direction.advanceDirection logicalColour -- Either equal or backwards is OK. ) . ( {-opponent-} `compare` Cartesian.Coordinates.getY coordinates ) -- As a Pawn advances, it becomes "Passed" when the y-distance to the least advanced adjacent opposing Pawn, is either equal or backwards. - ) . (`Data.Map.Strict.lookup` opposingPawnYByX) + ) . (`Map.lookup` opposingPawnYByX) ) . uncurry (:) . ( id &&& Cartesian.Abscissa.getAdjacents ) $ Cartesian.Coordinates.getX coordinates @@ -284,39 +265,24 @@ ) Property.FixedMembership.members where findPawns = (! Attribute.Rank.Pawn) . (byLogicalColour !) --- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side. -sumPieceSquareValueByLogicalColour - :: (Num pieceSquareValue) - => Component.PieceSquareByCoordinatesByRank.FindPieceSquareValues x y pieceSquareValue - -> CoordinatesByRankByLogicalColour x y - -> [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) - ) 0 $ Data.Array.IArray.assocs byRank - ) $ Data.Array.IArray.assocs byLogicalColour - -- | Self-documentation. -type Transformation x y = CoordinatesByRankByLogicalColour x y -> CoordinatesByRankByLogicalColour x y +type Transformation = CoordinatesByRankByLogicalColour -> CoordinatesByRankByLogicalColour -- | Remove the specified /coordinates/ from those recorded for the specified /rank/. deleteCoordinates - :: (Eq x, Eq y) - => Cartesian.Coordinates.Coordinates x y + :: Cartesian.Coordinates.Coordinates -> Attribute.Rank.Rank - -> CoordinatesByRank x y - -> CoordinatesByRank x y + -> CoordinatesByRank + -> CoordinatesByRank deleteCoordinates coordinates rank byRank = byRank // [(rank, Data.List.delete coordinates $ byRank ! rank)] -- | Adjust the array to reflect a new /move/. movePiece - :: (Eq x, Eq y) - => Component.Move.Move x y - -> Component.Piece.Piece -- ^ The piece which moved. - -> 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 + :: Component.Move.Move + -> Component.Piece.Piece -- ^ The piece which moved. + -> Maybe Attribute.Rank.Rank -- ^ The (possibly promoted) rank to place at the destination. + -> Either Cartesian.Coordinates.Coordinates (Maybe Attribute.Rank.Rank) -- ^ Either the destination of any passed @Pawn@, or the /rank/ of any /piece/ taken. + -> Transformation movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ byLogicalColour // ( (:) . (`deleteOpponentsCoordinates` Attribute.Rank.Pawn) ||| Data.Maybe.maybe id {-quiet move-} ( (:) . deleteOpponentsCoordinates destination @@ -343,6 +309,6 @@ deleteOpponentsCoordinates coordinates rank = id &&& deleteCoordinates coordinates rank . (byLogicalColour !) $ Property.Opposable.getOpposite logicalColour -- | Independently sort each list of /coordinates/. -sortCoordinates :: (Ord x, Ord y) => Transformation x y +sortCoordinates :: Transformation 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -43,34 +42,28 @@ 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.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.Type.Length as Type.Length import qualified Control.DeepSeq -import qualified Data.Array.IArray import qualified Data.Maybe -- | Defines the file on which an En-passant option currently exists. -newtype EnPassantAbscissa x = MkEnPassantAbscissa { - getAbscissa :: x -- ^ The file on which an En-passant option currently exists. +newtype EnPassantAbscissa = MkEnPassantAbscissa { + getAbscissa :: Type.Length.X -- ^ The file on which an En-passant option currently exists. } deriving (Eq, Ord) -instance Data.Array.IArray.Ix x => Component.Zobrist.Hashable1D EnPassantAbscissa x {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms1D MkEnPassantAbscissa { getAbscissa = x } = return {-to List-monad-} . Component.Zobrist.dereferenceRandomByEnPassantAbscissa x - -instance Control.DeepSeq.NFData x => Control.DeepSeq.NFData (EnPassantAbscissa x) where +instance Control.DeepSeq.NFData EnPassantAbscissa where rnf MkEnPassantAbscissa { getAbscissa = x } = Control.DeepSeq.rnf x +instance StateProperty.Hashable.Hashable EnPassantAbscissa where + listRandoms MkEnPassantAbscissa { getAbscissa = x } = return {-to List-monad-} . Component.Zobrist.dereferenceRandomByEnPassantAbscissa x + -- | Constructor. -mkMaybeEnPassantAbscissa :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The player who moves next, & who may have an En-passant capture-option. - -> 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 Type.Length.X Type.Length.Y -> Component.Turn.Turn Type.Length.X Type.Length.Y -> Maybe (EnPassantAbscissa Type.Length.X) #-} +mkMaybeEnPassantAbscissa + :: Attribute.LogicalColour.LogicalColour -- ^ The player who moves next, & who may have an En-passant capture-option. + -> State.MaybePieceByCoordinates.MaybePieceByCoordinates + -> Component.Turn.Turn -- ^ The last /turn/ taken. + -> Maybe EnPassantAbscissa mkMaybeEnPassantAbscissa nextLogicalColour maybePieceByCoordinates lastTurn | Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) lastTurn , let lastMoveDestination = Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove lastTurn 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,8 @@ module BishBosh.State.InstancesByPosition( -- * Types -- ** Type-synonyms --- Transformation. +-- NPositionsByPosition, +-- Transformation, -- * Constants leastCyclicPlies, -- ** Data-types @@ -39,19 +40,20 @@ mkInstancesByPosition, mkSingleton, -- ** Mutators +-- insertPosition', insertPosition, deletePosition, -- ** Predicates anyInstancesByPosition ) where -import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Property.Empty as Property.Empty 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.Foldable -import qualified Data.Map.Strict +import qualified Data.Map.Strict as Map -- | The smallest number of repeatable plies (applied by alternating players) required to form a cycle. leastCyclicPlies :: Type.Count.NPlies @@ -64,8 +66,15 @@ * The /position/ can either be represented by a physical 'State.Position.Position', or by proxy using a hash. -} +type NPositionsByPosition position = Map.Map position Type.Count.NPositions + +-- | Insert a position into the unwrapped collection. +insertPosition' :: Ord position => position -> NPositionsByPosition position -> NPositionsByPosition position +insertPosition' = flip (Map.insertWith $ const succ) 1 + +-- | Wrap the type, so that class-instances can be hung from it. newtype InstancesByPosition position = MkInstancesByPosition { - getNPositionsByPosition :: Data.Map.Strict.Map position Type.Count.NPositions + getNPositionsByPosition :: NPositionsByPosition position } deriving Eq instance Control.DeepSeq.NFData position => Control.DeepSeq.NFData (InstancesByPosition position) where @@ -75,37 +84,40 @@ Ord position, Property.Reflectable.ReflectableOnX position ) => Property.Reflectable.ReflectableOnX (InstancesByPosition position) where - reflectOnX MkInstancesByPosition { getNPositionsByPosition = m } = MkInstancesByPosition $ Data.Map.Strict.mapKeys Property.Reflectable.reflectOnX m + reflectOnX MkInstancesByPosition { getNPositionsByPosition = m } = MkInstancesByPosition $ Map.mapKeys Property.Reflectable.reflectOnX m --- | Smart constructor. -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 +-- | Construct from repeatable data. +mkInstancesByPosition + :: (Foldable foldable, Ord position) + => (a -> position) -- ^ Position-constructor. + -> foldable a -- ^ Data from which to construct positions. + -> InstancesByPosition position +mkInstancesByPosition f = MkInstancesByPosition . Data.Foldable.foldr (insertPosition' . f) Property.Empty.empty -- | Constructor. mkSingleton :: position -> InstancesByPosition position -mkSingleton position = MkInstancesByPosition $ Data.Map.Strict.singleton position 1 +mkSingleton = MkInstancesByPosition . (`Map.singleton` 1) + {- | * Count the total number of consecutive repeatable plies amongst recent moves. * This is equivalent to the number of entries in the map, since adding a non-repeatable move triggers a purge. -} countConsecutiveRepeatablePlies :: InstancesByPosition position -> Type.Count.NPlies -countConsecutiveRepeatablePlies MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Map.Strict.foldl' (+) ( +countConsecutiveRepeatablePlies MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Foldable.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 -> Type.Count.NPositions -countPositionRepetitions MkInstancesByPosition { getNPositionsByPosition = m } = Data.Map.Strict.foldl' ( +countPositionRepetitions MkInstancesByPosition { getNPositionsByPosition = m } = Data.Foldable.foldl' ( (+) . pred -- The initial instance isn't a repetition. ) 0 m -- | The number of distinct /position/s. getNDistinctPositions :: InstancesByPosition position -> Type.Count.NPositions -getNDistinctPositions MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Map.Strict.size m {-the number of keys-} +getNDistinctPositions MkInstancesByPosition { getNPositionsByPosition = m } = fromIntegral $ Data.Foldable.length m {-the number of keys-} -- | Predicate: apply the specified predicate to the map. anyInstancesByPosition @@ -121,8 +133,8 @@ -} 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 + | Data.Foldable.null m = 0 -- CAVEAT: this shouldn't happen. + | otherwise = Data.Foldable.maximum m -- | The type of a function which transforms the collection. type Transformation position = InstancesByPosition position -> InstancesByPosition position @@ -134,14 +146,14 @@ -> position -> Transformation position 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. + | isRepeatable = MkInstancesByPosition $ insertPosition' position 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 { getNPositionsByPosition = m } = MkInstancesByPosition . Data.Map.Strict.update ( +deletePosition position MkInstancesByPosition { getNPositionsByPosition = m } = MkInstancesByPosition . Map.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 + ) position $ Control.Exception.assert (Map.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 @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -36,13 +35,10 @@ -- Transformation, -- ** Data-types MaybePieceByCoordinates(), --- * Constants --- rankSeparator, -- * Functions inferMoveType, findBlockingPiece, findAttackerInDirection, - sumPieceSquareValueByLogicalColour, listDestinationsFor, -- listToRaster, -- shows2D, @@ -64,6 +60,7 @@ import Control.Arrow((&&&), (***)) import Control.Category((>>>)) import Data.Array.IArray((!), (//)) +import qualified BishBosh.Attribute.ANSIColourCode as Attribute.ANSIColourCode import qualified BishBosh.Attribute.ColourScheme as Attribute.ColourScheme import qualified BishBosh.Attribute.Direction as Attribute.Direction import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour @@ -74,12 +71,14 @@ import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Component.Accountant as Component.Accountant import qualified BishBosh.Component.CastlingMove as Component.CastlingMove import qualified BishBosh.Component.Move as Component.Move import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Notation.Figurine as Notation.Figurine import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.FixedMembership as Property.FixedMembership @@ -88,17 +87,18 @@ import qualified BishBosh.Property.Orientated as Property.Orientated import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.StateProperty.Censor as StateProperty.Censor +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.Text.ShowList as Text.ShowList 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 import qualified Data.Array.IArray import qualified Data.Char import qualified Data.Default +import qualified Data.Foldable import qualified Data.List import qualified Data.List.Extra import qualified Data.Maybe @@ -109,42 +109,24 @@ * N.B.: this could be implemented using 'Data.Vector.Vector', which being indexed by 'Int' is no longer polymorphic & permits many unsafe operations; but the result is no faster. -} -newtype MaybePieceByCoordinates x y = MkMaybePieceByCoordinates { - deconstruct :: Cartesian.Coordinates.ArrayByCoordinates x y ( +newtype MaybePieceByCoordinates = MkMaybePieceByCoordinates { + deconstruct :: Cartesian.Coordinates.ArrayByCoordinates ( Maybe Component.Piece.Piece -- Each square optionally contains a piece. ) } deriving (Eq, Ord) -- | Used to separate the /ranks/ of the /board/ as represented by the IO-format . -rankSeparator :: Char -rankSeparator = '/' - -- | Chops a list into a 2-D list. listToRaster :: [a] -> [[a]] listToRaster = Data.List.Extra.chunksOf $ fromIntegral Cartesian.Abscissa.xLength {-CAVEAT: this also depends on the raster-order-} -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Read (MaybePieceByCoordinates x y) where +instance Read MaybePieceByCoordinates where readsPrec _ = Property.ForsythEdwards.readsFEN -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Show (MaybePieceByCoordinates x y) where +instance Show MaybePieceByCoordinates where showsPrec _ = Property.ForsythEdwards.showsFEN -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ExtendedPositionDescription.ReadsEPD (MaybePieceByCoordinates x y) where +instance Property.ExtendedPositionDescription.ReadsEPD MaybePieceByCoordinates where readsEPD s | length rows /= fromIntegral Cartesian.Ordinate.yLength || any ( (/= fromIntegral Cartesian.Abscissa.xLength) . length @@ -158,21 +140,18 @@ [(i, "")] -> replicate i Nothing -- Expand the runlength-code so that each row has the same length. _ -> [Just piece | (piece, []) <- Property.ExtendedPositionDescription.readsEPD [c]] -- List-comprehension. ) - ) . Text.ShowList.splitOn (== rankSeparator) + ) . Text.ShowList.splitOn (== Property.ExtendedPositionDescription.rankSeparator) ) . span ( - `elem` rankSeparator : concatMap Property.ExtendedPositionDescription.showEPD Component.Piece.range ++ concatMap show [1 .. Cartesian.Abscissa.xLength] + `elem` ( + Property.ExtendedPositionDescription.rankSeparator : Component.Piece.epdCharacterSet ++ concatMap show [1 .. Cartesian.Abscissa.xLength] + ) ) $ Data.List.Extra.trimStart s -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ExtendedPositionDescription.ShowsEPD (MaybePieceByCoordinates x y) where +instance Property.ExtendedPositionDescription.ShowsEPD MaybePieceByCoordinates where showsEPD MkMaybePieceByCoordinates { deconstruct = byCoordinates } = foldr1 ( >>> -- Render the line with the highest y-coordinate first. ) . Data.List.intersperse ( - showChar rankSeparator -- Separate the lines. + showChar Property.ExtendedPositionDescription.rankSeparator -- Separate the lines. ) . map ( foldr1 (.) . concatMap ( \(runLength, maybePiece) -> Data.Maybe.maybe [ @@ -181,29 +160,14 @@ replicate runLength . Property.ExtendedPositionDescription.showsEPD -- Render each piece. ) maybePiece ) . ToolShed.Data.List.Runlength.encode - ) . listToRaster $ Data.Array.IArray.elems byCoordinates + ) . listToRaster $ Data.Foldable.toList byCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ForsythEdwards.ReadsFEN (MaybePieceByCoordinates x y) +instance Property.ForsythEdwards.ReadsFEN MaybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.ForsythEdwards.ShowsFEN (MaybePieceByCoordinates x y) +instance Property.ForsythEdwards.ShowsFEN MaybePieceByCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Data.Default.Default (MaybePieceByCoordinates x y) where - def = Property.ForsythEdwards.readFEN . Data.List.intercalate [rankSeparator] $ map ($ Attribute.LogicalColour.Black) [ +instance Data.Default.Default MaybePieceByCoordinates where + def = Property.ForsythEdwards.readFEN . Data.List.intercalate [Property.ExtendedPositionDescription.rankSeparator] $ map ($ Attribute.LogicalColour.Black) [ showNobility, showPawnRow ] ++ replicate 4 "8" ++ map ($ Attribute.LogicalColour.White) [ @@ -217,44 +181,21 @@ showPawnRow logicalColour = showPieces . replicate (fromIntegral Cartesian.Abscissa.xLength) $ Component.Piece.mkPawn logicalColour showNobility logicalColour = showPieces $ map (Component.Piece.mkPiece logicalColour) Attribute.Rank.nobility -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Reflectable.ReflectableOnX (MaybePieceByCoordinates x y) where +instance Property.Reflectable.ReflectableOnX MaybePieceByCoordinates where reflectOnX MkMaybePieceByCoordinates { deconstruct = byCoordinates } = MkMaybePieceByCoordinates . Cartesian.Coordinates.arrayByCoordinates . map ( Property.Reflectable.reflectOnX *** fmap Property.Opposable.getOpposite ) $ Data.Array.IArray.assocs byCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Reflectable.ReflectableOnY (MaybePieceByCoordinates x y) where +instance Property.Reflectable.ReflectableOnY MaybePieceByCoordinates where reflectOnY MkMaybePieceByCoordinates { deconstruct = byCoordinates } = MkMaybePieceByCoordinates $ Data.Array.IArray.ixmap (minBound, maxBound) Property.Reflectable.reflectOnY byCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Empty.Empty (MaybePieceByCoordinates x y) where +instance Property.Empty.Empty MaybePieceByCoordinates where empty = MkMaybePieceByCoordinates . Cartesian.Coordinates.listArrayByCoordinates $ repeat Property.Empty.empty -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (MaybePieceByCoordinates x y) where +instance Control.DeepSeq.NFData MaybePieceByCoordinates where rnf MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.DeepSeq.rnf byCoordinates -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Censor.Censor (MaybePieceByCoordinates x y) where +instance StateProperty.Censor.Censor MaybePieceByCoordinates where countPiecesByLogicalColour = Data.List.foldl' ( \acc piece -> let acc'@(nBlack, nWhite) = ( @@ -302,17 +243,17 @@ ([_], [_]) -> True _ -> False -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Component.Zobrist.Hashable2D MaybePieceByCoordinates x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms2D MkMaybePieceByCoordinates { deconstruct = byCoordinates } zobrist = [ +instance StateProperty.Hashable.Hashable MaybePieceByCoordinates where + listRandoms 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 ] -- List-comprehension. +instance StateProperty.Mutator.Mutator MaybePieceByCoordinates where + defineCoordinates maybePiece coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( + Data.Maybe.isJust maybePiece || Data.Maybe.isJust (byCoordinates ! coordinates) + ) . MkMaybePieceByCoordinates $ byCoordinates // [(coordinates, maybePiece)] + {- | * Find any @Knight@s of the specified /logical colour/, in attack-range around the specified /coordinates/. @@ -320,13 +261,7 @@ * CAVEAT: less efficient than 'State.CoordinatesByRankByLogicalColour.findProximateKnights'. -} -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Seeker.Seeker MaybePieceByCoordinates x y {-CAVEAT: MultiParamTypeClasses-} where - {-# SPECIALISE instance StateProperty.Seeker.Seeker MaybePieceByCoordinates Type.Length.X Type.Length.Y #-} +instance StateProperty.Seeker.Seeker MaybePieceByCoordinates where findProximateKnights logicalColour destination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = filter ( (== Just knight) . (byCoordinates !) ) $ Component.Piece.findAttackDestinations destination knight where @@ -338,44 +273,32 @@ predicate piece ] -- List-comprehension. -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => StateProperty.Mutator.Mutator MaybePieceByCoordinates x y {-CAVEAT: MultiParamTypeClasses-} where - {-# 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)] +instance Component.Accountant.Accountant MaybePieceByCoordinates where + sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces = ( + \(b, w) -> [b, w] + ) . Data.List.foldl' ( + \(b, w) (coordinates, piece) -> let + logicalColour = Component.Piece.getLogicalColour piece + pieceSquareValue = Component.PieceSquareByCoordinatesByRank.findPieceSquareValue pieceSquareByCoordinatesByRank nPieces logicalColour (Component.Piece.getRank piece) coordinates + in if Attribute.LogicalColour.isBlack logicalColour + then let b' = b + pieceSquareValue in b' `seq` (b', w) + else let w' = w + pieceSquareValue in w' `seq` (b, w') + ) (0, 0) . StateProperty.Seeker.findAllPieces -- | Dereference the array. -dereference :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y - -> MaybePieceByCoordinates x y +dereference + :: Cartesian.Coordinates.Coordinates + -> MaybePieceByCoordinates -> Maybe Component.Piece.Piece {-# INLINE dereference #-} dereference coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = byCoordinates ! coordinates -- | Infer the type of the specified /move/. -inferMoveType :: ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) - => Component.Move.Move x y +inferMoveType + :: Component.Move.Move -> Maybe Attribute.Rank.Rank -- ^ The /rank/ to which a @Pawn@ should be promoted; defaulting to @Queen@. - -> MaybePieceByCoordinates x y + -> MaybePieceByCoordinates -> 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 @@ -407,17 +330,11 @@ * CAVEAT: doesn't typically check whether anything (let alone the specified /piece/) exists at the specified source-/coordinates/. -} -listDestinationsFor :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ The source for which destinations are required. +listDestinationsFor + :: Cartesian.Coordinates.Coordinates -- ^ The source for which destinations are required. -> 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 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)] #-} + -> MaybePieceByCoordinates + -> [(Cartesian.Coordinates.Coordinates, Maybe Attribute.Rank.Rank)] -- ^ The destination & the rank of any piece taken. listDestinationsFor source piece maybePieceByCoordinates@MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Control.Exception.assert ( byCoordinates ! source == Just piece ) $ if Component.Piece.getRank piece `elem` Attribute.Rank.fixedAttackRange @@ -432,7 +349,7 @@ then findAttackDestinations ( Data.Maybe.maybe False {-unoccupied-} $ (/= logicalColour) . Component.Piece.getLogicalColour ) ++ let - advance :: (Enum y, Ord y) => Cartesian.Coordinates.Coordinates x y -> Cartesian.Coordinates.Coordinates x y + advance :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates advance = Cartesian.Coordinates.advance logicalColour advancedLocation = advance source @@ -466,114 +383,78 @@ logicalColour = Component.Piece.getLogicalColour piece -- | Show the /board/ in two dimensions, with /x/ & /y/ indexes. -shows2D :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Type.Length.Column -- ^ The column-magnification. +shows2D + :: Type.Length.Column -- ^ The column-magnification. -> Attribute.ColourScheme.ColourScheme - -> (Int, Int) -- ^ The origin from which axes are labelled. - -> MaybePieceByCoordinates x y - -> ShowS -- ^ The output suitable for display on a terminal. -shows2D boardColumnMagnification colourScheme (xOrigin, yOrigin) MkMaybePieceByCoordinates { deconstruct = byCoordinates } = ( + -> Bool -- ^ Whether to depict pieces as Unicode figurines. + -> (Type.Length.X, Type.Length.Y) -- ^ The origin from which axes are labelled. + -> MaybePieceByCoordinates + -> ShowS -- ^ Output suitable for display on a terminal. +shows2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) MkMaybePieceByCoordinates { deconstruct = byCoordinates } = ( foldr ( - \(y, pairs) showsRow -> showsRow . showString ( - Attribute.PhysicalColour.selectGraphicsRendition True $ Attribute.PhysicalColour.mkFgColourCode Attribute.PhysicalColour.green - ) . showChar y . foldr ( + \(y, pairs) showsRow -> showsRow . showString axisGraphicsRendition . showChar y . foldr ( \(coordinates, c) acc' -> showString ( - Attribute.PhysicalColour.selectGraphicsRendition False . Attribute.PhysicalColour.mkBgColourCode $ ( + Attribute.ANSIColourCode.selectGraphicsRendition False {-isBold-} . Attribute.ANSIColourCode.mkBgColourCode $ ( if Attribute.LogicalColourOfSquare.isBlack $ Cartesian.Coordinates.getLogicalColourOfSquare coordinates then Attribute.ColourScheme.getDarkSquareColour else Attribute.ColourScheme.getLightSquareColour - ) colourScheme + ) colourScheme ) . showString ( - Attribute.PhysicalColour.selectGraphicsRendition True . Attribute.PhysicalColour.mkFgColourCode $ ( + Attribute.ANSIColourCode.selectGraphicsRendition True {-isBold-} . Attribute.ANSIColourCode.mkFgColourCode $ ( if Data.Char.isLower c {-Black-} then Attribute.ColourScheme.getDarkPieceColour else Attribute.ColourScheme.getLightPieceColour - ) colourScheme + ) colourScheme ) . let showPadding = showString (fromIntegral (pred boardColumnMagnification) `replicate` ' ') in showPadding . showChar c . showPadding . acc' ) showsReset pairs . showChar '\n' ) id . zip ( - take (fromIntegral Cartesian.Ordinate.yLength) . enumFrom $ Data.Char.chr yOrigin + take (fromIntegral Cartesian.Ordinate.yLength) . enumFrom . Data.Char.chr $ fromIntegral yOrigin ) . listToRaster . map ( - Control.Arrow.second . Data.Maybe.maybe ' ' $ head . show -- Represent each piece as a single character. + Control.Arrow.second . Data.Maybe.maybe ' ' $ if depictFigurine + then Notation.Figurine.toFigurine -- Represent each piece as a Unicode figurine. + else head . show -- Represent each piece as an ASCII character. ) $ Data.Array.IArray.assocs byCoordinates ) . showString ( replicate (fromIntegral boardColumnMagnification) ' ' -- Shift the line of x-axis labels right. - ) . showString ( - Attribute.PhysicalColour.selectGraphicsRendition True $ Attribute.PhysicalColour.mkFgColourCode Attribute.PhysicalColour.green - ) . foldr (.) showsReset ( + ) . showString axisGraphicsRendition . foldr (.) showsReset ( Data.List.intersperse ( showString $ replicate (2 * fromIntegral (pred boardColumnMagnification)) ' ' -- Separate each of the x-axis labels. ) . map showChar . take ( fromIntegral Cartesian.Abscissa.xLength - ) . enumFrom $ Data.Char.chr xOrigin + ) . enumFrom . Data.Char.chr $ fromIntegral xOrigin ) where + axisGraphicsRendition :: Attribute.ANSIColourCode.GraphicsRendition + axisGraphicsRendition = Attribute.ANSIColourCode.selectGraphicsRendition True {-isBold-} $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.green + showsReset :: ShowS - showsReset = showString $ Attribute.PhysicalColour.selectGraphicsRendition False 0 + showsReset = showString $ Attribute.ANSIColourCode.selectGraphicsRendition False Data.Default.def -- | Show the board using a two-dimensional representation. -show2D :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Type.Length.Column -- ^ The column-magnification. +show2D + :: Type.Length.Column -- ^ The column-magnification. -> Attribute.ColourScheme.ColourScheme - -> (Int, Int) -- ^ The origin from which axes are labelled. - -> MaybePieceByCoordinates x y - -> String -- ^ The output suitable for display on a terminal. -show2D boardColumnMagnification colourScheme (xOrigin, yOrigin) maybePieceByCoordinates = shows2D boardColumnMagnification colourScheme (xOrigin, yOrigin) maybePieceByCoordinates "" + -> Bool -- ^ Whether to depict figurines. + -> (Type.Length.X, Type.Length.Y) -- ^ The origin from which axes are labelled. + -> MaybePieceByCoordinates + -> String -- ^ The output suitable for display on a terminal. +show2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) maybePieceByCoordinates = shows2D boardColumnMagnification colourScheme depictFigurine (xOrigin, yOrigin) maybePieceByCoordinates "" -- | Extract the pieces from the board, discarding their coordinates. -getPieces :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) => MaybePieceByCoordinates x y -> [Component.Piece.Piece] -getPieces MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.catMaybes $ Data.Array.IArray.elems byCoordinates +getPieces :: MaybePieceByCoordinates -> [Component.Piece.Piece] +getPieces MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.catMaybes $ Data.Foldable.toList byCoordinates {- | * Find the first /piece/ of either /logical colour/, encountered along a straight line in the specified /direction/, from just after the specified /coordinates/. * CAVEAT: this is a performance-hotspot. -} -findBlockingPiece :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.Direction.Direction -- ^ The direction in which to search. - -> 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 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 !)) - ) $ Cartesian.Coordinates.extrapolate direction source -findBlockingPiece direction source maybePieceByCoordinates = fmap ( - id &&& Data.Maybe.fromJust . (deconstruct maybePieceByCoordinates !) - ) . Data.List.find (`isOccupied` maybePieceByCoordinates) $ Cartesian.Coordinates.extrapolate direction source -findBlockingPiece direction source MkMaybePieceByCoordinates { deconstruct = byCoordinates } = slave $ Cartesian.Coordinates.extrapolate direction source where - slave (coordinates : remainder) = case byCoordinates ! coordinates of - Nothing -> slave remainder -- Recurse. - Just piece -> Just (coordinates, piece) - slave _ = Nothing -findBlockingPiece direction source MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.listToMaybe [ - (coordinates, piece) | - coordinates <- Cartesian.Coordinates.extrapolate direction source, - piece <- Data.Maybe.maybeToList $ byCoordinates ! coordinates - ] -- List-comprehension. --} +findBlockingPiece + :: Attribute.Direction.Direction -- ^ The direction in which to search. + -> Cartesian.Coordinates.Coordinates -- ^ The starting point. + -> MaybePieceByCoordinates + -> Maybe Component.Piece.LocatedPiece findBlockingPiece direction source MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.listToMaybe [ (coordinates, piece) | (coordinates, Just piece) <- map (id &&& (byCoordinates !)) $ Cartesian.Coordinates.extrapolate direction source @@ -584,18 +465,12 @@ * N.B.: there no requirement for there to actually be a /piece/ to attack at the specified target. -} -findAttackerInDirection :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. +findAttackerInDirection + :: Attribute.LogicalColour.LogicalColour -- ^ The defender's /logical colour/. -> Attribute.Direction.Direction -- ^ The /direction/ from the /coordinates/ of concern; the opposite /direction/ from which an attacker might strike. - -> 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 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) #-} + -> Cartesian.Coordinates.Coordinates -- ^ The defender's square. + -> MaybePieceByCoordinates + -> Maybe (Cartesian.Coordinates.Coordinates, Attribute.Rank.Rank) -- ^ Any opposing /piece/ which can attack the specified square from the specified /direction/. 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) @@ -603,27 +478,17 @@ ) . findBlockingPiece direction destination -- | Whether the specified /coordinates/ are unoccupied. -isVacant :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y - -> MaybePieceByCoordinates x y +isVacant + :: Cartesian.Coordinates.Coordinates + -> MaybePieceByCoordinates -> Bool {-# INLINE isVacant #-} isVacant coordinates MkMaybePieceByCoordinates { deconstruct = byCoordinates } = Data.Maybe.isNothing $ byCoordinates ! coordinates -- | Whether the specified /coordinates/ are occupied. -isOccupied :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y - -> MaybePieceByCoordinates x y +isOccupied + :: Cartesian.Coordinates.Coordinates + -> MaybePieceByCoordinates -> Bool {-# INLINE isOccupied #-} isOccupied coordinates = not . isVacant coordinates @@ -635,34 +500,22 @@ * N.B.: the specified end-points are uninspected. -} -isClear :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ Source. - -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. - -> MaybePieceByCoordinates x y +isClear + :: Cartesian.Coordinates.Coordinates -- ^ Source. + -> Cartesian.Coordinates.Coordinates -- ^ Destination. + -> MaybePieceByCoordinates -> Bool {-# INLINABLE isClear #-} -- N.B.: required to ensure specialisation of 'Cartesian.Coordinates.interpolate'. -{-# 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 -- | Whether there's a blockage between a /piece/ presumed to exist at the specified source, & a /piece/ presumed to exist @ the specified destination. -isObstructed :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Cartesian.Coordinates.Coordinates x y -- ^ Source. - -> Cartesian.Coordinates.Coordinates x y -- ^ Destination. - -> MaybePieceByCoordinates x y +isObstructed + :: Cartesian.Coordinates.Coordinates -- ^ Source. + -> Cartesian.Coordinates.Coordinates -- ^ Destination. + -> MaybePieceByCoordinates -> 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 {- | @@ -671,16 +524,10 @@ * CAVEAT: assumes that the /move/ is valid; otherwise one would also need to confirm that the opponent's @Pawn@ had just double-advanced into the appropriate position. -} -isEnPassantMove :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Component.Move.Move x y - -> MaybePieceByCoordinates x y +isEnPassantMove + :: Component.Move.Move + -> MaybePieceByCoordinates -> 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 @@ -690,24 +537,18 @@ (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- | Self-documentation. -type Transformation x y = MaybePieceByCoordinates x y -> MaybePieceByCoordinates x y +type Transformation = MaybePieceByCoordinates -> MaybePieceByCoordinates {- | * Adjust the array to reflect a move. * CAVEAT: regrettably this allocates an entire array. -} -movePiece :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Component.Move.Move x y - -> 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 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 + :: Component.Move.Move + -> Component.Piece.Piece -- ^ The (possibly promoted) piece to place at the destination. + -> Maybe Cartesian.Coordinates.Coordinates -- ^ Destination of any En-passant @Pawn@. + -> Transformation movePiece move destinationPiece maybeEnPassantDestination MkMaybePieceByCoordinates { deconstruct = byCoordinates } = MkMaybePieceByCoordinates $ byCoordinates // Data.Maybe.maybe id ( (:) . flip (,) Nothing -- Take the Pawn en-passant. ) maybeEnPassantDestination [ @@ -719,27 +560,4 @@ Just destinationPiece -- Place the piece at the destination, removing any opposing incumbent as a side-effect. ) ] - --- | Calculate the total value of the /coordinates/ occupied by the /piece/s of either side. -sumPieceSquareValueByLogicalColour :: ( - Enum x, - Enum y, - Num pieceSquareValue, - Ord x, - Ord y - ) - => Component.PieceSquareByCoordinatesByRank.FindPieceSquareValue x y pieceSquareValue - -> MaybePieceByCoordinates x y - -> [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' ( - \(b, w) (coordinates, piece) -> let - logicalColour = Component.Piece.getLogicalColour piece - pieceSquareValue = findPieceSquareValue logicalColour (Component.Piece.getRank piece) coordinates - in if Attribute.LogicalColour.isBlack logicalColour - then let b' = b + pieceSquareValue in b' `seq` (b', w) - else let w' = w + pieceSquareValue in w' `seq` (b, w') - ) (0, 0) . StateProperty.Seeker.findAllPieces 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -52,26 +51,19 @@ 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.Type.Length as Type.Length +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified Control.DeepSeq -import qualified Data.Array.IArray import qualified Data.Maybe -- | The state of the game, without regard to how it arrived there. -data Position x y = MkPosition { +data Position = MkPosition { getNextLogicalColour :: Attribute.LogicalColour.LogicalColour, -- ^ The next player to move. - getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates x y, - getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x, - getMaybeEnPassantAbscissa :: Maybe (State.EnPassantAbscissa.EnPassantAbscissa x) + getMaybePieceByCoordinates :: State.MaybePieceByCoordinates.MaybePieceByCoordinates, + getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, + getMaybeEnPassantAbscissa :: Maybe State.EnPassantAbscissa.EnPassantAbscissa } deriving Eq -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Ord (Position x y) where - {-# SPECIALISE instance Ord (Position Type.Length.X Type.Length.Y) #-} +instance Ord Position where position@MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates @@ -90,10 +82,7 @@ getMaybeEnPassantAbscissa position' ) -instance ( - Control.DeepSeq.NFData x, - Control.DeepSeq.NFData y - ) => Control.DeepSeq.NFData (Position x y) where +instance Control.DeepSeq.NFData Position where rnf MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates, @@ -101,12 +90,7 @@ getMaybeEnPassantAbscissa = maybeEnPassantAbscissa } = Control.DeepSeq.rnf (nextLogicalColour, maybePieceByCoordinates, castleableRooksByLogicalColour, maybeEnPassantAbscissa) -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Property.Reflectable.ReflectableOnX (Position x y) where +instance Property.Reflectable.ReflectableOnX Position where reflectOnX position@MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates, @@ -117,8 +101,8 @@ getCastleableRooksByLogicalColour = Property.Reflectable.reflectOnX castleableRooksByLogicalColour } -instance (Data.Array.IArray.Ix x, Enum x, Enum y, Ord y) => Component.Zobrist.Hashable2D Position x y {-CAVEAT: FlexibleInstances, MultiParamTypeClasses-} where - listRandoms2D MkPosition { +instance StateProperty.Hashable.Hashable Position where + listRandoms MkPosition { getNextLogicalColour = nextLogicalColour, getMaybePieceByCoordinates = maybePieceByCoordinates, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, @@ -128,22 +112,16 @@ then (Component.Zobrist.getRandomForBlacksMove zobrist :) else id ) . Data.Maybe.maybe id ( - (++) . (`Component.Zobrist.listRandoms1D` zobrist) - ) maybeEnPassantAbscissa $ Component.Zobrist.listRandoms1D castleableRooksByLogicalColour zobrist ++ Component.Zobrist.listRandoms2D maybePieceByCoordinates zobrist + (++) . (`StateProperty.Hashable.listRandoms` zobrist) + ) maybeEnPassantAbscissa $ StateProperty.Hashable.listRandoms castleableRooksByLogicalColour zobrist ++ StateProperty.Hashable.listRandoms maybePieceByCoordinates zobrist -- | Constructor. -mkPosition :: ( - Enum x, - Enum y, - Ord x, - Ord y - ) - => Attribute.LogicalColour.LogicalColour -- ^ The logical colour of the next player to move. - -> State.MaybePieceByCoordinates.MaybePieceByCoordinates x y - -> 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 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 + :: Attribute.LogicalColour.LogicalColour -- ^ The logical colour of the next player to move. + -> State.MaybePieceByCoordinates.MaybePieceByCoordinates + -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour + -> Maybe Component.Turn.Turn -- ^ The last /turn/ made. + -> Position 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/StateProperty/Hashable.hs b/src-lib/BishBosh/StateProperty/Hashable.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/StateProperty/Hashable.hs @@ -0,0 +1,64 @@ +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * Defines the random-numbers required to construct a hash of a chess-position. + + * Facilitates the construction of a hash from arbitrary data. +-} + +module BishBosh.StateProperty.Hashable( +-- * Type-classes + Hashable(..), +-- * Constants +-- combiningOp, +-- * Functions + hash, + combine +) where + +import qualified BishBosh.Component.Zobrist as Component.Zobrist +import qualified Data.Bits +import qualified Data.List + +-- | An interface to which hashable data can conform. +class Hashable hashable where + listRandoms :: hashable -> Component.Zobrist.Zobrist positionHash -> [positionHash] + +-- | The operator used when combining random numbers to compose a hash. +combiningOp :: Data.Bits.Bits positionHash => positionHash -> positionHash -> positionHash +combiningOp = Data.Bits.xor + +-- | Resolve a hashable into a hash. +hash :: ( + Data.Bits.Bits positionHash, + Hashable hashable + ) + => hashable + -> Component.Zobrist.Zobrist positionHash + -> positionHash +hash hashable = Data.List.foldl1' combiningOp . listRandoms hashable + +-- | Include a list of random numbers in the hash. +combine :: Data.Bits.Bits positionHash => positionHash -> [positionHash] -> positionHash +combine = Data.List.foldl' combiningOp + diff --git a/src-lib/BishBosh/StateProperty/Mutator.hs b/src-lib/BishBosh/StateProperty/Mutator.hs --- a/src-lib/BishBosh/StateProperty/Mutator.hs +++ b/src-lib/BishBosh/StateProperty/Mutator.hs @@ -47,12 +47,12 @@ * CAVEAT: this function isn't called during normal play. -} -class Mutator mutator x y where +class Mutator mutator where defineCoordinates - :: Maybe Component.Piece.Piece -- ^ The optional /piece/ to place (or remove if @Nothing@ is specified). - -> Cartesian.Coordinates.Coordinates x y -- ^ The /coordinates/ to define. - -> mutator x y - -> mutator x y + :: Maybe Component.Piece.Piece -- ^ The optional /piece/ to place (or remove if @Nothing@ is specified). + -> Cartesian.Coordinates.Coordinates -- ^ The /coordinates/ to define. + -> mutator + -> mutator {- | * Place a /piece/ at the specified /coordinates/. @@ -60,38 +60,38 @@ * CAVEAT: any /piece/ previously at the specified /coordinates/ will be obliterated. -} placePiece - :: Mutator mutator x y + :: Mutator mutator => Component.Piece.Piece - -> Cartesian.Coordinates.Coordinates x y - -> mutator x y - -> mutator x y + -> Cartesian.Coordinates.Coordinates + -> mutator + -> mutator placePiece piece = defineCoordinates $ Just piece -- | Place the first /piece/. placeFirstPiece :: ( - Property.Empty.Empty (mutator x y), - Mutator mutator x y + Property.Empty.Empty mutator, + Mutator mutator ) => Component.Piece.Piece - -> Cartesian.Coordinates.Coordinates x y - -> mutator x y + -> Cartesian.Coordinates.Coordinates + -> mutator placeFirstPiece piece coordinates = placePiece piece coordinates Property.Empty.empty -- | Place /pieces/ from scratch. placeAllPieces :: ( - Property.Empty.Empty (mutator x y), - Mutator mutator x y + Property.Empty.Empty mutator, + Mutator mutator ) - => [(Component.Piece.Piece, Cartesian.Coordinates.Coordinates x y)] - -> mutator x y + => [(Component.Piece.Piece, Cartesian.Coordinates.Coordinates)] + -> mutator placeAllPieces = foldr (uncurry placePiece) Property.Empty.empty -- | Remove a /piece/ from the /board/. removePiece - :: Mutator mutator x y - => Cartesian.Coordinates.Coordinates x y - -> mutator x y - -> mutator x y + :: Mutator mutator + => Cartesian.Coordinates.Coordinates + -> mutator + -> mutator removePiece = defineCoordinates Nothing diff --git a/src-lib/BishBosh/StateProperty/Seeker.hs b/src-lib/BishBosh/StateProperty/Seeker.hs --- a/src-lib/BishBosh/StateProperty/Seeker.hs +++ b/src-lib/BishBosh/StateProperty/Seeker.hs @@ -24,32 +24,81 @@ -} module BishBosh.StateProperty.Seeker( +-- * Types +-- ** Type-synonyms +-- NPiecesByFile, + NPiecesByFileByLogicalColour, -- * Type-classes Seeker(..), -- * Functions - findAllPieces + accumulatePawnsByFile, + findAllPieces, + summariseNPawnsByLogicalColour ) where +import Control.Arrow((***)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Type.Count as Type.Count +import qualified BishBosh.Type.Length as Type.Length +import qualified Control.Arrow +import qualified Data.Array.IArray +import qualified Data.Foldable +import qualified Data.Map.Strict as Map +-- | The number of /piece/s in each file, for each /logical colour/. +type NPiecesByFile = Map.Map Type.Length.X Type.Count.NPieces + +-- | Add a Pawn's file to the map. +accumulatePawnsByFile :: Type.Length.X -> NPiecesByFile -> NPiecesByFile +{-# INLINE accumulatePawnsByFile #-} +accumulatePawnsByFile = flip (Map.insertWith $ const succ) 1 + +-- | The number of /piece/s in each file, for each /logical colour/. +type NPiecesByFileByLogicalColour = Attribute.LogicalColour.ArrayByLogicalColour NPiecesByFile + -- | An interface which may be implemented by data which can search the board. -class Seeker seeker x y where - -- | Locate any @Knight@s capable of taking a piece at the specified coordinates. +class Seeker seeker where + -- | Locate any @Knight@s capable of taking a /piece/ at the specified /coordinates/. findProximateKnights :: Attribute.LogicalColour.LogicalColour -- ^ The /logical colour/ of the @Knight@ for which to search. - -> Cartesian.Coordinates.Coordinates x y -- ^ The destination to which the @Knight@ is required to be capable of jumping. - -> seeker x y - -> [Cartesian.Coordinates.Coordinates x y] + -> Cartesian.Coordinates.Coordinates -- ^ The destination to which the @Knight@ is required to be capable of jumping. + -> seeker + -> [Cartesian.Coordinates.Coordinates] -- | Locate any /piece/s satisfying the specified predicate. findPieces :: (Component.Piece.Piece -> Bool) -- ^ Predicate. - -> seeker x y - -> [Component.Piece.LocatedPiece x y] + -> seeker + -> [Component.Piece.LocatedPiece] + {- | + * Counts the number of @Pawn@s of each /logical colour/ with similar /x/-coordinates; their /y/-coordinate is irrelevant. + + * N.B.: files lacking any @Pawn@, don't feature in the results. + -} + countPawnsByFileByLogicalColour :: seeker -> NPiecesByFileByLogicalColour + countPawnsByFileByLogicalColour = ( + \(mB, mW) -> Attribute.LogicalColour.listArrayByLogicalColour [mB, mW] + ) . foldr ( + ( + \(x, isBlack) -> ( + if isBlack then Control.Arrow.first else Control.Arrow.second -- Select the appropriate map. + ) $ accumulatePawnsByFile x + ) . ( + Cartesian.Coordinates.getX *** Attribute.LogicalColour.isBlack . Component.Piece.getLogicalColour + ) + ) Property.Empty.empty . findPieces Component.Piece.isPawn + -- | Locate all /piece/s on the board. -findAllPieces :: Seeker seeker x y => seeker x y -> [Component.Piece.LocatedPiece x y] +findAllPieces :: Seeker seeker => seeker -> [Component.Piece.LocatedPiece] findAllPieces = findPieces $ const True + +-- | Resolves 'NPiecesByFileByLogicalColour' into the total number of /Pawn/s on either side. +summariseNPawnsByLogicalColour :: Seeker seeker => seeker -> Attribute.LogicalColour.ArrayByLogicalColour Type.Count.NPieces +summariseNPawnsByLogicalColour = Data.Array.IArray.amap ( + Data.Foldable.foldl' (+) 0 + ) . countPawnsByFileByLogicalColour diff --git a/src-lib/BishBosh/Text/Poly.hs b/src-lib/BishBosh/Text/Poly.hs --- a/src-lib/BishBosh/Text/Poly.hs +++ b/src-lib/BishBosh/Text/Poly.hs @@ -37,10 +37,12 @@ import qualified BishBosh.Data.Integral as Data.Integral import qualified Data.Char -#if USE_POLYPARSE == 1 +#if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +#elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly +#else +# error "USE_POLYPARSE invalid" #endif -- | Self-documentation. diff --git a/src-lib/BishBosh/Text/ShowColouredPrefix.hs b/src-lib/BishBosh/Text/ShowColouredPrefix.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Text/ShowColouredPrefix.hs @@ -0,0 +1,53 @@ +{- + 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@] Define standard prefixes for log-messages. +-} + +module BishBosh.Text.ShowColouredPrefix( +-- * Constants + showsPrefixInfo, + showsPrefixWarning, + showsPrefixError + ) where + +import qualified BishBosh.Attribute.ANSIColourCode as Attribute.ANSIColourCode +import qualified BishBosh.Attribute.PhysicalColour as Attribute.PhysicalColour +import qualified BishBosh.Text.ShowPrefix as Text.ShowPrefix + +-- | Show the prefix used to denote an information-message. +showsPrefixInfo :: ShowS +showsPrefixInfo = Attribute.ANSIColourCode.bracket ( + Attribute.ANSIColourCode.selectGraphicsRendition False $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.green + ) $ Text.ShowPrefix.showsPrefixInfo "" + +-- | Show the prefix used to denote a warning-message. +showsPrefixWarning :: ShowS +showsPrefixWarning = Attribute.ANSIColourCode.bracket ( + Attribute.ANSIColourCode.selectGraphicsRendition True $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.yellow + ) $ Text.ShowPrefix.showsPrefixWarning "" + +-- | Show the prefix used to denote an error-message. +showsPrefixError :: ShowS +showsPrefixError = Attribute.ANSIColourCode.bracket ( + Attribute.ANSIColourCode.selectGraphicsRendition True $ Attribute.ANSIColourCode.mkFgColourCode Attribute.PhysicalColour.red + ) $ Text.ShowPrefix.showsPrefixError "" + diff --git a/src-lib/BishBosh/Time/GameClock.hs b/src-lib/BishBosh/Time/GameClock.hs --- a/src-lib/BishBosh/Time/GameClock.hs +++ b/src-lib/BishBosh/Time/GameClock.hs @@ -63,11 +63,11 @@ | 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 + ) . mapM Property.Switchable.toggle . Data.Foldable.toList $ 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. + ) . mapM Property.Switchable.switchOff . Data.Foldable.toList . deconstruct -- CAVEAT: this invalidates the clock, since a subsequent call to 'toggle' would activate both stop-watches. isOn = Data.Foldable.any Property.Switchable.isOn . deconstruct -- CAVEAT: includes the dysfunctional state in which both sides are running. @@ -75,7 +75,7 @@ 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") + ((/= 1) . length . filter Property.Switchable.isOn . Data.Foldable.toList . deconstruct, "The two stop-watches must be in opposite states") ] -- | Show the elapsed times. diff --git a/src-lib/BishBosh/Type/Count.hs b/src-lib/BishBosh/Type/Count.hs --- a/src-lib/BishBosh/Type/Count.hs +++ b/src-lib/BishBosh/Type/Count.hs @@ -22,7 +22,7 @@ [@DESCRIPTION@] - * Defines distinct types for various countable quantities to prevent accidental conflation between conceptually different quantities. + * Defines distinct types for various conceptually different countable quantities to prevent accidental conflation. * Nothing but the type is exported, facilitating reversion to unwrapped types. -} @@ -32,6 +32,7 @@ -- ** Type-synonyms -- Base, -- ** Data-types + NCoordinates, NDecimalDigits, NDirections, NGames, @@ -50,9 +51,19 @@ import qualified Text.XML.HXT.Arrow.Pickle as HXT #endif --- | The private type which is wrapped by countable data-types. +-- | The private type which is wrapped by various countable data-types. type Base = Int +-- | A number of (board) coordinates. +#ifdef USE_NEWTYPE_WRAPPERS +newtype NCoordinates = MkNCoordinates Base deriving (Enum, Eq, Integral, Num, Ord, Real) + +instance Show NCoordinates where + showsPrec precedence (MkNCoordinates n) = showsPrec precedence n +#else +type NCoordinates = Base +#endif + -- | 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) @@ -63,7 +74,7 @@ type NDecimalDigits = Base #endif --- | A number of decimal digits. +-- | A number of directions. #ifdef USE_NEWTYPE_WRAPPERS newtype NDirections = MkNDirections Base deriving (Enum, Eq, Integral, Num, Ord, Real) #else diff --git a/src-lib/BishBosh/Type/Length.hs b/src-lib/BishBosh/Type/Length.hs --- a/src-lib/BishBosh/Type/Length.hs +++ b/src-lib/BishBosh/Type/Length.hs @@ -23,8 +23,10 @@ [@DESCRIPTION@] - * Defines suitable concrete types with which to specialise length-related type-parameters. + * Defines distinct types for various conceptually different length-related quantities to prevent accidental conflation. + * Nothing but the type is exported, facilitating reversion to unwrapped types. + * CAVEAT: use of narrow numeric types, results in marginally slower performance without any reduction in space-requirements. -} @@ -32,11 +34,11 @@ -- * Types -- ** Type-synonyms -- Base, - Distance, +-- ** Data-types X, Y, - Row(), - Column() + Row, + Column ) where #if defined(USE_NARROW_NUMBERS) || defined(USE_NEWTYPE_WRAPPERS) @@ -45,12 +47,14 @@ # endif # ifdef USE_NEWTYPE_WRAPPERS +import qualified Control.Arrow import qualified Control.DeepSeq +import qualified Data.Array.IArray # 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. +-- | The private type which is wrapped by various length-related data-types. type Base = #ifdef USE_NARROW_NUMBERS Data.Int.Int8 @@ -61,36 +65,49 @@ Int #endif -{- | - * The preferred type by which to represent the signed distance of a move. +-- | The board-abscissa. +#ifdef USE_NEWTYPE_WRAPPERS +newtype X = MkX Base deriving (Control.DeepSeq.NFData, Data.Array.IArray.Ix, Enum, Eq, Integral, Num, Ord, Real) - * 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. +instance Read X where + readsPrec precision = map (Control.Arrow.first MkX) . readsPrec precision --- | The distance along the abscissa. -type X = Base +instance Show X where + showsPrec precision (MkX x) = showsPrec precision x +#else +type X = Base +#endif --- | The distance along the ordinate. -type Y = Base -- N.B.: it can be independent of 'X'. +-- | The board-ordinate; independent of /X/. +#ifdef USE_NEWTYPE_WRAPPERS +newtype Y = MkY Base deriving (Control.DeepSeq.NFData, Enum, Eq, Integral, Num, Ord, Real) +instance Read Y where + readsPrec precision = map (Control.Arrow.first MkY) . readsPrec precision + +instance Show Y where + showsPrec precision (MkY y) = showsPrec precision y +#else +type Y = Base +#endif + -- | 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) +newtype Row = MkRow Base 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 +type Row = Base #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) +newtype Column = MkColumn Base 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 +type Column = Base #endif diff --git a/src-lib/BishBosh/Type/Mass.hs b/src-lib/BishBosh/Type/Mass.hs --- a/src-lib/BishBosh/Type/Mass.hs +++ b/src-lib/BishBosh/Type/Mass.hs @@ -38,20 +38,28 @@ PieceSquareValue ) where +#ifdef USE_PRECISION +import BishBosh.Data.Ratio() +#else import qualified Text.XML.HXT.Arrow.Pickle as HXT +#endif -- | The preferred type by which to weight criteria. type CriterionWeight = -#ifdef USE_NARROW_NUMBERS +#ifdef USE_PRECISION + Rational +#else /* Floating-point */ +# 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. +# else + Double instance HXT.XmlPickler Double where xpickle = HXT.xpPrim +# endif #endif -- | The preferred type by which to value criteria. 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 @@ -28,13 +28,13 @@ -- ** Data-types Command(..), -- * Constants - commandPrefix, +-- commandPrefix, -- hintTag, printTag, -- quitTag, -- reportTag, -- resignTag, - restartTag, +-- restartTag, -- rollBackTag, -- saveTag, setTag, @@ -48,17 +48,18 @@ -- * Functions readsCommand, showsCommand, + issueCommand, autoComplete ) where 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 +import qualified BishBosh.Input.Options as Input.Options +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription +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 import qualified Control.Arrow import qualified Control.DeepSeq import qualified Data.List @@ -125,24 +126,25 @@ -- | The format of the argument to the runtime-command /set/. setArgs :: String setArgs = Data.List.intercalate alternationTag [ - showString Input.SearchOptions.searchDepthTag " " + showString Property.ExtendedPositionDescription.tag " ", + showString UI.SetObject.searchDepthTag " " ] -- | The sum-type of commands that a user may issue. -data Command x y - = Hint -- ^ Request a move-suggestion. - | Print UI.PrintObject.PrintObject -- ^ Print the requested static data. - | Quit -- ^ Terminate this application. - | Report UI.ReportObject.ReportObject -- ^ Report on the requested dynamic data. - | Resign -- ^ Admit defeat. - | Restart -- ^ Abandon the current game, & start afresh. - | 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. +data Command + = Hint -- ^ Request a move-suggestion. + | Print UI.PrintObject.PrintObject -- ^ Print the requested static data. + | Quit -- ^ Terminate this application. + | Report UI.ReportObject.ReportObject -- ^ Report on the requested dynamic data. + | Resign -- ^ Admit defeat. + | Restart -- ^ Abandon the current game, & start afresh. + | 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 something. + | Swap -- ^ Swap options between the two sides; which causes the players to swap sides. deriving (Eq, Show) -instance Control.DeepSeq.NFData (Command x y) where +instance Control.DeepSeq.NFData Command where rnf (Print printObject) = Control.DeepSeq.rnf printObject rnf (Set setObject) = Control.DeepSeq.rnf setObject rnf _ = () @@ -185,7 +187,7 @@ ), ( setTag, Just setArgs, - showString "Mutate " Input.Options.tag + "Mutate something" ), ( swapTag, Nothing, @@ -213,7 +215,7 @@ objectFieldWidth = succ $ maximum [length arg | (_, Just arg, _) <- commands] -- | Reads a /command/. -readsCommand :: String -> Either String (Command x y, String) +readsCommand :: String -> Either String (Command, String) readsCommand [] = Left . showString "null command received; specify one of " . show $ map (\(tag, _, _) -> tag) commands readsCommand s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of [("hint", s')] -> Right (Hint, s') @@ -243,7 +245,7 @@ _ -> Left "no command received" -- | Shows a /command/. -showsCommand :: Command x y -> ShowS +showsCommand :: Command -> ShowS showsCommand = \case Hint -> showString hintTag Print printObject -> showString printTag . showChar ' ' . shows printObject @@ -251,10 +253,14 @@ Report reportObject -> showString reportTag . showChar ' ' . shows reportObject Resign -> showString resignTag Restart -> showString restartTag - RollBack maybeNMoves -> showString rollBackTag . Data.Maybe.maybe id (\nMoves -> showChar ' ' . shows nMoves) maybeNMoves + RollBack maybeNPlies -> showString rollBackTag . Data.Maybe.maybe id (\nPlies -> showChar ' ' . shows nPlies) maybeNPlies Save -> showString saveTag Set setObject -> showString setTag . showChar ' ' . shows setObject Swap -> showString swapTag + +-- | Show the specified command in the format required by this application's parser. +issueCommand :: Command -> ShowS +issueCommand command = showChar commandPrefix . shows command -- | Replace the first word of the specified string with the name of a command of which it is an unambiguous case-insensitive prefix. autoComplete :: ShowS 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 @@ -29,7 +29,6 @@ -- * Constants -- availableMovesTag, -- boardTag, --- epdTag, -- fenTag, -- gameTag, -- maxPositionInstancesTag, @@ -41,8 +40,10 @@ autoComplete ) where -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Text.AutoComplete as Text.AutoComplete +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Text.AutoComplete as Text.AutoComplete import qualified Control.Arrow import qualified Control.DeepSeq import qualified Data.List.Extra @@ -56,10 +57,6 @@ boardTag = "board" -- | Input-format. -epdTag :: String -epdTag = "epd" - --- | Input-format. fenTag :: String fenTag = "fen" @@ -73,7 +70,7 @@ -- | Input-format. movesTag :: String -movesTag = "moves" +movesTag = showString Component.Move.tag "s" -- | Input-format. pgnTag :: String @@ -102,7 +99,7 @@ instance Show ReportObject where show AvailableMoves = availableMovesTag show Board = boardTag - show EPD = epdTag + show EPD = Property.ExtendedPositionDescription.tag show FEN = fenTag show Game = gameTag show MaxPositionInstances = maxPositionInstancesTag @@ -135,7 +132,7 @@ autoComplete = Text.AutoComplete.autoComplete [ availableMovesTag, boardTag, - epdTag, + Property.ExtendedPositionDescription.tag, fenTag, gameTag, maxPositionInstancesTag, 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 @@ -19,42 +19,62 @@ {- | [@AUTHOR@] Dr. Alistair Ward - [@DESCRIPTION@] Defines the fields a user can mutate. + [@DESCRIPTION@] Defines the things a user can mutate at runtime. -} module BishBosh.UI.SetObject ( -- * Types -- ** Data-types SetObject(..), +-- * Constants + searchDepthTag, -- * Functions autoComplete, -- ** Constructors + mkEPD, mkSearchDepth ) where -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 BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Input.SearchOptions as Input.SearchOptions +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription +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 Type.Count.NPlies deriving Eq +-- | Input-format. +searchDepthTag :: String +searchDepthTag = Input.SearchOptions.searchDepthTag +-- | The sum-type of fields a user can mutate. +data SetObject + = EPD Model.Game.Game -- ^ Define the position. + | SearchDepth Type.Count.NPlies -- ^ Set the number of plies to to search ahead for the optimal move. + deriving Eq + instance Control.DeepSeq.NFData SetObject where - rnf (SearchDepth searchDepth) = Control.DeepSeq.rnf searchDepth + rnf (EPD epd) = Control.DeepSeq.rnf epd + rnf (SearchDepth searchDepth) = Control.DeepSeq.rnf searchDepth instance Show SetObject where - showsPrec _ (SearchDepth searchDepth) = showString Input.SearchOptions.searchDepthTag . showChar ' ' . shows searchDepth + showsPrec _ (EPD epd) = showString Property.ExtendedPositionDescription.tag . showChar ' ' . Property.ExtendedPositionDescription.showsEPD epd + showsPrec _ (SearchDepth searchDepth) = showString searchDepthTag . showChar ' ' . shows searchDepth instance Read SetObject where - readsPrec _ s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of - [("searchdepth", s')] -> Control.Arrow.first (mkSearchDepth . fromInteger) `map` reads s' - _ -> [] -- No parse. + readsPrec precedence s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of + [("epd", epd)] -> Control.Arrow.first EPD `map` Property.ExtendedPositionDescription.readsEPD epd + [("searchdepth", s')] -> Control.Arrow.first (mkSearchDepth . fromInteger) `map` readsPrec precedence s' + _ -> [] -- No parse. +-- | Constructor. +mkEPD :: Model.Game.Game -> SetObject +mkEPD = EPD + -- | Smart constructor. mkSearchDepth :: Type.Count.NPlies -> SetObject mkSearchDepth searchDepth @@ -63,5 +83,5 @@ -- | Replace the first word of the specified string with the name of a command of which it is an unambiguous case-insensitive prefix. autoComplete :: ShowS -autoComplete = Text.AutoComplete.autoComplete [Input.SearchOptions.searchDepthTag] +autoComplete = Text.AutoComplete.autoComplete [Property.ExtendedPositionDescription.tag, searchDepthTag] 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 @@ -23,9 +23,6 @@ -} module BishBosh.Test.HUnit.Cartesian.Coordinates( --- * Types --- ** Type-synonyms - Coordinates, -- * Constants testCases ) where @@ -33,31 +30,27 @@ 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.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 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 [ all (Attribute.LogicalColourOfSquare.isBlack . Cartesian.Coordinates.getLogicalColourOfSquare) ( - Cartesian.Coordinates.extrapolate maxBound {-direction-} (minBound :: Coordinates) + Cartesian.Coordinates.extrapolate maxBound {-direction-} (minBound :: Cartesian.Coordinates.Coordinates) ) ~? "'BishBosh.Cartesian.Coordinates.getLogicalColourOfSquare' failed to find black squares on the main diagonal.", "'BishBosh.Cartesian.Coordinates.getLogicalColourOfSquare' failed to count equal numbers of black & white squares." ~: ( \(black, white) -> length black ~?= length white ) . Data.List.partition Attribute.LogicalColourOfSquare.isBlack $ map Cartesian.Coordinates.getLogicalColourOfSquare ( - Property.FixedMembership.members :: [Coordinates] + Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates] ), "'BishBosh.Cartesian.Coordinates' failed to visit all squares." ~: length ( - Property.FixedMembership.members :: [Coordinates] - ) ~?= Cartesian.Coordinates.nSquares, + Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates] + ) ~?= fromIntegral 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 Type.Length.X Type.Length.Y Int + Cartesian.Coordinates.listArrayByCoordinates [0 .. ] :: Cartesian.Coordinates.ArrayByCoordinates 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,28 +32,23 @@ import Control.Arrow((&&&)) import qualified BishBosh.Cartesian.Vector as Cartesian.Vector import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -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 -> Type.Length.Distance -measureLength = uncurry (+) . (abs . Cartesian.Vector.getXDistance &&& abs . Cartesian.Vector.getYDistance) +measureLength :: Cartesian.Vector.Vector -> Int +measureLength = uncurry (+) . (fromIntegral . abs . Cartesian.Vector.getXDistance &&& fromIntegral . abs . Cartesian.Vector.getYDistance) -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ all ( Data.Maybe.isJust . Cartesian.Vector.toMaybeDirection - ) ( - Cartesian.Vector.attackVectorsForKing :: [Cartesian.Vector.VectorInt] - ) ~? "'BishBosh.Cartesian.Vector.attackVectorsForKing' failed.", + ) Cartesian.Vector.attackVectorsForKing ~? "'BishBosh.Cartesian.Vector.attackVectorsForKing' failed.", all ( Data.Maybe.isNothing . Cartesian.Vector.toMaybeDirection - ) ( - Cartesian.Vector.attackVectorsForKnight :: [Cartesian.Vector.VectorInt] - ) ~? "'BishBosh.Cartesian.Vector.attackVectorsForKnight' failed.", + ) Cartesian.Vector.attackVectorsForKnight ~? "'BishBosh.Cartesian.Vector.attackVectorsForKnight' failed.", all ( uncurry (&&) . ( all ((== 2) . measureLength) &&& (== 2) . length 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 @@ -33,7 +33,6 @@ import qualified BishBosh.Component.CastlingMove as Component.CastlingMove 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.Type.Length as Type.Length import qualified Data.List import qualified Test.HUnit @@ -49,7 +48,7 @@ and [ (== 1) . length . Data.List.nub $ map ( map ( - \castlingMove -> getAbscissa (getMove castlingMove :: Test.HUnit.Component.Move.Move) + \castlingMove -> getAbscissa (getMove castlingMove :: Component.Move.Move) ) . Component.CastlingMove.getCastlingMoves ) Property.FixedMembership.members | getMove <- [Component.CastlingMove.getKingsMove, Component.CastlingMove.getRooksMove], @@ -58,7 +57,7 @@ ] ~? "'BishBosh.Component.CastlingMove':\tdistance spanned by castling-moves should be independent of logical colour.", all ( \logicalColour -> (== 1) . length $ Data.List.nub [ - Cartesian.Coordinates.getY $ getTerminus (getMove castlingMove :: Test.HUnit.Component.Move.Move) | + Cartesian.Coordinates.getY $ getTerminus (getMove castlingMove :: Component.Move.Move) | castlingMove <- Component.CastlingMove.getCastlingMoves logicalColour, getMove <- [Component.CastlingMove.getKingsMove, Component.CastlingMove.getRooksMove], getTerminus <- [Component.Move.getSource, Component.Move.getDestination] @@ -67,7 +66,7 @@ and [ abs ( Cartesian.Vector.getXDistance $ Component.Move.measureDistance ( - Component.CastlingMove.getKingsMove castlingMove :: Test.HUnit.Component.Move.Move + Component.CastlingMove.getKingsMove castlingMove :: Component.Move.Move ) ) == kingsMoveLength | logicalColour <- Property.FixedMembership.members, 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 @@ -23,9 +23,6 @@ -} module BishBosh.Test.HUnit.Component.Move( --- * Types --- ** Type-synonyms - Move, -- * Constants testCases ) where @@ -35,19 +32,15 @@ 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.Type.Length as Type.Length import qualified Test.HUnit import Test.HUnit((~?)) --- | Defines a concrete type for testing. -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 testCases = Test.HUnit.test [ all ( \(direction, s) -> let - move :: Move + move :: Component.Move.Move move = Component.QualifiedMove.getMove . Notation.Smith.getQualifiedMove $ read s in Cartesian.Coordinates.extrapolate direction (Component.Move.getSource move) == Component.Move.interpolate move ) [ diff --git a/src-test/BishBosh/Test/HUnit/Component/Piece.hs b/src-test/BishBosh/Test/HUnit/Component/Piece.hs --- a/src-test/BishBosh/Test/HUnit/Component/Piece.hs +++ b/src-test/BishBosh/Test/HUnit/Component/Piece.hs @@ -28,15 +28,15 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -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.Notation.Smith as Notation.Smith -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates +import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Notation.Smith as Notation.Smith +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership import qualified Data.List import qualified Test.HUnit import Test.HUnit((~?), (~?=), (~:)) @@ -52,16 +52,14 @@ Data.List.sort . uncurry (++) $ (Component.Piece.getAttackDirections . Component.Piece.mkBishop &&& Component.Piece.getAttackDirections . Component.Piece.mkRook) Attribute.LogicalColour.Black ] ~? "'BishBosh.Component.Piece.getAttackDirections' failed to show Queen's moves to be union of Bishop & Rook.", "'BishBosh.Cartesian.Vector.attackVectorsForKing'." ~: ( - ( - length :: [Cartesian.Vector.VectorInt] -> Int - ) Cartesian.Vector.attackVectorsForKing ~?= length (Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black) + length Cartesian.Vector.attackVectorsForKing ~?= length (Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black) ), "'BishBosh.Component.Piece.getAttackDirections' failed for King." ~: Data.List.sort ( Component.Piece.getAttackDirections $ Component.Piece.mkKing Attribute.LogicalColour.Black {-arbitrarily-} ) ~?= Property.FixedMembership.members, all ( \((s, logicalColour), rank) -> let - source, destination :: Test.HUnit.Cartesian.Coordinates.Coordinates + source, destination :: Cartesian.Coordinates.Coordinates (source, destination) = (Component.Move.getSource &&& Component.Move.getDestination) . Component.QualifiedMove.getMove . Notation.Smith.getQualifiedMove $ read s in Component.Piece.canAttackAlong source destination $ Component.Piece.mkPiece logicalColour rank ) ( @@ -116,7 +114,7 @@ not ( any ( \((s, logicalColour), rank) -> let - source, destination :: Test.HUnit.Cartesian.Coordinates.Coordinates + source, destination :: Cartesian.Coordinates.Coordinates (source, destination) = (Component.Move.getSource &&& Component.Move.getDestination) . Component.QualifiedMove.getMove . Notation.Smith.getQualifiedMove $ read s in Component.Piece.canAttackAlong source destination $ Component.Piece.mkPiece logicalColour rank ) $ concat [ 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 @@ -25,27 +25,26 @@ module BishBosh.Test.HUnit.Component.Zobrist( -- * Types -- ** Type-synonyms - Zobrist, +-- Zobrist, -- * Constants testCases ) where import qualified BishBosh.Component.Zobrist as Component.Zobrist 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 Type.Length.X Type.Length.Y Type.Crypto.PositionHash +type Zobrist = Component.Zobrist.Zobrist Type.Crypto.PositionHash -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ - "'BishBosh.Component.Zobrist.Zobrist' contains the wrong number of random numbers." ~: length ( - Data.Foldable.toList (Data.Default.def :: Zobrist) + "'BishBosh.Component.Zobrist.Zobrist' contains the wrong number of random numbers." ~: Data.Foldable.length ( + Data.Default.def :: Zobrist ) ~?= 781 -- ] 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 @@ -24,64 +24,61 @@ -} module BishBosh.Test.HUnit.ContextualNotation.PGN( --- * Types --- ** Type-synonyms --- PGN, -- * Constants testCases ) where import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN -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 == 'L' import qualified Data.Char import qualified Text.ParserCombinators.Poly.Lazy as Poly -# else /* Plain */ +# elif USE_POLYPARSE == 'P' import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly +# else +# error "USE_POLYPARSE invalid" # endif #else /* Parsec */ import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec as Parsec #endif -#if !defined(USE_POLYPARSE) || USE_POLYPARSE != 1 +#if !defined(USE_POLYPARSE) || USE_POLYPARSE != 'L' import qualified BishBosh.Data.Exception as Data.Exception import qualified Control.Exception #endif --- | Test-subject. -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 == 'L' ( \s' -> all Data.Char.isSpace s' ~? showString "Unparsed input: " (show s') ) . snd -# else /* Plain */ +# elif USE_POLYPARSE == 'P' ( Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.ContextualNotation.PGN.testCases:\tfailed: " . show ||| const ( True ~? "" ) ) . fst +# else +# error "USE_POLYPARSE invalid" # endif $ Poly.runParser ( - ContextualNotation.PGN.parser isStrictlySequential validateMoves [] :: Text.Poly.TextParser PGN + ContextualNotation.PGN.parser isStrictlySequential validateMoves [] :: Text.Poly.TextParser ContextualNotation.PGN.PGN ) #else /* Parsec */ 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 + ContextualNotation.PGN.parser isStrictlySequential validateMoves [] :: Parsec.Parser ContextualNotation.PGN.PGN ) "PGN-parser" #endif s 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 @@ -24,7 +24,10 @@ module BishBosh.Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree( -- * Constants - testCases + testCases, +-- * Functions +-- mkGame, +-- checkMatch ) where import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove @@ -36,68 +39,78 @@ 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.Input.StandardOpeningOptions as Input.StandardOpeningOptions import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Reflectable as Property.Reflectable -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.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 import Test.HUnit((~:), (~?=)) +mkGame :: [String] -> Model.Game.Game +mkGame = either ( + \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree.mkGame:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." + ) id . Test.HUnit.Model.Game.applyMoves + +checkMatch + :: ContextualNotation.PositionHashQualifiedMoveTree.MatchSwitches + -> Model.Game.Game -- ^ Standard opening. + -> [String] -- ^ Move-sequence required to construct test-game. + -> Component.Move.Move -- ^ Expected move. + -> Test.HUnit.Test +checkMatch matchSwitches game moveStrings expectedMove = map ( + Component.QualifiedMove.getMove . fst {-qualifiedMove-} + ) ( + ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves matchSwitches ( + mkGame moveStrings + ) . ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest False {-incrementalEvaluation-} ( + Data.Default.def :: Component.Zobrist.Zobrist Type.Crypto.PositionHash + ) $ ContextualNotation.QualifiedMoveForest.fromPGNDatabase [ + ContextualNotation.PGN.mkPGN' [] [ + (ContextualNotation.PGN.dateTag, "2018.01.01") + ] game + ] + ) ~?= [expectedMove] + -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ - "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves" ~: checkMatch (True, False, False) sicilianDragon "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p f3d4p g8f6 b1c3" finalMove, -- Exact match for standard-opening. - "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/transposition" ~: checkMatch (False, False, False) sicilianDragon "e2e4 c7c5 d2d4 c5d4p g1f3 d7d6 f3d4p g8f6 b1c3" finalMove, -- White's 2nd & 3rd moves have been transposed & Black's 2nd & 3rd move also have been transposed. - "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/join" ~: checkMatch (False, True {-TryToMatchViaJoiningMove-}, False) sicilianDragon "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p b1c3 g8f6" ( - standardOpeningMoves !! 6 + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves" ~: checkMatch (True, False, False) game2 (init moveStrings2) finalMove2, -- Exact match for standard-opening. + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/transposition" ~: checkMatch (False, False, False) game1 (words "e2e4 c7c5 d2d4 c5d4p g1f3 d7d6 f3d4p g8f6 b1c3") finalMove1, -- White's 2nd & 3rd moves have been transposed & Black's 2nd & 3rd move also have been transposed. + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/transposition" ~: checkMatch (False, False, False) game2 (words "g1f3 d7d6 e2e4 c7c5 d2d4 c5d4p f3d4p g8f6 b1c3 a7a6 c1g5 e7e6 f2f4 d8b6 d1d2 b6b2p a1b1 b2a3 f4f5 b8c6 f5e6p f7e6p d4c6n b7c6n e4e5 d6e5p g5f6n g7f6b c3e4 f8e7 f1e2 h7h5 b1b3 a3a4") finalMove2, -- White & also Black's 1st & 2nd moves have been transposed. + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/join" ~: checkMatch (False, True {-TryToMatchViaJoiningMove-}, False) game1 (words "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p b1c3 g8f6") ( + moves1 !! 6 ), -- White still has to make the 2nd last move. - "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/colourFlip" ~: checkMatch (False, False, True {-TryToMatchColourFlippedPosition-}) sicilianDragon "c2c3 e7e5 c3c4 g8f6 d2d3 d7d5 c4d5p f6d5p g1f3 b8c6" ( - Property.Reflectable.reflectOnX finalMove + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/join" ~: checkMatch (False, True {-TryToMatchViaJoiningMove-}, False) game2 (words "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p f3d4p g8f6 b1c3 a7a6 c1g5 e7e6 f2f4 d8b6 d1d2 b6b2p a1b1 b2a3 f4f5 b8c6 f5e6p f7e6p d4c6n b7c6n e4e5 d6e5p g5f6n g7f6b c3e4 f8e7 f1e2 a3a4 b1b3") ( + moves2 !! 31 + ), -- White still has to make the 2nd last move. + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/colourFlip" ~: checkMatch (False, False, True {-TryToMatchColourFlippedPosition-}) game1 (words "c2c3 e7e5 c3c4 g8f6 d2d3 d7d5 c4d5p f6d5p g1f3 b8c6") ( + Property.Reflectable.reflectOnX finalMove1 ), -- White's first two moves are achievable in only one. - "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/colourFlip/transposition" ~: checkMatch (False, False, True {-TryToMatchColourFlippedPosition-}) sicilianDragon "c2c3 g8f6 c3c4 e7e5 d2d3 d7d5 c4d5p f6d5p g1f3 b8c6" ( - Property.Reflectable.reflectOnX finalMove + "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/colourFlip/transposition" ~: checkMatch (False, False, True {-TryToMatchColourFlippedPosition-}) game1 (words "c2c3 g8f6 c3c4 e7e5 d2d3 d7d5 c4d5p f6d5p g1f3 b8c6") ( + Property.Reflectable.reflectOnX finalMove1 ), -- White's first two moves are achievable in only one & Black's first two moves have been transposed. "ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves/colourFlip/join" ~: checkMatch (False, True, True) ( - mkGame $ showString sicilianDragonString " f2f3" -- Append a move after the match. - ) "c2c3 g8f6 c3c4 e7e5 d2d3 d7d5 c4d5p f6d5p g2g3 b8c6" . Component.EitherQualifiedMove.getMove . fst . head $ Notation.MoveNotation.readsQualifiedMove Data.Default.def "g1f3" + mkGame $ moveStrings1 ++ ["f2f3"] -- Append a move after the match. + ) (words "c2c3 g8f6 c3c4 e7e5 d2d3 d7d5 c4d5p f6d5p g2g3 b8c6") . Component.EitherQualifiedMove.getMove . fst . head $ Notation.MoveNotation.readsQualifiedMove Data.Default.def "g1f3" ] where - mkGame :: String -> Test.HUnit.Model.Game.Game - mkGame = either ( - \(moveString, errorMessage) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.ContextualNotation.QualifiedMoveForest.testCases:\tfailed for " . showString Component.Move.tag . Text.ShowList.showsAssociation . shows moveString . showString "; " $ showString errorMessage "." - ) id . Test.HUnit.Model.Game.applyMoves . words - - sicilianDragonString = "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p f3d4p g8f6 b1c3 g7g6" + moveStrings1, moveStrings2 :: [String] + moveStrings1 = words "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p f3d4p g8f6 b1c3 g7g6" + moveStrings2 = words "e2e4 c7c5 g1f3 d7d6 d2d4 c5d4p f3d4p g8f6 b1c3 a7a6 c1g5 e7e6 f2f4 d8b6 d1d2 b6b2p a1b1 b2a3 f4f5 b8c6 f5e6p f7e6p d4c6n b7c6n e4e5 d6e5p g5f6n g7f6b c3e4 f8e7 f1e2 h7h5 b1b3 a3a4 c2c4" -- ECO B97x. - sicilianDragon :: Test.HUnit.Model.Game.Game - sicilianDragon = mkGame sicilianDragonString + game1, game2 :: Model.Game.Game + game1 = mkGame moveStrings1 + game2 = mkGame moveStrings2 - standardOpeningMoves = map (Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove) $ Model.Game.listTurnsChronologically sicilianDragon - finalMove = last standardOpeningMoves + moves1, moves2 :: [Component.Move.Move] + [moves1, moves2] = map ( + map (Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove) . Model.Game.listTurnsChronologically + ) [game1, game2] - checkMatch - :: Input.StandardOpeningOptions.MatchSwitches - -> Test.HUnit.Model.Game.Game - -> String - -> Test.HUnit.Component.Move.Move - -> Test.HUnit.Test - checkMatch tryToMatchSwitches game s expectedMove = map ( - Component.QualifiedMove.getMove . fst {-qualifiedMove-} - ) ( - ContextualNotation.PositionHashQualifiedMoveTree.findNextOnymousQualifiedMoves tryToMatchSwitches ( - mkGame s - ) . ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest False {-incrementalEvaluation-} ( - 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") - ] game - ] - ) ~?= [expectedMove] + finalMove1, finalMove2 :: Component.Move.Move + finalMove1 = last moves1 + finalMove2 = last moves2 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 @@ -38,7 +38,6 @@ import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Property.Empty as Property.Empty -import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.Exception import qualified Data.Default @@ -47,10 +46,12 @@ #ifdef USE_POLYPARSE import Test.HUnit((~?=)) -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -# else /* Plain */ +# elif USE_POLYPARSE == 'P' import qualified Text.ParserCombinators.Poly.Plain as Poly +# else +# error "USE_POLYPARSE invalid" # endif #else /* Parsec */ import Control.Arrow((|||)) @@ -66,17 +67,19 @@ in #ifdef USE_POLYPARSE fst (Poly.runParser parser san) ~?= -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' standardAlgebraic -# else /* Plain */ +# elif USE_POLYPARSE == 'P' Right standardAlgebraic +# else +# error "USE_POLYPARSE invalid" # endif #else /* Parsec */ (\parseError -> False ~? show parseError) ||| (~?= standardAlgebraic) $ Text.ParserCombinators.Parsec.parse parser "SAN-parser" san #endif ) $ map ( \s -> let - game :: Test.HUnit.Model.Game.Game + game :: Model.Game.Game game = Data.Default.def in case Notation.MoveNotation.readsQualifiedMove Data.Default.def s of [(eitherQualifiedMove, "")] -> 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 @@ -40,7 +40,6 @@ import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game -import qualified BishBosh.Test.HUnit.State.Board as Test.HUnit.State.Board import qualified BishBosh.Text.ShowList as Text.ShowList import qualified Control.Exception import qualified Data.Default @@ -53,7 +52,7 @@ "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving King." ~: case Notation.MoveNotation.readsQualifiedMove Data.Default.def "e1e3" {-move King (illegally)-} of [(eitherQualifiedMove, "")] -> Evaluation.Fitness.measureValueOfCastlingPotential ( Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( - Data.Default.def :: Test.HUnit.Model.Game.Game + Data.Default.def :: Model.Game.Game ) ) ~?= negate 1 _ -> Control.Exception.throw $ Data.Exception.mkParseFailure "BishBosh.Test.HUnit.Evaluation.Fitness.testCases:\tfailed to parse move.", @@ -65,13 +64,13 @@ ) sourceCoordinates -- Construct two White moves. ) Data.Default.def {-moveType-} ) ( - Data.Default.def :: Test.HUnit.State.Board.Board + Data.Default.def :: State.Board.Board ) $ Cartesian.Coordinates.rooksStartingCoordinates Attribute.LogicalColour.White ) ~?= 1, "'BishBosh.Evaluation.Fitness.measureValueOfCastlingPotential' failed after moving White Queen's Rook." ~: case Notation.MoveNotation.readsQualifiedMove Data.Default.def "a1a3" {-move Queen's Rook (illegally)-} of [(eitherQualifiedMove, "")] -> Evaluation.Fitness.measureValueOfCastlingPotential ( Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( - Data.Default.def :: Test.HUnit.Model.Game.Game + Data.Default.def :: Model.Game.Game ) ) ~?= negate ( fromRational $ recip 2 -- Moving Queen's Rook still permits castling on the King's side. @@ -80,7 +79,7 @@ "'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 [(eitherQualifiedMove, "")] -> Evaluation.Fitness.measureValueOfCastlingPotential ( Model.Game.applyEitherQualifiedMove eitherQualifiedMove ( - Data.Default.def :: Test.HUnit.Model.Game.Game + Data.Default.def :: Model.Game.Game ) ) ~?= fromRational ( recip 2 -- Taking Queen's Rook still permits castling on the King's side. @@ -98,27 +97,27 @@ ], "'BishBosh.Evaluation.Fitness.measureValueOfDoubledPawns' failed." ~: Evaluation.Fitness.measureValueOfDoubledPawns ( Model.Game.fromBoard ( - read "4k3/p6p/8/3PP3/3PP3/3PP3/3PP3/4K3" :: Test.HUnit.State.Board.Board + read "4k3/p6p/8/3PP3/3PP3/3PP3/3PP3/4K3" :: State.Board.Board ) ) ~?= 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 + read "4k3/pppppppp/8/8/P1P1P1P1/8/P1P1P1P1/4K3" :: State.Board.Board ) ) ~?= 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 + read "4k3/pppppppp/8/2P2P2/2P2P2/2P2P2/2P2P2/4K3" :: State.Board.Board ) ) ~?= 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 + read "4k3/8/8/8/8/8/pppppppp/4K3" :: State.Board.Board ) ) ~?= 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 + read "8/PPPPPPPP/8/8/8/8/8/k3K3" :: State.Board.Board ) ) ~?= 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 ( @@ -129,7 +128,7 @@ not . uncurry (||) . (Component.Piece.isBlack &&& Component.Piece.isKing) ) . State.Board.getCoordinatesByRankByLogicalColour ) ( - Data.Default.def :: Test.HUnit.State.Board.Board + Data.Default.def :: State.Board.Board ) ) ~?= fromRational ( 19 / fromIntegral {-NPieces-} Evaluation.Fitness.maximumDefended @@ -137,7 +136,7 @@ "'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 + Data.Default.def :: Model.Game.Game ) ) ~?= fromRational ( recip $ fromIntegral {-NPieces-} Evaluation.Fitness.maximumDefended @@ -155,7 +154,7 @@ ], "'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 + read "k7/8/2p5/8/4RQQB/4QQQN/4NQQK/4BQQR" :: 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 @@ -31,7 +31,6 @@ import Control.Category((>>>)) import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Input.Options as Input.Options -import qualified BishBosh.Type.Length as Type.Length import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Data.List @@ -82,7 +81,7 @@ (== Just (head optionsList)) ( (HXT.unpickleDoc HXT.xpickle . HXT.pickleDoc HXT.xpickle) =<< Data.Maybe.listToMaybe ( optionsList :: [ - Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y + Input.Options.Options Type.Mass.PieceSquareValue ] ) ) @? "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 @@ -23,9 +23,6 @@ -} module BishBosh.Test.HUnit.Model.Game( --- * Types --- ** Type-synonyms - Game, -- * Constants testCases, -- * Functions @@ -48,32 +45,27 @@ 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.Type.Length as Type.Length import qualified Control.Exception import qualified Data.Default import qualified Data.Maybe import qualified Test.HUnit import Test.HUnit((~?), (~:), (~?=)) --- | Defines a concrete type for testing. -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 +applyMoves :: [String] -> Either (String, String) Model.Game.Game applyMoves = Model.Game.applyEitherQualifiedMoves ( \s -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def {-Smith-} s of [(eitherQualifiedMove, "")] -> Right eitherQualifiedMove _ -> Left . shows s . showString " /~ " $ Notation.MoveNotation.showsMoveSyntax Data.Default.def "" ) ( - Data.Default.def :: Game + Data.Default.def :: Model.Game.Game ) -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test [ - "'BishBosh.Model.Game.showFEN' failed" ~: Property.ForsythEdwards.showFEN (Data.Default.def :: Game) ~?= "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1", + "'BishBosh.Model.Game.showFEN' failed" ~: Property.ForsythEdwards.showFEN (Data.Default.def :: Model.Game.Game) ~?= "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1", "'BishBosh.Model.Game.showFEN' failed" ~: either ( \(moveString, s) -> Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Test.HUnit.Model.Game.testCases:\t" . showString moveString . showString "; " $ showString s "." ) Property.ForsythEdwards.showFEN ( @@ -91,7 +83,7 @@ ) ~?= "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2", all ( ( - $ (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "r3k2r/8/8/8/8/8/8/R3K2R" :: Game) + $ (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "r3k2r/8/8/8/8/8/8/R3K2R" :: Model.Game.Game) ) . ( \s -> case Notation.MoveNotation.readsQualifiedMove Data.Default.def s of [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove @@ -102,7 +94,7 @@ "e1c1C" ] ~? "'BishBosh.Model.Game.isValidEitherQualifiedMove' failed when castling.", "'BishBosh.Model.Game.findQualifiedMovesAvailableToNextPlayer' failed" ~: Model.Game.findQualifiedMovesAvailableToNextPlayer ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "8/3K4/4q3/3bb3/8/8/8/4k3" :: Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "8/3K4/4q3/3bb3/8/8/8/4k3" :: Model.Game.Game ) ~?= [ Component.QualifiedMove.mkQualifiedMove ( Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 6)) `Component.Move.mkMove` Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 7)) @@ -114,14 +106,14 @@ Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** succ) `Component.Move.mkMove` Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 2)) ) $ Attribute.MoveType.mkNormalMoveType (Just Attribute.Rank.Pawn) Nothing ) ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/8/8/8/1b6/3p4/3R4/4K3" :: Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/8/8/8/1b6/3p4/3R4/4K3" :: Model.Game.Game ) ) ~? "'BishBosh.Model.Game.isValidQualifiedMove' failed", let - pawnsCoordinates :: Test.HUnit.Cartesian.Coordinates.Coordinates + pawnsCoordinates :: Cartesian.Coordinates.Coordinates pawnsCoordinates = Cartesian.Coordinates.translateY pred maxBound - game :: Game + game :: Model.Game.Game game = Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/7P/8/8/8/8/8/4K3" in Model.Game.getBoard ( fst {-game-} . head . Model.Game.rollBack $ Model.Game.applyQualifiedMove ( @@ -131,7 +123,7 @@ ) game ) == Model.Game.getBoard game ~? "'BishBosh.Model.Game.rollback' failed to undo a Pawn-promotion", let - game :: Game + game :: Model.Game.Game game = Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "4k3/8/8/8/8/8/8/R3K2R" in all ( ( @@ -172,12 +164,12 @@ ], Data.Maybe.maybe False Rule.GameTerminationReason.isStaleMate ( Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "rnbqk2r/pppppp2/8/8/8/7p/6np/6bK" :: Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "rnbqk2r/pppppp2/8/8/8/7p/6np/6bK" :: Model.Game.Game ) ) ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Stale-mate\".", all ( \s -> Data.Maybe.maybe False Rule.GameTerminationReason.isDrawByInsufficientMaterial $ Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Model.Game.Game ) ) [ "2k5/8/1KB5/3B4/8/8/8/8", @@ -186,7 +178,7 @@ ] ~? "'BishBosh.Model.Game.getMaybeTerminationReason' failed to detect \"Draw by Insufficient Material\".", all ( \s -> Data.Maybe.maybe True (not . Rule.GameTerminationReason.isDrawByInsufficientMaterial) $ Model.Game.getMaybeTerminationReason ( - Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Game + Model.Game.fromBoard $ Property.ForsythEdwards.readFEN s :: Model.Game.Game ) ) [ "k7/8/K7/8/8/8/8/1Q6", @@ -267,7 +259,7 @@ longCastle = "e1c1C" in case Notation.MoveNotation.readsQualifiedMove Data.Default.def longCastle of [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove ( - Property.ForsythEdwards.readFEN "r2qkbnr/ppp1pppp/2np4/5b2/3P4/NQP5/PP1BPPPP/R3KBNR w KQkq - 5 6" :: Game + Property.ForsythEdwards.readFEN "r2qkbnr/ppp1pppp/2np4/5b2/3P4/NQP5/PP1BPPPP/R3KBNR w KQkq - 5 6" :: Model.Game.Game ) ~? "long Castle through legal check failed." _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse " $ shows longCastle ".", let @@ -288,7 +280,7 @@ \epd -> ( epd, case Property.ExtendedPositionDescription.readsEPD epd of - [(game, "")] -> Property.ExtendedPositionDescription.showEPD (game :: Game) + [(game, "")] -> Property.ExtendedPositionDescription.showEPD (game :: Model.Game.Game) [(_, remainder)] -> Control.Exception.throw . Data.Exception.mkRedundantData . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tparsed EPD=" . shows epd . showString ", but leaving " $ shows remainder " unparsed." _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse EPD=" $ shows epd "." ) -- Pair. @@ -297,7 +289,7 @@ let terminalMoves = map (Notation.Smith.getQualifiedMove . read) ["d6d8", "e7c7", "d6b6"] in all ( - `elem` Model.Game.findQualifiedMovesAvailableTo minBound (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "K7/4q1p1/3r4/8/8/5k2/8/8 b - - 13 49" :: Game) + `elem` Model.Game.findQualifiedMovesAvailableTo minBound (Model.Game.fromBoard $ Property.ForsythEdwards.readFEN "K7/4q1p1/3r4/8/8/5k2/8/8 b - - 13 49" :: Model.Game.Game) ) terminalMoves ~? "BishBosh.Test.HUnit.Model.Game.testCases:\tterminal move unavailable." ] diff --git a/src-test/BishBosh/Test/HUnit/Model/GameTree.hs b/src-test/BishBosh/Test/HUnit/Model/GameTree.hs --- a/src-test/BishBosh/Test/HUnit/Model/GameTree.hs +++ b/src-test/BishBosh/Test/HUnit/Model/GameTree.hs @@ -38,7 +38,6 @@ 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.Type.Length as Type.Length import qualified Data.Default import qualified Data.Maybe import qualified Data.Tree @@ -57,22 +56,17 @@ ) 0 [1 .. searchDepth] ) [1 .. 4], "'BishBosh.Model.GameTree.sortGameTree/MVVLVA' failed" ~: map ( - \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn Type.Length.X Type.Length.Y) + \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn) ) ( sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.MVVLVA) testString ) ~?= ["c4d5p","e4d5p","c3d5p","d1d5p","a1b1","c1b2","c1a3","c1d2","c1e3","c1f4","c1g5","c1h6","d1d2","d1d3","d1d4","d1e2","e1d2","e1e2","e1f1","g1e2","g1h3","a2a3","a2a4","g2g3","g2g4","h2h3","h2h4","b3b4","c3b1","c3b5","c3a4","c3e2","f3e2","f3g4","f3h5","c4c5","e4e5"], "'BishBosh.Model.GameTree.sortGameTree/SEE' failed" ~: map ( - \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn Type.Length.X Type.Length.Y) + \turn -> Notation.MoveNotation.showNotation Data.Default.def (turn :: Component.Turn.Turn) ) ( sortAvailableMoves (Just Attribute.CaptureMoveSortAlgorithm.SEE) testString ) ~?= ["c4d5p","e4d5p","a1b1","c1b2","c1a3","c1d2","c1e3","c1f4","c1g5","c1h6","d1d2","d1d3","d1d4","d1d5p","d1e2","e1d2","e1e2","e1f1","g1e2","g1h3","a2a3","a2a4","g2g3","g2g4","h2h3","h2h4","b3b4","c3b1","c3b5","c3a4","c3e2","c3d5p","f3e2","f3g4","f3h5","c4c5","e4e5"] ] where - sortAvailableMoves :: ( - Integral x, - Integral y, - Show x, - Show y - ) => Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> String -> [Component.Turn.Turn x y] + sortAvailableMoves :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> String -> [Component.Turn.Turn] sortAvailableMoves maybeSortAlgorithm = Data.Maybe.mapMaybe ( Model.Game.maybeLastTurn . Data.Tree.rootLabel ) . Data.Tree.subForest . Model.GameTree.deconstruct . Model.GameTree.sortGameTree maybeSortAlgorithm ( 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP#-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -42,7 +43,6 @@ import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Length as Type.Length import qualified BishBosh.Type.Mass as Type.Mass import qualified Control.Exception import qualified Control.Monad.Reader @@ -52,14 +52,10 @@ import Test.HUnit((~?)) -- | Constant. -evaluationOptions :: ( - Fractional pieceSquareValue, - Integral x, - Integral y - ) => Input.EvaluationOptions.EvaluationOptions pieceSquareValue x y +evaluationOptions :: Fractional pieceSquareValue => Input.EvaluationOptions.EvaluationOptions pieceSquareValue evaluationOptions = Input.EvaluationOptions.mkEvaluationOptions Data.Default.def {-rankValues-} Data.Default.def { - Input.CriteriaWeights.getWeightOfMobility = 24 / 1000, - Input.CriteriaWeights.getWeightOfCastlingPotential = 5 / 1000 + Input.CriteriaWeights.getWeightOfMobility = fromRational $ 24 / 1000, + Input.CriteriaWeights.getWeightOfCastlingPotential = fromRational $ 5 / 1000 } False {-IncrementalEvaluation-} Nothing {-Maybe PieceSquareTable-} -- | Constant. @@ -73,50 +69,61 @@ -- | Check the sanity of the implementation, by validating a list of static test-cases. testCases :: Test.HUnit.Test testCases = Test.HUnit.test $ map ( - \(searchDepth, epd, moveOptions) -> case Property.ExtendedPositionDescription.readsEPD epd of + \(searchDepth, epd, match, moveOptions) -> case Property.ExtendedPositionDescription.readsEPD epd of [(game, "")] -> let turnString = Notation.MoveNotation.showNotation Data.Default.def {-Smith-} $ case Search.Search.getQuantifiedGames $ Control.Monad.Reader.runReader ( Search.Search.search searchDepth $ Search.SearchState.initialise ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree ( - evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue 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 + evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue + ) searchOptions Data.Default.def {-Zobrist-} Property.Empty.empty {-MoveFrequency-} game :: Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree Type.Crypto.PositionHash ) ) searchOptions of quantifiedGame : _ -> Evaluation.QuantifiedGame.getLastTurn quantifiedGame _ -> Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Test.HUnit.Search.Search.testCases:\tfailed." moveStrings = words moveOptions - in elem turnString moveStrings ~? showString "Bratko-Kopec:\t" ( - shows turnString . showString " !~ /" $ showString (Data.List.intercalate "|" moveStrings) "/." + in ( + if match + then elem + else notElem + ) turnString moveStrings ~? ( + shows turnString . showChar ' ' . showString ( + if match + then "!~" + else "=~" + ) . showString " /" $ showString (Data.List.intercalate "|" moveStrings) "/." ) _ -> Control.Exception.throw $ Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Search.Search.testCases:\tfailed to parse " $ shows epd "." ) [ --- EPD Accepted move-options Observed move, at various search-depths. --- 4 5 - (4, "1k1r4/pp1b1R2/3q2pp/4p3/2B5/4Q3/PPP2B2/2K5 w - -", "e3a7p"), - (4, "3r1k2/4npp1/1ppr3p/p6P/P2PPPP1/1NR5/5K2/2R5 w - -", "d4d5"), -- f2g2 e4e5. - (4, "2q1rr1k/3bbnnp/p2p1pp1/2pPp3/PpP1P1P1/1P2BNNP/2BQ1PRK/7R b - -", "f6f5"), -- c8b7 d7g4p. - (4, "rnbqkb1r/p3pppp/1p6/2ppP3/3N4/2P5/PPP1QPPP/R1B1KB1R w KQkq -", "e5e6"), -- d4b3 c1g5. - (4, "r1b2rk1/2q1b1pp/p2ppn2/1p6/3QP3/1BN1B3/PPP3PP/R4RK1 w - -", "c3d5 a3a4"), -- e3g5 d4b6. - (4, "2r3k1/pppR1pp1/4p3/4P1P1/5P2/1P4K1/P1P5/8 w - -", "g5g6"), -- g3f2 g3f2. - (4, "1nk1r1r1/pp2n1pp/4p3/q2pPp1N/b1pP1P2/B1P2R2/2P1B1PP/R2Q2K1 w - -", "h5f6"), -- a3d6 a3e7n. - (4, "4b3/p3kp2/6p1/3pP2p/2pP1P2/4K1P1/P3N2P/8 w - -", "f4f5"), -- e2c3 e2c3. - (4, "2kr1bnr/pbpq4/2n1pp2/3p3p/3P1P1B/2N2N1Q/PPP3PP/2KR1B1R w - -", "f4f5"), -- f1b5. - (4, "3rr1k1/pp3pp1/1qn2np1/8/3p4/PP1R1P2/2P1NQPP/R1B3K1 b - -", "c6e5"), - (4, "2r1nrk1/p2q1ppp/bp1p4/n1pPp3/P1P1P3/2PBB1N1/4QPPP/R4RK1 w - -", "f3f4"), -- f1e1. - (4, "r3r1k1/ppqb1ppp/8/4p1NQ/8/2P5/PP3PPP/R3R1K1 b - -", "d7f5"), - (4, "r2q1rk1/4bppp/p2p4/2pP4/3pP3/3Q4/PP1B1PPP/R3R1K1 w - -", "b2b4"), - (4, "rnb2r1k/pp2p2p/2pp2p1/q2P1p2/8/1Pb2NP1/PB2PPBP/R2Q1RK1 w - -", "d1d2 d1e1"), - (4, "2r3k1/1p2q1pp/2b1pr2/p1pp4/6Q1/1P1PP1R1/P1PN2PP/5RK1 w - -", "g4g7p"), -- g4h3. - (4, "r1bqkb1r/4npp1/p1p4p/1p1pP1B1/8/1B6/PPPN1PPP/R2Q1RK1 w kq -", "d2e4"), -- g5h4. - (4, "r2q1rk1/1ppnbppp/p2p1nb1/3Pp3/2P1P1P1/2N2N1P/PPB1QP2/R1B2RK1 b - -", "h7h5"), -- f6e8. - (4, "r1bq1rk1/pp2ppbp/2np2p1/2n5/P3PP2/N1P2N2/1PB3PP/R1B1QRK1 b - -", "c5b3"), -- c8g4. - (4, "3rr3/2pq2pk/p2p1pnp/8/2QBPP2/1P6/P5PP/4RRK1 b - -", "e8e4p"), -- d6d5. - (4, "r4k2/pb2bp1r/1p1qp2p/3pNp2/3P1P2/2N3P1/PPP1Q2P/2KRR3 w - -", "g3g4"), -- c3b5. - (4, "3rn2k/ppb2rpp/2ppqp2/5N2/2P1P3/1P5Q/PB3PPP/3RR1K1 w - -", "f5h6"), -- f5h4. - (4, "2r2rk1/1bqnbpp1/1p1ppn1p/pP6/N1P1P3/P2B1N1P/1B2QPP1/R2R2K1 b - -", "b7e4p"), -- d7e5. - (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. +-- EPD Match Move-options Observed move, at various search-depths. +-- 4 5 +#ifdef USE_BRATKO_KOPEC + (4, "1k1r4/pp1b1R2/3q2pp/4p3/2B5/4Q3/PPP2B2/2K5 w - -", True, "e3a7p"), + (4, "3r1k2/4npp1/1ppr3p/p6P/P2PPPP1/1NR5/5K2/2R5 w - -", True, "d4d5"), -- f2g2 e4e5. + (4, "2q1rr1k/3bbnnp/p2p1pp1/2pPp3/PpP1P1P1/1P2BNNP/2BQ1PRK/7R b - -", True, "f6f5"), -- c8b7 d7g4p. + (4, "rnbqkb1r/p3pppp/1p6/2ppP3/3N4/2P5/PPP1QPPP/R1B1KB1R w KQkq -", True, "e5e6"), -- d4b3 c1g5. + (4, "r1b2rk1/2q1b1pp/p2ppn2/1p6/3QP3/1BN1B3/PPP3PP/R4RK1 w - -", True, "c3d5 a3a4"), -- e3g5 d4b6. + (4, "2r3k1/pppR1pp1/4p3/4P1P1/5P2/1P4K1/P1P5/8 w - -", True, "g5g6"), -- g3f2 g3f2. + (4, "1nk1r1r1/pp2n1pp/4p3/q2pPp1N/b1pP1P2/B1P2R2/2P1B1PP/R2Q2K1 w - -", True, "h5f6"), -- a3d6 a3e7n. + (4, "4b3/p3kp2/6p1/3pP2p/2pP1P2/4K1P1/P3N2P/8 w - -", True, "f4f5"), -- e2c3 e2c3. + (4, "2kr1bnr/pbpq4/2n1pp2/3p3p/3P1P1B/2N2N1Q/PPP3PP/2KR1B1R w - -", True, "f4f5"), -- f1b5. + (4, "3rr1k1/pp3pp1/1qn2np1/8/3p4/PP1R1P2/2P1NQPP/R1B3K1 b - -", True, "c6e5"), + (4, "2r1nrk1/p2q1ppp/bp1p4/n1pPp3/P1P1P3/2PBB1N1/4QPPP/R4RK1 w - -", True, "f3f4"), -- f1e1. + (4, "r3r1k1/ppqb1ppp/8/4p1NQ/8/2P5/PP3PPP/R3R1K1 b - -", True, "d7f5"), + (4, "r2q1rk1/4bppp/p2p4/2pP4/3pP3/3Q4/PP1B1PPP/R3R1K1 w - -", True, "b2b4"), + (4, "rnb2r1k/pp2p2p/2pp2p1/q2P1p2/8/1Pb2NP1/PB2PPBP/R2Q1RK1 w - -", True, "d1d2 d1e1"), + (4, "2r3k1/1p2q1pp/2b1pr2/p1pp4/6Q1/1P1PP1R1/P1PN2PP/5RK1 w - -", True, "g4g7p"), -- g4h3. + (4, "r1bqkb1r/4npp1/p1p4p/1p1pP1B1/8/1B6/PPPN1PPP/R2Q1RK1 w kq -", True, "d2e4"), -- g5h4. + (4, "r2q1rk1/1ppnbppp/p2p1nb1/3Pp3/2P1P1P1/2N2N1P/PPB1QP2/R1B2RK1 b - -", True, "h7h5"), -- f6e8. + (4, "r1bq1rk1/pp2ppbp/2np2p1/2n5/P3PP2/N1P2N2/1PB3PP/R1B1QRK1 b - -", True, "c5b3"), -- c8g4. + (4, "3rr3/2pq2pk/p2p1pnp/8/2QBPP2/1P6/P5PP/4RRK1 b - -", True, "e8e4p"), -- d6d5. + (4, "r4k2/pb2bp1r/1p1qp2p/3pNp2/3P1P2/2N3P1/PPP1Q2P/2KRR3 w - -", True, "g3g4"), -- c3b5. + (4, "3rn2k/ppb2rpp/2ppqp2/5N2/2P1P3/1P5Q/PB3PPP/3RR1K1 w - -", True, "f5h6"), -- f5h4. + (4, "2r2rk1/1bqnbpp1/1p1ppn1p/pP6/N1P1P3/P2B1N1P/1B2QPP1/R2R2K1 b - -", True, "b7e4p"), -- d7e5. + (4, "r1bqk2r/pp2bppp/2p5/3pP3/P2Q1P2/2N1B3/1PP3PP/R4RK1 b kq -", True, "f7f6"), -- c8f5. + (4, "r2qnrnk/p2b2b1/1p1p2pp/2pPpp2/1PP1P3/PRNBB3/3QNPPP/5RK1 w - -", True, "f2f4"), -- e4f5p. +#endif + (4, "8/k6P/7R/8/8/8/8/1R5K w - -", False, "h7h8Q h7h8R") -- Experimental test of Stalemate-avoidance. ] 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 @@ -23,60 +23,50 @@ -} module BishBosh.Test.HUnit.State.Board( --- * Types --- ** Type-synonyms - Board, -- * Constants testCases ) 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.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Component.Piece as Component.Piece -import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour -import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates -import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator -import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified Control.Arrow import qualified Data.Array.IArray import qualified Data.Default import qualified Data.Foldable -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified Test.HUnit import qualified ToolShed.Data.Foldable import Test.HUnit((~:), (~?=), (~?)) --- | Defines a concrete type for testing. -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 testCases = Test.HUnit.test [ "'BishBosh.Cartesian.Coordinates' failed to locate the expected pieces on a default board." ~: ( map length . ToolShed.Data.Foldable.gather $ map ( `State.MaybePieceByCoordinates.dereference` Data.Default.def - ) (Property.FixedMembership.members :: [Test.HUnit.Cartesian.Coordinates.Coordinates]) + ) (Property.FixedMembership.members :: [Cartesian.Coordinates.Coordinates]) ) ~?= [32, 8, 2, 2, 2, 1, 1, 8, 2, 2, 2, 1, 1], let - kingsColour = Attribute.LogicalColour.Black + kingsColour = minBound destination = Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 3)) directionToCoordinates = last . (`Cartesian.Coordinates.extrapolate` destination) mkPiece = Component.Piece.mkPiece $ Property.Opposable.getOpposite kingsColour - - maybeShift :: Cartesian.Vector.VectorInt -> Maybe Test.HUnit.Cartesian.Coordinates.Coordinates - maybeShift = Cartesian.Vector.maybeTranslate destination + maybeShift = Cartesian.Vector.maybeTranslate destination in all ( State.Board.isKingChecked kingsColour . placePieces . (:) (Component.Piece.mkKing kingsColour, destination) . return {-to List-monad-} ) ( @@ -96,73 +86,92 @@ in map ((,) attacker . directionToCoordinates) $ Component.Piece.getAttackDirections attacker ] ) ~? "'BishBosh.State.Board.isKingChecked' failed.", - "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed, for passed Pawn adjacent to opposing Pawn of equal rank." ~: Data.Array.IArray.elems ( + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for adjacent Pawns." ~: Data.Foldable.toList ( Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates ) [ ( - Attribute.LogicalColour.Black, + minBound, id ), ( - Attribute.LogicalColour.White, + maxBound, Control.Arrow.first succ ) ] ) ~?= [1, 1], - "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for passed Pawns isolated from opposing Pawn." ~: Data.Array.IArray.elems ( + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for isolated Pawns." ~: Data.Foldable.toList ( Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates ) [ ( - Attribute.LogicalColour.Black, + minBound, Control.Arrow.second succ ), ( - Attribute.LogicalColour.White, + maxBound, Control.Arrow.first (+ 2) ) ] ) ~?= [1, 1], - "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn approaching opposing Pawn." ~: Data.Array.IArray.elems ( + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for doubled Pawns." ~: Data.Foldable.toList ( + Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( + Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates + ) $ map ((,) minBound) [ + (+ 4) *** (+ 3), + (+ 4) *** (+ 4) + ] ++ map ((,) maxBound) [ + (+ 5) *** (+ 4), + (+ 5) *** (+ 5) + ] + ) ~?= [2, 2], + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for asymmetric Pawns." ~: Data.Foldable.toList ( + Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( + Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates + ) $ (minBound, (+ 4) *** (+ 4)) : map ((,) maxBound) [ + (+ 5) *** (+ 4), + (+ 5) *** (+ 5) + ] + ) ~?= [1, 2], + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed diagonally adjacent Pawns." ~: Data.Foldable.toList ( Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates ) [ ( - Attribute.LogicalColour.White, + maxBound, id ), ( - Attribute.LogicalColour.Black, + minBound, succ *** succ ) ] ) ~?= [0, 0], - "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn sandwiched by opposing Pawns." ~: Data.Array.IArray.elems ( + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn sandwiched by opposing Pawns." ~: Data.Foldable.toList ( Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates ) [ ( - Attribute.LogicalColour.Black, + minBound, id ), ( - Attribute.LogicalColour.White, + maxBound, succ *** succ ), ( - Attribute.LogicalColour.Black, + minBound, (+ 2) *** (+ 2) ) ] ) ~?= [1, 0], - "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn between doubled opposing Pawns." ~: Data.Array.IArray.elems ( + "'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn between doubled opposing Pawns." ~: Data.Foldable.toList ( Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates ) [ ( - Attribute.LogicalColour.Black, + minBound, id ), ( - Attribute.LogicalColour.Black, + minBound, Control.Arrow.second (+ 2) ), ( - Attribute.LogicalColour.White, + maxBound, succ *** succ ) ] @@ -170,17 +179,17 @@ let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing Attribute.LogicalColour.White ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates + State.Board.exposesKing maxBound ( + Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates ) $ placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkPawn Attribute.LogicalColour.White, + Component.Piece.mkPawn maxBound, whitePawnsCoordinates ), ( - Component.Piece.mkPawn Attribute.LogicalColour.Black, + Component.Piece.mkPawn minBound, Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) ) ] @@ -188,17 +197,17 @@ let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing Attribute.LogicalColour.White ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates + State.Board.exposesKing maxBound ( + Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates ) $ placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkPawn Attribute.LogicalColour.White, + Component.Piece.mkPawn maxBound, whitePawnsCoordinates ), ( - Component.Piece.mkKing Attribute.LogicalColour.Black, + Component.Piece.mkKing minBound, Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) ) ] @@ -206,53 +215,53 @@ let whiteBishopsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ in not ( - State.Board.exposesKing Attribute.LogicalColour.White ( + State.Board.exposesKing maxBound ( Component.Move.mkMove whiteBishopsCoordinates $ Cartesian.Coordinates.translate (succ *** succ) whiteBishopsCoordinates -- Move towards Black Queen. ) $ placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkBishop Attribute.LogicalColour.White, + Component.Piece.mkBishop maxBound, whiteBishopsCoordinates ), ( - Component.Piece.mkQueen Attribute.LogicalColour.Black, + Component.Piece.mkQueen minBound, maxBound ) ] ) ~? "'BishBosh.State.Board.exposesKing false positive attack by black Queen, after moving White Bishop.", let whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ - in State.Board.exposesKing Attribute.LogicalColour.White ( - Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates -- Expose attack from Black Queen. + in State.Board.exposesKing maxBound ( + Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance maxBound whitePawnsCoordinates -- Expose attack from Black Queen. ) ( placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkPawn Attribute.LogicalColour.White, + Component.Piece.mkPawn maxBound, whitePawnsCoordinates ), ( - Component.Piece.mkQueen Attribute.LogicalColour.Black, + Component.Piece.mkQueen minBound, maxBound ) ] ) ~? "'BishBosh.State.Board.exposesKing failed after advancing White Pawn.", let whiteKnightsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ - in State.Board.exposesKing Attribute.LogicalColour.White ( + in State.Board.exposesKing maxBound ( Component.Move.mkMove whiteKnightsCoordinates . Cartesian.Coordinates.mkRelativeCoordinates $ (+ 3) *** (+ 2) -- Expose attack from Black Queen. ) ( placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkKnight Attribute.LogicalColour.White, + Component.Piece.mkKnight maxBound, whiteKnightsCoordinates ), ( - Component.Piece.mkQueen Attribute.LogicalColour.Black, + Component.Piece.mkQueen minBound, maxBound ) ] @@ -260,20 +269,20 @@ let whiteRooksCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2) in not ( - State.Board.exposesKing Attribute.LogicalColour.White ( - Component.Move.mkMove whiteRooksCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whiteRooksCoordinates -- Shift blocking-role to Pawn. + State.Board.exposesKing maxBound ( + Component.Move.mkMove whiteRooksCoordinates $ Cartesian.Coordinates.advance maxBound whiteRooksCoordinates -- Shift blocking-role to Pawn. ) $ placePieces [ ( - Component.Piece.mkKing Attribute.LogicalColour.White, + Component.Piece.mkKing maxBound, minBound ), ( - Component.Piece.mkPawn Attribute.LogicalColour.White, + Component.Piece.mkPawn maxBound, Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ ), ( - Component.Piece.mkRook Attribute.LogicalColour.White, + Component.Piece.mkRook maxBound, whiteRooksCoordinates ), ( - Component.Piece.mkQueen Attribute.LogicalColour.Black, + Component.Piece.mkQueen minBound, maxBound ) ] @@ -281,11 +290,13 @@ Data.Foldable.all ( Data.Foldable.all (== 1) ) ( - State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour $ State.Board.getCoordinatesByRankByLogicalColour (Data.Default.def :: Board) + StateProperty.Seeker.countPawnsByFileByLogicalColour $ State.Board.getCoordinatesByRankByLogicalColour (Data.Default.def :: State.Board.Board) ) ~? "'BishBosh.State.Board.countPawnsByFileByLogicalColour': failed for default board", ( - (== [(0, 3), (2, 2), (4, 1)]) . Data.Map.assocs . (! Attribute.LogicalColour.White) . State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( - (,) (Component.Piece.mkPawn Attribute.LogicalColour.White) . Cartesian.Coordinates.mkRelativeCoordinates + ( + == map (Control.Arrow.first (Cartesian.Abscissa.xMin +)) [(0, 3), (2, 2), (4, 1)] + ) . Map.toList . (! maxBound) . StateProperty.Seeker.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map ( + (,) (Component.Piece.mkPawn maxBound) . Cartesian.Coordinates.mkRelativeCoordinates ) [ Control.Arrow.second succ, Control.Arrow.second (+ 3), @@ -296,17 +307,17 @@ ] ) ~? "'BishBosh.State.Board.countPawnsByFileByLogicalColour': failed", ( - Data.Map.unions ( - Data.Array.IArray.elems $ State.Board.countDefendersByCoordinatesByLogicalColour (Data.Default.def :: Board) + Map.unions ( + Data.Foldable.toList $ State.Board.countDefendersByCoordinatesByLogicalColour (Data.Default.def :: State.Board.Board) ) == foldr ( - Data.Map.delete . Cartesian.Coordinates.kingsStartingCoordinates + Map.delete . Cartesian.Coordinates.kingsStartingCoordinates ) ( - Data.Map.fromList $ zip [ + Map.fromList $ zip [ Cartesian.Coordinates.mkCoordinates x y | y <- [ Cartesian.Ordinate.yMax, - Cartesian.Ordinate.pawnsFirstRank Attribute.LogicalColour.Black, - Cartesian.Ordinate.pawnsFirstRank Attribute.LogicalColour.White, + Cartesian.Ordinate.pawnsFirstRank minBound, + Cartesian.Ordinate.pawnsFirstRank maxBound, Cartesian.Ordinate.yMin ], x <- Cartesian.Abscissa.xRange @@ -319,6 +330,6 @@ ) Property.FixedMembership.members ) ~? "'BoshBosh.State.Board.countDefendersByCoordinatesByLogicalColour': failed" ] where - placePieces :: [(Component.Piece.Piece, Test.HUnit.Cartesian.Coordinates.Coordinates)] -> Board + placePieces :: [(Component.Piece.Piece, Cartesian.Coordinates.Coordinates)] -> State.Board.Board placePieces = StateProperty.Mutator.placeAllPieces diff --git a/src-test/BishBosh/Test/HUnit/Time/GameClock.hs b/src-test/BishBosh/Test/HUnit/Time/GameClock.hs --- a/src-test/BishBosh/Test/HUnit/Time/GameClock.hs +++ b/src-test/BishBosh/Test/HUnit/Time/GameClock.hs @@ -74,7 +74,7 @@ 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 = " ( + abs relativeError < recip 10000 @? showString "Time.GameClock.GameClock:\trelative error between sum of game-clock times & stop-watch time = " ( shows (realToFrac relativeError :: Double) "." ) ] where 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 @@ -61,6 +61,12 @@ f = Test.QuickCheck.label "MoveType.prop_isQuiet" . uncurry (==) . ( Attribute.MoveType.isQuiet &&& not . uncurry (||) . (Attribute.MoveType.isCapture &&& Attribute.MoveType.isPromotion) ) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64} f, + let + f :: Attribute.MoveType.MoveType -> Test.QuickCheck.Property + f = Test.QuickCheck.label "MoveType.prop_isSimple" . uncurry (==) . ( + Attribute.MoveType.isSimple &&& uncurry (&&) . (Attribute.MoveType.isQuiet &&& not . Attribute.MoveType.isCastle) + ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64} f ] diff --git a/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs b/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs --- a/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs +++ b/src-test/BishBosh/Test/QuickCheck/Cartesian/Coordinates.hs @@ -24,13 +24,8 @@ -} module BishBosh.Test.QuickCheck.Cartesian.Coordinates( --- * Types --- ** Type-synonyms - Coordinates, -- * Constants - results, --- * Functions - translate + results ) where import BishBosh.Test.QuickCheck.Attribute.Direction() @@ -42,7 +37,6 @@ import qualified BishBosh.Property.Orientated as Property.Orientated import qualified BishBosh.Property.Reflectable as Property.Reflectable import qualified BishBosh.Property.Rotatable as Property.Rotatable -import qualified BishBosh.Type.Length as Type.Length import qualified Data.Array.IArray import qualified Data.List import qualified Data.List.Extra @@ -51,82 +45,54 @@ import qualified ToolShed.Test.ReversibleIO import Test.QuickCheck((==>)) --- | Defines a concrete type for testing. -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 #-} +instance Test.QuickCheck.Arbitrary Cartesian.Coordinates.Coordinates where arbitrary = Test.QuickCheck.elements Property.FixedMembership.members --- | Re-cast the specified coordinates. -translate :: ( - Integral x, - Integral y, - Num p, - Num q - ) - => Cartesian.Coordinates.Coordinates x y - -> Cartesian.Coordinates.Coordinates p q -translate coordinates = coordinates { - Cartesian.Coordinates.getX = fromIntegral $ Cartesian.Coordinates.getX coordinates, - Cartesian.Coordinates.getY = fromIntegral $ Cartesian.Coordinates.getY coordinates -} - -- Check that one can interpolate between the coordinates. -isValidMove :: ( - Enum x, - Enum y, - Eq x, - Eq y - ) - => Cartesian.Coordinates.Coordinates x y - -> Cartesian.Coordinates.Coordinates x y - -> Bool -isValidMove source destination = source /= destination && Property.Orientated.isStraight ( - Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt - ) +isValidMove :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Bool +isValidMove source destination = source /= destination && Property.Orientated.isStraight (Cartesian.Vector.measureDistance source destination) -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_readPrependedWhiteSpace" . ToolShed.Test.ReversibleIO.readPrependedWhiteSpace in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let f :: String -> Test.QuickCheck.Property f garbage = Test.QuickCheck.label "Coordinates.prop_read" $ case ( - reads garbage :: [(Coordinates, String)] + reads garbage :: [(Cartesian.Coordinates.Coordinates, String)] ) of [_] -> True _ -> True -- Unless the read-implementation throws an exception. in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> String -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> String -> Test.QuickCheck.Property f coordinates = Test.QuickCheck.label "Coordinates.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) coordinates in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_ix" . ToolShed.Test.Ix.index in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f coordinates = Test.QuickCheck.label "Coordinates.prop_fromIx" $ Cartesian.Coordinates.fromIx (Data.Array.IArray.index (minBound, maxBound) coordinates) == coordinates in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_reflectOnY" . uncurry (==) . (id &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnY) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_rotate180" . uncurry (==) . (Property.Rotatable.rotate180 &&& Property.Rotatable.rotate180) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f coordinates = Test.QuickCheck.label "Coordinates.prop_rotateIdentity" $ all ((== coordinates) . ($ coordinates)) [ Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90 . Property.Rotatable.rotate90, Property.Rotatable.rotate180 . Property.Rotatable.rotate180, @@ -134,7 +100,7 @@ ] in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f coordinates = Test.QuickCheck.label "Coordinates.prop_rotate180/identity" . Data.List.Extra.allSame $ map ($ coordinates) [ Property.Rotatable.rotate180, Property.Rotatable.rotate90 . Property.Rotatable.rotate90, @@ -142,25 +108,7 @@ ] in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Coordinates -> Test.QuickCheck.Property - f source destination = isValidMove source destination ==> Test.QuickCheck.label "Coordinates.prop_interpolateInt" $ Cartesian.Coordinates.interpolate source destination == map translate ( - Cartesian.Coordinates.interpolate ( - translate source :: Cartesian.Coordinates.Coordinates Integer Integer -- Force use of unspecialised instance. - ) ( - translate destination - ) - ) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Attribute.Direction.Direction -> Coordinates -> Test.QuickCheck.Property - f direction source = Test.QuickCheck.label "Coordinates.prop_extrapolateInt" $ Cartesian.Coordinates.extrapolate direction source == map translate ( - Cartesian.Coordinates.extrapolate direction ( - translate source :: Cartesian.Coordinates.Coordinates Integer Integer -- Force use of unspecialised instance. - ) - ) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Attribute.Direction.Direction -> Coordinates -> Test.QuickCheck.Property + f :: Attribute.Direction.Direction -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f direction source = Test.QuickCheck.label "Coordinates.prop_extrapolate" . ( \extrapolation -> let destination @@ -172,13 +120,13 @@ ) $ Cartesian.Coordinates.extrapolate direction source in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Coordinates -> Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f source destination = isValidMove source destination ==> Test.QuickCheck.label "Coordinates.prop_interpolate" $ source : Cartesian.Coordinates.interpolate source destination == reverse ( destination : Cartesian.Coordinates.interpolate destination source ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: [Coordinates] -> Test.QuickCheck.Property + f :: [Cartesian.Coordinates.Coordinates] -> Test.QuickCheck.Property f = Test.QuickCheck.label "Coordinates.prop_areSquaresIsochromatic" . uncurry (==) . ( Cartesian.Coordinates.areSquaresIsochromatic &&& uncurry (||) . ( null &&& (== 1) . length . Data.List.nub . map Cartesian.Coordinates.getLogicalColourOfSquare 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -28,22 +29,25 @@ results ) where +import BishBosh.Test.QuickCheck.Cartesian.Coordinates() import Control.Arrow((&&&), (***)) -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Orientated as Property.Orientated -import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Orientated as Property.Orientated +import qualified BishBosh.Type.Length as Type.Length import qualified Test.QuickCheck import Test.QuickCheck((==>)) -instance (Num distance, Ord distance) => Test.QuickCheck.Arbitrary (Cartesian.Vector.Vector distance) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Cartesian.Vector.VectorInt #-} +#ifdef USE_NEWTYPE_WRAPPERS +import BishBosh.Test.QuickCheck.Type.Length() +#endif + +instance Test.QuickCheck.Arbitrary Cartesian.Vector.Vector where arbitrary = do - source <- Test.QuickCheck.arbitrary :: Test.QuickCheck.Gen Test.QuickCheck.Cartesian.Coordinates.Coordinates + source <- Test.QuickCheck.arbitrary :: Test.QuickCheck.Gen Cartesian.Coordinates.Coordinates destination <- Test.QuickCheck.suchThat Test.QuickCheck.arbitrary (/= source) return {-to Gen-monad-} $ Cartesian.Vector.measureDistance source destination @@ -52,46 +56,46 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Cartesian.Vector.VectorInt -> Test.QuickCheck.Property + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property f = Test.QuickCheck.label "Vector.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Cartesian.Vector.VectorInt -> Test.QuickCheck.Property + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property f = Test.QuickCheck.label "Vector.prop_orthogonal" . not . uncurry (&&) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Cartesian.Vector.VectorInt -> Test.QuickCheck.Property + f :: Cartesian.Vector.Vector -> Test.QuickCheck.Property f vector = not (Property.Orientated.isStraight vector) ==> Test.QuickCheck.label "Vector.prop_straight" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) vector in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: (Type.Length.Distance, Type.Length.Distance) -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f :: (Type.Length.X, Type.Length.Y) -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f (distanceX, distanceY) coordinates = Test.QuickCheck.label "Vector.prop_maybeTranslate" $ Cartesian.Coordinates.maybeTranslate (deltaX *** deltaY) coordinates == ( Cartesian.Coordinates.maybeTranslateX deltaX coordinates >>= Cartesian.Coordinates.maybeTranslateY deltaY ) where deltaX :: Type.Length.X -> Type.Length.X deltaX = ( - + fromIntegral ( + + ( (distanceX `mod` Cartesian.Abscissa.xLength) - (Cartesian.Abscissa.xLength `div` 2) ) - ) + ) -- Section. deltaY :: Type.Length.Y -> Type.Length.Y deltaY = ( - + fromIntegral ( + + ( (distanceY `mod` Cartesian.Ordinate.yLength) - (Cartesian.Ordinate.yLength `div` 2) ) - ) + ) -- Section. in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f source destination = Test.QuickCheck.label "Vector.prop_measureDistance => translate" $ Cartesian.Vector.translate source ( - Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt + Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.Vector ) == destination in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property f source destination = Test.QuickCheck.label "Vector.prop_translate" $ Cartesian.Vector.measureDistance source destination == Property.Opposable.getOpposite ( - Cartesian.Vector.measureDistance destination source :: Cartesian.Vector.VectorInt + Cartesian.Vector.measureDistance destination source :: Cartesian.Vector.Vector ) 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 @@ -24,78 +24,62 @@ -} module BishBosh.Test.QuickCheck.Component.Move( --- * Types --- ** Type-synonyms - Move, -- * Constants results ) where import BishBosh.Test.QuickCheck.Cartesian.Coordinates() import Control.Arrow((&&&)) -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector import qualified BishBosh.Component.Move as Component.Move 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.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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Eq x, - Eq y - ) => Test.QuickCheck.Arbitrary (Component.Move.Move x y) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Move #-} +instance Test.QuickCheck.Arbitrary Component.Move.Move where arbitrary = fmap (uncurry Component.Move.mkMove) . Test.QuickCheck.suchThat Test.QuickCheck.arbitrary $ uncurry (/=) -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property f = Test.QuickCheck.label "Move.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 "Move.prop_read" $ case (reads garbage :: [(Move, String)]) of + f garbage = Test.QuickCheck.label "Move.prop_read" $ case (reads garbage :: [(Component.Move.Move, 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 :: Move -> String -> Test.QuickCheck.Property + f :: Component.Move.Move -> String -> Test.QuickCheck.Property f move = Test.QuickCheck.label "Move.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) move in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property f = Test.QuickCheck.label "Move.prop_orthogonal" . not . uncurry (&&) . (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property f move = not (Property.Orientated.isStraight move) ==> Test.QuickCheck.label "Move.prop_straight" . not . uncurry (||) $ (Property.Orientated.isDiagonal &&& Property.Orientated.isParallel) move in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property f = Test.QuickCheck.label "Move.prop_getOpposite" . uncurry (==) . (Property.Opposable.getOpposite . Property.Opposable.getOpposite &&& id) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Move -> Test.QuickCheck.Property - f move = Test.QuickCheck.label "Move.prop_measureDistance" $ Component.Move.measureDistance (Property.Opposable.getOpposite move) == Property.Opposable.getOpposite ( - Component.Move.measureDistance move :: Cartesian.Vector.VectorInt - ) + f :: Component.Move.Move -> Test.QuickCheck.Property + f move = Test.QuickCheck.label "Move.prop_measureDistance" $ Component.Move.measureDistance (Property.Opposable.getOpposite move) == Property.Opposable.getOpposite (Component.Move.measureDistance move) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property f = Test.QuickCheck.label "Move.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, let - f :: Move -> Test.QuickCheck.Property + f :: Component.Move.Move -> Test.QuickCheck.Property 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/Piece.hs b/src-test/BishBosh/Test/QuickCheck/Component/Piece.hs --- a/src-test/BishBosh/Test/QuickCheck/Component/Piece.hs +++ b/src-test/BishBosh/Test/QuickCheck/Component/Piece.hs @@ -29,16 +29,12 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Component.Piece as Component.Piece -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.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Property.Opposable as Property.Opposable import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO -import Test.QuickCheck((==>)) instance Test.QuickCheck.Arbitrary Component.Piece.Piece where arbitrary = Test.QuickCheck.elements Property.FixedMembership.members @@ -69,14 +65,6 @@ f piece = Test.QuickCheck.label "Piece.prop_fen" $ case Property.ForsythEdwards.readsFEN $ Property.ForsythEdwards.showFEN piece of [(piece', "")] -> piece' == piece _ -> False - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, - let - f :: Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Component.Piece.Piece -> Test.QuickCheck.Property - f coordinates piece = Component.Piece.getRank piece `elem` Attribute.Rank.fixedAttackRange ==> Test.QuickCheck.label "Piece.prop_findAttackDestinationsInt" $ Component.Piece.findAttackDestinations coordinates piece == map Test.QuickCheck.Cartesian.Coordinates.translate ( - Component.Piece.findAttackDestinations ( - Test.QuickCheck.Cartesian.Coordinates.translate coordinates :: Cartesian.Coordinates.Coordinates Integer Integer -- Force use of unspecialised instance. - ) piece - ) - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } 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 @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Component.QualifiedMove( --- * Types --- ** Type-synonyms --- QualifiedMove, -- * Constants results ) where @@ -36,41 +33,31 @@ import Control.Arrow((&&&)) import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Property.Reflectable as Property.Reflectable -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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Eq x, - Eq y - ) => Test.QuickCheck.Arbitrary (Component.QualifiedMove.QualifiedMove x y) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary QualifiedMove #-} +instance Test.QuickCheck.Arbitrary Component.QualifiedMove.QualifiedMove where arbitrary = uncurry Component.QualifiedMove.mkQualifiedMove `fmap` Test.QuickCheck.arbitrary -- CAVEAT: the move & moveType are unlikely to be compatible. -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: QualifiedMove -> Test.QuickCheck.Property + f :: Component.QualifiedMove.QualifiedMove -> Test.QuickCheck.Property f = Test.QuickCheck.label "QualifiedMove.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 "QualifiedMove.prop_read" $ case (reads garbage :: [(QualifiedMove, String)]) of + f garbage = Test.QuickCheck.label "QualifiedMove.prop_read" $ case (reads garbage :: [(Component.QualifiedMove.QualifiedMove, 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 :: QualifiedMove -> String -> Test.QuickCheck.Property + f :: Component.QualifiedMove.QualifiedMove -> String -> Test.QuickCheck.Property f qualifiedMove = Test.QuickCheck.label "QualifiedMove.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) qualifiedMove in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: QualifiedMove -> Test.QuickCheck.Property + f :: Component.QualifiedMove.QualifiedMove -> Test.QuickCheck.Property 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 @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Component.Turn( --- * Types --- ** Type-synonyms - Turn, -- * Constants -- rankValues, results @@ -47,7 +44,6 @@ 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 @@ -55,15 +51,7 @@ import qualified ToolShed.Data.List import qualified ToolShed.Test.ReversibleIO --- | Defines a concrete type for testing. -type Turn = Component.Turn.Turn Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Component.Turn.Turn x y) where +instance Test.QuickCheck.Arbitrary Component.Turn.Turn where arbitrary = do moveType <- Test.QuickCheck.arbitrary (move, piece) <- case moveType of @@ -85,25 +73,25 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Turn -> Test.QuickCheck.Property + f :: Component.Turn.Turn -> Test.QuickCheck.Property f = Test.QuickCheck.label "Turn.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 "Turn.prop_read" $ case (reads garbage :: [(Turn, String)]) of + f garbage = Test.QuickCheck.label "Turn.prop_read" $ case (reads garbage :: [(Component.Turn.Turn, 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 :: Turn -> String -> Test.QuickCheck.Property + f :: Component.Turn.Turn -> String -> Test.QuickCheck.Property f turn = Test.QuickCheck.label "Turn.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) turn in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Turn -> Test.QuickCheck.Property + f :: Component.Turn.Turn -> Test.QuickCheck.Property 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 :: Input.RankValues.RankValues -> [Turn] -> Test.QuickCheck.Property + f :: Input.RankValues.RankValues -> [Component.Turn.Turn] -> Test.QuickCheck.Property f rankValues' = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/quiet" . uncurry (==) . ( dropWhile Component.Turn.isCapture . Data.List.sortBy ( Component.Turn.compareByMVVLVA (`Input.RankValues.findRankValue` rankValues') @@ -113,7 +101,7 @@ ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: [Turn] -> Test.QuickCheck.Property + f :: [Component.Turn.Turn] -> Test.QuickCheck.Property f = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/MVV" . ( \ranks -> Data.List.sortOn ( negate . toRational . (`Input.RankValues.findRankValue` rankValues) -- Most valuable victim should be first. @@ -125,7 +113,7 @@ ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: [Turn] -> Test.QuickCheck.Property + f :: [Component.Turn.Turn] -> Test.QuickCheck.Property f = Test.QuickCheck.label "Turn.prop_compareByMVVLVA/LVA" . all ( ( \ranks -> uncurry (++) ( 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 @@ -26,79 +26,23 @@ module BishBosh.Test.QuickCheck.Component.Zobrist( -- * Types -- ** Type-synonyms - Zobrist, --- * Constants, - results + Zobrist ) where -import Control.Arrow((&&&)) -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.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.Length as Type.Length -import qualified Data.Array.IArray +import qualified BishBosh.Component.Zobrist as Component.Zobrist +import qualified BishBosh.Type.Crypto as Type.Crypto import qualified Data.Bits -import qualified Data.List import qualified System.Random import qualified Test.QuickCheck -- | Defines a concrete type for testing. -type Zobrist = Component.Zobrist.Zobrist Type.Length.X Type.Length.Y Type.Crypto.PositionHash +type Zobrist = Component.Zobrist.Zobrist Type.Crypto.PositionHash -instance ( - Data.Array.IArray.Ix x, - Data.Bits.FiniteBits positionHash, - Enum x, - Enum y, - Ord y, - System.Random.Random positionHash - ) => Test.QuickCheck.Arbitrary (Component.Zobrist.Zobrist x y positionHash) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Zobrist #-} +instance (Data.Bits.FiniteBits positionHash, System.Random.Random positionHash) => Test.QuickCheck.Arbitrary (Component.Zobrist.Zobrist 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 'Crypto.PositionHash'. ) - ) Test.QuickCheck.arbitrary <*> fmap System.Random.mkStdGen Test.QuickCheck.arbitrary - --- | The constant test-results for this data-type. -results :: IO [Test.QuickCheck.Result] -results = sequence [ - let - f :: Zobrist -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property - f zobrist game = Test.QuickCheck.label "Zobrist.prop_hash2D(Game)/unique" . areUnique . map ( - (`Component.Zobrist.hash2D` zobrist) . (`Model.Game.applyQualifiedMove` game) - ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Zobrist -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property - f zobrist game = Test.QuickCheck.label "Zobrist.prop_hash2D(Position)/unique" . areUnique . map ( - (`Component.Zobrist.hash2D` zobrist) . Model.Game.mkPosition . (`Model.Game.applyQualifiedMove` game) - ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Zobrist -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property - f zobrist game = Test.QuickCheck.label "Zobrist.prop_(hash2D(Game) == hash2D(Position))" . all ( - uncurry (==) . ( - ( - `Component.Zobrist.hash2D` zobrist - ) &&& ( - `Component.Zobrist.hash2D` zobrist - ) . Model.Game.mkPosition - ) . (`Model.Game.applyQualifiedMove` game) - ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, - let - f :: Zobrist -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property - f zobrist game = Test.QuickCheck.label "Zobrist.prop_incrementalEvaluation" . all ( - ( - \game' -> Component.Zobrist.hash2D game' zobrist == Model.Game.updateIncrementalPositionHash game ( - Component.Zobrist.hash2D game zobrist - ) game' zobrist - ) . (`Model.Game.applyQualifiedMove` game) - ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f - ] where - areUnique :: Ord a => [a] -> Bool - areUnique = all ((== 1) . length) . Data.List.group . Data.List.sort + ) Test.QuickCheck.arbitrary {-MaybeMinimumHammingDistance-} <*> 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 @@ -25,9 +25,6 @@ -} module BishBosh.Test.QuickCheck.ContextualNotation.PGN( --- * Types --- ** Type-synonyms - PGN, -- * Constants -- ficsGamesDBGameNoTag, -- ecoCodeTag, @@ -37,23 +34,24 @@ ) where import BishBosh.Test.QuickCheck.ContextualNotation.PGNComment() +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.ContextualNotation.PGN as ContextualNotation.PGN import qualified BishBosh.ContextualNotation.PGNComment as ContextualNotation.PGNComment 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.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 */ +#elif USE_POLYPARSE == 'L' +import qualified Text.ParserCombinators.Poly.Lazy as Poly +#elif USE_POLYPARSE == 'P' import Control.Arrow((|||)) -import qualified Text.ParserCombinators.Poly.Plain as Poly +import qualified Text.ParserCombinators.Poly.Plain as Poly +#else +# error "USE_POLYPARSE invalid" #endif -- | Qualifies a value. @@ -73,18 +71,7 @@ return {-to Gen-monad-} [c, i, j] --- | Defines a concrete type for testing. -type PGN = ContextualNotation.PGN.PGN Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Test.QuickCheck.Arbitrary (ContextualNotation.PGN.PGN x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary PGN #-} +instance Test.QuickCheck.Arbitrary ContextualNotation.PGN.PGN where arbitrary = let arbitraryString :: Test.QuickCheck.Gen String arbitraryString = do @@ -124,13 +111,15 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> 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 == 'L' (Model.Game.listTurns game ==) . Model.Game.listTurns -# else /* Plain */ +# elif USE_POLYPARSE == 'P' (const False ||| (Model.Game.listTurns game ==) . Model.Game.listTurns) +# else +# error "USE_POLYPARSE invalid" # endif . fst {-discard unparsed text-} . Poly.runParser moveTextParser #else /* Parsec */ @@ -141,13 +130,15 @@ moveTextParser = ContextualNotation.PGN.moveTextParser isStrictlySequential validateMoves in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 128 } f, let - f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> PGN -> [ContextualNotation.PGNComment.PGNComment] -> Test.QuickCheck.Property + f :: Bool -> ContextualNotation.StandardAlgebraic.ValidateMoves -> ContextualNotation.PGN.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 == 'L' (== pgn) -# else /* Plain */ +# elif USE_POLYPARSE == 'P' (const False ||| (== pgn)) +# else +# error "USE_POLYPARSE invalid" # endif . fst {-discard unparsed text-} . Poly.runParser parser #else /* Parsec */ 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 @@ -35,11 +35,13 @@ #ifndef USE_POLYPARSE import Control.Arrow((|||)) import qualified Text.ParserCombinators.Parsec -#elif USE_POLYPARSE == 1 +#elif USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -#else /* Plain */ +#elif USE_POLYPARSE == 'P' import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly +#else +# error "USE_POLYPARSE invalid" #endif instance Test.QuickCheck.Arbitrary ContextualNotation.PGNComment.PGNComment where @@ -56,10 +58,12 @@ 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 == 'L' (== s) -# else /* Plain */ +# elif USE_POLYPARSE == 'P' (const False ||| (== s)) +# else +# error "USE_POLYPARSE invalid" # endif . fst {-discard unparsed text-} . Poly.runParser ContextualNotation.PGNComment.parser #else /* Parsec */ 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 @@ -24,27 +24,21 @@ -} module BishBosh.Test.QuickCheck.ContextualNotation.PositionHashQualifiedMoveTree( --- * Types --- ** Type-synonyms --- PositionHashQualifiedMoveTree, -- * Constants results ) where +import BishBosh.Test.QuickCheck.ContextualNotation.QualifiedMoveForest() import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.ContextualNotation.PositionHashQualifiedMoveTree as ContextualNotation.PositionHashQualifiedMoveTree import qualified BishBosh.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions -import qualified BishBosh.Input.StandardOpeningOptions as Input.StandardOpeningOptions import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTree as Model.GameTree 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.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 import qualified Data.Maybe @@ -53,28 +47,19 @@ import qualified Test.QuickCheck import Test.QuickCheck((==>)) --- | Defines a concrete type for testing. -type PositionHashQualifiedMoveTree = ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree 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 x, - Show y, System.Random.Random positionHash - ) => Test.QuickCheck.Arbitrary (ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree x y positionHash) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary PositionHashQualifiedMoveTree #-} + ) => Test.QuickCheck.Arbitrary (ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree positionHash) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary (ContextualNotation.PositionHashQualifiedMoveTree.PositionHashQualifiedMoveTree Type.Crypto.PositionHash) #-} arbitrary = ContextualNotation.PositionHashQualifiedMoveTree.fromQualifiedMoveForest <$> Test.QuickCheck.arbitrary {-IncrementalEvaluation-} <*> Test.QuickCheck.arbitrary {-Zobrist-} <*> Test.QuickCheck.arbitrary {-QualifiedMoveForest-} -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Input.EvaluationOptions.IncrementalEvaluation -> Input.StandardOpeningOptions.MatchSwitches -> Test.QuickCheck.Component.Zobrist.Zobrist -> Test.QuickCheck.ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> Test.QuickCheck.Property + f :: Input.EvaluationOptions.IncrementalEvaluation -> ContextualNotation.PositionHashQualifiedMoveTree.MatchSwitches -> Test.QuickCheck.Component.Zobrist.Zobrist -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> Test.QuickCheck.Property f incrementalEvaluation tryToMatchSwitches zobrist qualifiedMoveForest = not (Property.Null.isNull qualifiedMoveForest) ==> Test.QuickCheck.label "PositionHashQualifiedMoveTree.prop_findNextOnymousQualifiedMoves" $ all ( ( \(previousGame, lastTurn) -> Data.Maybe.isJust . Data.List.find ( 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 @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.ContextualNotation.QualifiedMoveForest( --- * Types --- ** Type-synonyms - QualifiedMoveForest, -- * Constants results ) where @@ -38,31 +35,19 @@ 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.Type.Length as Type.Length import qualified Data.Foldable import qualified Data.Tree import qualified Test.QuickCheck import Test.QuickCheck((==>)) -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Test.QuickCheck.Arbitrary (ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary QualifiedMoveForest #-} +instance Test.QuickCheck.Arbitrary ContextualNotation.QualifiedMoveForest.QualifiedMoveForest where arbitrary = fmap ContextualNotation.QualifiedMoveForest.fromPGNDatabase Test.QuickCheck.arbitrary --- | Defines a concrete type for testing. -type QualifiedMoveForest = ContextualNotation.QualifiedMoveForest.QualifiedMoveForest Type.Length.X Type.Length.Y - -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: QualifiedMoveForest -> Test.QuickCheck.Property + f :: ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> Test.QuickCheck.Property f = Test.QuickCheck.label "QualifiedMoveForest.prop_findMinimumPieces" . uncurry (==) . ( ContextualNotation.QualifiedMoveForest.findMinimumPieces &&& Data.Foldable.minimum . fmap ( State.Board.getNPieces . Model.Game.getBoard @@ -70,7 +55,7 @@ ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: QualifiedMoveForest -> Test.QuickCheck.Property + f :: ContextualNotation.QualifiedMoveForest.QualifiedMoveForest -> Test.QuickCheck.Property f qualifiedMoveForest = not (Property.Null.isNull qualifiedMoveForest) ==> Test.QuickCheck.label "QualifiedMoveForest.prop_count" . uncurry (==) $ ( snd {-nPositions-} . ContextualNotation.QualifiedMoveForest.count &&& fromIntegral . length . tail {-remove the apex-} . Data.Tree.flatten . Model.GameTree.deconstruct . ContextualNotation.QualifiedMoveForest.toGameTree ) qualifiedMoveForest 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 @@ -29,20 +29,22 @@ ) where import BishBosh.Test.QuickCheck.Attribute.Rank() +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Component.Turn as Component.Turn 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 Test.QuickCheck #ifdef USE_POLYPARSE import Control.Arrow((***)) -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' import qualified Text.ParserCombinators.Poly.Lazy as Poly -# else /* Plain */ +# elif USE_POLYPARSE == 'P' import Control.Arrow((|||)) import qualified Text.ParserCombinators.Poly.Plain as Poly +# else +# error "USE_POLYPARSE invalid" # endif #else /* Parsec */ import Control.Arrow((|||)) @@ -57,19 +59,21 @@ f rank = Test.QuickCheck.label "StandardAlgebraic.prop_san" $ ContextualNotation.StandardAlgebraic.toRank (ContextualNotation.StandardAlgebraic.fromRank rank) == rank in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Test.QuickCheck.Model.Game.Game -> ContextualNotation.StandardAlgebraic.ExplicitEnPassant -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Test.QuickCheck.Property + f :: Model.Game.Game -> ContextualNotation.StandardAlgebraic.ExplicitEnPassant -> ContextualNotation.StandardAlgebraic.ValidateMoves -> Test.QuickCheck.Property f game explicitEnPassant validateMoves = Test.QuickCheck.label "StandardAlgebraic.prop_sanParser" $ all ( \(game', turn) -> let qualifiedMove = Component.Turn.getQualifiedMove turn in #ifdef USE_POLYPARSE uncurry (&&) . ( -# if USE_POLYPARSE == 1 +# if USE_POLYPARSE == 'L' (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove *** null {-unparsed input-} -# else /* Plain */ +# elif USE_POLYPARSE == 'P' ( const False ||| (== qualifiedMove) . ContextualNotation.StandardAlgebraic.getQualifiedMove ) *** null {-unparsed input-} +# else +# error "USE_POLYPARSE invalid" # endif ) . Poly.runParser ( ContextualNotation.StandardAlgebraic.parser explicitEnPassant validateMoves game' 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 @@ -28,19 +28,16 @@ ) where import BishBosh.Test.QuickCheck.Input.SearchOptions() +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame --- import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.Model.Game as Model.Game --- import qualified BishBosh.Property.Arboreal as Property.Arboreal import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.State.Position as State.Position import qualified BishBosh.Test.QuickCheck.Component.Zobrist as Test.QuickCheck.Component.Zobrist import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions -import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game 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 @@ -51,36 +48,16 @@ -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ -{- let f :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Test.QuickCheck.Component.Zobrist.Zobrist - -> Test.QuickCheck.Model.Game.Game - -> Test.QuickCheck.Property - 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 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. - } searchOptions zobrist Property.Empty.empty {-MoveFrequency-} game - ) where - prune = Property.Arboreal.prune 3 - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4 } f, --} - let - f - :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions - -> Input.SearchOptions.SearchOptions - -> Test.QuickCheck.Component.Zobrist.Zobrist - -> Test.QuickCheck.Model.Game.Game + -> Model.Game.Game -> 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 Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> State.Position.Position Type.Length.X Type.Length.Y + Model.Game.mkPosition . Evaluation.QuantifiedGame.getGame . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel Type.Crypto.PositionHash -> State.Position.Position ) ) matches where matches = filter ( @@ -94,13 +71,13 @@ :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions -> Input.SearchOptions.SearchOptions -> Test.QuickCheck.Component.Zobrist.Zobrist - -> Test.QuickCheck.Model.Game.Game + -> Model.Game.Game -> Test.QuickCheck.Property 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 Type.Length.X Type.Length.Y Type.Crypto.PositionHash -> Type.Mass.WeightedMean + Evaluation.QuantifiedGame.getFitness . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame :: Evaluation.PositionHashQuantifiedGameTree.NodeLabel 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 + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } 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 @@ -31,47 +31,40 @@ results ) where -import BishBosh.Data.Bool() -import BishBosh.Test.QuickCheck.Attribute.Rank() import BishBosh.Test.QuickCheck.Input.CriteriaWeights() import BishBosh.Test.QuickCheck.Input.PieceSquareTable() import BishBosh.Test.QuickCheck.Input.RankValues() +import BishBosh.Test.QuickCheck.State.Board() import Control.Arrow((&&&)) -import qualified BishBosh.Component.PieceSquareByCoordinatesByRank as Component.PieceSquareByCoordinatesByRank -import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights -import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions -import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour -import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates -import qualified BishBosh.Test.QuickCheck.State.Board as Test.QuickCheck.State.Board -import qualified BishBosh.Type.Length as Type.Length -import qualified BishBosh.Type.Mass as Type.Mass +import qualified BishBosh.Component.Accountant as Component.Accountant +import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable +import qualified BishBosh.Input.RankValues as Input.RankValues +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.Type.Mass as Type.Mass import qualified Data.Array.IArray import qualified Data.List -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified Test.QuickCheck import Test.QuickCheck((==>)) -- | Defines a concrete type for testing. -type EvaluationOptions = Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y +type EvaluationOptions = Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue instance ( - 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 #-} + ) => Test.QuickCheck.Arbitrary (Input.EvaluationOptions.EvaluationOptions pieceSquareValue) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary EvaluationOptions #-} arbitrary = do - criteriaWeights <- Test.QuickCheck.arbitrary + rankValues <- Test.QuickCheck.arbitrary + criteriaWeights <- Test.QuickCheck.suchThat Test.QuickCheck.arbitrary $ \c -> Input.RankValues.calculateMaximumTotalValue rankValues /= 0 || Input.CriteriaWeights.getWeightOfMaterial c == 0 - Input.EvaluationOptions.mkEvaluationOptions <$> Test.QuickCheck.arbitrary {-RankValues-} <*> return {-to Gen-monad-} criteriaWeights <*> Test.QuickCheck.arbitrary {-incrementalEvaluation-} <*> if Input.CriteriaWeights.getWeightOfPieceSquareValue criteriaWeights == minBound + Input.EvaluationOptions.mkEvaluationOptions rankValues criteriaWeights <$> Test.QuickCheck.arbitrary {-incrementalEvaluation-} <*> if Input.CriteriaWeights.getWeightOfPieceSquareValue criteriaWeights == minBound then return {-to Gen-monad-} Nothing else do (pieceSquareTable, pieceSquareTable', ranks) <- Test.QuickCheck.arbitrary @@ -79,7 +72,7 @@ return {-to Gen-monad-} $ Just ( pieceSquareTable, pieceSquareTable' { - Input.PieceSquareTable.getPieceSquareValueByCoordinatesByRank = foldr Data.Map.delete (Input.PieceSquareTable.getPieceSquareValueByCoordinatesByRank pieceSquareTable') $ Data.List.nub ranks -- Delete arbitrary ranks from the end-game table. + Input.PieceSquareTable.getPieceSquareValueByCoordinatesByRank = foldr Map.delete (Input.PieceSquareTable.getPieceSquareValueByCoordinatesByRank pieceSquareTable') $ Data.List.nub ranks -- Delete arbitrary ranks from the end-game table. } ) -- Pair. @@ -87,7 +80,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: EvaluationOptions -> Test.QuickCheck.State.Board.Board -> Test.QuickCheck.Property + f :: EvaluationOptions -> State.Board.Board -> Test.QuickCheck.Property f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour/reflectOnX" . uncurry (==) $ ( Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour &&& reverse . Data.Array.IArray.elems . sumPieceSquareValueByLogicalColour . Property.Reflectable.reflectOnX ) board where @@ -95,13 +88,9 @@ 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 Rational {-precision is required-} Type.Length.X Type.Length.Y -> Test.QuickCheck.State.Board.Board -> Test.QuickCheck.Property + f :: Input.EvaluationOptions.EvaluationOptions Rational {-precision is required-} -> State.Board.Board -> Test.QuickCheck.Property f evaluationOptions board = Data.Maybe.isJust maybePieceSquareByCoordinatesByRank ==> Test.QuickCheck.label "EvaluationOptions.prop_sumPieceSquareValueByLogicalColour" . uncurry (==) $ ( - State.CoordinatesByRankByLogicalColour.sumPieceSquareValueByLogicalColour ( - \logicalColour rank coordinatesList -> Component.PieceSquareByCoordinatesByRank.findPieceSquareValues nPieces logicalColour rank coordinatesList pieceSquareByCoordinatesByRank - ) . State.Board.getCoordinatesByRankByLogicalColour &&& State.MaybePieceByCoordinates.sumPieceSquareValueByLogicalColour ( - \logicalColour rank coordinates -> Component.PieceSquareByCoordinatesByRank.findPieceSquareValue nPieces logicalColour rank coordinates pieceSquareByCoordinatesByRank - ) . State.Board.getMaybePieceByCoordinates + Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces . State.Board.getCoordinatesByRankByLogicalColour &&& Component.Accountant.sumPieceSquareValueByLogicalColour pieceSquareByCoordinatesByRank nPieces . State.Board.getMaybePieceByCoordinates ) board where maybePieceSquareByCoordinatesByRank = Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions pieceSquareByCoordinatesByRank = Data.Maybe.fromJust maybePieceSquareByCoordinatesByRank 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 @@ -33,7 +33,7 @@ instance Test.QuickCheck.Arbitrary Input.NativeUIOptions.NativeUIOptions where arbitrary = Input.NativeUIOptions.mkNativeUIOptions <$> fmap ( mkOddNaturalNumber *** mkOddNaturalNumber - ) Test.QuickCheck.arbitrary {-BoardMagnification-} <*> return {-to Gen-monad-} Data.Default.def {-ColourScheme-} where + ) Test.QuickCheck.arbitrary {-BoardMagnification-} <*> return {-to Gen-monad-} Data.Default.def {-ColourScheme-} <*> Test.QuickCheck.arbitrary {-DepictFigurine-} 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,7 +26,7 @@ module BishBosh.Test.QuickCheck.Input.Options( -- * Types -- ** Type-synonyms - Options, +-- Options, -- * Constants results ) where @@ -34,30 +34,33 @@ import BishBosh.Test.QuickCheck.Input.EvaluationOptions() import BishBosh.Test.QuickCheck.Input.IOOptions() import BishBosh.Test.QuickCheck.Input.SearchOptions() -import qualified BishBosh.Input.Options as Input.Options -import qualified BishBosh.Type.Length as Type.Length -import qualified BishBosh.Type.Mass as Type.Mass +import qualified BishBosh.Input.IOOptions as Input.IOOptions +import qualified BishBosh.Input.Options as Input.Options +import qualified BishBosh.Input.SearchOptions as Input.SearchOptions +import qualified BishBosh.Type.Mass as Type.Mass import qualified Test.QuickCheck -- | Defines a concrete type for testing. -type Options = Input.Options.Options Type.Mass.PieceSquareValue Type.Length.X Type.Length.Y +type Options = Input.Options.Options Type.Mass.PieceSquareValue instance ( - 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 #-} + ) => Test.QuickCheck.Arbitrary (Input.Options.Options pieceSquareValue) 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 (fromInteger . succ . abs) maybeMaximumPlies - ) maybeRandomSeed evaluationOptions searchOptions ioOptions + ) maybeRandomSeed evaluationOptions ( + if null $ Input.IOOptions.getPGNOptionsList ioOptions + then searchOptions { + Input.SearchOptions.getSortOnStandardOpeningMoveFrequency = False + } + else searchOptions + ) ioOptions -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] 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 @@ -26,36 +26,30 @@ module BishBosh.Test.QuickCheck.Input.PieceSquareTable( -- * Types -- ** Type-synonyms - PieceSquareTable, +-- PieceSquareTable, -- * Constants results ) where import BishBosh.Test.QuickCheck.Attribute.Rank() -import BishBosh.Test.QuickCheck.Component.Piece() import qualified BishBosh.Attribute.Rank as Attribute.Rank import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Input.PieceSquareTable as Input.PieceSquareTable import qualified BishBosh.Property.FixedMembership as Property.FixedMembership -import qualified BishBosh.Type.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 Type.Length.X Type.Length.Y Type.Mass.PieceSquareValue +type PieceSquareTable = Input.PieceSquareTable.PieceSquareTable Type.Mass.PieceSquareValue instance ( - Enum x, - Enum y, Fractional pieceSquareValue, Ord pieceSquareValue, - Ord x, - Ord y, Show pieceSquareValue - ) => Test.QuickCheck.Arbitrary (Input.PieceSquareTable.PieceSquareTable x y pieceSquareValue) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary PieceSquareTable #-} + ) => Test.QuickCheck.Arbitrary (Input.PieceSquareTable.PieceSquareTable pieceSquareValue) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary PieceSquareTable #-} arbitrary = do reflectOnY <- Test.QuickCheck.arbitrary @@ -68,7 +62,7 @@ if reflectOnY then (`div` 2) else id - ) Cartesian.Coordinates.nSquares + ) $ fromIntegral Cartesian.Coordinates.nSquares ) ) ) Property.FixedMembership.members 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 @@ -31,12 +31,12 @@ import Control.Arrow((***)) import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified Data.Foldable -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Test.QuickCheck instance Test.QuickCheck.Arbitrary Input.SearchOptions.SearchOptions where arbitrary = do - searchDepthByLogicalColour <- Data.Map.map ( + searchDepthByLogicalColour <- Map.map ( (+ Input.SearchOptions.minimumSearchDepth) . fromInteger . (`mod` 4) ) <$> Test.QuickCheck.arbitrary @@ -45,13 +45,13 @@ ) <*> ( fmap (fromInteger . (`mod` 4)) <$> Test.QuickCheck.arbitrary -- maybeRetireKillerMovesAfter. ) <*> Test.QuickCheck.arbitrary {-trapRepeatedPositions-} <*> ( - if Data.Map.size searchDepthByLogicalColour == 1 + if Data.Foldable.length searchDepthByLogicalColour == 1 then Test.QuickCheck.arbitrary else return {-to Gen-monad-} False -- UsePondering. ) <*> ( fmap ( fromInteger . (`mod` 3) *** ( - if Data.Map.null searchDepthByLogicalColour + if Data.Foldable.null searchDepthByLogicalColour then id else min $ Data.Foldable.maximum searchDepthByLogicalColour ) . fromInteger . succ . (`mod` 3) diff --git a/src-test/BishBosh/Test/QuickCheck/Input/StandardOpeningOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/StandardOpeningOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/StandardOpeningOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/StandardOpeningOptions.hs @@ -29,5 +29,5 @@ import qualified Test.QuickCheck instance Test.QuickCheck.Arbitrary Input.StandardOpeningOptions.StandardOpeningOptions where - arbitrary = Input.StandardOpeningOptions.mkStandardOpeningOptions <$> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary + arbitrary = Input.StandardOpeningOptions.mkStandardOpeningOptions <$> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary <*> Test.QuickCheck.arbitrary 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -24,43 +25,39 @@ -} module BishBosh.Test.QuickCheck.Model.Game( --- * Types --- ** Type-synonyms - Game, -- * Constants results ) where -import BishBosh.Test.QuickCheck.State.Board() import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.MoveType as Attribute.MoveType -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -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.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.Type.Count as Type.Count -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove +import qualified BishBosh.Component.Turn as Component.Turn +import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness +import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.Rule.DrawReason as Rule.DrawReason +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour +import qualified BishBosh.Test.QuickCheck.Input.EvaluationOptions as Test.QuickCheck.Input.EvaluationOptions +import qualified BishBosh.Type.Count as Type.Count import qualified Data.Array.IArray import qualified Data.Default import qualified Data.Foldable import qualified Data.List -import qualified Data.Map +import qualified Data.Map as Map import qualified Data.Maybe import qualified Data.Ord import qualified System.Random @@ -70,18 +67,7 @@ import qualified ToolShed.Test.ReversibleIO import Test.QuickCheck((==>)) --- | Defines a concrete type for testing. -type Game = Model.Game.Game Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y, - Show x, - Show y - ) => Test.QuickCheck.Arbitrary (Model.Game.Game x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary Game #-} +instance Test.QuickCheck.Arbitrary Model.Game.Game where arbitrary = let play game (randomGen : randomGens) | Model.Game.isTerminated game = game @@ -99,25 +85,25 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.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 "Game.prop_read" $ case (reads garbage :: [(Game, String)]) of + f garbage = Test.QuickCheck.label "Game.prop_read" $ case (reads garbage :: [(Model.Game.Game, 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 :: Game -> String -> Test.QuickCheck.Property + f :: Model.Game.Game -> String -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen/nFields" . (== 6) . length . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen/Half move clock" $ uncurry (&&) . ( (>= 0) &&& (<= Rule.DrawReason.maximumConsecutiveRepeatablePlies) ) . fromInteger . read . ( @@ -125,7 +111,7 @@ ) . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen/Full move counter" $ ( > (0 :: Type.Count.NMoves) ) . fromInteger . read . ( @@ -133,7 +119,7 @@ ) . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_fen" . ( \game' -> and [ uncurry (==) $ (($ game) &&& ($ game')) Model.Game.getNextLogicalColour, @@ -144,11 +130,11 @@ ) . Property.ForsythEdwards.readFEN $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = not (Model.Game.isTerminated game) ==> Test.QuickCheck.label "Game.prop_isValidQualifiedMove" . all (`Model.Game.isValidQualifiedMove` game) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_findOrderedQualifiedMovesAvailableToNextPlayer" . ( == if Model.Game.isTerminated game then [] @@ -170,7 +156,7 @@ maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_inferMoveType" . all ( \qualifiedMove -> let moveType = Component.QualifiedMove.getMoveType qualifiedMove @@ -181,34 +167,34 @@ ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_findQualifiedMovesAvailableToNextPlayer/unique" . uncurry (==) . (id &&& Data.List.nub) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_getNextLogicalColour" . uncurry (==) . (Model.Game.getNextLogicalColour &&& State.TurnsByLogicalColour.inferNextLogicalColour . Model.Game.getTurnsByLogicalColour) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_mkCoordinatesByRankByLogicalColour" . uncurry (==) . ( State.CoordinatesByRankByLogicalColour.deconstruct . State.CoordinatesByRankByLogicalColour.sortCoordinates . State.Board.getCoordinatesByRankByLogicalColour &&& State.CoordinatesByRankByLogicalColour.deconstruct . State.CoordinatesByRankByLogicalColour.sortCoordinates . State.CoordinatesByRankByLogicalColour.fromMaybePieceByCoordinates . State.Board.getMaybePieceByCoordinates ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_getCoordinatesByRankByLogicalColour/unique" . all ( (== 1) . length ) . ToolShed.Data.Foldable.gather . State.CoordinatesByRankByLogicalColour.listCoordinates . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(getAvailableQualifiedMovesByLogicalColour == mkAvailableQualifiedMovesFor)" . Data.Maybe.maybe True ( == Model.Game.mkAvailableQualifiedMovesFor nextLogicalColour game - ) . Data.Map.lookup nextLogicalColour $ Model.Game.getAvailableQualifiedMovesByLogicalColour game where + ) . Map.lookup nextLogicalColour $ Model.Game.getAvailableQualifiedMovesByLogicalColour game where nextLogicalColour = Model.Game.getNextLogicalColour game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 4096 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(findQualifiedMovesAvailableTo => countPliesAvailableTo)" $ all ( \logicalColour -> Model.Game.countPliesAvailableTo logicalColour game == ( if Model.Game.isTerminated game @@ -218,25 +204,19 @@ ) Property.FixedMembership.members in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_(getNDefendersByCoordinatesByLogicalColour == countDefendersByCoordinatesByLogicalColour)" . uncurry (==) . ( State.Board.getNDefendersByCoordinatesByLogicalColour &&& State.Board.countDefendersByCoordinatesByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f, let - f :: Game -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Game.prop_(getNPawnsByFileByLogicalColour => countPawnsByFileByLogicalColour)" . uncurry (==) . ( - State.Board.getNPawnsByFileByLogicalColour &&& State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour - ) . Model.Game.getBoard - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, - let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_getNPawnsByFileByLogicalColour/non-zero" . Data.Foldable.all ( Data.Foldable.all (> 0) ) . State.Board.getNPawnsByFileByLogicalColour . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(getCoordinatesByRankByLogicalColour => getNPawnsByFileByLogicalColour)" . all ( \(logicalColour, nPawnsByFile) -> Data.Foldable.sum nPawnsByFile == fromIntegral ( length . State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn $ State.Board.getCoordinatesByRankByLogicalColour board @@ -245,51 +225,51 @@ board = Model.Game.getBoard game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_(getPassedPawnCoordinatesByLogicalColour == findPassedPawnCoordinatesByLogicalColour)" . uncurry (==) . ( State.Board.getPassedPawnCoordinatesByLogicalColour &&& State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_(getMaybeChecked == isKingChecked)" . uncurry (==) . ( Data.Maybe.isJust . Model.Game.getMaybeChecked &&& uncurry State.Board.isKingChecked . (Model.Game.getNextLogicalColour &&& Model.Game.getBoard) ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 512 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.(prop_getCastleableRooksByLogicalColour == fromTurnsByLogicalColour)" . uncurry (==) . ( Model.Game.getCastleableRooksByLogicalColour &&& State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour . Model.Game.getTurnsByLogicalColour ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_reflectOnX/isValidQualifiedMove" . all ( \(game, turn) -> Model.Game.isValidQualifiedMove (Component.Turn.getQualifiedMove turn) game ) . Model.Game.rollBack . Property.Reflectable.reflectOnX in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Game.prop_cantConverge" . not . any ( \(game, turn) -> Model.Game.cantConverge game $ Model.Game.takeTurn turn game ) . Model.Game.rollBack in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = not (Property.Null.isNull game) ==> Test.QuickCheck.label "Game.prop_rollBack/restart" . (== Data.Default.def) . fst {-game-} . last {-original-} $ Model.Game.rollBack game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_rollBack/takeTurn" . (== game) . foldr ( Model.Game.takeTurn . snd {-turn-} ) Data.Default.def $ Model.Game.rollBack game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(findAttackersOf => listDestinationsFor)" $ all ( \(destination, destinationLogicalColour, destinationRank, source, sourceRank) -> (destination, Just destinationRank) `elem` State.MaybePieceByCoordinates.listDestinationsFor source ( Component.Piece.mkPiece (Property.Opposable.getOpposite destinationLogicalColour) sourceRank @@ -304,7 +284,7 @@ maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Test.QuickCheck.label "Game.prop_(listDestinationsFor => findAttackersOf)" $ all ( \(source, piece, destination) -> (source, Component.Piece.getRank piece) `elem` State.Board.findAttackersOf ( Property.Opposable.getOpposite $ Component.Piece.getLogicalColour piece @@ -318,12 +298,31 @@ maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Game -> Test.QuickCheck.Property - f game = Test.QuickCheck.label "Game.prop_pawnOrdinates" . all ( - uncurry (&&) . ( - (/= Cartesian.Ordinate.yMin) &&& (/= Cartesian.Ordinate.yMax) - ) . Cartesian.Coordinates.getY . fst {-coordinates-} - ) . StateProperty.Seeker.findPieces Component.Piece.isPawn . State.Board.getCoordinatesByRankByLogicalColour $ Model.Game.getBoard game - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + f :: Test.QuickCheck.Input.EvaluationOptions.EvaluationOptions -> Model.Game.Game -> Test.QuickCheck.Property + f evaluationOptions game = Data.Maybe.isJust ( + Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions + ) && not ( + Property.Null.isNull game + ) ==> Test.QuickCheck.label "Game.prop_measurePieceSquareValueIncrementally" . +#ifdef USE_PRECISION + uncurry (==) +#else + ( + < recip +# if USE_NARROW_NUMBERS + 100000 +# else + 10000000000 +# endif + ) . abs . uncurry (-) -- Tolerance for floating-point errors. +#endif + $ ( + Evaluation.Fitness.measurePieceSquareValue pieceSquareByCoordinatesByRank &&& Evaluation.Fitness.measurePieceSquareValueIncrementally ( + Evaluation.Fitness.measurePieceSquareValue pieceSquareByCoordinatesByRank oldGame + ) pieceSquareByCoordinatesByRank + ) game where + pieceSquareByCoordinatesByRank = Data.Maybe.fromJust $ Input.EvaluationOptions.getMaybePieceSquareByCoordinatesByRank evaluationOptions + (oldGame, _) : _ = Model.Game.rollBack game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f ] 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 @@ -24,36 +24,29 @@ -} module BishBosh.Test.QuickCheck.Model.GameTree( --- * Types --- ** Type-synonyms - GameTree, -- * Constants results ) where -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.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -import qualified BishBosh.Type.Length as Type.Length +import BishBosh.Test.QuickCheck.Model.Game() +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 Data.Default import qualified Data.Maybe import qualified Test.QuickCheck -instance (Enum x, Enum y, Ord x, Ord y, Show x, Show y) => Test.QuickCheck.Arbitrary (Model.GameTree.GameTree x y) where +instance Test.QuickCheck.Arbitrary Model.GameTree.GameTree where arbitrary = do depth <- Test.QuickCheck.elements [1 .. 3] fmap (Property.Arboreal.prune depth . Model.GameTree.fromGame) Test.QuickCheck.arbitrary --- | Define a concrete type for testing. -type GameTree = Model.GameTree.GameTree Type.Length.X Type.Length.Y - -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "GameTree.prop_traceRoute" . ( \turns -> Data.Maybe.maybe False ( (== Just turns) . mapM Model.Game.maybeLastTurn 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,9 +27,9 @@ results ) where -import qualified BishBosh.Model.GameTree as Model.GameTree -import qualified BishBosh.Model.MoveFrequency as Model.MoveFrequency -import qualified BishBosh.Test.QuickCheck.Model.GameTree as Test.QuickCheck.Model.GameTree +import BishBosh.Test.QuickCheck.Model.GameTree() +import qualified BishBosh.Model.GameTree as Model.GameTree +import qualified BishBosh.Model.MoveFrequency as Model.MoveFrequency import qualified Data.Foldable import qualified Test.QuickCheck @@ -37,7 +37,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Test.QuickCheck.Model.GameTree.GameTree -> Test.QuickCheck.Property + f :: Model.GameTree.GameTree -> Test.QuickCheck.Property f gameTree = Test.QuickCheck.label "MoveFrequency.prop_countMoves" $ Model.MoveFrequency.countEntries ( Model.GameTree.toMoveFrequency gameTree ) == pred {-the apex is counted in 'getNPlies'-} ( diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/Figurine.hs b/src-test/BishBosh/Test/QuickCheck/Notation/Figurine.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Notation/Figurine.hs @@ -0,0 +1,43 @@ +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.Notation.Figurine( +-- * Constants + results +) where + +import BishBosh.Test.QuickCheck.Component.Piece() +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Notation.Figurine as Notation.Figurine +import qualified Test.QuickCheck + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Component.Piece.Piece -> Test.QuickCheck.Property + f piece = Test.QuickCheck.label "Figurine.prop_figurine" $ Notation.Figurine.fromFigurine (Notation.Figurine.toFigurine piece) == Just piece + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } 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 @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Notation.ICCFNumeric( --- * Types --- ** Type-synonyms --- ICCFNumeric, -- * Constants results ) where @@ -39,25 +36,15 @@ 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.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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Notation.ICCFNumeric.ICCFNumeric x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary ICCFNumeric #-} +instance Test.QuickCheck.Arbitrary Notation.ICCFNumeric.ICCFNumeric where arbitrary = do move <- Test.QuickCheck.arbitrary Notation.ICCFNumeric.mkICCFNumeric move `fmap` if abs ( - Cartesian.Vector.getXDistance (Component.Move.measureDistance move :: Cartesian.Vector.VectorInt) + Cartesian.Vector.getXDistance (Component.Move.measureDistance move) ) <= 1 && ( Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move ) `elem` [ @@ -74,19 +61,19 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: ICCFNumeric -> Test.QuickCheck.Property + f :: Notation.ICCFNumeric.ICCFNumeric -> Test.QuickCheck.Property f = Test.QuickCheck.label "ICCFNumeric.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 "ICCFNumeric.prop_read" $ case ( - reads garbage :: [(Notation.ICCFNumeric.ICCFNumeric Int Int, String)] + reads garbage :: [(Notation.ICCFNumeric.ICCFNumeric, 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 :: ICCFNumeric -> String -> Test.QuickCheck.Property + f :: Notation.ICCFNumeric.ICCFNumeric -> String -> Test.QuickCheck.Property f coordinate = Test.QuickCheck.label "ICCFNumeric.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage ( `elem` concatMap (show . fst {-digit-}) Notation.ICCFNumeric.toRank ) coordinate 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 @@ -23,12 +23,57 @@ [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary'. -} -module BishBosh.Test.QuickCheck.Notation.MoveNotation () where +module BishBosh.Test.QuickCheck.Notation.MoveNotation ( +-- * Constants + results +) where +import BishBosh.Test.QuickCheck.Cartesian.Coordinates() +import BishBosh.Test.QuickCheck.Model.Game() +import Control.Arrow((&&&), (|||)) +import qualified BishBosh.Attribute.MoveType as Attribute.MoveType +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove +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.Model.Game as Model.Game import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Notation.Notation as Notation.Notation import qualified BishBosh.Property.FixedMembership as Property.FixedMembership +import qualified BishBosh.Property.Null as Property.Null +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified Data.Maybe import qualified Test.QuickCheck +import Test.QuickCheck((==>)) instance Test.QuickCheck.Arbitrary Notation.MoveNotation.MoveNotation where arbitrary = Test.QuickCheck.elements Property.FixedMembership.members + +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Notation.MoveNotation.MoveNotation -> Cartesian.Coordinates.Coordinates -> Test.QuickCheck.Property + f moveNotation = Test.QuickCheck.label "MoveNotation.prop_(read.show)Coordinates" . uncurry (==) . ( + Notation.Notation.readsCoordinates (Notation.MoveNotation.getNotation moveNotation) . Notation.MoveNotation.showNotation moveNotation &&& return . flip (,) "" + ) + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, + let + f :: Notation.MoveNotation.MoveNotation -> Model.Game.Game -> Test.QuickCheck.Property + f moveNotation game = not (Property.Null.isNull game) ==> Test.QuickCheck.label "MoveNotation.prop_(read.show)QualifiedMove" $ case Notation.MoveNotation.readsQualifiedMove moveNotation $ Notation.MoveNotation.showNotation moveNotation turn of + [(eitherQualifiedMove, "")] -> uncurry (&&) $ ( + (== move) . Component.EitherQualifiedMove.getMove &&& ( + Data.Maybe.maybe (not $ Attribute.MoveType.isPromotion moveType) (== rank) ||| (== moveType) + ) . Component.EitherQualifiedMove.getPromotionRankOrMoveType + ) eitherQualifiedMove + _ -> False + where + turn = Data.Maybe.fromJust $ Model.Game.maybeLastTurn game + (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ Component.Turn.getQualifiedMove turn + (Just rank) = fmap Component.Piece.getRank . State.MaybePieceByCoordinates.dereference (Component.Move.getDestination move) . State.Board.getMaybePieceByCoordinates $ Model.Game.getBoard game + + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f + ] diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs --- a/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs +++ b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Notation.PureCoordinate( --- * Types --- ** Type-synonyms --- PureCoordinate, -- * Constants results ) where @@ -39,26 +36,16 @@ 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.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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Notation.PureCoordinate.PureCoordinate x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary PureCoordinate #-} +instance Test.QuickCheck.Arbitrary Notation.PureCoordinate.PureCoordinate where arbitrary = do move <- Test.QuickCheck.arbitrary Notation.PureCoordinate.mkPureCoordinate move `fmap` if abs ( - Cartesian.Vector.getXDistance (Component.Move.measureDistance move :: Cartesian.Vector.VectorInt) + Cartesian.Vector.getXDistance (Component.Move.measureDistance move) ) <= 1 && ( Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move ) `elem` [ @@ -75,19 +62,19 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: PureCoordinate -> Test.QuickCheck.Property + f :: Notation.PureCoordinate.PureCoordinate -> Test.QuickCheck.Property f = Test.QuickCheck.label "PureCoordinate.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 "PureCoordinate.prop_read" $ case ( - reads garbage :: [(Notation.PureCoordinate.PureCoordinate Int Int, String)] + reads garbage :: [(Notation.PureCoordinate.PureCoordinate, 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 :: PureCoordinate -> String -> Test.QuickCheck.Property + f :: Notation.PureCoordinate.PureCoordinate -> String -> Test.QuickCheck.Property f coordinate = Test.QuickCheck.label "PureCoordinate.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage ( ( `elem` concatMap show Attribute.Rank.promotionProspects 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 @@ -24,9 +24,6 @@ -} module BishBosh.Test.QuickCheck.Notation.Smith( --- * Types --- ** Type-synonyms --- Smith, -- * Constants results ) where @@ -34,39 +31,29 @@ 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.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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Notation.Smith.Smith x y) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary Smith #-} +instance Test.QuickCheck.Arbitrary Notation.Smith.Smith where arbitrary = fmap Notation.Smith.fromQualifiedMove Test.QuickCheck.arbitrary -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Smith -> Test.QuickCheck.Property + f :: Notation.Smith.Smith -> Test.QuickCheck.Property f = Test.QuickCheck.label "Smith.prop_readPrependedWhiteSpace" . ToolShed.Test.ReversibleIO.readPrependedWhiteSpace in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let f :: String -> Test.QuickCheck.Property f garbage = Test.QuickCheck.label "Smith.prop_read" $ case ( - reads garbage :: [(Notation.Smith.Smith Int Int, String)] + reads garbage :: [(Notation.Smith.Smith, 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 :: Smith -> String -> Test.QuickCheck.Property + f :: Notation.Smith.Smith -> String -> Test.QuickCheck.Property 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/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 @@ -26,8 +26,7 @@ module BishBosh.Test.QuickCheck.Search.KillerMoves( -- * Types -- ** Type-synonyms --- Key, - KillerMoves, +-- KillerMoves, -- * Constants results -- * Functions @@ -42,19 +41,9 @@ import qualified BishBosh.Search.EphemeralData as Search.EphemeralData import qualified BishBosh.Search.KillerMoves as Search.KillerMoves 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 Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Search.DynamicMoveData.KillerMoveKey x y) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary KillerMoveKey #-} +instance Test.QuickCheck.Arbitrary Search.DynamicMoveData.KillerMoveKey where arbitrary = fmap Search.DynamicMoveData.mkKillerMoveKeyFromTurn Test.QuickCheck.arbitrary -- | Map the integer-domain into a smaller non-negative number of plies. @@ -66,19 +55,20 @@ 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 +type KillerMoves = Search.KillerMoves.KillerMoves Search.DynamicMoveData.KillerMoveKey instance ( Ord key, Test.QuickCheck.Arbitrary key ) => Test.QuickCheck.Arbitrary (Search.KillerMoves.KillerMoves key) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary KillerMoves #-} arbitrary = fmap populate Test.QuickCheck.arbitrary -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: [(Int, KillerMoveKey)] -> Test.QuickCheck.Property + f :: [(Int, Search.DynamicMoveData.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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- Copyright (C) 2018 Dr. Alistair Ward @@ -34,11 +35,16 @@ import qualified BishBosh.Search.Search as Search.Search import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.Test.QuickCheck.Search.SearchState as Test.QuickCheck.Search.SearchState +import qualified BishBosh.Type.Count as Type.Count import qualified Control.Monad.Reader import qualified Data.Default import qualified Test.QuickCheck import Test.QuickCheck((==>)) +#ifdef USE_NEWTYPE_WRAPPERS +import BishBosh.Test.QuickCheck.Type.Count() +#endif + -- | The constant test-results. results :: IO [Test.QuickCheck.Result] results = sequence [ @@ -50,7 +56,7 @@ let f :: Input.SearchOptions.SearchOptions - -> Int -- ^ Search-depth. + -> Type.Count.NPlies -- ^ Search-depth. -> Test.QuickCheck.Search.SearchState.SearchState -> Test.QuickCheck.Property f searchOptions searchDepth searchState = searchOptions /= Data.Default.def && not ( 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 @@ -39,36 +39,27 @@ import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Search.SearchState as Search.SearchState import qualified BishBosh.Type.Crypto as Type.Crypto -import qualified BishBosh.Type.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 -- | A suitable concrete type for testing. -type SearchState = Search.SearchState.SearchState Type.Length.X Type.Length.Y Type.Crypto.PositionHash +type SearchState = Search.SearchState.SearchState Type.Crypto.PositionHash -instance forall x y positionHash. ( - Data.Array.IArray.Ix x, - Data.Bits.FiniteBits positionHash, - Integral x, - Integral y, - Num positionHash, - Show positionHash, - Show x, - Show y, - System.Random.Random positionHash, - Test.QuickCheck.Arbitrary x, - Test.QuickCheck.Arbitrary y - ) => Test.QuickCheck.Arbitrary (Search.SearchState.SearchState x y positionHash) where +instance forall positionHash. ( + Data.Bits.FiniteBits positionHash, + Num positionHash, + Show positionHash, + System.Random.Random positionHash + ) => Test.QuickCheck.Arbitrary (Search.SearchState.SearchState positionHash) where {-# SPECIALISE instance Test.QuickCheck.Arbitrary SearchState #-} arbitrary = do evaluationOptions <- Test.QuickCheck.arbitrary Search.SearchState.initialise <$> ( Evaluation.PositionHashQuantifiedGameTree.mkPositionHashQuantifiedGameTree ( - evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue x y + evaluationOptions :: Input.EvaluationOptions.EvaluationOptions Type.Mass.PieceSquareValue ) <$> Test.QuickCheck.arbitrary {-SearchOptions-} <*> Test.QuickCheck.arbitrary {-Zobrist-} <*> return {-to Gen-monad-} Property.Empty.empty {-MoveFrequency-} <*> Test.QuickCheck.arbitrary {-Game-} ) 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 @@ -24,57 +24,43 @@ -} module BishBosh.Test.QuickCheck.State.Board( --- * Types --- ** Type-synonyms - Board, -- * Constants results ) where import BishBosh.Test.QuickCheck.Attribute.LogicalColour() -import BishBosh.Test.QuickCheck.Component.Piece() +import BishBosh.Test.QuickCheck.Cartesian.Coordinates() import Control.Arrow((&&&)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Component.Piece as Component.Piece -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.Property.Opposable as Property.Opposable -import qualified BishBosh.Property.Reflectable as Property.Reflectable -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour -import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates -import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator -import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker -import qualified BishBosh.Test.QuickCheck.Cartesian.Coordinates as Test.QuickCheck.Cartesian.Coordinates -import qualified BishBosh.Type.Length as Type.Length +import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Component.Piece as Component.Piece +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.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.Reflectable as Property.Reflectable +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour +import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates +import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified Control.Monad import qualified Data.Foldable import qualified Data.List -import qualified Data.Map +import qualified Data.Map.Strict as Map import qualified Data.Maybe import qualified Data.Ord import qualified Data.Set import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO --- | Defines a concrete type for testing. -type Board = State.Board.Board Type.Length.X Type.Length.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (State.Board.Board x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary Board #-} +instance Test.QuickCheck.Arbitrary State.Board.Board where arbitrary = let - isKingChecked :: (Enum x, Enum y, Ord x, Ord y) => Attribute.LogicalColour.LogicalColour -> State.Board.Board x y -> Bool + isKingChecked :: Attribute.LogicalColour.LogicalColour -> State.Board.Board -> Bool isKingChecked logicalColour board = not . all ( null . ($ board) . State.Board.findAttackersOf logicalColour ) . State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.King $ State.Board.getCoordinatesByRankByLogicalColour board @@ -98,41 +84,41 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.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 "Board.prop_read" $ case (reads garbage :: [(Board, String)]) of + f garbage = Test.QuickCheck.label "Board.prop_read" $ case (reads garbage :: [(State.Board.Board, 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 :: Board -> String -> Test.QuickCheck.Property + f :: State.Board.Board -> String -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` ('/' : Component.Piece.showPieces ++ concatMap show [1 .. Cartesian.Abscissa.xLength])) board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_fen" $ case Property.ForsythEdwards.readsFEN $ Property.ForsythEdwards.showFEN board of [(board', "")] -> board' == board _ -> False in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 16 } f, let - f :: Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property f source logicalColour = Test.QuickCheck.label "Board.prop_bishopsMove/logicalColour" . all ( (== Cartesian.Coordinates.getLogicalColourOfSquare source) . Cartesian.Coordinates.getLogicalColourOfSquare . fst {-coordinates-} ) . State.MaybePieceByCoordinates.listDestinationsFor source piece . State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source where piece = Component.Piece.mkBishop logicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property + f :: Cartesian.Coordinates.Coordinates -> Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Property f source logicalColour = Test.QuickCheck.label "Board.prop_knightsMove/logicalColour" . all ( (/= Cartesian.Coordinates.getLogicalColourOfSquare source) . Cartesian.Coordinates.getLogicalColourOfSquare . fst {-coordinates-} ) . State.MaybePieceByCoordinates.listDestinationsFor source piece . State.Board.getMaybePieceByCoordinates $ StateProperty.Mutator.placeFirstPiece piece source where piece = Component.Piece.mkKnight logicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_listDestinationsFor/unique" $ all ( \(coordinates, piece) -> uncurry (==) . ( length &&& length . Data.List.nub @@ -141,27 +127,27 @@ maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_(findAttacksBy <=> findAttackersOf)" $ all ( \(piece, coordinates) -> let logicalColour = Component.Piece.getLogicalColour piece in all ( \destination -> foldr ( \rank m -> foldr ( - \source -> Data.Map.insertWith Data.Set.union source $ Data.Set.singleton rank + \source -> Map.insertWith Data.Set.union source $ Data.Set.singleton rank ) m $ State.Board.findAttacksBy ( Component.Piece.mkPiece (Property.Opposable.getOpposite logicalColour) rank ) destination board - ) Data.Map.empty Property.FixedMembership.members == foldr ( - \(source, rank) -> Data.Map.insertWith Data.Set.union source $ Data.Set.singleton rank - ) Data.Map.empty ( + ) Property.Empty.empty Property.FixedMembership.members == foldr ( + \(source, rank) -> Map.insertWith Data.Set.union source $ Data.Set.singleton rank + ) Property.Empty.empty ( State.Board.findAttackersOf logicalColour destination board ) ) coordinates ) . State.CoordinatesByRankByLogicalColour.assocs $ State.Board.getCoordinatesByRankByLogicalColour board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_(findBlockingPiece => isObstructed)" $ all ( \(source, _) -> let isClear = ($ maybePieceByCoordinates) . State.MaybePieceByCoordinates.isClear source @@ -176,26 +162,26 @@ maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.prop_findPieces" . uncurry (==) . ( Data.List.sort . StateProperty.Seeker.findAllPieces . State.Board.getCoordinatesByRankByLogicalColour &&& Data.List.sort . StateProperty.Seeker.findAllPieces . State.Board.getMaybePieceByCoordinates ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.prop_reflectOnY" . uncurry (==) . (id &&& Property.Reflectable.reflectOnY . Property.Reflectable.reflectOnY) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f = Test.QuickCheck.label "Board.prop_countPawnsByFileByLogicalColour" . ( \coordinatesByRankByLogicalColour -> all ( uncurry (==) . ( Data.Foldable.sum . ( - State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour ! + StateProperty.Seeker.countPawnsByFileByLogicalColour coordinatesByRankByLogicalColour ! ) &&& fromIntegral . length . ( \logicalColour -> State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour ) @@ -204,7 +190,7 @@ ) . State.Board.getCoordinatesByRankByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_(exposesKing => isKingChecked)" $ all ( \(logicalColour, move) -> State.Board.isKingChecked logicalColour $ State.Board.movePiece move Nothing board ) [ @@ -217,7 +203,7 @@ ] -- List-comprehension. in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024 } f, let - f :: Board -> Test.QuickCheck.Property + f :: State.Board.Board -> Test.QuickCheck.Property f board = Test.QuickCheck.label "Board.prop_findProximateKnights" . all ( \(coordinates, piece) -> let logicalColour = Property.Opposable.getOpposite $ Component.Piece.getLogicalColour piece 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 @@ -24,14 +24,12 @@ -} module BishBosh.Test.QuickCheck.State.CastleableRooksByLogicalColour( --- * Types --- ** Type-synonyms - CastleableRooksByLogicalColour, -- * Constants results ) where import BishBosh.Test.QuickCheck.Attribute.LogicalColour() +import BishBosh.Test.QuickCheck.Cartesian.Coordinates() import Control.Arrow((&&&)) import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa @@ -40,19 +38,13 @@ import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards 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.Type.Length as Type.Length import qualified Data.List import qualified Data.List.Extra import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO import Test.QuickCheck((==>)) -instance ( - Enum x, - Ord x, - Show x - ) => Test.QuickCheck.Arbitrary (State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x) where +instance Test.QuickCheck.Arbitrary State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour where arbitrary = fmap ( State.CastleableRooksByLogicalColour.fromAssocs . Data.List.Extra.groupSort ) . Test.QuickCheck.elements $ Data.List.subsequences [ @@ -61,38 +53,35 @@ x <- [Cartesian.Abscissa.xMin, Cartesian.Abscissa.xMax] ] -- List-comprehension. --- | Defines a concrete type for testing. -type CastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour Type.Length.X - -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f = Test.QuickCheck.label "CastleableRooksByLogicalColour.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 "CastleableRooksByLogicalColour.prop_read" $ case (reads garbage :: [(CastleableRooksByLogicalColour, String)]) of + f garbage = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_read" $ case (reads garbage :: [(State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, 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 :: CastleableRooksByLogicalColour -> String -> Test.QuickCheck.Property + f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> String -> Test.QuickCheck.Property f castleableRooksByLogicalColour = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (const False) castleableRooksByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_reflectOnX" . uncurry (==) . (id &&& Property.Reflectable.reflectOnX . Property.Reflectable.reflectOnX) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_fen" . uncurry (==) . ( State.CastleableRooksByLogicalColour.unify . Property.ForsythEdwards.readFEN . Property.ForsythEdwards.showFEN &&& State.CastleableRooksByLogicalColour.unify ) in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f castleableRooksByLogicalColour = Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(canCastle /= hasCastled)" . not $ any ( uncurry (&&) . ( (`State.CastleableRooksByLogicalColour.canCastle` castleableRooksByLogicalColour) &&& (`State.CastleableRooksByLogicalColour.hasCastled` castleableRooksByLogicalColour) @@ -100,7 +89,7 @@ ) Property.FixedMembership.members in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 32 } f, let - f :: Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f logicalColour coordinates castleableRooksByLogicalColour = coordinates `notElem` [ minBound, Cartesian.Coordinates.bottomRight, @@ -109,14 +98,14 @@ ] ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_canCastleWith" . not $ State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64} f, let - f :: Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f logicalColour coordinates castleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(canCastleWith => canCastle)" $ State.CastleableRooksByLogicalColour.canCastle logicalColour castleableRooksByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64, Test.QuickCheck.maxDiscardRatio = 128 } f, let - f :: Attribute.LogicalColour.LogicalColour -> Test.QuickCheck.Cartesian.Coordinates.Coordinates -> CastleableRooksByLogicalColour -> Test.QuickCheck.Property + f :: Attribute.LogicalColour.LogicalColour -> Cartesian.Coordinates.Coordinates -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> Test.QuickCheck.Property f logicalColour coordinates castleableRooksByLogicalColour = not (State.CastleableRooksByLogicalColour.canCastle logicalColour castleableRooksByLogicalColour) ==> Test.QuickCheck.label "CastleableRooksByLogicalColour.prop_(not . canCastle => not . canCastleWith)" . not $ State.CastleableRooksByLogicalColour.canCastleWith logicalColour coordinates castleableRooksByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f ] 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 @@ -28,16 +28,16 @@ ) where import Control.Arrow((&&&)) +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.State.InstancesByPosition as State.InstancesByPosition -import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game import qualified Test.QuickCheck -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "InstancesByPosition.prop_countPositionRepetitions" . uncurry (==) . ( State.InstancesByPosition.countPositionRepetitions &&& uncurry (-) . ( succ . fromIntegral . State.InstancesByPosition.countConsecutiveRepeatablePlies &&& State.InstancesByPosition.getNDistinctPositions @@ -45,7 +45,7 @@ ) . Model.Game.getInstancesByPosition in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "InstancesByPosition.prop_anyInstancesByPosition (< 1)" . not . State.InstancesByPosition.anyInstancesByPosition (< 1) . Model.Game.getInstancesByPosition in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/State/Position.hs b/src-test/BishBosh/Test/QuickCheck/State/Position.hs --- a/src-test/BishBosh/Test/QuickCheck/State/Position.hs +++ b/src-test/BishBosh/Test/QuickCheck/State/Position.hs @@ -28,6 +28,7 @@ ) where import Control.Arrow((&&&)) +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Attribute.MoveType as Attribute.MoveType import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates import qualified BishBosh.Component.Move as Component.Move @@ -35,7 +36,6 @@ import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.State.EnPassantAbscissa as State.EnPassantAbscissa import qualified BishBosh.State.Position as State.Position -import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game import qualified Data.List import qualified Test.QuickCheck @@ -43,7 +43,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Position.prop_getMaybeEnPassantAbscissa" . uncurry (==) . ( fmap ( Cartesian.Coordinates.getX . Component.Move.getDestination . Component.QualifiedMove.getMove -- Extract the abscissa. 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 @@ -32,25 +32,23 @@ ) where import BishBosh.Test.QuickCheck.Component.Turn() +import BishBosh.Test.QuickCheck.Model.Game() import Control.Arrow((&&&)) import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa import qualified BishBosh.Component.Piece as Component.Piece import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour -import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game -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 Type.Length.X Type.Length.Y) +type TurnsByLogicalColour = State.TurnsByLogicalColour.TurnsByLogicalColour Component.Turn.Turn instance ( - Show a, - Test.QuickCheck.Arbitrary a - ) => Test.QuickCheck.Arbitrary (State.TurnsByLogicalColour.TurnsByLogicalColour a) where --- {-# SPECIALISE instance Test.QuickCheck.Arbitrary TurnsByLogicalColour #-} + Show turn, + Test.QuickCheck.Arbitrary turn + ) => Test.QuickCheck.Arbitrary (State.TurnsByLogicalColour.TurnsByLogicalColour turn) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary TurnsByLogicalColour #-} arbitrary = do turns <- Test.QuickCheck.arbitrary @@ -76,7 +74,7 @@ f turnsByLogicalColour = Test.QuickCheck.label "TurnsByLogicalColour.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` ('/' : Component.Piece.showPieces ++ concatMap show [1 .. Cartesian.Abscissa.xLength])) turnsByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 128 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "TurnsByLogicalColour.prop_getNPlies" . uncurry (==) . (State.TurnsByLogicalColour.getNPlies &&& State.TurnsByLogicalColour.countPlies) . Model.Game.getTurnsByLogicalColour in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f ] diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/Censor.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/Censor.hs --- a/src-test/BishBosh/Test/QuickCheck/StateProperty/Censor.hs +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/Censor.hs @@ -28,10 +28,10 @@ ) where import Control.Arrow((&&&)) -import qualified BishBosh.Model.Game as Model.Game -import qualified BishBosh.State.Board as State.Board -import qualified BishBosh.StateProperty.Censor as StateProperty.Censor -import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game +import BishBosh.Test.QuickCheck.Model.Game() +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.StateProperty.Censor as StateProperty.Censor import qualified Test.QuickCheck -- import Test.QuickCheck((==>)) @@ -39,32 +39,32 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_countPiecesByLogicalColour" . uncurry (==) . ( StateProperty.Censor.countPiecesByLogicalColour . State.Board.getMaybePieceByCoordinates &&& StateProperty.Censor.countPiecesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_countPieces" . uncurry (==) . ( StateProperty.Censor.countPieces . State.Board.getMaybePieceByCoordinates &&& StateProperty.Censor.countPieces . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_countPieces/bounds" . uncurry (&&) . ( (> 2) &&& (<= 32) ) . StateProperty.Censor.countPieces . State.Board.getCoordinatesByRankByLogicalColour . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_countPieceDifferenceByRank" . uncurry (==) . ( StateProperty.Censor.countPieceDifferenceByRank . State.Board.getMaybePieceByCoordinates &&& StateProperty.Censor.countPieceDifferenceByRank . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, {- let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f game = Model.Game.isTerminated game ==> Test.QuickCheck.label "Censor.prop_hasInsufficientMaterial" . uncurry (==) . ( StateProperty.Censor.hasInsufficientMaterial . State.Board.getMaybePieceByCoordinates &&& StateProperty.Censor.hasInsufficientMaterial . State.Board.getCoordinatesByRankByLogicalColour ) $ Model.Game.getBoard game @@ -74,19 +74,19 @@ } f, -} let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_hasBothKings" . uncurry (==) . ( StateProperty.Censor.hasBothKings . State.Board.getMaybePieceByCoordinates &&& StateProperty.Censor.hasBothKings . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_(getNPieces == countPieces)" . uncurry (==) . ( State.Board.getNPieces &&& StateProperty.Censor.countPieces . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let - f :: Test.QuickCheck.Model.Game.Game -> Test.QuickCheck.Property + f :: Model.Game.Game -> Test.QuickCheck.Property f = Test.QuickCheck.label "Censor.prop_(getNPiecesDifferenceByRank == countPieceDifferenceByRank)" . uncurry (==) . ( State.Board.getNPiecesDifferenceByRank &&& StateProperty.Censor.countPieceDifferenceByRank . State.Board.getCoordinatesByRankByLogicalColour ) . Model.Game.getBoard diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/Hashable.hs @@ -0,0 +1,78 @@ +{- + 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 tests. +-} + +module BishBosh.Test.QuickCheck.StateProperty.Hashable( +-- * Constants, + results +) where + +import BishBosh.Test.QuickCheck.Model.Game() +import Control.Arrow((&&&)) +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable +import qualified BishBosh.Test.QuickCheck.Component.Zobrist as Test.QuickCheck.Component.Zobrist +import qualified Data.List +import qualified Test.QuickCheck + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property + f zobrist game = Test.QuickCheck.label "Hashable.prop_hash(Game)/unique" . areUnique . map ( + (`StateProperty.Hashable.hash` zobrist) . (`Model.Game.applyQualifiedMove` game) + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property + f zobrist game = Test.QuickCheck.label "Hashable.prop_hash(Position)/unique" . areUnique . map ( + (`StateProperty.Hashable.hash` zobrist) . Model.Game.mkPosition . (`Model.Game.applyQualifiedMove` game) + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property + f zobrist game = Test.QuickCheck.label "Hashable.prop_(hash(Game) == hash(Position))" . all ( + uncurry (==) . ( + ( + `StateProperty.Hashable.hash` zobrist + ) &&& ( + `StateProperty.Hashable.hash` zobrist + ) . Model.Game.mkPosition + ) . (`Model.Game.applyQualifiedMove` game) + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 64 } f, + let + f :: Test.QuickCheck.Component.Zobrist.Zobrist -> Model.Game.Game -> Test.QuickCheck.Property + f zobrist game = Test.QuickCheck.label "Hashable.prop_incrementalEvaluation" . all ( + ( + \game' -> StateProperty.Hashable.hash game' zobrist == Model.Game.updateIncrementalPositionHash game ( + StateProperty.Hashable.hash game zobrist + ) game' zobrist + ) . (`Model.Game.applyQualifiedMove` game) + ) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + ] where + areUnique :: Ord a => [a] -> Bool + areUnique = all ((== 1) . length) . Data.List.group . Data.List.sort + diff --git a/src-test/BishBosh/Test/QuickCheck/StateProperty/Seeker.hs b/src-test/BishBosh/Test/QuickCheck/StateProperty/Seeker.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/StateProperty/Seeker.hs @@ -0,0 +1,72 @@ +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.StateProperty.Seeker( +-- * Constants + results +) where + +import BishBosh.Test.QuickCheck.Model.Game() +import Control.Arrow((&&&)) +import Data.Array.IArray((!)) +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Component.Piece as Component.Piece +import qualified BishBosh.Model.Game as Model.Game +import qualified BishBosh.State.Board as State.Board +import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker +import qualified Test.QuickCheck + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Seeker.prop_(getNPawnsByFileByLogicalColour => countPawnsByFileByLogicalColour)" . uncurry (==) . ( + State.Board.getNPawnsByFileByLogicalColour &&& StateProperty.Seeker.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour + ) . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Seeker.prop_countPawnsByFileByLogicalColour" . uncurry (==) . ( + StateProperty.Seeker.countPawnsByFileByLogicalColour . State.Board.getMaybePieceByCoordinates &&& StateProperty.Seeker.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour + ) . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f = Test.QuickCheck.label "Seeker.prop_(summariseNPawnsByLogicalColour vs getNPiecesDifferenceByRank)" . uncurry (==) . ( + uncurry (-) . ((! maxBound) &&& (! minBound)) . StateProperty.Seeker.summariseNPawnsByLogicalColour &&& (! Attribute.Rank.Pawn) . State.Board.getNPiecesDifferenceByRank + ) . Model.Game.getBoard + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Model.Game.Game -> Test.QuickCheck.Property + f game = Test.QuickCheck.label "Seeker.prop_pawnOrdinates" . all ( + uncurry (&&) . ( + (/= Cartesian.Ordinate.yMin) &&& (/= Cartesian.Ordinate.yMax) + ) . Cartesian.Coordinates.getY . fst {-coordinates-} + ) . StateProperty.Seeker.findPieces Component.Piece.isPawn . State.Board.getCoordinatesByRankByLogicalColour $ Model.Game.getBoard game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f + ] + diff --git a/src-test/BishBosh/Test/QuickCheck/Type/Count.hs b/src-test/BishBosh/Test/QuickCheck/Type/Count.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Type/Count.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' +-} + +module BishBosh.Test.QuickCheck.Type.Count() where + +#ifdef USE_NEWTYPE_WRAPPERS +import qualified BishBosh.Type.Count as Type.Count +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Type.Count.NPlies where + arbitrary = fromInteger <$> Test.QuickCheck.elements [0 .. 9] +#endif + diff --git a/src-test/BishBosh/Test/QuickCheck/Type/Length.hs b/src-test/BishBosh/Test/QuickCheck/Type/Length.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Type/Length.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + Copyright (C) 2021 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' +-} + +module BishBosh.Test.QuickCheck.Type.Length() where + +#ifdef USE_NEWTYPE_WRAPPERS +import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Type.Length as Type.Length +import qualified Test.QuickCheck + +instance Test.QuickCheck.Arbitrary Type.Length.X where + arbitrary = Test.QuickCheck.elements Cartesian.Abscissa.xRange + +instance Test.QuickCheck.Arbitrary Type.Length.Y where + arbitrary = Test.QuickCheck.elements Cartesian.Ordinate.yRange +#endif + diff --git a/src-test/BishBosh/Test/QuickCheck/UI/Command.hs b/src-test/BishBosh/Test/QuickCheck/UI/Command.hs --- a/src-test/BishBosh/Test/QuickCheck/UI/Command.hs +++ b/src-test/BishBosh/Test/QuickCheck/UI/Command.hs @@ -24,23 +24,16 @@ -} module BishBosh.Test.QuickCheck.UI.Command ( --- * Types --- ** Type-synonyms --- Command, -- * Constants results ) where import BishBosh.Test.QuickCheck.UI.PrintObject() import BishBosh.Test.QuickCheck.UI.SetObject() -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 Type.Length.X Type.Length.Y - -instance Test.QuickCheck.Arbitrary (UI.Command.Command x y) where +instance Test.QuickCheck.Arbitrary UI.Command.Command where arbitrary = Test.QuickCheck.oneof [ Test.QuickCheck.elements [ UI.Command.Hint, @@ -59,7 +52,7 @@ results :: IO [Test.QuickCheck.Result] results = sequence [ let - f :: Command -> Test.QuickCheck.Property + f :: UI.Command.Command -> Test.QuickCheck.Property f command = Test.QuickCheck.label "Command.prop_io" $ UI.Command.readsCommand (UI.Command.showsCommand command "") == Right (command, "") in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } 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 @@ -28,13 +28,17 @@ results ) where +import BishBosh.Test.QuickCheck.Model.Game() import qualified BishBosh.Input.SearchOptions as Input.SearchOptions import qualified BishBosh.UI.SetObject as UI.SetObject import qualified Test.QuickCheck import qualified ToolShed.Test.ReversibleIO instance Test.QuickCheck.Arbitrary UI.SetObject.SetObject where - arbitrary = fmap (UI.SetObject.mkSearchDepth . (+ Input.SearchOptions.minimumSearchDepth) . fromInteger . (`mod` 4)) Test.QuickCheck.arbitrary + arbitrary = Test.QuickCheck.oneof [ +-- UI.SetObject.mkEPD <$> Test.QuickCheck.arbitrary, -- CAVEAT: this is problematic, since move-information is irretrievably lost from the game in the conversion to EPD. + Test.QuickCheck.elements $ map UI.SetObject.mkSearchDepth $ take 4 [Input.SearchOptions.minimumSearchDepth .. ] + ] -- | The constant test-results for this data-type. results :: IO [Test.QuickCheck.Result] @@ -54,6 +58,4 @@ f setObject = Test.QuickCheck.label "SetObject.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage (`elem` (".-+eEoOxX" ++ ['0' .. '9'])) setObject in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 1024} f ] - - diff --git a/src-test/HUnit.hs b/src-test/HUnit.hs --- a/src-test/HUnit.hs +++ b/src-test/HUnit.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {- Copyright (C) 2021 Dr. Alistair Ward @@ -42,16 +41,13 @@ import qualified BishBosh.Test.HUnit.Model.Game as Test.HUnit.Model.Game import qualified BishBosh.Test.HUnit.Model.GameTree as Test.HUnit.Model.GameTree import qualified BishBosh.Test.HUnit.Model.PositionHashTree as Test.HUnit.Model.PositionHashTree +import qualified BishBosh.Test.HUnit.Search.Search as Test.HUnit.Search.Search 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 -import qualified BishBosh.Test.HUnit.Search.Search as Test.HUnit.Search.Search -#endif - -- | Entry-point to the test-suite. main :: IO () main = mapM_ Test.HUnit.runTestTT [ @@ -75,9 +71,7 @@ Test.HUnit.ContextualNotation.PGN.testCases, Test.HUnit.ContextualNotation.PositionHashQualifiedMoveTree.testCases, Test.HUnit.Input.Options.testCases, -#ifdef USE_SEARCH - Test.HUnit.Search.Search.testCases, -#endif - Test.HUnit.Evaluation.Fitness.testCases + Test.HUnit.Evaluation.Fitness.testCases, + Test.HUnit.Search.Search.testCases ] diff --git a/src-test/QuickCheck.hs b/src-test/QuickCheck.hs --- a/src-test/QuickCheck.hs +++ b/src-test/QuickCheck.hs @@ -34,7 +34,6 @@ import qualified BishBosh.Test.QuickCheck.Component.Piece as Test.QuickCheck.Component.Piece import qualified BishBosh.Test.QuickCheck.Component.QualifiedMove as Test.QuickCheck.Component.QualifiedMove import qualified BishBosh.Test.QuickCheck.Component.Turn as Test.QuickCheck.Component.Turn -import qualified BishBosh.Test.QuickCheck.Component.Zobrist as Test.QuickCheck.Component.Zobrist import qualified BishBosh.Test.QuickCheck.ContextualNotation.PGN as Test.QuickCheck.ContextualNotation.PGN import qualified BishBosh.Test.QuickCheck.ContextualNotation.PGNComment as Test.QuickCheck.ContextualNotation.PGNComment import qualified BishBosh.Test.QuickCheck.ContextualNotation.PositionHashQualifiedMoveTree as Test.QuickCheck.ContextualNotation.PositionHashQualifiedMoveTree @@ -51,7 +50,9 @@ import qualified BishBosh.Test.QuickCheck.Model.Game as Test.QuickCheck.Model.Game 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.Notation.Figurine as Test.QuickCheck.Notation.Figurine import qualified BishBosh.Test.QuickCheck.Notation.ICCFNumeric as Test.QuickCheck.Notation.ICCFNumeric +import qualified BishBosh.Test.QuickCheck.Notation.MoveNotation as Test.QuickCheck.Notation.MoveNotation 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 @@ -63,6 +64,8 @@ import qualified BishBosh.Test.QuickCheck.State.InstancesByPosition as Test.QuickCheck.State.InstancesByPosition import qualified BishBosh.Test.QuickCheck.State.Position as Test.QuickCheck.State.Position import qualified BishBosh.Test.QuickCheck.StateProperty.Censor as Test.QuickCheck.StateProperty.Censor +import qualified BishBosh.Test.QuickCheck.StateProperty.Hashable as Test.QuickCheck.StateProperty.Hashable +import qualified BishBosh.Test.QuickCheck.StateProperty.Seeker as Test.QuickCheck.StateProperty.Seeker import qualified BishBosh.Test.QuickCheck.State.TurnsByLogicalColour as Test.QuickCheck.State.TurnsByLogicalColour import qualified BishBosh.Test.QuickCheck.Text.Encoding as Test.QuickCheck.Text.Encoding import qualified BishBosh.Test.QuickCheck.UI.Command as Test.QuickCheck.UI.Command @@ -95,19 +98,22 @@ Test.QuickCheck.Component.Turn.results, Test.QuickCheck.Rule.GameTerminationReason.results, Test.QuickCheck.Rule.Result.results, + Test.QuickCheck.Notation.Figurine.results, Test.QuickCheck.Notation.ICCFNumeric.results, Test.QuickCheck.Notation.PureCoordinate.results, Test.QuickCheck.Notation.Smith.results, + Test.QuickCheck.Notation.MoveNotation.results, Test.QuickCheck.State.CastleableRooksByLogicalColour.results, Test.QuickCheck.State.Position.results, Test.QuickCheck.State.InstancesByPosition.results, Test.QuickCheck.State.Board.results, Test.QuickCheck.State.TurnsByLogicalColour.results, Test.QuickCheck.StateProperty.Censor.results, + Test.QuickCheck.StateProperty.Hashable.results, + Test.QuickCheck.StateProperty.Seeker.results, Test.QuickCheck.Model.Game.results, Test.QuickCheck.Model.GameTree.results, Test.QuickCheck.Model.MoveFrequency.results, - Test.QuickCheck.Component.Zobrist.results, Test.QuickCheck.ContextualNotation.PositionHashQualifiedMoveTree.results, Test.QuickCheck.ContextualNotation.StandardAlgebraic.results, Test.QuickCheck.ContextualNotation.PGNComment.results,