module Chess
where
import qualified Data.Char as Char
import qualified Data.List as List
import OpenTheory.Unicode
import qualified Unicode
data Side =
Black
| White
deriving (Eq,Ord,Show)
data Piece =
King
| Queen
| Rook
| Bishop
| Knight
| Pawn
deriving (Eq,Ord,Show)
data Edge =
NoEdge
| SingleEdge
| DoubleEdge
deriving (Eq,Ord,Show)
newtype Board =
Board { unBoard :: [[Maybe (Side,Piece)]] }
deriving (Eq,Ord,Show)
emptySquareUnicode :: Unicode
emptySquareUnicode = Unicode 8729
fenToSide :: Char -> Side
fenToSide c = if Char.isLower c then Black else White
fenToPiece :: Char -> Piece
fenToPiece c =
case Char.toLower c of
'k' -> King
'q' -> Queen
'r' -> Rook
'b' -> Bishop
'n' -> Knight
'p' -> Pawn
_ -> error $ "bad FEN character: " ++ show c
fenToSidePiece :: Char -> (Side,Piece)
fenToSidePiece c = (fenToSide c, fenToPiece c)
fenToBoard :: String -> Board
fenToBoard =
Board . uncurry (:) . foldr parse ([],[])
where
parse '/' (r,rs) = ([], r : rs)
parse c (r,rs) =
if Char.isDigit c
then (replicate (Char.digitToInt c) Nothing ++ r, rs)
else (Just (fenToSidePiece c) : r, rs)
stringToEdge :: String -> Edge
stringToEdge "0" = NoEdge
stringToEdge "1" = SingleEdge
stringToEdge "2" = DoubleEdge
stringToEdge _ = error "edge must be one of {0,1,2}"
sidePieceToUnicode :: (Side,Piece) -> Unicode
sidePieceToUnicode p =
Unicode codepoint
where
codepoint =
case p of
(White,King) -> 9812
(White,Queen) -> 9813
(White,Rook) -> 9814
(White,Bishop) -> 9815
(White,Knight) -> 9816
(White,Pawn) -> 9817
(Black,King) -> 9818
(Black,Queen) -> 9819
(Black,Rook) -> 9820
(Black,Bishop) -> 9821
(Black,Knight) -> 9822
(Black,Pawn) -> 9823
squareToUnicode :: Maybe (Side,Piece) -> Unicode
squareToUnicode Nothing = emptySquareUnicode
squareToUnicode (Just p) = sidePieceToUnicode p
rankToUnicode :: [Maybe (Side,Piece)] -> [Unicode]
rankToUnicode = map squareToUnicode
boardToUnicode :: Edge -> Board -> [Unicode]
boardToUnicode e b =
top ++ List.intercalate Unicode.newline (map rank (unBoard b)) ++ bottom
where
rank l = side ++ rankToUnicode l ++ side
top = case e of
NoEdge -> []
SingleEdge -> singleTop
DoubleEdge -> doubleTop
side = case e of
NoEdge -> []
SingleEdge -> singleSide
DoubleEdge -> doubleSide
bottom = case e of
NoEdge -> []
SingleEdge -> singleBottom
DoubleEdge -> doubleBottom
singleTop = topEdge 9484 9472 9488
singleSide = sideEdge 9474
singleBottom = bottomEdge 9492 9472 9496
doubleTop = topEdge 9556 9552 9559
doubleSide = sideEdge 9553
doubleBottom = bottomEdge 9562 9552 9565
topEdge x y z = longEdge x y z ++ Unicode.newline
sideEdge x = [Unicode x]
bottomEdge x y z = Unicode.newline ++ longEdge x y z
longEdge x y z = map Unicode ([x] ++ replicate 8 y ++ [z])
fenToUnicode :: String -> Edge -> [Unicode]
fenToUnicode f e = boardToUnicode e (fenToBoard f)