This is the third question in the series. Number 1 had most of the official two-player rules implemented, and Number 2 was the basic UI. This one has the complete two-player rules implemented, an AI using minimax with alpha-beta pruning. All suggestions welcome, especially those that help me program in a more functionally and more cleanly.
Checkers.fs contains my basic types:
module public Checkers.Types
type Player = Black | White
type PieceType = Checker | King
type Coord = { Row :int; Column :int }
let offset c1 c2 =
{ Row = c1.Row + c2.Row; Column = c1.Column + c2.Column }
type Move = Coord List
type MoveTree = { Move :Move; Parent :Option<MoveTree>; Children :Option<List<MoveTree>> }
type internal AlphaBetaMove = { Alpha :float Option; Beta :float Option; Move :Move }
Piece.fs contains the information on a piece:
module public Checkers.Piece
open Checkers.Types
type Piece = { Player :Player; PieceType :PieceType }
let Promote piece = { Player = piece.Player; PieceType = King }
let whiteChecker = Some <| { Player = White; PieceType = Checker }
let whiteKing = Some <| { Player = White; PieceType = King }
let blackChecker = Some <| { Player = Black; PieceType = Checker }
let blackKing = Some <| { Player = Black; PieceType = King }
Board.fs contains a type alias and some helper methods:
module public Checkers.Board
open Checkers.Types
open Checkers.Piece
open System.Collections.Generic
type Board = Piece option list list
let square (coord :Coord) = List.item coord.Row >> List.item coord.Column
let rowFromSeq (value :'a seq) =
Some (List.ofSeq value)
let listFromSeq (value :'a seq seq) =
List.ofSeq (Seq.choose rowFromSeq value)
let defaultBoard =
[
List.replicate 4 [None; blackChecker] |> List.concat
List.replicate 4 [blackChecker; None] |> List.concat
List.replicate 4 [None; blackChecker] |> List.concat
List.replicate 8 None
List.replicate 8 None
List.replicate 4 [whiteChecker; None] |> List.concat
List.replicate 4 [None; whiteChecker] |> List.concat
List.replicate 4 [whiteChecker; None] |> List.concat
]
FSharpExtensions.fs contains a few functions that will be used by all the variants:
module internal Checkers.FSharpExtensions
open Checkers
open Checkers.Types
open System
let internal getJumpedCoord startCoord endCoord =
{ Row = startCoord.Row - Math.Sign(startCoord.Row - endCoord.Row); Column = startCoord.Column - Math.Sign(startCoord.Column - endCoord.Column) }
let internal moveIsDiagonal startCoord endCoord =
startCoord <> endCoord &&
System.Math.Abs(startCoord.Row - endCoord.Row) = System.Math.Abs(startCoord.Column - endCoord.Column)
let internal otherPlayer player =
match player with
| White -> Black
| Black -> White
AmericanCheckers.fs contains the logic for American Checkers (or English Draughts, if you prefer):
module internal Checkers.Variants.AmericanCheckers
open Checkers.Types
open Checkers.Piece
open Checkers.Board
open Checkers.FSharpExtensions
open System
open System.Collections.Generic
[<Literal>]
let Rows = 7
[<Literal>]
let Columns = 7
let internal kingRowIndex(player) =
match player with
| Player.Black -> Rows
| Player.White -> 0
let internal coordExists coord =
coord.Row >= 0 && coord.Row <= Rows &&
coord.Column >= 0 && coord.Column <= Columns
let internal checkMoveDirection piece startCoord endCoord =
match piece.PieceType with
| PieceType.Checker ->
match piece.Player with
| Player.Black -> startCoord.Row < endCoord.Row
| Player.White -> startCoord.Row > endCoord.Row
| PieceType.King -> true
let internal isValidCheckerHop startCoord endCoord (board :Board) =
let piece = (square startCoord board).Value
checkMoveDirection piece startCoord endCoord &&
(square endCoord board).IsNone
let internal isValidKingHop endCoord (board :Board) =
(square endCoord board).IsNone
let internal isValidCheckerJump startCoord endCoord (board :Board) =
let piece = (square startCoord board).Value
let jumpedCoord = getJumpedCoord startCoord endCoord
let jumpedPiece = square jumpedCoord board
checkMoveDirection piece startCoord endCoord &&
(square endCoord board).IsNone &&
jumpedPiece.IsSome &&
jumpedPiece.Value.Player <> piece.Player
let internal isValidKingJump startCoord endCoord (board :Board) =
let piece = (square startCoord board).Value
let jumpedCoord = getJumpedCoord startCoord endCoord
let jumpedPiece = square jumpedCoord board
(square endCoord board).IsNone &&
jumpedPiece.IsSome &&
jumpedPiece.Value.Player <> piece.Player
let internal isValidHop startCoord endCoord (board :Board) =
match (square startCoord board).Value.PieceType with
| PieceType.Checker -> isValidCheckerHop startCoord endCoord board
| PieceType.King -> isValidKingHop endCoord board
let internal isValidJump startCoord endCoord (board :Board) =
match (square startCoord board).Value.PieceType with
| PieceType.Checker -> isValidCheckerJump startCoord endCoord board
| PieceType.King -> isValidKingJump startCoord endCoord board
let internal hasValidHop startCoord (board :Board) =
let hopCoords =
[
offset startCoord {Row = -1; Column = 1};
offset startCoord {Row = -1; Column = -1};
offset startCoord {Row = 1; Column = 1};
offset startCoord {Row = 1; Column = -1}
]
let flattenedList = seq {
for coord in hopCoords do
yield coordExists coord && isValidHop startCoord coord board }
flattenedList |> Seq.exists id
let internal hasValidJump startCoord (board :Board) =
let jumpCoords =
[
offset startCoord {Row = -2; Column = 2};
offset startCoord {Row = -2; Column = -2};
offset startCoord {Row = 2; Column = 2};
offset startCoord {Row = 2; Column = -2}
]
let flattenedList = seq {
for coord in jumpCoords do
yield coordExists coord && isValidJump startCoord coord board }
flattenedList |> Seq.exists id
let internal jumpAvailable player (board :Board) =
let pieceHasJump row column =
let piece = board.[row].[column]
piece.IsSome && piece.Value.Player = player && hasValidJump { Row = row; Column = column } board
let flattenedList = seq {
for row in 0 .. Rows do
for column in 0 .. Columns do
yield (pieceHasJump row column) }
flattenedList |> Seq.exists id
let internal moveAvailable (board :Board) player =
let pieceHasMove row column =
let piece = board.[row].[column]
piece.IsSome &&
piece.Value.Player = player &&
(hasValidJump { Row = row; Column = column } board || hasValidHop { Row = row; Column = column } board)
let flattenedList = seq {
for row in 0 .. Rows do
for column in 0 .. Columns do
yield (pieceHasMove row column) }
flattenedList |> Seq.exists id
let isWon (board :Board) =
match (moveAvailable board) with
| x when not <| x White -> Some Black
| x when not <| x Black -> Some White
| _ -> None
let internal setPieceAt coord piece (board :Board) =
let boardItems = List.init (Rows + 1) (fun row ->
match row with
| i when i = coord.Row ->
List.init (Columns + 1) (fun col ->
match col with
| j when j = coord.Column -> piece
| _ -> board.[row].[col]
)
| _ -> board.[row]
)
boardItems
let internal jump startCoord endCoord (board :Board) =
let kingRowIndex = kingRowIndex((square startCoord board).Value.Player)
let piece =
match endCoord.Row with
| row when row = kingRowIndex -> Some <| Promote (square startCoord board).Value
| _ -> (square startCoord board)
let jumpedCoord = getJumpedCoord startCoord endCoord
board
|> setPieceAt startCoord None
|> setPieceAt endCoord piece
|> setPieceAt jumpedCoord None
let internal hop startCoord endCoord (board :Board) =
let kingRowIndex = kingRowIndex (square startCoord board).Value.Player
let piece =
match endCoord.Row with
| row when row = kingRowIndex -> Some <| Promote (square startCoord board).Value
| _ -> (square startCoord board)
board
|> setPieceAt startCoord None
|> setPieceAt endCoord piece
let internal playerTurnEnds (move :Move) (originalBoard :Board) (currentBoard :Board) =
let lastMoveWasJump = Math.Abs(move.[0].Row - move.[1].Row) = 2
let pieceWasPromoted = (square (List.last move) currentBoard).Value.PieceType = King &&
(square move.[0] originalBoard).Value.PieceType = Checker
pieceWasPromoted ||
not (lastMoveWasJump && hasValidJump (List.last move) currentBoard)
let public isValidMove startCoord endCoord (board :Board) =
coordExists startCoord &&
coordExists endCoord &&
moveIsDiagonal startCoord endCoord &&
(square startCoord board).IsSome &&
match Math.Abs(startCoord.Row - endCoord.Row) with
| 1 -> isValidHop startCoord endCoord board && not <| jumpAvailable (square startCoord board).Value.Player board
| 2 -> isValidJump startCoord endCoord board
| _ -> false
let public movePiece startCoord endCoord (board :Board) :Option<Board> =
match isValidMove startCoord endCoord board with
| false -> None
| true ->
match Math.Abs(startCoord.Row - endCoord.Row) with
| 1 -> Some <| hop startCoord endCoord board
| 2 -> Some <| jump startCoord endCoord board
| _ -> None
let rec public moveSequence (coordinates :Coord seq) (board :Option<Board>) =
let coords = List.ofSeq(coordinates)
match board with
| None -> None
| Some b ->
match coords.Length with
| b when b >= 3 ->
let newBoard = movePiece coords.Head coords.[1] board.Value
moveSequence coords.Tail newBoard
| _ -> movePiece coords.Head coords.[1] board.Value
let internal uncheckedMovePiece startCoord endCoord (board :Board) =
match Math.Abs(startCoord.Row - endCoord.Row) with
| 1 -> hop startCoord endCoord board
| 2 -> jump startCoord endCoord board
let rec internal uncheckedMoveSequence (coordinates :Coord seq) (board :Board) =
let coords = List.ofSeq(coordinates)
match coords.Length with
| b when b >= 3 ->
let newBoard = uncheckedMovePiece coords.Head coords.[1] board
uncheckedMoveSequence coords.Tail newBoard
| _ -> uncheckedMovePiece coords.Head coords.[1] board
AmericanCheckersAI.fs contains the variant-specific logic for AI:
module Checkers.AIs.AmericanCheckersAI
open Checkers.Board
open Checkers.Variants.AmericanCheckers
open Checkers.Types
open System
let checkerWeights =
[[0.0; 3.20; 0.0; 3.20; 0.0; 3.20; 0.0; 3.10];
[1.15; 0.0; 1.05; 0.0; 1.0; 0.0; 1.10; 0.0];
[0.0; 1.10; 0.0; 1.0; 0.0; 1.05; 0.0; 1.15];
[1.15; 0.0; 1.05; 0.0; 1.0; 0.0; 1.10; 0.0];
[0.0; 1.10; 0.0; 1.0; 0.0; 1.05; 0.0; 1.15];
[1.15; 0.0; 1.05; 0.0; 1.0; 0.0; 1.10; 0.0];
[0.0; 1.10; 0.0; 1.0; 0.0; 1.05; 0.0; 1.15];
[3.10; 0.0; 3.20; 0.0; 3.20; 0.0; 3.20; 0.0]]
let kingWeights =
[[0.0; 1.05; 0.0; 1.0; 0.0; 1.0; 0.0; 1.0];
[1.05; 0.0; 1.10; 0.0; 1.05; 0.0; 1.05; 0.0];
[0.0; 1.10; 0.0; 1.15; 0.0; 1.10; 0.0; 1.0];
[1.0; 0.0; 1.15; 0.0; 1.20; 0.0; 1.05; 0.0];
[0.0; 1.05; 0.0; 1.20; 0.0; 1.15; 0.0; 1.0];
[1.0; 0.0; 1.10; 0.0; 1.15; 0.0; 1.10; 0.0];
[0.0; 1.05; 0.0; 1.05; 0.0; 1.10; 0.0; 1.05];
[1.0; 0.0; 1.0; 0.0; 1.0; 0.0; 1.05; 0.0]]
let isPlayerPiece player coord (board :Board) =
let piece = square coord board
piece.IsSome && player = piece.Value.Player
let nextPoint coord =
match coord with
| c when c.Row = Rows && c.Column = Columns -> None
| c when c.Column = Columns -> Some {Row = c.Row + 1; Column = 0}
| _ -> Some {coord with Column = coord.Column + 1}
let calculateCheckerWeight coord (board :Board) =
let piece = (square coord board).Value
let kingRow = kingRowIndex piece.Player
let weight = 8.0 - (float <| Math.Abs(kingRow - coord.Row)) + (square coord checkerWeights)
match piece.Player with
| Black -> weight
| White -> -weight
let calculateKingWeight coord (board :Board) =
let piece = (square coord board).Value
let weight = 8.0 + (square coord kingWeights)
match piece.Player with
| Black -> weight
| White -> -weight
let calculatePieceWeight coord (board :Board) =
let piece = square coord board
match piece.Value.PieceType with
| Checker -> calculateCheckerWeight coord board
| King -> calculateKingWeight coord board
let calculateWeight player (board :Board) =
let rec loop (weight :float) coord :float =
match nextPoint coord with
| Some c ->
match isPlayerPiece player coord board with
| true -> loop (weight + (calculatePieceWeight coord board)) c
| false -> loop weight c
| None -> weight
loop 0.0 {Row = 0; Column = 0}
let calculateWeightDifference (board :Board) =
let rec loop (weight :float) coord =
match nextPoint coord with
| Some c ->
let piece = square coord board
match piece.IsSome with
| true -> loop (weight + (calculatePieceWeight coord board)) c
| false -> loop weight c
| None -> weight
loop 0.0 {Row = 0; Column = 0}
let checkerJumps player =
match player with
| White -> [{Row = -2; Column = -2}; {Row = -2; Column = 2}]
| Black -> [{Row = 2; Column = -2}; {Row = 2; Column = 2}]
let kingJumps player =
(checkerJumps player) @
(match player with
| White -> [{Row = 2; Column = -2}; {Row = 2; Column = 2}]
| Black -> [{Row = -2; Column = -2}; {Row = -2; Column = 2}])
let checkerHops player =
match player with
| White -> [{Row = -1; Column = -1}; {Row = -1; Column = 1}]
| Black -> [{Row = 1; Column = -1}; {Row = 1; Column = 1}]
let kingHops player =
(checkerHops player) @
(match player with
| White -> [{Row = 1; Column = -1}; {Row = 1; Column = 1}]
| Black -> [{Row = -1; Column = -1}; {Row = -1; Column = 1}])
let getPieceSingleJumps coord (board :Board) =
let piece = (square coord board).Value
let moves =
match piece.PieceType with
| Checker -> checkerJumps piece.Player
| King -> kingJumps piece.Player
let hops = List.ofSeq (seq {
for move in moves do
let endCoord = offset coord move
yield
match coordExists endCoord && isValidJump coord endCoord board with
| true -> Some [coord; endCoord]
| false -> None })
List.map (fun (item :Option<Move>) -> item.Value) (List.where (fun (item :Option<Move>) -> item.IsSome) hops)
let rec createMoveTree (move :Move) (board :Board) =
let moveTree =
{
Move = move;
Parent = None;
Children =
let newBoard = if move.Length = 1 then board else uncheckedMoveSequence move board
let newJumps = getPieceSingleJumps (List.last move) newBoard
let newMoveEndCoords = List.map (fun item -> List.last item) newJumps
let oldPieceType = (square move.Head board).Value.PieceType
let newPieceType = (square (List.last move) newBoard).Value.PieceType
match newMoveEndCoords.IsEmpty || (oldPieceType = Checker && newPieceType = King) with
| false ->
let moves = List.map (fun (item :Coord) -> move @ [item]) newMoveEndCoords
let children = List.map (fun item -> createMoveTree item board) moves
Some children
| true -> None
}
moveTree
let getPieceJumps coord (board :Board) =
let moves = new System.Collections.Generic.List<Move>()
let rec loop (moveTree :MoveTree) =
match moveTree.Children with
| None -> moves.Add(moveTree.Move)
| Some t -> List.iter (fun item -> (loop item)) t
let moveTree = createMoveTree [coord] board
match moveTree.Children with
| Some t -> loop <| createMoveTree [coord] board
| None -> ()
List.ofSeq moves
let getPieceHops coord (board :Board) =
let piece = (square coord board).Value
let moves =
match piece.PieceType with
| Checker -> checkerHops piece.Player
| King -> kingHops piece.Player
let hops = List.ofSeq (seq {
for move in moves do
let endCoord = offset coord move
yield
match coordExists endCoord && isValidHop coord endCoord board with
| true -> Some [coord; endCoord]
| false -> None })
List.map (fun (item :Option<Move>) -> item.Value) (List.where (fun (item :Option<Move>) -> item.IsSome) hops)
let calculateMoves player (board :Board) =
let rec loop jumpAcc hopAcc coord =
match isPlayerPiece player coord board with
| true ->
let newJumpAcc = getPieceJumps coord board @ jumpAcc
match newJumpAcc with
| [] ->
let newHopAcc = getPieceHops coord board @ hopAcc
match nextPoint coord with
| Some c -> loop newJumpAcc newHopAcc c
| None -> newHopAcc
| _ ->
match nextPoint coord with
| Some c -> loop newJumpAcc [] c
| None -> newJumpAcc
| false ->
match nextPoint coord with
| Some c -> loop jumpAcc hopAcc c
| None -> jumpAcc @ hopAcc
loop [] [] {Row = 0; Column = 0}
GameController.fs contains the state of the game as a whole. In the future, this will be expanded to tracking move history and other relevant information.
module public Checkers.GameController
open Checkers.Types
open Checkers.Board
type GameController = { Board :Board; CurrentPlayer :Player; CurrentCoord :Option<Coord> }
let newGame = { Board = Board.defaultBoard; CurrentPlayer = Black; CurrentCoord = None }
Minimax.fs contains the general logic for the AI's. This module contains some very nasty code, including a few mutable variables. I'm sure my other code is a mess as well, but I'd like special attention for this.
module internal Checkers.Minimax
open Checkers.Types
open Checkers.Board
open Checkers.FSharpExtensions
open Checkers.Variants.AmericanCheckers
open Checkers.AIs.AmericanCheckersAI
let rec internal bestMatchInList player highestDifference moveForHighestDifference (list :List<float * Move>) =
let head::tail = list
let weight = fst head
let newMoveForHighestDifference =
match player with
| Black -> match weight > highestDifference with
| true -> snd head
| false -> moveForHighestDifference
| White -> match weight < highestDifference with
| true -> snd head
| false -> moveForHighestDifference
let newHighestDifference =
(highestDifference, weight)
||> match player with
| Black -> max
| White -> min
match tail with
| [] -> (highestDifference, newMoveForHighestDifference)
| _ -> bestMatchInList player newHighestDifference newMoveForHighestDifference list.Tail
let internal chooseNewAlpha currentAlpha (candidateAlpha :float Option) =
match currentAlpha with
| Some x -> if candidateAlpha.IsSome then Some <| max x candidateAlpha.Value else currentAlpha
| None -> candidateAlpha
let internal chooseNewBeta currentBeta (candidateBeta :float Option) =
match currentBeta with
| Some x -> if candidateBeta.IsSome then Some <| min x candidateBeta.Value else currentBeta
| None -> candidateBeta
let rec minimax player searchDepth alpha beta (board :Board) =
match searchDepth = 0 || (isWon board).IsSome with
| true ->
let weightDifference = Some <| calculateWeightDifference board
let newAlpha = if player = Black then weightDifference else alpha
let newBeta = if player = White then weightDifference else beta
{ Alpha = newBeta; Beta = newAlpha; Move = [] }
| false ->
let moves = calculateMoves player board
let mutable alphaForNode = None
let mutable betaForNode = None
let mutable newAlpha = alpha
let mutable newBeta = beta
let mutable move = []
if searchDepth <> 0 then
ignore <| List.map (fun x -> if newAlpha.IsNone || newBeta.IsNone || newAlpha.Value < newBeta.Value then
let newBoard = uncheckedMoveSequence x board
let alphaBetaMove = minimax (otherPlayer player) (searchDepth - 1) alphaForNode betaForNode newBoard
match player with
| Black ->
alphaForNode <- chooseNewAlpha alphaForNode alphaBetaMove.Alpha
newAlpha <- chooseNewAlpha newAlpha alphaForNode
move <- if newAlpha = alphaBetaMove.Alpha then x else move
| White ->
betaForNode <- chooseNewBeta betaForNode alphaBetaMove.Beta
newBeta <- chooseNewBeta newBeta betaForNode
move <- if newBeta = alphaBetaMove.Beta then x else move
())
moves
{ Alpha = betaForNode; Beta = alphaForNode; Move = move }
PublicAPI.fs is really kind of a wrapper that containing methods that are meant to be called from outside the library. On this note, note that all the internal
methods are really meant to be private to the class, but xUnit doesn't support Portable Class Libraries (PCLs), so I need to expose them to the test library.
module public Checkers.PublicAPI
open Checkers.Variants
open Checkers.Types
open Checkers.Board
open Checkers.FSharpExtensions
open Checkers.Variants.AmericanCheckers
open Checkers.Minimax
open Checkers.GameController
open System
let isValidMove startCoord endCoord gameController =
isValidMove startCoord endCoord gameController.Board &&
(square startCoord gameController.Board).Value.Player = gameController.CurrentPlayer &&
match gameController.CurrentCoord with
| None -> true
| coord -> startCoord = coord.Value
let movePiece startCoord endCoord gameController :Option<GameController> =
let board = movePiece startCoord endCoord gameController.Board
match (isValidMove startCoord endCoord gameController) with
| true -> Some <|
{
Board = board.Value;
CurrentPlayer = match playerTurnEnds [startCoord; endCoord] gameController.Board board.Value with
| true -> otherPlayer gameController.CurrentPlayer
| false -> gameController.CurrentPlayer
CurrentCoord = match playerTurnEnds [startCoord; endCoord] gameController.Board board.Value with
| true -> None
| false -> Some endCoord
}
| false -> None
let move (move :Coord seq) (gameController) :Option<GameController> =
let board = moveSequence move (Some gameController.Board)
match board with
| Some b -> Some <|
{
Board = board.Value;
CurrentPlayer = match playerTurnEnds (List.ofSeq move) gameController.Board board.Value with
| true -> otherPlayer gameController.CurrentPlayer
| false -> gameController.CurrentPlayer
CurrentCoord = match playerTurnEnds (List.ofSeq move) gameController.Board board.Value with
| true -> None
| false -> Some (Seq.last move)
}
| None -> None
let getMove searchDepth gameController =
(minimax gameController.CurrentPlayer searchDepth None None gameController.Board).Move
let isWon controller =
isWon controller.Board