update_status <- function(game_moves, viz = FALSE) {
# expects a `game_moves` data frame wth five columns:
# number, row, column, color and group_id
check1 <- class(game_moves) == "data.frame"
check2 <- all(c("column", "row", "number", "color", "group_id") %in% names(game_moves))
check3 <- nrow(game_moves) > 0
check <- check1 & check2 & check3
if(!check) stop("not a valid game_moves object")
n_moves <- max(game_moves$number)
game_moves$n_liberties <- NA
for (i in 1:n_moves) {
current_row <- which(game_moves$number == i)
is_pass <- is.na(game_moves$column[current_row])
# passes are defined by NA in column and row
if (!is_pass) {
current_color <- game_moves$color[current_row]
other_color <- ifelse(current_color == "black", "white", "black")
# 0. check that the current move's location isn't occupied
extant_moves <- which(game_moves$number < i &
game_moves$group_id != "removed" & !is.na(game_moves$row))
if (length(extant_moves) > 0) {
collision <- any(game_moves$column[extant_moves] == game_moves$column[current_row] &
game_moves$row[extant_moves] == game_moves$row[current_row])
if(collision) stop(paste0("illegal collision detected, move ", i, " is to an occupied location"))
}
# 1. update group identity of stones of same color for all moves up to this move
update_rows <- which(game_moves$color == current_color &
game_moves$number <= i & game_moves$group_id != "removed")
if (length(update_rows) > 0) {
game_moves$group_id[update_rows] <- paste(current_color,
id_groups(game_moves[update_rows, c("column", "row", "group_id")]))
}
black_groups <- game_moves$group_id[which(game_moves$group_id != "removed" & game_moves$color == "black")]
white_groups <- game_moves$group_id[which(game_moves$group_id != "removed" & game_moves$color=="white")]
bad <- any(black_groups %in% white_groups)
if (bad) stop("groups are mixing up colors!")
# 2. recount liberties for all stones
active_rows <- which(game_moves$number <= i & game_moves$group_id != "removed")
game_moves$n_liberties[active_rows] <- count_liberties(game_moves[active_rows,])
# 3. remove enemy groups with 0 liberties!
update_rows <- which(game_moves$color == other_color & game_moves$number < i & game_moves$group_id != "removed")
group_liberties <- tapply(game_moves$n_liberties[update_rows], game_moves$group_id[update_rows], sum)
removable_groups <- names(which(group_liberties == 0))
if (length(removable_groups) > 0) {
game_moves$group_id[update_rows][which(game_moves$group_id[update_rows] %in% removable_groups)] <- "removed"
}
# 4. recount liberties again
active_rows <- which(game_moves$number <= i & game_moves$group_id != "removed" & !is.na(game_moves$row))
game_moves$n_liberties[active_rows] <- count_liberties(game_moves[active_rows,])
if (viz) {
plot(game_moves$column[active_rows], game_moves$row[active_rows],
bg = game_moves$color[active_rows], pch = 21, ylim = c(0, 20), xlim = c(0, 20),
axes = FALSE, xaxt = "n", yaxt = "n", xlab = "", ylab = "")
polygon(c(0, 0, 20, 20), c(0, 20, 20, 0))
points(game_moves$column[current_row], game_moves$row[current_row], col = "red", pch = 20, cex = 0.5)
}
# 5. suicide check - ah its just a problem with my algorithm
update_rows <- which(game_moves$color == current_color & game_moves$number <= i &
game_moves$group_id != "removed" & !is.na(game_moves$row))
group_liberties <- tapply(game_moves$n_liberties[update_rows], game_moves$group_id[update_rows], sum)
removable_groups <- names(which(group_liberties == 0))
if (length(removable_groups) > 0) {
warning(paste0("suicide detected at move ", i))
}
}
}
return(game_moves$group_id)
}
count_liberties <- function(moves, board_size = 19){
# assumes all are active
n_liberties <- rep(NA, nrow(moves))
for (i in 1:nrow(moves)){
i_x <- moves$column[i]
i_y <- moves$row[i]
south_free <- !any(moves$row == (i_y - 1) & moves$column == i_x) &
i_y != 1
north_free <- !any(moves$row == (i_y + 1) & moves$column == i_x) &
i_y != board_size
west_free <- !any(moves$row == (i_y) & moves$column == (i_x - 1)) &
i_x != 1
east_free <- !any(moves$row == (i_y) & moves$column == (i_x + 1)) &
i_x != board_size
n_liberties[i] <- sum(south_free, north_free, west_free, east_free)
}
return(n_liberties)
}
make_ids <- function(n, reserved = "", seed = NA, nchars = NA){
my_let <- letters
my_num <- 0:9
if (is.na(seed) | !is.numeric(seed)) set.seed(as.numeric(
as.POSIXlt(Sys.time())))
if (!is.na(seed) & is.numeric(seed)) set.seed(seed)
output <- replicate(n, paste(sample(c(my_let, my_num),
nchars, replace = TRUE), collapse = ""))
rejected <- duplicated(output) | output %in% reserved |
substr(output, 1, 1) %in% my_num
while (any(rejected)){
output <- output[-which(rejected)]
remaining <- n - length(output)
output <- c(output, replicate(remaining, paste(sample(c(my_let, my_num),
nchars, replace = TRUE), collapse = "")))
rejected <- duplicated(output) | output %in% reserved |
substr(output, 1, 1) %in% my_num
}
output
}
id_groups <- function(moves){
direct_mat <- id_direct_connections(moves)
color_network <- graph_from_adjacency_matrix(direct_mat)
group_id <- components(color_network)$membership
return(group_id)
}
id_direct_connections <- function(moves){
direct_mat <- matrix(FALSE, nrow = nrow(moves), ncol = nrow(moves))
diag(direct_mat) <- TRUE
for (i in 1:nrow(moves)){
i_y <- moves$row[i]
i_x <- moves$column[i]
south <- which(moves$row == (i_y - 1) & moves$column == i_x)
north <- which(moves$row == (i_y + 1) & moves$column == i_x)
west <- which(moves$row == (i_y) & moves$column == (i_x - 1))
east <- which(moves$row == (i_y) & moves$column == (i_x + 1))
if (length(south) > 0) direct_mat[i, south] <- TRUE
if (length(north) > 0) direct_mat[i, north] <- TRUE
if (length(west) > 0) direct_mat[i, west] <- TRUE
if (length(east) > 0) direct_mat[i, east] <- TRUE
}
return(direct_mat)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.