##
## R source file
## This file is part of rgl
##
## $Id: _internal.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##

##
## ===[ SECTION: internal ]===================================================
##

#
# rgl.range
#
# ensure value x is between low and high
#

rgl.range <- function ( x, low, high )
{
  if (length(x) > 1)
    stop( deparse(substitute(x)), " must be a single numeric")
  if ( ( x < low ) || ( x > high ) )
    stop( deparse(substitute(x)), " must be a numeric in the range [ ",low, ":", high , "]")
}


#
# rgl.clamp
#
# clamp value if lower than low or higher than high
#

rgl.clamp <- function(value, low, high)
{
  if (value < low) {
    warning( paste("value clamped to ",low) ); 
    result <- low
  }
  else if (value > high) {
    warning( paste("value clamped to ",high) );
    result <- high
  }
  else {
    result <- value
  }

  return (result);
}

##
## types verification
##


#
# single field bool
#

rgl.bool <- function ( x )
{
  if (length(x) > 1)
    stop( deparse(substitute(x)), " must be a single color character string")
}


#
# single field numeric
#

rgl.numeric <- function ( x )
{
  if (length(x) > 1)
    stop( deparse(substitute(x)), " must be a single numeric value")
}


#
# vertex data object
#

rgl.vertex <- function (x,y,z)
{
  return ( matrix( rbind(x,y,z), nrow=3, dimnames=list( c("x","y","z"), NULL ) ) )
}


#
# obtain number of vertices
#

rgl.nvertex <- function (vertex)
{  
  return ( ncol(vertex) )
}


#
# rgl.color - single field color
#

rgl.color <- function ( color )
{
  if (length(color) > 1)
    stop( deparse(substitute(color)), " must be a single color character string")
  else
    return (col2rgb(color))
}


#
# rgl.mcolor - multiple field colors
#

rgl.mcolor <- function ( colors )
{
  return ( col2rgb(colors) )
}


#
# if vattr > 1, recycle data
#

rgl.attr <- function (vattr, nvertex) 
{
  nvattr <- length(vattr)

  if ((nvattr > 1) && (nvattr != nvertex))
    vattr  <- rep(vattr,length.out=nvertex)
  
  return(vattr)
}
##
## R source file
## This file is part of rgl
##
## $Id: device.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##

##
## ===[ SECTION: device management ]==========================================
##


##
## open device
##
##

rgl.open <- function() {

  ret <- .C( symbol.C("rgl_dev_open"), success=FALSE )

  if (! ret$success)
    stop("failed")

}


##
## close device
##
##

rgl.close <- function() {

  ret <- .C( symbol.C("rgl_dev_close"), success=FALSE )

  if (! ret$success)
    stop("no device opened.")

}


## 
## get current device
##
##

rgl.cur <- function() {

  ret <- .C( symbol.C("rgl_dev_getcurrent"), 
    success=FALSE, 
    id=as.integer(0) 
  )

  if (! ret$success)
    stop("rgl_dev_getcurrent")

  return(ret$id)

}


##
## set current device
##
##

rgl.set <- function(which) {

  idata <- c( as.integer(which) )

  ret <- .C( symbol.C("rgl_dev_setcurrent"), 
    success=FALSE, 
    idata 
  )

  if (! ret$success)
    stop("no device opened with id", which)
}



##
## device system shutdown
## 
##

rgl.quit <- function() {

  detach("package:rgl")

}

##
## export image
##
##

rgl.snapshot <- function( filename, fmt="png" )
{
  idata <- as.integer(rgl.enum.pixfmt(fmt))

  ret <- .C( symbol.C("rgl_snapshot"),
    success=FALSE,
    idata,
    as.character(filename)
  )

  if (! ret$success)
    print("failed")
}
##
## R source file
## This file is part of rgl
##
## $Id: enum.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##


##
## ===[ SECTION: enumerations ]===============================================
##

##
## FUNCTIONS
##   rgl.enum
##
## utility function translating literals to ids
##

rgl.enum   <- function ( name, ... )
{
  choices <- list( ... )
  names   <- attr(choices,"names")

  pos <- pmatch( name, names )

  if ( is.na(pos) )
    stop("symbolic value must be of ", list(names) )

  id  <- choices[[pos]]
  
  return( id )
}

##
## ENUM FUNCTIONS
##

rgl.enum.nodetype <- function (type)
  return ( rgl.enum( type, shapes=1, lights=2, bboxdeco=3 ) )

rgl.enum.pixfmt <- function (fmt)
  return ( rgl.enum( fmt, png=0 ) )

rgl.enum.polymode <- function (mode)
  return ( rgl.enum( mode, filled=1, lines=2, points=3, culled=4) )

rgl.enum.textype <- function (textype)
  return ( rgl.enum( textype, alpha=1, luminance=2, luminance.alpha=3, rgb=4, rgba=5 ) )

rgl.enum.fogtype <- function (fogtype)
  return ( rgl.enum (fogtype, none=1, linear=2, exp=3, exp2=4) )

rgl.enum.primtype <- function (primtype)
  return ( rgl.enum( primtype, points=1, lines=2, triangles=3, quadrangles=4 ) )

rgl.enum.halign <- function( halign)
  return ( rgl.enum (halign, left=-1, center=0, right=1 ) )

##
## R source file
## This file is part of rgl
##
## $Id: material.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##

##
## ===[ SECTION: generic appearance function ]================================
##

rgl.material <- function ( 
  color = "white",  alpha = 1.0,
  lit = TRUE, ambient = "black",  specular="white", emission = "black", shininess = 50.0, 
  smooth = TRUE,  texture = NULL, textype = "rgb",
  front = "fill", back = "fill",
  size = 1.0, fog = TRUE )
{

  # solid or diffuse component

  color     <- rgl.mcolor(color)

  # light properties

  ambient   <- rgl.color(ambient)
  specular  <- rgl.color(specular)
  emission  <- rgl.color(emission)

  # others

  rgl.bool(lit)
  rgl.bool(fog)
  rgl.bool(smooth)
  rgl.clamp(shininess,0,128)
  rgl.numeric(size)
  
  # side-dependant rendering

  front <- rgl.enum.polymode(front)
  back  <- rgl.enum.polymode(back)

  # texture mapping

  if (length(texture) > 1)
    stop("texture should be a single character string or NULL")

  if (is.null(texture))
    texture <- ""

  textype <- rgl.enum.textype( textype )

  # vector length

  ncolor <- dim(color)[2]
  nalpha <- length(alpha)

  # pack data

  idata <- as.integer( c( ncolor, lit, smooth, front, back, fog, textype, nalpha, ambient, specular, emission, color ) )
  cdata <- as.character(c( texture ))
  ddata <- as.numeric(c( shininess, size, alpha ))

  ret <- .C( symbol.C("rgl_material"),
    success = FALSE,
    idata,
    cdata,
    ddata
  )
}
##
## R source file
## This file is part of rgl
##
## $Id: scene.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##

##
## ===[ SECTION: scene management ]===========================================
##


##
## clear scene
##
##

rgl.clear <- function( type = "shapes" )
{
  type <- rgl.enum.nodetype(type)

  idata <- as.integer(c(type))

  ret <- .C( symbol.C("rgl_clear"), 
    success=FALSE,
    idata
  )

  if (! ret$success)
    stop("rgl_clear")
}


##
## pop node
##
##

rgl.pop <- function( type = "shapes" )
{
  type <- rgl.enum.nodetype(type)

  idata <- as.integer(c(type))

  ret <- .C( symbol.C("rgl_pop"),
    success = FALSE,
    idata
  )

  if (! ret$success)
    warning("stack is empty")
}

##
## ===[ SECTION: environment ]================================================
##



##
## set viewpoint
##
##

rgl.viewpoint <- function( theta = 0.0, phi = 15.0, fov = 60.0, zoom = 0.0, interactive = TRUE )
{
  zoom <- rgl.clamp(zoom,0,1)
  phi  <- rgl.clamp(phi,-90,90)
  fov  <- rgl.clamp(fov,0,180)

  idata <- as.integer(c(interactive))
  ddata <- as.numeric(c(theta,phi,fov,zoom))

  ret <- .C( symbol.C("rgl_viewpoint"),
    success=FALSE,
    idata,
    ddata
  )

  if (! ret$success)
    stop("rgl_viewpoint")
}


##
## set background
##
##

rgl.bg <- function(sphere=FALSE, fogtype="none", color=c("black","white"), back="lines", ... )
{
  rgl.material( color=color, back=back, ... )

  fogtype <- rgl.enum.fogtype(fogtype)

  idata   <- as.integer(c(sphere,fogtype))

  ret <- .C( symbol.C("rgl_bg"), 
    success=FALSE,
    idata
  )

  if (! ret$success)
    stop("rgl_bg")
}


##
## bbox
##
##

rgl.bbox <- function( 
  xat=NULL, xlab=NULL, xunit=0, xlen=5,
  yat=NULL, ylab=NULL, yunit=0, ylen=5,
  zat=NULL, zlab=NULL, zunit=0, zlen=5,
  marklen=15.0, marklen.rel=T, ...) {

  rgl.material( ... )

  if (is.null(xat)) {
    xticks = 0; xlab = NULL;
  } else if (is.null(xlab)) {
    xlab = as.character(xat)
  }
  if (is.null(yat)) {
    yticks = 0; ylab = NULL;
  } else if (is.null(ylab)) {
    ylab = as.character(yat)
  }
  if (is.null(zat)) {
    zticks = 0; zlab = NULL;
  } else if (is.null(zlab)) {
    zlab = as.character(zat)
  }

  xticks <- length(xat)
  yticks <- length(yat)
  zticks <- length(zat)

  length(xticks)      <- 1
  length(yticks)      <- 1
  length(zticks)      <- 1
  length(xlen)        <- 1
  length(ylen)        <- 1
  length(zlen)        <- 1
  length(marklen.rel) <- 1
  length(xunit)       <- 1
  length(yunit)       <- 1
  length(zunit)       <- 1

  idata <- as.integer(c(xticks,yticks,zticks, xlen, ylen, zlen, marklen.rel))
  ddata <- as.numeric(c(xunit, yunit, zunit, marklen))

  ret <- .C( symbol.C("rgl_bbox"),
    success=FALSE,
    idata,
    ddata,
    as.numeric(xat),
    as.character(xlab),
    as.numeric(yat),
    as.character(ylab),
    as.numeric(zat),
    as.character(zlab)
  )

  if (! ret$success)
    stop("rgl_bbox")

}

##
## set lights
##
##

rgl.light <- function( theta = 0, phi = 0, viewpoint.rel = FALSE, ambient = "#FFFFFF", diffuse = "#FFFFFF", specular = "#FFFFFF")
{
  ambient  <- rgl.color(ambient)
  diffuse  <- rgl.color(diffuse)
  specular <- rgl.color(specular)

  idata <- as.integer(c(viewpoint.rel, ambient, diffuse, specular))
  ddata <- as.numeric(c(theta, phi))

  ret <- .C( symbol.C("rgl_light"),
    success=FALSE,
    idata,
    ddata
  )

  if (! ret$success)
    stop("too many lights. maximum is 8 sources per scene.");
}

##
## ===[ SECTION: shapes ]=====================================================
##

##
## add primitive
##
##

rgl.primitive <- function( type, x, y, z, ... )
{
  rgl.material( ... )

  type <- rgl.enum.primtype(type)

  vertex  <- rgl.vertex(x,y,z)
  nvertex <- rgl.nvertex(vertex)
  idata   <- as.integer( c(type, nvertex ) )

  ret <- .C( symbol.C("rgl_primitive"),
    success=FALSE,
    idata,
    as.numeric(vertex),
  );

  if (! ret$success)
    stop("rgl_points")
}

rgl.points <- function ( x, y, z, ... )
{
  rgl.primitive( "points", x, y, z, ... )
}

rgl.lines <- function (x, y, z, ... )
{
  rgl.primitive( "lines", x, y, z, ... )
}

rgl.triangles <- function (x, y, z, ... )
{
  rgl.primitive( "triangles", x, y, z, ... )
}

rgl.quads <- function ( x, y, z, ... )
{
  rgl.primitive( "quadrangles", x, y, z, ... )
}

##
## add surface
##
##

rgl.surface <- function( x, z, y, ... )
{
  rgl.material(...)

  nx <- length(x)
  nz <- length(z)
  ny <- length(y)

  if ( nx*nz != ny)
    stop("y length != x length * z length")

  if ( nx < 2 )
    stop("x length < 2")
  
  if ( nz < 2 )   
    stop("y length < 2")

  idata <- as.integer( c( nx, nz ) )

  ret <- .C( symbol.C("rgl_surface"),
    success=FALSE,
    idata,
    as.numeric(x),
    as.numeric(z),
    as.numeric(y)
  );

  if (! ret$success)
    print("rgl_surface failed")
}

##
## add spheres
##

rgl.spheres <- function( x, y, z,radius=1.0,...)
{
  rgl.material(...)

  vertex  <- rgl.vertex(x,y,z)
  nvertex <- rgl.nvertex(vertex)
  radius  <- rgl.attr(radius, nvertex)
  nradius <- length(radius)
 
  idata <- as.integer( c( nvertex, nradius ) )
   
  ret <- .C( symbol.C("rgl_spheres"),
    success=FALSE,
    idata,
    as.numeric(vertex),    
    as.numeric(radius)
  )

  if (! ret$success)
    print("rgl_spheres failed")

}

##
## add texts
##

rgl.texts <- function(x, y, z, text, justify="center", ... )
{
  rgl.material( ... )

  vertex  <- rgl.vertex(x,y,z)
  nvertex <- rgl.nvertex(vertex)
  text    <- rep(text, length.out=nvertex)

  justify <- rgl.enum.halign( justify );

  idata <- as.integer( c(nvertex, justify) )

  ret <- .C( symbol.C("rgl_texts"),
    success=FALSE,
    idata,
    as.character(text),
    as.numeric(vertex)
  )
  
  if (! ret$success)
    print("rgl_texts failed")

}

##
## add sprites
##

rgl.sprites <- function( x, y, z, radius=1.0, ... )
{
  rgl.material(...)

  center  <- rgl.vertex(x,y,z)
  ncenter <- rgl.nvertex(center)
  radius  <- rgl.attr(center, radius)
  nradius <- length(radius)
 
  idata   <- as.integer( c(ncenter,nradius) )
   
  ret <- .C( symbol.C("rgl_sprites"),
    success=FALSE,
    idata,
    as.numeric(center),
    as.numeric(radius)
  );

  if (! ret$success)
    print("rgl_sprites failed")

}
##
## R source file
## This file is part of rgl
##
## $Id: zzz.R,v 1.1.1.1 2003/03/25 00:13:21 dadler Exp $
##

##
## ===[ SECTION: package entry/exit point ]===================================
##


##
## entry-point
##
##

.First.lib <- function(lib, pkg)
{
  # load shared library

  library.dynam( "rgl", pkg, lib)
  
  ret <- .C( symbol.C("rgl_init"), 
    success=FALSE, 
  )
  
  if (!ret$success)
    stop("error rgl_init")
  
}


##
## exit-point
##
##

.Last.lib <- function(libpath)
{
  # shutdown
  
  ret <- .C( symbol.C("rgl_quit"), 
    success=FALSE, 
  )
  
  if (!ret$success)
    stop("error rgl_quit")
  
  # unload shared library

  dyn.unload( file.path( libpath, "libs", paste( "rgl", .Platform$dynlib.ext, sep="") ) )

  # R BUG: i must fix .Dyn.libs environment variable manually
  # the variable is used by 'library.dynam' to determine if a package is unloaded
  # workaround: find and remove the string item "rglview" from the list manually

  # .Dyn.libs <- get(".Dyn.libs", envir=NULL)
  # .Dyn.libs <- .Dyn.libs[-match( "rgl", .Dyn.libs )]
  # assign(".Dyn.libs", .Dyn.libs, envir=NULL)
}
