######################################
# 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)
}

# 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=TRUE, 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)
}

######################################
# 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)
}

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)) {
    # FIXME:  There should be a grid.pretty rather than
    # forcing users to use grid.Call
    at <- grid.pretty(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
editDetails.xaxis <- function(axis, new.values) {
  slot.names <- names(new.values)
  if (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
    }
  }
  # FIXME:  Handle "label=" and "main=" too ?
  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 <- grid.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 <- grid.pretty(current.viewport()$yscale)
    grid.edit(grob, at=at, redraw=FALSE)
    axis <- grid.get(grob)
  }    
  common.draw.axis(axis)
}

editDetails.yaxis <- function(axis, new.values) {
  slot.names <- names(new.values)
  if (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
    }
  }
  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 <- grid.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)
}

######################################
# Simple "side-effect" plotting functions         
######################################

grid.grill <- function(h=unit(seq(0.25, 0.75, 0.25), "npc"),
                       v=unit(seq(0.25, 0.75, 0.25), "npc"),
                       default.units="npc",
                       gp=gpar(col="grey"), 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
  if (!is.null(vp))
    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)
  if (!is.null(vp))
    pop.viewport()
}

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

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

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

draw.frame.child <- function(grob) {
  temp.vp <- viewport(layout.pos.col=grob$col,
                      layout.pos.row=grob$row)
  push.viewport(temp.vp, recording=FALSE)
  if (!is.null(grob$border))
    push.viewport(viewport(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)]),
                           just=c("left", "bottom")),
                  recording=FALSE)
  grid.draw(grob, recording=FALSE)
  if (!is.null(grob$border))
    pop.viewport(recording=FALSE)
  pop.viewport(recording=FALSE)
}

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

# 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(layout=NULL, vp=NULL, gp=gpar(), draw=FALSE) {
  if (!is.null(layout))
    frame.vp <- viewport(layout=layout)
  else
    frame.vp <- NULL
  grid.grob(list(children=NULL, vp=vp, gp=gp, frame.vp=frame.vp),
        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
  result <- TRUE
  if (!is.null(col)) {
    # It is an error to specify a range for col which is outside 1..ncol
    if (length(col) == 2) 
      if (col[1] < 1 || col[2] > ncol)
        stop("`col' can only be a range of existing columns")
      else
        result <- FALSE
    # It is also an error to specify a single col outside 1..ncol+1
    else
      if (col < 1 || col > ncol + 1)
        stop("Invalid column specification")
      else
        result <- col == ncol+1
  }
  result
}

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
  result <- TRUE
  if (!is.null(row)) {
    # It is an error to specify a range for row which is outside 1..nrow
    if (length(row) == 2) 
      if (row[1] < 1 || row[2] > nrow)
        stop("`row' can only be a range of existing rows")
      else
        result <- FALSE
    # It is also an error to specify a single row outside 1..nrow+1
    else
      if (row < 1 || row > nrow + 1)
        stop("Invalid row specification")
      else
        result <- row == nrow+1
  }
  result
}

mod.dims <- function(dim, dims, index, new.index, nindex, force) {
  # If adding a new row/col, add the new width/height to the list
  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])
  # Otherwise, if force=TRUE, we override previous width/heights for the
  # row/col, otherotherwise, the width/height of the existing row/col
  # is the maximum of the previous width/height and the new width/height
  else {
    if (!force)
      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
}

updateCol <- function(grob, added.col) {
  old.col <- grob$col
  # If grob$col is a range ...
  if (length(old.col) == 2) {
    if (added.col <= old.col[2])
      grob$col <- c(old.col[1], old.col[2] + 1)
  }
  else
    if (added.col <= old.col)
      grob$col <- old.col + 1
  grob
}

updateRow <- function(grob, added.row) {
  old.row <- grob$row
  # If grob$row is a range ...
  if (length(old.row) == 2) {
    if (added.row <= old.row[2])
      grob$row <- c(old.row[1], old.row[2] + 1)
  }
  else
    if (added.row <= old.row)
      grob$row <- old.row + 1
  grob
}

# This guy is just a simpler interface to grid.pack(), with
# the focus more on just "placing" a grob within the existing
# layout of a frame, without modifying that layout in any way
# In this way, it is basically just a more convenient way of
# locating grobs within a viewport with a layout
# NOTE that it relies on intimate knowledge of grid.pack
# to make the minimum impact on the existing layout
# THEREFORE it is fragile if grid.pack changes
# In particular, it makes sure that the widths/heights of
# the layout are untouched by specifying the row and col as
# a range
grid.place <- function(frame, grob, grob.name="", draw=TRUE,
                       row=1, col=1) {
  if (length(row) == 1)
    row <- rep(row, 2)
  if (length(col) == 1)
    col <- rep(col, 2)
  grid.pack(frame, grob, grob.name, draw,
            col=col, row=row,
            # Just dummy values;  they will be ignored by grid.pack
            width=unit(1, "null"), height=unit(1, "null"))
}

# Pack a child grob within a frame grob
# (a special sort of editing just for frame grobs)
# 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,
                      force.width=FALSE, force.height=FALSE,
                      border=NULL) {
  # col/row can be given as a range, but I only want to know
  # about the min and max
  if (!is.null(col) & length(col) > 1) {
    col <- range(col)
    col.range <- TRUE
  }
  else
    col.range <- FALSE
  if (!is.null(row) & length(row) > 1) {
    row <- range(row)
    row.range <- TRUE
  }
  else
    row.range <- FALSE
  
  frame.vp <- grid.get(frame, "frame.vp")
  if (is.null(frame.vp))
    frame.vp <- viewport()
  lay <- viewport.layout(frame.vp)
  if (is.null(lay)) {
    ncol <- 0
    nrow <- 0
  } else {
    ncol <- layout.ncol(lay) 
    nrow <- layout.nrow(lay) 
  }
  
  # (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 all cols
  if (ncs == 0) {
    # Allow for fact that this might be first grob packed
    if (ncol > 0) {
      col <- c(1, ncol)
      col.range <- TRUE
    }
    else
      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 all rows
  if (nrs == 0) {
    # Allow for fact that this might be first grob packed
    if (nrow > 0) {
      row <- c(1, nrow)
      row.range <- TRUE
    }
    else
      row <- 1
    nrs <- 1
  }
  if (nrs != 1)
    stop("Must specify exactly one of side=[\"top\", \"bottom\"], row, row.before, or row.after")

  # (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)
  new.row <- new.row(side, row, row.before, row.after, nrow)
  row <- row.spec(side, row, row.before, row.after, nrow)
  
  # (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 <- unit(1, "grobwidth", grob)
  if (is.null(height))
    if (is.null(grob))
      height <- unit(1, "null")
    else
      height <- unit(1, "grobheight", grob)
  # 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 we are creating the frame.vp$layout for the first time then
  # we have to initialise the layout widths and heights
  if (is.null(lay)) {
    widths <- width
    heights <- height
  } else {
    # DO NOT modify widths/heights if the grob is being added to
    # multiple columns/rows
    if (col.range)
      widths <- layout.widths(lay)
    else
      widths <- mod.dims(width, layout.widths(lay), col, new.col, ncol,
                         force.width)
    if (row.range)
      heights <- layout.heights(lay)
    else
      heights <- mod.dims(height, layout.heights(lay), row, new.row, nrow,
                          force.height)
  }
  # NOT SURE WHAT THIS WAS DOING HERE
  # respect <- layout.respect(lay)
  frame.vp$layout <- grid.layout(ncol=ncol, nrow=nrow,
                                 widths=widths, height=heights)
  children <- grid.get(frame, "children")
  # Modify the locations (row, col) of existing children in the frame
  if (new.col)
    children <- lapply(children, updateCol, col)
  if (new.row)
    children <- lapply(children, updateRow, row)
  if (!is.null(grob)) {
    # Give the new grob a record of its location (row, col) in the frame
    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)
}


# A "gpar" object is a list of graphics parameters
# A graphics parameter is a name-value pair

gpar <- function(...) {
  gp <- validGP(list(...))
  class(gp) <- "gpar"
  gp
}

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

validGP <- function(gpars) {
  # Check a gpar is numeric and not NULL
  numnotnull <- function(gparname) {
    if (!is.na(match(gparname, names(gpars)))) {
      if (is.null(gpars[[gparname]]))
        gpars[[gparname]] <<- NULL
      else 
        gpars[[gparname]] <<- as.numeric(gpars[[gparname]])
    }
  }
  # fontsize, lineheight, cex, lwd should be numeric and not NULL
  numnotnull("fontsize")
  numnotnull("lineheight")
  numnotnull("cex")
  numnotnull("lwd")
  numnotnull("gamma")
  # col and fill are converted in C code
  # so is lty, BUT still want to check for NULL
  if (!is.na(match("lty", names(gpars)))) 
    if (is.null(gpars$lty))
      gpars$lty <- NULL  
  # font should be integer and not NULL
  if (!is.na(match("font", names(gpars)))) {
    if (is.null(gpars$font))
      gpars$font <- NULL
    else
      gpars$font <- as.integer(gpars$font)
  }
  gpars
}

saved.pars <- function(pars) {
  list(prev=NULL, pars=pars)
}
push.saved.gpars <- function(gpars) {
  sp <- saved.pars(gpars)
  sp$prev <- grid.Call("L_getGPsaved")
  grid.Call("L_setGPsaved", sp)
}

pop.saved.gpars <- function() {
  grid.Call("L_setGPsaved", grid.Call("L_getGPsaved")$prev)
}

# possible gpar names
.grid.gpar.names <- c("fill", "col", "gamma", "lty", "lwd", "cex",
                      "fontsize", "lineheight", "font")

# Set .grid.gpars to keep grid record of current settings
set.gpar <- function(gp) {
  if (!is.gpar(gp))
    stop("Argument must be a 'gpar' object")
  subset <- match(names(gp), .grid.gpar.names)
  cur.gpars <- grid.Call("L_getGPar")
  push.saved.gpars(cur.gpars[subset])
  temp <- cur.gpars
  temp[subset] <- gp
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setGPar", temp)
}

unset.gpar <- function(gp) {
  if (!is.gpar(gp))
    stop("Argument must be a 'gpar' object")
  # for debugging really
  subset <- match(names(gp), .grid.gpar.names)
  saved.gpars <- grid.Call("L_getGPsaved")
  if (length(subset) != length(saved.gpars$pars))
    stop(paste("Trying to reset", names(gp),
               "with", saved.gpars$pars))
  temp <- grid.Call("L_getGPar")
  temp[subset] <- saved.gpars$pars
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setGPar", temp)
  pop.saved.gpars()
}  

get.gpar <- function(gpar.name) {
  grid.Call("L_getGPar")[[gpar.name]]
}



# This should be the only grid global variable(?)
# It contains the list of state structures corresponding to the
# state for each device.
# The state structures are stored in here so that they do not
# get garbage collected.
.GRID.STATE <- NULL

# FIXME:  all grid functions should check that .grid.started is TRUE
.grid.loaded <- FALSE

# Define a convenience function that is easy to call from C code
grid.top.level.vp <- function() {
  viewport(clip=TRUE)
}

push.vp <- function(vps, index, len, recording) {
  vp <- vps[[index]]
  if (is.null(vp))
    stop("Illegal to push NULL viewport")
  # Record on the display list
  if (recording)
    record(vp)
  # Enforce gpar settings
  set.gpar(vp$gp)
  # Later, we will query the viewport to ask "what were the gpar
  # settings when you were drawn".  This is NOT the same as asking
  # the viewport for its gpar settings because the viewport may only
  # specify some gpar values.  So we record the default settings
  # we will need to know about
  vp$cur.font <- get.gpar("font")
  vp$cur.fontsize <- get.gpar("fontsize")
  vp$cur.lineheight <- get.gpar("lineheight")
  # Calculate viewport transform 
  # NOTE that we will have modified "vp" within L_setviewport
  # to record the current transformation and layout
  grid.Call.graphics("L_setviewport", vp, TRUE)
  # Push further viewports if required
  if (index < len) 
    push.vp(vps, index+1, len, recording)
}

push.viewport <- function(..., recording=TRUE) {
  if (missing(...))
    stop("Must specify at least one viewport")
  else {
    vps <- list(...)
    nvp <- length(vps)
    push.vp(vps, 1, nvp, recording)
  }
}

pop.vp <- function(last.one, recording) {
  vp <- grid.Call("L_currentViewport")
  # Fail if trying to pop top-level viewport
  if (is.null(vp$parent))
    stop("Illegal to pop top-level viewport")
  # Unset gpar settings
  unset.gpar(vp$gp)
  # Allow for recalculation of viewport transform if necessary
  grid.Call.graphics("L_unsetviewport", last.one)
}

pop.viewport <- function(n=1, recording=TRUE) {
  if (n < 1)
    stop("Must pop at least one viewport")
  else {
    for (i in 1:n)
      pop.vp(i==n, recording)
    # Record on the display list
    if (recording)
      record(n)
  }
}

# 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)
current.viewport <- function(vp=NULL) {
  if (is.null(vp))
    grid.Call("L_currentViewport")
  else
    vp
}

# 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) {
  # NOTE that we do NOT do grid.Call here because we have to do
  # things slightly differently if grid.newpage is the first grid operation
  # on a new device
  .Call("L_newpagerecording", par("ask"))
  .Call("L_newpage")
  .Call("L_initGPar")
  .Call("L_initViewportStack")
  if (recording)
    .Call("L_initDisplayList")
}

###########
# DISPLAY LIST FUNCTIONS
###########

# Keep a list of all drawing operations (since last grid.newpage()) so
# that we can redraw upon edit.

inc.display.list <- function() {
  display.list <- grid.Call("L_getDisplayList")
  dl.index <- grid.Call("L_getDLindex")
  dl.index <- dl.index + 1
  n <- length(display.list)
  # The " - 1" below is because dl.index is now stored internally
  # so is a C-style zero-based index rather than an R-style
  # 1-based index
  if (dl.index > (n - 1)) {
    temp <- display.list
    display.list <- vector("list", n+100)
    display.list[1:n] <- temp
  }
  grid.Call("L_setDisplayList", display.list)
  grid.Call("L_setDLindex", as.integer(dl.index))
}

# 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.Call("L_setDLon", as.logical(on))
  if (on) {
    grid.Call("L_setDisplayList", vector("list", 100))
    grid.Call("L_setDLindex", as.integer(0))
  }
  else 
    grid.Call("L_setDisplayList", NULL)
}

record <- function(x) {
  if (grid.Call("L_getDLon"))
    UseMethod("record")
}

# When there is a pop.viewport, the number of viewports popped
# gets put on the display list
record.default <- function(n) {
  grid.Call("L_setDLelt", n)
  inc.display.list()
}

record.grob <- function(grob) {
  grid.Call("L_setDLelt", grob)
  inc.display.list()
}

record.viewport <- function(vp) {
  grid.Call("L_setDLelt", vp)
  inc.display.list()
}

# Wrapper for .Call and .Call.graphics
# Used to make sure that grid-specific initialisation occurs just before
# the first grid graphics output OR the first querying of grid state
# (on the current device)
# The general rule is you should use these rather than .Call or
# .Call.graphics unless you have a good reason and you know what
# you are doing -- this will be a bit of overkill, but is for safety
grid.Call <- function(fnname, ...) {
  .Call("L_gridDirty")
  .Call(fnname, ...)
}

grid.Call.graphics <- function(fnname, ...) {
  .Call.graphics("L_gridDirty")
  .Call.graphics(fnname, ...)
}

######################################
# 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 <- editDetails(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()
    }
  }
}

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

editDetails.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() { grid.lines(); 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)) {
      list.struct <- get.value(x)
      # automatically push/pop the viewport and set/unset the gpar
      if (!is.null(list.struct$vp))
        push.viewport(list.struct$vp, recording=FALSE)
      if (!is.null(list.struct$gp))
        set.gpar(list.struct$gp)
      # Do any class-specific drawing
      draw.details(list.struct, x, recording)
      if (!is.null(list.struct$gp))
        unset.gpar(list.struct$gp)
      if (!is.null(list.struct$vp))
          pop.viewport(recording=FALSE)
      if (recording)
        record(x)
  }
}

draw.all <- function() {
  grid.newpage(recording=FALSE)
  lapply(grid.Call("L_getDisplayList"), grid.draw, recording=FALSE)
  NULL
}

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

# When there is a pop.viewport, the number of viewports popped
# gets put on the display list
draw.details.default <- function(n, n.again, recording) {
  pop.viewport(n, recording)
}

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

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

print.grob <- function(x, ...) {
  cl <- class(get.value.grob(x))
  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)
}

######################################
# 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)
  if (!is.null(vp))
    push.viewport(vp)
  grid.rect(gp=gpar(col=NULL, fill=fill))
  grid.rect((range.thumb[1] - range.full[1])/diff.full, 0,
            diff.thumb/diff.full, 1,
            just=c("left", "bottom"),
            gp=gpar(col=NULL, fill=thumb))
  grid.text(as.character(label))
  if (!is.null(vp))
    pop.viewport()
}  

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) {
  if (!is.null(vp))
    push.viewport(vp)
  temp.vp <- viewport(layout=grid.layout(2, 1,
                         heights=unit(c(1, 1), c("lines", "null"))))
  push.viewport(temp.vp)
  strip.vp <- viewport(layout.pos.row=1, layout.pos.col=1,
                        xscale=xscale)
  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)
  pop.viewport()
  plot.vp <- viewport(layout.pos.row=2, layout.pos.col=1,
                       xscale=xscale, yscale=yscale)
  push.viewport(plot.vp)
  grid.grill()
  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)
  pop.viewport(2)
  if (!is.null(vp))
    pop.viewport()
  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()
  if (!is.null(vp))
    push.viewport(vp)
  temp.vp <- viewport(layout=grid.layout(nrow, ncol))
  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 <- 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)
  pop.viewport()
  if (!is.null(vp))
    pop.viewport()
}

grid.show.layout <- function(l, newpage=TRUE,
                         cell.border="blue", cell.fill="light blue",
                         cell.label=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  if (!is.null(vp))
    push.viewport(vp)
  grid.rect(gp=gpar(col=NULL, fill="light grey"))
  vp.mid <- viewport(0.5, 0.5, 0.8, 0.8, layout=l)
  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 <- viewport(layout.pos.row=i, layout.pos.col=j)
      push.viewport(vp.inner)
      grid.rect(gp=gpar(col=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) 
      pop.viewport()
    }
  pop.viewport()
  if (!is.null(vp))
    pop.viewport()
  # 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)) {
    if (!is.null(vp))
      push.viewport(vp)
    vp.mid <- grid.show.layout(parent.layout,
                           cell.border="grey", cell.fill="white",
                           cell.label=FALSE, newpage=newpage)
    push.viewport(vp.mid)
    push.viewport(v)
    gp.red <- gpar(col="red")
    grid.rect(gp=gpar(col="blue", fill="light blue"))
    at <- grid.pretty(v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- grid.pretty(v$yscale)
    grid.yaxis(at=c(min(at), max(at)), gp=gp.red)
    pop.viewport(2)
    if (!is.null(vp))
      pop.viewport()
  } else {
    if (newpage)
      grid.newpage()
    if (!is.null(vp))
      push.viewport(vp)
    grid.rect(gp=gpar(col=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 <- viewport(0.5, 0.5, 0.8, 0.8)
    push.viewport(vp.mid)
    grid.rect(gp=gpar(fill="white"))
    x <- v$x
    y <- v$y
    w <- v$width
    h <- v$height
    push.viewport(v)
    grid.rect(gp=gpar(col="blue", fill="light blue"))
    # represent the "native" scale
    gp.red <- gpar(col="red")
    at <- grid.pretty(v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- grid.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"))
    pop.viewport()
    # 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)
    pop.viewport()
    if (!is.null(vp))
      pop.viewport()
  }
}

# old 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")
  gf <- grid.frame(layout=grid.layout(nkeys, 2), vp=vp, gp=gp, draw=FALSE)
  for (i in 1:nkeys) {
    if (i==1) {
      symbol.border <- unit.c(vgap, hgap, vgap, hgap)
      text.border <- unit.c(vgap, unit(0, "npc"), vgap, hgap)
    }
    else {
      symbol.border <- unit.c(vgap, hgap, unit(0, "npc"), hgap)
      text.border <- unit.c(vgap, unit(0, "npc"), unit(0, "npc"), hgap)
    }
    grid.pack(gf, grid.points(.5, .5, pch=pch[i], draw=FALSE),
              col=1, row=i, border=symbol.border,
              width=unit(1, "lines"), height=unit(1, "lines"),
              force.width=TRUE, draw=FALSE)
    grid.pack(gf, grid.text(labels[i], x=0, y=.5, just=c("left", "centre"),
                            draw=FALSE),
              col=2, row=i, border=text.border, draw=FALSE)
  }
  if (draw) 
    grid.draw(gf)
  gf
}

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")
  legend.layout <-
    grid.layout(nkeys, 3,
                widths=unit.c(unit(2, "lines"),
                  max(unit(rep(1, nkeys), "strwidth", as.list(labels))),
                  hgap),
                heights=unit.pmax(unit(2, "lines"),
                  vgap + unit(rep(1, nkeys), "strheight", as.list(labels))))
  gf <- grid.frame(layout=legend.layout, vp=vp, gp=gp, draw=FALSE)
  for (i in 1:nkeys) {
    grid.place(gf, grid.points(.5, .5, pch=pch[i], draw=FALSE),
               col=1, row=i, draw=FALSE)
    grid.place(gf, grid.text(labels[i], x=0, y=.5, just=c("left", "centre"),
                             draw=FALSE),
               col=2, row=i, draw=FALSE)
  }
  if (draw) 
    grid.draw(gf)
  gf
}

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

# NOTE: the order of the strings in these conversion functions must
# match the order of the enums in ../src/lattice.h
# NOTE: the result of match() is an integer, but subtracting 1 converts
# to real => have to convert back to integer for passing to C code
valid.just <- function(just, n) {
  if (length(just) < n)
    just <- rep(just, length.out=n)
  just <- as.integer(match(just, c("left", "right", "bottom", "top",
                                   "centre", "center")) - 1)
  if (any(is.na(just)))
    stop("Invalid justification")
  just
}

justifyX <- function(x, width, just) {
  switch(just[1],
         left=x,
         centre=x - width*0.5,
         center=x - width*0.5,
         right=x - width)
}

justifyY <- function(y, height, just) {
  switch(if (length(just) > 1) just[2] else just[1],
         bottom=y,
         centre=y - height*0.5,
         center=y - height*0.5,
         top=y - height)
}



is.layout <- function(l) {
  inherits(l, "layout")
}

# FIXME:  The internal C code now does a lot of recycling of
# unit values, units, and data.  Can some/most/all of the
# recycling stuff below be removed ?
valid.layout <- function(nrow, ncol, widths, heights, respect) {
  nrow <- as.integer(nrow)
  ncol <- as.integer(ncol)
  # make sure we're dealing with a unit object
  if (!is.logical(respect)) {
    respect <- as.matrix(respect)
    if (!is.matrix(respect) || any(dim(respect) != c(nrow, ncol))) 
      stop("'respect' must be logical or an 'nrow' by 'ncol' matrix")
    }
  if (is.matrix(respect)) {
    respect.mat <- as.integer(respect)
    respect <- 2
  }
  else {
    respect.mat <- matrix(as.integer(0), nrow, ncol)
  }
  l <- list(nrow = nrow, ncol = ncol,
            widths = widths, heights = heights,
            respect = respect, valid.respect=as.integer(respect),
            respect.mat = respect.mat)
  class(l) <- "layout"
  l
}

layout.torture <- function() {
  top.vp <- viewport(y=0, height=unit(1, "npc") - unit(1.5, "lines"),
                     just=c("centre", "bottom"))
  do.label <- function(label) {
    grid.rect(y=1, height=unit(1.5, "lines"),
              just=c("center", "top"))
    grid.text(label,
              y=unit(1, "npc") - unit(1, "lines"),
              gp=gpar(font=2))
  }
  # 1 = all relative widths and heights
  grid.show.layout(grid.layout(3,2), vp=top.vp)
  do.label("All dimensions relative -- no respect")
  # (1) with full respect
  grid.show.layout(grid.layout(3,2, respect=TRUE), vp=top.vp)
  do.label("All dimensions relative -- full respect")
  # (1) with partial respect
  grid.show.layout(grid.layout(3,2,respect=matrix(c(1,0,0,0,0,0), 3, 2, TRUE)),
                   vp=top.vp)
  do.label("All dimensions relative -- only top-left cell respected")
  # (1) with slightly weirder partial respect
  grid.show.layout(grid.layout(3,2,respect=matrix(c(1,0,0,0,0,1), 3, 2, TRUE)),
                   vp=top.vp)
  do.label("All relative -- top-left, bottom-right respected")
  # 2 = combination of absolute and relative widths and heights
  grid.show.layout(grid.layout(2, 3,
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null"))),
                   vp=top.vp)
  do.label("Absolute and relative -- no respect")
  # (2) with full respect
  grid.show.layout(grid.layout(2, 3, 
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null")), respect=TRUE),
                   vp=top.vp)
  do.label("Absolute and relative -- full respect")
  # (2) with partial respect
  grid.show.layout(grid.layout(2, 3, 
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null")),
                       respect=matrix(c(0,0,0,0,0,1), 2, 3, TRUE)),
                   vp=top.vp)
  do.label("Absolute and relative -- bottom-right respected")
}

####################
# Accessors
####################

layout.nrow <- function(lay) {
  lay$nrow
}

layout.ncol <- function(lay) {
  lay$ncol
}

layout.widths <- function(lay) {
  lay$widths
}

layout.heights <- function(lay) {
  lay$heights
}

layout.respect <- function(lay) {
  switch(lay$respect + 1,
         FALSE,
         TRUE,
         lay$respect.mat)
}

####################
# Public constructor function
####################
grid.layout <- function (nrow = 1, ncol = 1,
                         widths = unit(rep(1, ncol), "null"), 
                         heights = unit(rep(1, nrow), "null"),
                         default.units = "null",
                         respect = FALSE)
{
  if (!is.unit(widths))
    unit(widths, default.units)
  if (!is.unit(heights))
    unit(heights, default.units) 
  valid.layout(nrow, ncol, widths, heights, respect)
}

####################
# Utility Functions
####################
valid.origin <- function(origin) {
  origin <- as.integer(match(origin,
                             c("bottom.left", "top.left",
                               "bottom.right", "top.right")) - 1)
  if (any(is.na(origin)))
    stop("Invalid origin")
  origin
}

origin.left <- function(origin) {
  switch (origin,
          bottom.left = TRUE,
          bottom.right = FALSE,
          top.left = TRUE,
          top.right = FALSE)
}

origin.right <- function(origin) {
  switch (origin,
          bottom.left = FALSE,
          bottom.right = TRUE,
          top.left = FALSE,
          top.right = TRUE)
}

origin.bottom <- function(origin) {
  switch (origin,
          bottom.left = TRUE,
          bottom.right = TRUE,
          top.left = FALSE,
          top.right = FALSE)
}

origin.top <- function(origin) {
  switch (origin,
          bottom.left = FALSE,
          bottom.right = FALSE,
          top.left = TRUE,
          top.right = TRUE)
}
  
swap.origin.horizontal <- function(origin) {
  switch (origin,
          bottom.left = "bottom.right",
          bottom.right = "bottom.left",
          top.left = "top.right",
          top.right = "top.left")
}

swap.origin.vertical <- function(origin) {
  switch (origin,
          bottom.left = "top.left",
          bottom.right = "top.right",
          top.left = "bottom.left",
          top.right = "bottom.right")
}
######################################
# move-to and line-to primitives
######################################
draw.details.move.to <- function(l, grob, recording=TRUE) {
  grid.Call.graphics("L_moveTo", l$x, l$y)
}

grid.move.to <- function(x=0, y=0,
                         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)
  # Make sure that x and y are of length 1
  if (unit.length(x) > 1 | unit.length(y) > 1)
    stop("x and y must have length 1")
  grid.grob(list(x=x, y=y, vp=vp), "move.to", draw)
}

draw.details.line.to <- function(l, grob, recording=TRUE) {
  grid.Call.graphics("L_lineTo", l$x, l$y)
}

grid.line.to <- function(x=1, y=1,
                         default.units="npc",
                         draw=TRUE, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  # Make sure that x and y are of length 1
  if (unit.length(x) > 1 | unit.length(y) > 1)
    stop("x and y must have length 1")
  grid.grob(list(x=x, y=y, gp=gp, vp=vp), "line.to", draw)
}

######################################
# LINES primitive
######################################
draw.details.lines <- function(l, grob, recording=TRUE) {
  grid.Call.graphics("L_lines", l$x, 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),
                   default.units="npc", units.per.obs=FALSE,
                   gp=gpar(), 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) {
  grid.Call.graphics("L_segments", s$x0, s$y0, s$x1, s$y1)
}

# 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"),
                      default.units="npc", units.per.obs=FALSE,
                      gp=gpar(), 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)
}

######################################
# POLYGON primitive
######################################

draw.details.polygon <- function(p, 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 :)
  grid.Call.graphics("L_polygon", p$x, p$y)
}

grid.polygon <- function(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                         default.units="npc", 
                         gp=gpar(),draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  p <- list(x=x, y=y, gp=gp, vp=vp)
  cl <- "polygon"
  grid.grob(p, cl, draw)
}

######################################
# CIRCLE primitive
######################################

draw.details.circle <- function(c, 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 :)
  grid.Call.graphics("L_circle", c$x, c$y, c$r)
}

grid.circle <- function(x=0.5, y=0.5, r=0.5,
                         default.units="npc", 
                         gp=gpar(),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(r))
    r <- unit(r, default.units)
  c <- list(x=x, y=y, r=r, gp=gp, vp=vp)
  cl <- "circle"
  grid.grob(c, 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 :)
  grid.Call.graphics("L_rect", r$x, r$y, r$width, r$height,
                 valid.just(r$just, 2))
}

width.details.rect <- function(r) {
  absolute.size(r$width)
}

height.details.rect <- function(r) {
  absolute.size(r$height)
}

grid.rect <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                      width=unit(1, "npc"), height=unit(1, "npc"),
                      just="centre", default.units="npc", 
                      gp=gpar(),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"
  grid.Call.graphics("L_text", txt$label, txt$x, txt$y, 
                 valid.just(txt$just, 2), txt$rot, txt$check.overlap)
}

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

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

grid.text <- function(label, x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                  just="centre", rot=0, check.overlap=FALSE,
                  default.units="npc", gp=gpar(), 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=as.character(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) {
  grid.Call.graphics("L_points", p$x, p$y, p$pch, p$size)
}

valid.pch <- function(pch) {
  if (!is.character(pch))
    pch <- as.integer(pch)
  pch
}

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

# These functions are used to evaluate "grobwidth" and
# "grobheight" units.
# They are actually called from within the C code
# (specifically, from within unit.c) and should NOT be called
# from the command line in normal use.
# The width.pre function sets up the correct graphical context (
# gpar settings) for the grob.  The basic idea is that the width
# of a grob has to be evaluated within the same context as would
# be used to draw the grob.  For simple grobs, there should be
# nothing to do beyond the default given here.

# NOTE that we do NOT push any viewports.  That would probably create
# an infinite loop (because push.viewport would call set.viewport
# which would attempt to recalculate the entire viewport transform,
# which may get back to here if we originally got here due to
# calculating a viewport transform;  i.e., if we started with a
# viewport or layout that was using "grobwidth" or "grobheight" units)

# NOTE that the above note implies that we should NOT return a unit
# in the width.details method that relies on having the correct
# viewport set up.  In other words we should only return "absolute"
# units;  there is a function at the end of this file to help with this.

# For complex grobs, e.g., ones which
# construct their own viewports, it may be necessary to do extra
# setting up by writing a width.pre.details method.
# The width function just returns a unit object.
# The width.post function is important for reversing all of the
# setting up that was done in the width.pre function.  Again, for
# simple grobs there should be nothing to do beyond the default.

#########
# WIDTHS
#########

# NOTE that I have to do this in R rather than C code because
# I can't set par() values from C (yet !)
# ALSO NOTE that I have to set par() values for "strwidth" and 
# "strheight" units to work;  they rely on GStrWidth/Height which
# refer to par() values
# We are just setting graphical parameters
# We do NOT push any viewports !!
width.pre <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    set.gpar(gp)
  if (!is.null(list.struct$vp))
    width.pre.details(list.struct$vp)
  else
    width.pre.details(list.struct)
}

width.pre.details <- function(x) {
  UseMethod("width.pre.details")
}

width.pre.details.default <- function(x) {}

width <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    width.details(list.struct$vp)
  else
    width.details(list.struct)
}

width.details <- function(x) {
  UseMethod("width.details", x)
}

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

# We are just unsetting graphical parameters
# We do NOT pop any viewports !!
width.post <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    width.post.details(list.struct$vp)
  else
    width.post.details(list.struct)
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    unset.gpar(gp)
}

width.post.details <- function(x) {
  UseMethod("width.post.details")
}

width.post.details.default <- function(x) {}

#########
# HEIGHTS
#########

# We are just setting graphical parameters
# We do NOT push any viewports !!
height.pre <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    set.gpar(gp)
  if (!is.null(list.struct$vp))
    height.pre.details(list.struct$vp)
  else
    height.pre.details(list.struct)
}

height.pre.details <- function(x) {
  UseMethod("height.pre.details")
}

height.pre.details.default <- function(x) {}

height <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    height.details(list.struct$vp)
  else
    height.details(list.struct)
}

height.details <- function(x) {
  UseMethod("height.details", x)
}

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

# We are just unsetting graphical parameters
# We do NOT pop any viewports !!
height.post <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    height.post.details(list.struct$vp)
  else
    height.post.details(list.struct)
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    unset.gpar(gp)
}

height.post.details <- function(x) {
  UseMethod("height.post.details")
}

height.post.details.default <- function(x) {}

#########
# Some functions that might be useful for determining the sizes
# of your grobs
#########

# Dimensions which depend on the parent context EITHER don't make
# sense (e.g., no good to have the parent width depend on the child's
# width unit(1, "grobwidth", <child>), which depends on the parent's
# width unit(.1, "npc"), ...) OR are slightly ambiguous
# (e.g., gf <- grid.frame(); grid.pack(gf, grid.rect(width=unit(.1, "npc")))
# makes the area allocated to the rectangle .1 of the frame area, but
# then the rectangle only occupies .1 of _that_ allocated area;  my head
# hurts !).  The first sort will actually lead to infinite loops so
# I outlaw them;  the second sort I just don't want to have to deal with.
#
# On the other hand, dimensions which do not depend on the parent context
# are much easier to deal with (e.g., "inches", "cm", "lines", ...)
#
# So this function takes a unit and returns absolute values
# untouched and replaces other values with unit(1, "null")
#
# NOTE that I included "lines" amongst the absolute units above, even
# though these depend on the parent context in the sense that the
# parent may specify a value for lineheight or fontsize.
# This is ok because these are "absolute" graphical parameters that do not
# themselves depend on the parent's size (by contrast, "npc" units
# and "native" units depend on the parent's size).

absolute.size <- function(unit) {
  absolute.units(unit)
}


recycle.data <- function(data, data.per, max.n) {
  # VERY IMPORTANT:  Even if there is only one data specified
  # and/or only one data needed, we want this to be a LIST of
  # data values so that a single data and several data can be
  # handled equivalently
  # The test for whether it is only a single value currently
  # consists of a check for mode="character" (i.e., a single
  # string) or class="grob" (i.e., a single grob)
  if (is.character(data) || is.grob(data)) 
    data <- list(data)
  if (data.per)
    n <- max.n
  else
    n <- length(data)
  original <- data
  index <- 1
  while (length(data) < n) {
    data <- c(data, list(original[[(index - 1) %% length(original) + 1]]))
    index <- index + 1
  }
  data
}

# Create an object of class "unit"
# Simple units are of the form `unit(1, "cm")' or `unit(1:3, "cm")' or
# `unit(c(1,3,6), c("cm", "inch", "npc"))'
# More complicated units are of the form `unit(1, "string", "a string")'
# or `unit(1, "grob", a.grob)'
unit <- function(x, units, data=NULL) {
  if (!is.numeric(x))
    stop("x must be numeric")
  valid.unit(x, units, recycle.data(data, FALSE, length(x)))
}

valid.unit <- function(x, units, data) {
  valid.units <- valid.units(units)
  data <- valid.data(rep(units, length.out=length(x)), data)
  attr(x, "unit") <- units
  attr(x, "valid.unit") <- valid.units
  attr(x, "data") <- data
  class(x) <- "unit"
  x
}

convertNative <- function(unit, dimension="x", type="location") {
  what <- match(dimension, c("x", "y")) - 1 +
    2*(match(type, c("location", "dimension")) - 1)
  if (is.na(what))
    stop("Invalid dimension or type")
  grid.Call("L_convertToNative", unit, as.integer(what))
}

# NOTE: the order of the strings in these conversion functions must
# match the order of the enums in ../src/grid.h
.grid.unit.list <- c("npc", "cm", "inches", "lines",
                     "native", "null", "snpc", "mm",
                     "points", "picas", "bigpts",
                     "dida", "cicero", "scaledpts",
                     "strwidth", "strheight",
                     "vplayoutwidth", "vplayoutheight", "char",
                     "grobwidth", "grobheight",
                     "mylines", "mychar", "mystrwidth", "mystrheight")

# Make sure that and "str*" and "grob*" units have data
valid.data <- function(units, data) {
  n <- length(units)
  str.units <- units == "strwidth"
  if (any(str.units != 0))
    for (i in (1:n)[str.units])
      if (!(length(data) >= i && is.character(data[[i]])))
        stop("No string supplied for `strwidth' unit")
  str.units <- units == "strheight"
  if (any(str.units != 0))
    for (i in (1:n)[str.units])
      if (!(length(data) >= i && is.character(data[[i]])))
        stop("No string supplied for `strheight' unit")
  # Make sure that a grob has been specified
  grob.units <- units == "grobwidth"
  if (any(grob.units != 0))
    for (i in (1:n)[grob.units]) {
      if (!(length(data) >= i && is.grob(data[[i]])))
        stop("No grob supplied for `grobwidth' unit")
    }
  grob.units <- units == "grobheight"
  if (any(grob.units != 0))
    for (i in (1:n)[grob.units]) {
      if (!(length(data) >= i && is.grob(data[[i]])))
        stop("No grob supplied for `grobheight' unit")
    }
  data
}

valid.units <- function(units) {
  .Call("validUnits", units)
}

as.character.unit <- function(unit) {
  class(unit) <- NULL
  paste(unit, attr(unit, "unit"), sep="")
}

#########################
# UNIT ARITHMETIC STUFF
#########################

unit.arithmetic <- function(func.name, arg1, arg2=NULL) {
  ua <- list(fname=func.name, arg1=arg1, arg2=arg2)
  class(ua) <- c("unit.arithmetic", "unit")
  ua
}

Ops.unit <- function(x, y) {
  ok <- switch(.Generic, "+"=TRUE, "-"=TRUE, "*"=TRUE, FALSE)
  if (!ok)
    stop(paste("Operator", .Generic, "not meaningful for units"))
  if (.Generic=="*")
    # can only multiply a unit by a scalar
    if (nchar(.Method[1])) {
      if (nchar(.Method[2]))
        stop("Only one operand may be a unit")
      else if (is.numeric(y))
        # NOTE that we always put the scalar first
        unit.arithmetic(.Generic, y, x)
      else
        stop("Non-unit operand must be numeric")
    } else {
      if (is.numeric(x))
        unit.arithmetic(.Generic, x, y)
      else
        stop("Non-unit operand must be numeric")
    }
  else
    # Check that both arguments are units
    if (nchar(.Method[1]) && nchar(.Method[2]))
      unit.arithmetic(.Generic, x, y)
    else
      stop("Both operands must be units") 
}    

Summary.unit <- function(..., na.rm=FALSE) {
  # NOTE that this call to unit.c makes sure that arg1 is
  # a single unit object 
  x <- unit.c(...)
  ok <- switch(.Generic, "max"=TRUE, "min"=TRUE, "sum"=TRUE, FALSE)
  if (!ok)
    stop(paste("Summary function", .Generic, "not meaningful for units"))
  unit.arithmetic(.Generic, x)
}

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

as.character.unit.arithmetic <- function(ua) {
  # bit too customised for my liking, but whatever ...
  # NOTE that paste coerces arguments to mode character hence
  # this will recurse.
  fname <- ua$fname
  if (fname == "+" || fname == "-" || fname == "*")
    paste(ua$arg1, fname, ua$arg2, sep="")
  else
    paste(fname, "(", paste(ua$arg1, collapse=", "), ")", sep="")
}

unit.pmax <- function(...) {

  select.i <- function(unit, i) {
    "["(unit, i, top=FALSE)
  }

  x <- list(...)
  numargs <- length(x)
  if (numargs == 0)
    stop("Zero arguments where at least one expected")
  # how long will the result be?
  maxlength <- 0
  for (i in 1:numargs)
    if (unit.length(x[[i]]) > maxlength)
      maxlength <- unit.length(x[[i]])
  # maxlength guaranteed >= 1
  result <- max(unit.list.from.list(lapply(x, select.i, 1)))
  for (i in 2:maxlength)
    result <- unit.c(result, max(unit.list.from.list(lapply(x, select.i, i))))
  result
}

unit.pmin <- function(...) {

  select.i <- function(unit, i) {
    "["(unit, i, top=FALSE)
  }

  x <- list(...)
  numargs <- length(x)
  if (numargs == 0)
    stop("Zero arguments where at least one expected")
  # how long will the result be?
  maxlength <- 0
  for (i in 1:numargs)
    if (unit.length(x[[i]]) > maxlength)
      maxlength <- unit.length(x[[i]])
  # maxlength guaranteed >= 1
  result <- min(unit.list.from.list(lapply(x, select.i, 1)))
  for (i in 2:maxlength)
    result <- unit.c(result, min(unit.list.from.list(lapply(x, select.i, i))))
  result  
}

#########################
# UNIT LISTS
# The idea with these is to allow arbitrary combinations
# of unit objects and unit arithmetic objects
#########################

# create a unit list from a unit, unit.arithmetic, or unit.list object
unit.list <- function(unit) {
  if (is.unit.list(unit))
    unit
  else {
    l <- unit.length(unit)
    result <- list() 
    for (i in 1:l)
      result[[i]] <- unit[i]
    class(result) <- c("unit.list", "unit")
    result
  }
}

is.unit.list <- function(x) {
  inherits(x, "unit.list")
}
  
as.character.unit.list <- function(ul) {
  l <- unit.length(ul)
  result <- rep("", l)
  for (i in 1:unit.length(ul))
    result[i] <- as.character(ul[[i]])
  result
}

#########################
# These work on any sort of unit object
#########################

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

print.unit <- function(x, ...) {
  print(as.character(x), quote=FALSE)
}

#########################
# Unit subsetting
#########################

# The idea of the "top" argument is to allow the function to
# know if it has been called from the command-line or from
# a previous (recursive) call to "[.unit" or "[.unit.arithmetic"
# this allows recycling beyond the end of the unit object
# except at the top level

# NOTE that "unit" and "data" attributes will be recycled
"[.unit" <- function(x, index, top=TRUE, ...) {
  this.length <- length(x)
  if (top && index > this.length)
    stop("Index out of bounds (unit subsetting)")
  cl <- class(x);
  units <- attr(x, "unit")
  valid.units <- attr(x, "valid.unit")
  data <- attr(x, "data")
  class(x) <- NULL;
  # The line below may seem slightly odd, but it should only be
  # used to recycle values when this method is called to
  # subset an argument in a unit.arithmetic object
  x <- x[(index - 1) %% this.length + 1]
  attr(x, "unit") <- units[(index - 1) %% length(units) + 1]
  attr(x, "valid.unit") <- valid.units[(index - 1) %% length(valid.units) + 1]
  data.list <- data[(index - 1) %% length(data) + 1]
  attr(x, "data") <- data.list
  class(x) <- cl
  x
}

# NOTE that units will be recycled to the length of the largest
# of the arguments
"[.unit.arithmetic" <- function(x, index, top=TRUE, ...) {
  this.length <- unit.arithmetic.length(x)
  if (top && index > this.length)
    stop("Index out of bounds (unit arithmetic subsetting)")
  switch(x$fname,
         "+"="["(x$arg1, (index - 1) %% this.length + 1, top=FALSE) +
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         "-"="["(x$arg1, (index - 1) %% this.length + 1, top=FALSE) -
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         "*"=x$arg1 *
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         "min"=x,
         "max"=x,
         "sum"=x)
}

"[.unit.list" <- function(x, index, top=TRUE, ...) {
  this.length <- unit.list.length(x)
  if (top && index > this.length)
    stop("Index out of bounds (unit list subsetting)")
  cl <- class(x)
  result <- unclass(x)[(index - 1) %% this.length + 1]
  class(result) <- cl
  result
}

# Write "[<-.unit" methods too ?? 

#########################
# "c"ombining unit objects
#########################

# NOTE that I have not written methods for c()
# because method dispatch occurs on the first argument to
# "c" so c(unit(...), ...) would come here, but c(whatever, unit(...), ...)
# would go who-knows-where.
# A particularly nasty example is:  c(1, unit(1, "npc")) which will
# produce the same result as c(1, 1)
# Same problem for trying to control c(<unit>, <unit.arithmetic>)
# versus c(<unit.arithmetic>, <unit>), etc ...

# If any arguments are unit.arithmetic or unit.list, then the result will be
# unit.list
unit.c <- function(...) {
  x <- list(...)
  ual <- FALSE
  for (i in 1:length(x))
    if (inherits(x[[i]], "unit.list") ||
        inherits(x[[i]], "unit.arithmetic"))
      ual <- TRUE
  if (ual)
    unit.list.from.list(x)
  else {
    values <- NULL
    units <- NULL
    data <- NULL
    for (i in 1:length(x))
      if (is.unit(x[[i]])) {
        values <- c(values, x[[i]])
        units <- c(units, rep(attr(x[[i]], "unit"), length.out=length(x[[i]])))
        data <- c(data, recycle.data(attr(x[[i]], "data"), TRUE,
                                     length(x[[i]])))
      }
      else 
        stop("It is invalid to combine unit objects with other types")
    unit(values, units, data=data)
  }
}

unit.list.from.list <- function(x) {
  if (length(x) == 1)
    unit.list(x[[1]])
  else {
    result <- c(unit.list(x[[1]]), unit.list.from.list(x[2:length(x)]))
    class(result) <- c("unit.list", "unit")
    result
  }
}

# OLD unit.list.from.list <-
function(x) {
  result <- unit.list(x[[1]])
  i <- 2
  while (i < length(x) + 1) {
    result <- c(result, unit.list(x[[i]]))
    i <- i + 1
  }
  class(result) <- c("unit.list", "unit")
  result 
}

#########################
# rep'ing unit objects
#########################

# NOTE that rep() is not a generic -- it does have different "methods"
# for some different data types, but this is ALL handled internally
# in seq.c

unit.arithmetic.rep <- function(x, times) {
  switch(x$fname,
         "+"=unit.rep(x$arg1, times) + unit.rep(x$arg2, times),
         "-"=unit.rep(x$arg1, times) - unit.rep(x$arg2, times),
         "*"=x$arg1 * unit.rep(x$arg2, times),
         "min"=unit.list.rep(unit.list(x), times),
         "max"=unit.list.rep(unit.list(x), times),
         "sum"=unit.list.rep(unit.list(x), times))
}

unit.list.rep <- function(x, times) {
  # Make use of the subsetting code to replicate the unit list
  # top=FALSE allows the subsetting to go beyond the original length
  "["(x, 1:(unit.length(x)*times), top=FALSE)
}

unit.rep <- function (x, times, length.out) 
{
  if (unit.length(x) == 0) 
    return(x)
  if (missing(times)) 
    times <- ceiling(length.out/length(x))
  
  if (is.unit.list(x))
    unit <- unit.list.rep(x, times)
  else if (is.unit.arithmetic(x))
    unit <- unit.arithmetic.rep(x, times)
  else {
    values <- rep(x, times)
    # Do I need to replicate the "unit"s?
    unit <- attr(x, "unit")
    # If there are any data then they must be explicitly replicated
    # because the list of data must be the same length as the
    # vector of values
    data <- recycle.data(attr(x, "data"), TRUE, length(values))
    unit <- unit(values, unit, data=data)
  }
  if (!missing(length.out)) 
    return(unit[if (length.out > 0) 1:length.out else integer(0)])
  unit
}

#########################
# Length of unit objects
#########################

unit.list.length <- function(ul) {
  length(ul)
}

# unit.length is designed to call this when appropriate
# so that this need never be called by the user
unit.arithmetic.length <- function(ua) {
  switch(ua$fname,
         "+"=max(unit.length(ua$arg1), unit.length(ua$arg2)),
         "-"=max(unit.length(ua$arg1), unit.length(ua$arg2)),
         "*"=max(length(ua$arg1), unit.length(ua$arg2)),
         "min"=1,
         "max"=1,
         "sum"=1)
}

# FIXME: I am doing my own dispatching here;  should be generic function
unit.length <- function(unit) {
  if (is.unit.list(unit))
    unit.list.length(unit)
  else if (is.unit.arithmetic(unit))
    unit.arithmetic.length(unit)
  else
    length(unit)
}

#########################
# Function to decide which values in a unit are "absolute" (do not depend
# on parent's drawing context or size)
#########################

# Only deals with unit of unit.length() 1
absolute <- function(unit) {
  !is.na(match(attr(unit, "unit"),
               c("cm", "inches", "lines", "null",
                 "mm", "points", "picas", "bigpts",
                 "dida", "cicero", "scaledpts",
                 "strwidth", "strheight", "char",
                 "mylines", "mychar", "mystrwidth", "mystrheight")))
}

absolute.units.list <- function(ul) {
  cl <- class(ul)
  abs.ul <- lapply(ul, absolute.units)
  class(abs.ul) <- cl
  abs.ul
}
                                  
absolute.units.arithmetic <- function(ua) {
  switch(ua$fname,
         "+"=unit.arithmetic("+", absolute.units(ua$arg1),
           absolute.units(ua$arg2)),
         "-"=unit.arithmetic("-", absolute.units(ua$arg1),
           absolute.units(ua$arg2)),
         "*"=unit.arithmetic("*", ua$arg1, absolute.units(ua$arg2)),
         "min"=unit.arithmetic("min", absolute.units(ua$arg1)),
         "max"=unit.arithmetic("max", absolute.units(ua$arg1)),
         "sum"=unit.arithmetic("sum", absolute.units(ua$arg1)))
}

absolute.units <- function(unit) {
  if (is.unit.list(unit))
    absolute.units.list(unit)
  else if (is.unit.arithmetic(unit))
    absolute.units.arithmetic(unit)
  else {
    n <- unit.length(unit)
    if (absolute(unit[1]))
      abs.unit <- unit[1]
    else
      abs.unit <- unit(1, "null")
    if (n == 1)
      new.unit <- abs.unit
    else
      new.unit <- unit.c(abs.unit, absolute.units(unit[2:n]))
    new.unit
  }
}
                 

is.odd <- function(x) {
  x %% 2
}

is.even <- function(x) {
  !is.odd(x)
}

grid.pretty <- function(range) {
  if (!is.numeric(range))
    stop("range must be numeric")
  .Call("L_pretty", range)
}


valid.viewport <- function(x, y, width, height, just, origin,
                           gp, clip,
                           xscale, yscale, angle,
                           layout, layout.pos.row, layout.pos.col) {
  if (unit.length(x) > 1 || unit.length(y) > 1 ||
      unit.length(width) > 1 || unit.length(height) > 1)
    stop("`x', `y', `width', and `height' must all be units of length 1")
  if (!is.gpar(gp))
    stop("Invalid graphics parameters")
  clip <- as.logical(clip)
  if (!is.numeric(xscale) || length(xscale) != 2)
    stop("Invalid xscale in viewport")
  if (!is.numeric(yscale) || length(yscale) != 2)
    stop("Invalid yscale in viewport")
  if (!is.numeric(angle) || length(angle) != 1)
    stop("Invalid angle in viewport")
  if (!is.null(layout.pos.row))
    layout.pos.row <- as.integer(rep(range(layout.pos.row), length.out=2))
  if (!is.null(layout.pos.col))
    layout.pos.col <- as.integer(rep(range(layout.pos.col), length.out=2))
  # Put all the valid things first so that are found quicker
  vp <- list(x = x, y = y, width = width, height = height,
             valid.just = valid.just(just, 2),
             valid.origin = valid.origin(origin),
             layout = layout,
             valid.pos.row = layout.pos.row,
             valid.pos.col = layout.pos.col,
             gp = gp,
             clip = clip,
             # A viewport may have a specification of fontsize
             # and lineheight in the gpar, BUT it does not have to
             # If it does not, then that means it will just use
             # whatever is the "current" setting of fontsize
             # and lineheight.
             # "current" means at drawing time, which means when
             # L_setviewport is called.
             # We record here the "current" value so that we can
             # reset the value when a child viewport is popped.
             # Ditto font.
             cur.font = NULL,
             cur.fontsize = NULL,
             cur.lineheight = NULL,
             # When L_setviewport is called, we also record
             # the transformation and layout for the viewport
             # so that we don't have to recalculate it every
             # time (until the device changes size)
             cur.trans = NULL,
             cur.widths = NULL,
             cur.heights = NULL,
             cur.width.cm = NULL,
             cur.height.cm = NULL,
             cur.rotation = NULL,
             cur.clip = NULL,
             xscale = xscale,
             yscale = yscale,
             angle = angle,
             parent = NULL,
             justification = just,
             origin = origin,
             layout.pos.row = layout.pos.row,
             layout.pos.col = layout.pos.col)
  class(vp) <- "viewport"
  vp
}

print.viewport <- function(x, ...) {
  print(class(x))
}

width.details.viewport <- function(vp) {
  absolute.size(vp$width)
}

height.details.viewport <- function(vp) {
  absolute.size(vp$height)
}

####################
# Accessors
####################

viewport.layout <- function(vp) {
  vp$layout
}

####################
# Public Constructor
####################
viewport <- function(x = unit(0.5, "npc"),
                     y = unit(0.5, "npc"),
                     width = unit(1, "npc"),
                     height = unit(1, "npc"),
                     default.units = "npc",
                     just = "centre",
                     origin = "bottom.left",
                     gp = gpar(),
                     clip = FALSE,
                     # FIXME: scales are only linear at the moment 
                     xscale = c(0, 1),
                     yscale = c(0, 1),
                     angle = 0,
                     # Layout for arranging children of this viewport
                     layout = NULL,
                     # Position of this viewport in parent's layout
                     layout.pos.row = NULL,
                     layout.pos.col = 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)
  valid.viewport(x, y, width, height, just, origin,
                 gp, clip, xscale, yscale, angle,
                 layout, layout.pos.row, layout.pos.col)
}

is.viewport <- function(vp) {
  inherits(vp, "viewport")
}

#############
# Some handy viewport functions
#############

# Create a viewport with margins given in number of lines
plotViewport <- function(margins, ...) {
  margins <- rep(as.numeric(margins), length.out=4)
  viewport(x=unit(margins[2], "lines"),
           width=unit(1, "npc") - unit(sum(margins[c(2,4)]), "lines"),
           y=unit(margins[1], "lines"),
           height=unit(1, "npc") - unit(sum(margins[c(1,3)]), "lines"),
           just=c("left", "bottom"),
           ...)
}

# Create a viewport from data
# If xscale not specified then determine from x
# If yscale not specified then determine from y
dataViewport <- function(x=NULL, y=NULL, xscale=NULL, yscale=NULL,
                          extension=0.05, ...) {
  if (missing(xscale)) {
    if (missing(x))
      stop("Must specify at least one of x or xscale")
    xscale <- range(x) + c(-1, 1)*diff(range(y))*extension
  }
  if (missing(yscale)) {
    if (missing(y))
      stop("Must specify at least one of y or yscale")
    yscale <- range(y) + c(-1, 1)*diff(range(y))*extension
  }
  viewport(xscale=xscale, yscale=yscale, ...)
}

.First.lib <- function(lib, pkg) {
  library.dynam( "grid", pkg, lib )
  .Call("L_initGrid")
  .grid.loaded <<- TRUE
}

.Last.lib <-function(libpath) {
  if (.grid.loaded) {
    # Kill all existing devices to avoid replay
    # of display list which tries to run grid code
    # Not very friendly to other registered graphics systems
    # but its safety first for now
    graphics.off()
    .Call("L_killGrid")
  }
}

