Rosetta Code

Generate random chess position: Difference between revisions

Page Discussion

Generate random chess position (view source)

Revision as of 13:15, 16 April 2020

294 bytes removed ,  4 years ago
m
→‎{{header|Haskell}}
Line 568:
type ChessBoard = [(Square, Pos)]
 
data PieceRank = King | Queen | Rook | Bishop | Knight | Pawn
deriving (Enum, Bounded, Show, Eq, Ord)
data PieceColor = Black | White
deriving (Enum, Bounded, Show, Eq, Ord)
 
data Square = ChessPiece PieceRank PieceColor | EmptySquare
deriving (Eq, Ord)
 
Line 579:
 
instance Show Square where
show (ChessPiece King Black) Black) = "♚"
show (ChessPiece Queen Black) = "♛"
show (ChessPiece Rook Black) Black) = "♜"
show (ChessPiece Bishop Black) = "♝"
show (ChessPiece Knight Black) = "♞"
show (ChessPiece Pawn Black) Black) = "♟"
show (ChessPiece King White) White) = "♔"
show (ChessPiece Queen White) = "♕"
show (ChessPiece Rook White) White) = "♖"
show (ChessPiece Bishop White) = "♗"
show (ChessPiece Knight White) = "♘"
show (ChessPiece Pawn White) White) = "♙"
show EmptySquare = " "
 
instance Random PieceRank where
randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of
case(x, randomRg'') -> (fromEnumtoEnum ax, fromEnum b) g of'')
(x, g'') -> (toEnum x, g'')▼
random g = randomR (minBound, maxBound) g
 
instance Random PieceColor where
randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of
case(x, randomRg'') -> (fromEnumtoEnum ax, fromEnum b) g of'')
(x, g'') -> (toEnum x, g'')
random g = randomR (minBound, maxBound) g
 
fullBoard :: PieceCount
fullBoard =
[ (ChessPiece King Black , 1)
, (ChessPiece Queen Black , 1)
, (ChessPiece Rook Black , 2)
, (ChessPiece Bishop Black, 2)
, (ChessPiece Knight Black, 2)
, (ChessPiece Pawn Black , 8)
, (ChessPiece King White , 1)
, (ChessPiece Queen White , 1)
, (ChessPiece Rook White , 2)
, (ChessPiece Bishop White, 2)
, (ChessPiece Knight White, 2)
, (ChessPiece Pawn White , 8)
, (EmptySquare , 32)
]
 
emptyBoard :: ChessBoard
emptyBoard = [ (EmptySquare, (x, y)) | x <- ['a' .. 'h'], y <- [1 .. 8] ]
 
replaceSquareByPos :: (Square, Pos) -> ChessBoard -> ChessBoard
replaceSquareByPos e@(s, p) = map (\t@(s'', p'')x -> if p == p''snd x then (s, p)e else tx)
 
isPosOccupied :: Pos -> ChessBoard -> Bool
isPosOccupied p = occupied . foundfind (\x -> p == snd x)
where
where found = find (\(_, p'') -> p == p'')
occupied (Just (EmptySquare, _)) = False
occupied _ occupied _ = True
 
isAdjacent :: Pos -> Pos -> Bool
Line 638 ⟶ 636:
let upOrDown = (pred y == y'' || succ y == y'')
leftOrRight = (pred x == x'' || succ x == x'')
in (x'' == x && upOrDown) ||
|| (pred x == x'' && upOrDown) ||
|| (succ x == x'' && upOrDown) ||
|| (leftOrRight && y == y'')
 
fen :: Square -> String
fen (ChessPiece King Black) Black) = "k"
fen (ChessPiece Queen Black) = "q"
fen (ChessPiece Rook Black) Black) = "r"
fen (ChessPiece Bishop Black) = "b"
fen (ChessPiece Knight Black) = "n"
fen (ChessPiece Pawn Black) Black) = "p"
fen (ChessPiece King White) White) = "K"
fen (ChessPiece Queen White) = "Q"
fen (ChessPiece Rook White) White) = "R"
fen (ChessPiece Bishop White) = "B"
fen (ChessPiece Knight White) = "N"
fen (ChessPiece Pawn White) White) = "P"
 
boardSort :: (Square, Pos) -> (Square, Pos) -> Ordering
boardSort (_, (x, y)) (_, (x'', y'')) | y < y'' = GT
| y <> y'' = GT= LT
| y >== y'' = LTcompare x x''
| y == y'' = compare x x''
 
toFen :: ChessBoard -> String
toFen [] = " w - - 0 1" <> []
toFen b = scanRow (map fst $ take 8 b) 0
where
where scanRow [] 0 = nextRow
scanRow [] scanRow [] n = show n <> 0 = nextRow
scanRow [] scanRow ((EmptySquare): xs) n = scanRowshow xsn (succ<> n)nextRow
scanRow (x(EmptySquare) : xs) 0n = nextPiece xscanRow xs (succ n)
scanRow (x scanRow (x: xs) n0 = show n <> nextPiece x xs
scanRow (x : xs) n = show n <> nextPiece x xs
 
nextRow = "/" <> toFen (drop 8 b)
nextPiece x xs = fen x <> scanRow xs 0
 
-- impure functions
 
randomPos :: ChessBoard -> IO Pos
randomPos b = pos >>= \p -> if isPosOccupied p b then randomPos b else pos
where
then randomPos b ▼
where pos = (,) <$> chr <*> num▼
else pos ▼
chrnum = getStdRandom $ randomR ('a'1,'h' 8)▼
▲ where pos = (,) <$> chr <*> num
numchr = getStdRandom $ randomR (1'a',8 'h')
▲ chr = getStdRandom $ randomR ('a','h')
 
randomPiece :: IO Square
randomPiece = ChessPiece <$> rank <*> color
where
where rank = getStdRandom random▼
rank color = getStdRandom random
▲ where rank color = getStdRandom random
 
placeKings :: ChessBoard -> IO ChessBoard
placeKings b = do
p1 <- randomPos b
p2 <- randomPos b
if p1 `isAdjacent` p2 || p1 == p2
then placeKings b
else pure
pure ( replaceSquareByPos ((ChessPiece King White), p1) $
$ replaceSquareByPos ((ChessPiece King Black), p2) b)
)
 
placePawns :: ChessBoard -> IO ChessBoard
placePawns b = num >>= go b
where
where go :: ChessBoard -> Int -> IO ChessBoard
go b'' 0 = pure b''▼
go b'' n0 = dopure b''
▲ go b'' 0n = pure b''do
pos <- randomPos b''
pos pawn@(ChessPiece _ color) <- randomPawnrandomPos b''
pawn@(ChessPiece _ color) <- randomPawn
if promoted color == snd pos || isPosOccupied pos b''
if || enpassant color == snd pos || firstPospromoted color == snd pos
|| isPosOccupied then gopos b'' n
|| elseenpassant color == snd pos
|| firstPos color go== (replaceSquareByPos (pawn,snd pos) b'') (pred n)
then go promotedb'' White = 8n
else go (replaceSquareByPos (pawn, pos) b'') (pred n)
promoted Black = 1▼
enpassantpromoted White = 58
enpassantpromoted Black = 41
firstPosenpassant White = 15
firstPosenpassant Black = 84
firstPos White = 1
▲ promotedfirstPos Black = 18
 
num num = getStdRandom (randomR (1, 16))
 
randomPawn = ChessPiece Pawn <$> rColor where rColor = getStdRandom (random)
where rColor = getStdRandom (random)
 
placeRemaining :: ChessBoard -> IO ChessBoard
placeRemaining b = do
n <- num (sum $ map snd remaining)
putStrLn $ "Placing " <> show n <>
<> " more random positions after placing 2 kings and "
<> (show $ totalPawns b) <> " pawns. "
go remaining b n
where
where remaining :: [(Square, Int)]
remaining =
remaining = filter (\case
(\case
((ChessPiece King _), _) -> False▼
((ChessPiece PawnKing _), _) -> False
((ChessPiece Pawn (EmptySquare_), _) -> False
(EmptySquare , _ ) -> True) fullBoardFalse
▲ _ then randomPos b-> True
)
fullBoard
 
num mx = getStdRandom $ randomR (5, mx)
 
totalPawns = length . filter (\case ((ChessPiece Pawn _), _) -> True
▲ (\case ((ChessPiece KingPawn _), _) -> FalseTrue
_ -> False)
▲ _ else pos -> False
)
 
go :: [(Square, Int)] -> ChessBoard -> Int -> IO ChessBoard
go _ go _ b'' 0 = pure b''
go permitted b'' n = do
position <- randomPos b''
piece piece <- randomPiece
if (not $ isPermitted piece) || isPosOccupied position b''
then go permitted b'' n
else go (consume piece else permitted)
go (consume piece permitted) (replaceSquareByPos (piece, position) b'') (pred n)
putStr " " (pred n)▼
 
where
where isPermitted p = case find (\x -> fst x == p) permitted of
Just (_, count) -> count > 0
Nothing -> False
consume p'' = map (\(p, c) -> if p == p'' then (p, pred c) else (p, c))
 
draw :: ChessBoard -> IO ()
Line 763 ⟶ 770:
showXAxis
line
mapM_ (\b@(p, (x,y)) ->
▲ (\b@(p, (x, g''y)) -> (toEnumcase x, g'')of
case x of 'h' -> putStr (" | " <> show p <> " | " <> show y <> "\n") >> line
'ah' -> putStr (" | " <> show yp <> " | " <> show py <> "\n") >> line
'a' -> putStr (show y _ -<> putStr (" | " <> show p)
_ -> putStr (" | " <> show p)
)
sorted
showXAxis
Line 774 ⟶ 782:
-- mapM_ print $ sortBy (comparing fst) $ filter (\(s, _) -> s /= EmptySquare) b
 
where
where sorted = sortBy boardSort b
line line = putStrLn (" " <> (replicate 33 '-'))
showXAxis = do
▲ putStr " "
putStr " "
mapM_ (\(_, (x, _)) -> putStr $ " " <> [x]) (take 8 sorted)
putStrLn ""
 
main :: IO ()
main = placeKings emptyBoard >>= placePawns >>= placeRemaining >>= draw</lang>
main =
placeKings emptyBoard >>=
placePawns >>=
placeRemaining >>=
draw</lang>
{{out}}
Run 1
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/263107"