diff --git a/.ghci b/.ghci --- a/.ghci +++ b/.ghci @@ -1,1 +1,1 @@ -:set -isrc-lib:src-exe:src-test:dist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h -Wall -fno-warn-tabs +:set -isrc-lib:src-exe:src-test -Wall -fno-warn-tabs diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -9,7 +9,7 @@ ## Installation -It can be built and installed using [Cabal](https://www.haskell.org/cabal/users-guide/installing-packages.html). +It can be built and installed using [Cabal](https://www.haskell.org/cabal/users-guide/installing-packages.html) or [The Haskell Tool Stack](https://docs.haskellstack.org/en/stable/README/). ## Documentation @@ -25,11 +25,10 @@ ## Testing -The test-suite can be run using: +The test-suite can be run using either of: - cabal configure --enable-tests; - cabal build; - cabal test --show-details=always; +* cabal configure --enable-tests && cabal build && cabal test --show-details=always; +* stack test; It's currently only been tested on **Linux**. diff --git a/bishbosh.cabal b/bishbosh.cabal --- a/bishbosh.cabal +++ b/bishbosh.cabal @@ -14,7 +14,7 @@ -- along with BishBosh. If not, see . Name: bishbosh -Version: 0.0.0.7 +Version: 0.0.0.8 Cabal-version: >= 1.10 Copyright: (C) 2018 Dr. Alistair Ward License: GPL @@ -60,13 +60,17 @@ Default: False -- Automatically disabled when the required package isn't available. --- To manually disable, use "runhaskell Setup configure -f -polyparse --verbose"; which may be required to access Parsec's more precise error-messages. +-- 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 manually disable, use "runhaskell Setup configure -f -hxtrelaxng --verbose", under which circumstances the XML-configuration will be validated against the packaged DTD instead. +-- 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; flag hxtrelaxng Description: Link with package "hxt-relaxng" when available, for more precise specification of the XML-configuration than a traditional DTD. Default: True @@ -156,11 +160,12 @@ BishBosh.Model.MoveFrequency BishBosh.Model.PositionHashTree BishBosh.Model.Result - BishBosh.Notation.Coordinate BishBosh.Notation.ICCFNumeric BishBosh.Notation.MoveNotation + BishBosh.Notation.PureCoordinate BishBosh.Notation.Smith BishBosh.Property.Empty + BishBosh.Property.ExtendedPositionDescription BishBosh.Property.ForsythEdwards BishBosh.Property.Null BishBosh.Property.Opposable @@ -377,9 +382,9 @@ BishBosh.Test.QuickCheck.Model.GameTree BishBosh.Test.QuickCheck.Model.MoveFrequency BishBosh.Test.QuickCheck.Model.Result - BishBosh.Test.QuickCheck.Notation.Coordinate BishBosh.Test.QuickCheck.Notation.ICCFNumeric BishBosh.Test.QuickCheck.Notation.MoveNotation + BishBosh.Test.QuickCheck.Notation.PureCoordinate BishBosh.Test.QuickCheck.Notation.Smith BishBosh.Test.QuickCheck.Search.KillerMoves BishBosh.Test.QuickCheck.Search.Search 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.0.0.7 +Version: 0.0.0.8 Release: 1 License: GPLv3 # From '/usr/share/doc/packages/rpm/GROUPS'. diff --git a/bishbosh.svg b/bishbosh.svg --- a/bishbosh.svg +++ b/bishbosh.svg @@ -1,1527 +1,1827 @@ - - - - -G - -cluster_0 - -BishBosh - -cluster_1 - -Attribute - -cluster_2 - -Cartesian - -cluster_3 - -Component - -cluster_4 - -Concurrent - -cluster_5 - -ContextualNotation - -cluster_6 - -Data - -cluster_7 - -Evaluation - -cluster_8 - -Input - -cluster_9 - -Model - -cluster_10 - -Notation - -cluster_11 - -Property - -cluster_12 - -Search - -cluster_13 - -State - -cluster_14 - -Text - -cluster_15 - -UI - - -u4 - -PhysicalColour - - -u7 - -LogicalColour - - -u8 - -ForsythEdwards - - -u7->u8 - - - - -u9 - -Opposable - - -u7->u9 - - - - -u11 - -MoveType - - -u12 - -Rank - - -u11->u12 - - - - -u5 - -ShowList - - -u11->u5 - - - - -u14 - -Direction - - -u14->u7 - - - - -u15 - -Ordering - - -u14->u15 - - - - -u16 - -Exception - - -u14->u16 - - - - -u17 - -Orientated - - -u14->u17 - - - - -u18 - -Reflectable - - -u14->u18 - - - - -u19 - -LogicalColourOfSquare - - -u19->u7 - - - - -u49 - -ColourScheme - - -u49->u4 - - - - -u49->u16 - - - - -u49->u5 - - - - -u60 - -CaptureMoveSortAlgorithm - - -u65 - -WeightedMeanAndCriterionValues - - -u40 - -ShowFloat - - -u65->u40 - - - - -u65->u5 - - - - -u66 - -RankValues - - -u66->u12 - - - - -u66->u16 - - - - -u67 - -Num - - -u66->u67 - - - - -u66->u40 - - - - -u66->u5 - - - - -u69 - -CriterionValue - - -u69->u65 - - - - -u70 - -CriterionWeight - - -u69->u70 - - - - -u21 - -Types - - -u69->u21 - - - - -u70->u16 - - - - -u70->u67 - - - - -u70->u5 - - - - -u13 - -Coordinates - - -u13->u14 - - - - -u13->u19 - - - - -u22 - -Ordinate - - -u13->u22 - - - - -u23 - -Rotatable - - -u13->u23 - - - - -u13->u5 - - - - -u20 - -Abscissa - - -u20->u21 - - - - -u22->u7 - - - - -u22->u20 - - - - -u24 - -Vector - - -u24->u13 - - - - -u10 - -Move - - -u10->u11 - - - - -u10->u24 - - - - -u27 - -Piece - - -u27->u12 - - - - -u27->u24 - - - - -u28 - -QualifiedMove - - -u28->u10 - - - - -u29 - -Turn - - -u29->u28 - - - - -u31 - -EitherQualifiedMove - - -u31->u10 - - - - -u32 - -Zobrist - - -u32->u12 - - - - -u32->u13 - - - - -u44 - -PieceSquareArray - - -u44->u27 - - - - -u45 - -Bool - - -u44->u45 - - - - -u2 - -SignalHandlers - - -u3 - -Show - - -u2->u3 - - - - -u97 - -Pondering - - -u6 - -PGN - - -u25 - -PGNComment - - -u6->u25 - - - - -u26 - -StandardAlgebraic - - -u6->u26 - - - - -u55 - -Integral - - -u6->u55 - - - - -u30 - -Game - - -u26->u30 - - - - -u56 - -PGNDatabase - - -u56->u6 - - - - -u57 - -QualifiedMoveForest - - -u57->u56 - - - - -u59 - -GameTree - - -u57->u59 - - - - -u95 - -PositionHashQualifiedMoveTree - - -u95->u57 - - - - -u1 - -Float - - -u58 - -RoseTree - - -u81 - -Either - - -u98 - -Time - - -u64 - -PositionHashQuantifiedGameTree - - -u74 - -QuantifiedGame - - -u64->u74 - - - - -u75 - -SearchOptions - - -u64->u75 - - - - -u64->u59 - - - - -u68 - -Fitness - - -u72 - -EvaluationOptions - - -u68->u72 - - - - -u68->u30 - - - - -u74->u68 - - - - -u71 - -CriteriaWeights - - -u71->u69 - - - - -u72->u66 - - - - -u72->u44 - - - - -u72->u71 - - - - -u73 - -PieceSquareTable - - -u72->u73 - - - - -u73->u12 - - - - -u73->u13 - - - - -u73->u45 - - - - -u73->u67 - - - - -u73->u40 - - - - -u75->u60 - - - - -u75->u10 - - - - -u75->u55 - - - - -u76 - -StandardOpeningOptions - - -u75->u76 - - - - -u76->u45 - - - - -u76->u5 - - - - -u77 - -IOOptions - - -u79 - -PGNOptions - - -u77->u79 - - - - -u80 - -UIOptions - - -u77->u80 - - - - -u78 - -CECPFeatures - - -u78->u16 - - - - -u78->u45 - - - - -u78->u5 - - - - -u79->u6 - - - - -u80->u55 - - - - -u80->u81 - - - - -u82 - -CECPOptions - - -u80->u82 - - - - -u83 - -NativeUIOptions - - -u80->u83 - - - - -u84 - -Verbosity - - -u80->u84 - - - - -u36 - -MoveNotation - - -u80->u36 - - - - -u62 - -Tree - - -u80->u62 - - - - -u82->u78 - - - - -u83->u49 - - - - -u85 - -Options - - -u85->u72 - - - - -u85->u75 - - - - -u85->u77 - - - - -u93 - -CommandLineOption - - -u93->u16 - - - - -u34 - -GameTerminationReason - - -u30->u34 - - - - -u30->u36 - - - - -u53 - -InstancesByPosition - - -u30->u53 - - - - -u54 - -Position - - -u30->u54 - - - - -u33 - -DrawReason - - -u33->u10 - - - - -u34->u33 - - - - -u35 - -Result - - -u34->u35 - - - - -u35->u7 - - - - -u59->u60 - - - - -u59->u58 - - - - -u59->u30 - - - - -u61 - -MoveFrequency - - -u59->u61 - - - - -u59->u62 - - - - -u61->u10 - - - - -u41 - -Empty - - -u61->u41 - - - - -u42 - -Null - - -u61->u42 - - - - -u36->u29 - - - - -u36->u31 - - - - -u37 - -Coordinate - - -u36->u37 - - - - -u38 - -ICCFNumeric - - -u36->u38 - - - - -u39 - -Smith - - -u36->u39 - - - - -u36->u40 - - - - -u37->u10 - - - - -u38->u10 - - - - -u39->u28 - - - - -u23->u18 - - - - -u86 - -SearchState - - -u86->u64 - - - - -u87 - -DynamicMoveData - - -u86->u87 - - - - -u87->u29 - - - - -u87->u75 - - - - -u89 - -KillerMoves - - -u87->u89 - - - - -u90 - -Transpositions - - -u87->u90 - - - - -u88 - -EphemeralData - - -u88->u10 - - - - -u89->u41 - - - - -u89->u88 - - - - -u90->u41 - - - - -u90->u88 - - - - -u91 - -TranspositionValue - - -u90->u91 - - - - -u91->u10 - - - - -u99 - -Search - - -u100 - -AlphaBeta - - -u99->u100 - - - - -u100->u86 - - - - -u43 - -Board - - -u47 - -CoordinatesByRankByLogicalColour - - -u43->u47 - - - - -u46 - -Censor - - -u46->u27 - - - - -u48 - -MaybePieceByCoordinates - - -u47->u48 - - - - -u48->u49 - - - - -u48->u10 - - - - -u48->u32 - - - - -u48->u44 - - - - -u48->u41 - - - - -u48->u46 - - - - -u50 - -CastleableRooksByLogicalColour - - -u50->u29 - - - - -u50->u43 - - - - -u51 - -TurnsByLogicalColour - - -u50->u51 - - - - -u51->u10 - - - - -u51->u41 - - - - -u51->u42 - - - - -u52 - -EnPassantAbscissa - - -u52->u29 - - - - -u52->u48 - - - - -u53->u43 - - - - -u54->u50 - - - - -u54->u52 - - - - -u63 - -PlayState - - -u63->u85 - - - - -u63->u86 - - - - -u92 - -ApplicationTerminationReason - - -u63->u92 - - - - -u3->u4 - - - - -u3->u5 - - - - -u96 - -CECP - - -u96->u97 - - - - -u96->u95 - - - - -u96->u98 - - - - -u96->u99 - - - - -u96->u63 - - - - -u101 - -Command - - -u96->u101 - - - - -u101->u85 - - - - -u102 - -PrintObject - - -u101->u102 - - - - -u103 - -SetObject - - -u101->u103 - - - - -u103->u75 - - - - -u104 - -Raw - - -u104->u97 - - - - -u104->u95 - - - - -u104->u98 - - - - -u104->u99 - - - - -u104->u63 - - - - -u104->u3 - - - - -u104->u101 - - - - -u94 - -Play - - -u94->u96 - - - - -u94->u104 - - - - -u0 - -Main - - -u0->u2 - - - - -u0->u1 - - - - -u0->u93 - - - - -u0->u94 - - + + + + +G + + +cluster_0 + +BishBosh + + +cluster_1 + +Attribute + + +cluster_2 + +Cartesian + + +cluster_3 + +Component + + +cluster_4 + +Concurrent + + +cluster_5 + +ContextualNotation + + +cluster_6 + +Data + + +cluster_7 + +Evaluation + + +cluster_8 + +Input + + +cluster_9 + +Model + + +cluster_10 + +Notation + + +cluster_11 + +Property + + +cluster_12 + +Search + + +cluster_13 + +State + + +cluster_14 + +Text + + +cluster_15 + +UI + + + +u3 + +LogicalColour + + + +u5 + +ForsythEdwards + + + +u3->u5 + + + + + +u6 + +Opposable + + + +u3->u6 + + + + + +u8 + +MoveType + + + +u9 + +Rank + + + +u8->u9 + + + + + +u10 + +ShowList + + + +u8->u10 + + + + + +u12 + +Direction + + + +u12->u3 + + + + + +u13 + +Exception + + + +u12->u13 + + + + + +u14 + +Orientated + + + +u12->u14 + + + + + +u15 + +Reflectable + + + +u12->u15 + + + + + +u16 + +LogicalColourOfSquare + + + +u16->u3 + + + + + +u46 + +ColourScheme + + + +u47 + +PhysicalColour + + + +u46->u47 + + + + + +u46->u13 + + + + + +u46->u10 + + + + + +u58 + +CaptureMoveSortAlgorithm + + + +u73 + +RankValues + + + +u73->u9 + + + + + +u73->u13 + + + + + +u74 + +Num + + + +u73->u74 + + + + + +u37 + +ShowFloat + + + +u73->u37 + + + + + +u73->u10 + + + + + +u76 + +CriterionValue + + + +u77 + +CriterionWeight + + + +u76->u77 + + + + + +u78 + +WeightedMeanAndCriterionValues + + + +u76->u78 + + + + + +u18 + +Types + + + +u76->u18 + + + + + +u77->u13 + + + + + +u77->u74 + + + + + +u77->u10 + + + + + +u78->u37 + + + + + +u78->u10 + + + + + +u11 + +Coordinates + + + +u11->u12 + + + + + +u11->u16 + + + + + +u19 + +Ordinate + + + +u11->u19 + + + + + +u20 + +Rotatable + + + +u11->u20 + + + + + +u11->u10 + + + + + +u17 + +Abscissa + + + +u17->u18 + + + + + +u19->u3 + + + + + +u19->u17 + + + + + +u21 + +Vector + + + +u21->u11 + + + + + +u7 + +Move + + + +u7->u8 + + + + + +u7->u21 + + + + + +u24 + +Piece + + + +u24->u9 + + + + + +u24->u21 + + + + + +u25 + +QualifiedMove + + + +u25->u7 + + + + + +u26 + +Turn + + + +u26->u25 + + + + + +u28 + +EitherQualifiedMove + + + +u28->u7 + + + + + +u29 + +Zobrist + + + +u29->u9 + + + + + +u29->u11 + + + + + +u41 + +PieceSquareArray + + + +u41->u24 + + + + + +u42 + +Bool + + + +u41->u42 + + + + + +u97 + +Pondering + + + +u2 + +PGN + + + +u22 + +PGNComment + + + +u2->u22 + + + + + +u23 + +StandardAlgebraic + + + +u2->u23 + + + + + +u53 + +Integral + + + +u2->u53 + + + + + +u27 + +Game + + + +u23->u27 + + + + + +u54 + +PGNDatabase + + + +u54->u2 + + + + + +u55 + +QualifiedMoveForest + + + +u55->u54 + + + + + +u57 + +GameTree + + + +u55->u57 + + + + + +u83 + +PositionHashQualifiedMoveTree + + + +u83->u55 + + + + + +u1 + +Float + + + +u56 + +RoseTree + + + +u67 + +Either + + + +u98 + +Time + + + +u85 + +PositionHashQuantifiedGameTree + + + +u87 + +QuantifiedGame + + + +u85->u87 + + + + + +u80 + +SearchOptions + + + +u85->u80 + + + + + +u85->u57 + + + + + +u86 + +Fitness + + + +u72 + +EvaluationOptions + + + +u86->u72 + + + + + +u86->u27 + + + + + +u87->u86 + + + + + +u61 + +CommandLineOption + + + +u61->u13 + + + + + +u62 + +IOOptions + + + +u64 + +PGNOptions + + + +u62->u64 + + + + + +u66 + +UIOptions + + + +u62->u66 + + + + + +u63 + +CECPFeatures + + + +u63->u13 + + + + + +u63->u42 + + + + + +u63->u10 + + + + + +u64->u2 + + + + + +u65 + +Encoding + + + +u64->u65 + + + + + +u66->u53 + + + + + +u66->u67 + + + + + +u68 + +CECPOptions + + + +u66->u68 + + + + + +u69 + +NativeUIOptions + + + +u66->u69 + + + + + +u70 + +Verbosity + + + +u66->u70 + + + + + +u33 + +MoveNotation + + + +u66->u33 + + + + + +u60 + +Tree + + + +u66->u60 + + + + + +u68->u63 + + + + + +u69->u46 + + + + + +u71 + +Options + + + +u71->u62 + + + + + +u71->u72 + + + + + +u71->u80 + + + + + +u72->u73 + + + + + +u72->u41 + + + + + +u75 + +CriteriaWeights + + + +u72->u75 + + + + + +u79 + +PieceSquareTable + + + +u72->u79 + + + + + +u75->u76 + + + + + +u79->u9 + + + + + +u79->u11 + + + + + +u79->u42 + + + + + +u79->u74 + + + + + +u79->u37 + + + + + +u80->u58 + + + + + +u80->u7 + + + + + +u80->u53 + + + + + +u81 + +StandardOpeningOptions + + + +u80->u81 + + + + + +u81->u42 + + + + + +u81->u10 + + + + + +u31 + +GameTerminationReason + + + +u27->u31 + + + + + +u27->u33 + + + + + +u51 + +InstancesByPosition + + + +u27->u51 + + + + + +u52 + +Position + + + +u27->u52 + + + + + +u30 + +DrawReason + + + +u30->u7 + + + + + +u31->u30 + + + + + +u32 + +Result + + + +u31->u32 + + + + + +u32->u3 + + + + + +u57->u58 + + + + + +u57->u56 + + + + + +u57->u27 + + + + + +u59 + +MoveFrequency + + + +u57->u59 + + + + + +u57->u60 + + + + + +u59->u7 + + + + + +u38 + +Empty + + + +u59->u38 + + + + + +u39 + +Null + + + +u59->u39 + + + + + +u33->u26 + + + + + +u33->u28 + + + + + +u34 + +ICCFNumeric + + + +u33->u34 + + + + + +u35 + +PureCoordinate + + + +u33->u35 + + + + + +u36 + +Smith + + + +u33->u36 + + + + + +u33->u37 + + + + + +u34->u7 + + + + + +u35->u7 + + + + + +u36->u25 + + + + + +u4 + +ExtendedPositionDescription + + + +u5->u4 + + + + + +u20->u15 + + + + + +u84 + +SearchState + + + +u84->u85 + + + + + +u88 + +DynamicMoveData + + + +u84->u88 + + + + + +u88->u26 + + + + + +u88->u80 + + + + + +u90 + +KillerMoves + + + +u88->u90 + + + + + +u91 + +Transpositions + + + +u88->u91 + + + + + +u89 + +EphemeralData + + + +u89->u7 + + + + + +u90->u38 + + + + + +u90->u89 + + + + + +u91->u38 + + + + + +u91->u89 + + + + + +u92 + +TranspositionValue + + + +u91->u92 + + + + + +u92->u7 + + + + + +u99 + +Search + + + +u100 + +AlphaBeta + + + +u99->u100 + + + + + +u100->u84 + + + + + +u40 + +Board + + + +u44 + +CoordinatesByRankByLogicalColour + + + +u40->u44 + + + + + +u43 + +Censor + + + +u43->u24 + + + + + +u45 + +MaybePieceByCoordinates + + + +u44->u45 + + + + + +u45->u46 + + + + + +u45->u7 + + + + + +u45->u29 + + + + + +u45->u41 + + + + + +u45->u38 + + + + + +u45->u43 + + + + + +u48 + +CastleableRooksByLogicalColour + + + +u48->u26 + + + + + +u48->u40 + + + + + +u49 + +TurnsByLogicalColour + + + +u48->u49 + + + + + +u49->u7 + + + + + +u49->u38 + + + + + +u49->u39 + + + + + +u50 + +EnPassantAbscissa + + + +u50->u26 + + + + + +u50->u45 + + + + + +u51->u40 + + + + + +u52->u48 + + + + + +u52->u50 + + + + + +u93 + +PlayState + + + +u93->u71 + + + + + +u93->u84 + + + + + +u94 + +ApplicationTerminationReason + + + +u93->u94 + + + + + +u95 + +Show + + + +u95->u47 + + + + + +u95->u10 + + + + + +u96 + +CECP + + + +u96->u97 + + + + + +u96->u83 + + + + + +u96->u98 + + + + + +u96->u99 + + + + + +u96->u93 + + + + + +u101 + +Command + + + +u96->u101 + + + + + +u101->u71 + + + + + +u102 + +PrintObject + + + +u101->u102 + + + + + +u103 + +SetObject + + + +u101->u103 + + + + + +u103->u80 + + + + + +u104 + +Raw + + + +u104->u97 + + + + + +u104->u83 + + + + + +u104->u98 + + + + + +u104->u99 + + + + + +u104->u93 + + + + + +u104->u95 + + + + + +u104->u101 + + + + + +u82 + +Play + + + +u82->u96 + + + + + +u82->u104 + + + + + +u0 + +Main + + + +u0->u1 + + + + + +u0->u61 + + + + + +u0->u82 + + diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -24,3 +24,7 @@ ## 0.0.0.7 Rewrote function **BishBosh.Data.RoseTree.countTerminalNodes** in accordance with the suggestions of David Feuer. Amended function **BishBosh.State.EnPassantAbscissa.mkMaybeEnPassantAbscissa** to guard against exposing one's King after En-passant capture. + +## 0.0.0.8 +Corrected the parsing of FEN when an Enpassant-destination defined on file **b** was erroneously interpreted as a bishop in the previous **CastleableRooks** field. +Added parent class **BishBosh.Property.ExtendedPositionDescription.EPD** for **Property.ForsythEdwards.FEN**, for which the latter typically has a default implementation of both methods. 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 @@ -63,7 +63,7 @@ --> - + diff --git a/config/bishbosh.dtd b/config/bishbosh.dtd --- a/config/bishbosh.dtd +++ b/config/bishbosh.dtd @@ -109,7 +109,7 @@ > - Coordinate ICCFNumeric + PureCoordinate Smith diff --git a/man/man1/bishbosh.1 b/man/man1/bishbosh.1 --- a/man/man1/bishbosh.1 +++ b/man/man1/bishbosh.1 @@ -93,7 +93,7 @@ Command Arguments Description ======= ========= =========== :hint Request a move-suggestion. -:print object Print the value of one of "\fBboard\fR", "\fBconfiguration\fR", "\fBFEN\fR", "\fBgame\fR", "\fBhelp\fR", "\fBmoves\fR", "\fBPGN\fR". +:print object Print the value of one of "\fBboard\fR", "\fBconfiguration\fR", "\fBEPD\fR", "\fBFEN\fR", "\fBgame\fR", "\fBhelp\fR", "\fBmoves\fR", "\fBPGN\fR". :quit Exit the application. The current game-state will be saved, provided \fBpersistence\fR (see "\fBpgnOptions\fR" in \fBsection-5\fR of the man-pages) hasn't been disabled. :resign Resign the game. :restart Start a new game. diff --git a/man/man5/bishbosh.5 b/man/man5/bishbosh.5 --- a/man/man5/bishbosh.5 +++ b/man/man5/bishbosh.5 @@ -176,7 +176,7 @@ .P "\fBioOptions\fR" has a sub-section "\fBuiOptions\fR", which defines the user-interface. .IP \(bu -\fBmoveNotation\fR (\fBCoordinate\fR|\fBICCFNumeric\fR|\fBSmith\fR), defaulting to "\fBSmith\fR"; <\fBhttps://en.wikipedia.org/wiki/Chess_notation\fR>. The expected syntax used to define a move. +\fBmoveNotation\fR (\fBICCFNumeric\fR|\fBPureCoordinate\fR|\fBSmith\fR), defaulting to "\fBSmith\fR"; <\fBhttps://en.wikipedia.org/wiki/Chess_notation\fR>. The expected syntax used to define a move. This application also understands \fBStandard Algebraic\fR notation, but it is only used to read the PGN-databases used to define standard openings. .IP \(bu \fBprintMoveTree\fR \fIInt\fR. 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 @@ -188,7 +188,7 @@ ) => Model.Game.Game x y -> Transformation column criterionValue criterionWeight pieceSquareValue positionHash rankValue row weightedMean x y updateWithManualMove game playState@MkPlayState { getSearchState = searchState } = setPositionHashQuantifiedGameTree ( Data.Maybe.fromMaybe ( - Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.State.PlayState.updateWithManualMove:\tData.RoseTree.reduce failed." + Control.Exception.throw $ Data.Exception.mkIncompatibleData "BishBosh.State.PlayState.updateWithManualMove:\tEvaluation.PositionHashQuantifiedGameTree.reduce failed." ) . Evaluation.PositionHashQuantifiedGameTree.reduce ( ( == Data.Maybe.fromMaybe ( 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 @@ -71,6 +71,7 @@ import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Search.Search as Search.Search @@ -203,8 +204,6 @@ Integral x, Integral y, Ord positionHash, - Read x, - Read y, Real criterionValue, Real criterionWeight, Real pieceSquareValue, @@ -285,6 +284,7 @@ putStrLn . tellUser =<< case printObject of UI.PrintObject.Board -> return {-to IO-monad-} . show $ Model.Game.getBoard game UI.PrintObject.Configuration -> return {-to IO-monad-} $ Property.ShowFloat.showsFloatToN nDecimalDigits options "." + UI.PrintObject.EPD -> return {-to IO-monad-} $ Property.ExtendedPositionDescription.showEPD game UI.PrintObject.FEN -> return {-to IO-monad-} $ Property.ForsythEdwards.showFEN game UI.PrintObject.Game -> return {-to IO-monad-} $ show game UI.PrintObject.Help -> return {-to IO-monad-} . showString "USAGE: " . showString UI.Command.printTag . showChar ' ' $ Text.ShowList.showsDelimitedList (showChar '|') (showChar '(') (showChar ')') (map shows UI.PrintObject.range) "" @@ -1066,8 +1066,6 @@ Integral x, Integral y, Ord positionHash, - Read x, - Read y, Real criterionValue, Real criterionWeight, Real pieceSquareValue, 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 @@ -51,6 +51,7 @@ import qualified BishBosh.Input.UIOptions as Input.UIOptions import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified BishBosh.Search.Search as Search.Search @@ -193,6 +194,7 @@ case printObject of UI.PrintObject.Board -> putStrLn $ show2D game UI.PrintObject.Configuration -> putStrLn $ Property.ShowFloat.showsFloatToN nDecimalDigits options "." + UI.PrintObject.EPD -> putStrLn $ Property.ExtendedPositionDescription.showEPD game UI.PrintObject.FEN -> putStrLn $ Property.ForsythEdwards.showFEN game UI.PrintObject.Game -> print game UI.PrintObject.Help -> putStrLn . showString "Enter either a move in " . shows moveNotation $ showString "-notation, or:\n" UI.Command.usageMessage diff --git a/src-lib/BishBosh/Attribute/LogicalColour.hs b/src-lib/BishBosh/Attribute/LogicalColour.hs --- a/src-lib/BishBosh/Attribute/LogicalColour.hs +++ b/src-lib/BishBosh/Attribute/LogicalColour.hs @@ -44,8 +44,9 @@ -- isWhite ) where -import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards -import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription +import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Property.Opposable as Property.Opposable import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray @@ -93,16 +94,20 @@ getOpposite Black = White getOpposite _ = Black -instance Property.ForsythEdwards.ReadsFEN LogicalColour where - readsFEN s = case Data.List.Extra.trimStart s of +instance Property.ExtendedPositionDescription.ReadsEPD LogicalColour where + readsEPD s = case Data.List.Extra.trimStart s of 'b' : remainder -> [(Black, remainder)] 'w' : remainder -> [(White, remainder)] _ -> [] -instance Property.ForsythEdwards.ShowsFEN LogicalColour where - showsFEN logicalColour = showChar $ case logicalColour of +instance Property.ExtendedPositionDescription.ShowsEPD LogicalColour where + showsEPD logicalColour = showChar $ case logicalColour of Black -> 'b' White -> 'w' + +instance Property.ForsythEdwards.ReadsFEN LogicalColour + +instance Property.ForsythEdwards.ShowsFEN LogicalColour -- | Whether the specified /logical colour/ is @Black@. isBlack :: LogicalColour -> Bool 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 @@ -73,16 +73,17 @@ import Control.Arrow((&&&), (***)) import Data.Array.IArray((!)) -import qualified BishBosh.Attribute.Direction as Attribute.Direction -import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards -import qualified BishBosh.Property.Opposable as Property.Opposable -import qualified BishBosh.Types as T +import qualified BishBosh.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.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription +import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards +import qualified BishBosh.Property.Opposable as Property.Opposable +import qualified BishBosh.Types as T import qualified Control.DeepSeq import qualified Control.Exception import qualified Data.Array.IArray @@ -90,7 +91,7 @@ import qualified Data.List.Extra import qualified Data.Map import qualified Data.Maybe -import qualified Text.XML.HXT.Arrow.Pickle as HXT +import qualified Text.XML.HXT.Arrow.Pickle as HXT import qualified Text.XML.HXT.Arrow.Pickle.Schema -- | Used to qualify XML. @@ -130,8 +131,8 @@ instance Show Piece where showsPrec _ = Property.ForsythEdwards.showsFEN -instance Property.ForsythEdwards.ReadsFEN Piece where - readsFEN s = case Data.List.Extra.trimStart s of +instance Property.ExtendedPositionDescription.ReadsEPD Piece where + readsEPD s = case Data.List.Extra.trimStart s of c : remainder -> ( MkPiece ( if Data.Char.isUpper c @@ -141,12 +142,16 @@ ) `map` reads [c] _ -> [] -- No parse. -instance Property.ForsythEdwards.ShowsFEN Piece where - showsFEN piece@MkPiece { getRank = rank } = showString . map ( +instance Property.ExtendedPositionDescription.ShowsEPD Piece where + showsEPD piece@MkPiece { getRank = rank } = showString . map ( if isBlack piece then Data.Char.toLower -- Only required for independence from the specific implementation of Read for Rank. else Data.Char.toUpper ) $ show rank + +instance Property.ForsythEdwards.ReadsFEN Piece + +instance Property.ForsythEdwards.ShowsFEN Piece instance HXT.XmlPickler Piece where xpickle = HXT.xpWrap (read, show) . HXT.xpAttr tag . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range 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 @@ -42,24 +42,13 @@ -- longCastleToken, -- shortCastleToken, -- moveSuffixAnnotations, --- xMin, --- yMin, --- xMax, --- yMax, --- xOrigin, --- yOrigin, -- * Functions --- encode, - showsCoordinates, showsTurn, showTurn, showsMove, showMove, movePiece, -- rankParser, --- abscissaParser, --- ordinateParser, --- coordinatesParser, -- captureParser, -- moveSuffixAnnotationParser, parser, @@ -67,18 +56,13 @@ toRank, -- ** Constructors fromQualifiedMove --- ** Predicates --- inXRange, --- inYRange ) where -import Control.Arrow((&&&), (***)) +import Control.Arrow((&&&)) import Data.Array.IArray((!)) 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.Piece as Component.Piece import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove @@ -86,6 +70,7 @@ import qualified BishBosh.Data.Exception as Data.Exception import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason +import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates @@ -151,32 +136,6 @@ moveSuffixAnnotations :: String moveSuffixAnnotations = "!?" --- | 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) -xOrigin, yOrigin :: Int -origin@(xOrigin, yOrigin) = Data.Char.ord *** Data.Char.ord $ min' - --- | 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)) - -- | Defines a /move/, to enable i/o in /StandardAlgebraic/-notation. newtype StandardAlgebraic x y = MkStandardAlgebraic { getQualifiedMove :: Component.QualifiedMove.QualifiedMove x y @@ -186,14 +145,6 @@ fromQualifiedMove :: Component.QualifiedMove.QualifiedMove x y -> StandardAlgebraic x y fromQualifiedMove = MkStandardAlgebraic --- | Encodes the ordinate & abscissa. -encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS) -encode = showChar . Data.Char.chr . (+ (xOrigin - Cartesian.Abscissa.xOrigin)) . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . (+ (yOrigin - Cartesian.Ordinate.yOrigin)) . fromEnum . Cartesian.Coordinates.getY - --- | Shows the specified /coordinates/. -showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS -showsCoordinates = uncurry (.) . encode - -- | Whether en-passant moves are tagged, or implicit. type ExplicitEnPassant = Bool @@ -254,7 +205,7 @@ else checkFlag else id ) - | otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.ContextualNotation.StandardAlgebraic.showsTurn:\tno piece exists at " . showsCoordinates source . showString "; " $ Property.ForsythEdwards.showsFEN game "." + | 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 "." 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 @@ -268,8 +219,8 @@ showsCapture, showsX, showsY, showsDestination :: ShowS showsCapture = showChar captureFlag - (showsX, showsY) = encode source - showsDestination = showsCoordinates destination + (showsX, showsY) = Notation.PureCoordinate.encode source + showsDestination = Notation.PureCoordinate.showsCoordinates destination game' = Model.Game.takeTurn turn game @@ -342,34 +293,6 @@ rankParser :: Text.Poly.TextParser Attribute.Rank.Rank rankParser = toRank `fmap` Poly.satisfyMsg (`elem` map fromRank Attribute.Rank.pieces) Attribute.Rank.tag --- | Parse an /x/-coordinate. -abscissaParser :: Enum x => Text.Poly.TextParser x -{-# SPECIALISE abscissaParser :: Text.Poly.TextParser T.X #-} -abscissaParser = ( - toEnum . (+ (Cartesian.Abscissa.xOrigin - xOrigin)) . Data.Char.ord - ) `fmap` Poly.satisfyMsg inXRange "Abscissa" - --- | Parse a /y/-coordinate. -ordinateParser :: Enum y => Text.Poly.TextParser y -{-# SPECIALISE ordinateParser :: Text.Poly.TextParser T.Y #-} -ordinateParser = ( - toEnum . (+ (Cartesian.Ordinate.yOrigin - yOrigin)) . Data.Char.ord - ) `fmap` Poly.satisfyMsg inYRange "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 T.X T.Y) #-} -coordinatesParser = do - x <- abscissaParser - y <- ordinateParser - - return {-to Parser-monad-} $ Cartesian.Coordinates.mkCoordinates x y - -- | Parse the flag which denotes capture. captureParser :: Text.Poly.TextParser Char captureParser = Poly.satisfyMsg (== captureFlag) "Capture" @@ -378,30 +301,6 @@ rankParser :: Parsec.Parser Attribute.Rank.Rank rankParser = toRank <$> Parsec.oneOf (map fromRank Attribute.Rank.pieces) Attribute.Rank.tag --- | Parse an /x/-coordinate. -abscissaParser :: Enum x => Parsec.Parser x -{-# SPECIALISE abscissaParser :: Parsec.Parser T.X #-} -abscissaParser = ( - toEnum . (+ (Cartesian.Abscissa.xOrigin - xOrigin)) . Data.Char.ord - ) <$> Parsec.satisfy inXRange "Abscissa" - --- | Parse a /y/-coordinate. -ordinateParser :: Enum y => Parsec.Parser y -{-# SPECIALISE ordinateParser :: Parsec.Parser T.X #-} -ordinateParser = ( - toEnum . (+ (Cartesian.Ordinate.yOrigin - yOrigin)) . Data.Char.ord - ) <$> Parsec.satisfy inYRange "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 T.X T.Y) #-} -coordinatesParser = Cartesian.Coordinates.mkCoordinates <$> abscissaParser <*> ordinateParser - -- | Parse the flag which denotes capture. captureParser :: Parsec.Parser () captureParser = Control.Monad.void (Parsec.char captureFlag "Capture") @@ -461,7 +360,7 @@ ( "Pawn-advance", do - destination <- coordinatesParser + destination <- Notation.PureCoordinate.coordinatesParser Data.Maybe.maybe ( do @@ -480,9 +379,9 @@ ), ( "Pawn-capture", do - x <- abscissaParser + x <- Notation.PureCoordinate.abscissaParser _ <- captureParser - destination <- Poly.commit coordinatesParser + destination <- Poly.commit Notation.PureCoordinate.coordinatesParser let maybeDestinationRank = getMaybeRank destination @@ -532,8 +431,8 @@ ( "Fully qualified move", -- N.B. this scenario occurs when there are identical pieces on both the same row & the same column, as the intended attacker; i.e. after a promotion. do - source <- coordinatesParser - destination <- Control.Applicative.optional captureParser >> coordinatesParser + source <- Notation.PureCoordinate.coordinatesParser + destination <- Control.Applicative.optional captureParser >> Notation.PureCoordinate.coordinatesParser return {-to Parser-monad-} . Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination ), ( @@ -544,22 +443,22 @@ "Abscissa qualification", ( \x -> filter $ (== x) . Cartesian.Coordinates.getX - ) `fmap` abscissaParser + ) `fmap` Notation.PureCoordinate.abscissaParser ), ( "Ordinate qualification", ( \y -> filter $ (== y) . Cartesian.Coordinates.getY - ) `fmap` ordinateParser + ) `fmap` Notation.PureCoordinate.ordinateParser ) ] -- Build a filter from the source-qualifier. - destination <- Control.Applicative.optional captureParser >> coordinatesParser + destination <- Control.Applicative.optional captureParser >> Notation.PureCoordinate.coordinatesParser resolveQualifiedMove destination . sourceFilter $ findAttacksBy destination ), ( "Unqualified move", -- The most likely scenario, where the intended attacker is unambiguous. Poly.commit $ do - destination <- Control.Applicative.optional captureParser >> coordinatesParser + destination <- Control.Applicative.optional captureParser >> Notation.PureCoordinate.coordinatesParser resolveQualifiedMove destination $ findAttacksBy destination ) @@ -616,7 +515,7 @@ promotionParser = (Parsec.char promotionFlag "Promotion") >> rankParser in Parsec.try ( do - destination <- coordinatesParser "Destination" + destination <- Notation.PureCoordinate.coordinatesParser "Destination" Data.Maybe.maybe ( fail . showString "Failed to locate any " . shows piece . showString " which can advance to " $ shows destination "." @@ -630,8 +529,8 @@ >>= Cartesian.Coordinates.maybeRetreat nextLogicalColour ) $ Just destination ) <|> do - x <- abscissaParser <* captureParser - destination <- coordinatesParser "Destination" + x <- Notation.PureCoordinate.abscissaParser <* captureParser + destination <- Notation.PureCoordinate.coordinatesParser "Destination" let maybeDestinationRank = getMaybeRank destination @@ -669,33 +568,33 @@ ] -- List-comprehension. in Parsec.choice [ Parsec.try $ do -- N.B. this scenario occurs when there are identical pieces on both the same row & the same column, as the intended attacker; i.e. after a promotion. - source <- coordinatesParser "Source" + source <- Notation.PureCoordinate.coordinatesParser "Source" Parsec.optional captureParser "Optional capture" - destination <- coordinatesParser "Destination" + destination <- Notation.PureCoordinate.coordinatesParser "Destination" return {-to ParsecT-monad-} . Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination, Parsec.try $ do -- This scenario occurs if there's an identical piece on either the same row or the same column, as the intended attacker. sourceFilter <- ( ( \x -> filter $ (== x) . Cartesian.Coordinates.getX - ) <$> abscissaParser + ) <$> Notation.PureCoordinate.abscissaParser ) <|> ( ( \y -> filter $ (== y) . Cartesian.Coordinates.getY - ) <$> ordinateParser + ) <$> Notation.PureCoordinate.ordinateParser ) -- Build a filter from the source-qualifier. Parsec.optional captureParser "Optional capture" - destination <- coordinatesParser "Destination" + destination <- Notation.PureCoordinate.coordinatesParser "Destination" resolveQualifiedMove destination . sourceFilter $ findAttacksBy destination, do -- The most likely scenario, where the intended attacker is unambiguous. Parsec.optional captureParser "Optional capture" - destination <- coordinatesParser "Unqualified destination" + destination <- Notation.PureCoordinate.coordinatesParser "Unqualified destination" resolveQualifiedMove destination $ findAttacksBy destination ], diff --git a/src-lib/BishBosh/Input/CECPFeatures.hs b/src-lib/BishBosh/Input/CECPFeatures.hs --- a/src-lib/BishBosh/Input/CECPFeatures.hs +++ b/src-lib/BishBosh/Input/CECPFeatures.hs @@ -180,7 +180,7 @@ reuseTag :: Key reuseTag = "reuse" --- | Tags the feature which defines whether the GUI may send moves in "SAN" rather than "Coordinate" notation. +-- | Tags the feature which defines whether the GUI may send moves in "SAN" rather than "PureCoordinate" notation. sanTag :: Key sanTag = "san" @@ -294,7 +294,7 @@ ), ( reuseTag, true -- Whether xboard may reuse this engine for multiple games. ), ( - sanTag, false -- Whether xboard sends moves in "Standard Algebraic Notation" rather than "Coordinate". + sanTag, false -- Whether xboard sends moves in "Standard Algebraic Notation" rather than "PureCoordinate". ), ( setboardTag, true -- Whether xboard may send the "setboard" command, to define the board. ), ( diff --git a/src-lib/BishBosh/Input/UIOptions.hs b/src-lib/BishBosh/Input/UIOptions.hs --- a/src-lib/BishBosh/Input/UIOptions.hs +++ b/src-lib/BishBosh/Input/UIOptions.hs @@ -205,7 +205,7 @@ | ( const False `either` const True ) eitherNativeUIOrCECPOptions && not ( - Notation.MoveNotation.isCoordinate moveNotation + Notation.MoveNotation.isPureCoordinate moveNotation ) = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.Input.UIOptions.mkUIOptions:\t" . shows Input.CECPOptions.tag . showString " is incompatible with " . showString Notation.MoveNotation.tag . Text.ShowList.showsAssociation $ shows moveNotation "." | otherwise = MkUIOptions { getMoveNotation = moveNotation, 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 @@ -109,7 +109,9 @@ import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Model.Result as Model.Result import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.Empty as Property.Empty +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Null as Property.Null import qualified BishBosh.Property.Opposable as Property.Opposable @@ -324,29 +326,26 @@ ) Attribute.LogicalColour.range } --- CAVEAT: some information is lost during 'showsFEN', which can't subsequently be recovered by 'readsFEN'. instance ( Enum x, Enum y, Ord x, Ord y, - Read x, - Read y, Show x, Show y - ) => Property.ForsythEdwards.ReadsFEN (Game x y) where - {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game T.X T.Y) #-} - readsFEN s = [ + ) => Property.ExtendedPositionDescription.ReadsEPD (Game x y) where + {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Game T.X T.Y) #-} + readsEPD s = [ ( mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour, - remainder -- En-passant target, half-move clock, full-move number. + s4 ) | - (board, s1) <- Property.ForsythEdwards.readsFEN s, - (nextLogicalColour, s2) <- Property.ForsythEdwards.readsFEN s1, - (castleableRooksByLogicalColour, s3) <- Property.ForsythEdwards.readsFEN s2, - (turnsByLogicalColour, remainder) <- case Data.List.Extra.trimStart s3 of - '-' : remainder -> [(Property.Empty.empty {-TurnsByLogicalColour-}, remainder)] - s4 -> Control.Arrow.first ( + (board, s1) <- Property.ExtendedPositionDescription.readsEPD s, + (nextLogicalColour, s2) <- Property.ExtendedPositionDescription.readsEPD s1, + (castleableRooksByLogicalColour, s3) <- Property.ExtendedPositionDescription.readsEPD s2, + (turnsByLogicalColour, s4) <- case Data.List.Extra.trimStart s3 of + '-' : s4' -> [(Property.Empty.empty {-TurnsByLogicalColour-}, s4')] + s3' -> Control.Arrow.first ( \enPassantDestination -> let opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour in State.TurnsByLogicalColour.fromAssocs [ @@ -360,13 +359,15 @@ Component.QualifiedMove.mkQualifiedMove ( uncurry Component.Move.mkMove $ ( uncurry Cartesian.Coordinates.retreat &&& uncurry Cartesian.Coordinates.advance - ) (opponentsLogicalColour, enPassantDestination) -- Construct a Pawn double-advance. + ) (opponentsLogicalColour, enPassantDestination) -- Reconstruct the recent Pawn double-advance. ) Data.Default.def {-move-type-} ) Attribute.Rank.Pawn ] -- Singleton. ) -- Pair. ] - ) `map` reads s4 + ) `map` ( + Notation.PureCoordinate.readsCoordinates s3' + ) {-En-passant destination-} ] -- List-comprehension. instance ( @@ -374,26 +375,23 @@ Enum y, Ord x, Ord y - ) => Property.ForsythEdwards.ShowsFEN (Game x y) where - showsFEN game@MkGame { + ) => Property.ExtendedPositionDescription.ShowsEPD (Game x y) where + showsEPD game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, - getBoard = board, - getTurnsByLogicalColour = turnsByLogicalColour, - getInstancesByPosition = instancesByPosition - } = Text.ShowList.showsDelimitedList Property.ForsythEdwards.showsSeparator id id [ - Property.ForsythEdwards.showsFEN board, -- Placement of pieces. - Property.ForsythEdwards.showsFEN nextLogicalColour, -- Active colour. - Property.ForsythEdwards.showsFEN castleableRooksByLogicalColour, -- Castling availability. - Data.Maybe.maybe Property.ForsythEdwards.showsNullField ( + getBoard = board + } = Text.ShowList.showsDelimitedList Property.ExtendedPositionDescription.showsSeparator id id [ + Property.ExtendedPositionDescription.showsEPD board, -- 1. Placement of pieces. + Property.ExtendedPositionDescription.showsEPD nextLogicalColour, -- 2. Active colour. + Property.ExtendedPositionDescription.showsEPD castleableRooksByLogicalColour, -- 3. Castling availability. + Data.Maybe.maybe Property.ExtendedPositionDescription.showsNullField ( \turn -> if Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) turn then Notation.MoveNotation.showsNotation Data.Default.def {-Smith is the same as the required Algebraic notation in this limited role-} . Cartesian.Coordinates.advance nextLogicalColour . Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove turn - else Property.ForsythEdwards.showsNullField - ) $ maybeLastTurn game, -- En-passant target square. CAVEAT: in contrast to X-FEN, the opponent isn't required to have a Pawn in position to take en-passant. - shows $ State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition, -- Half move clock. - shows . succ {-the full-move count starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference Attribute.LogicalColour.Black turnsByLogicalColour -- Full move number. + else Property.ExtendedPositionDescription.showsNullField + ) $ maybeLastTurn game -- 4. En-passant target square. CAVEAT: in contrast to X-EPD, this is required even when there's no opposing Pawn in a suitable position to take en-passant. ] +-- CAVEAT: some information is lost during 'showsFEN', which can't subsequently be recovered by 'readsFEN'. instance ( Enum x, Enum y, @@ -401,6 +399,37 @@ Ord y, Show x, Show y + ) => Property.ForsythEdwards.ReadsFEN (Game x y) where + {-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game T.X T.Y) #-} + readsFEN s = [ + (game, s3) | + (game, s1) <- Property.ExtendedPositionDescription.readsEPD s, + (_halfMoveClock, s2) <- reads s1 :: [(Int, String)], + (_fullMoveCounter, s3) <- reads s2 :: [(Int, String)] + ] -- List-comprehension. + +instance ( + Enum x, + Enum y, + Ord x, + Ord y + ) => Property.ForsythEdwards.ShowsFEN (Game x y) where + showsFEN game@MkGame { + getTurnsByLogicalColour = turnsByLogicalColour, + getInstancesByPosition = instancesByPosition + } = Text.ShowList.showsDelimitedList Property.ExtendedPositionDescription.showsSeparator id id [ + Property.ExtendedPositionDescription.showsEPD game, + shows $ State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition, -- 5. Half move clock. + shows . succ {-the full-move counter starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference Attribute.LogicalColour.Black turnsByLogicalColour -- 6. Full move counter. + ] + +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 T.X T.Y) #-} empty = Data.Default.def -- i.e. zero turns have been taken, rather than zero pieces remain (which is illegal). @@ -986,7 +1015,7 @@ Attribute.Rank.Knight -> [ ( distance `notElem` Cartesian.Vector.attackVectorsForKnight, - "the jump must be to the opposite corner of a 3 x 2 rectangle." + "the jump must be to the opposite corner of a 3 x 2 rectangle" ) -- Pair. ] Attribute.Rank.Bishop -> [ diff --git a/src-lib/BishBosh/Notation/Coordinate.hs b/src-lib/BishBosh/Notation/Coordinate.hs deleted file mode 100644 --- a/src-lib/BishBosh/Notation/Coordinate.hs +++ /dev/null @@ -1,153 +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@] - - * . - - * CAVEAT: defined a variant of this notation. - - * N.B.: used for communication via /CECP/ with /xboard/. --} - -module BishBosh.Notation.Coordinate( --- * Types --- ** Data-types - Coordinate( --- MkCoordinate, - getMove --- getMaybePromotionRank - ), --- * Constants --- xOrigin, --- yOrigin, - origin, - regexSyntax, --- * Functions --- encode, - showsCoordinates, --- ** Constructors - mkCoordinate, - mkCoordinate' -) 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 Control.Arrow -import qualified Control.Exception -import qualified Data.Char -import qualified Data.List.Extra -import qualified Data.Maybe - --- | The /x/-origin. -xOrigin :: Int -xOrigin = Data.Char.ord 'a' - --- | The /y/-origin. -yOrigin :: Int -yOrigin = Data.Char.ord '1' - --- | The origin. -origin :: (Int, Int) -origin = (xOrigin, yOrigin) - --- | Defines using a regex, the required syntax. -regexSyntax :: String -regexSyntax = showString "([a-h][1-8]){2}[" $ showString ( - concatMap show Attribute.Rank.promotionProspects - ) "]?" - --- | Defines a /move/, to enable i/o in /Coordinate/-notation. -data Coordinate x y = MkCoordinate { - getMove :: Component.Move.Move x y, - getMaybePromotionRank :: Maybe Attribute.Rank.Rank -} deriving Eq - --- | Smart constructor. -mkCoordinate :: Component.Move.Move x y -> Maybe Attribute.Rank.Rank -> Coordinate x y -mkCoordinate move maybePromotionRank - | Just rank <- maybePromotionRank - , rank `notElem` Attribute.Rank.promotionProspects = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Notation.Coordinate.Coordinate:\tcan't promote to a " $ shows rank "." - | otherwise = MkCoordinate { - getMove = move, - getMaybePromotionRank = maybePromotionRank - } - --- | Smart constructor. -mkCoordinate' :: Attribute.Rank.Promotable promotable => Component.Move.Move x y -> promotable -> Coordinate x y -mkCoordinate' move = mkCoordinate 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 . (+ (xOrigin - Cartesian.Abscissa.xOrigin)) . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . (+ (yOrigin - Cartesian.Ordinate.yOrigin)) . 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 (Coordinate x y) where - showsPrec _ MkCoordinate { - getMove = move, - getMaybePromotionRank = maybePromotionRank - } = showsCoordinates ( - Component.Move.getSource move - ) . showsCoordinates ( - 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 (Coordinate x y) 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'' + (Cartesian.Abscissa.xOrigin - xOrigin) - ) ( - toEnum $ Data.Char.ord y'' + (Cartesian.Ordinate.yOrigin - yOrigin) - ) - in [ - Control.Arrow.first ( - mkCoordinate $ Component.Move.mkMove source destination - ) ( - case reads $ take 1 remainder of - [(rank, "")] -> if rank `elem` Attribute.Rank.promotionProspects - then (Just rank, tail remainder) - else (Nothing, remainder) - _ -> (Nothing, remainder) - ) | - source <- Data.Maybe.maybeToList $ translate x y, - destination <- Data.Maybe.maybeToList $ translate x' y', - source /= destination - ] -- List-comprehension. - _ -> [] -- No parse. - -instance Attribute.Rank.Promotable (Coordinate x y) 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 @@ -31,7 +31,7 @@ MoveNotation(), -- * Constants tag, - coordinate, + pureCoordinate, range, -- * Functions readsQualifiedMove, @@ -40,7 +40,7 @@ getOrigin, showsNotationFloatToNDecimals, -- ** Predicates - isCoordinate + isPureCoordinate ) where import Control.Arrow((&&&)) @@ -49,8 +49,8 @@ import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove import qualified BishBosh.Component.Turn as Component.Turn -import qualified BishBosh.Notation.Coordinate as Notation.Coordinate import qualified BishBosh.Notation.ICCFNumeric as Notation.ICCFNumeric +import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Notation.Smith as Notation.Smith import qualified BishBosh.Property.ShowFloat as Property.ShowFloat import qualified Control.Arrow @@ -70,9 +70,9 @@ * /Standard Algebraic/ isn't included here because conversion to or from a /QualifiedMove/ requires access to the /game/. -} data MoveNotation - = Coordinate -- ^ As used for communication with /xboard/. - | ICCFNumeric -- ^ . - | Smith -- ^ . + = ICCFNumeric -- ^ . + | PureCoordinate -- ^ As used for communication with /xboard/ & as the basis of Standard Algebraic. + | Smith -- ^ . deriving (Eq, Read, Show) instance Control.DeepSeq.NFData MoveNotation where @@ -85,12 +85,12 @@ xpickle = HXT.xpDefault Data.Default.def . HXT.xpWrap (read, show) . HXT.xpAttr tag . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range -- CAVEAT: whether it'll be used as an XML-attribute or an XML-element isn't currently known. -- | Constant. -coordinate :: MoveNotation -coordinate = Coordinate +pureCoordinate :: MoveNotation +pureCoordinate = PureCoordinate -- | The constant complete range of values. range :: [MoveNotation] -range = [Coordinate, ICCFNumeric, Smith] +range = [ICCFNumeric, PureCoordinate, Smith] -- | Reads a /move/ & /move-type/ from the specified 'MoveNotation'. readsQualifiedMove :: ( @@ -101,29 +101,29 @@ ) => MoveNotation -> ReadS (Component.EitherQualifiedMove.EitherQualifiedMove x y) -readsQualifiedMove Coordinate = map (Control.Arrow.first $ uncurry Component.EitherQualifiedMove.mkPartiallyQualifiedMove . (Notation.Coordinate.getMove &&& Attribute.Rank.getMaybePromotionRank)) . reads 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 -- | Show the syntax required by a specific 'MoveNotation'. showsMoveSyntax :: MoveNotation -> ShowS showsMoveSyntax moveNotation = showChar '/' . showString ( case moveNotation of - Coordinate -> Notation.Coordinate.regexSyntax ICCFNumeric -> Notation.ICCFNumeric.regexSyntax + PureCoordinate -> Notation.PureCoordinate.regexSyntax Smith -> Notation.Smith.regexSyntax ) . showChar '/' -- | Returns the origin of the specified coordinate-system. getOrigin :: MoveNotation -> (Int, Int) -getOrigin Coordinate = Notation.Coordinate.origin -getOrigin ICCFNumeric = Notation.ICCFNumeric.origin -getOrigin Smith = Notation.Smith.origin +getOrigin ICCFNumeric = Notation.ICCFNumeric.origin +getOrigin PureCoordinate = Notation.PureCoordinate.origin +getOrigin Smith = Notation.Smith.origin -- | Predicate. -isCoordinate :: MoveNotation -> Bool -isCoordinate Coordinate = True -isCoordinate _ = False +isPureCoordinate :: MoveNotation -> Bool +isPureCoordinate PureCoordinate = True +isPureCoordinate _ = False -- | An interface for types which can be rendered in a chess-notation. class ShowNotation a where @@ -131,8 +131,8 @@ instance (Enum x, Enum y) => ShowNotation (Component.QualifiedMove.QualifiedMove x y) where showsNotation moveNotation qualifiedMove = case moveNotation of - Coordinate -> shows $ Notation.Coordinate.mkCoordinate' move moveType ICCFNumeric -> shows $ Notation.ICCFNumeric.mkICCFNumeric' move moveType + PureCoordinate -> shows $ Notation.PureCoordinate.mkPureCoordinate' move moveType Smith -> shows $ Notation.Smith.fromQualifiedMove qualifiedMove where (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove @@ -141,8 +141,8 @@ showsNotation moveNotation = showsNotation moveNotation . Component.Turn.getQualifiedMove instance (Enum x, Enum y) => ShowNotation (Cartesian.Coordinates.Coordinates x y) where - showsNotation Coordinate = Notation.Coordinate.showsCoordinates showsNotation ICCFNumeric = Notation.ICCFNumeric.showsCoordinates + showsNotation PureCoordinate = Notation.PureCoordinate.showsCoordinates showsNotation Smith = Notation.Smith.showsCoordinates -- | Show an arbitrary datum using the specified notation. diff --git a/src-lib/BishBosh/Notation/PureCoordinate.hs b/src-lib/BishBosh/Notation/PureCoordinate.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Notation/PureCoordinate.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{- + Copyright (C) 2018 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * . + + * CAVEAT: defined a variant of this notation. + + * N.B.: used for communication via /CECP/ with /xboard/. + + * N.B.: this minimal notation defines the coordinate-system on which Standard Algebraic is based. +-} + +module BishBosh.Notation.PureCoordinate( +-- * Types +-- ** Data-types + PureCoordinate( +-- MkPureCoordinate, + getMove +-- getMaybePromotionRank + ), +-- * Constants +-- min', +-- xMin, +-- xMax, +-- yMin, +-- yMax, +-- xOrigin, +-- yOrigin, + origin, + regexSyntax, +-- * Functions + encode, + showsCoordinates, + readsCoordinates, + abscissaParser, + ordinateParser, + coordinatesParser, +-- ** Constructors + 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.Types as T +import qualified Control.Arrow +import qualified Control.Exception +import qualified Data.Char +import qualified Data.List.Extra +import qualified Data.Maybe + +#ifdef USE_POLYPARSE +import qualified BishBosh.Text.Poly as Text.Poly +#if USE_POLYPARSE == 1 +import qualified Text.ParserCombinators.Poly.Lazy as Poly +#else /* Plain */ +import qualified Text.ParserCombinators.Poly.Plain as Poly +#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) +xOrigin, yOrigin :: Int +origin@(xOrigin, yOrigin) = Data.Char.ord *** Data.Char.ord $ min' + +-- | 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)) + +-- | Defines using a regex, the required syntax. +regexSyntax :: String +regexSyntax = showString "([a-h][1-8]){2}[" $ showString ( + concatMap show Attribute.Rank.promotionProspects + ) "]?" + +#ifdef USE_POLYPARSE +-- | Parse an /x/-coordinate. +abscissaParser :: Enum x => Text.Poly.TextParser x +{-# SPECIALISE abscissaParser :: Text.Poly.TextParser T.X #-} +abscissaParser = ( + toEnum . (+ (Cartesian.Abscissa.xOrigin - xOrigin)) . Data.Char.ord + ) `fmap` Poly.satisfyMsg inXRange "Abscissa" + +-- | Parse a /y/-coordinate. +ordinateParser :: Enum y => Text.Poly.TextParser y +{-# SPECIALISE ordinateParser :: Text.Poly.TextParser T.Y #-} +ordinateParser = ( + toEnum . (+ (Cartesian.Ordinate.yOrigin - yOrigin)) . Data.Char.ord + ) `fmap` Poly.satisfyMsg inYRange "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 T.X T.Y) #-} +coordinatesParser = do + x <- abscissaParser + y <- ordinateParser + + return {-to Parser-monad-} $ Cartesian.Coordinates.mkCoordinates x y +#else +-- | Parse an /x/-coordinate. +abscissaParser :: Enum x => Parsec.Parser x +{-# SPECIALISE abscissaParser :: Parsec.Parser T.X #-} +abscissaParser = ( + toEnum . (+ (Cartesian.Abscissa.xOrigin - xOrigin)) . Data.Char.ord + ) <$> Parsec.satisfy inXRange "Abscissa" + +-- | Parse a /y/-coordinate. +ordinateParser :: Enum y => Parsec.Parser y +{-# SPECIALISE ordinateParser :: Parsec.Parser T.X #-} +ordinateParser = ( + toEnum . (+ (Cartesian.Ordinate.yOrigin - yOrigin)) . Data.Char.ord + ) <$> Parsec.satisfy inYRange "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 T.X T.Y) #-} +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, + getMaybePromotionRank :: Maybe Attribute.Rank.Rank +} deriving Eq + +-- | Smart constructor. +mkPureCoordinate :: Component.Move.Move x y -> Maybe Attribute.Rank.Rank -> PureCoordinate x y +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 "." + | otherwise = MkPureCoordinate { + getMove = move, + getMaybePromotionRank = maybePromotionRank + } + +-- | Smart constructor. +mkPureCoordinate' :: Attribute.Rank.Promotable promotable => Component.Move.Move x y -> promotable -> PureCoordinate x y +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 . (+ (xOrigin - Cartesian.Abscissa.xOrigin)) . fromEnum . Cartesian.Coordinates.getX &&& showChar . Data.Char.chr . (+ (yOrigin - Cartesian.Ordinate.yOrigin)) . 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 + (Cartesian.Abscissa.xOrigin - xOrigin) + ) ( + toEnum $ Data.Char.ord y + (Cartesian.Ordinate.yOrigin - yOrigin) + ) + _ -> [] -- Mo parse. + +instance (Enum x, Enum y) => Show (PureCoordinate x y) where + showsPrec _ MkPureCoordinate { + getMove = move, + getMaybePromotionRank = maybePromotionRank + } = showsCoordinates ( + Component.Move.getSource move + ) . showsCoordinates ( + 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 + 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'' + (Cartesian.Abscissa.xOrigin - xOrigin) + ) ( + toEnum $ Data.Char.ord y'' + (Cartesian.Ordinate.yOrigin - yOrigin) + ) + in [ + Control.Arrow.first ( + mkPureCoordinate $ Component.Move.mkMove source destination + ) ( + case reads $ take 1 remainder of + [(rank, "")] -> if rank `elem` Attribute.Rank.promotionProspects + then (Just rank, tail remainder) + else (Nothing, remainder) + _ -> (Nothing, remainder) + ) | + source <- Data.Maybe.maybeToList $ translate x y, + destination <- Data.Maybe.maybeToList $ translate x' y', + source /= destination + ] -- List-comprehension. + _ -> [] -- No parse. + +instance Attribute.Rank.Promotable (PureCoordinate x y) where + getMaybePromotionRank = getMaybePromotionRank + diff --git a/src-lib/BishBosh/Property/ExtendedPositionDescription.hs b/src-lib/BishBosh/Property/ExtendedPositionDescription.hs new file mode 100644 --- /dev/null +++ b/src-lib/BishBosh/Property/ExtendedPositionDescription.hs @@ -0,0 +1,64 @@ +{- + Copyright (C) 2018 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] + + * . +-} + +module BishBosh.Property.ExtendedPositionDescription( +-- * Type-classes + ReadsEPD(..), + ShowsEPD(..), +-- * Constants + showsNullField, + showsSeparator, +-- * Functions + readEPD, + showEPD +) where + +-- | An alternative to 'Read'. +class ReadsEPD a where + readsEPD :: ReadS a -- ^ Read a datum from EPD. + +-- | An alternative to 'Show'. +class ShowsEPD a where + showsEPD :: a -> ShowS -- ^ Stringify a EPD-datum. + +-- | Read from EPD. +readEPD :: ReadsEPD a => String -> a +readEPD s = case readsEPD s of + [(a, _)] -> a + _ -> error . showString "BishBosh.Property.ExtendedPositionDescription.readEPD:\tfailed to parse " $ shows s "." + +-- | Display in EPD. +showEPD :: ShowsEPD a => a -> String +showEPD a = showsEPD a "" + +-- | The standard way to denote the absence of a field. +showsNullField :: ShowS +showsNullField = showChar '-' + +-- | The standard separator between fields in EPD. +showsSeparator :: ShowS +showsSeparator = showChar ' ' + 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 @@ -30,21 +30,22 @@ -- * Type-classes ReadsFEN(..), ShowsFEN(..), --- * Constants - showsNullField, - showsSeparator, -- * Functions readFEN, showFEN ) where +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription + -- | An alternative to 'Read'. -class ReadsFEN a where +class Property.ExtendedPositionDescription.ReadsEPD a => ReadsFEN a where readsFEN :: ReadS a -- ^ Read a datum from FEN. + readsFEN = Property.ExtendedPositionDescription.readsEPD -- Default implementation. -- | An alternative to 'Show'. -class ShowsFEN a where +class Property.ExtendedPositionDescription.ShowsEPD a => ShowsFEN a where showsFEN :: a -> ShowS -- ^ Stringify a FEN-datum. + showsFEN = Property.ExtendedPositionDescription.showsEPD -- Default implementation. -- | Read from FEN. readFEN :: ReadsFEN a => String -> a @@ -55,12 +56,4 @@ -- | Display in FEN. showFEN :: ShowsFEN a => a -> String showFEN a = showsFEN a "" - --- | The standard way to denote the absence of a field. -showsNullField :: ShowS -showsNullField = showChar '-' - --- | The standard separator between fields in FEN. -showsSeparator :: ShowS -showsSeparator = showChar ' ' 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 @@ -83,6 +83,7 @@ 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 import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Reflectable as Property.Reflectable @@ -176,17 +177,33 @@ Enum y, Ord x, Ord y + ) => Property.ExtendedPositionDescription.ReadsEPD (Board x y) where + {-# SPECIALISE instance Property.ExtendedPositionDescription.ReadsEPD (Board T.X T.Y) #-} + 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 + 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 T.X T.Y) #-} - readsFEN = map (Control.Arrow.first fromMaybePieceByCoordinates) . Property.ForsythEdwards.readsFEN + readsFEN = Property.ExtendedPositionDescription.readsEPD instance ( Enum x, Enum y, Ord x, Ord y - ) => Property.ForsythEdwards.ShowsFEN (Board x y) where - showsFEN MkBoard { getMaybePieceByCoordinates = maybePieceByCoordinates } = Property.ForsythEdwards.showsFEN maybePieceByCoordinates + ) => Property.ForsythEdwards.ShowsFEN (Board x y) instance ( Enum x, 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 @@ -67,6 +67,7 @@ import qualified BishBosh.Component.Turn as Component.Turn import qualified BishBosh.Component.Zobrist as Component.Zobrist import qualified BishBosh.Data.Exception as Data.Exception +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Reflectable as Property.Reflectable @@ -78,6 +79,7 @@ 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 import qualified Data.List.Extra @@ -159,42 +161,46 @@ Enum x, Ord x, Show x - ) => Property.ForsythEdwards.ReadsFEN (CastleableRooksByLogicalColour x) where - readsFEN s = case Data.List.Extra.trimStart s of + ) => Property.ExtendedPositionDescription.ReadsEPD (CastleableRooksByLogicalColour x) where + readsEPD s = case Data.List.Extra.trimStart s of '-' : remainder -> [ ( - MkCastleableRooksByLogicalColour $ Attribute.LogicalColour.range `zip` repeat [], -- CAVEAT: it could also be just '[]'. + MkCastleableRooksByLogicalColour $ Attribute.LogicalColour.range `zip` repeat [], -- CAVEAT: can't disambiguate between this potential value & '[]' which have different semantics for this application. remainder ) -- Pair. ] -- Singleton. s1 -> let - readsAssocs s' = case reads s' of - [(piece, s'')] -> let - logicalColour = Component.Piece.getLogicalColour piece - in case Component.Piece.getRank piece of - Attribute.Rank.Queen -> Control.Arrow.first ( - ( - logicalColour, - Cartesian.Abscissa.xMin - ) : - ) `map` readsAssocs s'' -- Recurse. - Attribute.Rank.King -> Control.Arrow.first ( - ( - logicalColour, - Cartesian.Abscissa.xMax - ) : - ) `map` readsAssocs s'' -- Recurse. - _ -> [] -- Inappropriate rank => parse-failure. - _ -> [([], s')] + readsAssocs s' + | null s' || Data.Char.isSpace (head s') = terminate -- CAVEAT: white space separates this field from the start of the En-passant destination, which should it begin with a 'b' might be interpreted as a Bishop. + | otherwise = case reads s' of + [(piece, s'')] -> case rank of + Attribute.Rank.Queen -> Control.Arrow.first ( + ( + logicalColour, + Cartesian.Abscissa.xMin + ) : {-prepend-} + ) `map` readsAssocs s'' -- Recurse. + Attribute.Rank.King -> Control.Arrow.first ( + ( + logicalColour, + Cartesian.Abscissa.xMax + ) : {-prepend-} + ) `map` readsAssocs s'' -- Recurse. + _ -> [] -- Inappropriate rank => parse-failure. + where + (logicalColour, rank) = Component.Piece.getLogicalColour &&& Component.Piece.getRank $ piece + _ -> terminate + where + terminate = [([], s')] in case readsAssocs s1 of - [([], _)] -> [] -- Zero pieces were read => no parse. + [([], _)] -> [] -- Zero pieces were read => parse-failure. l -> Control.Arrow.first (fromAssocs . Data.List.Extra.groupSort) `map` l -instance (Enum x, Eq x) => Property.ForsythEdwards.ShowsFEN (CastleableRooksByLogicalColour x) where - showsFEN MkCastleableRooksByLogicalColour { getAssocs = assocs } - | all (null . snd) assocs = Property.ForsythEdwards.showsNullField +instance (Enum x, Eq x) => Property.ExtendedPositionDescription.ShowsEPD (CastleableRooksByLogicalColour x) where + showsEPD MkCastleableRooksByLogicalColour { getAssocs = assocs } + | all (null . snd) assocs = Property.ExtendedPositionDescription.showsNullField | otherwise = foldr ( - (.) . Property.ForsythEdwards.showsFEN + (.) . Property.ExtendedPositionDescription.showsEPD ) id [ pieceConstructor logicalColour | logicalColour <- [Attribute.LogicalColour.White, Attribute.LogicalColour.Black], -- N.B.: the order is standardised. @@ -202,6 +208,14 @@ canCastleWith' logicalColour rooksX assocs ] -- List-comprehension. +instance ( + Enum x, + Ord x, + Show x + ) => Property.ForsythEdwards.ReadsFEN (CastleableRooksByLogicalColour x) + +instance (Enum x, Eq x) => Property.ForsythEdwards.ShowsFEN (CastleableRooksByLogicalColour x) + -- | 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 [ @@ -215,7 +229,7 @@ Enum x, Ord x, Show x - ) => [(Attribute.LogicalColour.LogicalColour, [x])] -> CastleableRooksByLogicalColour x + ) => AbscissaeByLogicalColour x -> CastleableRooksByLogicalColour x 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 "." 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 @@ -82,6 +82,7 @@ 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 import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Property.Opposable as Property.Opposable import qualified BishBosh.Property.Reflectable as Property.Reflectable @@ -142,8 +143,8 @@ Enum y, Ord x, Ord y - ) => Property.ForsythEdwards.ReadsFEN (MaybePieceByCoordinates x y) where - readsFEN s + ) => Property.ExtendedPositionDescription.ReadsEPD (MaybePieceByCoordinates x y) where + readsEPD s | length rows /= fromIntegral Cartesian.Ordinate.yLength || any ( (/= fromIntegral Cartesian.Abscissa.xLength) . length ) rows = [] -- No parse. @@ -154,11 +155,11 @@ concatMap ( \c -> case reads [c] of [(i, "")] -> replicate i Nothing -- Expand the runlength-code so that each row has the same length. - _ -> [Just piece | (piece, []) <- Property.ForsythEdwards.readsFEN [c]] -- List-comprehension. + _ -> [Just piece | (piece, []) <- Property.ExtendedPositionDescription.readsEPD [c]] -- List-comprehension. ) ) . Text.ShowList.splitOn (== rankSeparator) ) . span ( - `elem` rankSeparator : concatMap Property.ForsythEdwards.showFEN Component.Piece.range ++ concatMap show [1 .. Cartesian.Abscissa.xLength] + `elem` rankSeparator : concatMap Property.ExtendedPositionDescription.showEPD Component.Piece.range ++ concatMap show [1 .. Cartesian.Abscissa.xLength] ) $ Data.List.Extra.trimStart s instance ( @@ -166,8 +167,8 @@ Enum y, Ord x, Ord y - ) => Property.ForsythEdwards.ShowsFEN (MaybePieceByCoordinates x y) where - showsFEN MkMaybePieceByCoordinates { deconstruct = byCoordinates } = foldr1 ( + ) => Property.ExtendedPositionDescription.ShowsEPD (MaybePieceByCoordinates x y) where + showsEPD MkMaybePieceByCoordinates { deconstruct = byCoordinates } = foldr1 ( flip (.) -- Render the line with the highest y-coordinate first. ) . Data.List.intersperse ( showChar rankSeparator -- Separate the lines. @@ -176,10 +177,24 @@ \(runLength, maybePiece) -> Data.Maybe.maybe [ shows runLength -- Represent empty squares. ] ( - replicate runLength . Property.ForsythEdwards.showsFEN -- Render each piece. + replicate runLength . Property.ExtendedPositionDescription.showsEPD -- Render each piece. ) maybePiece ) . ToolShed.Data.List.Runlength.encode ) . listToRaster $ Data.Array.IArray.elems byCoordinates + +instance ( + Enum x, + Enum y, + Ord x, + Ord y + ) => Property.ForsythEdwards.ReadsFEN (MaybePieceByCoordinates x y) + +instance ( + Enum x, + Enum y, + Ord x, + Ord y + ) => Property.ForsythEdwards.ShowsFEN (MaybePieceByCoordinates x y) instance ( Enum x, 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 @@ -119,7 +119,7 @@ data Command x y = Hint -- ^ Request a move-suggestion. | Print UI.PrintObject.PrintObject -- ^ Show the value of the specified object. - | Quit -- ^ Terminate ths application. + | Quit -- ^ Terminate this application. | Resign -- ^ Admit defeat. | Restart -- ^ Abandon the current game, & start afresh. | RollBack (Maybe Component.Move.NMoves) -- ^ Roll-back the specified number of plies. @@ -147,7 +147,7 @@ ), ( quitTag, Nothing, - "Terminate ths application" + "Terminate this application" ), ( resignTag, Nothing, diff --git a/src-lib/BishBosh/UI/PrintObject.hs b/src-lib/BishBosh/UI/PrintObject.hs --- a/src-lib/BishBosh/UI/PrintObject.hs +++ b/src-lib/BishBosh/UI/PrintObject.hs @@ -29,6 +29,7 @@ -- * Constants boardTag, configurationTag, + epdTag, fenTag, gameTag, helpTag, @@ -54,6 +55,10 @@ configurationTag = "configuration" -- | Input-format. +epdTag :: String +epdTag = "epd" + +-- | Input-format. fenTag :: String fenTag = "fen" @@ -77,6 +82,7 @@ data PrintObject = Board | Configuration + | EPD | FEN | Game | Help @@ -91,6 +97,7 @@ showsPrec _ printObject = showString $ case printObject of Board -> boardTag Configuration -> configurationTag + EPD -> epdTag FEN -> fenTag Game -> gameTag Help -> helpTag @@ -101,6 +108,7 @@ readsPrec _ s = case Control.Arrow.first Data.List.Extra.lower `map` lex s of [("board", remainder)] -> [(Board, remainder)] [("configuration", remainder)] -> [(Configuration, remainder)] + [("epd", remainder)] -> [(EPD, remainder)] [("fen", remainder)] -> [(FEN, remainder)] [("game", remainder)] -> [(Game, remainder)] [("help", remainder)] -> [(Help, remainder)] @@ -110,7 +118,7 @@ -- | The constant unordered list of possible values. range :: [PrintObject] -range = [Board, Configuration, FEN, Game, Help, Moves, PGN] +range = [Board, Configuration, EPD, FEN, Game, Help, Moves, PGN] -- | 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 @@ -120,6 +128,7 @@ tag <- [ boardTag, configurationTag, + epdTag, fenTag, gameTag, helpTag, 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 @@ -45,6 +45,7 @@ import qualified BishBosh.Model.Game as Model.Game import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation +import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates import qualified BishBosh.Text.ShowList as Text.ShowList @@ -267,6 +268,30 @@ [(eitherQualifiedMove, "")] -> Model.Game.isValidEitherQualifiedMove eitherQualifiedMove ( Property.ForsythEdwards.readFEN "r2qkbnr/ppp1pppp/2np4/5b2/3P4/NQP5/PP1BPPPP/R3KBNR w KQkq - 5 6" :: 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 "." + _ -> Control.Exception.throw . Data.Exception.mkParseFailure . showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to parse " $ shows longCastle ".", + let + epds :: [String] + epds = [ + "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -", -- Initial position. + "rnbqkbnr/pppp1ppp/8/3Pp3/8/8/PPP1PPPP/RNBQKBNR w KQkq e6", -- Double Pawn-advance leading to en-passant option. + "rnbqkbnr/pppppppp/8/8/4P3/8/PPPP1PPP/RNBQKBNR b KQkq e3", -- Double Pawn-advance, but no actual en-passant option. + "rnbqkbnr/pp1ppppp/8/2p5/4P3/8/PPPP1PPP/RNBQKBNR w KQkq c6", -- Double Pawn-advance, but no actual en-passant option. + " rnbqkbnr/pppppppp/8/8/1P6/8/P1PPPPPP/RNBQKBNR w\t Kq \r b3", -- Extra white space & potential parser confusion between Casteable Rooks & En-passant destination fields. + "rnbqkr2/p2pbp1p/1pp4n/6N1/PP2pRpP/2N5/R1PPPPP1/2BQKB2 b - -" -- Neither Casteable Rooks nor En-passant destination are defined. + ] + + parseFailures :: [(String, String)] + parseFailures = filter ( + uncurry (/=) + ) $ map ( + \epd -> ( + epd, + case Property.ExtendedPositionDescription.readsEPD epd of + [(game, "")] -> Property.ExtendedPositionDescription.showEPD (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. + ) epds + in not (null parseFailures) ~? (showString "BishBosh.Test.HUnit.Model.Game.testCases:\tfailed to correctly parse EPDs=" $ shows parseFailures ".") ] 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 @@ -70,8 +70,6 @@ sortAvailableMoves :: ( Integral x, Integral y, - Read x, - Read y, Show x, Show y ) => Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> String -> [Component.Turn.Turn x y] diff --git a/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs b/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs --- a/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs +++ b/src-test/BishBosh/Test/QuickCheck/Input/UIOptions.hs @@ -41,7 +41,7 @@ ) => Test.QuickCheck.Arbitrary (Input.UIOptions.UIOptions row column) where arbitrary = do eitherNativeUIOrCECPOptions <- Test.QuickCheck.arbitrary - moveNotation <- const Test.QuickCheck.arbitrary `either` const (return {-to Gen-monad-} Notation.MoveNotation.coordinate) $ eitherNativeUIOrCECPOptions + moveNotation <- const Test.QuickCheck.arbitrary `either` const (return {-to Gen-monad-} Notation.MoveNotation.pureCoordinate) $ eitherNativeUIOrCECPOptions Input.UIOptions.mkUIOptions <$> return {-to Gen-monad-} moveNotation <*> fmap ( fmap $ succ . (`mod` 3) -- maybePrintMoveTree. 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 @@ -119,12 +119,27 @@ f game = Test.QuickCheck.label "Game.prop_fen/Half move clock" $ uncurry (&&) . ( (>= 0) &&& (<= Model.DrawReason.maximumConsecutiveRepeatablePlies) ) . read . ( - !! 4 + !! 4 -- Half-move Clock. ) . words $ Property.ForsythEdwards.showFEN game in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, let f :: Game -> Test.QuickCheck.Property - f game = Test.QuickCheck.label "Game.prop_fen/Full move number" $ (> (0 :: Component.Move.NMoves)) . read . (!! 5) . words $ Property.ForsythEdwards.showFEN game + f game = Test.QuickCheck.label "Game.prop_fen/Full move counter" $ ( + > (0 :: Component.Move.NMoves) + ) . read . ( + !! 5 -- Full Move Counter. + ) . words $ Property.ForsythEdwards.showFEN game + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 256 } f, + let + f :: Game -> Test.QuickCheck.Property + f game = Test.QuickCheck.label "Game.prop_fen" . ( + \game' -> and [ + uncurry (==) $ (($ game) &&& ($ game')) Model.Game.getNextLogicalColour, + uncurry (==) . (($ game) &&& ($ game')) $ State.CastleableRooksByLogicalColour.unify . Model.Game.getCastleableRooksByLogicalColour, + uncurry (==) $ (($ game) &&& ($ game')) Model.Game.getBoard, + uncurry (==) $ (($ game) &&& ($ game')) Model.Game.getMaybeChecked + ] + ) . 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 diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/Coordinate.hs b/src-test/BishBosh/Test/QuickCheck/Notation/Coordinate.hs deleted file mode 100644 --- a/src-test/BishBosh/Test/QuickCheck/Notation/Coordinate.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{- - Copyright (C) 2018 Dr. Alistair Ward - - This file is part of BishBosh. - - BishBosh is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - BishBosh is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with BishBosh. If not, see . --} -{- | - [@AUTHOR@] Dr. Alistair Ward - - [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. --} - -module BishBosh.Test.QuickCheck.Notation.Coordinate( --- * Types --- ** Type-synonyms --- Coordinate, --- * Constants - results -) where - -import BishBosh.Test.QuickCheck.Component.Move() -import Control.Arrow((&&&)) -import qualified BishBosh.Attribute.Rank as Attribute.Rank -import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates -import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate -import qualified BishBosh.Cartesian.Vector as Cartesian.Vector -import qualified BishBosh.Component.Move as Component.Move -import qualified BishBosh.Notation.Coordinate as Notation.Coordinate -import qualified BishBosh.Types as T -import qualified Data.Char -import qualified Test.QuickCheck -import qualified ToolShed.Test.ReversibleIO - --- | Defines a concrete type for testing. -type Coordinate = Notation.Coordinate.Coordinate T.X T.Y - -instance ( - Enum x, - Enum y, - Ord x, - Ord y - ) => Test.QuickCheck.Arbitrary (Notation.Coordinate.Coordinate x y) where - {-# SPECIALISE instance Test.QuickCheck.Arbitrary Coordinate #-} - arbitrary = do - move <- Test.QuickCheck.arbitrary - - Notation.Coordinate.mkCoordinate move `fmap` if abs ( - Cartesian.Vector.getXDistance (Component.Move.measureDistance move :: Cartesian.Vector.VectorInt) - ) <= 1 && ( - Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move - ) `elem` [ - (succ Cartesian.Ordinate.yMin, Cartesian.Ordinate.yMin), -- Black moving down. - (pred Cartesian.Ordinate.yMax, Cartesian.Ordinate.yMax) -- White moving up. - ] - then Test.QuickCheck.oneof [ - return {-to Gen-monad-} Nothing, - Test.QuickCheck.elements $ map Just Attribute.Rank.promotionProspects -- CAVEAT: move & promotionRank are still unlikely to be compatible. - ] - else return {-to Gen-monad-} Nothing - --- | The constant test-results for this data-type. -results :: IO [Test.QuickCheck.Result] -results = sequence [ - let - f :: Coordinate -> Test.QuickCheck.Property - f = Test.QuickCheck.label "Coordinate.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 "Coordinate.prop_read" $ case ( - reads garbage :: [(Notation.Coordinate.Coordinate Int Int, 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 :: Coordinate -> String -> Test.QuickCheck.Property - f coordinate = Test.QuickCheck.label "Coordinate.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage ( - ( - `elem` concatMap show Attribute.Rank.promotionProspects - ) . Data.Char.toLower - ) coordinate - in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f - ] diff --git a/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs new file mode 100644 --- /dev/null +++ b/src-test/BishBosh/Test/QuickCheck/Notation/PureCoordinate.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- + Copyright (C) 2018 Dr. Alistair Ward + + This file is part of BishBosh. + + BishBosh is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + BishBosh is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with BishBosh. If not, see . +-} +{- | + [@AUTHOR@] Dr. Alistair Ward + + [@DESCRIPTION@] Implements 'Test.QuickCheck.Arbitrary' & defines /QuickCheck/-properties. +-} + +module BishBosh.Test.QuickCheck.Notation.PureCoordinate( +-- * Types +-- ** Type-synonyms +-- PureCoordinate, +-- * Constants + results +) where + +import BishBosh.Test.QuickCheck.Component.Move() +import Control.Arrow((&&&)) +import qualified BishBosh.Attribute.Rank as Attribute.Rank +import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates +import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate +import qualified BishBosh.Cartesian.Vector as Cartesian.Vector +import qualified BishBosh.Component.Move as Component.Move +import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate +import qualified BishBosh.Types as T +import qualified Data.Char +import qualified Test.QuickCheck +import qualified ToolShed.Test.ReversibleIO + +-- | Defines a concrete type for testing. +type PureCoordinate = Notation.PureCoordinate.PureCoordinate T.X T.Y + +instance ( + Enum x, + Enum y, + Ord x, + Ord y + ) => Test.QuickCheck.Arbitrary (Notation.PureCoordinate.PureCoordinate x y) where + {-# SPECIALISE instance Test.QuickCheck.Arbitrary PureCoordinate #-} + arbitrary = do + move <- Test.QuickCheck.arbitrary + + Notation.PureCoordinate.mkPureCoordinate move `fmap` if abs ( + Cartesian.Vector.getXDistance (Component.Move.measureDistance move :: Cartesian.Vector.VectorInt) + ) <= 1 && ( + Cartesian.Coordinates.getY . Component.Move.getSource &&& Cartesian.Coordinates.getY . Component.Move.getDestination $ move + ) `elem` [ + (succ Cartesian.Ordinate.yMin, Cartesian.Ordinate.yMin), -- Black moving down. + (pred Cartesian.Ordinate.yMax, Cartesian.Ordinate.yMax) -- White moving up. + ] + then Test.QuickCheck.oneof [ + return {-to Gen-monad-} Nothing, + Test.QuickCheck.elements $ map Just Attribute.Rank.promotionProspects -- CAVEAT: move & promotionRank are still unlikely to be compatible. + ] + else return {-to Gen-monad-} Nothing + +-- | The constant test-results for this data-type. +results :: IO [Test.QuickCheck.Result] +results = sequence [ + let + f :: 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)] + ) 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 coordinate = Test.QuickCheck.label "PureCoordinate.prop_readTrailingGarbage" . ToolShed.Test.ReversibleIO.readTrailingGarbage ( + ( + `elem` concatMap show Attribute.Rank.promotionProspects + ) . Data.Char.toLower + ) coordinate + in Test.QuickCheck.quickCheckWithResult Test.QuickCheck.stdArgs { Test.QuickCheck.maxSuccess = 2048 } f + ] diff --git a/src-test/Main.hs b/src-test/Main.hs --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -68,8 +68,8 @@ import qualified BishBosh.Test.QuickCheck.Model.GameTree as Test.QuickCheck.Model.GameTree import qualified BishBosh.Test.QuickCheck.Model.MoveFrequency as Test.QuickCheck.Model.MoveFrequency import qualified BishBosh.Test.QuickCheck.Model.Result as Test.QuickCheck.Model.Result -import qualified BishBosh.Test.QuickCheck.Notation.Coordinate as Test.QuickCheck.Notation.Coordinate import qualified BishBosh.Test.QuickCheck.Notation.ICCFNumeric as Test.QuickCheck.Notation.ICCFNumeric +import qualified BishBosh.Test.QuickCheck.Notation.PureCoordinate as Test.QuickCheck.Notation.PureCoordinate import qualified BishBosh.Test.QuickCheck.Notation.Smith as Test.QuickCheck.Notation.Smith import qualified BishBosh.Test.QuickCheck.Search.KillerMoves as Test.QuickCheck.Search.KillerMoves -- import qualified BishBosh.Test.QuickCheck.Search.Search as Test.QuickCheck.Search.Search @@ -127,8 +127,8 @@ Test.QuickCheck.Component.Move.results, Test.QuickCheck.Component.QualifiedMove.results, Test.QuickCheck.Component.Turn.results, - Test.QuickCheck.Notation.Coordinate.results, Test.QuickCheck.Notation.ICCFNumeric.results, + Test.QuickCheck.Notation.PureCoordinate.results, Test.QuickCheck.Notation.Smith.results, Test.QuickCheck.Model.GameTerminationReason.results, Test.QuickCheck.Model.Result.results,