Vectorised sudoku solver in R

sudoku2.R

sudoku <- matrix( data = c(0,0,0,0,0,6,0,0,0
                          ,0,9,5,7,0,0,3,0,0
                          ,4,0,0,0,9,2,0,0,5
                          ,7,6,4,0,0,0,0,0,3
                          ,0,0,0,0,0,0,0,0,0
                          ,2,0,0,0,0,0,9,7,1
                          ,5,0,0,2,1,0,0,0,9
                          ,0,0,7,0,0,5,4,8,0
                          ,0,0,0,8,0,0,0,0,0)
                , byrow = TRUE
                , ncol = 9
                )

build_masks <- function( N ) {
  N2 <- N * N
  N12 <- as.integer( sqrt( N ) )
  coords <- expand.grid( i = seq.int( N )
                       , j = seq.int( N )
                       )
  coords$ii <- ( coords$i - 1L ) %/% N12 + 1L # block row
  coords$jj <- ( coords$j - 1L ) %/% N12 + 1L # block column
  coords$b <- with( coords, ii + ( jj - 1L ) * N12 )
  bmasks <- matrix( rep( FALSE, N2 * N )
                  , ncol = N
                  )
  for ( b in seq.int( N ) ) {
    bmasks[ , b ] <- b == coords$b
  }
  imasks <- matrix( rep( FALSE, N2 * N )
                  , ncol = N
                  )
  for ( i in seq.int( N ) ) {
    imasks[ , i ] <- i == coords$i
  }
  jmasks <- matrix( rep( FALSE, N2 * N )
                  , ncol = N
                  )
  for ( j in seq.int( N ) ) {
    jmasks[ , j ] <- j == coords$j
  }
  list( coords = coords
      , bmasks = bmasks
      , imasks = imasks
      , jmasks = jmasks
      )
}
#build_masks( 4L )

sudoku2 <- function( m ) {
  if ( inherits( m, "sudoku2" ) ) return( m )
  stopifnot( inherits( m, "matrix" ) )
  stopifnot( ncol( m ) == nrow( m ) )
  N <- ncol( m )
  N12 <- as.integer( sqrt( N ) )
  stopifnot( N == N12 * N12 )
  class( m ) <- c( "sudoku2", class( m ) )
  m
}

print.sudoku2 <- function( obj, ... ) {
  cat( "\n" )
  for ( i in 1:9 ) {
    if ( i %in% c( 4, 7 ) ) {
      cat("- - - + - - - + - - -\n")
    }
    cat( obj[ i, 1:3 ]
       , "|"
       , obj[ i, 4:6 ]
       , "|"
       , obj[ i, 7:9 ]
       , "\n"
       )
  }
  cat( "\n" )
}

solve_sudoku2 <-function( bo, masks ) {
  # Find all empty cells
  empties <- which( 0L == bo )

  if ( 0L == length( empties ) ) {
    # The board has been solved
    return( sudoku2( bo ) )
  }
  eix <- length( empties )
  e <- empties[ eix ]
  N <- as.integer( sqrt( length( bo ) ) )
  boards <- matrix( 0L, nrow = N * N, ncol = eix )
  boards[ , eix ] <- bo
  
  coords <- masks$coords
  iv <- coords$i # row indices for each slot
  jv <- coords$j # column indices for each slot
  bv <- coords$b # block indices for each slot
  bmasks <- masks$bmasks # block masks
  imasks <- masks$imasks # row masks
  jmasks <- masks$jmasks # column masks
  # Attempt to solve iteratively
  while ( 0L < eix ) { # while empties index is not used up...
    # if have reached highest number in this location... rollup to next empties index
    while ( N == boards[ e, eix ] ) {
      if ( length( eix ) == eix ) {
        return( NULL )
      }
      eix <- eix + 1L
      e <- empties[ eix ]
    }
    boards[ e, eix ] <- boards[ e, eix ] + 1L # increment possible value for empty slot
    board <-boards[ , eix ] # grab a copy of the board for testing
    evalue <- board[ e ]
    # Test for valid answers
    if (  ( 1L == sum( evalue == board[ imasks[ , iv[ e ] ] ] ) )   # Check for only one matching entry in the row
       && ( 1L == sum( evalue == board[ jmasks[ , jv[ e ] ] ] ) )   # Check for only one matching entry in the column
       && ( 1L == sum( evalue == board[ bmasks[ , bv[ e ] ] ] ) )   # Check for only one matching entry in the block
       ) {
      # If it works, try the next empty slot
      eix <- eix - 1L
      if ( 0 < eix ) {
        e <- empties[ eix ]
        boards[ , eix ] <- boards[ , eix + 1L ]
      }
    }
  }
  # return a sudoku2 object for perusal or possible printing
  sudoku2( matrix( boards[ , 1L ], ncol = ncol( bo ) ) )
}
masks <- build_masks( ncol( sudoku ) ) # precompute the masks
solve_sudoku2( sudoku, masks ) # solve, use automatic printing