Generate random chess position: Difference between revisions

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 ~~System~~.~~Random~~ (~~getStdRandom~~, ~~randomR~~, ~~Random~~, ~~random~~)

import Control.Monad.State (State, get, gets, put)

import Data.List (find, sortBy)

import ~~Data~~.~~Ord~~ (~~comparing~~)

import System.Random (Random, StdGen, random, randomR)

type Pos = (Char, Int)

Line 576:

Line 591:

type PieceCount = [(Square, Int)]

data BoardState = BoardState { board :: ChessBoard , generator :: StdGen }

instance Show Square where

Line 595:

Line 612:

randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of

(x, g'') -> (toEnum x, g'')

random g = randomR (minBound, maxBound) g

random = randomR (minBound, maxBound)

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

random = randomR (minBound, maxBound)

fullBoard :: PieceCount

Line 620:

Line 637:

emptyBoard :: ChessBoard

emptyBoard = [ (EmptySquare, (x, y)) ~~| x~~ <- ['a' .. 'h']~~, y~~ <- [1 .. 8] ]

emptyBoard = fmap (EmptySquare,) . (,) <$> ['a'..'h'] <*> [1..8]

replaceSquareByPos :: (Square, Pos) -> ChessBoard -> ChessBoard

replaceSquareByPos e@(s, p) = ~~map~~ (\x -> if p == snd x then e else x)

replaceSquareByPos e@(_, p) = fmap (\x -> if p == snd x then e else x)

isPosOccupied :: Pos -> ChessBoard -> Bool

Line 632:

Line 649:

isAdjacent :: Pos -> Pos -> Bool

isAdjacent (x, y) (~~x''~~, ~~y''~~) =

isAdjacent (x1, y1) (x2, y2) =

let upOrDown = (pred y == ~~y''~~ || succ y == ~~y''~~)

let upOrDown = (pred y1 == y2 || succ y1 == y2)

leftOrRight = (pred x == ~~x''~~ || succ x == ~~x''~~)

leftOrRight = (pred x1 == x2 || succ x1 == x2)

in (~~x''~~ == x && upOrDown)

in (x2 == x1 && upOrDown)

|| (pred x == ~~x''~~ && upOrDown)

|| (pred x1 == x2 && upOrDown)

|| (succ x == ~~x''~~ && upOrDown)

|| (succ x1 == x2 && upOrDown)

|| (leftOrRight && y == ~~y''~~)

|| (leftOrRight && y1 == y2)

fen :: Square -> String

Line 655:

Line 672:

boardSort :: (Square, Pos) -> (Square, Pos) -> Ordering

boardSort (_, (x, y)) (_, (~~x''~~, ~~y''~~)) | y < ~~y''~~ = GT

boardSort (_, (x1, y1)) (_, (x2, y2)) | y1 < y2 = GT

| y > ~~y''~~ = LT

| y1 > y2 = LT

| y == ~~y''~~ = compare x ~~x''~~

| y1 == y2 = compare x1 x2

toFen :: ChessBoard -> String

toFen [] = " w - - 0 1" <> []

toFen b = scanRow (~~map~~ fst $ take 8 b) 0

toFen b = scanRow (fst <$> take 8 b) 0

where

scanRow [] 0 = nextRow

scanRow [] n = show n <> nextRow

scanRow ((EmptySquare) : xs) n = scanRow xs (succ n)

scanRow (EmptySquare:xs) n = scanRow xs (succ n)

scanRow (x ~~: xs) 0~~ = nextPiece x xs

scanRow (x:xs) 0 = nextPiece x xs

scanRow (x ~~: xs) n~~ = 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

-- 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

then placeKings

else ~~pure~~

else do

( replaceSquareByPos ((ChessPiece King White), p1)

let updatedBoard = replaceSquareByPos (ChessPiece King White, p1) $

$ replaceSquareByPos ((ChessPiece King Black), p2) b

replaceSquareByPos (ChessPiece King Black, p2) (board currentState)

put currentState { board = updatedBoard }

)

placePawns :: ~~ChessBoard~~ -> ~~IO ChessBoard~~

placePawns :: State BoardState ()

placePawns b = ~~num >>= go b~~

placePawns = do

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

if ~~promoted~~ ~~color~~ == ~~snd~~ ~~pos~~

go :: Int -> State BoardState ()

go 0 = pure ()

|| isPosOccupied pos b''

go n = do

|| enpassant color == snd pos

currentState <- get

|| firstPos color == snd pos

~~then~~ go ~~b''~~ n

let gen1 = generator 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))

~~placeRemaining~~ :: ~~ChessBoard~~ ~~-> IO~~ ChessBoard

getBoard :: State BoardState 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

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 <> " | " <> show ~~y <> "\n"~~) ~~>> line~~

_ -> putStr (" | " <> show p)

)

'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 ~~sorted~~)

mapM_ (\(_, (x, _)) -> putStr $ " " <> [x]) (take 8 b)

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>

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

8 | | | ♜ | ♘ | | | ♞ | | 8

---------------------------------

7 | ♙ | | | | | ♟ | ♟ | ♗ | 7

7 | ♙ | ♟ | ♟ | ♔ | ♙ | ♙ | | ♙ | 7

---------------------------------

6 | | | | | | | ♟ | ♟ | 6

6 | | | | ♛ | | | | | 6

---------------------------------

5 | | | ♟ | | ♟ | | | | 5

5 | ♘ | | | | | | | ♟ | 5

---------------------------------

4 | | | | | ♔ | | | | 4

4 | | | ♙ | | | ♗ | ♙ | | 4

---------------------------------

3 | | ♙ | ♟ | | | ♝ | ♖ | | 3

3 | ♟ | ♕ | ♜ | ♟ | | ♗ | ♚ | | 3

---------------------------------

2 | ♜ | | ♟ ~~| ♟~~ | | ♕ | | | 2

2 | ♞ | | | | ♙ | | ♙ | ♟ | 2

---------------------------------

1 | | | | ♝ | | ♘ | | | 1

1 | | | ♖ | | | | | | 1

---------------------------------

a b c d e f g h

~~3B1k2~~/~~P4ppB~~/~~6pp~~/~~2p1p3~~/~~4K3~~/~~1Pp2bR1~~/~~r1pp1Q2~~/~~3b1N2~~/ w - - 0 1

2rN2n1/PppKPP1P/3q4/N6p/2P2BP1/pQrp1Bk1/n3P1Pp/2R5/ 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

8 | | | | | ♚ | | | | 8

---------------------------------

7 | ♔ | ♙ | | | | | ♚ | | 7

7 | ♟ | ♔ | ♙ | | | | | | 7

---------------------------------

6 | | | | | ♞ | | | | 6

6 | ♟ | | ♜ | ♟ | | | | | 6

---------------------------------

5 | | | | | | ♜ | | | 5

5 | | | ♟ | | | | | | 5

---------------------------------

4 | | ♗ | | | | | | | 4

4 | | | | | | | | | 4

---------------------------------

3 | | | ♙ | | | | | ♘ | 3

3 | | ♟ | | | ♙ | | | ♛ | 3

---------------------------------

2 | | | ♕ | | | ♞ | | | 2

2 | | | | | ♟ | | | ♘ | 2

---------------------------------

1 | | ♛ | | | ♝ | | | | 1

1 | ♖ | ♖ | | | ♝ | | | | 1

---------------------------------

a b c d e f g h

~~1R6~~/~~KP4k1~~/~~4n3~~/~~5r2~~/~~1B6~~/~~2P4N~~/~~2Q2n2~~/~~1q2b3~~/ w - - 0 1

4k3/pKP5/p1rp4/2p5/8/1p2P2q/4p2N/RR2b3/ w - - 0 1</pre>

</pre>

etc...