R/1-classes.R

In tpq/codenames: Game Interface and AI for Codenames by Vlaada Chvatil

###########################################################
### Define Board class to manage active game state

#' The Board Class
#'
#' This object container manages the active state of the game.
#'
#' @slot words A character vector. The 25 prompts on the \code{Board}.
#' @slot spies A character vector. The 25 "spies" (i.e., "R", "B", "N", or "K").
#' @slot team A character scalar. The active team (i.e., "R" or "B").
#' @slot intended A logical vector. Effectively \code{@@spies == @@team}.
#' @slot onboard A logical vector. Which of the 25 "spies" no team has yet exposed.
#' @slot history A character vector. All clues given to date. Used for AI.
#' @slot lastguess A logical scalar. Whether team made last guess correctly.
#' @slot endgame A logical scalar. Whether the game is finished.
#' @slot winner A character scalar. The winning team (i.e., "R" or "B").
#'
#' @export
setClass("Board",
         slots = c(
           words = "character",
           spies = "character",
           team = "character",
           intended = "logical",
           onboard = "logical",
           history = "character",
           lastguess = "logical",
           endgame = "logical",
           winner = "character"
         )
)

#' @describeIn Board A method to view the active \code{Board}.
#'
#' @param object,board The most recent \code{Board} object.
#'
#' @export
setMethod("show", "Board",
          function(object){

            displaywords <- object@words
            displaywords[!object@onboard] <-
              paste0("[--", object@spies[!object@onboard], "--]")
            show(matrix(displaywords, nrow = 5, ncol = 5))
          }
)

###########################################################
### Define some miscellaneous helper functions

#' Make New Board
#'
#' A helper function to create a new \code{Board} object.
#'
#' @param defaultTeam The value to assign to the \code{@@team} slot.
#' @return A new \code{Board} object.
#'
#' @export
makeNewBoard <- function(defaultTeam = "R"){

  board <- sample(colnames(codenames:::reference), 25)
  board.mat <- matrix(board, nrow = 5, ncol = 5)

  doubleagent <- sample(c("R", "B"), 1) # random...
  spy <- sample(c(doubleagent, rep("R", 8), rep("B", 8), rep("N", 7), rep("K", 1)))

  newboard <-
    new("Board",
        words = board,
        spies = spy,
        team = defaultTeam,
        intended = spy == defaultTeam,
        onboard = rep(TRUE, 25),
        endgame = FALSE
    )

  return(newboard)
}

#' Prompt Player for Input
#'
#' A helper function to prompt the user for input.
#'
#' @param question The prompt to ask the user.
#' @return The input provided by the user.
#'
#' @export
askPlayer <- function(question){

  n <- readline(prompt = paste0(question, ": "))
  return(n)
}

###########################################################
### Define Board methods to perform game tasks

#' Consider Instance
#'
#' Game AI uses \code{Board} to suggest clue(s).
#'
#' @param board The most recent \code{Board} object.
#' @return A character vector of clue(s).
#'
#' @export
setGeneric("considerInstance",
           function(board, ...) standardGeneric("considerInstance")
)

#' @describeIn Board AI uses \code{Board} to suggest clue(s).
#'
#' @return A character vector of clue(s).
#'
#' @export
setMethod("considerInstance", "Board",
          function(board){

            prompts <- board@words[board@onboard]
            spy <- board@spies[board@onboard]
            team <- board@team

            # Define useful indexes for board cards
            ind.team <- spy == team
            ind.anti <- spy == ifelse(team == "R", "B", "R")
            ind.neut <- spy == "N"
            ind.kill <- spy == "K"

            # Only consider clues that relate to at least one intended word (min. score: 5)
            row.index <- apply(codenames:::reference[, prompts], 1, function(row) any(row[ind.team] >= 5))
            pool <- codenames:::reference[row.index, prompts, drop = FALSE]

            # Only consider clues that have not yet been given already
            pool <- pool[!rownames(pool) %in% board@history, ]
            tryCatch(nrow(pool), error = function(e) stop("DEBUG ERROR (a): Could not find any clue."))
            if(nrow(pool) == 0){

              stop("DEBUG ERROR (b): Could not find any clue.")
            }

            # Use some metric to calculate utility of each possible clue
            possibleclues <- vector("numeric", nrow(pool))
            names(possibleclues) <- rownames(pool)
            for(i in 1:nrow(pool)){

              # Add additional weight if a clue applies to multiple words (min. score: 0)
              a <- sum(pool[i, prompts][ind.team] != 0)
              b <- sum(pool[i, prompts][ind.anti] != 0)
              c <- sum(pool[i, prompts][ind.neut] != 0)
              score <-
                a^2 * sum(pool[i, ind.team]^(1/3)) - 3 * b * sum(pool[i, ind.anti]^(1/3)) -
                2 * c * sum(pool[i, ind.neut]^(1/3)) - 10 * sum(pool[i, ind.neut]^(1/3))
              possibleclues[i] <- score
            }

            return(possibleclues)
          }
)

#' Check Guess
#'
#' Game AI uses \code{Board} to evaluate guess.
#'
#' @param board The most recent \code{Board} object.
#' @param guess Guess input from \code{\link{askPlayer}}.
#' @return An updated \code{Board} object.
#'
#' @export
setGeneric("checkGuess",
           function(board, guess) standardGeneric("checkGuess")
)

#' @describeIn Board AI uses \code{Board} to evaluate guess.
#'
#' @param guess Guess input from \code{\link{askPlayer}}.
#' @return An updated \code{Board} object.
#'
#' @export
setMethod("checkGuess", "Board",
          function(board, guess){

            checkingGuess <- TRUE

            while(checkingGuess){

              if(guess %in% c("kill", "q", "q()", "quit()", "quit", "exit")){

                stop("[endgame]")

              }else if(guess == "pass"){

                checkingGuess <- FALSE
                board@lastguess <- FALSE

              }else if(guess %in% board@words){

                if(guess %in% board@words[!board@onboard]){

                  cat("You already guessed this word, remember? Try again.\n")
                  guess <- askPlayer("What will you choose?")
                  checkingGuess = TRUE

                }else{

                  cat("Let's see if you got it...\n")
                  checkingGuess = FALSE
                  ind.guess <- board@words == guess

                  if(board@spies[ind.guess] == board@team){

                    cat("Contact with spy made successfully!\n")
                    board@lastguess <- TRUE

                  }else if(board@spies[ind.guess] == "K"){

                    # Set up end of game variables
                    cat("Uh oh! You encountered the assassin!\n")
                    board@lastguess <- FALSE
                    board@endgame <- TRUE
                    board@winner <- ifelse(board@team == "R", "B", "R")

                  }else if(board@spies[ind.guess] == "N"){

                    cat("You encountered a civilian.\n")
                    board@lastguess <- FALSE

                  }else{

                    cat("You encountered another spy!\n")
                    board@lastguess <- FALSE
                  }

                  # Remove the selected word from the board
                  board@onboard[ind.guess] <- FALSE

                  # Stop game if no Red or Blue spies are left
                  if(sum(board@spies[board@onboard] == "R") == 0){

                    # Set up end of game variables
                    board@endgame <- TRUE
                    board@winner <- "R"

                  }else if(sum(board@spies[board@onboard] == "B") == 0){

                    # Set up end of game variables
                    board@endgame <- TRUE
                    board@winner <- "B"
                  }
                }

              }else{

                cat("Uhh...I don't see that word on the board. Try again.\n")
                guess <- askPlayer("What will you choose?")
                checkingGuess = TRUE
              }
            }

            return(board)
          }
)