mirror of
https://github.com/monadicsystems/okapi.git
synced 2024-11-27 13:59:13 +03:00
421 lines
10 KiB
Haskell
421 lines
10 KiB
Haskell
{-# LANGUAGE StrictData #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Chess where
|
|
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as Map
|
|
import Lucid
|
|
import Data.Text
|
|
import Control.Monad
|
|
import Web.HttpApiData
|
|
import Lucid.Htmx
|
|
|
|
data PieceType
|
|
= Pawn
|
|
| Knight
|
|
| Rook
|
|
| Bishop
|
|
| Queen
|
|
| King
|
|
deriving (Eq, Show)
|
|
|
|
data PieceColor = White | Black deriving (Eq, Ord, Show)
|
|
|
|
opposite :: PieceColor -> PieceColor
|
|
opposite White = Black
|
|
opposite Black = White
|
|
|
|
newtype Piece = Piece { unPiece :: (PieceColor, PieceType) } deriving (Eq)
|
|
|
|
instance Show Piece where
|
|
show (Piece piece) = case piece of
|
|
(White, Pawn) -> "WP"
|
|
(Black, Pawn) -> "BP"
|
|
(White, Knight) -> "WN"
|
|
(Black, Knight) -> "BN"
|
|
(White, Rook) -> "WR"
|
|
(Black, Rook) -> "BR"
|
|
(White, Bishop) -> "WB"
|
|
(Black, Bishop) -> "BB"
|
|
(White, Queen) -> "WQ"
|
|
(Black, Queen) -> "BQ"
|
|
(White, King) -> "WK"
|
|
(Black, King) -> "BK"
|
|
|
|
instance ToHtml Piece where
|
|
toHtml (Piece (White, Pawn)) = "♙"
|
|
toHtml (Piece (Black, Pawn)) = "♟"
|
|
toHtml (Piece (White, Knight)) = "♘"
|
|
toHtml (Piece (Black, Knight)) = "♞"
|
|
toHtml (Piece (White, Rook)) = "♖"
|
|
toHtml (Piece (Black, Rook)) = "♜"
|
|
toHtml (Piece (White, Bishop)) = "♗"
|
|
toHtml (Piece (Black, Bishop)) = "♝"
|
|
toHtml (Piece (White, Queen)) = "♕"
|
|
toHtml (Piece (Black, Queen)) = "♛"
|
|
toHtml (Piece (White, King)) = "♔"
|
|
toHtml (Piece (Black, King)) = "♚"
|
|
toHtmlRaw = toHtml
|
|
|
|
instance ToHttpApiData Piece where
|
|
toUrlPiece = pack . show
|
|
toQueryParam = toUrlPiece
|
|
|
|
instance FromHttpApiData Piece where
|
|
parseUrlPiece piece = case piece of
|
|
"WP" -> Right wPawn
|
|
"BP" -> Right bPawn
|
|
"WN" -> Right wKnight
|
|
"BN" -> Right bKnight
|
|
"WR" -> Right wRook
|
|
"BR" -> Right bRook
|
|
"WB" -> Right wBishop
|
|
"BB" -> Right bBishop
|
|
"WQ" -> Right wQueen
|
|
"BQ" -> Right bQueen
|
|
"WK" -> Right wKing
|
|
"BK" -> Right bKing
|
|
_ -> Left "Couldn't parse Piece"
|
|
parseQueryParam = parseUrlPiece
|
|
|
|
wPawn = Piece (White, Pawn)
|
|
|
|
wKnight = Piece (White, Knight)
|
|
|
|
wRook = Piece (White, Rook)
|
|
|
|
wBishop = Piece (White, Bishop)
|
|
|
|
wQueen = Piece (White, Queen)
|
|
|
|
wKing = Piece (White, King)
|
|
|
|
bPawn = Piece (Black, Pawn)
|
|
|
|
bKnight = Piece (Black, Knight)
|
|
|
|
bRook = Piece (Black, Rook)
|
|
|
|
bBishop = Piece (Black, Bishop)
|
|
|
|
bQueen = Piece (Black, Queen)
|
|
|
|
bKing = Piece (Black, King)
|
|
|
|
data File
|
|
= FileA
|
|
| FileB
|
|
| FileC
|
|
| FileD
|
|
| FileE
|
|
| FileF
|
|
| FileG
|
|
| FileH
|
|
deriving (Eq, Show, Ord, Enum)
|
|
|
|
data Rank
|
|
= Rank1
|
|
| Rank2
|
|
| Rank3
|
|
| Rank4
|
|
| Rank5
|
|
| Rank6
|
|
| Rank7
|
|
| Rank8
|
|
deriving (Eq, Show, Ord, Enum)
|
|
|
|
newtype Position = Position { unPosition :: (File, Rank) } deriving (Eq, Ord)
|
|
|
|
instance Show Position where
|
|
show (Position position) = case position of
|
|
(FileA, Rank1) -> "a1"
|
|
(FileA, Rank2) -> "a2"
|
|
(FileA, Rank3) -> "a3"
|
|
(FileA, Rank4) -> "a4"
|
|
(FileA, Rank5) -> "a5"
|
|
(FileA, Rank6) -> "a6"
|
|
(FileA, Rank7) -> "a7"
|
|
(FileA, Rank8) -> "a8"
|
|
(FileB, Rank1) -> "b1"
|
|
(FileB, Rank2) -> "b2"
|
|
(FileB, Rank3) -> "b3"
|
|
(FileB, Rank4) -> "b4"
|
|
(FileB, Rank5) -> "b5"
|
|
(FileB, Rank6) -> "b6"
|
|
(FileB, Rank7) -> "b7"
|
|
(FileB, Rank8) -> "b8"
|
|
(FileC, Rank1) -> "c1"
|
|
(FileC, Rank2) -> "c2"
|
|
(FileC, Rank3) -> "c3"
|
|
(FileC, Rank4) -> "c4"
|
|
(FileC, Rank5) -> "c5"
|
|
(FileC, Rank6) -> "c6"
|
|
(FileC, Rank7) -> "c7"
|
|
(FileC, Rank8) -> "c8"
|
|
(FileD, Rank1) -> "d1"
|
|
(FileD, Rank2) -> "d2"
|
|
(FileD, Rank3) -> "d3"
|
|
(FileD, Rank4) -> "d4"
|
|
(FileD, Rank5) -> "d5"
|
|
(FileD, Rank6) -> "d6"
|
|
(FileD, Rank7) -> "d7"
|
|
(FileD, Rank8) -> "d8"
|
|
(FileE, Rank1) -> "e1"
|
|
(FileE, Rank2) -> "e2"
|
|
(FileE, Rank3) -> "e3"
|
|
(FileE, Rank4) -> "e4"
|
|
(FileE, Rank5) -> "e5"
|
|
(FileE, Rank6) -> "e6"
|
|
(FileE, Rank7) -> "e7"
|
|
(FileE, Rank8) -> "e8"
|
|
(FileF, Rank1) -> "f1"
|
|
(FileF, Rank2) -> "f2"
|
|
(FileF, Rank3) -> "f3"
|
|
(FileF, Rank4) -> "f4"
|
|
(FileF, Rank5) -> "f5"
|
|
(FileF, Rank6) -> "f6"
|
|
(FileF, Rank7) -> "f7"
|
|
(FileF, Rank8) -> "f8"
|
|
(FileG, Rank1) -> "g1"
|
|
(FileG, Rank2) -> "g2"
|
|
(FileG, Rank3) -> "g3"
|
|
(FileG, Rank4) -> "g4"
|
|
(FileG, Rank5) -> "g5"
|
|
(FileG, Rank6) -> "g6"
|
|
(FileG, Rank7) -> "g7"
|
|
(FileG, Rank8) -> "g8"
|
|
(FileH, Rank1) -> "h1"
|
|
(FileH, Rank2) -> "h2"
|
|
(FileH, Rank3) -> "h3"
|
|
(FileH, Rank4) -> "h4"
|
|
(FileH, Rank5) -> "h5"
|
|
(FileH, Rank6) -> "h6"
|
|
(FileH, Rank7) -> "h7"
|
|
(FileH, Rank8) -> "h8"
|
|
|
|
instance ToHttpApiData Position where
|
|
toUrlPiece = pack . show
|
|
toQueryParam = toUrlPiece
|
|
|
|
instance FromHttpApiData Position where
|
|
parseUrlPiece position = case position of
|
|
"a1" -> Right a1
|
|
"a2" -> Right a2
|
|
"a3" -> Right a3
|
|
"a4" -> Right a4
|
|
"a5" -> Right a5
|
|
"a6" -> Right a6
|
|
"a7" -> Right a7
|
|
"a8" -> Right a8
|
|
"b1" -> Right b1
|
|
"b2" -> Right b2
|
|
"b3" -> Right b3
|
|
"b4" -> Right b4
|
|
"b5" -> Right b5
|
|
"b6" -> Right b6
|
|
"b7" -> Right b7
|
|
"b8" -> Right b8
|
|
"c1" -> Right c1
|
|
"c2" -> Right c2
|
|
"c3" -> Right c3
|
|
"c4" -> Right c4
|
|
"c5" -> Right c5
|
|
"c6" -> Right c6
|
|
"c7" -> Right c7
|
|
"c8" -> Right c8
|
|
"d1" -> Right d1
|
|
"d2" -> Right d2
|
|
"d3" -> Right d3
|
|
"d4" -> Right d4
|
|
"d5" -> Right d5
|
|
"d6" -> Right d6
|
|
"d7" -> Right d7
|
|
"d8" -> Right d8
|
|
"e1" -> Right e1
|
|
"e2" -> Right e2
|
|
"e3" -> Right e3
|
|
"e4" -> Right e4
|
|
"e5" -> Right e5
|
|
"e6" -> Right e6
|
|
"e7" -> Right e7
|
|
"e8" -> Right e8
|
|
"f1" -> Right f1
|
|
"f2" -> Right f2
|
|
"f3" -> Right f3
|
|
"f4" -> Right f4
|
|
"f5" -> Right f5
|
|
"f6" -> Right f6
|
|
"f7" -> Right f7
|
|
"f8" -> Right f8
|
|
"g1" -> Right g1
|
|
"g2" -> Right g2
|
|
"g3" -> Right g3
|
|
"g4" -> Right g4
|
|
"g5" -> Right g5
|
|
"g6" -> Right g6
|
|
"g7" -> Right g7
|
|
"g8" -> Right g8
|
|
"h1" -> Right h1
|
|
"h2" -> Right h2
|
|
"h3" -> Right h3
|
|
"h4" -> Right h4
|
|
"h5" -> Right h5
|
|
"h6" -> Right h6
|
|
"h7" -> Right h7
|
|
"h8" -> Right h8
|
|
_ -> Left "Couldn't parse Position"
|
|
parseQueryParam = parseUrlPiece
|
|
|
|
a1 = Position (FileA, Rank1)
|
|
a2 = Position (FileA, Rank2)
|
|
a3 = Position (FileA, Rank3)
|
|
a4 = Position (FileA, Rank4)
|
|
a5 = Position (FileA, Rank5)
|
|
a6 = Position (FileA, Rank6)
|
|
a7 = Position (FileA, Rank7)
|
|
a8 = Position (FileA, Rank8)
|
|
b1 = Position (FileB, Rank1)
|
|
b2 = Position (FileB, Rank2)
|
|
b3 = Position (FileB, Rank3)
|
|
b4 = Position (FileB, Rank4)
|
|
b5 = Position (FileB, Rank5)
|
|
b6 = Position (FileB, Rank6)
|
|
b7 = Position (FileB, Rank7)
|
|
b8 = Position (FileB, Rank8)
|
|
c1 = Position (FileC, Rank1)
|
|
c2 = Position (FileC, Rank2)
|
|
c3 = Position (FileC, Rank3)
|
|
c4 = Position (FileC, Rank4)
|
|
c5 = Position (FileC, Rank5)
|
|
c6 = Position (FileC, Rank6)
|
|
c7 = Position (FileC, Rank7)
|
|
c8 = Position (FileC, Rank8)
|
|
d1 = Position (FileD, Rank1)
|
|
d2 = Position (FileD, Rank2)
|
|
d3 = Position (FileD, Rank3)
|
|
d4 = Position (FileD, Rank4)
|
|
d5 = Position (FileD, Rank5)
|
|
d6 = Position (FileD, Rank6)
|
|
d7 = Position (FileD, Rank7)
|
|
d8 = Position (FileD, Rank8)
|
|
e1 = Position (FileE, Rank1)
|
|
e2 = Position (FileE, Rank2)
|
|
e3 = Position (FileE, Rank3)
|
|
e4 = Position (FileE, Rank4)
|
|
e5 = Position (FileE, Rank5)
|
|
e6 = Position (FileE, Rank6)
|
|
e7 = Position (FileE, Rank7)
|
|
e8 = Position (FileE, Rank8)
|
|
f1 = Position (FileF, Rank1)
|
|
f2 = Position (FileF, Rank2)
|
|
f3 = Position (FileF, Rank3)
|
|
f4 = Position (FileF, Rank4)
|
|
f5 = Position (FileF, Rank5)
|
|
f6 = Position (FileF, Rank6)
|
|
f7 = Position (FileF, Rank7)
|
|
f8 = Position (FileF, Rank8)
|
|
g1 = Position (FileG, Rank1)
|
|
g2 = Position (FileG, Rank2)
|
|
g3 = Position (FileG, Rank3)
|
|
g4 = Position (FileG, Rank4)
|
|
g5 = Position (FileG, Rank5)
|
|
g6 = Position (FileG, Rank6)
|
|
g7 = Position (FileG, Rank7)
|
|
g8 = Position (FileG, Rank8)
|
|
h1 = Position (FileH, Rank1)
|
|
h2 = Position (FileH, Rank2)
|
|
h3 = Position (FileH, Rank3)
|
|
h4 = Position (FileH, Rank4)
|
|
h5 = Position (FileH, Rank5)
|
|
h6 = Position (FileH, Rank6)
|
|
h7 = Position (FileH, Rank7)
|
|
h8 = Position (FileH, Rank8)
|
|
|
|
newtype Board = Board { unBoard :: Map Position Piece }
|
|
|
|
instance ToHtml Board where
|
|
toHtml (Board board) = do
|
|
div_ [class_ "grid grid-cols-8 grid-rows-8 gap-0 h-full w-full border-2 border-black"] $ do
|
|
forM_
|
|
([encodingToPosition (encodedFile, encodedRank) | encodedFile <- [0 .. 7], encodedRank <- [0 .. 7]])
|
|
( \position -> do
|
|
let tileClass = positionToTileClass position
|
|
case Map.lookup position board of
|
|
Just piece -> do
|
|
div_
|
|
[ id_ $ tShow position
|
|
, tileClass
|
|
, hxGet_ $ "/select?position=" <> toQueryParam position <> "&piece=" <> toUrlPiece piece
|
|
, hxSwap_ "outerHTML"
|
|
]
|
|
$ toHtml piece
|
|
Nothing -> div_ [tileClass] ""
|
|
)
|
|
toHtmlRaw = toHtml
|
|
|
|
tShow :: Show a => a -> Text
|
|
tShow = pack . show
|
|
|
|
startingBoard :: Board
|
|
startingBoard = Board (Map.fromList $ whiteFront <> whiteBack <> blackFront <> blackBack)
|
|
where
|
|
whiteFront =
|
|
[ (a2, wPawn),
|
|
(b2, wPawn),
|
|
(c2, wPawn),
|
|
(d2, wPawn),
|
|
(e2, wPawn),
|
|
(f2, wPawn),
|
|
(g2, wPawn),
|
|
(h2, wPawn)
|
|
]
|
|
blackFront =
|
|
[ (a7, bPawn),
|
|
(b7, bPawn),
|
|
(c7, bPawn),
|
|
(d7, bPawn),
|
|
(e7, bPawn),
|
|
(f7, bPawn),
|
|
(g7, bPawn),
|
|
(h7, bPawn)
|
|
]
|
|
whiteBack =
|
|
[ (a1, wRook),
|
|
(b1, wKnight),
|
|
(c1, wBishop),
|
|
(d1, wQueen),
|
|
(e1, wKing),
|
|
(f1, wBishop),
|
|
(g1, wKnight),
|
|
(h1, wRook)
|
|
]
|
|
blackBack =
|
|
[ (a8, bRook),
|
|
(b8, bKnight),
|
|
(c8, bBishop),
|
|
(d8, bQueen),
|
|
(e8, bKing),
|
|
(f8, bBishop),
|
|
(g8, bKnight),
|
|
(h8, bRook)
|
|
]
|
|
|
|
encodingToPosition :: (Int, Int) -> Position
|
|
encodingToPosition (x, y) = Position (toEnum y, toEnum (7 - x))
|
|
|
|
calculatePossibleMoves :: Board -> Position -> Piece -> [Position]
|
|
calculatePossibleMoves (Board board) (Position (file, rank)) (Piece (pieceColor, pieceType)) = undefined
|
|
|
|
performMove :: Board -> Position -> Piece -> (Board, Maybe Piece)
|
|
performMove (Board board) position piece = undefined
|
|
|
|
positionToTileClass :: Position -> Attribute
|
|
positionToTileClass (Position (file, rank)) =
|
|
class_ $ "flex items-center justify-center aspect-square text-3xl " <>
|
|
case (even $ fromEnum file, even $ fromEnum rank) of
|
|
(True, True) -> "bg-gray-700"
|
|
(True, False) -> "bg-gray-200"
|
|
(False, False) -> "bg-gray-700"
|
|
(False, True) -> "bg-gray-200"
|