FastR experiments with Sudoku code extracted (Rcpp ignored)

## plain_R.R
sudokuTxt <- "
1 0 0  0 0 0  0 0 6
0 0 6  0 2 0  7 0 0
7 8 9  4 5 0  1 0 3

0 0 0  8 0 7  0 0 4
0 0 0  0 3 0  0 0 0
0 9 0  0 0 4  2 0 1

3 1 2  9 7 0  0 4 0
0 4 0  0 1 2  0 7 8
9 0 8  0 0 0  0 0 0"


sudoku <- as.matrix(
  read.table(text = sudokuTxt,
             col.names = letters[1:9]))


library(zeallot)
library(magrittr)

solve <- function(partialSolution, choicesFUN) {
  # Eliminate impossible values, give some suggestions
  # and flag contradictions.
  c(partialSolution, suggestions, contradiction) %<-%
    eliminate(partialSolution, choicesFUN)
  # If dead end FALSE to trace back, if finished TRUE.
  if (contradiction) return(list(FALSE, NULL))
  if (all(partialSolution %in% 1:9))
    return(list(TRUE, partialSolution))
  # Branching, exit when the solution is found.
  for (suggestion in suggestions) {
    c(result, solution) %<-% solve(suggestion,
                                   choicesFUN)
    if (result) return(list(result, solution))
  }
  list(FALSE, NULL)
}


eliminate <- function(grid, choicesFUN) {
  suggestions <- 0:9
  for (i in 1:nrow(grid)) { for (j in 1:ncol(grid)) {
    if (grid[i, j] == 0L) {
      choices <- choicesFUN(grid, i, j)
      if (length(choices) == 0L) {
        return(list(NULL, NULL, TRUE))
      } else if (length(choices) == 1L) {
        grid[i, j] <- choices
        return(list(grid, list(grid), FALSE))
      } else
        suggestions <- updateSuggestions(
          choices, grid, i, j, suggestions)
    }
  }}
  list(grid, suggestions, FALSE)
}


# Find all the choices allowed by the rules.
findChoices <- function(grid, i, j) {
  1:9 %>% setdiff(grid[i, ]) %>%
    setdiff(grid[ , j]) %>%
    setdiff(grid[i - (i - 1) %% 3L + 0:2,
                 j - (j - 1) %% 3L + 0:2])
}
# Create a list of grids with suggested next moves.
updateSuggestions <- function(choices, grid, i, j,
                              lastBest) {
  if (length(choices) < length(lastBest))
    lapply(choices, function(choice) {
      grid[i, j] <- choice; grid
    })
  else
    lastBest
}


solution <- solve(sudoku, findChoices)
if (!solution[[1]]) { cat('Solution not found\n')
} else { print(as.data.frame(solution[[2]])) }


sudokuTxt <- "
8 0 0  0 0 0  0 0 0
0 0 3  6 0 0  0 0 0
0 7 0  0 9 0  2 0 0
0 5 0  0 0 7  0 0 0
0 0 0  0 4 5  7 0 0
0 0 0  1 0 0  0 3 0
0 0 1  0 0 0  0 6 8
0 0 8  5 0 0  0 1 0
0 9 0  0 0 0  4 0 0"
sudoku <- as.matrix(
  read.table(text = sudokuTxt,
             col.names = letters[1:9]))


solve2 <- function(partialSolution, choicesFUN) {
  # Eliminate impossible values, give some suggestions
  # and flag contradictions.
  elStep <- eliminate(partialSolution, choicesFUN)
  # If dead end FALSE to trace back, if finished TRUE.
  if (elStep[[3]]) return(list(res = FALSE,
                               sol = NULL))
  if (all(elStep[[1]] %in% 1:9))
    return(list(res = TRUE, sol = elStep[[1]]))
  # Branching, exit when the solution is found.
  for (suggestion in elStep[[2]]) {
    ans <- solve2(suggestion, choicesFUN)
    if (ans$res) return(ans)
  }
  list(res = FALSE, sol = NULL)
}


findChoices2 <- function(grid, i, j) {
  setdiff(setdiff(setdiff(1:9,
                    grid[i, ]),
            grid[ , j]),
    grid[i - (i - 1) %% 3L + 0:2,
         j - (j - 1) %% 3L + 0:2])
}

print(microbenchmark::microbenchmark(
  solve2(sudoku, findChoices2),
  control = list(warmup = 20L)
))

## sqr.R
library(microbenchmark)
sqr <- function(x) x * x

f1 <- function() for (n in 1:1000) sqr(runif(1:n))

print(R.version)
print(microbenchmark(f1(), control = list(warmup = 100L)))

## sudoku.cpp
#include <Rcpp.h>
using namespace Rcpp;

IntegerMatrix subGrid(IntegerMatrix& x, int i, int j) {
  i -= i % 3; j -= j % 3;
  return x(Range(i, i + 2), Range(j, j + 2));
}
// [[Rcpp::export]]
IntegerVector findChoicesCpp(IntegerMatrix& x,
                             int i, int j) {
  IntegerVector candidates(9);
  std::iota(candidates.begin(), candidates.end(), 1);
  // C++ is zero-indexed.
  return setdiff(setdiff(setdiff(candidates,
                                 IntegerVector(x(i - 1, _))),
                                 IntegerVector(x(_, j - 1))),
                                 subGrid(x, i - 1, j - 1));
}

## sudoku.R
library(Rcpp)
library(microbenchmark)

sudokuTxt <- "
8 0 0  0 0 0  0 0 0
0 0 3  6 0 0  0 0 0
0 7 0  0 9 0  2 0 0
0 5 0  0 0 7  0 0 0
0 0 0  0 4 5  7 0 0
0 0 0  1 0 0  0 3 0
0 0 1  0 0 0  0 6 8
0 0 8  5 0 0  0 1 0
0 9 0  0 0 0  4 0 0"
sudoku <- as.matrix(
  read.table(text = sudokuTxt,
             col.names = letters[1:9]))

eliminate <- function(grid, choicesFUN) {
  suggestions <- 0:9
  for (i in 1:nrow(grid)) { for (j in 1:ncol(grid)) {
    if (grid[i, j] == 0L) {
      choices <- choicesFUN(grid, i, j)
      if (length(choices) == 0L) {
        return(list(NULL, NULL, TRUE))
      } else if (length(choices) == 1L) {
        grid[i, j] <- choices
        return(list(grid, list(grid), FALSE))
      } else
        suggestions <- updateSuggestions(
          choices, grid, i, j, suggestions)
    }
  }}
  list(grid, suggestions, FALSE)
}

updateSuggestions <- function(choices, grid, i, j,
                              lastBest) {
  if (length(choices) < length(lastBest))
    lapply(choices, function(choice) {
      grid[i, j] <- choice; grid
    })
  else
    lastBest
}

solve2 <- function(partialSolution, choicesFUN) {
  # Eliminate impossible values, give some suggestions
  # and flag contradictions.
  elStep <- eliminate(partialSolution, choicesFUN)
  # If dead end FALSE to trace back, if finished TRUE.
  if (elStep[[3]]) return(list(res = FALSE,
                               sol = NULL))
  if (all(elStep[[1]] %in% 1:9))
    return(list(res = TRUE, sol = elStep[[1]]))
  # Branching, exit when the solution is found.
  for (suggestion in elStep[[2]]) {
    ans <- solve2(suggestion, choicesFUN)
    if (ans$res) return(ans)
  }
  list(res = FALSE, sol = NULL)
}

Rcpp::sourceCpp('sudoku.cpp')

solve2(sudoku, findChoicesCpp)