# FIXME:  All of these functions are calling par(xpd=NA, ...)
# Only the "bottom level" calls need to;  can I easily identify which
# are the "bottom level" ones ?

# NOTE that the valid.* functions are ONLY called just before
# parameters are passed in a .Call.graphics
# If you call a valid.* function on an already-validated unit or
# whatever, it will fail.

# FIXME:  all grid functions should check that .grid.started is TRUE
.grid.started <- FALSE
.grid.saved.pars <- NULL
# We rely on this being set to a valid viewport by a call to lset.viewport()
# (in a call to lstart() in .First.lib)
.grid.viewport <- NULL

# Call this function before you do any grid graphics
# This function is called by .First.lib so in simple usage
# the user need never know about it.
# Simple usage means:
#     library(grid), <grid drawing>[, detach(package:grid)]
grid.start <- function() {
  # NOTE that this starts a device as a side-effect
  .grid.saved.pars <<- par(xpd=NA, mfrow=c(1, 1),
                              oma=rep(0, 4), mar=rep(0, 4))
  # Install some default par settings
  set.gpar(gpar(fontsize=10, lineheight=1.2))
  grid.newpage()
  # Line below no longer needed because grid.newpage() calls lset.viewport()
  # lset.viewport()
  .grid.started <<- TRUE
}

# Call this function once you have finished with grid graphics
# This function is called by .Last.lib so in simple usage
# the user need never know about it.
# Simple usage means:
#     library(grid), <grid drawing>, detach(package:grid)
grid.stop <- function() {
  par(.grid.saved.pars)
  .grid.started <<- FALSE
}

# Set the grid "current viewport"
# This sets the top-level viewport; it resets the viewport stack
# NOTE that this operation gets recorded in the ldisplay.list
grid.set.viewport <- function(vp=grid.viewport(), recording=TRUE) {
  # valid.viewport will let a NULL viewport through and we do
  # NOT want that to happen here
  if (is.null(vp))
    stop("Illegal current viewport setting")
  # The viewport contains most of the context for coordinate systems
  # BUT it does not necessarily have explicit information about
  # fontsize;  we must use the current fontsize setting (i.e., par("ps"))
  # NOTE that this will include information from the viewport if it
  # has any because lpush/pop.viewport calls stack/unstack.viewports
  # (which call set/unset.gpar) before it calls grid.set.viewport
  # We also have to provide information about lineheight (again
  # because it is not necessarily explicitly specified in the viewport)
  # We record these in the viewport so that, for example, when
  # a child viewport is "popped" we can reset the fontsize and lineheight
  vp$cur.fontsize <- par("ps")
  vp$cur.lineheight <- get.gpar("lineheight")
  .Call.graphics("L_setviewport", vp)
  .grid.viewport <<- vp
  if (recording)
    record(vp)
}

stack.viewports <- function(vps) {
  if (length(vps) == 0)
    vp <- NULL
  else {
    vp <- vps[[length(vps)]]
    if (is.null(vp)) {
      if (length(vps) > 1)
        vp <- stack.viewports(vps[1:(length(vps)-1)])
    }
    else {
      if (length(vps) > 1)
        vp$parent <- stack.viewports(vps[1:(length(vps)-1)])
    }
  }
  vp
}

set.vp.gpars <- function(vps) {
  if (length(vps) != 0) {
    if (!is.null(vps[[1]])) {
      set.gpar(vps[[1]]$gp)
    }
    if (length(vps) > 1)
      set.vp.gpars(vps[1:(length(vps)-1)])
  }
}

# Push a viewport onto the viewport stack
grid.push.viewport <- function(..., recording=TRUE) {
  # FIXME:  should probably be doing this internally because
  # the user can get at .grid.viewport
  # Check special case where ... is single NULL viewport
  if (missing(...))
    stop("Must specify at least one viewport")
  else {
    vps <- list(...)
    if (length(vps) != 1 || !is.null(vps[[1]])) {
      # NOTE that we must do setting of gpars here so that
      # the gpars of viewports and grobs are correctly
      # intertwined
      set.vp.gpars(vps)
      vps <- list(.grid.viewport, ...)
      vp <- stack.viewports(vps)
      grid.set.viewport(vp, recording)
    }
  }
}

unstack.viewports <- function(startvp, vps) {
  if (!is.null(vps[[1]])) {
    startvp <- startvp$parent
  }
  if (length(vps) > 1)
    vp <- unstack.viewports(startvp, vps[2:length(vps)])
  else
    vp <- startvp
  vp
}

unset.vp.gpars <- function(vps) {
  if (length(vps) != 0) {
    if (!is.null(vps[[1]])) {
      unset.gpar(vps[[1]]$gp)
    }
    if (length(vps) > 1)
      unset.vp.gpars(vps[1:(length(vps)-1)])
  }
}

# Pop a viewport off the viewport stack
grid.pop.viewport <- function(..., recording=TRUE) {
  # FIXME:  should probably be doing this internally because
  # the user can get at .grid.viewport
  # Check special case where ... is single NULL viewport
  if (missing(...))
    stop("Must specify at least one viewport")
  else {
    vps <- list(...)
    if (length(vps) != 1 || !is.null(vps[[1]])) {
      # NOTE that we must do unsetting of gpars here so that
      # the gpars of viewports and grobs are correctly
      # intertwined
      unset.vp.gpars(vps)
      vp <- unstack.viewports(.grid.viewport, vps)
      grid.set.viewport(vp, recording)
    }
  }
}

# Function to obtain the current viewport
# Grid plotting functions all take a viewport argument which
# currents to NULL (NULL indicates that the current viewport
# should be used).  The function may want to copy the viewport
# it is drawing into (see e.g., lxaxis and grid.yaxis) and this
# function provides a consistent interface for deciding whether
# a temporary viewport has been specified or whether the
# current viewport is being used.
# Can also be called without specifying vp, just to get current
# current viewport (see e.g., lgrid)
grid.current.viewport <- function(vp=NULL) {
  if (is.null(vp))
    .grid.viewport
  else
    vp
}

clearpage <- function() {
  .Call("L_newpagerecording", par("ask"))
  .Call.graphics("L_newpage")
}

# Call this function if you want the graphics device erased or moved
# on to a new page.  High-level plotting functions should call this.
# NOTE however, that if you write a function which calls grid.newpage,
# you should provide an argument to allow people to turn it off
# so that they can use your function within a parent viewport
# (rather than the whole device) if they want to.
grid.newpage <- function(recording=TRUE) {
  clearpage()
  if (recording)
    # Erase the Grid display list
    clear.display.list()  
  # Reset the current viewport to be the entire device
  # (Is this an ok thing to do ?)
  grid.set.viewport(recording=recording)
}

# Keep a list of all drawing operations (since last grid.newpage()) so
# that we can redraw upon edit.
# FIXME:  Need list like this PER DEVICE
.grid.display.list <- vector("list", 100)
.grid.display.list.index <- 0
# Flag to indicate whether to record graphics operations
# record() and clear.display.list() check this value before
# they do anything
.grid.display.list.on <- 1

inc.display.list <- function() {
  .grid.display.list.index <<- .grid.display.list.index + 1
  n <- length(.grid.display.list)
  if (.grid.display.list.index > n) {
    temp <- .grid.display.list
    .grid.display.list <<- vector("list", n+100)
    .grid.display.list[1:n] <<- temp
  }
}

# This will either ...
#   (i) turn on AND INITIALISE the display list or ...
#   (ii) turn off AND ERASE the display list
grid.display.list <- function(on=TRUE) {
  .grid.display.list.on <<- on
  if (on) {
    .grid.display.list <- vector("list", 100)
    .grid.display.list.index <- 0
  }
  else 
    .grid.display.list <<- NULL
  .grid.display.list
}

record <- function(x) {
  if (.grid.display.list.on)
    UseMethod("record")
}

record.grob <- function(grob) {
  inc.display.list()
  # FIXME:  Should use assign() here ?
  .grid.display.list[[.grid.display.list.index]] <<- grob
}

record.viewport <- function(vp) {
  inc.display.list()
  # FIXME:  Should use assign() here ?
  .grid.display.list[[.grid.display.list.index]] <<- vp
}

clear.display.list <- function() {
  if (.grid.display.list.on) {
    .grid.display.list <<- vector("list", 100)
    .grid.display.list.index <<- 0
  }
}

######################################
# Grid graphical primitives
#######################################

# A graphical object is a unique object (i.e., we refer to it by pointer)
# so that it can be edited
# NOTE that cl is the class of the list.struct and "grob" is
# the class of the reference object
# The aim is to have user code only deal with the list.struct
# and hide the handling of pointers
# NOTE also that we stick class "glist" onto the list structure
# so that we can do generic things with them too.
grid.grob <- function(list.struct, cl=NULL, draw=TRUE) {
  class(list.struct) <- c(cl, "glist")
  ptr <- .Call("L_CreateSEXPPtr", list.struct)
  grob <- list(ptr)
  class(grob) <- "grob"
  if (draw)
    grid.draw(grob)
  invisible(grob)
}

is.grob <- function(x) {
  inherits(x, "grob")
}

get.value <- function(x, ...) {
  UseMethod("get.value")
}

get.value.default <- function(x, child.specs=NULL) {
  if (is.list(x) && length(child.specs) > 0)
      get.value(x[[child.specs[[1]]]], child.specs[-1])
  else
    x
}

get.value.grob <- function(grob, child.specs=NULL) {
  result <- .Call("L_GetSEXPPtr", grob[[1]])
  if (length(child.specs) > 0) 
    result <- get.value(result[[child.specs[[1]]]],
                        child.specs[-1])
  result
}

# Unwrap a list.struct from within a grob external pointer
grid.get <- function(grob, ...) {
  if (!is.grob(grob))
    stop("Cannot get value of non-grob")
  get.value.grob(grob, list(...))
}

# FIXME:  Replace with "<-.grob" method ?
set.value.grob <- function(grob, child.specs, list.struct) {
  ncs <- length(child.specs)  
  if (ncs == 0)
    target <- grob
  else
    target <- get.value.grob(grob, child.specs[-ncs])[[child.specs[[ncs]]]]
  .Call("L_SetSEXPPtr", target[[1]], list.struct)
}

# Wrap a list.struct within a grob external pointer
# Destructively set value of a grob
grid.set <- function(grob, ...) {
  if (!is.grob(grob))
    stop("Cannot set value of non-grob")
  args <- list(...)
  nargs <- length(args)
  if (nargs == 0)
    stop("No list.struct value specified")
  set.value.grob(grob, args[-nargs], args[[nargs]])
}

copy <- function(grob) {
  grob2 <- get.value.grob(grob)
  cl <- class(grob)
  grid.grob(grob2, cl[length(cl) - 1])
}

# Use this function to produce a list of new.values for grid.edit()
grid.prop.list <- function(...) {
  result <- list(...)
  class(result) <- "prop.list"
  result
}

# The ... part consists of zero or more child.specs, plus a single
# new.value or a list of new.values
grid.edit <- function(grob, ..., redraw=TRUE) {
  # If grob is NULL, do nothing, but don't give an error
  # This allows grobs to have NULL components
  if (!is.null(grob)) {
    if (!inherits(grob, "grob"))
      stop("Cannot edit value of non-grob")
    args <- list(...)
    nargs <- length(args)
    if (nargs == 0)
      stop("No new value specified")
    new.values <- args[nargs]
    # Handle list of new values
    if (inherits(new.values[[1]], "prop.list")) 
      new.values <- new.values[[1]]
    # Make sure that when grid.edit is called again from within
    # an edit.details method, that the new.values is a prop.list
    class(new.values) <- "prop.list"
    # If there are no new.values, just do nothing
    # This is possible, e.g., axis consumes at= and passes empty
    # new.values to axis$major etc
    if (length(new.values) > 0 && !is.null(names(new.values))) {
      child.specs <- args[-nargs]
      list.struct <- get.value.grob(grob, child.specs)
      slot.names <- names(new.values)
      for (i in 1:length(new.values)) 
        # If there is no slot with the argument name, just ignore that argument
        if (match(slot.names[i], names(list.struct), nomatch=0)) {
          list.struct[[slot.names[i]]] <- new.values[[i]]
          # If the new value was NULL, we have just erased the slot
          # from the list.struct.  Here we put it back.
          # FIXME: there must be a better way to do this !
          if (is.null(new.values[[i]])) {
            cl <- class(list.struct)
            temp <- list(NULL)
            names(temp) <- slot.names[i]
            list.struct <- c(list.struct, temp)
            class(list.struct) <- cl
          }
        }
      # Do any class-specific editing
      list.struct <- edit.details(list.struct, new.values)
      set.value.grob(grob, child.specs, list.struct)
      # FIXME:  This needs to draw ldisplay.list for all devices where
      # grob appears
      if (redraw)
        draw.all()
    }
  }
}

edit.details <- function(x, new.values) {
  UseMethod("edit.details")
}

edit.details.default <- function(x, new.values) {
  # Do nothing BUT return object being edited
  x
}

# Use generic function "draw" rather than generic function "print"
# because want graphics functions to produce graphics output
# without having to be evaluated at the command-line AND without having
# to necessarily produce a single graphical object as the return value
# (i.e., so that simple procedural code can be written just for its
# side-effects).
# For example, so that the following code will draw
# a rectangle AND a line:
#   temp <- function() { llines(); grid.rect() }
#   temp()
# All drawing methods have to extract the grob value at the start and
# record if necessary at the end.  The approach below means that custom
# drawing methods don't have to bother about this;  they just have to
# write a draw.details method
# Assume that all grobs have a slot called "vp" containing a viewport
# and a slot "gpar" containing a gpar
grid.draw <- function(x, recording=TRUE) {
  if (!is.null(x)) {
    if (is.grob(x) || is.viewport(x)) {
      list.struct <- get.value(x)
      # automatically push/pop the viewport and set/unset the gpar 
      grid.push.viewport(list.struct$vp, recording=FALSE)
      set.gpar(list.struct$gp)
      # Do any class-specific drawing
      draw.details(list.struct, x, recording)
      unset.gpar(list.struct$gp)
      grid.pop.viewport(list.struct$vp, recording=FALSE)
      if (recording)
        record(x)
    }
    else
      stop("Trying to draw non-grob or non-viewport")
  }
}

draw.all <- function() {
  grid.newpage(recording=FALSE)
  lapply(.grid.display.list, grid.draw, recording=FALSE)
  NULL
}

draw.details <- function(x, x.wrapper, recording) {
  UseMethod("draw.details")
}

draw.details.glist <- function(glist, grob, recording) {
}

draw.details.viewport <- function(vp, vp.again, recording) {
  grid.set.viewport(vp, recording=FALSE)
}

print.grob <- function(grob) {
  cl <- class(get.value.grob(grob))
  print(paste(cl[1:(length(cl)-1)], collapse=" "))
}

# Make an explicit copy of a grob (i.e., not just another reference
# to the same grob)
grid.copy <- function(grob) {
  list.struct <- grid.get(grob)
  cl <- class(list.struct)
  cl <- cl[1:(length(cl)-1)]
  grid.grob(list.struct, cl, draw=FALSE)
}

######################################
# Stuff for lpack()
######################################

grid.width <- function(x) {
  width(get.value(x))
}

grid.height <- function(x) {
  height(get.value(x))
}

width <- function(x) {
  UseMethod("width")
}

height <- function(x) {
  UseMethod("height")
}

width.default <- function(x) {
  unit(1, "null")
}

height.default <- function(x) {
  unit(1, "null")
}

width.frame <- function(frame) {
  sum(layout.widths(viewport.layout(frame$frame.vp)))
}

height.frame <- function(frame) {
  sum(layout.heights(viewport.layout(frame$frame.vp)))
}

draw.frame.child <- function(grob) {
  if (is.null(grob$border)) 
    temp.vp <- grid.viewport(layout.pos.col=grob$col,
                         layout.pos.row=grob$row)
  else
    temp.vp <- grid.viewport(layout.pos.col=grob$col,
                         layout.pos.row=grob$row,
                         x=grob$border[2],
                         y=grob$border[1],
                         width=unit(1, "npc") - sum(grob$border[c(2,4)]),
                         height=unit(1, "npc") - sum(grob$border[c(1,3)]))
  grid.push.viewport(temp.vp, recording=FALSE)
  grid.draw(grob, recording=FALSE)
  grid.pop.viewport(temp.vp, recording=FALSE)
}

draw.details.frame <- function(frame, grob, recording=TRUE) {
  grid.push.viewport(frame$frame.vp, recording=FALSE)
  lapply(frame$children, draw.frame.child)
  grid.pop.viewport(frame$frame.vp, recording=FALSE)
}

edit.details.frame <- function(frame, new.values) {
  # All we want to do here is make sure that children= and vp=
  # new.values are consumed
  slot.names <- names(new.values)
  if (c.index <- match("children", slot.names, nomatch=0)) {
    new.values <- new.values[-c.index]
    slot.names <- slot.names[-c.index]
  }
  if (fv.index <- match("frame.vp", slot.names, nomatch=0)) {
    new.values <- new.values[-fv.index]
    slot.names <- slot.names[-fv.index]
  }
  if (v.index <- match("vp", slot.names, nomatch=0))
    new.values <- new.values[-v.index]
  # Then we do what "collection"s do and pass everything down to children
  NextMethod()
}

# NOTE that this never produces any actual graphical output
# (there is nothing to draw) BUT it is important to use
# draw=TRUE if you want to pack the frame interactively.
# This ensures that the frame is on the .grid.display.list
# so that the editing that occurs in grid.pack() will redraw the
# frame when it forces a draw.all()
grid.frame <- function(vp=NULL, gp=gpar(), draw=TRUE) {
  # NOTE we have our own edit.details.frame, but in that
  # we want to be able to call edit.details.collection
  grid.grob(list(children=NULL, vp=vp, gp=gp, frame.vp=NULL),
        c("frame", "collection"), draw=draw)
}

num.col.specs <- function(side, col, col.before, col.after) {
  4 - sum(is.null(side) || any(c("top", "bottom") %in% side),
          is.null(col), is.null(col.before), is.null(col.after))
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
col.spec <- function(side, col, col.before, col.after, ncol) {
  if (!is.null(side)) {
    if (side == "left")
      col <- 1
    else if (side == "right")
      col <- ncol + 1
  }
  else if (!is.null(col.before))
    col <- col.before
  else if (!is.null(col.after))
    col <- col.after + 1
  col
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
new.col <- function(side, col, col.before, col.after, ncol) {
  # Special case ncol==0 for first grob added to frame
  if (!is.null(col))
    if (col > ncol)
      TRUE
    else
      FALSE
  else
    TRUE
}

num.row.specs <- function(side, row, row.before, row.after) {
  4 - sum(is.null(side) || any(c("left", "right") %in% side),
          is.null(row), is.null(row.before), is.null(row.after))
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
row.spec <- function(side, row, row.before, row.after, nrow) {
  if (!is.null(side)) {
    if (side == "top")
      row <- 1
    else if (side == "bottom")
      row <- nrow + 1
  }
  else if (!is.null(row.before))
    row <- row.before
  else if (!is.null(row.after))
    row <- row.after + 1
  row
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
new.row <- function(side, row, row.before, row.after, nrow) {
  # Special case nrow==0 for first grob added to frame
  if (!is.null(row))
    if (row > nrow)
      TRUE
    else
      FALSE
  else
    TRUE
}

mod.dims <- function(dim, dims, index, new.index, nindex) {
  if (new.index)
    if (index == 1)
      dims <- unit.c(dim, dims)
    else if (index == nindex)
      dims <- unit.c(dims, dim)
    else
      dims <- unit.c(dims[1:(index-1)], dim, dims[index:nindex])
  else {
    dim <- max(dim, dims[index])
    if (index==1)
      if (nindex == 1)
        dims <- dim
      else
        dims <- unit.c(dim, dims[2:nindex])
    else if (index==nindex)
      dims <- unit.c(dims[1:(nindex-1)], dim)
    else
      dims <- unit.c(dims[1:(index-1)], dim, dims[(index+1):nindex])
  }
  dims
}

# Pack a child grob within a frame grob
# (a special sort of editing just for frame grobs)
# FIXME:  Allow row/col specifications of length > 1
# FIXME:  Allow specification of respect for new row/col
grid.pack <- function(frame, grob, grob.name="", draw=TRUE,
                  side=NULL,
                  row=NULL, row.before=NULL, row.after=NULL,
                  col=NULL, col.before=NULL, col.after=NULL,
                  width=NULL, height=NULL,
                  border=NULL) {
  # (i) Check that the specifications of the location of the grob
  # give a unique location
  ncs <- num.col.specs(side, col, col.before, col.after)
  # If user does not specify a col, assume it is col 1 (for now ...)
  if (ncs == 0) {
    col <- 1
    ncs <- 1
  }
  if (ncs != 1) 
    stop("Cannot specify more than one of side=[\"left\", \"right\"], col, col.before, or col.after")
  nrs <- num.row.specs(side, row, row.before, row.after)
  # If user does not specify a row, assume it is row 1 (for now ...)
  if (nrs == 0) {
    row <- 1
    nrs <- 1
  }
  if (nrs != 1)
    stop("Must specify exactly one of side=[\"top\", \"bottom\"], row, row.before, or row.after")

  frame.vp <- grid.get(frame, "frame.vp")
  if (is.null(frame.vp))
    frame.vp <- grid.viewport()
  lay <- viewport.layout(frame.vp)
  if (is.null(lay)) {
    ncol <- 0
    nrow <- 0
  } else {
    ncol <- layout.ncol(lay) 
    nrow <- layout.nrow(lay) 
  }
  
  # (ii) Determine that location and check that it is valid
  new.col <- new.col(side, col, col.before, col.after, ncol)
  col <- col.spec(side, col, col.before, col.after, ncol)
  if (col < 1 || col > ncol + 1)
    stop("Invalid column specification")
  new.row <- new.row(side, row, row.before, row.after, nrow)
  row <- row.spec(side, row, row.before, row.after, nrow)
  if (row < 1 || row > nrow + 1)
    stop("Invalid row specification")
  
  # (iii) If width and height are not given, take them from the child
  if (is.null(width))
    if (is.null(grob))
      width <- unit(1, "null")
    else
      width <- grid.width(grob)
  # FIXME:  What do you do with "width" if length(col) > 1 ???
  if (is.null(height))
    if (is.null(grob))
      height <- unit(1, "null")
    else
      height <- grid.height(grob)
  # FIXME:  What do you do with "height" if length(row) > 1 ???
  # If there is a border, include it in the width/height
  if (!is.null(border)) {
    width <- sum(border[2], width, border[4])
    height <- sum(border[1], height, border[3])
  }
  
  # (iv) Update the frame.vp of the frame (possibly add new row/col,
  # possibly update existing widths/heights and respect)
  if (new.col) ncol <- ncol + 1
  if (new.row) nrow <- nrow + 1
  if (is.null(lay)) {
    widths <- width
    heights <- height
  } else {
    widths <- mod.dims(width, layout.widths(lay), col, new.col, ncol)
    heights <- mod.dims(height, layout.heights(lay), row, new.row, nrow)
  }
  respect <- layout.respect(lay)
  viewport.layout(frame.vp) <- grid.layout(ncol=ncol, nrow=nrow,
                                       widths=widths, height=heights)
  children <- grid.get(frame, "children")
  if (!is.null(grob)) {
    grob$row <- row
    grob$col <- col
    grob$border <- border
    children <- c(children, list(grob))
  }
  grid.edit(frame, grid.prop.list(children=children, frame.vp=frame.vp), redraw=draw)
}

######################################
# LINES primitive
######################################
draw.details.lines <- function(l, grob, recording=TRUE) {
  .Call.graphics("L_lines", l$x, l$y, .grid.viewport)
}

width.lines <- function(l) {
  max(l$x) - min(l$x)
}

height.lines <- function(l) {
  max(l$y) - min(l$y)
}

# Specify "units.per.obs=TRUE" to give a unit or units per (x, y) pair
grid.lines <- function(x=unit(c(0, 1), "npc", units.per.obs),
                   y=unit(c(0, 1), "npc", units.per.obs),
                   gp=gpar(),
                   default.units="npc", units.per.obs=FALSE,
                   draw=TRUE, vp=NULL) {
  # Allow user to specify unitless vector;  add default units
  if (!is.unit(x))
    x <- unit(x, default.units, units.per.obs)
  if (!is.unit(y))
    y <- unit(y, default.units, units.per.obs)
  l <- list(x=x, y=y, gp=gp, vp=vp)
  cl <- "lines"
  grid.grob(l, cl, draw)
}

######################################
# SEGMENTS primitive
######################################
draw.details.segments <- function(s, grob, recording=TRUE) {
  .Call.graphics("L_segments", s$x0, s$y0, s$x1, s$y1,
                 .grid.viewport)
}

# Specify "units.per.obs=TRUE" to give a unit or units per (x, y) pair
grid.segments <- function(x0=unit(0, "npc"), y0=unit(0, "npc"),
                      x1=unit(1, "npc"), y1=unit(1, "npc"),
                      gp=gpar(),
                      default.units="npc", units.per.obs=FALSE,
                      draw=TRUE, vp=NULL) {
  # Allow user to specify unitless vector;  add default units
  if (!is.unit(x0))
    x0 <- unit(x0, default.units, units.per.obs)
  if (!is.unit(x1))
    x1 <- unit(x1, default.units, units.per.obs)
  if (!is.unit(y0))
    y0 <- unit(y0, default.units, units.per.obs)
  if (!is.unit(y1))
    y1 <- unit(y1, default.units, units.per.obs)
  s <- list(x0=x0, y0=y0, x1=x1, y1=y1, gp=gp, vp=vp)
  cl <- "segments"
  grid.grob(s, cl, draw)
}

######################################
# RECT primitive
######################################
draw.details.rect <- function(r, grob, recording=TRUE) {
  # FIXME:  Here I am passing in the colours, whereas in lgrid below
  # I set the colours using par and never pass them down.  This is
  # inconsistent !  BUT due to inconsistency in graphics.c so this
  # is a FIXGRAPHICS rather than a FIXME :)
  .Call.graphics("L_rect", r$x, r$y, r$width, r$height,
                 valid.just(r$just, 2),
                 get.gpar("border"), get.gpar("fill"),
                 .grid.viewport)
}

grid.rect <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                  width=unit(1, "npc"), height=unit(1, "npc"),
                  just="centre", gp=gpar(),
                  default.units="npc", draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.unit(width))
    width <- unit(width, default.units)
  if (!is.unit(height))
    height <- unit(height, default.units)
  r <- list(x=x, y=y, width=width, height=height, just=just, gp=gp, vp=vp)
  cl <- "rect"
  grid.grob(r, cl, draw)
}

######################################
# TEXT primitive
######################################
draw.details.text <- function(txt, grob, recording=TRUE) {
  # FIXME:  Need type checking for "rot" and "check.overlap"
  .Call.graphics("L_text", txt$label, txt$x, txt$y, 
                 valid.just(txt$just, 2), txt$rot, txt$check.overlap,
                 .grid.viewport)
}

width.text <- function(txt) {
  unit(1, "strwidth", data=txt$label)
}

height.text <- function(txt) {
  unit(1, "strheight", data=txt$label)
}

grid.text <- function(label, x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                  just="centre", rot=0, gp=gpar(),
                  check.overlap=FALSE,
                  default.units="npc", draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  txt <- list(label=label, x=x, y=y, gp=gp,
              just=just, rot=rot, check.overlap=check.overlap,
              vp=vp)
  cl <- "text"
  grid.grob(txt, cl, draw)
}

######################################
# POINTS primitive
######################################
draw.details.points <- function(p, grob, recording=TRUE) {
  .Call.graphics("L_points", p$x, p$y, p$pch,
                 get.gpar("col"), get.gpar("fill"), 
                 .grid.viewport)
}

grid.points <- function(x=unit(runif(10), "native"),
                    y=unit(runif(10), "native"),
                    pch=1, gp=gpar(),
                    default.units="native",
                    draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (length(x) != length(y))
    stop("x and y must be unit objects and have the same length")
  p <- list(x=x, y=y, pch=pch, gp=gp, vp=vp)
  cl <- "points"
  grid.grob(p, cl, draw)
}

######################################
# Default COLLECTION of grobs
######################################
draw.details.collection <- function(collection, grob, recording=TRUE) {
  # A collection draws all of its children
  lapply(collection$children, grid.draw, recording=FALSE)
}

edit.details.collection <- function(collection, new.values) {
  # Pass all editing operations to children
  lapply(collection$children, grid.edit, new.values, redraw=FALSE)
  collection
}

# Have a draw=T argument because "only" other alternative is to
# have a separate make.collection function with identical argument
# list (i.e., duplicated entry point).  Not such an issue here,
# but just gets worse the more complex the graphical object gets.
grid.collection <- function(..., gp=gpar(), draw=T, vp=NULL) {
  children <- list(...)
  # Allow for single argument of a list of grobs (rather than
  # multiple grobs as separate arguments)
  if (!is.grob(children[[1]]) && is.list(children[[1]]))
    children <- children[[1]]
  collection <- list(children=children, gp=gp, vp=vp)
  cl <- "collection"
  grid.grob(collection, cl, draw)
}

######################################
# Grid plotting functions         #
######################################

grid.grid <- function(h=unit(seq(0.25, 0.75, 0.25), "npc"),
                  v=unit(seq(0.25, 0.75, 0.25), "npc"),
                  gp=gpar(col="grey"),
                  default.units="npc", vp=NULL) {
  if (!is.unit(h))
    h <- unit(h, default.units)
  if (!is.unit(v))
    v <- unit(v, default.units)
  # FIXME:  Should replace for loop and call to grid.lines with call to grid.segments
  # once the latter exists
  grid.push.viewport(vp)
  grid.segments(v, unit(0, "npc"), v, unit(1, "npc"), gp=gp)
  grid.segments(unit(0, "npc"), h, unit(1, "npc"), h, gp=gp)
  grid.pop.viewport(vp)
}

######################################
# AXES
######################################

# NOTE that the `at' parameter is numeric (i.e., NOT a unit) for
# lxaxis and grid.yaxis.  These functions assume a unit for the `at'
# values rather than letting the user specify a unit.

common.draw.axis <- function(axis) {
  grid.draw(axis$major, recording=FALSE)
  grid.draw(axis$ticks, recording=FALSE)
  if (!is.null(axis$labels))
    grid.draw(axis$labels, recording=FALSE)
}

common.edit.axis <- function(axis, new.values) {
  # Pass editing operations down to components
  grid.edit(axis$major, new.values, redraw=FALSE)
  grid.edit(axis$ticks, new.values, redraw=FALSE)
  if (!is.null(axis$labels))
    grid.edit(axis$labels, new.values, redraw=FALSE)
}

draw.details.xaxis <- function(axis, grob, recording=TRUE) {
  # We may have to create the children if there was not
  # enough information available at creation time
  if (is.na(axis$at)) {
    at <- .Call("L_pretty", grid.current.viewport()$xscale)
    # We edit the grob itself so that the change is permanent
    grid.edit(grob, at=at, redraw=FALSE)
    # Then we make sure the current draw is aware of the change
    axis <- grid.get(grob)
  }    
  common.draw.axis(axis)
}

# NOTE that this can't be for all axes because it needs to
# call make.XAXIS.ticks and make.XAXIS.labels
edit.details.xaxis <- function(axis, new.values) {
  slot.names <- names(new.values)
  if (at.index <- match("at", slot.names, nomatch=0)) {
    # NOTE that grid.edit has already set axis$at to the new value
    # We might set at to NULL to get ticks recalculated at redraw
    if (!is.na(axis$at)) {
      axis$major <- make.xaxis.major(axis$at, axis$main)
      axis$ticks <- make.xaxis.ticks(axis$at, axis$main)
      if (axis$label)
        axis$labels <- make.xaxis.labels(axis$at, axis$main)
      else
        axis$labels <- NULL
    }
    # Consume the "at=" argument
    new.values <- new.values[-at.index]
  }
  # FIXME:  Handle "label=" and "main=" too ?
  common.edit.axis(axis, new.values)
  axis
}

make.xaxis.major <- function(at, main) {
  if (main)
    y <- c(0, 0)
  else
    y <- c(1, 1)
  grid.lines(unit(c(min(at), max(at)), "native"),
         unit(y, "npc"), draw=FALSE)
}
    
make.xaxis.ticks <- function(at, main) {
  if (main) {
    tick.y0 <- unit(0, "npc")
    tick.y1 <- unit(-.5, "lines")
  }
  else {
    tick.y0 <- unit(1, "npc")
    tick.y1 <- unit(1, "npc") + unit(.5, "lines")
  }
  ticks <- grid.segments(unit(at, "native"), tick.y0,
                     unit(at, "native"), tick.y1,
                     draw=FALSE)
}

make.xaxis.labels <- function(at, main) {
  # FIXME:  labels only character versions of "at"
  if (main)
    label.y <- unit(-1.5, "lines")
  else
    label.y <- unit(1, "npc") + unit(1.5, "lines")
  grid.text(as.character(at), unit(at, "native"), label.y,
                    just="centre", rot=0, 
                    check.overlap=TRUE, draw=FALSE)
}

# The "main" x-axis is on the bottom when vp$origin is "bottom.*"
# and on the top when vp$origin is "top.*"
grid.xaxis <- function(at=NA, label = TRUE, main=TRUE, gp=gpar(),
                   draw=TRUE, vp=NULL) {
  if (is.na(at))
    if (is.null(vp)) {
      # We do not have enough information to make the ticks and labels
      major <- NULL
      ticks <- NULL
      labels <- NULL
    }
    else
      at <- .Call("L_pretty", vp$xscale)
  if (!is.na(at)) {
    major <- make.xaxis.major(at, main)
    ticks <- make.xaxis.ticks(at, main)
    if (label)
      labels <- make.xaxis.labels(at, main)
    else
      labels <- NULL
  }
  grid.grob(list(at=at, major=major, ticks=ticks, labels=labels,
             label=label, gp=gp, main=main, vp=vp),
        c("xaxis", "axis"), draw)
}

draw.details.yaxis <- function(axis, grob, recording=TRUE) {
  # We may have to create the children if there was not
  # enough information available at creation time
  if (is.na(axis$at)) {
    at <- .Call("L_pretty", grid.current.viewport()$yscale)
    grid.edit(grob, at=at, redraw=FALSE)
    axis <- grid.get(grob)
  }    
  common.draw.axis(axis)
}

edit.details.yaxis <- function(axis, new.values) {
  slot.names <- names(new.values)
  if (at.index <- match("at", slot.names, nomatch=0)) {
    if (!is.na(axis$at)) {
      axis$major <- make.yaxis.major(axis$at, axis$main)
      axis$ticks <- make.yaxis.ticks(axis$at, axis$main)
      if (axis$label)
        axis$labels <- make.yaxis.labels(axis$at, axis$main)
      else
        axis$labels <- NULL
    }
    new.values <- new.values[-at.index]
  }
  common.edit.axis(axis, new.values)
  axis
}

make.yaxis.major <- function(at, main) {
  if (main)
    x <- c(0, 0)
  else
    x <- c(1, 1)
  grid.lines(unit(x, "npc"), unit(c(min(at), max(at)), "native"), draw=FALSE)
}
    
make.yaxis.ticks <- function(at, main) {
  if (main) {
    tick.x0 <- unit(0, "npc")
    tick.x1 <- unit(-.5, "lines")
  }
  else {
    tick.x0 <- unit(1, "npc")
    tick.x1 <- unit(1, "npc") + unit(.5, "lines")
  }
  ticks <- grid.segments(tick.x0, unit(at, "native"), 
                     tick.x1, unit(at, "native"),
                     draw=FALSE)
}

make.yaxis.labels <- function(at, main) {
  if (main) {
    hjust <- "right"
    label.x <- unit(-1, "lines")
  }
  else {
    hjust <- "left"
    label.x <- unit(1, "npc") + unit(1, "lines")
  }
  just <- c(hjust, "centre")
  grid.text(as.character(at), label.x, unit(at, "native"), 
        just=just, rot=0, check.overlap=TRUE, draw=FALSE)
}

# The "main" y-axis is on the left when vp$origin is "*.left"
# and on the right when vp$origin is "*.right"
grid.yaxis <- function(at=NA, label=TRUE, main=TRUE, gp=gpar(),
                   draw=TRUE, vp=NULL) {
  if (is.na(at))
    if (is.null(vp)) {
      # We do not have enough information to make the ticks and labels
      major <- NULL
      ticks <- NULL
      labels <- NULL
    }
    else
      at <- .Call("L_pretty", vp$yscale)
  if (!is.na(at)) {
    major <- make.yaxis.major(at, main)
    ticks <- make.yaxis.ticks(at, main)
    if (label)
      labels <- make.yaxis.labels(at, main)
    else
      labels <- NULL
  }
  grid.grob(list(at=at, major=major, ticks=ticks, labels=labels,
             label=label, gp=gp, main=main, vp=vp),
        c("yaxis", "axis"), draw)
}

######################################
# Example applications of grid    #
######################################

grid.strip <- function(label="whatever", range.full=c(0, 1),
                   range.thumb=c(.3, .6),
                   fill="#FFBF00", thumb="#FF8000",
                   vp=NULL) {
  diff.full <- diff(range.full)
  diff.thumb <- diff(range.thumb)
  grid.push.viewport(vp)
  grid.rect(gp=gpar(border=NULL, fill=fill))
  grid.rect(range.thumb[1]/diff.full, 0, diff.thumb/diff.full, 1,
        just=c("left", "bottom"),
        gp=gpar(border=NULL, fill=thumb))
  grid.text(as.character(label))
  grid.pop.viewport(vp)
}  

grid.panel <- function(x = runif(10), y = runif(10),
                   zrange = c(0, 1), zbin = runif(2),
                   xscale = range(x)+c(-1,1)*.05*diff(range(x)),
                   yscale = range(y)+c(-1,1)*.05*diff(range(y)),
                   axis.left = TRUE, axis.left.label = TRUE,
                   axis.right = FALSE, axis.right.label = TRUE,
                   axis.bottom = TRUE, axis.bottom.label = TRUE,
                   axis.top = FALSE, axis.top.label = TRUE,
                   vp=NULL) {
  grid.push.viewport(vp)
  temp.vp <- grid.viewport(layout=grid.layout(2, 1,
                         heights=unit(c(1, 1), c("lines", "null"))))
  grid.push.viewport(temp.vp)
  strip.vp <- grid.viewport(layout.pos.row=1, layout.pos.col=1,
                        xscale=xscale)
  grid.push.viewport(strip.vp)
  grid.strip(range.full=zrange, range.thumb=zbin)
  grid.rect()
  if (axis.top)
    grid.xaxis(main=FALSE, label=axis.top.label)
  grid.pop.viewport(strip.vp)
  plot.vp <- grid.viewport(layout.pos.row=2, layout.pos.col=1,
                       xscale=xscale, yscale=yscale)
  grid.push.viewport(plot.vp)
  grid.grid()
  grid.points(x, y, gp=gpar(col="blue"))
  grid.rect()
  if (axis.left)
    grid.yaxis(label=axis.left.label)
  if (axis.right)
    grid.yaxis(main=FALSE, label=axis.right.label)
  if (axis.bottom)
    grid.xaxis(label=axis.bottom.label)
  grid.pop.viewport(plot.vp)
  grid.pop.viewport(temp.vp)
  grid.pop.viewport(vp)
  invisible(list(strip.vp = strip.vp, plot.vp = plot.vp))
}

grid.multipanel <- function(x=runif(90), y=runif(90), z=runif(90),
                        nrow=2, ncol=5, nplots=9,
                        newpage=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  grid.push.viewport(vp)
  temp.vp <- grid.viewport(layout=grid.layout(nrow, ncol))
  grid.push.viewport(temp.vp)
  xscale <- range(x)+c(-1,1)*.05*diff(range(x))
  yscale <- range(y)+c(-1,1)*.05*diff(range(y))
  breaks <- seq(min(z), max(z), length=nplots + 1)
  for (i in 1:nplots) {
    col <- (i - 1) %% ncol + 1
    row <- (i - 1) %/% ncol + 1
    panel.vp <- grid.viewport(layout.pos.row=row,
                          layout.pos.col=col)
    panelx <- x[z >= breaks[i] & z <= breaks[i+1]]
    panely <- y[z >= breaks[i] & z <= breaks[i+1]]
    grid.panel(panelx, panely, range(z), c(breaks[i], breaks[i+1]),
           xscale, yscale,
           axis.left=(col==1), axis.left.label=is.odd(row),
           axis.right=(col==ncol || i==nplots),
           axis.right.label=is.even(row),
           axis.bottom=(row==nrow), axis.bottom.label=is.odd(col),
           axis.top=(row==1), axis.top.label=is.even(col),
           vp=panel.vp)
  }
  grid.text("Compression Ratio", unit(.5, "npc"), unit(-4, "lines"),
        gp=gpar(fontsize=20),
        just="center", rot=0)
  grid.text("NOx (micrograms/J)", unit(-4, "lines"), unit(.5, "npc"),
        gp=gpar(fontsize=20),
        just="centre", rot=90)
  grid.pop.viewport(temp.vp)
  grid.pop.viewport(vp)
}

grid.show.layout <- function(l, newpage=TRUE,
                         cell.border="blue", cell.fill="light blue",
                         cell.label=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  grid.push.viewport(vp)
  grid.rect(gp=gpar(border=NULL, fill="light grey"))
  vp.mid <- grid.viewport(0.5, 0.5, 0.8, 0.8, layout=l)
  grid.push.viewport(vp.mid)
  grid.rect(gp=gpar(fill="white"))
  gp.red <- gpar(col="red")
  for (i in 1:l$nrow)
    for (j in 1:l$ncol) {
      vp.inner <- grid.viewport(layout.pos.row=i, layout.pos.col=j)
      grid.push.viewport(vp.inner)
      grid.rect(gp=gpar(border=cell.border, fill=cell.fill))
      if (cell.label)
        grid.text(paste("(", i, ", ", j, ")", sep=""), gp=gpar(col="blue"))
      if (j==1)
        grid.text(as.character(l$heights[i]), gp=gp.red,
              just=c("right", "centre"),
              x=unit(-.05, "inches"), y=unit(.5, "npc"), rot=0)
      if (i==l$nrow)
        grid.text(as.character(l$widths[j]), gp=gp.red,
              just=c("centre", "top"), 
              x=unit(.5, "npc"), y=unit(-.05, "inches"), rot=0)
      if (j==l$ncol)
        grid.text(as.character(l$heights[i]), gp=gp.red,
              just=c("left", "centre"), 
              x=unit(1, "npc") + unit(.05, "inches"), y=unit(.5, "npc"),
              rot=0)
      if (i==1)
        grid.text(as.character(l$widths[j]), gp=gp.red,
              just=c("centre", "bottom"), 
              x=unit(.5, "npc"), y=unit(1, "npc") + unit(.05, "inches"),
              rot=0) 
      grid.pop.viewport(vp.inner)
    }
  grid.pop.viewport(vp.mid)
  grid.pop.viewport(vp)
  # return the viewport used to represent the parent viewport
  invisible(vp.mid)
}

grid.show.viewport <- function(v, parent.layout=NULL, newpage=TRUE, vp=NULL) {
  # if the viewport has a non-NULL layout.pos.row or layout.pos.col
  # AND the viewport has a parent AND the parent has a layout
  # represent the location of the viewport in the parent's layout ...
  if ((!is.null(v$layout.pos.row) || !is.null(v$layout.pos.col)) &&
      !is.null(parent.layout)) {
    grid.push.viewport(vp)
    vp.mid <- grid.show.layout(parent.layout,
                           cell.border="grey", cell.fill="white",
                           cell.label=FALSE, newpage=newpage)
    grid.push.viewport(vp.mid)
    grid.push.viewport(v)
    gp.red <- gpar(col="red")
    grid.rect(gp=gpar(border="blue", fill="light blue"))
    at <- .Call("L_pretty", v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- .Call("L_pretty", v$yscale)
    grid.yaxis(at=c(min(at), max(at)), gp=gp.red)
    grid.pop.viewport(v)
    grid.pop.viewport(vp.mid)
    grid.pop.viewport(vp)
  } else {
    if (newpage)
      grid.newpage()
    grid.push.viewport(vp)
    grid.rect(gp=gpar(border=NULL, fill="light grey"))
    # generate a viewport within the "top" viewport (vp) to represent the
    # parent viewport of the viewport we are "show"ing (v).
    # This is so that annotations at the edges of the
    # parent viewport will be at least partially visible
    vp.mid <- grid.viewport(0.5, 0.5, 0.8, 0.8)
    grid.push.viewport(vp.mid)
    grid.rect(gp=gpar(fill="white"))
    x <- v$x
    y <- v$y
    w <- v$width
    h <- v$height
    grid.push.viewport(v)
    grid.rect(gp=gpar(border="blue", fill="light blue"))
    # represent the "native" scale
    gp.red <- gpar(col="red")
    at <- .Call("L_pretty", v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- .Call("L_pretty", v$yscale)
    grid.yaxis(at=c(min(at), max(at)), gp=gp.red)
    grid.text(as.character(w), gp=gp.red,
          just=c("centre", "bottom"),
          x=unit(.5, "npc"), y=unit(1, "npc") + unit(.05, "inches"))        
    grid.text(as.character(h), gp=gp.red,
          just=c("left", "centre"), 
          x=unit(1, "npc") + unit(.05, "inches"), y=unit(.5, "npc"))
    grid.pop.viewport(v)
    # annotate the location and dimensions of the viewport
    grid.lines(unit.c(x, x), unit.c(unit(0, "npc"), y),
           gp=gpar(col="red", lty="dashed"))
    grid.lines(unit.c(unit(0, "npc"), x), unit.c(y, y),
           gp=gpar(col="red", lty="dashed"))
    grid.text(as.character(x), gp=gp.red,
          just=c("centre", "top"), 
          x=x, y=unit(-.05, "inches"))
    grid.text(as.character(y), gp=gp.red, 
          just=c("right", "centre"), 
          x=unit(-.05, "inches"), y=y)
    grid.pop.viewport(vp.mid)
    grid.pop.viewport(vp)
  }
}

grid.legend <- function(pch, labels, frame=TRUE,
                    hgap=unit(0.5, "lines"), vgap=unit(0.5, "lines"),
                    default.units="lines",
                    gp=gpar(), draw=TRUE,
                    vp=NULL) {
  # Type checking on arguments
  labels <- as.character(labels)
  nkeys <- length(labels)
  if (length(pch) != nkeys)
    stop("pch and labels not the same length")
  if (!is.unit(hgap))
    hgap <- unit(hgap, default.units)
  if (length(hgap) != 1)
    stop("hgap must be single unit")
  if (!is.unit(vgap))
    vgap <- unit(vgap, default.units)
  if (length(vgap) != 1)
    stop("vgap must be single unit")
  lf <- grid.frame(vp=vp, gp=gp, draw=FALSE)
  for (i in 1:nkeys) {
    if (i==1)
      border <- unit.c(0.5*vgap, hgap, vgap*0.5, hgap*0.5)
    else
      border <- unit.c(0.5*vgap, 0.5*hgap, vgap*0.5, hgap)
    grid.pack(lf, grid.points(.5, .5, pch=pch[i], draw=F),
          col=1, row=i, border=border,
          width=unit(1, "lines"), height=unit(1, "lines"),
          draw=FALSE)
    grid.pack(lf, grid.text(labels[i], x=0, y=.5, just=c("left", "centre"),
                    draw=F),
          col=2, row=i, border=border, draw=FALSE)
  }
  if (draw) 
    grid.draw(lf)
  lf
}

# Just a wrapper for a sample series of grid commands
grid.plot.and.legend <- function() {
  grid.newpage()
  top.vp <- grid.viewport(w=0.8, h=0.8)
  grid.push.viewport(top.vp)
  x <- runif(10)
  y1 <- runif(10)
  y2 <- runif(10)
  pch <- 1:3
  labels <- c("Girls", "Boys", "Other")
  lf <- grid.frame()
  plot <- grid.collection(grid.rect(draw=F),
                      grid.points(x, y1, pch=1, draw=F),
                      grid.points(x, y2, pch=2, draw=F),
                      grid.xaxis(draw=F),
                      grid.yaxis(draw=F),
                      draw=F)
  grid.pack(lf, plot)
  grid.pack(lf, llegend(pch, labels, draw=F), height=unit(1,"null"), side="right")
  grid.draw(lf)
}

