A raycaster engine in plain R

Navigate a ā€œ3dā€ environment using the cursor keys.

This is not an instructive example on how to write a raycast engine, but more a demonstration of how far {eventloop} can go.

Controls

  • Navigage with LEFT, RIGHT, UP, DOWN cursor keys
  • Press ESC to quit

Note: No wall collisions. No handling of out-of-bound navigation

library(eventloop)
library(grid)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Generate a random N*N map
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
N <- 9
set.seed(1)
map <- matrix(sample(c(0L, 1L), N*N, replace = TRUE, prob = c(0.85, 0.3)), N, N)

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Ensure there are walls at each edge
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
map[1,] <- 1L
map[N,] <- 1L
map[,1] <- 1L
map[,N] <- 1L


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Data.frame representation of points so I have total control on how
# the map is rendered later
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
map_df     <- expand.grid(y = seq(N)-0.5, x = seq(N)-0.5)
map_df$val <- as.vector(map)
map_df$col <- ifelse(map_df$val == 1, 'grey70', 'white')


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Raycast into a map returning a vector of distances and types
#
# @param x0,y0 user position
# @param direction viewing angle in degrees
#
# @return list(dists, types)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
raycast <- function(x0, y0, direction, fov = 60, Nrays = 100) {

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Calculate all the rays to encompass the given field-of-view
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  
  ray_spread <- seq(-fov/2, fov/2, length.out = Nrays)
  angle_deg  <- direction + ray_spread

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Calculate angle (in radians) and the quadrant this is in
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  theta_orig <- angle_deg * pi/180
  theta      <- rep(theta_orig, each = N)
  
  quadrant <- as.integer( (angle_deg %% 360) / 90) + 1L
  quadrant <- rep(quadrant, each=N)
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Intercepts with horizontal walls
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  yfrac <- 1 - (y0 - floor(y0))
  yfrac <- rep(yfrac, N)
  
  dx <- 1/tan(theta)
  dx <- rep(dx, N)
  
  dy    <- ifelse(quadrant %in% 1:2,     1,        -1)
  yfrac <- ifelse(quadrant %in% 1:2, yfrac, 1 - yfrac)
  dx    <- ifelse(quadrant %in% 1:2,    dx,       -dx)
  
  
  mults <- yfrac + rep(seq.int(0, N-1L), times = Nrays)
  horx  <- x0 + mults * dx
  hory  <- y0 + mults * dy
  
  # If outside the boundary, then set to NA
  idx <- horx > 0 & horx < N & hory > 0 & hory < N
  horx[!idx] <- NA_real_
  hory[!idx] <- NA_real_
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Intercepts with vertical walls
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  xfrac <- 1 - (x0 - floor(x0))
  xfrac <- rep(xfrac, N)
  
  dy <- tan(theta)
  dy <- rep(dy, N)
  
  dx    <- ifelse(quadrant %in% c(1L, 4L),     1,        -1)
  xfrac <- ifelse(quadrant %in% c(1L, 4L), xfrac, 1 - xfrac)
  dy    <- ifelse(quadrant %in% c(1L, 4L),    dy,       -dy)
  
  mults <- xfrac + rep(seq.int(0, N-1L), times = Nrays)
  verx = x0 + mults * dx
  very = y0 + mults * dy
  
  # If outside the boundary, then set to NA
  idx <- verx > 0 & verx < N & very > 0 & very < N
  verx[!idx] <- NA_real_
  very[!idx] <- NA_real_
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # - Find the closest hit of the horizontal and vertical intercepts which intersect
  #     with a square containing a '1'
  # - Calculate the distance to the eye at (x0, y0)
  # - Determine whether the intersection was a horitonatl or vertical intercept
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  hhits_y <- ifelse(quadrant %in% 1:2, hory + 1, hory)
  hhits_x <- ceiling(horx)
  vhits_y <- ceiling(very)
  vhits_x <- ifelse(quadrant %in% c(1L, 4L), verx + 1, verx)
  
  hhits <- map[cbind(hhits_y, hhits_x)]
  vhits <- map[cbind(vhits_y, vhits_x)]
  
  hray <- rep(seq(Nrays), each = N)
  vray <- rep(seq(Nrays), each = N)
  
  htype <- rep(1L, length(hory))
  vtype <- rep(2L, length(very))
  
  hidx <- which(hhits == 1)
  vidx <- which(vhits == 1)
  
  
  fhorx <- horx[hidx]
  fhory <- hory[hidx]
  fhray <- hray[hidx]
  
  fverx <- verx[vidx]
  fvery <- very[vidx]
  fvray <- vray[vidx]
  
  
  x    <- c(fhorx, fverx)
  y    <- c(fhory, fvery)
  ray  <- c(fhray, fvray)
  type <- c(htype[hidx], vtype[vidx])
  
  
  raw_dists <- sqrt( (x - x0)^2 + (y - y0)^2 )
  dists     <- aggregate(raw_dists, by = list(ray = ray), min)$x
  
  # Correct for fish eye / lens distortion
  dists0 <- dists
  dists  <- dists * cos(ray_spread * pi/180)
  
  # Precalculate some heights
  heights <- 0.75 * 1/dists
  
  # work out the type of ray. was this a vertical or horitonal intercept?
  # I think this is wrong, but it works somehow???
  sray  <- sort(ray)
  types <- type[order(ray, raw_dists)]
  types <- aggregate(types, list(ray = sray), head, 1)$x
  
  
  
  list(
    dists0  = dists0,
    dists   = dists,
    heights = heights,
    types   = types,
    Nrays   = Nrays,
    theta   = theta_orig
  )
}




plot_raycast <- function(res, show_map = FALSE) {
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Plot the DDA view
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  dunit <- 'cm'
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Sky and ground
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  grid.rect(gp = gpar(fill='lightblue'))
  grid.rect(y = 0.25, height = 0.5, gp = gpar(fill = 'grey30'))
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Draw the walls
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  fill <- c('#004588', '#002366')[res$types]
  grid.rect(
    x      = ((res$Nrays:1)-0.5)/res$Nrays, 
    width  = 1/res$Nrays, 
    # height = (N - dists2)/15, 
    height = res$heights,
    gp     = gpar(col=NA, fill=fill)
  )
  
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Overhead view of the map
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (show_map) {
    grid.rect(x = map_df$x, y = map_df$y, width = 1, height = 1, default.units = dunit,
              gp = gpar(fill = map_df$col, col = 'grey50', alpha = 0.5))
    grid.points(x0, y0, default.units = dunit)
    
    xh <- x0 + res$dists0 * cos(res$theta)
    yh <- y0 + res$dists0 * sin(res$theta)
    grid.polyline(
      x = c(rbind(x0, xh)), 
      y = c(rbind(y0, yh)), 
      default.units = dunit,
      gp = gpar(
        col   = 'darkgreen', 
        lwd   = 1, 
        alpha = 0.5
      ), 
      id = rep(seq(res$Nrays), each = 2)
    )
  }
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Globals- starting user position and direction
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
x0  <- 4.7
y0  <- 3.4
angle <- 0



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Update the view within the eventloop depending on users control using
#' the arrow keys
#' 
#' Press ESC to quit.
#'
#' @param event The event from the graphics device. Is NULL when no event
#'        occurred.  Otherwise has `type` element set to:
#'        `event$type = 'mouse_down'` 
#'               - an event in which a mouse button was pressed
#'               - `event$button` gives the index of the button
#'        `event$type = 'mouse_up'`   
#'               - a mouse button was released
#'        `event$type = 'mouse_move'`   
#'               - mouse was moved 
#'        `event$type = 'key_press'`  
#'               - a key was pressed
#'               - `event$str` String describing which key was pressed. 
#'                  See \code{grDevices::setGraphicsEventHandlers} for more information.
#' @param mouse_x,mouse_y current location of mouse within window in normalised 
#'        coordinates in the range [0, 1]. If mouse is 
#'        not within window, this will be set to the last available coordinates
#' @param frame_num Current frame number (integer)
#' @param fps_actual,fps_target the curent framerate and the framerate specified
#'        by the user
#' @param dev_width,dev_height the width and height of the output device. Note:
#'        this does not cope well if you resize the window
#' @param ... any extra arguments ignored
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
wolf <- function(event, mouse_x, mouse_y, frame_num, fps_actual,
                         fps_target, dev_width, dev_height, ...) {
  grid::grid.rect(gp = grid::gpar(fill = 'black'))

  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # Keyboard control Left/Right/Up
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  if (!is.null(event) && event$type == 'key_press') {
    if (event$str == 'Left') {
      angle <<- angle + 3
    } else if (event$str == 'Right') {
      angle <<- angle - 3
    } else if (event$str == 'Up') {
      x0 <<- x0 + cos(angle * pi/180)/10
      y0 <<- y0 + sin(angle * pi/180)/10
    } else if (event$str == 'Down') {
      x0 <<- x0 - cos(angle * pi/180)/10
      y0 <<- y0 - sin(angle * pi/180)/10
    }
  }
  
  res <- raycast(x0, y0, angle)
  plot_raycast(res, show_map = TRUE)
  
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Start the event loop. Press ESC to quit
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
eventloop::run_loop(wolf, fps_target = 30)

Since an interactive window cannot be captured in a vignette, a video screen capture has been taken of the window and included below.