Task
 
Generate a random chess position in FEN format.

The position does not have to be realistic or even balanced,  but it must comply to the following rules:

 there is one and only one king of each color  (one black king and one white king);
 the kings must not be placed on adjacent squares;
 there can not be any pawn in the promotion square  (no white pawn in the eighth rank, and no black pawn in the first rank);
 including the kings, up to 32 pieces of either color can be placed. 
 There is no requirement for material balance between sides. 
 The picking of pieces does not have to comply to a regular chess set --- there can be five knights, twenty rooks, whatever ... as long as the total number of pieces do not exceed thirty-two. 
 it is white's turn.
 It's assumed that both sides have lost castling rights and that there is no possibility for   en passant   (the FEN should thus end in w - - 0 1).


No requirement is made regarding the probability distribution of your method, but your program should be able to span a reasonably representative sample of all possible positions. For instance, programs that would always generate positions with say five pieces on the board, or with kings on a corner, would not be considered truly random.




{-# LANGUAGE LambdaCase, TupleSections #-}
 
module RandomChess
( placeKings
, placePawns
, placeRemaining
, emptyBoard
, toFen
, ChessBoard
, Square (..)
, BoardState (..)
, getBoard
)
where
 
import Control.Monad.State (State, get, gets, put)
import Data.List (find, sortBy)
import System.Random (Random, RandomGen, StdGen, random, randomR)
 
type Pos = (Char, Int)
 
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)
 
type PieceCount = [(Square, Int)]
 
data BoardState = BoardState { board :: ChessBoard , generator :: StdGen }
 
instance Show Square where
  show (ChessPiece King   Black) = "♚"
  show (ChessPiece Queen  Black) = "♛"
  show (ChessPiece Rook   Black) = "♜"
  show (ChessPiece Bishop Black) = "♝"
  show (ChessPiece Knight Black) = "♞"
  show (ChessPiece Pawn   Black) = "♟"
  show (ChessPiece King   White) = "♔"
  show (ChessPiece Queen  White) = "♕"
  show (ChessPiece Rook   White) = "♖"
  show (ChessPiece Bishop White) = "♗"
  show (ChessPiece Knight White) = "♘"
  show (ChessPiece Pawn   White) = "♙"
  show EmptySquare               = " "
 
instance Random PieceRank where
  randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of
    (x, g'') -> (toEnum x, 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 = randomR (minBound, maxBound)
 
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 = fmap (EmptySquare,) . (,) <$> ['a'..'h'] <*> [1..8]
 
replaceSquareByPos :: (Square, Pos) -> ChessBoard -> ChessBoard
replaceSquareByPos e@(_, p) = fmap (\x -> if p == snd x then e else x)
 
isPosOccupied :: Pos -> ChessBoard -> Bool
isPosOccupied p = occupied . find (\x -> p == snd x)
 where
  occupied (Just (EmptySquare, _)) = False
  occupied _                       = True
 
isAdjacent :: Pos -> Pos -> Bool
isAdjacent (x1, y1) (x2, y2) =
  let upOrDown    = (pred y1 == y2 || succ y1 == y2)
      leftOrRight = (pred x1 == x2 || succ x1 == x2)
  in  (x2 == x1 && upOrDown)
        || (pred x1 == x2 && upOrDown)
        || (succ x1 == x2 && upOrDown)
        || (leftOrRight && y1 == y2)
 
fen :: Square -> String
fen (ChessPiece King   Black) = "k"
fen (ChessPiece Queen  Black) = "q"
fen (ChessPiece Rook   Black) = "r"
fen (ChessPiece Bishop Black) = "b"
fen (ChessPiece Knight Black) = "n"
fen (ChessPiece Pawn   Black) = "p"
fen (ChessPiece King   White) = "K"
fen (ChessPiece Queen  White) = "Q"
fen (ChessPiece Rook   White) = "R"
fen (ChessPiece Bishop White) = "B"
fen (ChessPiece Knight White) = "N"
fen (ChessPiece Pawn   White) = "P"
 
boardSort :: (Square, Pos) -> (Square, Pos) -> Ordering
boardSort (_, (x1, y1)) (_, (x2, y2)) | y1 < y2  = GT
                                      | y1 > y2  = LT
                                      | y1 == y2 = compare x1 x2
 
toFen :: ChessBoard -> String
toFen [] = " w - - 0 1" <> []
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 (x:xs) 0           = 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
withStateGen :: (StdGen -> (a, StdGen)) -> State BoardState a
withStateGen f = do
  currentState <- get
  let gen1 = generator currentState
  let (x, gen2) = f gen1
  put (currentState {generator = gen2})
  pure x
 
randomPos :: State BoardState Pos
randomPos = do
  boardState <- gets board
  chr <- withStateGen (randomR ('a', 'h'))
  num <- withStateGen (randomR (1, 8))
  let pos = (chr, num)
  if isPosOccupied pos boardState then
    randomPos
  else
    pure pos
 
randomPiece :: State BoardState Square
randomPiece = ChessPiece <$> withStateGen random <*> withStateGen random
 
placeKings :: State BoardState ()
placeKings = do
  currentState <- get
  p1 <- randomPos
  p2 <- randomPos
  if p1 `isAdjacent` p2 || p1 == p2
    then placeKings
    else do
      let updatedBoard = replaceSquareByPos (ChessPiece King White, p1) $
            replaceSquareByPos (ChessPiece King Black, p2) (board currentState)
      put currentState { board = updatedBoard }
 
placePawns :: State BoardState ()
placePawns = withStateGen (randomR (1, 16)) >>= go
  where
    go :: Int -> State BoardState ()
    go 0 = pure ()
    go n = do
      currentState <- get
      pos <- randomPos
      color <- withStateGen random
      let pawn = ChessPiece Pawn color
      let currentBoard = board currentState
      if promoted color == snd pos || isPosOccupied pos currentBoard ||
                           enpassant color == snd pos || firstPos color == snd pos
        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 ()
placeRemaining =
  withStateGen (randomR (5, sum $ fmap snd remaining)) >>= go remaining
  where
    remaining = filter (\case
                         (ChessPiece King _, _) -> False
                         (ChessPiece Pawn _, _) -> False
                         (EmptySquare, _) -> False
                         _ -> True)
                        fullBoard
 
    go :: PieceCount -> Int -> State BoardState ()
    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))
 
getBoard :: State BoardState ChessBoard
getBoard = gets (sortBy boardSort . board)