R/export.R

In misc3d: Miscellaneous 3D Plots

## Write out a triangle mesh scene as an OFF format file.  This only
## outputs the geometry; color and transparency are ignored for now.
## The format supports adding three or four rgb values to each face
## line, but MeshLab seems to ignore these.
saveTrianglesAsOFF <- function(scene, filename = "scene.OFF") {
    scene <- colorScene(scene)
    triangles <- canonicalizeAndMergeScene(scene, "color", "color2",
                                                    "alpha", "col.mesh",
                                                    "fill", "smooth")
    ve <- t2ve(triangles)
    f <- file(filename, open = "w")
    on.exit(close(f))
    write("OFF", f)
    write(c(ncol(ve$vb), ncol(ve$ib), 3 * ncol(ve$ib)), f, 3)
    write(ve$vb, f, 3)
    write(rbind(3, ve$ib - 1), f, 4)
    invisible(NULL)
}

## write an asymptote program for recreating a triangular mesh
## scene. Color and transparency are supported; mesh drawing, color2,
## and material properties are not currently supported. The loops
## could be vectorized but seem adequate for now.
saveTrianglesAsASY <- function(scene, filename = "scene.asy") {
    scene <- colorScene(scene)
    triangles <- canonicalizeAndMergeScene(scene, "color",
                                                    "color2", "alpha",
                                                    "col.mesh", "fill",
                                                    "smooth")
    ve <- t2ve(triangles)
    f <- file(filename, open = "w")
    on.exit(close(f))

    ## write out header information and vertices
    cat("//generated by saveTrianglesAsASY\n\n",
        "import three;\n\n",
        "size(20cm);\n\n",
        "//currentprojection=perspective(250,-250,250);\n",
        "currentlight=Viewport;\n\n",
        "typedef path3[] trimesh;\n\n",
        "// Vertices\n",
        "triple[] V;\n",
        sep = "", file = f)

    nv <- ncol(ve$vb)
    x <- ve$vb[1,]
    y <- ve$vb[2,]
    z <- ve$vb[3,]
    for (i in 1 : nv)
        cat(sprintf("V[%d] = (%f, %f, %f);\n",
                    i - 1, x[i], y[i], z[i]), file = f)

    ## write out the faces
    cat("\n",
        "guide3 triface_(int i, int j, int k) {\n",
        "  guide3 gh; gh=V[i-1]--V[j-1]--V[k-1]--cycle;\n",
        "  return gh;\n",
        "};\n\n",
        "// Faces\n",
        "trimesh F;\n",
        sep = "", file = f)

    nf <- ncol(ve$ib)
    v1 <- ve$ib[1,]
    v2 <- ve$ib[2,]
    v3 <- ve$ib[3,]
    for (i in 1 : nf)
        cat(sprintf("F[%d] = triface_(%d, %d, %d);\n",
                    i - 1, v1[i], v2[i], v3[i]), file = f)

    ## write out color and transparency values
    cat("\n",
        "// Colors\n",
        "material M[];\n",
        sep = "", file = f)

    cols <- col2rgb(triangles$color)
    alpha <- triangles$alpha
    r <- cols[1,]
    g <- cols[2,]
    b <- cols[3,]
    if (any(alpha < 1))
        for (i in 1 : nf)
            cat(sprintf("M[%d] = rgb(%f, %f, %f) + opacity(%f);\n",
                        i - 1, r[i], g[i], b[i], alpha[i]),
                file = f)
    else
        for (i in 1 : nf)
            cat(sprintf("M[%d] = rgb(%f, %f, %f);\n",
                        i - 1, r[i], g[i], b[i]),
                file = f)

    cat("\ndraw(surface(F), M);\n", file = f)
    invisible(NULL)
}

## write out a triangle mesh scene as an IDTF format file.
saveTrianglesAsIDTF <- function(scene, filename = "scene.idtf") {
    ns <- length(scene)
    f <- file(filename, open = "w")
    on.exit(close(f))

    ## write out header information
    cat("FILE_FORMAT \"IDTF\"\n",
        "FORMAT_VERSION 100\n\n",sep="", file=f)

    ## write out group information
    cat("NODE \"GROUP\" {\n",
	"\tNODE_NAME \"Mesh_Group\"\n",
	"\tPARENT_LIST {\n",
        "\t\tPARENT_COUNT 1\n",
        "\t\tPARENT 0 {\n",
        "\t\t\tPARENT_NAME \"<NULL>\"\n",
        "\t\t\tPARENT_TM {\n",
        "\t\t\t\t1.000000 0.000000 0.000000 0.000000\n",
        "\t\t\t\t0.000000 1.000000 0.000000 0.000000\n",
        "\t\t\t\t0.000000 0.000000 1.000000 0.000000\n",
        "\t\t\t\t0.000000 0.000000 0.000000 1.000000\n",
        "\t\t\t}\n",
        "\t\t}\n",
        "\t}\n",
        "}\n\n", sep="", file=f)

    ## write out node "model"
    for(i in 1:ns){
        cat("NODE \"MODEL\" {\n", sep="", file=f)
        cat(sprintf("\tNODE_NAME \"Mesh%d\"\n", i), file=f)
        cat("\tPARENT_LIST {\n",
            "\t\tPARENT_COUNT 1\n",
            "\t\tPARENT 0 {\n",
            "\t\t\tPARENT_NAME \"Mesh_Group\"\n",
            "\t\t\tPARENT_TM {\n",
            "\t\t\t\t1.000000 0.000000 0.000000 0.000000\n",
            "\t\t\t\t0.000000 1.000000 0.000000 0.000000\n",
            "\t\t\t\t0.000000 0.000000 1.000000 0.000000\n",
            "\t\t\t\t0.000000 0.000000 0.000000 1.000000\n",
            "\t\t\t}\n",
            "\t\t}\n",
            "\t}\n", sep="", file=f)
        cat(sprintf("\tRESOURCE_NAME \"MyMesh%d\"\n", i), file=f)
        cat("}\n\n", sep="", file=f)
    }

    ## write out resource_list "model"
    cat("RESOURCE_LIST \"MODEL\" {\n", sep="", file=f)
    cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f)
    for(s in 1:ns){
        cat(sprintf("\tRESOURCE %d {\n", s-1), file=f)
        cat(sprintf("\t\tRESOURCE_NAME \"MyMesh%d\"\n", s), file=f)
        cat("\t\tMODEL_TYPE \"MESH\"\n",
            "\t\tMESH {\n", sep="", file=f)

        ve <- t2ve(scene[[s]])
        nv <- ncol(ve$vb)
        x <- ve$vb[1,]
        y <- ve$vb[2,]
        z <- ve$vb[3,]
        nf <- ncol(ve$ib)
        v1 <- ve$ib[1,]
        v2 <- ve$ib[2,]
        v3 <- ve$ib[3,]
        N <- triangleNormals(scene[[s]])
        vt <- vertexTriangles(ve)
        VN <- vertexNormals(vt, N)

        cat(sprintf("\t\t\tFACE_COUNT %d\n", nf), file=f)
        cat(sprintf("\t\t\tMODEL_POSITION_COUNT %d\n", nv), file=f)
        cat(sprintf("\t\t\tMODEL_NORMAL_COUNT %d\n", nv), file=f)
        cat("\t\t\tMODEL_DIFFUSE_COLOR_COUNT 0\n",
            "\t\t\tMODEL_SPECULAR_COLOR_COUNT 0\n",
            "\t\t\tMODEL_TEXTURE_COORD_COUNT 0\n",
            "\t\t\tMODEL_BONE_COUNT 0\n",
            "\t\t\tMODEL_SHADING_COUNT 1\n",
            "\t\t\tMODEL_SHADING_DESCRIPTION_LIST {\n",
            "\t\t\t\tSHADING_DESCRIPTION 0 {\n",
            "\t\t\t\t\tTEXTURE_LAYER_COUNT 0\n",
            "\t\t\t\t\tSHADER_ID 0\n",
            "\t\t\t\t}\n",
            "\t\t\t}\n", sep="", file=f)
        #face position
        cat("\t\t\tMESH_FACE_POSITION_LIST {\n", sep="", file=f)
        for(i in 1:nf)
            cat(sprintf("\t\t\t\t%d  %d  %d \n", v1[i]-1, v2[i]-1, v3[i]-1), file=f)
        cat("\t\t\t}\n", sep="", file=f)
        #face normal
        cat("\t\t\tMESH_FACE_NORMAL_LIST {\n", sep="", file=f)
        for(i in 1:nf)
            cat(sprintf("\t\t\t\t%d  %d  %d \n", v1[i]-1, v2[i]-1, v3[i]-1), file=f)
        cat("\t\t\t}\n", sep="", file=f)
        #shading list---not sure what that is use 0 for all
        cat("\t\t\tMESH_FACE_SHADING_LIST {\n", sep="", file=f)
        for(i in 1:nf)
            cat(sprintf("\t\t\t\t%d\n", 0), file=f)
        cat("\t\t\t}\n", sep="", file=f)
        #model position
        cat("\t\t\tMODEL_POSITION_LIST {\n", sep="", file=f)
        for(i in 1:nv)
            cat(sprintf("\t\t\t\t%f  %f  %f \n", x[i], y[i], z[i]), file=f)
        cat("\t\t\t}\n", sep="", file=f)
        #model normal
        cat("\t\t\tMODEL_NORMAL_LIST {\n", sep="", file=f)
        for(i in 1:nv)
            cat(sprintf("\t\t\t\t%f  %f  %f \n", VN[i,1], VN[i,2], VN[i,3]), file=f)
        cat("\t\t\t}\n", sep="", file=f)
        #
        cat("\t\t}\n", sep="", file=f)
        cat("\t}\n", sep="", file=f)
    }
    cat("}\n\n", sep="", file=f)


    ## write out resource_list "shader"
    cat("RESOURCE_LIST \"SHADER\" {\n", sep="", file=f)
    cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f)
    for(s in 1:ns){
        cat(sprintf("\tRESOURCE %d {\n", s-1), file=f)
        cat(sprintf("\t\tRESOURCE_NAME \"Box0%d0\"\n", s), file=f)
        cat(sprintf("\t\tSHADER_MATERIAL_NAME \"Box0%d0\"\n", s), file=f)
        cat("\t\tSHADER_ACTIVE_TEXTURE_COUNT 0\n",
            "\t}\n", sep="", file=f)
    }
    cat("}\n\n", sep="", file=f)

    ## write out resource_list "material"
    ## need to be more flexible
    cat("RESOURCE_LIST \"MATERIAL\" {\n", sep="", file=f)
    cat(sprintf("\tRESOURCE_COUNT %d\n", ns), file=f)
    for(s in 1:ns){
        cat(sprintf("\tRESOURCE %d {\n", s-1), file=f)
        cat(sprintf("\t\tRESOURCE_NAME \"Box0%d0\"\n", s), file=f)
        cat("\t\tMATERIAL_AMBIENT 0.0 0.0 0.0\n", sep="", file=f)
        rgb <- col2rgb(scene[[s]]$color)/255
        cat(sprintf("\t\tMATERIAL_DIFFUSE %f %f %f\n", rgb[1], rgb[2], rgb[3]), file=f)
        cat("\t\tMATERIAL_SPECULAR 0.0 0.0 0.0\n",
            "\t\tMATERIAL_EMISSIVE 0.0 0.0 0.0\n",
            "\t\tMATERIAL_REFLECTIVITY 0.000000\n", sep="", file=f)
        cat(sprintf("\t\tMATERIAL_OPACITY %f\n", scene[[s]]$alpha), file=f)
        cat("\t}\n", sep="", file=f)
    }
    cat("}\n\n", sep="", file=f)

    ## write out modifier "shading"
    for(s in 1:ns){
        cat("MODIFIER \"SHADING\" {\n", sep="", file=f)
        cat(sprintf("\tMODIFIER_NAME \"Mesh%d\"\n", s), file=f)
        cat("\tPARAMETERS {\n",
            "\t\tSHADER_LIST_COUNT 1\n",
            "\t\tSHADER_LIST_LIST {\n",
            "\t\t\tSHADER_LIST 0 {\n",
            "\t\t\t\tSHADER_COUNT 1\n",
            "\t\t\t\tSHADER_NAME_LIST {\n", sep="", file=f)
        cat(sprintf("\t\t\t\t\tSHADER 0 NAME: \"Box0%d0\"\n", s), file=f)
        cat("\t\t\t\t}\n",
            "\t\t\t}\n",
            "\t\t}\n",
            "\t}\n",
            "}\n\n", sep="", file=f)
    }

    invisible(NULL)
}

exportScene <- function(scene, filename, format=c("OFF", "IDTF", "ASY")){
    format <- match.arg(format)
    switch(format,
           OFF = saveTrianglesAsOFF(scene, filename = paste(filename, ".off", sep="")),
           IDTF = saveTrianglesAsIDTF(scene, filename = paste(filename, ".idtf", sep="")),
           ASY = saveTrianglesAsASY(scene, filename = paste(filename, ".asy", sep=""))
           )

}