Grand Chess domain model and helper functions

Question

So I am trying to write, essentially from a blank slate, a program that plays Grand Chess. In short, it is a chess variant that is played with two extra pieces, on a 10x10 board, no castling, and optional promotion on the 8th and 9th ranks, mandatory on the last. Finally, you may not promote to a piece unless it has been captured (no 2 queens, for example.) Rest of the rules are the same as chess.

These functions will, hopefully, be the basis for both a UI to play the game and a simple engine to play against.

I have somewhat implemented the kind-of-complicated promotion rules, but I am not too sure about the implementation. It should only generate legal moves. The only legality check is checking whether the move ends with the King in check. I am maintaining that you can only promote to a captured piece by maintaining a piece list in the Position Type. this will probably generate tons of garbage, so any performance improvements are welcome.

Edit: The code below is a restructuring / renaming / refactoring of the original code posted here. I did so since there were no answers nor comments and I kept working on the code anyway. The algorithms used and the main logic are the same, however.

Without further ado:

Types.fs

namespace Stamma

type Color = 
    | White
    | Black
    member x.Opp = 
        match x with
        | White -> Black
        | Black -> White

(*
This type is replaced by simple int * int tuples throughout

type Vector = 
    { Forward : int // changes per player 
      East : int } // to the Right of the white player. 
*)

type Piece = 
    | King
    | Queen
    | Marshal
    | Cardinal
    | Bishop
    | Knight
    | Rook
    | Pawn

type MoveType = 
    | Move
    | Capture
    | Promotion of Piece
    | CapAndPromotion of Piece

type Coordinates = 
    { Rank : int
      File : int }

[<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
type Field = 
    | Empty
    | Piece of Piece * Color

type Position = 
    { Board : Map<Coordinates, Field>
      EnPassant : Coordinates
      Turn : Color
      KingWhite : Coordinates
      KingBlack : Coordinates
      CappedWhite : Piece list
      CappedBlack : Piece list 
      ReversibleCount : int}

Piece.fs

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module Stamma.Piece

open System

let private charMap = 
    [ ('k', King)
      ('q', Queen)
      ('m', Marshal)
      ('c', Cardinal)
      ('p', Pawn)
      ('n', Knight)
      ('b', Bishop)
      ('r', Rook) ]
    |> Map.ofList

let ofChar c = 
    let color = 
        if Char.IsLower c then Black
        else White
    Piece(Map.find (Char.ToLower c) charMap, color)

let toChar color piece = 
    let ch = Map.findKey (fun c p -> p = piece) charMap
    if color = White then Char.ToUpper ch
    else ch

let internal vectors = 
    function 
    | Rook -> 
        [ (1, 0)
          (0, 1)
          (-1, 0)
          (0, -1) ]
    | Bishop -> 
        [ (1, 1)
          (-1, -1)
          (-1, 1)
          (1, -1) ]
    | King | Queen -> 
        [ (1, 0)
          (0, 1)
          (-1, 0)
          (0, -1)
          (1, 1)
          (-1, -1)
          (-1, 1)
          (1, -1) ]
    | Knight -> 
        [ (-2, -1)
          (-2, 1)
          (-1, -2)
          (-1, 2)
          (1, -2)
          (1, 2)
          (2, -1)
          (2, 1) ]
    | _ -> [] (* unused *)

Board.fs

Everything from here onwards is on the assumption that

• First Rank is 1
• First File is 1
• Board is 10x10

The board is represented by a Map<Coordinates, Field> . Might later swap the coordinates type to be either represented as a string (such as "a1") or an int * int, or just replace the whole thing with an Array2D or a bitboard (once I figure out how they work,) but I think optimizing the board representation can wait.

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module Stamma.Board

let private ofFenRank fenR = 
    let mutable baseArray = Array.create 10 Empty
    if fenR = "10" then baseArray
    else 
        let rec loop (rnk : string) count = 
            if count = 10 then ()
            elif System.Char.IsLetter rnk.[0] then 
                baseArray.[count] <- Piece.ofChar rnk.[0]
                loop (rnk.Substring 1) (count + 1)
            else 
                let dgt = int rnk.[0] - 48
                loop (rnk.Substring 1) (count + dgt)
        loop fenR 0
        baseArray

let ofFen (fen : string) = 
    fen.Split '/'
    |> Array.rev
    |> Array.map ofFenRank
    |> Array.collect id
    |> Array.mapi (fun idx F -> 
           ({ Rank = idx / 10 + 1
              File = idx % 10 + 1 }, F))
    |> Map.ofArray

(* logic translated from my C# experiment, which I probably stole from somewhere *)
let toFen board = 
    let mutable esc = 0
    let mutable sb = System.Text.StringBuilder()
    for r in 10..-1..1 do
        for f in 1..10 do
            match Map.find { Rank = r
                             File = f } board with
            | Empty -> esc <- esc + 1
            | Piece(p, c) -> 
                if esc > 0 then 
                    sb.Append esc |> ignore
                    esc <- 0
                else sb.Append(Piece.toChar c p) |> ignore
        if esc > 0 then 
            sb.Append esc |> ignore
            esc <- 0
        if r > 1 then sb.Append '/' |> ignore
    sb.ToString()

let empty = ofFen "10/10/10/10/10/10/10/10/10/10"
let start = 
    ofFen "r8r/1nbqkmcbn1/pppppppppp/10/10/10/10/PPPPPPPPPP/1NBQKMCBN1/R8R"

let toAscii board = 
    seq { 
        for r in 10..-1..1 do
            for f in 1..11 do
                if f = 11 then yield sprintf "| %d\n" r
                else 
                    match Map.find { Rank = r
                                     File = f } board with
                    | Empty -> yield "| "
                    | Piece(p, c) -> yield sprintf "|%c" (Piece.toChar c p)
        yield " a b c d e f g h i j\n"
    }
    |> String.concat ""

Position.fs

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module Stamma.Position

(* Pawn Promotion logic *)

let private applyVector turn start (x, y) = 
    { Rank = 
          start.Rank + ((if turn = White then 1
                         else -1)
                        * x)
      File = start.File + y }

let private pawnMove start pos = 
    let reach = 
        match start.Rank, pos.Turn with
        | 3, White | 8, Black -> 2
        | _ -> 1

    let rec loop start acc r = 
        if r = 0 then acc
        else 
            let dist = applyVector pos.Turn start (1, 0)
            match Map.tryFind dist pos.Board with
            | Some Empty -> loop dist (dist :: acc) (r - 1)
            | _ -> acc

    loop start [] reach

let private pawnCap start pos = 
    [ -1; 1 ]
    |> List.map (fun x -> applyVector pos.Turn start (1, x))
    |> List.filter (fun sq -> 
           sq = pos.EnPassant || (match Map.tryFind sq pos.Board with
                                  | Some(Piece(_, c)) when c <> pos.Turn -> true
                                  | _ -> false))

let private promotionTarget start pos = 
    let proTarsWhite = 
        pos.CappedWhite
        |> List.distinct
        |> List.map Promotion

    let proTarsBlack = 
        pos.CappedBlack
        |> List.distinct
        |> List.map Promotion

    match pos.Turn, start.Rank with
    | White, n when n < 7 -> [ Move ]
    | Black, n when n > 4 -> [ Move ]
    | White, n when n < 9 -> Move :: proTarsWhite
    | Black, n when n > 2 -> Move :: proTarsBlack
    | White, _ -> proTarsWhite
    | _ -> proTarsBlack

(* Way finding Logic :
 * Result is ( Coordinates * Coordinates * MoveType )
 * Stands for ( Start Square * End Square * MoveType )
 *)

let private wayfindCore start pos piece reach = 
    let rec loop start acc reach vector = 
        if reach = 0 then acc
        else 
            let dist = applyVector pos.Turn start vector
            match Map.tryFind dist pos.Board with
            | Some(Piece(p, c)) when c <> pos.Turn -> (dist, Capture) :: acc
            | Some(Empty) -> loop dist ((dist, Move) :: acc) (reach - 1) vector
            | _ -> acc
    Piece.vectors piece
    |> List.collect (loop start [] reach)
    |> List.map (fun (d, m) -> start, d, m)

let rec private wayfindMoveAux start piece pos = 
    match piece with
    | Rook | Bishop | Queen -> wayfindCore start pos piece 10
    | Knight | King -> wayfindCore start pos piece 1
    | Marshal -> wayfindMoveAux start Rook pos @ wayfindMoveAux start Knight pos
    | Cardinal -> wayfindMoveAux start Bishop pos @ wayfindMoveAux start Knight pos
    | Pawn -> 
        pawnMove start pos 
        |> List.collect (fun x -> promotionTarget start pos |> List.map (fun y -> start, x, y))

let private wayfindCapsAux start piece pos = 
    match piece with
    | Pawn -> 
        pawnCap start pos
        |> List.collect (fun x -> promotionTarget start pos |> List.map (fun y -> start, x, y))
        |> List.map (fun (s, d, m) -> 
               (s, d, 
                match m with
                | Move | Capture -> Capture
                | Promotion(p) | CapAndPromotion(p) -> CapAndPromotion(p)))
    | _ -> 
        wayfindMoveAux start piece pos |> List.filter (function 
                                              | _, _, Capture | _, _, CapAndPromotion(_) -> true
                                              | _ -> false)

(* END OF AUX FUNCTIONS *)

(* START OF USEFUL FUNCTIONS *)

let wayfindMovesFrom start pos = 
    match Map.find start pos.Board with
    | Empty -> []
    | Piece(_, c) when c <> pos.Turn -> []
    | Piece(p, _) -> wayfindMoveAux start p pos

let wayfindCapsFrom start pos = 
    match Map.find start pos.Board with
    | Empty -> []
    | Piece(_, c) when c <> pos.Turn -> []
    | Piece(p, _) -> wayfindCapsAux start p pos

let wayfind pos = 
    pos.Board
    |> Map.toList
    |> List.collect (fun (s, f) -> 
           wayfindMovesFrom s pos @ (if f = Piece(Pawn, pos.Turn) then wayfindCapsFrom s pos
                                     else []))

(* Legality checking  *)
let isAttacked loc pos = 
    List.exists (fun (_, dist, _) -> 
        match Map.find dist pos.Board with
        | Piece(Rook, c) | Piece(Queen, c) | Piece(Marshal, c) when c = pos.Turn.Opp -> true
        | _ -> false) (wayfindCapsAux loc Rook pos) 
    && List.exists (fun (_, dist, _) -> 
           match Map.find dist pos.Board with
           | Piece(Knight, c) | Piece(Cardinal, c) | Piece(Marshal, c) when c = pos.Turn.Opp -> true
           | _ -> false) (wayfindCapsAux loc Knight pos) 
    && List.exists (fun (_, dist, _) -> 
           match Map.find dist pos.Board with
           | Piece(Bishop, c) | Piece(Queen, c) | Piece(Cardinal, c) when c = pos.Turn.Opp -> true
           | _ -> false) (wayfindCapsAux loc Bishop pos) 
    && List.exists (fun (_, dist, _) -> 
           match Map.find dist pos.Board with
           | Piece(Pawn, c) when c <> pos.Turn -> true
           | _ -> false) (wayfindCapsAux loc Pawn pos)
    && List.exists (fun (_, dist, _) -> 
           match Map.find dist pos.Board with
           | Piece(King, c) when c <> pos.Turn -> true
           | _ -> false) (wayfindCapsAux loc King pos)

let isDefended loc pos = isAttacked loc { pos with Turn = pos.Turn.Opp }

let isCheck pos = 
    if pos.Turn = White then isAttacked pos.KingWhite pos
    else isAttacked pos.KingBlack pos

let isLegal pos = 
    (* checks if the wrong king is in check *)
    isCheck { pos with Turn = pos.Turn.Opp } |> not

let applyMove pos (start, dist, move) = 
    let movingPiece = 
        match Map.find start pos.Board with
        | Piece(p, c) when c = pos.Turn -> p
        | _ -> failwith "What are you trying to move?"

    let endPiece, promo = 
        match move with
        | Promotion(p) | CapAndPromotion(p) -> p, true
        | _ -> movingPiece, false

    let capturedPiece = 
        match move with
        | Move | Promotion(_) -> None
        | _ -> 
            match Map.find dist pos.Board with
            | Piece(p, _) when p <> Pawn -> Some p
            | _ -> None

    let update capped turn = 
        match pos.Turn, capturedPiece with
        | t, Some p when t = turn -> p :: capped
        | _ -> capped

    let rec remove pred lst = 
        match lst with
        | h :: t when pred h -> t
        | h :: t -> h :: remove pred t
        | _ -> []

    let newBoard = 
        pos.Board
        |> Map.add dist (Piece(endPiece, pos.Turn))
        |> Map.add start Empty

    { pos with Board = 
                   if pos.EnPassant = dist && movingPiece = Pawn then 
                       newBoard |> Map.add { Rank = start.Rank
                                             File = dist.File } Empty
                   else newBoard
               KingWhite = 
                   if movingPiece = King && pos.Turn = White then dist
                   else pos.KingWhite
               KingBlack = 
                   if movingPiece = King && pos.Turn = Black then dist
                   else pos.KingBlack
               CappedWhite = update pos.CappedWhite Black |> remove (fun x -> promo && x = endPiece)
               CappedBlack = update pos.CappedBlack White |> remove (fun x -> promo && x = endPiece)
               Turn = pos.Turn.Opp
               EnPassant = 
                   if movingPiece = Pawn && abs (start.Rank - dist.Rank) = 2 then 
                       { Rank = (start.Rank + dist.Rank) / 2
                         File = start.File }
                   else 
                       { Rank = 0
                         File = 0 } }

let wayfindLegalPositions pos = 
    pos
    |> wayfind
    |> List.map (applyMove pos)
    |> List.filter isLegal

let isCheckmate pos = isCheck pos && (wayfindLegalPositions pos |> List.length) = 0
let isStalemate pos = not (isCheck pos) && (wayfindLegalPositions pos |> List.length) = 0

Game.fs

[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
[<RequireQualifiedAccess>]
module Stamma.Game

open System

let start() = raise (NotImplementedException())

let makeMove game = raise (NotImplementedException())

Any improvements that could be suggested (especially performance or algorithm validity) are welcome. Of particular concern for me is where I can go forward from here? I realize I have the core logic, but how do I extend that core logic so I can play a game?

Answer 1

In toFen, you don't need sb to be mutable. You're not reassigning it, but are instead calling methods on it, of which mutable does not affect.

The same thing applies to baseArray in ofFenRank. This doesn't need to be mutable, because you're not directly assigning to the array, but are assigning to elements in the array.

---

Generally, in F# it's preferred to match instead of if, especially with constants:

let private applyVector turn start (x, y) = 
    { Rank = 
          start.Rank + ((match turn with
                         | White -> 1
                         | _ -> -1)
                        * x)
      File = start.File + y }

Just as well:

let private wayfindCore start pos piece reach = 
    let rec loop start acc reach vector = 
        match reach with
        | 0 -> acc
        | _ -> let dist = applyVector pos.Turn start vector
               match Map.tryFind dist pos.Board with
               | Some(Piece(p, c)) when c <> pos.Turn -> (dist, Capture) :: acc
               | Some(Empty) -> loop dist ((dist, Move) :: acc) (reach - 1) vector
               | _ -> acc
    Piece.vectors piece
    |> List.collect (loop start [] reach)
    |> List.map (fun (d, m) -> start, d, m)

One more:

{ pos with Board = 
               match (pos.EnPassant, movingPiece) with
               | (ep, Pawn) when ep = dist ->
                   newBoard |> Map.add { Rank = start.Rank
                                         File = dist.File } Empty
               | _ -> newBoard
           KingWhite = 
               match (movingPiece, pos.Turn) with
               | (King, White) -> dist
               | _ -> pos.KingWhite
           KingBlack = 
               match (movingPiece, pos.Turn) with
               | (King, Black) -> dist
               | _ -> pos.KingBlack
           CappedWhite = update pos.CappedWhite Black |> remove (fun x -> promo && x = endPiece)
           CappedBlack = update pos.CappedBlack White |> remove (fun x -> promo && x = endPiece)
           Turn = pos.Turn.Opp
           EnPassant = 
               match (movingPiece, abs (start.Rank - dist.Rank)) with
               | (Pawn, 2) ->
                    { Rank = (start.Rank + dist.Rank) / 2
                      File = start.File }
               | _ ->
                    { Rank = 0
                      File = 0 } }

---

Other than that, there's not much I can say. I'm not an expert in F# by any means. You used tail-call recursion everywhere you could, which is good. You use Option and unions when appropriate, and you used functional paradigms everywhere. The only one I don't like is the mutable esc.

Rewriting toFen as follows should eliminate the need for this mutable variable, and follow functional paradigms as much as possible. (Reduced the number of if statements substantially.)

Note: I haven't yet tested this, you provided no test data, but it should provide the same result.

let toFen board = 
    let sb = System.Text.StringBuilder()
    let rec rLoop r acc =
        let rec fLoop f acc =
            let newAcc = 
                match Map.find { Rank = r
                                 File = f } board with
                | Empty -> acc + 1
                | Piece(p, c) -> 
                    match acc with
                    | v when v > 0 ->
                        sb.Append acc |> ignore
                        0
                    | _ ->
                        sb.Append(Piece.toChar c p) |> ignore
                        acc
            match f with
            | v when v < 10 -> fLoop (f + 1) newAcc
            | _ -> newAcc

        let newAcc = fLoop 1 acc
        let finalAcc =
            if newAcc > 0 then 
                sb.Append newAcc |> ignore
                0
            elif r > 1 then
                sb.Append '/' |> ignore
                newAcc
            else
                newAcc

        if r > 1 then
            rLoop (r - 1) newAcc
    rLoop 10 0
    sb.ToString()

Basically, we use recursive loops like the functional paradigms expect.

---

All-in-all this was a very well-written programme, I actually learned a lot from it and it forced me to think functionally for a moment, and helped me remove that esc mutable variable with a little effort. Very good job! :)