Rosetta Code

Generate random chess position: Difference between revisions

Page Discussion

Generate random chess position (view source)

Revision as of 18:24, 1 July 2020

1,052 bytes added ,  3 years ago
m
→‎{{header|Haskell}}
(improved function pawn_on_extreme_ranks)
Line 556:
Uses System.Random library: https://hackage.haskell.org/package/random-1.1/docs/System-Random.html
 
Module RandomChess
<lang haskell>{-# LANGUAGE LambdaCase, TupleSections #-}
 
module RandomChess
<lang haskell>{-# LANGUAGE LambdaCase #-}
( placeKings
, placePawns
, placeRemaining
, boardSort
, emptyBoard
, toFen
, ChessBoard
, Square (..)
, Pos
, BoardState (..)
, getBoard
)
where
 
import SystemControl.RandomMonad.State (getStdRandomState, randomRget, Randomgets, randomput)
import Data.List (find, sortBy)
import DataSystem.OrdRandom (comparingRandom, StdGen, random, randomR)
 
type Pos = (Char, Int)
Line 576 ⟶ 591:
 
type PieceCount = [(Square, Int)]
 
data BoardState = BoardState { board :: ChessBoard , generator :: StdGen }
 
instance Show Square where
Line 595 ⟶ 612:
randomR (a, b) g = case randomR (fromEnum a, 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
(x, g'') -> (toEnum x, g'')
random g = randomR (minBound, maxBound) g
 
fullBoard :: PieceCount
Line 620 ⟶ 637:
 
emptyBoard :: ChessBoard
emptyBoard = [fmap (EmptySquare,) . (x, y)) | x <-$> ['a' .. 'h'], y <-*> [1 .. 8] ]
 
replaceSquareByPos :: (Square, Pos) -> ChessBoard -> ChessBoard
replaceSquareByPos e@(s_, p) = mapfmap (\x -> if p == snd x then e else x)
 
isPosOccupied :: Pos -> ChessBoard -> Bool
Line 632 ⟶ 649:
 
isAdjacent :: Pos -> Pos -> Bool
isAdjacent (xx1, yy1) (x''x2, y''y2) =
let upOrDown = (pred yy1 == y''y2 || succ yy1 == y''y2)
leftOrRight = (pred xx1 == x''x2 || succ xx1 == x''x2)
in (x''x2 == xx1 && upOrDown)
|| (pred xx1 == x''x2 && upOrDown)
|| (succ xx1 == x''x2 && upOrDown)
|| (leftOrRight && yy1 == y''y2)
 
fen :: Square -> String
Line 655 ⟶ 672:
 
boardSort :: (Square, Pos) -> (Square, Pos) -> Ordering
boardSort (_, (xx1, yy1)) (_, (x''x2, y''y2)) | yy1 < y''y2 = GT
| yy1 > y''y2 = LT
| yy1 == y''y2 = compare xx1 x''x2
 
toFen :: ChessBoard -> String
toFen [] = " w - - 0 1" <> []
toFen b = scanRow (map fst <$> take 8 b) 0
where
scanRow [] 0 0 = nextRow
scanRow [] n n = show n <> nextRow
scanRow ((EmptySquare) : xs) n = scanRow xs (succ n)
scanRow (x:xs) 0 : xs) 0 = nextPiece x xs
scanRow (x:xs) n : xs) n = show n <> nextPiece x xs
nextRow = "/" <> toFen (drop 8 b)
nextPiece x xs = fen x <> scanRow xs 0
 
-- State functions
nextRow = "/" <> toFen (drop 8 b)
randomPos :: State BoardState Pos
nextPiece x xs = fen x <> scanRow xs 0
randomPos = do
currentState <- get
let gen1 = generator currentState
let (num, gen2) = randomR (1, 8) gen1
let (chr, gen3) = randomR ('a', 'h') gen2
put (currentState {generator = gen3})
let pos = (chr, num)
if isPosOccupied pos (board currentState) then
randomPos
else
pure pos
 
randomPiece :: State BoardState Square
-- IO functions
randomPiece = do
currentState <- get
let gen1 = generator currentState
let (rank, gen2) = random gen1
let (color, gen3) = random gen2
put (currentState {generator = gen3})
pure $ ChessPiece rank color
 
placeKings :: State BoardState ()
randomPos :: ChessBoard -> IO Pos
placeKings = do
randomPos b = pos >>= \p -> if isPosOccupied p b then randomPos b else pos
currentState <- get
where
p1 <- randomPos
pos = (,) <$> chr <*> num
p2 <- randomPos
num = getStdRandom $ randomR (1, 8)
chr = getStdRandom $ randomR ('a', 'h')
 
randomPiece :: IO Square
randomPiece = ChessPiece <$> rank <*> color
where
rank = getStdRandom random
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 puredo
(let updatedBoard = replaceSquareByPos ((ChessPiece King White), p1) $
$ replaceSquareByPos ((ChessPiece King Black), p2) b(board currentState)
put currentState { board = updatedBoard }
)
 
placePawns :: ChessBoardState ->BoardState IO ChessBoard()
placePawns b = num >>= go bdo
currentState <- get
where
let gen1 = generator currentState
go :: ChessBoard -> Int -> IO ChessBoard
let (totalPawns, gen2) = randomR (1, 16) gen1
go b'' 0 = pure b''
put currentState { generator = gen2 }
go b'' n = do
go totalPawns
pos <- randomPos b''
where
pawn@(ChessPiece _ color) <- randomPawn
ifgo promoted:: colorInt ==-> sndState posBoardState ()
go 0 = pure ()
|| isPosOccupied pos b''
go n = do
|| enpassant color == snd pos
currentState <- get
|| firstPos color == snd pos
thenlet gogen1 b''= ngenerator currentState
pos <- randomPos
else go (replaceSquareByPos (pawn, pos) b'') (pred n)
let (color, gen2) = random gen1
promoted White = 8
put currentState { generator = gen2 }
promoted Black = 1
let pawn = ChessPiece Pawn color
enpassant White = 5
let currentBoard = board currentState
enpassant Black = 4
if promoted color == snd pos || isPosOccupied pos currentBoard ||
firstPos White = 1
enpassant color == snd pos || firstPos color == snd pos
firstPos Black = 8
then go n
else do
put currentState { board = replaceSquareByPos (pawn, pos) currentBoard }
go $ pred n
promoted White = 8
promoted Black = 1
enpassant White = 5
enpassant Black = 4
firstPos White = 1
firstPos Black = 8
 
placeRemaining :: State BoardState ()
num = getStdRandom (randomR (1, 16))
placeRemaining = do
currentState <- get
let gen1 = generator currentState
let (n, gen2) = randomR (5, sum $ fmap snd remaining) gen1
put currentState { generator = gen2 }
go remaining n
where
remaining = filter (\case
(ChessPiece King _, _) -> False
(ChessPiece Pawn _, _) -> False
(EmptySquare, _) -> False
_ -> True)
fullBoard
 
go :: [(Square, Int)] -> Int -> State BoardState ()
randomPawn = ChessPiece Pawn <$> rColor where rColor = getStdRandom (random)
go _ 0 = pure ()
go remaining n = do
currentState <- get
let currentBoard = board currentState
position <- randomPos
piece <- randomPiece
if not (isPermitted piece) || isPosOccupied position currentBoard
then go remaining n
else do
let updatedBoard = replaceSquareByPos (piece, position) currentBoard
put currentState { board = updatedBoard }
go (consume piece remaining) (pred n)
where
isPermitted p =
case find ((==p) . fst) remaining of
Just (_, count) -> count > 0
Nothing -> False
consume p'' = fmap (\(p, c) -> if p == p'' then (p, pred c) else (p, c))
 
placeRemaininggetBoard :: ChessBoardState -> IOBoardState ChessBoard
getBoard = gets (sortBy boardSort . board)</lang>
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
remaining :: [(Square, Int)]
remaining = filter
(\case
((ChessPiece King _), _) -> False
((ChessPiece Pawn _), _) -> False
(EmptySquare , _) -> False
_ -> True
)
fullBoard
 
num mx = getStdRandom $ randomR (5, mx)
 
totalPawns = length . filter
(\case ((ChessPiece Pawn _), _) -> True
_ -> False
)
 
Module Main
go :: [(Square, Int)] -> ChessBoard -> Int -> IO ChessBoard
<lang haskell>module Main where
go _ b'' 0 = pure b''
go permitted b'' n = do
position <- randomPos b''
piece <- randomPiece
if (not $ isPermitted piece) || isPosOccupied position b''
then go permitted b'' n
else go (consume piece permitted)
(replaceSquareByPos (piece, position) b'')
(pred n)
 
import Control.Monad.State (evalState)
where
import RandomChess (ChessBoard, emptyBoard, placeKings, getBoard,
isPermitted p = case find (\x -> fst x == p) permitted of
placePawns, placeRemaining, toFen, BoardState (..))
Just (_, count) -> count > 0
import System.Random (newStdGen)
Nothing -> False
consume p'' = map (\(p, c) -> if p == p'' then (p, pred c) else (p, c))
 
draw :: ChessBoard -> IO ()
draw b = do
showXAxis >> drawLine
mapM_ (\b@(p, (x,y)) ->
line
case x of 'h' -> putStr (" | " <> show p <> " | " <> show y <> "\n") >> drawLine
mapM_
'a' -> putStr (show y <> " | " <> show p)
(\b@(p, (x, y)) -> case x of
'h' -> putStr (" | " <> show p < _ -> putStr (" | " <> show y <> "\n"p) >> line
)
'a' -> putStr (show y <> " | " <> show p)
b
_ -> putStr (" | " <> show p)
showXAxis >> putStrLn "" >> putStrLn (toFen b)
)
sorted
showXAxis
putStrLn ""
putStrLn $ toFen sorted
-- mapM_ print $ sortBy (comparing fst) $ filter (\(s, _) -> s /= EmptySquare) b
 
where
drawLine = putStrLn (" " <> replicate 33 '-')
sorted = sortBy boardSort b
line = putStrLn (" " <> (replicate 33 '-'))
showXAxis = do
putStr " "
mapM_ (\(_, (x, _)) -> putStr $ " " <> [x]) (take 8 sortedb)
putStrLn ""
 
main :: IO ()
main = do
main = placeKings emptyBoard >>= placePawns >>= placeRemaining >>= draw</lang>
stdGen <- newStdGen
draw $ evalState buildBoard (BoardState emptyBoard stdGen)
where
buildBoard = placeKings >> placePawns >> placeRemaining >> getBoard</lang>
{{out}}
Run 1
<pre> a b c d e f g h
<pre>
Placing 8 more random positions after placing 2 kings and 11 pawns.
a b c d e f g h
---------------------------------
8 | | | ♜ | ♗♘ | | ♚ | ♞ | | 8
---------------------------------
7 | ♙ | ♟ | ♟ | ♔ | ♙ | ♟♙ | ♟ | ♗♙ | 7
---------------------------------
6 | | | | ♛ | | | ♟ | ♟ | 6
---------------------------------
5 | ♘ | | ♟ | | ♟ | | | ♟ | 5
---------------------------------
4 | | | ♙ | | ♔ | ♗ | ♙ | | 4
---------------------------------
3 | ♟ | ♙♕ | ♟♜ | ♟ | | ♝♗ | ♖♚ | | 3
---------------------------------
2 | ♜♞ | | ♟ | ♟ | | ♕♙ | | ♙ | ♟ | 2
---------------------------------
1 | | | ♖ | ♝ | | ♘ | | | 1
---------------------------------
a b c d e f g h
 
3B1k22rN2n1/P4ppBPppKPP1P/6pp3q4/2p1p3N6p/4K32P2BP1/1Pp2bR1pQrp1Bk1/r1pp1Q2n3P1Pp/3b1N22R5/ w - - 0 1</pre>
</pre>
Run 2
<pre> a b c d e f g h
<pre>
Placing 9 more random positions after placing 2 kings and 2 pawns.
a b c d e f g h
---------------------------------
8 | | ♖ | | | ♚ | | | | 8
---------------------------------
7 | ♔♟ | ♙♔ | ♙ | | | | ♚ | | 7
---------------------------------
6 | ♟ | | ♜ | ♟ | | ♞ | | | | 6
---------------------------------
5 | | | ♟ | | | ♜ | | | 5
---------------------------------
4 | | ♗ | | | | | | | 4
---------------------------------
3 | | ♟ | ♙ | | ♙ | | | ♘♛ | 3
---------------------------------
2 | | | ♕ | | ♟ | ♞ | | ♘ | 2
---------------------------------
1 | ♖ | ♛♖ | | | ♝ | | | | 1
---------------------------------
a b c d e f g h
 
1R64k3/KP4k1pKP5/4n3p1rp4/5r22p5/1B68/2P4N1p2P2q/2Q2n24p2N/1q2b3RR2b3/ w - - 0 1</pre>
</pre>
etc...
 
Anonymous user
Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/263113"