Once you become addicted to chess game analysis, it becomes very easy to swamp yourselves with questions regarding different aspects of the game. Testing out different hypothesis like preference of mobility versus positional advantage requires a bit of manual chess game mining, which could potentially be analyzed using R.

With the help of websites like chessgames.com, one could download saved games in PGN format (portable game notation), analyze player behavior towards certain game strategies and positions, and break them down by player strength and so on.

Well, that was my initial intention, although my attention these days migrated towards other interesting hobbies and whatnot. I’m posting my code on this blog for posterity, and maybe I’ll come back later when the interest comes back.

The intended usage was:

g <- ChessGame('test.pgn')
g$event # returns metadata information stored in PGN file
move.to(g, 10) # advance game g to move 10
material(g, "white") # returns a score for white
mobility(g, "relative") # returns a score of mobility white vs. black pieces

Here it is. Although the following is probably buggy, it could be useful to the chess hobbyists online.

library(R.oo)

PIECE_VALUES <- list(Q=9, R=5, B=3, N=3, P=1)
PIECES <- list("K", "Q", "R", "B", "N", "P")

ChessPiece <- function(color=NULL, piece=NULL, r=NULL, f=NULL) {
   o <- list(color=color, piece=piece, r=r, f=f)
   class(o) <- "ChessPiece"
   return(o)
}

ChessBoard <- function() {
   o <- list(ChessPiece())
   length(o) <- 64
   dim(o) <- c(8,8)
   class(o) <- "ChessBoard"
   rownames(o) <- c("a", "b", "c", "d", "e", "f", "g", "h")
   o <- reset(o)
   return(o)
}

summary.ChessPiece <- function(o) {
        paste(o$color, o$piece, sep='')
}
getPieceInfo <- function(x) {
        if (is.null(x)) "  " else summary(x)
}

print.ChessPiece <- function(o) {
        print(paste(o$color, o$piece))
}
print.ChessBoard <- function(o) {
        print.table(array(lapply(o[,8], getPieceInfo)))
        print.table(array(lapply(o[,7], getPieceInfo)))
        print.table(array(lapply(o[,6], getPieceInfo)))
        print.table(array(lapply(o[,5], getPieceInfo)))
        print.table(array(lapply(o[,4], getPieceInfo)))
        print.table(array(lapply(o[,3], getPieceInfo)))
        print.table(array(lapply(o[,2], getPieceInfo)))
        print.table(array(lapply(o[,1], getPieceInfo)))
}

reset <- function(o) {
        UseMethod("reset", o)
}
reset.ChessBoard <- function(o) {
   o[["a", 1]] <- ChessPiece(color="W", piece="R", r=1, f=1)
   o[["b", 1]] <- ChessPiece(color="W", piece="N", r=1, f=2)
   o[["c", 1]] <- ChessPiece(color="W", piece="B", r=1, f=3)
   o[["d", 1]] <- ChessPiece(color="W", piece="Q", r=1, f=4)
   o[["e", 1]] <- ChessPiece(color="W", piece="K", r=1, f=5)
   o[["f", 1]] <- ChessPiece(color="W", piece="B", r=1, f=6)
   o[["g", 1]] <- ChessPiece(color="W", piece="N", r=1, f=7)
   o[["h", 1]] <- ChessPiece(color="W", piece="R", r=1, f=8)
   o[["a", 2]] <- ChessPiece(color="W", piece="P", r=2, f=1)
   o[["b", 2]] <- ChessPiece(color="W", piece="P", r=2, f=2)
   o[["c", 2]] <- ChessPiece(color="W", piece="P", r=2, f=3)
   o[["d", 2]] <- ChessPiece(color="W", piece="P", r=2, f=4)
   o[["e", 2]] <- ChessPiece(color="W", piece="P", r=2, f=5)
   o[["f", 2]] <- ChessPiece(color="W", piece="P", r=2, f=6)
   o[["g", 2]] <- ChessPiece(color="W", piece="P", r=2, f=7)
   o[["h", 2]] <- ChessPiece(color="W", piece="P", r=2, f=8)

   o[["a", 8]] <- ChessPiece(color="B", piece="R", r=8, f=1)
   o[["b", 8]] <- ChessPiece(color="B", piece="N", r=8, f=2)
   o[["c", 8]] <- ChessPiece(color="B", piece="B", r=8, f=3)
   o[["d", 8]] <- ChessPiece(color="B", piece="Q", r=8, f=4)
   o[["e", 8]] <- ChessPiece(color="B", piece="K", r=8, f=5)
   o[["f", 8]] <- ChessPiece(color="B", piece="B", r=8, f=6)
   o[["g", 8]] <- ChessPiece(color="B", piece="N", r=8, f=7)
   o[["h", 8]] <- ChessPiece(color="B", piece="R", r=8, f=8)
   o[["a", 7]] <- ChessPiece(color="B", piece="P", r=7, f=1)
   o[["b", 7]] <- ChessPiece(color="B", piece="P", r=7, f=2)
   o[["c", 7]] <- ChessPiece(color="B", piece="P", r=7, f=3)
   o[["d", 7]] <- ChessPiece(color="B", piece="P", r=7, f=4)
   o[["e", 7]] <- ChessPiece(color="B", piece="P", r=7, f=5)
   o[["f", 7]] <- ChessPiece(color="B", piece="P", r=7, f=6)
   o[["g", 7]] <- ChessPiece(color="B", piece="P", r=7, f=7)
   o[["h", 7]] <- ChessPiece(color="B", piece="P", r=7, f=8)

   #o$white_pieces <- c(o[, 1:2])
   #o$black_pieces <- c(o[, 7:8])
   return(o)
}


pieces.ChessBoard <- function(x, color="all") {
   if (color == "white") {
      return(x.white_pieces)
   } else if (color == "black") {
      return(x.black_pieces)
   } else {
      return(c(x.white_pieces, x.black_pieces))
   }
}

is.occupied <- function(board, r, f) {
        !is.null(board[[r, f]])
}

ChessGame <- function(f=NULL) {
   o <- list()
   class(o) <- "ChessGame"
   if (!is.null(f))
      loadPGN(o, f)
   o$board <- ChessBoard()
   o$whitePieces <- array(o$board[, 1:2])
   o$blackPieces <- array(o$board[, 7:8])
   o$current_position <- 0
   return(o)
}

loadPGN <- function(game, f) {
    pat  <-  "\\[(.*) \".*\"\\]"
    e <- readLines(f)
    meta <- e[grep(pat, e)]
    a <- getMeta(meta)
    moves <- e[grep(pat, e, invert=TRUE)]
    moves <- moves[grep("^$", moves, invert=TRUE)]
    getMoves(moves)
}

getMeta  <- function(l) {
        mapply(parseMetaLine, l)
}

parseMetaLine <- function(l) {
        pat  <-  "\\[(.*) \"(.*)\"\\]"
        tag <- gsub(pat, "\\1", l)
        value <- gsub(pat, "\\2", l)
        c(tag, value)
}

applyMove <- function(board, move, color=white) {
   if (!is.element(substr(move, 1, 1), PIECES)) {
      move <- paste("P", move, sep="")
   }
   mp <- substr(move, 1, 1)
}


moveTo <- function(game, nb, black=TRUE) {
}

mobility <- function(x, ...) UseMethod("mobility", x)
mobility.ChessBoard <- function(x, ...) {
}
mobility.ChessGame <- function(x, ...) {
}


material <- function(x, ...) UseMethod("material", x)
material.ChessPiece <- function(x, ...) {
   return(PIECE_VALUES[[x.piece]])
}
material.list <- function(x, ...) {
   sapply(x, material)
}
material.ChessBoard <- function(x, color="relative") {
   if (color != "relative") {
      return(sum(material(pieces(x, color=color))))
   } else {
      return(sum(material(pieces(x, color="white"))) - sum(material(pieces(x, color="black"))))
   }
}
material.ChessGame <- function(x, color="relative") {
}
getMoves <- function(moves) {
        moves <- gsub(';.*$', '', moves)
        moves <- gsub('\\{.*?\\}', '', moves)
        s <- paste(moves, collapse=" ")
        moves <- strsplit(s, '[0-9]*?\\.')[[1]]
        moves <- unlist(lapply(moves[-1], function(x) { a <- strsplit(trim(x), ' ')[[1]]; c(a[1], a[2]) }))
        dim(moves) <- c(2, length(moves)/2)
        moves <- t(moves)
        colnames(moves) <- c("W", "B")
        moves
}

is.free.square <- function(x) {
        if (is.null(x)) return(1) else return(0)
}

is.free <- function(board, r=0, f=0, d=0) {
        if (r == 0 && f == 0) return(unlist(lapply(board, is.free.square)))
        if (r == 0) return(unlist(lapply(board[f,], is.free.square)))
        if (f == 0) return(unlist(lapply(board[,r], is.free.square)))
        if (d == 1) {
                return(unlist(lapply(board[col(board) + row(board) == f+r], is.free.square)))
        }
        if (d == -1) {
                return(unlist(lapply(board[col(board) - row(board) == f-r], is.free.square)))
        }
        return(is.free.square(board[[f,r]]))
}

mobility.line <- function(l, p) {
        l[p] <- 2
        pat <- '(^|[01]*0+)(1*21*)($|0+[01]*)'
        l <- gsub(pat, '\\2', paste(l, collapse=''))
        nchar(l)-1
}

mobility.ChessPiece <- function(x, board) {
        if (x$piece == 'P') {
                if (x$color == 'W')
                return(is.free(board, x$r+1, x$f))
                else
                return(is.free(board, x$r-1, x$f))
        } else if (x$piece == 'R') {
                return(mobility.line(is.free(board, r=x$r), x$r) + mobility.line(is.free(board, f=x$f), x$f))
        } else if (x$piece == 'N') {
                m <- c(-2, 1, -2, -1, -1, 2, -1, -2, 1, 2, 1, -2, 2, 1, 2, -1)
                dim(m) <- c(2, 8)
                l <- apply(m, 2, function(y, r=x$r, f=x$f) {(y[[1]] + f - 1)*8 + y[[2]] + r})
                l <- l[l>0]
                l <- l[l<65]
                if (x$r < 3)
                    l <- l[l %% 8 < 5]
                if (x$r > 6)
                    l <- l[l %% 8 > 4]
                return(sum(unlist(lapply(board[l], is.free.square))))
        } else if (x$piece == 'B') {
                return(mobility.line(is.free(board, r=x$r, f=x$f, d=1)) + mobility.line(is.free(board, r=x$r, f=x$f, d=-1)))
        } else if (x$piece == 'Q') {
                return(mobility.line(is.free(board, r=x$r), x$r) + mobility.line(is.free(board, f=x$f), x$f) + mobility.line(is.free(board, r=x$r, f=x$f, d=1)) + mobility.line(is.
free(board, r=x$r, f=x$f, d=-1)))
        } else if (x$piece == 'K') {
                m <- c(1, 1, 1, 0, 1, -1, 0, -1, -1, -1, -1, 0, -1, 1, 0, 1)
                dim(m) <- c(2, 8)
                l <- apply(m, 2, function(y, r=x$r, f=x$f) {(y[[1]] + f - 1)*8 + y[[2]] + r})
                l <- l[l>0]
                l <- l[l<65]
                if (x$r < 2)
                    l <- l[l %% 8 < 3]
                if (x$r > 7)
                    l <- l[l %% 8 > 6]
                return(sum(unlist(lapply(board[l], is.free.square))))
        }
}

Photograph used with permission from mylittleshoebox.ca