library(tkrgl)
library(misc3d)
library(gpclib)
library(grImport)
setwd("~/svn/papers/rgl_presentations/2007-08-10")

spheres <<- tclVar(0)

r3dDefaults$mouseMode = c('zAxis', 'zoom', 'trackball')

PointCloud <- function() {
   print(PointCloud)
   while(rgl.cur()) rgl.close()

   x <- rnorm(1000)
   y <- rnorm(1000)
   z <- rnorm(1000) + atan2(x,y)
   if (tclvalue(spheres) == "1") {
           type <- "s"
           size <- 0.2
   } else {
           type <- "p"
           size <- 4
   }
   plot3d(x, y, z, cex=1.5, size=size,
          type=type, col="red")
}

Volcano <- function() {
   print(Volcano)
   while(rgl.cur()) rgl.close()
   data(volcano)
   z <<- volcano
   x <<- 1:nrow(z)
   y <<- 1:ncol(z)
   persp3d(x, y, z, aspect=c(1,1,0.5),
           xlab = "", ylab = "", zlab = "", col="gray")
}

ChangeColour <- function() {
   print(ChangeColour)

   save <- par3d(skipRedraw = TRUE)
   on.exit(par3d(save))

   with(rgl.ids(), rgl.pop(id = id[type=="surface"]))
   r <- range(z)
   zunit <- (z - r[1])/(r[2]-r[1])
   col <- terrain.colors(50)[round(zunit*49,0)+1]
   persp3d(x, y, z, col=col, add=TRUE)
}

GlobeDemo <- function() {
   print(GlobeDemo)
   while(rgl.cur()) rgl.close()
   lat <- matrix(seq(90,-90, len=50)*pi/180, 50, 50, byrow=TRUE)
   long <- matrix(seq(-180, 180, len=50)*pi/180, 50, 50)

   r <- 6378.1 # radius of Earth in km
   x <- r*cos(lat)*cos(long)
   y <- r*cos(lat)*sin(long)
   z <- r*sin(lat)

   open3d()
   persp3d(x, y, z, col="white",
       texture=system.file("textures/world.png",package="rgl"),
       specular="black", axes=FALSE, box=FALSE, xlab="", ylab="", zlab="",
       normal_x=x, normal_y=y, normal_z=z)
}

ContourDemo <- function() {
   # Contouring from misc3d by Dai Feng and Luke Tierney
   print(ContourDemo)
   while(rgl.cur()) rgl.close()
   nmix3 <- function(x, y, z, m, s) {
          0.4 * dnorm(x, m, s) * dnorm(y, m, s) * dnorm(z, m, s) +
          0.3 * dnorm(x, -m, s) * dnorm(y, -m, s) * dnorm(z, -m, s) +
          0.3 * dnorm(x, m, s) * dnorm(y, -1.5 * m, s) * dnorm(z, m, s)
   }
   f <- function(x,y,z) nmix3(x,y,z,.5,.5)
   g <- function(n = 40, k = 5, alo = 0.1, ahi = 0.5, cmap = heat.colors) {
          th <- seq(0.05, 0.2, len = k)
          col <- rev(cmap(length(th)))
          al <- seq(alo, ahi, len = length(th))
          x <- seq(-2, 2, len=n)
          contour3d(f,th,x,x,x,color=col,alpha=al)
          bg3d(col="white")
          material3d(col="black", alpha=1)
          decorate3d()
  }
  g(40,5)
}

MipmapDemo <- function() {
   print(MipmapDemo)
   while(rgl.cur()) rgl.close()
   x <- c(0,0,1,1)
   y <- c(0,1,1,0)
   plain <- open3d()
   quads3d(x,y,1, texcoords=cbind(x,y)*256, texture="rgl2.png", col="white")
   mipmap <- open3d()
   quads3d(x,y,1,texcoords=cbind(x,y)*256,
       texture="rgl2.png", col="white",
       texmipmap=TRUE, texminfilter="linear.mipmap.linear")
   spin3d(c(plain, mipmap))
}

SmoothingDemo <- function() {
   print(SmoothingDemo)
   while(rgl.cur()) rgl.close()
   data(volcano)

   x <- runif(1000,min=0.5,max=nrow(volcano)+0.5)
   y <- runif(1000,min=0.5,max=ncol(volcano)+0.5)
   z <- volcano[cbind(round(x),round(y))] + rnorm(1000)

   fit <- loess(z ~ x*y, enp = 5)

   newx <- as.double(row(volcano))
   newy <- as.double(col(volcano))
   newz <- matrix(predict(fit,data.frame(x=newx,y=newy)), nrow(volcano), ncol(volcano))
   p <- persp3d(1:nrow(volcano), 1:ncol(volcano), newz,
                     zlim = range(c(z, newz)), xlab='', ylab='', zlab='', col='lightblue',
                     box = FALSE, cex=2, alpha=0.9)

   if (tclvalue(spheres) == "1") spheres3d(x,y,z)
   else points3d(x,y,z, size=4)

   pz <- predict(fit)

   bw <- tclVar(5)
   bw.sav <- 5 # in case replot.maybe is called too early

   replot <- function(...) {

           save <- par3d(skipRedraw = TRUE)
           on.exit(par3d(save))

           bw.sav <<- b <- as.numeric(tclvalue(bw))
           fit <- loess(z ~ x*y, enp = b)
           newz <- matrix(predict(fit,data.frame(x=newx,y=newy)), nrow(volcano), ncol(volcano))
           with(rgl.ids(), rgl.pop(id = id[type=="surface"]))
           persp3d(1:nrow(volcano), 1:ncol(volcano), newz, add=TRUE, col='lightblue', alpha = 0.9)
   }

   replot.maybe <- function(...) {
           if (as.numeric(tclvalue(bw)) != bw.sav) replot()
   }

   font <- "{Arial 18}"
   base <- tktoplevel()
   tkwm.title(base, "Smoothing")
   tkpack(tkradiobutton(base, command=replot.maybe, value = 5, text="5",
                              variable=bw, font=font))
   tkpack(tkradiobutton(base, command=replot.maybe, value = 10, text="10",
                              variable=bw, font=font))
   tkpack(tkradiobutton(base, command=replot.maybe, value = 20, text="20",
                              variable=bw, font=font))
   tkpack(tkradiobutton(base, command=replot.maybe, value = 50, text="50",
                              variable=bw, font=font))
   tkpack(tkradiobutton(base, command=replot.maybe, value = 100, text="100",
                              variable=bw, font=font))
   tkpack(tkradiobutton(base, command=replot.maybe, value = 200, text="200",
                              variable=bw, font=font))
}

EnvDemo <- function() {
   while(rgl.cur()) rgl.close()

   open3d()
   material3d(texture="rgl2.png",
              texenvmap=TRUE, color = "gold")
   surface3d( 10*1:nrow(volcano),10*1:ncol(volcano),5*volcano)
}


setGeneric("rglify", function(object, ...) standardGeneric("rglify"))

setMethod("rglify", "PictureStroke", function(object, z, ...)
lines3d(object@x, object@y, z, col=object@rgb)
)

setMethod("rglify", c("PictureFill"), function(object, z, ...)
 if (length(object@x) > 2)
   triangles3d( cbind(triangulate(as(cbind(object@x, object@y), "gpc.poly")), z),
                col=object@rgb, lit=FALSE)
)

setMethod("rglify", "Picture", function(object, ...)
for (i in 1:length(object@paths)) rglify(object@paths[[i]], 2*i))

TigerDemo <-function() {
       while(rgl.cur()) rgl.close()

   open3d()
   view3d(0,0)
   tiger <- readPicture("tiger.eps.xml")

   rglify(tiger)
}


demos <- function() {
   base <- tktoplevel()
   tkwm.title(base,"Demos")
   font <- "{Arial 24}"
   tkpack(tkcheckbutton(base, text="Spheres", font=font, variable=spheres), side="left")
   tkpack(tkbutton(base, command=PointCloud, text="Point cloud", font=font), side="left")
   tkpack(tkbutton(base, command=Volcano, text="Volcano", font=font), side="left")
   tkpack(tkbutton(base, command=ChangeColour, text="Change colour", font=font), side="left")
   tkpack(tkbutton(base, command=GlobeDemo, text="Textures", font=font), side="left")
   tkpack(tkbutton(base, command=ContourDemo,text="Contour", font=font), side="left")
   tkpack(tkbutton(base, command=MipmapDemo,text="Mipmap", font=font), side="left")
   tkpack(tkbutton(base, command=SmoothingDemo, text="Smoothing", font=font), side="left")
   tkpack(tkbutton(base, command=EnvDemo, text="Fun1", font=font), side="left")
   tkpack(tkbutton(base, command=TigerDemo, text="Fun2", font=font), side="left")
}