
# Functions to create an SVG graphics device object, complete with
# "methods" for performing all necessary graphical operations

# This is designed to foreshadow the time when graphics devices
# in R (or at least in grid) are R objects and graphics functions
# include the device as an argument (i.e., no longer have
# the notion of graphics always going to the "current device")

# This will not be called in this way yet (instead, I will just
# be running down the grid display list and calling appropriate
# methods from that, BUT I thought it was worth designing for the
# future anyway.

# In another forward-looking move, I will create the device class
# and methods for it using S4 methods

#################
# Utility functions
#################

devParNameToSVGStyleName <- function(name) {
  switch(name,
         col="stroke",
         fill="fill",
         # Ignore changes in font (!!)
         font="fontplaceholder",
         fontsize="font-size",
         alpha="opacity",
         lty="stroke-dasharray",
         lwd="stroke-width",
         NA)
}

# An R lty has to become an SVG strok-dasharray
# This is going to be imperfect (to say the least)
devLtyToSVG <- function(lty) {
  switch(lty,
         solid="none",
         dashed="5,5",
         "none")
}

devParToSVGPar <- function(name, par) {
  if (is.null(par))
    "none"
  else if (is.na(par))
    "none"
  else
    switch(name,
           lty=devLtyToSVG(par),
           # By default just pass through the actual value
           par)
}

devParToSVGStyle <- function(gp) {
  if (is.null(gp))
    result <- svgStyle()
  else {
    result <- list()
    for (i in names(gp))
      if (!is.na(devParNameToSVGStyleName(i)))
        result[[devParNameToSVGStyleName(i)]] <- devParToSVGPar(i, gp[[i]])
  }
  result
}

#################
# SVG Device Stuff
#################

setClass("svgDevice",
         representation("graphicsDevice",
                        # Object created by svgDevice() in svg.R
                        # has no S4 class yet
                        dev="ANY"))

setMethod("inchToDevX", signature(device="svgDevice"),
          function(x, device) {
            x * 72
          })
          
setMethod("inchToDevY", signature(device="svgDevice"),
          function(x, device) {
            x * 72
          })
          
setMethod("devLines", signature(device="svgDevice"),
          function(lines, gp, device) {
            svgLines(lines$x, lines$y, lines$name,
                     listToSVGAttrib(lines$attributes),
                     devParToSVGStyle(gp), device@dev)
          })

setMethod("devPolygon", signature(device="svgDevice"),
          function(polygon, gp, device) {
            svgPolygon(polygon$x, polygon$y, polygon$name,
                       listToSVGAttrib(polygon$attributes),
                       devParToSVGStyle(gp), device@dev)
          })

setMethod("devRect", signature(device="svgDevice"),
          function(rect, gp, device) {
            svgRect(rect$x, rect$y, rect$width, rect$height, rect$name,
                    listToSVGAttrib(rect$attributes),
                    devParToSVGStyle(gp), device@dev)
          })

setMethod("devText", signature(device="svgDevice"),
          function(text, gp, device) {
            # Draw SVG text with no border and fill = col
            if (is.null(gp$col))
              gp$fill <- "black"
            else
              gp$fill <- gp$col
            gp$col <- NA
            svgText(text$x, text$y, text$text,
                    text$hjust, text$vjust, text$rot,
                    text$name,
                    listToSVGAttrib(text$attributes),
                    devParToSVGStyle(gp), device@dev)
          })

setMethod("devCircle", signature(device="svgDevice"),
          function(circle, gp, device) {
            svgCircle(circle$x, circle$y, circle$r, circle$name,
                      listToSVGAttrib(circle$attributes),
                      devParToSVGStyle(gp), device@dev)
          })

setMethod("devStartGroup", signature(device="svgDevice"),
          function(group, gp, device) {
            svgStartGroup(group$name,
                          listToSVGAttrib(group$attributes),
                          devParToSVGStyle(gp), device@dev)
          })

setMethod("devEndGroup", signature(device="svgDevice"),
          function(device) {
            svgEndGroup(device@dev)
          })

setMethod("devClose", signature(device="svgDevice"),
          function(device) {
            svgClose(device@dev)
          })

#################
# User Functions
#################

openSVGDev <- function(name="Rplots.svg", width=6, height=6) {
  new("svgDevice",
      name=name, width=width, height=height,
      dev=svgOpen(name,
        par("cra")[1]/par("cin")[1]*width,
        par("cra")[2]/par("cin")[2]*height))
}
                   


