RSelenium + 2048

RSelenium_2048.R

# RSelenium + 2048 demo on Budapest RUG (BURN) meetup - Laszlo Szakacs, 2015-01-14
# Commented and updated on 2015-01-18


# Selenium: http://www.seleniumhq.org
# RSelenium: http://ropensci.github.io/RSelenium
# 2048: http://gabrielecirulli.github.io/2048
# 2048 + R: http://decisionsandr.blogspot.hu/2014/04/play-2048-using-r.html
# Strategies: http://stackoverflow.com/questions/22342854/what-is-the-optimal-algorithm-for-the-game-2048


# load libraries
library("RSelenium")
library("magrittr") # just for fun
 
# open Firefox; the Selenium Server needs to be in the background (java -jar selenium-server-standalone-x.xx.x.jar)
remDr <- remoteDriver()
remDr$open()

# window sizing, positioning
remDr$setWindowSize(600, 750)
remDr$setWindowPosition(700, 0)

# open 2048
remDr$navigate("http://gabrielecirulli.github.io/2048")

# get title, make screenshot
remDr$getTitle()
remDr$screenshot(display = TRUE)

# javascript alert
remDr$executeScript("alert('2048!!!');")
remDr$dismissAlert()

# how to click on "New Game"
new_game <- remDr$findElement("css selector", ".restart-button")
new_game$highlightElement()
new_game$clickElement()

# or just press "r" for restart
remDr$sendKeysToActiveElement(list("r"))

# press an arrow
press <- function(k) {
  direction <- list(l = "left_arrow", r = "right_arrow", u = "up_arrow", d = "down_arrow")
  remDr$sendKeysToActiveElement(list(key = direction[[k]]))
}

# test arrows
press("r")
press("l")
press("u")
press("d")

# simple strategy
while(TRUE){
  press(c("l","r","u","d")[sample(1:4,1)])
}

# without "d"
while(TRUE){
  press(c("l","r","u")[sample(1:3,1)])
}

# only "l" and "u" - gets stuck
while(TRUE){
  press(c("l","u")[sample(1:2,1)])
}

# how to find out a tile's number
(remDr$findElement("css selector", ".tile-position-1-3 .tile-inner"))$getElementText()

# create a 4x4 matrix from the game state - slow
get_state1 <- function() {
  grid <- matrix(0, nrow = 4, ncol = 4)
  for (i in 1:4) {
    for (j in 1:4) {
      pos <- paste0(".tile-position-",j,"-",i," .tile-inner")
      e <- remDr$findElements("css selector", pos)
      l <- length(e)
      if (l > 0) {
        grid[i,j] <- as.numeric(e[[l]]$getElementText()[[1]])
      }
    }
  }
  grid
}
get_state1()
system.time(get_state1())

# create a 4x4 matrix from the game state - faster
get_state2 <- function() {
  s <-
    remDr$executeScript("return localStorage.gameState;") %>%
    `[[`(1) %>%
    fromJSON %>%
    `[[`("grid") %>%
    `[[`("cells") %>%
    unlist %>%
    matrix(ncol = 3, byrow = TRUE) %>% 
    apply(1, function(x) c(x[2]+1, x[1]+1, x[3])) %>%
    t
  grid <- matrix(0, nrow = 4, ncol = 4)
  for (i in 1:nrow(s)) {
    grid[s[i,1], s[i,2]] <- s[i,3]
  }
  grid
}
get_state2()
system.time(get_state2())

# "improved" strategy
m0 <- get_state2()
while(TRUE) {
  m <- get_state2()
  if (!identical(m, m0)) {
    press("l")
    press("u")
  } else {
    press("r")
  }
  m0 <- m
}


# the functions below are part of a more sophisticated algorithm (that was updated after the meetup)

# simulation of tile move in the 4x4 matrix
slide_matrix <- function(m, k) {
  slide_row <- function(v, f = identity) {
    v <- f(v)
    v <- c(v[v != 0], rep(0, sum(v == 0)))
    for (i in 1:3) {
      if (v[i] == v[i + 1]) v[i:(i + 1)] <- c(2 * v[i], 0) 
    }
    v <- v[v != 0]
    f(c(v, rep(0, 4 - length(v))))
  }
  switch(k,
    l = t(apply(m, 1, slide_row)),
    r = t(apply(m, 1, slide_row, rev)),
    u = apply(m, 2, slide_row),
    d = apply(m, 2, slide_row, rev)
  )
}

# simulation of random tile addition
add_random_tile <- function(m) {
  m <- c(m)
  n <- sum(m == 0)
  if (n > 0) m[m == 0][sample(1:n, 1)] <- sample(c(rep(2, 9), 4), 1)
  matrix(m, nrow = 4, ncol = 4)
}

# tile numbers in decreasing order weighted by position
get_rank <- function(m) {
  z <- t(m)
  x0 <- c(0.5, 0.3, 0.1, 0)
  x <- x0
  if (all(z[1:4]  >= 8)) x <- c(x, rev(x0))
  if (all(z[1:8]  >= 8)) x <- c(x, x0)
  if (all(z[1:12] >= 8)) x <- c(x, rev(x0))
  x <- c(x, rep(0, 16-length(x)))
  x <- t(matrix(x, nrow = 4, ncol = 4))
  rev(sort(m * (rep(c(4:1), 4) + x)))
}

# difference defined by lexicographical order
lex_diff <- function(r0, r1) {
  d <- r0 - r1
  d <- d[d != 0]
  if (length(d)==0) return(0)
  d[1]
}

# algorithm search depth: 2, effect of random tile: 20 runs averaged
# best result to my knowledge: 4096 tile with score of 78616
while(TRUE) {
  m0 <- get_state2()
  m0r <- 0
  b <- "u"
  for (k in c("u", "l", "r", "d")) {
    r <- rep(0, 16)
    m0k <- slide_matrix(m0, k)
    if (!identical(m0, m0k)) {
      for (i in 1:20) {
        m1 <- add_random_tile(m0k)
        m2o <- m1
        m2r <- get_rank(m2o)
        for (l in c("u", "l", "r", "d")) {
          m2 <- slide_matrix(m1, l)
          if (lex_diff(get_rank(m2), m2r) >= 0) {
            m2o <- m2
            m2r <- get_rank(m2o)
          }
        }
        r <- r + m2r
      }
    }
    m2r <- r / 20
    if (lex_diff(m2r, m0r) >= 0) {
      m0r <- m2r
      b <- k
    }
  }
  press(b)
}

# bye-bye
remDr$close()