#   IGraph R package
#   Copyright (C) 2003-2012  Gabor Csardi <csardi.gabor@gmail.com>
#   334 Harvard street, Cambridge, MA 02139 USA

#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program; if not, write to the Free Software
#   Foundation, Inc.,  51 Franklin Street, Fifth Floor, Boston, MA
#   02110-1301 USA
#
###################################################################



#' Plotting of graphs
#' 
#' \code{plot.igraph} is able to plot graphs to any R device. It is the
#' non-interactive companion of the \code{tkplot} function.
#' 
#' One convenient way to plot graphs is to plot with \code{\link{tkplot}}
#' first, handtune the placement of the vertices, query the coordinates by the
#' \code{\link{tk_coords}} function and use them with \code{plot} to
#' plot the graph to any R device.
#'
#' @aliases plot.graph
#' @param x The graph to plot.
#' @param axes Logical, whether to plot axes, defaults to FALSE.
#' @param add Logical scalar, whether to add the plot to the current device, or
#' delete the device's current contents first.
#' @param xlim The limits for the horizontal axis, it is unlikely that you want
#' to modify this.
#' @param ylim The limits for the vertical axis, it is unlikely that you want
#' to modify this.
#' @param mark.groups A list of vertex id vectors. It is interpreted as a set
#' of vertex groups. Each vertex group is highlighted, by plotting a colored
#' smoothed polygon around and \dQuote{under} it. See the arguments below to
#' control the look of the polygons.
#' @param mark.shape A numeric scalar or vector. Controls the smoothness of the
#' vertex group marking polygons. This is basically the \sQuote{shape}
#' parameter of the \code{\link[graphics]{xspline}} function, its possible
#' values are between -1 and 1. If it is a vector, then a different value is
#' used for the different vertex groups.
#' @param mark.col A scalar or vector giving the colors of marking the
#' polygons, in any format accepted by \code{\link[graphics]{xspline}}; e.g.
#' numeric color ids, symbolic color names, or colors in RGB.
#' @param mark.border A scalar or vector giving the colors of the borders of
#' the vertex group marking polygons. If it is \code{NA}, then no border is
#' drawn.
#' @param mark.expand A numeric scalar or vector, the size of the border around
#' the marked vertex groups. It is in the same units as the vertex sizes. If a
#' vector is given, then different values are used for the different vertex
#' groups.
#' @param \dots Additional plotting parameters. See \link{igraph.plotting} for
#' the complete list.
#' @return Returns \code{NULL}, invisibly.
#' @author Gabor Csardi \email{csardi.gabor@@gmail.com}
#' @seealso \code{\link{layout}} for different layouts,
#' \code{\link{igraph.plotting}} for the detailed description of the plotting
#' parameters and \code{\link{tkplot}} and \code{\link{rglplot}} for other
#' graph plotting functions.
#' @method plot igraph
#' @export
#' @export plot.igraph
#' @importFrom grDevices rainbow
#' @importFrom graphics plot polygon text par
#' @keywords graphs
#' @examples
#' 
#' g <- make_ring(10)
#' plot(g, layout=layout_with_kk, vertex.color="green")
#' 
plot.igraph <- function(x, 
                       # SPECIFIC: #####################################
                       axes=FALSE, add=FALSE,
                       xlim=c(-1,1), ylim=c(-1,1),
                       mark.groups=list(), mark.shape=1/2,
                       mark.col=rainbow(length(mark.groups), alpha=0.3),
                       mark.border=rainbow(length(mark.groups), alpha=1),
                       mark.expand=15,
                       ...) {

  graph <- x
  if (!is_igraph(graph)) {
    stop("Not a graph object")
  }

  ################################################################
  ## Visual parameters
  params <- i.parse.plot.params(graph, list(...))
  vertex.size        <- 1/200 * params("vertex", "size")
  label.family       <- params("vertex", "label.family")
  label.font         <- params("vertex", "label.font")
  label.cex          <- params("vertex", "label.cex")
  label.degree       <- params("vertex", "label.degree")
  label.color        <- params("vertex", "label.color")
  label.dist         <- params("vertex", "label.dist")
  labels             <- params("vertex", "label")
  shape              <- igraph.check.shapes(params("vertex", "shape"))

  edge.color         <- params("edge", "color")
  edge.width         <- params("edge", "width")
  edge.lty           <- params("edge", "lty")
  arrow.mode         <- params("edge", "arrow.mode")
  edge.labels        <- params("edge", "label")
  loop.angle         <- params("edge", "loop.angle")
  edge.label.font    <- params("edge", "label.font")
  edge.label.family  <- params("edge", "label.family")
  edge.label.cex     <- params("edge", "label.cex")
  edge.label.color   <- params("edge", "label.color")
  elab.x             <- params("edge", "label.x")
  elab.y             <- params("edge", "label.y")
  arrow.size         <- params("edge", "arrow.size")[1]
  arrow.width        <- params("edge", "arrow.width")[1]
  curved             <- params("edge", "curved")
  if (is.function(curved)) { curved <- curved(graph) }
  
  layout             <- params("plot", "layout")
  margin             <- params("plot", "margin")
  margin <- rep(margin, length=4)
  rescale            <- params("plot", "rescale")
  asp                <- params("plot", "asp")
  frame              <- params("plot", "frame")
  main               <- params("plot", "main")
  sub                <- params("plot", "sub")
  xlab               <- params("plot", "xlab")
  ylab               <- params("plot", "ylab")

  palette            <- params("plot", "palette")
  if (!is.null(palette)) {
    old_palette <- palette(palette)
    on.exit(palette(old_palette), add = TRUE)
  }

  # the new style parameters can't do this yet
  arrow.mode         <- i.get.arrow.mode(graph, arrow.mode)

  ################################################################
  ## create the plot
  maxv <- max(vertex.size)
  if (rescale) {
    # norm layout to (-1, 1)
    layout <- norm_coords(layout, -1, 1, -1, 1)
    xlim <- c(xlim[1]-margin[2]-maxv, xlim[2]+margin[4]+maxv)
    ylim <- c(ylim[1]-margin[1]-maxv, ylim[2]+margin[3]+maxv)
  }
  if (!add) {
    plot(0, 0, type="n", xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim,
         axes=axes, frame=frame, asp=asp, main=main, sub=sub)
  }

  ################################################################
  ## Mark vertex groups
  if (!is.list(mark.groups) && is.numeric(mark.groups)) {
    mark.groups <- list(mark.groups)
  }

  mark.shape  <- rep(mark.shape,  length=length(mark.groups))
  mark.border <- rep(mark.border, length=length(mark.groups))
  mark.col    <- rep(mark.col,    length=length(mark.groups))
  mark.expand <- rep(mark.expand, length=length(mark.groups))
  
  for (g in seq_along(mark.groups)) {
    v <- V(graph)[mark.groups[[g]]]
    if (length(vertex.size)==1) {
      vs <- vertex.size
    } else {
      vs <- rep(vertex.size, length=vcount(graph))[v]
    }
    igraph.polygon(layout[v,,drop=FALSE],
                   vertex.size=vs,
                   expand.by=mark.expand[g]/200,
                   shape=mark.shape[g],
                   col=mark.col[g],
                   border=mark.border[g])
  }

  ################################################################
  ## calculate position of arrow-heads
  el <- as_edgelist(graph, names=FALSE)
  loops.e <- which(el[,1] == el[,2])
  nonloops.e <- which(el[,1] != el[,2])
  loops.v <- el[,1] [loops.e]
  loop.labels <- edge.labels[loops.e]
  loop.labx <- if (is.null(elab.x)) {
    rep(NA, length(loops.e))
  } else {
    elab.x[loops.e]
  }
  loop.laby <- if (is.null(elab.y)) {
    rep(NA, length(loops.e))
  } else {
    elab.y[loops.e]
  }
  edge.labels <- edge.labels[nonloops.e]
  elab.x <- if (is.null(elab.x)) NULL else elab.x[nonloops.e]
  elab.y <- if (is.null(elab.y)) NULL else elab.y[nonloops.e]
  el <- el[nonloops.e,,drop=FALSE]

  edge.coords <- matrix(0, nrow=nrow(el), ncol=4)
  edge.coords[,1] <- layout[,1][ el[,1] ]
  edge.coords[,2] <- layout[,2][ el[,1] ]
  edge.coords[,3] <- layout[,1][ el[,2] ]
  edge.coords[,4] <- layout[,2][ el[,2] ]
  if ( length(unique(shape)) == 1) {
    ## same vertex shape for all vertices
    ec <- .igraph.shapes[[ shape[1] ]]$clip(edge.coords, el,
                                            params=params, end="both")
  } else {
    ## different vertex shapes, do it by "endpoint"
    shape <- rep(shape, length=vcount(graph))
    ec <- edge.coords
    ec[,1:2] <- t(sapply(seq(length=nrow(el)), function(x) {
      .igraph.shapes[[ shape[el[x,1]] ]]$clip(edge.coords[x,,drop=FALSE],
                                              el[x,,drop=FALSE],
                                              params=params, end="from")
    }))
    ec[,3:4] <- t(sapply(seq(length=nrow(el)), function(x) {
      .igraph.shapes[[ shape[el[x,2]] ]]$clip(edge.coords[x,,drop=FALSE],
                                              el[x,,drop=FALSE],
                                              params=params, end="to")
    }))
  }
  
  x0 <- ec[,1] ; y0 <- ec[,2] ; x1 <- ec[,3] ; y1 <- ec[,4]

  ################################################################
  ## add the loop edges
  if (length(loops.e) > 0) {
    ec <- edge.color
    if (length(ec)>1) { ec <- ec[loops.e] }

    point.on.cubic.bezier <- function(cp, t) {

      c <- 3 * (cp[2,] - cp[1,])
      b <- 3 * (cp[3,] - cp[2,]) - c
      a <- cp[4,] - cp[1,] - c - b
      
      t2 <- t*t;
      t3 <- t*t*t
      
      a*t3 + b*t2 + c*t + cp[1,]
    }

    compute.bezier <- function(cp, points) {
      dt <- seq(0, 1, by=1/(points-1))
      sapply(dt, function(t) point.on.cubic.bezier(cp, t))
    }
    
    plot.bezier <- function(cp, points, color, width, arr, lty, arrow.size, arr.w) {
      p <- compute.bezier( cp, points )
      polygon(p[1,], p[2,], border=color, lwd=width, lty=lty)
      if (arr==1 || arr==3) {
        igraph.Arrows(p[1,ncol(p)-1], p[2,ncol(p)-1], p[1,ncol(p)], p[2,ncol(p)],
                      sh.col=color, h.col=color, size=arrow.size,
                      sh.lwd=width, h.lwd=width, open=FALSE, code=2, width=arr.w)
      }
      if (arr==2 || arr==3) {
        igraph.Arrows(p[1,2], p[2,2], p[1,1], p[2,1],
                      sh.col=color, h.col=color, size=arrow.size,
                      sh.lwd=width, h.lwd=width, open=FALSE, code=2, width=arr.w)
      }
    }
    
    loop <- function(x0, y0, cx=x0, cy=y0, color, angle=0, label=NA,
                     width=1, arr=2, lty=1, arrow.size=arrow.size,
                     arr.w=arr.w, lab.x, lab.y) {

      rad <- angle
      center <- c(cx,cy)
      cp <- matrix( c(x0,y0, x0+.4,y0+.2, x0+.4,y0-.2, x0,y0),
                   ncol=2, byrow=TRUE)
      phi <- atan2(cp[,2]-center[2], cp[,1]-center[1])
      r <- sqrt((cp[,1]-center[1])**2 + (cp[,2]-center[2])**2)
      
      phi <- phi + rad

      cp[,1] <- cx+r*cos(phi)
      cp[,2] <- cy+r*sin(phi)

      plot.bezier(cp, 50, color, width, arr=arr, lty=lty, arrow.size=arrow.size, arr.w=arr.w)

      if (is.language(label) || !is.na(label)) {
        lx <- x0+.3
        ly <- y0
        phi <- atan2(ly-center[2], lx-center[1])
        r <- sqrt((lx-center[1])**2 + (ly-center[2])**2)

        phi <- phi + rad

        lx <- cx+r*cos(phi)
        ly <- cy+r*sin(phi)

        if (!is.na(lab.x)) { lx <- lab.x }
        if (!is.na(lab.y)) { ly <- lab.y }

        text(lx, ly, label, col=edge.label.color, font=edge.label.font,
             family=edge.label.family, cex=edge.label.cex)
      }
    }

    ec <- edge.color
    if (length(ec)>1) { ec <- ec[loops.e] }
    vs <- vertex.size
    if (length(vertex.size)>1) { vs <- vs[loops.v] }
    ew <- edge.width
    if (length(edge.width)>1) { ew <- ew[loops.e] }
    la <- loop.angle
    if (length(loop.angle)>1) { la <- la[loops.e] }
    lty <- edge.lty
    if (length(edge.lty)>1) { lty <- lty[loops.e] }
    arr <- arrow.mode
    if (length(arrow.mode)>1) { arr <- arrow.mode[loops.e] }
    asize <- arrow.size
    if (length(arrow.size)>1) { asize <- arrow.size[loops.e] }
    xx0 <- layout[loops.v,1] + cos(la) * vs
    yy0 <- layout[loops.v,2] - sin(la) * vs
    mapply(loop, xx0, yy0,
           color=ec, angle=-la, label=loop.labels, lty=lty,
           width=ew, arr=arr, arrow.size=asize, arr.w=arrow.width,
           lab.x=loop.labx, lab.y=loop.laby)
  }

  ################################################################
  ## non-loop edges
  if (length(x0) != 0) {
    if (length(edge.color)>1) { edge.color <- edge.color[nonloops.e] }
    if (length(edge.width)>1) { edge.width <- edge.width[nonloops.e] }
    if (length(edge.lty)>1) { edge.lty <- edge.lty[nonloops.e] }
    if (length(arrow.mode)>1) { arrow.mode <- arrow.mode[nonloops.e] }
    if (length(arrow.size)>1) { arrow.size <- arrow.size[nonloops.e] }
    if (length(curved)>1) { curved <- curved[nonloops.e] }
    if (length(unique(arrow.mode))==1) {
      lc <-igraph.Arrows(x0, y0, x1, y1, h.col=edge.color, sh.col=edge.color,
                    sh.lwd=edge.width, h.lwd=1, open=FALSE, code=arrow.mode[1],
                    sh.lty=edge.lty, h.lty=1, size=arrow.size,
                    width=arrow.width, curved=curved)
      lc.x <- lc$lab.x
      lc.y <- lc$lab.y
    } else {
      ## different kinds of arrows drawn separately as 'arrows' cannot
      ## handle a vector as the 'code' argument
      curved <- rep(curved, length=ecount(graph))[nonloops.e]
      lc.x <- lc.y <- numeric(length(curved))
      for (code in 0:3) {
        valid <- arrow.mode==code
        if (!any(valid)) { next }
        ec <- edge.color ; if (length(ec)>1) { ec <- ec[valid] }
        ew <- edge.width ; if (length(ew)>1) { ew <- ew[valid] }
        el <- edge.lty   ; if (length(el)>1) { el <- el[valid] }
        lc <- igraph.Arrows(x0[valid], y0[valid], x1[valid], y1[valid],
                      code=code, sh.col=ec, h.col=ec, sh.lwd=ew, h.lwd=1,
                      h.lty=1, sh.lty=el, open=FALSE, size=arrow.size,
                      width=arrow.width, curved=curved[valid])
        lc.x[valid] <- lc$lab.x
        lc.y[valid] <- lc$lab.y
      }
    }
    if (!is.null(elab.x)) { lc.x <- ifelse(is.na(elab.x), lc.x, elab.x) }
    if (!is.null(elab.y)) { lc.y <- ifelse(is.na(elab.y), lc.y, elab.y) }
    text(lc.x, lc.y, labels=edge.labels, col=edge.label.color,
         family=edge.label.family, font=edge.label.font, cex=edge.label.cex)
  }
  
  rm(x0, y0, x1, y1)
  
  ################################################################
  # add the vertices
  if (length(unique(shape)) == 1) {
    .igraph.shapes[[ shape[1] ]]$plot(layout, params=params)
  } else {
    sapply(seq(length=vcount(graph)), function(x) {
      .igraph.shapes[[ shape[x] ]]$plot(layout[x,,drop=FALSE], v=x,
                                        params=params)
    })
  }
      
  ################################################################
  # add the labels
  par(xpd=TRUE)
  x <- layout[,1]+label.dist*cos(-label.degree)* 
    (vertex.size+6*8*log10(2))/200
  y <- layout[,2]+label.dist*sin(-label.degree)*
    (vertex.size+6*8*log10(2))/200
  if (length(label.family)==1) {
    text(x, y, labels=labels, col=label.color, family=label.family,
         font=label.font, cex=label.cex)
  } else {
    if1 <- function(vect, idx) if (length(vect)==1) vect else vect[idx]
    sapply(seq_len(vcount(graph)), function(v) {
      text(x[v], y[v], labels=if1(labels, v), col=if1(label.color, v),
           family=if1(label.family, v), font=if1(label.font, v),
           cex=if1(label.cex, v))
    })
  }
  rm(x, y)
  invisible(NULL)
}



#' 3D plotting of graphs with OpenGL
#' 
#' Using the \code{rgl} package, \code{rglplot} plots a graph in 3D. The plot
#' can be zoomed, rotated, shifted, etc. but the coordinates of the vertices is
#' fixed.
#' 
#' Note that \code{rglplot} is considered to be highly experimental. It is not
#' very useful either. See \code{\link{igraph.plotting}} for the possible
#' arguments.
#' 
#' @aliases rglplot rglplot.igraph
#' @param x The graph to plot.
#' @param \dots Additional arguments, see \code{\link{igraph.plotting}} for the
#' details
#' @return \code{NULL}, invisibly.
#' @author Gabor Csardi \email{csardi.gabor@@gmail.com}
#' @seealso \code{\link{igraph.plotting}}, \code{\link{plot.igraph}} for the 2D
#' version, \code{\link{tkplot}} for interactive graph drawing in 2D.
#' @export
#' @keywords graphs
#' @export
#' @examples
#' 
#' \dontrun{
#' g <- make_lattice( c(5,5,5) )
#' coords <- layout_with_fr(g, dim=3)
#' rglplot(g, layout=coords)
#' }
#' 
rglplot        <- function(x, ...)
  UseMethod("rglplot", x)

#' @method rglplot igraph
#' @export

rglplot.igraph <- function(x, ...) {

  graph <- x
  if (!is_igraph(graph)) {
    stop("Not a graph object")
  }

  create.edge <- function(v1, v2, r1, r2, ec, ew, am, as) {
    ## these could also be parameters:
    aw <- 0.005*3*as                      # arrow width
    al <- 0.005*4*as                      # arrow length    
    
    dist <- sqrt(sum((v2-v1)^2))   # distance of the centers

    if (am==0) {
      edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist,1, ew/2,-ew/2,dist,1, ew/2,ew/2,dist,1,
                        -ew/2,ew/2,dist,1,  -ew/2,-ew/2,0,1, ew/2,-ew/2,0,1,
                        ew/2,ew/2,0,1, -ew/2,ew/2,0,1),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8))
    } else if (am==1) {
      edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist,1, ew/2,-ew/2,dist,1,
                        ew/2,ew/2,dist,1, -ew/2,ew/2,dist,1,
                        -ew/2,-ew/2,al+r1,1, ew/2,-ew/2,al+r1,1,
                        ew/2,ew/2,al+r1,1, -ew/2,ew/2,al+r1,1,
                        -aw/2,-aw/2,al+r1,1, aw/2,-aw/2,al+r1,1,
                        aw/2,aw/2,al+r1,1, -aw/2,aw/2,al+r1,1, 0,0,r1,1),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8,
                        9,10,11,12, 9,12,13,13, 9,10,13,13, 10,11,13,13,
                        11,12,13,13))
    } else if (am==2) {
      box <- dist-r2-al
      edge <- rgl::qmesh3d(c(-ew/2,-ew/2,box,1, ew/2,-ew/2,box,1, ew/2,ew/2,box,1,
                        -ew/2,ew/2,box,1,  -ew/2,-ew/2,0,1, ew/2,-ew/2,0,1,
                        ew/2,ew/2,0,1, -ew/2,ew/2,0,1,
                        -aw/2,-aw/2,box,1, aw/2,-aw/2,box,1, aw/2,aw/2,box,1,
                        -aw/2,aw/2,box,1, 0,0,box+al,1),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8,
                        9,10,11,12, 9,12,13,13, 9,10,13,13, 10,11,13,13,
                        11,12,13,13))
    } else {
      edge <- rgl::qmesh3d(c(-ew/2,-ew/2,dist-al-r2,1, ew/2,-ew/2,dist-al-r2,1,
                        ew/2,ew/2,dist-al-r2,1, -ew/2,ew/2,dist-al-r2,1,
                        -ew/2,-ew/2,r1+al,1, ew/2,-ew/2,r1+al,1,
                        ew/2,ew/2,r1+al,1, -ew/2,ew/2,r1+al,1,
                        -aw/2,-aw/2,dist-al-r2,1, aw/2,-aw/2,dist-al-r2,1,
                        aw/2,aw/2,dist-al-r2,1, -aw/2,aw/2,dist-al-r2,1,
                        -aw/2,-aw/2,r1+al,1, aw/2,-aw/2,r1+al,1,
                        aw/2,aw/2,r1+al,1, -aw/2,aw/2,r1+al,1,
                        0,0,dist-r2,1, 0,0,r1,1),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7, 4,1,5,8,
                        9,10,11,12, 9,12,17,17, 9,10,17,17, 10,11,17,17,
                        11,12,17,17,
                        13,14,15,16, 13,16,18,18, 13,14,18,18, 14,15,18,18,
                        15,16,18,18))
    }
      

    ## rotate and shift it to its position
    phi<- -atan2(v2[2]-v1[2],v1[1]-v2[1])-pi/2
    psi<- acos((v2[3]-v1[3])/dist)    
    rot1 <- rbind(c(1,0,0),c(0,cos(psi),sin(psi)), c(0,-sin(psi),cos(psi)))
    rot2 <- rbind(c(cos(phi),sin(phi),0),c(-sin(phi),cos(phi),0), c(0,0,1))
    rot <- rot1 %*% rot2
    edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix=rot))
    edge <- rgl::transform3d(edge, rgl::translationMatrix(v1[1], v1[2], v1[3]))

    ## we are ready 
    rgl::shade3d(edge, col=ec)
  }
  
  create.loop <- function(v, r, ec, ew, am, la, la2, as) {
    aw <- 0.005*3*as
    al <- 0.005*4*as
    wi <- aw*2                          # size of the loop
    wi2 <- wi+aw-ew                     # size including the arrow heads
    hi <- al*2+ew*2
    gap <- wi-2*ew

    if (am==0) {
      edge <- rgl::qmesh3d(c(-wi/2,-ew/2,0,1, -gap/2,-ew/2,0,1,
                        -gap/2,ew/2,0,1, -wi/2,ew/2,0,1,
                        -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1,
                        -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1,
                        wi/2,-ew/2,0,1, gap/2,-ew/2,0,1,
                        gap/2,ew/2,0,1, wi/2,ew/2,0,1,
                        wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1,
                        gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1,
                        -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1,
                        wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1
                        ),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7,
                        1,4,18,17,
                        9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14,
                        11,12,16,15, 9,12,20,19,
                        5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14
                        ))
    } else if (am==1 || am==2) {
      edge <- rgl::qmesh3d(c(-wi/2,-ew/2,r+al,1, -gap/2,-ew/2,r+al,1,
                        -gap/2,ew/2,r+al,1, -wi/2,ew/2,r+al,1,
                        -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1,
                        -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1,
                        wi/2,-ew/2,0,1, gap/2,-ew/2,0,1,
                        gap/2,ew/2,0,1, wi/2,ew/2,0,1,
                        wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1,
                        gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1,
                        -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1,
                        wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1,
                        # the arrow
                        -wi2/2,-aw/2,r+al,1, -wi2/2+aw,-aw/2,r+al,1,
                        -wi2/2+aw,aw/2,r+al,1, -wi2/2,aw/2,r+al,1,
                        -wi2/2+aw/2,0,r,1                   
                        ),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7,
                        1,4,18,17,
                        9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14,
                        11,12,16,15, 9,12,20,19,
                        5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14,
                        # the arrow
                        21,22,23,24, 21,22,25,25, 22,23,25,25, 23,24,25,25,
                        21,24,25,25
                        ))
    } else if (am==3) {
      edge <- rgl::qmesh3d(c(-wi/2,-ew/2,r+al,1, -gap/2,-ew/2,r+al,1,
                        -gap/2,ew/2,r+al,1, -wi/2,ew/2,r+al,1,
                        -wi/2,-ew/2,hi-ew+r,1, -gap/2,-ew/2,hi-ew+r,1,
                        -gap/2,ew/2,hi-ew+r,1, -wi/2,ew/2,hi-ew+r,1,
                        wi/2,-ew/2,r+al,1, gap/2,-ew/2,r+al,1,
                        gap/2,ew/2,r+al,1, wi/2,ew/2,r+al,1,
                        wi/2,-ew/2,hi-ew+r,1, gap/2,-ew/2,hi-ew+r,1,
                        gap/2,ew/2,hi-ew+r,1, wi/2,ew/2,hi-ew+r,1,
                        -wi/2,-ew/2,hi+r,1, -wi/2,ew/2,hi+r,1,
                        wi/2,-ew/2,hi+r,1, wi/2,ew/2,hi+r,1,
                        # the arrows
                        -wi2/2,-aw/2,r+al,1, -wi2/2+aw,-aw/2,r+al,1,
                        -wi2/2+aw,aw/2,r+al,1, -wi2/2,aw/2,r+al,1,
                        -wi2/2+aw/2,0,r,1,
                        wi2/2,-aw/2,r+al,1, wi2/2-aw,-aw/2,r+al,1,
                        wi2/2-aw,aw/2,r+al,1, wi2/2,aw/2,r+al,1,
                        wi2/2-aw/2,0,r,1                   
                        ),
                      c(1,2,3,4, 5,6,7,8, 1,2,6,5, 2,3,7,6, 3,4,8,7,
                        1,4,18,17,
                        9,10,11,12, 13,14,15,16, 9,10,14,13, 10,11,15,14,
                        11,12,16,15, 9,12,20,19,
                        5,13,19,17, 17,18,20,19, 8,16,20,18, 6,7,15,14,
                        # the arrows
                        21,22,23,24, 21,22,25,25, 22,23,25,25, 23,24,25,25,
                        21,24,25,25,
                        26,27,28,29, 26,27,30,30, 27,28,30,30, 28,29,30,30,
                        26,29,30,30
                        ))
    }

    # rotate and shift to its position
    rot1 <- rbind(c(1,0,0),c(0,cos(la2),sin(la2)), c(0,-sin(la2),cos(la2)))
    rot2 <- rbind(c(cos(la),sin(la),0),c(-sin(la),cos(la),0), c(0,0,1))
    rot <- rot1 %*% rot2
    edge <- rgl::transform3d(edge, rgl::rotationMatrix(matrix=rot))
    edge <- rgl::transform3d(edge, rgl::translationMatrix(v[1], v[2], v[3]))

    ## we are ready
    rgl::shade3d(edge, col=ec)
  }
  
  # Visual parameters
  params <- i.parse.plot.params(graph, list(...))
  labels <- params("vertex", "label")
  label.color <- params("vertex", "label.color")
  label.font <- params("vertex", "label.font")
  label.degree <- params("vertex", "label.degree")
  label.dist <- params("vertex", "label.dist")
  vertex.color <- params("vertex", "color")
  vertex.size <- (1/200) * params("vertex", "size")
  loop.angle <- params("edge", "loop.angle")
  loop.angle2 <- params("edge", "loop.angle2")

  edge.color <- params("edge", "color")
  edge.width <- (1/200) * params("edge", "width")
  edge.labels <- params("edge","label")
  arrow.mode <- params("edge","arrow.mode")
  arrow.size <- params("edge","arrow.size")
  
  layout <- params("plot", "layout")
  rescale <- params("plot", "rescale")

  # the new style parameters can't do this yet
  arrow.mode         <- i.get.arrow.mode(graph, arrow.mode)
  
  # norm layout to (-1, 1)
  if (ncol(layout)==2) { layout <- cbind(layout, 0) }
  if (rescale) {
    layout <- norm_coords(layout, -1, 1, -1, 1, -1, 1)
  }
  
  # add the edges, the loops are handled separately
  el <- as_edgelist(graph, names=FALSE)
  
  # It is faster this way
  rgl::par3d(skipRedraw=TRUE)

  # edges first
  for (i in seq(length=nrow(el))) {
    from <- el[i,1]
    to   <- el[i,2]
    v1 <- layout[from,]
    v2 <- layout[to,]
    am <- arrow.mode; if (length(am)>1) { am <- am[i] }
    ew <- edge.width; if (length(ew)>1) { ew <- ew[i] }
    ec <- edge.color; if (length(ec)>1) { ec <- ec[i] }
    r1 <- vertex.size; if (length(r1)>1) { r1 <- r1[from] }
    r2 <- vertex.size; if (length(r2)>1) { r2 <- r2[to] }

    if (from!=to) {
      create.edge(v1,v2,r1,r2,ec,ew,am,arrow.size)
    } else {
      la <- loop.angle; if (length(la)>1) { la <- la[i] }
      la2 <- loop.angle2; if (length(la2)>1) { la2 <- la2[i] }      
      create.loop(v1,r1,ec,ew,am,la,la2,arrow.size)
    }
    
  }
      
  # add the vertices
  if (length(vertex.size)==1) { vertex.size <- rep(vertex.size, nrow(layout)) }
  rgl::rgl.spheres(layout[,1], layout[,2], layout[,3], radius=vertex.size,
              col=vertex.color)

  # add the labels, 'l1' is a stupid workaround of a mysterious rgl bug
  labels[is.na(labels)] <- ""
  x <- layout[,1]+label.dist*cos(-label.degree)* 
    (vertex.size+6*10*log10(2))/200
  y <- layout[,2]+label.dist*sin(-label.degree)*
    (vertex.size+6*10*log10(2))/200
  z <- layout[,3]
  l1 <- labels[1]
  labels[1] <- ""
  rgl::rgl.texts(x,y,z, labels, col=label.color, adj=0)
  rgl::rgl.texts(c(0,x[1]), c(0,y[1]), c(0,z[1]),
            c("",l1), col=c(label.color[1],label.color[1]), adj=0)

  edge.labels[is.na(edge.labels)] <- ""
  if (any(edge.labels != "")) {
    x0 <- layout[,1][el[,1]]
    x1 <- layout[,1][el[,2]]
    y0 <- layout[,2][el[,1]]
    y1 <- layout[,2][el[,2]]
    z0 <- layout[,3][el[,1]]
    z1 <- layout[,4][el[,2]]
    rgl::rgl.texts((x0+x1)/2, (y0+y1)/2, (z0+z1)/2, edge.labels,
              col=label.color)
  }

  # draw everything
  rgl::par3d(skipRedraw=FALSE)
  
  invisible(NULL)
}

# This is taken from the IDPmisc package,
# slightly modified: code argument added

#' @importFrom graphics par xyinch segments xspline lines polygon

igraph.Arrows <-
function (x1, y1, x2, y2,
                    code=2,
                    size= 1,     
                    width= 1.2/4/cin,
                    open=TRUE,
                    sh.adj=0.1, 
                    sh.lwd=1,
                    sh.col=if(is.R()) par("fg") else 1,
                    sh.lty=1,
                    h.col=sh.col,
                    h.col.bo=sh.col,
                    h.lwd=sh.lwd,
                    h.lty=sh.lty,
                    curved=FALSE)
  ## Author: Andreas Ruckstuhl, refined by Rene Locher
  ## Version: 2005-10-17
{
  cin <- size * par("cin")[2]
  width <- width * (1.2/4/cin)
  uin <- if (is.R()) 
    1/xyinch()
  else par("uin")
  x <- sqrt(seq(0, cin^2, length = floor(35 * cin) + 2))
  delta <-  sqrt(h.lwd)*par("cin")[2]*0.005      ## has been 0.05
  x.arr <- c(-rev(x), -x)
  wx2 <- width * x^2
  y.arr <- c(-rev(wx2 + delta), wx2 + delta)
  deg.arr <- c(atan2(y.arr, x.arr), NA)
  r.arr <- c(sqrt(x.arr^2 + y.arr^2), NA)

  ## backup
  bx1 <- x1 ; bx2 <- x2 ; by1 <- y1 ; by2 <- y2
  
  ## shaft
  lx <- length(x1)
  r.seg <- rep(cin*sh.adj, lx)
  theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1])
  th.seg1 <- theta1 + rep(atan2(0, -cin), lx)
  theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1])
  th.seg2 <- theta2 + rep(atan2(0, -cin), lx)
  x1d <- y1d <- x2d <- y2d <- 0
  if (code %in% c(1,3)) {
    x2d <- r.seg*cos(th.seg2)/uin[1]
    y2d <- r.seg*sin(th.seg2)/uin[2]
  }
  if (code %in% c(2,3)) {
    x1d <- r.seg*cos(th.seg1)/uin[1]
    y1d <- r.seg*sin(th.seg1)/uin[2]
  }
  if (is.logical(curved) && all(!curved) ||
      is.numeric(curved) && all(!curved)) {

    segments(x1+x1d, y1+y1d, x2+x2d, y2+y2d, lwd=sh.lwd, col=sh.col, lty=sh.lty)
    phi <- atan2(y1-y2, x1-x2)
    r <- sqrt( (x1-x2)^2 + (y1-y2)^2 )
    lc.x <- x2 + 2/3*r*cos(phi)
    lc.y <- y2 + 2/3*r*sin(phi)

  } else {
    if (is.numeric(curved)) {
      lambda <- curved
    } else {
      lambda <- as.logical(curved) * 0.5
    }
    lambda <- rep(lambda, length.out = length(x1))
    c.x1 <- x1+x1d
    c.y1 <- y1+y1d
    c.x2 <- x2+x2d
    c.y2 <- y2+y2d

    midx <- (x1+x2)/2
    midy <- (y1+y2)/2  
    spx <- midx - lambda * 1/2 * (c.y2-c.y1)
    spy <- midy + lambda * 1/2 * (c.x2-c.x1)
    sh.col <- rep(sh.col, length=length(c.x1))
    sh.lty <- rep(sh.lty, length=length(c.x1))
    sh.lwd <- rep(sh.lwd, length=length(c.x1))
    lc.x <- lc.y <- numeric(length(c.x1))

    for (i in seq_len(length(c.x1))) {
      ## Straight line?
      if (lambda[i] == 0) {
        segments(c.x1[i], c.y1[i], c.x2[i], c.y2[i],
                 lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i])
        phi <- atan2(y1[i] - y2[i], x1[i] - x2[i])
        r <- sqrt( (x1[i] - x2[i])^2 + (y1[i] - y2[i])^2 )
        lc.x[i] <- x2[i] + 2/3*r*cos(phi)
        lc.y[i] <- y2[i] + 2/3*r*sin(phi)

      } else {
        spl <- xspline(x=c(c.x1[i],spx[i],c.x2[i]),
                       y=c(c.y1[i],spy[i],c.y2[i]), shape=1, draw=FALSE)
        lines(spl, lwd=sh.lwd[i], col=sh.col[i], lty=sh.lty[i])
        if (code %in% c(2,3)) {
          x1[i] <- spl$x[3*length(spl$x)/4]
          y1[i] <- spl$y[3*length(spl$y)/4]
        }
        if (code %in% c(1,3)) {
          x2[i] <- spl$x[length(spl$x)/4]
          y2[i] <- spl$y[length(spl$y)/4]
        }
        lc.x[i] <- spl$x[2/3 * length(spl$x)]
        lc.y[i] <- spl$y[2/3 * length(spl$y)]
      }
    }
  }

  ## forward arrowhead
  if (code %in% c(2,3)) {    
    theta <- atan2((by2 - y1) * uin[2], (bx2 - x1) * uin[1])
    Rep <- rep(length(deg.arr), lx)
    p.x2 <- rep(bx2, Rep)
    p.y2 <- rep(by2, Rep)
    ttheta <- rep(theta, Rep) + rep(deg.arr, lx)
    r.arr <- rep(r.arr, lx)  
    if(open) lines((p.x2 + r.arr * cos(ttheta)/uin[1]),
                   (p.y2 + r.arr*sin(ttheta)/uin[2]), 
                   lwd=h.lwd, col = h.col.bo, lty=h.lty) else
    polygon(p.x2 + r.arr * cos(ttheta)/uin[1], p.y2 + r.arr*sin(ttheta)/uin[2], 
            col = h.col, lwd=h.lwd,
            border=h.col.bo, lty=h.lty)
  }
    
  ## backward arrow head
  if (code %in% c(1,3)) {
    x1 <- bx1; y1 <- by1
    tmp <- x1 ; x1 <- x2 ; x2 <- tmp
    tmp <- y1 ; y1 <- y2 ; y2 <- tmp
    theta <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1])
    lx <- length(x1)
    Rep <- rep(length(deg.arr), lx)
    p.x2 <- rep(x2, Rep)
    p.y2 <- rep(y2, Rep)
    ttheta <- rep(theta, Rep) + rep(deg.arr, lx)
    r.arr <- rep(r.arr, lx)

    if(open) lines((p.x2 + r.arr * cos(ttheta)/uin[1]),
                   (p.y2 + r.arr*sin(ttheta)/uin[2]), 
                   lwd=h.lwd, col = h.col.bo, lty=h.lty) else
    polygon(p.x2 + r.arr * cos(ttheta)/uin[1], p.y2 + r.arr*sin(ttheta)/uin[2], 
            col = h.col, lwd=h.lwd,
            border=h.col.bo, lty=h.lty)
  }

  list(lab.x=lc.x, lab.y=lc.y)

} # Arrows

#' @importFrom graphics xspline

igraph.polygon <- function(points, vertex.size=15/200, expand.by=15/200,
                           shape=1/2, col="#ff000033", border=NA) {

  by <- expand.by
  pp <- rbind(points,
              cbind(points[,1]-vertex.size-by, points[,2]),
              cbind(points[,1]+vertex.size+by, points[,2]),
              cbind(points[,1], points[,2]-vertex.size-by),
              cbind(points[,1], points[,2]+vertex.size+by))

  cl <- convex_hull(pp)
  xspline(cl$rescoords, shape=shape, open=FALSE, col=col, border=border)
}

