packages feed

chessica (empty) → 0.1.0.0

raw patch · 29 files changed

+1602/−0 lines, 29 filesdep +basedep +containers

Dependencies added: base, containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for chessica++## 0.1.0.0 -- 2023-05-11++* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Michael Szvetits++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Michael Szvetits nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,9 @@+<p align="center">+<img src="https://raw.githubusercontent.com/typedbyte/chessica/main/logo.png" alt="chessica" title="chessica"/>+</p>++# chessica++[![Hackage](https://img.shields.io/hackage/v/chessica.svg?logo=haskell&label=chessica)](https://hackage.haskell.org/package/chessica)++`chessica` is a library to create, manipulate and query chess game states, written in Haskell. It is designed to support arbitrary rulebooks and to generate all possible piece movements and future game states according to these rulebooks. The documentation can be found on [Hackage](https://hackage.haskell.org/package/chessica).
+ chessica.cabal view
@@ -0,0 +1,60 @@+cabal-version:   3.0+name:            chessica+version:         0.1.0.0+synopsis:        A Library for Chess Game Logic+description:     Please see the README on GitHub at <https://github.com/typedbyte/chessica#readme>+homepage:        https://github.com/typedbyte/chessica+bug-reports:     https://github.com/typedbyte/chessica/issues+license:         BSD-3-Clause+license-file:    LICENSE+author:          Michael Szvetits+maintainer:      typedbyte@qualified.name+copyright:       2023 Michael Szvetits+category:        Game+build-type:      Simple+extra-doc-files:+  CHANGELOG.md+  README.md++common shared-properties+  default-language: GHC2021+  build-depends:+      base >= 4.16.0 && < 5+  ghc-options:+      -Wall+  default-extensions:+      DuplicateRecordFields+      NoFieldSelectors+      OverloadedRecordDot++library+  import: shared-properties+  hs-source-dirs: src+  build-depends:+      containers >= 0.6.5 && < 0.7+  exposed-modules:+      Chess+      Chess.Board+      Chess.Board.Direction+      Chess.Board.PlacedPiece+      Chess.Board.Position+      Chess.Color+      Chess.Exception+      Chess.Game+      Chess.Game.Command+      Chess.Game.Status+      Chess.Piece+      Chess.Player+      Chess.Rulebook+      Chess.Rulebook.Standard+      Chess.Rulebook.Standard.Check+      Chess.Rulebook.Standard.Movement+      Chess.Rulebook.Standard.Movement.Bishop+      Chess.Rulebook.Standard.Movement.King+      Chess.Rulebook.Standard.Movement.Knight+      Chess.Rulebook.Standard.Movement.Pawn+      Chess.Rulebook.Standard.Movement.Queen+      Chess.Rulebook.Standard.Movement.Rook+      Chess.Rulebook.Standard.Status+      Chess.Rulebook.Standard.Threat+      Chess.Some
+ src/Chess.hs view
@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+-----------------------------------------------------------------------------+module Chess+  ( module Chess.Board+  , module Chess.Color+  , module Chess.Exception+  , module Chess.Game+  , module Chess.Piece+  , module Chess.Player+  , module Chess.Rulebook+  , module Chess.Some+  ) where++import Chess.Board+import Chess.Color+import Chess.Exception+import Chess.Game+import Chess.Piece+import Chess.Player+import Chess.Rulebook+import Chess.Some
+ src/Chess/Board.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Board+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to create, manipulate and query chess boards.+-----------------------------------------------------------------------------+module Chess.Board+  ( -- * Representing Boards+    Board+  , empty+    -- * Manipulating Boards+  , place+  , replace+  , remove+    -- * Querying Boards+  , lookup+  , isOccupied+  , pieces+  , piecesOf+  -- * Re-exports+  , module Chess.Board.Direction+  , module Chess.Board.PlacedPiece+  , module Chess.Board.Position+  ) where++-- base+import Control.Applicative qualified as A+import Data.Maybe          (isJust)+import Prelude      hiding (lookup)++-- containers+import Data.Map.Strict qualified as M++import Chess.Board.Direction+import Chess.Board.PlacedPiece+import Chess.Board.Position+import Chess.Color             (Color)+import Chess.Exception         (ChessException, fieldOccupied, pieceMissing, unexpectedPiece)+import Chess.Piece             (Piece(color), same)+import Chess.Some              (Some(Some))++-- | Represents a chess board.+newtype Board = Board { pieces :: M.Map Position (Some Piece) }++-- | An empty chess board, i.e. a board with no placed pieces.+empty :: Board+empty = Board M.empty++-- | Introduces a new chess piece to the chess board at a specific position.+place+  :: Position+  -- ^ The position of the newly introduced chess piece.+  -> Piece t+  -- ^ The newly introduced chess piece.+  -> Board+  -- ^ The original chess board.+  -> Either ChessException Board+  -- ^ The new chess board, if the specified position has not been occupied.+place position piece board =+  let+    (maybeOldPiece, newPieces) =+      M.insertLookupWithKey+        ( \_key new _old -> new )+        ( position )+        ( Some piece )+        ( board.pieces )+  in+    case maybeOldPiece of+      Just (Some oldPiece) ->+        Left $ fieldOccupied (PlacedPiece position oldPiece)+      Nothing ->+        Right $ Board newPieces++-- | Introduces a new chess piece to the chess board at a specific position.+replace+  :: Position+  -- ^ The position of the newly introduced chess piece.+  -> Piece t+  -- ^ The newly introduced chess piece.+  -> Board+  -- ^ The original chess board.+  -> Board+  -- ^ The new chess board. If the specified position has been occupied, the piece is replaced.+replace position piece (Board oldPieces) =+  Board (M.insert position (Some piece) oldPieces)++-- | Removes a chess piece from the chess board at a given position.+remove+  :: PlacedPiece t+  -- ^ The position of the chess piece to be removed.+  -> Board+  -- ^ The original chess board.+  -> Either ChessException Board+  -- ^ The new chess board, if the specified position was indeed occupied by the piece.+remove placed@PlacedPiece{position, piece} board =+  let+    (maybeOldPiece, newPieces) =+      M.updateLookupWithKey+        ( \_ _ -> Nothing )+        ( position )+        ( board.pieces )+  in+    case maybeOldPiece of+      Nothing -> Left $ pieceMissing placed+      Just (Some oldPiece)+        | same oldPiece piece -> Right $ Board newPieces+        | otherwise           -> Left $ unexpectedPiece (PlacedPiece position oldPiece)++-- | Gets a chess piece at a specific position of the chess board.+lookup+  :: A.Alternative f+  => Position+  -- ^ The position to look for a chess piece.+  -> Board+  -- ^ The board used for the lookup.+  -> f (Some PlacedPiece)+  -- ^ The chess piece, if the specified position was indeed occupied by it.+lookup position board =+  case M.lookup position board.pieces of+    Just (Some piece) -> pure $ placedPiece position piece+    Nothing           -> A.empty++-- | Checks if a specified position of the chess board is occupied by a chess piece.+isOccupied+  :: Position -- ^ The position to be checked for occupation.+  -> Board    -- ^ The board whose position is checked for occupation.+  -> Bool     -- ^ True if the specified position is occupied, or else false.+isOccupied position =+  isJust . lookup position++-- | Gets all chess pieces that are currently on the chess board.+pieces :: Board -> [Some PlacedPiece]+pieces+  = fmap (\(position, Some piece) -> placedPiece position piece)+  . M.assocs+  . (.pieces)++-- | Gets all chess pieces of a given color that are currently on the chess board.+piecesOf :: Color -> Board -> [Some PlacedPiece]+piecesOf color+  = fmap (\(position, Some piece) -> placedPiece position piece)+  . filter (\(_, Some piece) -> piece.color == color)+  . M.assocs+  . (.pieces)
+ src/Chess/Board/Direction.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Board.Direction+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to represent and manipulate directions on a chess board.+-----------------------------------------------------------------------------+module Chess.Board.Direction where++-- | Represents a two-dimensional direction on a chess board.+data Direction = Direction+  { rowDelta :: Int+    -- ^ The row component of the direction.+  , columnDelta :: Int+    -- ^ The column component of the direction.+  }++-- | Yields the integral vector pointing to the left, where the leftmost column is labelled A.+left :: Direction+left = Direction 0 (-1)++-- | Yields the integral vector pointing to the right, where the leftmost column is labelled A.+right :: Direction+right = Direction 0 1++-- | Yields the integral vector pointing up, where the lowest row is labelled 1.+up :: Direction+up = Direction 1 0++-- | Yields the integral vector pointing down, where the lowest row is labelled 1.+down :: Direction+down = Direction (-1) 0++-- | Yields the four integral vectors in the directions up, right, down and left.+orthogonals :: [Direction]+orthogonals = [up, right, down, left]++-- | Yields the four integral vectors in the directions left up, right up, right down and left down.+diagonals :: [Direction]+diagonals =+  [ Direction   1  (-1)+  , Direction   1    1+  , Direction (-1)   1+  , Direction (-1) (-1)+  ]++-- | Yields the combination of orthogonal and diagonal integral vectors.+principals :: [Direction]+principals = orthogonals ++ diagonals++-- | Yields the eight directions a knight is able to jump, according to the standard rules.+jumps :: [Direction]+jumps =+  [ Direction row column+    | row    <- [-1, 1, 2, -2]+    , column <- [-1, 1, 2, -2]+    , row /= column+    , row /= -column+  ]
+ src/Chess/Board/PlacedPiece.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs     #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Board.PlacedPiece+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to create and analyze placed chess pieces.+-----------------------------------------------------------------------------+module Chess.Board.PlacedPiece+  ( -- * Representing Placed Pieces+    PlacedPiece(..)+  , placedPiece+    -- * Analyzing Placed Pieces+  , assumeType+  ) where++-- base+import Control.Applicative (Alternative, empty)+import Data.Type.Equality  ((:~:)(Refl), testEquality)+import GHC.Records         (HasField, getField)++import Chess.Board.Position (Position)+import Chess.Color          (Color)+import Chess.Piece          (Piece(..), PieceType, same)+import Chess.Some           (Some(Some))++-- | Represents a chess piece that is currently placed on the board.+data PlacedPiece t = PlacedPiece+  { position :: Position+    -- ^ The position of the placed chess piece.+  , piece :: Piece t+    -- ^ The placed chess piece.+  }+  deriving (Eq, Ord, Show)++instance Eq (Some PlacedPiece) where+  Some p1 == Some p2 =+    p1.position == p2.position &&+    same p1.piece p2.piece++instance Ord (Some PlacedPiece) where+  compare (Some p1) (Some p2) =+    compare p1.position p2.position <>+    compare (Some p1.piece) (Some p2.piece)++instance Show (Some PlacedPiece) where+  show (Some piece) = show piece++instance HasField "color" (PlacedPiece t) Color where+  getField = (.piece.color)+  {-# INLINE getField #-}++instance HasField "type'" (PlacedPiece t) (PieceType t) where+  getField = (.piece.type')+  {-# INLINE getField #-}++-- | Smart constructor for creating 'Some' 'PlacedPiece'.+placedPiece :: Position -> Piece t -> Some PlacedPiece+placedPiece position = Some . PlacedPiece position++-- | Assumes that the given placed piece has the specified piece type.+assumeType :: Alternative f => PieceType t -> PlacedPiece a -> f (PlacedPiece t)+assumeType type' placed =+  case testEquality type' placed.piece.type' of+    Just Refl -> pure placed+    Nothing   -> empty
+ src/Chess/Board/Position.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Board.Position+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to represent and manipulate positions on a chess board.+-----------------------------------------------------------------------------+module Chess.Board.Position+  ( -- * Representing Positions+    Position(row, column)+  , mkPosition+  , boundedPosition+    -- * Manipulating Positions+  , offset+  , boundedOffset+  ) where++-- base+import Control.Applicative (Alternative, empty)++import Chess.Board.Direction (Direction(rowDelta, columnDelta))++-- | Represents a position on the chess board.+data Position = Position+  { row :: Int+    -- ^ The row of the position, where 0 is row 1.+  , column :: Int+    -- ^ The column of the position, where 0 is column A.+  }+  deriving (Eq, Ord, Read, Show)++-- | Creates a position from row and column indices.+mkPosition+  :: Alternative f+  => Int        -- ^ The row of the position, where 0 is the row labelled 1.+  -> Int        -- ^ The column of the position, where 0 is the column labelled A.+  -> f Position -- ^ The position, if it is within the bounds of the chess board.+mkPosition row column+  | between 0 7 row && between 0 7 column =+      pure $ Position row column+  | otherwise =+      empty+  where+    between low high value =+      low <= value && value <= high++-- | Creates a position from row and column indices.+boundedPosition+  :: Int      -- ^ The row of the position, where 0 is the row labelled 1.+  -> Int      -- ^ The column of the position, where 0 is the column labelled A.+  -> Position -- ^ The position, where out-of-bounds indices are limited to the valid range.+boundedPosition row column =+  Position+    ( clamp 0 7 row )+    ( clamp 0 7 column)+  where+    clamp lower upper value+      | value < lower = lower+      | value > upper = upper+      | otherwise     = value++-- | Adds an offset to a position, yielding a new position.+offset+  :: Alternative f+  => Direction  -- ^ The offset to be added to the position.+  -> Position   -- ^ The original position.+  -> f Position -- ^ The new position, if it is within the bounds of the chess board.+offset direction position =+  mkPosition+    ( position.row + direction.rowDelta )+    ( position.column + direction.columnDelta )++-- | Adds an offset to a position, yielding a new position.+boundedOffset+  :: Direction -- ^ The offset to be added to the position.+  -> Position  -- ^ The original position.+  -> Position  -- ^ The new position, where out-of-bounds indices are limited to the valid range.+boundedOffset direction position =+  boundedPosition+    ( position.row + direction.rowDelta )+    ( position.column + direction.columnDelta )
+ src/Chess/Color.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Color+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to handle the colors of a chess game.+-----------------------------------------------------------------------------+module Chess.Color where++-- | The colors involved in a chess game.+data Color = White | Black+  deriving (Eq, Ord, Read, Show)++-- | Gets the opposite color of a specified color.+oppositeOf :: Color -> Color+oppositeOf White = Black+oppositeOf Black = White
+ src/Chess/Exception.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE LambdaCase #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Exception+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions for exceptions that can occur when manipulating chess+-- games.+-----------------------------------------------------------------------------+module Chess.Exception where++-- base+import Control.Applicative (Alternative, empty)++import Chess.Board.PlacedPiece (PlacedPiece)+import Chess.Some              (Some(Some))++-- | Represents errors that can occur when manipulating chess games.+data ChessException+  = FieldOccupied (Some PlacedPiece)+  | PieceMissing (Some PlacedPiece)+  | UnexpectedPiece (Some PlacedPiece)++-- | Smart constructor for 'FieldOccupied'.+fieldOccupied :: PlacedPiece t -> ChessException+fieldOccupied = FieldOccupied . Some++-- | Smart constructor for 'PieceMissing'.+pieceMissing :: PlacedPiece t -> ChessException+pieceMissing = PieceMissing . Some++-- | Smart constructor for 'UnexpectedPiece'.+unexpectedPiece :: PlacedPiece t -> ChessException+unexpectedPiece = UnexpectedPiece . Some++-- | Extracts the 'Right' value from an 'Either'.+assumeRight :: Alternative f => Either e a -> f a+assumeRight = \case+  Right a -> pure a+  Left _  -> empty
+ src/Chess/Game.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedLists #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Game+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to create, manipulate and query chess game states.+-----------------------------------------------------------------------------+module Chess.Game+  ( -- * Representing Games+    Game(..)+  , Update(..)+    -- * Manipulating Games+  , execute+    -- * Querying Games+  , history+  , spawnCommands+    -- * Re-exports+  , module Chess.Game.Command+  , module Chess.Game.Status+  ) where++import Chess.Board             (Board, pieces, place, remove)+import Chess.Board.PlacedPiece (PlacedPiece(..))+import Chess.Exception         (ChessException)+import Chess.Game.Command+import Chess.Game.Status+import Chess.Player            (Player)+import Chess.Some              (Some(Some))++-- | Represents an update of a chess game state.+data Update = Update+  { game :: Game+    -- ^ Represents the chess game state before or after executing the corresponding command,+    -- depending on the context.+  , command :: Command+    -- ^ Represents the command that is involved in the game state update.+  }++-- | Represents a chess game state.+data Game = Game+  { board :: Board+    -- ^ The state of the chess board.+  , activePlayer :: Player+    -- ^ The player who is currently playing.+  , passivePlayer :: Player+    -- ^ The player who is currently waiting.+  , lastUpdate :: Maybe Update+    -- ^ The last update which led to this game state.+  }++-- | Executes a command on a game state in order to obtain a new game state.+execute :: Command -> Game -> Either ChessException Game+execute command game =+  case command of+    EndTurn ->+      pure+        game+          { activePlayer  = game.passivePlayer+          , passivePlayer = game.activePlayer+          }+    Move dst (Some placed) -> do+      tempBoard <- remove placed game.board+      newBoard <- place dst placed.piece tempBoard+      pure game { board = newBoard }+    Destroy (Some piece) -> do+      newBoard <- remove piece game.board+      pure game { board = newBoard }+    Spawn position (Some piece) -> do+      newBoard <- place position piece game.board+      pure game { board = newBoard }+    Sequence cmd1 cmd2 ->+      execute cmd1 game >>= execute cmd2+    Promote piece@(Some old) new ->+      execute [Destroy piece, Spawn old.position new] game+    Atomic cmd -> do+      newGame <- execute cmd game+      pure newGame { lastUpdate = Just (Update game command) }++-- | Gets the history of updates that led to the specified game state.+-- The most recent update is at the head of the list.+history :: Game -> [Update]+history game =+  case game.lastUpdate of+    Just update -> update : history update.game+    Nothing     -> []++-- | Gets a list of 'Spawn' commands which can be used to reconstruct+-- the board of the specified game state.+spawnCommands :: Game -> [Command]+spawnCommands game =+  flip fmap (pieces game.board) $ \(Some placedPiece) ->+    spawn placedPiece.position placedPiece.piece
+ src/Chess/Game/Command.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE TypeFamilies #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Game.Command+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions for commands that can change chess game states.+-----------------------------------------------------------------------------+module Chess.Game.Command where++-- base+import GHC.Exts       (IsList(Item, fromList, toList))+import Prelude hiding (sequence)++import Chess.Board.PlacedPiece (PlacedPiece(..))+import Chess.Board.Position    (Position)+import Chess.Piece             (Piece)+import Chess.Some              (Some(Some))++-- | A command can be applied to a chess game state in order to obtain a new game state.+data Command+  = EndTurn+    -- ^ Ends the turn of the active player.+  | Move Position (Some PlacedPiece)+    -- ^ Moves a placed piece to the specified position.+  | Destroy (Some PlacedPiece)+    -- ^ Removes a placed piece.+  | Spawn Position (Some Piece)+    -- ^ Creates a chess piece on the specified position.+  | Promote (Some PlacedPiece) (Some Piece)+    -- ^ Converts a chess piece into another piece.+  | Sequence Command Command+    -- ^ Represents the consecutive execution of two commands.+  | Atomic Command+    -- ^ Denotes that a command and its sub-commands belong together and should+    -- be treated as single command (e.g., when recording the history of a chess game).+  deriving (Eq, Ord, Show)++instance IsList Command where+  type Item Command = Command+  +  fromList [cmd]    = cmd+  fromList (cmd:cs) = Sequence cmd (fromList cs)+  fromList []       = errorWithoutStackTrace "Command.fromList: empty list"+  +  toList (Sequence cmd1 cmd2) = cmd1 : toList cmd2+  toList cmd                  = [cmd]++-- | Smart constructor for 'EndTurn'.+endTurn :: Command+endTurn = EndTurn++-- | Smart constructor for 'Move'.+move :: Position -> PlacedPiece t -> Command+move position = Move position . Some++-- | Smart constructor for 'Destroy'.+destroy :: PlacedPiece t -> Command+destroy = Destroy . Some++-- | Smart constructor for 'Spawn'.+spawn :: Position -> Piece t -> Command+spawn position = Spawn position . Some++-- | Smart constructor for 'Promote'.+promote :: PlacedPiece a -> Piece b -> Command+promote placed piece = Promote (Some placed) (Some piece)++-- | Smart constructor for 'Sequence'.+sequence :: Command -> Command -> Command+sequence = Sequence++-- | Smart constructor for 'Atomic'.+atomic :: Command -> Command+atomic = Atomic++-- | Produces a command that has the opposite effect of the specified command.+undo :: Command -> Command+undo = \case+  EndTurn ->+    EndTurn+  Move dst (Some (PlacedPiece src piece)) ->+    move src (PlacedPiece dst piece)+  Destroy (Some placed) ->+    spawn placed.position placed.piece+  Spawn position (Some piece) ->+    destroy (PlacedPiece position piece)+  Promote (Some (PlacedPiece position old)) (Some new) ->+    promote (PlacedPiece position new) old+  Sequence cmd1 cmd2 ->+    sequence (undo cmd2) (undo cmd1)+  Atomic cmd ->+    atomic (undo cmd)
+ src/Chess/Game/Status.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Game.Status+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to handle the status of a chess game.+-----------------------------------------------------------------------------+module Chess.Game.Status where++import Chess.Player (Player)++-- | Represents the status of a chess game.+data Status+  = Win Player  -- ^ Indicates that the specified player has won.+  | Turn Player -- ^ Indicates that the specified player is currently playing.+  | Draw        -- ^ Indicates that the chess game has ended in a draw.
+ src/Chess/Piece.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs     #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Piece+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to create and analyze chess pieces.+-----------------------------------------------------------------------------+module Chess.Piece+  ( -- * Representing Pieces+    PieceType'(..)+  , PieceType(..)+  , Piece(..)+  , somePiece+  , fromSome+    -- * Analyzing Piece Types+  , equals+    -- * Analyzing Pieces+  , same+  , isOfType+  , assume+  )where++-- base+import Control.Applicative (Alternative, empty)+import Data.Type.Equality  ((:~:)(Refl), TestEquality, testEquality)++import Chess.Color (Color)+import Chess.Some  (Some(Some))++-- | Represents the piece types involved in a chess game on the type-level.+data PieceType'+  = Pawn'+  | Knight'+  | Bishop'+  | Rook'+  | Queen'+  | King'+  deriving (Eq, Ord, Read, Show)++-- | Represents the piece types involved in a chess game on the term-level.+data PieceType t where+  Pawn   :: PieceType Pawn'+  Knight :: PieceType Knight'+  Bishop :: PieceType Bishop'+  Rook   :: PieceType Rook'+  Queen  :: PieceType Queen'+  King   :: PieceType King'++deriving instance Eq   (PieceType t)+deriving instance Ord  (PieceType t)+deriving instance Show (PieceType t)++instance TestEquality PieceType where+  testEquality Pawn   Pawn   = Just Refl+  testEquality Knight Knight = Just Refl+  testEquality Bishop Bishop = Just Refl+  testEquality Rook   Rook   = Just Refl+  testEquality Queen  Queen  = Just Refl+  testEquality King   King   = Just Refl+  testEquality _      _      = Nothing++-- | Returns true if two piece types are the same.+equals :: PieceType a -> PieceType b -> Bool+equals type1 type2 =+  case testEquality type1 type2 of+    Just Refl -> True+    Nothing   -> False++-- | Represents a chess piece, which is a combination of its type and its color.+data Piece t = Piece+  { type' :: PieceType t+  , color :: Color+  }+  deriving (Eq, Ord, Show)++instance Eq (Some Piece) where+  Some p1 == Some p2 = same p1 p2++instance Ord (Some Piece) where+  compare (Some p1) (Some p2) =+    case (p1.type', p2.type') of+      (Pawn  , Pawn  ) -> compareColor+      (Pawn  , _     ) -> LT+      (Knight, Pawn  ) -> GT+      (Knight, Knight) -> compareColor+      (Knight, _     ) -> LT+      (Bishop, Pawn  ) -> GT+      (Bishop, Knight) -> GT+      (Bishop, Bishop) -> compareColor+      (Bishop, _     ) -> LT+      (Rook  , King  ) -> LT+      (Rook  , Queen ) -> LT+      (Rook  , Rook  ) -> compareColor+      (Rook  , _     ) -> GT+      (Queen , King  ) -> LT+      (Queen , Queen ) -> compareColor+      (Queen , _     ) -> GT+      (King  , King  ) -> compareColor+      (King  , _     ) -> GT+    where+      compareColor = compare p1.color p2.color++instance Show (Some Piece) where+  show (Some piece) = show piece++-- | Smart constructor for creating 'Some' 'Piece'.+somePiece :: PieceType t -> Color -> Some Piece+somePiece type' color = Some $ Piece type' color++-- | Smart constructor for creating 'Some' 'Piece' from 'Some' 'PieceType'.+fromSome :: Some PieceType -> Color -> Some Piece+fromSome (Some type') = somePiece type'++-- | Assumes that the given piece has the specified piece type.+assume :: Alternative f => PieceType t -> Piece a -> f (Piece t)+assume type' piece =+  case testEquality type' piece.type' of+    Just Refl -> pure piece+    Nothing   -> empty++-- | Returns true if two pieces are the same.+same :: Piece a -> Piece b -> Bool+same piece1 piece2 =+  case testEquality piece1.type' piece2.type' of+    Just Refl -> piece1.color == piece2.color+    Nothing   -> False++-- | Returns true if the given piece has the specified piece type.+isOfType :: PieceType t -> Piece a -> Bool+isOfType type' piece =+  case testEquality type' piece.type' of+    Just Refl -> True+    Nothing   -> False
+ src/Chess/Player.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Player+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to handle chess players.+-----------------------------------------------------------------------------+module Chess.Player where++import Chess.Color (Color)++-- | Represents a player who participates in a chess game.+--+-- Currently, a player is only identified by the color of the controlled chess pieces.+-- In the future, a player could have more attributes, like name, ELO rating, etc.+newtype Player = Player { color :: Color }+  deriving (Eq, Ord, Read, Show)
+ src/Chess/Rulebook.hs view
@@ -0,0 +1,27 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to define rulebooks for chess games.+-----------------------------------------------------------------------------+module Chess.Rulebook where++import Chess.Board.Position (Position)+import Chess.Game           (Game, Update)+import Chess.Game.Status    (Status)++-- | Represents a rulebook for a chess game.+data Rulebook = Rulebook+  { newGame :: Game+    -- ^ Creates a new chess game, according to the rulebook.+  , status :: Game -> Status+    -- ^ Gets the status of a chess game, according to the rulebook.+  , updates :: Position -> Game -> [Update]+    -- ^ Gets all possible updates (i.e., future game states) for a chess piece+    -- on a specified position, according to the rulebook.+  }
+ src/Chess/Rulebook/Standard.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedLists #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to represent the standard rulebook for chess games.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard (standardRulebook) where++-- base+import Control.Monad  (guard)+import Prelude hiding (lookup)++import Chess.Board                      (Board, empty, lookup, replace)+import Chess.Board.PlacedPiece          (PlacedPiece(PlacedPiece), placedPiece)+import Chess.Board.Position             (boundedPosition)+import Chess.Color                      (Color(..))+import Chess.Exception                  (assumeRight)+import Chess.Game                       (Game(..), Update(..), execute)+import Chess.Game.Command               (atomic, endTurn)+import Chess.Piece                      (Piece(Piece), PieceType(..))+import Chess.Player                     (Player(Player))+import Chess.Rulebook                   (Rulebook(..))+import Chess.Rulebook.Standard.Check    (checked)+import Chess.Rulebook.Standard.Movement (movements)+import Chess.Rulebook.Standard.Status   (status)+import Chess.Some                       (Some(Some))++-- | The standard rulebook for chess games.+standardRulebook :: Rulebook+standardRulebook =+  Rulebook+  { newGame =+      Game+        { board         = newBoard+        , activePlayer  = Player White+        , passivePlayer = Player Black+        , lastUpdate    = Nothing+        }+  , status = status+  , updates =+      \position game -> do+        Some piece <- lookup position game.board+        move <- movements piece game+        let turn = atomic [move, endTurn]+        newGame <- assumeRight $ execute turn game+        guard $ not (checked newGame.passivePlayer newGame.board)+        pure (Update newGame turn)+  }++baseLine :: Color -> [Some PlacedPiece]+baseLine color =+  let+    rook   = Piece Rook color+    knight = Piece Knight color+    bishop = Piece Bishop color+    queen  = Piece Queen color+    king   = Piece King color+    row    = if color == White then 0 else 7+  in+    [ placedPiece (boundedPosition row 0) rook+    , placedPiece (boundedPosition row 1) knight+    , placedPiece (boundedPosition row 2) bishop+    , placedPiece (boundedPosition row 3) queen+    , placedPiece (boundedPosition row 4) king+    , placedPiece (boundedPosition row 5) bishop+    , placedPiece (boundedPosition row 6) knight+    , placedPiece (boundedPosition row 7) rook+    ]++pawnLine :: Color -> [Some PlacedPiece]+pawnLine color =+  let+    pawn = Piece Pawn color+    row  = if color == White then 1 else 6+  in+    fmap+      ( \column -> placedPiece (boundedPosition row column) pawn )+      [ 0..7 ]++newBoard :: Board+newBoard =+  let+    whiteBaseLine = baseLine White+    whitePawnLine = pawnLine White+    blackBaseLine = baseLine Black+    blackPawnLine = pawnLine Black+  in+    foldr+      ( \(Some (PlacedPiece position piece)) -> replace position piece )+      ( empty )+      ( whiteBaseLine ++ whitePawnLine ++ blackBaseLine ++ blackPawnLine )
+ src/Chess/Rulebook/Standard/Check.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Check+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the check rule, according to the standard rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Check where++-- base+import Data.List (find)++import Chess.Board                    (Board, piecesOf)+import Chess.Board.PlacedPiece        (PlacedPiece(position, piece))+import Chess.Color                    (oppositeOf)+import Chess.Piece                    (PieceType(King), isOfType)+import Chess.Player                   (Player(color))+import Chess.Rulebook.Standard.Threat (threats)+import Chess.Some                     (Some(Some))++-- | Returns true if the specified player is currently checked, according to the+-- standard rulebook.+checked :: Player -> Board -> Bool+checked player board =+  let+    enemyThreats =+      concatMap+        ( \(Some enemy) -> threats enemy board )+        ( piecesOf (oppositeOf player.color) board )+    playerKing =+      find+        ( \(Some friend) -> isOfType King friend.piece )+        ( piecesOf player.color board )+  in+    case playerKing of+      Just (Some king) -> elem king.position enemyThreats+      Nothing          -> False
+ src/Chess/Rulebook/Standard/Movement.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE GADTs #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rules, according to the standard rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement where++import Chess.Board.PlacedPiece                 (PlacedPiece)+import Chess.Game                              (Game(Game, board))+import Chess.Game.Command                      (Command)+import Chess.Piece                             (PieceType(..))+import Chess.Rulebook.Standard.Movement.Bishop qualified as Bishop+import Chess.Rulebook.Standard.Movement.King   qualified as King+import Chess.Rulebook.Standard.Movement.Knight qualified as Knight+import Chess.Rulebook.Standard.Movement.Pawn   qualified as Pawn+import Chess.Rulebook.Standard.Movement.Queen  qualified as Queen+import Chess.Rulebook.Standard.Movement.Rook   qualified as Rook++-- | Determines all possible movements (including captures and promotions) for a given chess piece.+movements :: PlacedPiece t -> Game -> [Command]+movements piece game@Game{board} =+  case piece.type' of+    Pawn   -> Pawn.movements piece game+    Knight -> Knight.movements piece board+    Bishop -> Bishop.movements piece board+    Rook   -> Rook.movements piece board+    Queen  -> Queen.movements piece board+    King   -> King.movements piece game
+ src/Chess/Rulebook/Standard/Movement/Bishop.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.Bishop+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for bishops, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.Bishop where++import Chess.Board                    (Board)+import Chess.Board.PlacedPiece        (PlacedPiece)+import Chess.Game.Command             (Command)+import Chess.Piece                    (PieceType'(Bishop'))+import Chess.Rulebook.Standard.Threat (threatCommands)++-- | Determines all possible movements (including captures) for a given bishop.+movements :: PlacedPiece Bishop' -> Board -> [Command]+movements = threatCommands
+ src/Chess/Rulebook/Standard/Movement/King.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE OverloadedLists #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.King+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for kings, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.King where++-- base+import Control.Applicative ((<|>))+import Control.Monad       (guard)+import Prelude hiding      (lookup)++import Chess.Board                    (isOccupied, lookup, piecesOf)+import Chess.Board.Direction          (left, right)+import Chess.Board.PlacedPiece        (PlacedPiece(..), assumeType)+import Chess.Board.Position           (Position(..), boundedOffset, boundedPosition)+import Chess.Color                    (Color(..), oppositeOf)+import Chess.Game                     (Game(Game, board), Update(command), history)+import Chess.Game.Command             (Command(..), move)+import Chess.Piece                    (PieceType(Rook), PieceType'(King'))+import Chess.Rulebook.Standard.Threat (threats, threatCommands)+import Chess.Some                     (Some(Some))++-- | Determines all possible movements (including captures and castlings) for a given king.+movements :: PlacedPiece King' -> Game -> [Command]+movements king game@Game{board}+    = threatCommands king board+  <|> castlings king game++-- | Determines all possible castlings for a given king.+castlings :: PlacedPiece King' -> Game -> [Command]+castlings king game@Game{board} =+  let+    expectedPosition =+      case king.color of+        White -> boundedPosition 0 4+        Black -> boundedPosition 7 4+    enemyThreats =+      concatMap+        ( \(Some enemy) -> threats enemy board )+        ( piecesOf (oppositeOf king.color) board )+    hasMoved rookPosition = \case+      Move _ (Some (PlacedPiece src _)) ->+        src == king.position || src == rookPosition+      Sequence cmd1 cmd2 ->+        hasMoved rookPosition cmd1 || hasMoved rookPosition cmd2+      Atomic cmd ->+        hasMoved rookPosition cmd+      _ ->+        False+  in do+    -- the king must be in the right position+    guard $ king.position == expectedPosition+    -- the same-colored rook must be in the right position+    let leftCorner  = boundedPosition king.position.row 0+    let rightCorner = boundedPosition king.position.row 7+    Some piece <- lookup leftCorner board <|> lookup rightCorner board+    rook       <- assumeType Rook piece+    guard $ rook.color == king.color+    -- get the fields between king and rook+    let direction = if king.position.column > rook.position.column then left else right+    let oneNext   = boundedOffset direction king.position+    let twoNext   = boundedOffset direction oneNext+    guard+      -- the fields between king and rook must be empty+       $ not (isOccupied oneNext board)+      && not (isOccupied twoNext board)+      -- the king must not be threatened+      && not (elem king.position enemyThreats)+      -- the fields between king and rook must not be threatened+      && not (elem oneNext enemyThreats)+      && not (elem twoNext enemyThreats)+      -- king and rook must not have moved during the game+      && not+           ( any+             ( hasMoved rook.position . (.command) )+             ( history game )+           )+    pure [move twoNext king, move oneNext rook]
+ src/Chess/Rulebook/Standard/Movement/Knight.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.Knight+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for knights, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.Knight where++import Chess.Board                    (Board)+import Chess.Board.PlacedPiece        (PlacedPiece)+import Chess.Game.Command             (Command)+import Chess.Piece                    (PieceType'(Knight'))+import Chess.Rulebook.Standard.Threat (threatCommands)++-- | Determines all possible movements (including captures) for a given knight.+movements :: PlacedPiece Knight' -> Board -> [Command]+movements = threatCommands
+ src/Chess/Rulebook/Standard/Movement/Pawn.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE OverloadedLists #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.Pawn+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for pawns, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.Pawn+  ( movements+  , oneStep+  , twoSteps+  , capture+  , enPassant+  ) where++-- base+import Control.Applicative ((<|>))+import Control.Monad       (guard)+import Data.Maybe          (maybeToList)+import Prelude hiding      (lookup)++import Chess.Board                    (Board, isOccupied, lookup)+import Chess.Board.Direction          (Direction, up, down)+import Chess.Board.PlacedPiece        (PlacedPiece(..))+import Chess.Board.Position           (Position(..), boundedPosition, offset)+import Chess.Color                    (Color(..))+import Chess.Game                     (Game(..), Update(command))+import Chess.Game.Command             (Command(..), move, promote, destroy)+import Chess.Piece                    (Piece(Piece), PieceType(..), PieceType'(Pawn'), isOfType)+import Chess.Rulebook.Standard.Threat (threats)+import Chess.Some                     (Some(Some))++-- | Determines all possible movements (including captures, promotions and en+-- passant) for a given pawn.+movements :: PlacedPiece Pawn' -> Game -> [Command]+movements pawn game@Game{board}+    = oneStep pawn board+  <|> twoSteps pawn board+  <|> capture pawn board+  <|> maybeToList (enPassant pawn game)++-- | Determines all possible one-step forward movements (including promotions)+-- for a given pawn.+oneStep :: PlacedPiece Pawn' -> Board -> [Command]+oneStep pawn board = do+  let pawnDirection = direction pawn+  forward <- offset pawnDirection pawn.position+  guard $ not $ isOccupied forward board+  maybePromote forward pawn (move forward pawn)++-- | Determines all possible two-step forward movements for a given pawn.+twoSteps :: PlacedPiece Pawn' -> Board -> [Command]+twoSteps pawn board = do+  guard $+    case pawn.color of+      White -> pawn.position.row == 1+      Black -> pawn.position.row == 6+  let pawnDirection = direction pawn+  oneForward <- offset pawnDirection pawn.position+  guard $ not $ isOccupied oneForward board+  twoForward <- offset pawnDirection oneForward+  guard $ not $ isOccupied twoForward board+  pure (move twoForward pawn)++-- | Determines all possible capture movements (including promotions, excluding+-- en passant) for a given pawn.+capture :: PlacedPiece Pawn' -> Board -> [Command]+capture pawn board = do+  target     <- threats pawn board+  Some enemy <- lookup target board+  maybePromote target pawn [destroy enemy, move target pawn]++-- | Determines the en passant movement for a given pawn, if possible.+enPassant :: PlacedPiece Pawn' -> Game -> Maybe Command+enPassant pawn game =+  let+    expectedRow =+      case pawn.color of+        White -> 4+        Black -> 3+    lastMove = \case+      Move dst (Some (PlacedPiece src movedPiece)) ->+        Just (src, dst, Some movedPiece)+      Sequence cmd _ ->+        lastMove cmd+      Atomic cmd ->+        lastMove cmd+      _ ->+        Nothing+  in do+    update <- game.lastUpdate+    (src, dst, Some enemy) <- lastMove update.command+    guard+      -- the pawn must be in the correct row+       $ pawn.position.row == expectedRow+      -- the previous move of the enemy must include a pawn+      && isOfType Pawn enemy+      -- the enemy's pawn must have ended its move next to the pawn+      && pawn.position.row == dst.row+      && abs (pawn.position.column - dst.column) == 1+      -- the enemy's pawn must have moved two fields+      && abs (src.row - dst.row) == 2+    let+      newPosition =+        boundedPosition+          ( (src.row + dst.row) `div` 2 )+          ( dst.column )+    pure [destroy (PlacedPiece dst enemy), move newPosition pawn]++promotions :: PlacedPiece Pawn' -> [Command]+promotions pawn = do+  guard $+    ( pawn.color == White && pawn.position.row == 7 ) ||+    ( pawn.color == Black && pawn.position.row == 0 )+  [  promote pawn (Piece Queen  pawn.color)+   , promote pawn (Piece Rook   pawn.color)+   , promote pawn (Piece Bishop pawn.color)+   , promote pawn (Piece Knight pawn.color) ]++direction :: PlacedPiece Pawn' -> Direction+direction pawn =+  case pawn.color of+    White -> up+    Black -> down++maybePromote :: Position -> PlacedPiece Pawn' -> Command -> [Command]+maybePromote position pawn moveCmd =+  case promotions (pawn {position = position}) of+    [] -> [moveCmd]+    ps -> [[moveCmd, p] | p <- ps]
+ src/Chess/Rulebook/Standard/Movement/Queen.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.Queen+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for queens, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.Queen where++import Chess.Board                    (Board)+import Chess.Board.PlacedPiece        (PlacedPiece)+import Chess.Game.Command             (Command)+import Chess.Piece                    (PieceType'(Queen'))+import Chess.Rulebook.Standard.Threat (threatCommands)++-- | Determines all possible movements (including captures) for a given queen.+movements :: PlacedPiece Queen' -> Board -> [Command]+movements = threatCommands
+ src/Chess/Rulebook/Standard/Movement/Rook.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Movement.Rook+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the movement rule for rooks, according to the standard+-- rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Movement.Rook where++import Chess.Board                    (Board)+import Chess.Board.PlacedPiece        (PlacedPiece)+import Chess.Game.Command             (Command)+import Chess.Piece                    (PieceType'(Rook'))+import Chess.Rulebook.Standard.Threat (threatCommands)++-- | Determines all possible movements (including captures) for a given rook.+movements :: PlacedPiece Rook' -> Board -> [Command]+movements = threatCommands
+ src/Chess/Rulebook/Standard/Status.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE MultiWayIf #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Status+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of the game status, according to the standard rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Status where++-- base+import Data.Either (rights)++import Chess.Board                      (piecesOf)+import Chess.Game                       (Game(activePlayer, board, passivePlayer), execute)+import Chess.Game.Status                (Status(..))+import Chess.Player                     (Player(color))+import Chess.Rulebook.Standard.Check    (checked)+import Chess.Rulebook.Standard.Movement (movements)+import Chess.Some                       (Some(Some))++-- | Determines the status of a chess game, according to the standard rulebook.+status :: Game -> Status+status game =+  let+    activeColor   = game.activePlayer.color+    activePieces  = piecesOf activeColor game.board+    isChecked     = checked game.activePlayer game.board+    possibleMoves = concatMap (\(Some piece) -> movements piece game) activePieces+    futures       = rights $ fmap (flip execute game) possibleMoves+    hasMoves      = any (not . checked game.activePlayer . (.board)) futures+  in if+    | isChecked && not hasMoves     -> Win game.passivePlayer+    | not isChecked && not hasMoves -> Draw+    | otherwise                     -> Turn game.activePlayer
+ src/Chess/Rulebook/Standard/Threat.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE OverloadedLists #-}+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Rulebook.Standard.Threat+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Implementation of chess piece threats, according to the standard rulebook.+-----------------------------------------------------------------------------+module Chess.Rulebook.Standard.Threat+  ( threats+  , threatCommands+  ) where++-- base+import Prelude hiding (lookup)++import Chess.Board             (Board, lookup)+import Chess.Board.Direction   (Direction(..), diagonals, jumps, orthogonals, principals)+import Chess.Board.PlacedPiece (PlacedPiece(..))+import Chess.Board.Position    (Position, offset)+import Chess.Color             (Color(White))+import Chess.Game.Command      (Command, move, destroy)+import Chess.Piece             (PieceType(..))+import Chess.Some              (Some(Some))++-- | Determines the positions threatened by a given chess piece.+threats :: PlacedPiece t -> Board -> [Position]+threats piece board =+  case piece.type' of+    Pawn   -> threat pawnDirections 1+    Knight -> threat jumps 1+    Bishop -> threat diagonals maxBound+    Rook   -> threat orthogonals maxBound+    Queen  -> threat principals maxBound+    King   -> threat principals 1+  where+    threat = reach piece board+    pawnDelta = if piece.color == White then 1 else (-1)+    pawnDirections = filter (\d -> d.rowDelta == pawnDelta) diagonals++-- | Determines all possible threat-based movements (including captures) for a+-- given chess piece.+threatCommands :: PlacedPiece t -> Board -> [Command]+threatCommands piece board = do+  target <- threats piece board+  case lookup target board of+    Nothing ->+      pure (move target piece)+    Just (Some enemy) ->+      pure [destroy enemy, move target piece]++-- | Starting at a specified position, provides a list of all the positions+--   that are reachable by a chess piece in the given directions.+reach+  :: PlacedPiece t -- ^ The analyzed chess piece.+  -> Board         -- ^ The current chess board state.+  -> [Direction]   -- ^ The directions to iterate, beginning by the starting position.+  -> Int           -- ^ The maximum count of steps to take in a specific direction.+  -> [Position]    -- ^ A list of all the reachable positions.+reach piece board directions maxSteps = do+  direction <- directions+  takeUntilPiece+    $ take maxSteps+    $ collect (offset direction) piece.position+  where+    -- takeUntilPiece iterates until a friend or enemy piece is hit+    takeUntilPiece [] = []+    takeUntilPiece (p:ps) =+      case lookup p board of+        Nothing -> p : takeUntilPiece ps+        Just (Some other)+          | piece.color == other.color -> []+          | otherwise                  -> [p]+    -- collect is catMaybes, but only until the first Nothing+    collect f start = go (f start)+      where+        go (Just p) = p : go (f p)+        go Nothing  = []
+ src/Chess/Some.hs view
@@ -0,0 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Chess.Some+-- Copyright   : (c) Michael Szvetits, 2023+-- License     : BSD-3-Clause (see the file LICENSE)+-- Maintainer  : typedbyte@qualified.name+-- Stability   : stable+-- Portability : portable+--+-- Types and functions to create an existential type.+-----------------------------------------------------------------------------+module Chess.Some where++-- | This existential type is used to "erase" the type parameter of a type, which+-- allows one to define types and functions that are agnostic to the erased type+-- parameter.+data Some f = forall t. Some (f t)