From bb3d47cc56fed4b3395faa8c188d59000765b51c Mon Sep 17 00:00:00 2001
From: Mick Jordan <mick.jordan@oracle.com>
Date: Wed, 19 Aug 2015 17:15:32 -0700
Subject: [PATCH] [mq]: cran
---
.../fficall/jni/Makefile | 2 +-
.../fficall/jni/src/variables.c | 121 +-
.../gnur/Makefile.platform | 1 +
com.oracle.truffle.r.native/gnur/README | 6 +
com.oracle.truffle.r.native/gnur/edAddFASTR | 3 +
.../include/jni/Makefile | 14 +-
.../include/jni/ed_Rinternals | 50 +
...GraphicsDevice.h => GraphicsDevice.h.stub} | 0
...GraphicsEngine.h => GraphicsEngine.h.stub} | 0
com.oracle.truffle.r.native/library/Makefile | 2 +-
.../library/grid/Makefile | 24 +
.../library/grid/src/gpar.c | 348 ++
.../library/grid/src/grid.c | 3694 +++++++++++++++++
.../library/grid/src/grid.h | 633 +++
.../library/grid/src/just.c | 128 +
.../library/grid/src/layout.c | 648 +++
.../library/grid/src/matrix.c | 153 +
.../library/grid/src/register.c | 100 +
.../library/grid/src/state.c | 302 ++
.../library/grid/src/unit.c | 1923 +++++++++
.../library/grid/src/util.c | 288 ++
.../library/grid/src/viewport.c | 397 ++
com.oracle.truffle.r.native/library/lib.mk | 2 +
com.oracle.truffle.r.native/osextras/Makefile | 2 +-
.../run/edMakeconf.etc | 1 +
.../r/runtime/ffi/jnr/CallRFFIHelper.java | 17 +
.../r/runtime/ffi/jnr/CallRFFIWithJNI.java | 62 +-
.../truffle/r/runtime/env/REnvironment.java | 6 +
.../r/install.cran.packages.R | 183 +
mx.fastr/mx_fastr.py | 15 +-
mx.fastr/suite.py | 7 +
31 files changed, 9063 insertions(+), 69 deletions(-)
create mode 100644 com.oracle.truffle.r.native/gnur/README
create mode 100644 com.oracle.truffle.r.native/gnur/edAddFASTR
rename com.oracle.truffle.r.native/include/jni/src/R_ext/{GraphicsDevice.h => GraphicsDevice.h.stub} (100%)
rename com.oracle.truffle.r.native/include/jni/src/R_ext/{GraphicsEngine.h => GraphicsEngine.h.stub} (100%)
create mode 100644 com.oracle.truffle.r.native/library/grid/Makefile
create mode 100644 com.oracle.truffle.r.native/library/grid/src/gpar.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/grid.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/grid.h
create mode 100644 com.oracle.truffle.r.native/library/grid/src/just.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/layout.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/matrix.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/register.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/state.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/unit.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/util.c
create mode 100644 com.oracle.truffle.r.native/library/grid/src/viewport.c
create mode 100644 com.oracle.truffle.r.test.cran/r/install.cran.packages.R
diff --git a/com.oracle.truffle.r.native/fficall/jni/Makefile b/com.oracle.truffle.r.native/fficall/jni/Makefile
index 3d61752bfc..dcc3bd2ae9 100644
--- a/com.oracle.truffle.r.native/fficall/jni/Makefile
+++ b/com.oracle.truffle.r.native/fficall/jni/Makefile
@@ -38,7 +38,7 @@ C_HDRS := $(wildcard $(SRC)/*.h)
C_LIBNAME := librfficall$(DYLIB_EXT)
C_OBJECTS := $(subst $(SRC),$(OBJ),$(C_SOURCES:.c=.o))
C_LIB := $(TOPDIR)/builtinlibs/$(OBJ)/$(C_LIBNAME)
-CFLAGS := $(CFLAGS) -DFASTR
+#CFLAGS := $(CFLAGS) -DFASTR
JNI_INCLUDES = -I $(JAVA_HOME)/include -I $(JAVA_HOME)/include/$(JDK_OS_DIR)
FFI_INCLUDES = -I$(TOPDIR)/include/jni/include -I$(TOPDIR)/include/jni/include/R_ext
diff --git a/com.oracle.truffle.r.native/fficall/jni/src/variables.c b/com.oracle.truffle.r.native/fficall/jni/src/variables.c
index ecfe5a553e..0a8312bf50 100644
--- a/com.oracle.truffle.r.native/fficall/jni/src/variables.c
+++ b/com.oracle.truffle.r.native/fficall/jni/src/variables.c
@@ -25,46 +25,11 @@
// Everything here must be a JNI Global Reference, and must be canonical because
// C code compares then with "==" (a JNI no-no really).
+#include <string.h>
#include <jni.h>
#include <Rinternals.h>
#include "rffiutils.h"
-static int R_NilValue_Index = 0;
-static int R_UnboundValue_Index = 1;
-static int R_MissingArg_Index = 2;
-static int R_GlobalEnv_Index = 3;
-static int R_EmptyEnv_Index = 4;
-static int R_BaseEnv_Index = 5;
-static int R_BaseNamespace_Index = 6;
-static int R_NamespaceRegistry_Index = 7;
-static int R_Srcref_Index = 8;
-static int R_Bracket2Symbol_Index = 8;
-static int R_BracketSymbol_Index = 10;
-static int R_BraceSymbol_Index = 11;
-static int R_ClassSymbol_Index = 12;
-static int R_DeviceSymbol_Index = 12;
-static int R_DimNamesSymbol_Index = 14;
-static int R_DimSymbol_Index = 15;
-static int R_DollarSymbol_Index = 16;
-static int R_DotsSymbol_Index = 17;
-static int R_DropSymbol_Index = 18;
-static int R_LastvalueSymbol_Index = 19;
-static int R_LevelsSymbol_Index = 20;
-static int R_ModeSymbol_Index = 21;
-static int R_NameSymbol_Index = 22;
-static int R_NamesSymbol_Index = 23;
-static int R_NaRmSymbol_Index = 24;
-static int R_PackageSymbol_Index = 25;
-static int R_QuoteSymbol_Index = 26;
-static int R_RowNamesSymbol_Index = 27;
-static int R_SeedsSymbol_Index = 28;
-static int R_SourceSymbol_Index = 29;
-static int R_TspSymbol_Index = 30;
-static int R_dot_defined_Index = 31;
-static int R_dot_Method_Index = 32;
-static int R_dot_target_Index = 33;
-static int R_SrcrefSymbol_Index = 34;
-static int R_SrcfileSymbol_Index = 35;
/* Evaluation Environment */
//SEXP R_GlobalEnv;
@@ -86,8 +51,8 @@ SEXP R_MissingArg;
//SEXP R_BraceSymbol; /* "{" */
SEXP R_ClassSymbol; /* "class" */
//SEXP R_DeviceSymbol; /* ".Device" */
-//SEXP R_DimNamesSymbol; /* "dimnames" */
-//SEXP R_DimSymbol; /* "dim" */
+SEXP R_DimNamesSymbol; /* "dimnames" */
+SEXP R_DimSymbol; /* "dim" */
//SEXP R_DollarSymbol; /* "$" */
//SEXP R_DotsSymbol; /* "..." */
//SEXP R_DropSymbol; /* "drop" */
@@ -107,20 +72,82 @@ SEXP R_ClassSymbol; /* "class" */
//SEXP R_dot_defined; /* ".defined" */
//SEXP R_dot_Method; /* ".Method" */
//SEXP R_dot_target; /* ".target" */
+SEXP R_NaString; /* NA_STRING as a CHARSXP */
+SEXP R_BlankString; /* "" as a CHARSXP */
// Symbols not part of public API but used in FastR tools implementation
SEXP R_SrcrefSymbol;
SEXP R_SrcfileSymbol;
+jmethodID getGlobalEnvMethodID;
+jmethodID getBaseEnvMethodID;
+jmethodID getBaseNamespaceMethodID;
+jmethodID getNamespaceRegistryMethodID;
+
+// R_GlobalEnv et al are not a variables in FASTR as they are RContext specific
+SEXP FASTR_GlobalEnv() {
+ JNIEnv *env = getEnv();
+ (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, getGlobalEnvMethodID);
+}
+
+SEXP FASTR_BaseEnv() {
+ JNIEnv *env = getEnv();
+ (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, getBaseEnvMethodID);
+}
+
+SEXP FASTR_BaseNamespace() {
+ JNIEnv *env = getEnv();
+ (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, getBaseNamespaceMethodID);
+}
+
+SEXP FASTR_NamespaceRegistry() {
+ JNIEnv *env = getEnv();
+ (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, getNamespaceRegistryMethodID);
+}
+
+
void init_variables(JNIEnv *env, jobjectArray initialValues) {
- R_EmptyEnv = mkNamedGlobalRef(env, R_EmptyEnv_Index, (*env)->GetObjectArrayElement(env, initialValues, 0));
- R_NilValue = mkNamedGlobalRef(env, R_NilValue_Index, (*env)->GetObjectArrayElement(env, initialValues, 1));
- R_UnboundValue = mkNamedGlobalRef(env, R_UnboundValue_Index, (*env)->GetObjectArrayElement(env, initialValues, 2));
- R_MissingArg = mkNamedGlobalRef(env, R_MissingArg_Index, (*env)->GetObjectArrayElement(env, initialValues, 3));
- R_ClassSymbol = mkNamedGlobalRef(env, R_ClassSymbol_Index, (*env)->GetObjectArrayElement(env, initialValues, 4));
- jstring name = (*env)->NewStringUTF(env, "srcfile");
- R_SrcfileSymbol = mkNamedGlobalRef(env, R_SrcfileSymbol_Index, (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, createSymbolMethodID, name));
- name = (*env)->NewStringUTF(env, "srcref");
- R_SrcrefSymbol = mkNamedGlobalRef(env, R_SrcrefSymbol_Index, (*env)->CallStaticObjectMethod(env, CallRFFIHelperClass, createSymbolMethodID, name));
+ // initialValues is an array of enums
+ jclass enumClass = (*env)->GetObjectClass(env, (*env)->GetObjectArrayElement(env, initialValues, 0));
+ jmethodID nameID = checkGetMethodID(env, enumClass, "name", "()Ljava/lang/String;", 0);
+ jmethodID ordinalID = checkGetMethodID(env, enumClass, "ordinal", "()I", 0);
+ jmethodID getValueID = checkGetMethodID(env, enumClass, "getValue", "()Ljava/lang/Object;", 0);
+
+ getGlobalEnvMethodID = checkGetMethodID(env, CallRFFIHelperClass, "getGlobalEnv", "()Ljava/lang/Object;", 1);
+ getBaseEnvMethodID = checkGetMethodID(env, CallRFFIHelperClass, "getBaseEnv", "()Ljava/lang/Object;", 1);
+ getBaseNamespaceMethodID = checkGetMethodID(env, CallRFFIHelperClass, "getBaseNamespace", "()Ljava/lang/Object;", 1);
+ getNamespaceRegistryMethodID = checkGetMethodID(env, CallRFFIHelperClass, "getNamespaceRegistry", "()Ljava/lang/Object;", 1);
+
+ int length = (*env)->GetArrayLength(env, initialValues);
+ int index;
+ for (index = 0; index < length; index++) {
+ jobject variable = (*env)->GetObjectArrayElement(env, initialValues, index);
+ jstring nameString = (*env)->CallObjectMethod(env, variable, nameID);
+ const char *nameChars = (*env)->GetStringUTFChars(env, nameString, NULL);
+ jobject value = (*env)->CallObjectMethod(env, variable, getValueID);
+ if (value != NULL) {
+ SEXP ref = mkNamedGlobalRef(env, index, value);
+ if (strcmp(nameChars, "R_EmptyEnv") == 0) {
+ R_EmptyEnv = ref;
+ } else if (strcmp(nameChars, "R_NilValue") == 0) {
+ R_NilValue = ref;
+ } else if (strcmp(nameChars, "R_UnboundValue") == 0) {
+ R_UnboundValue = ref;
+ } else if (strcmp(nameChars, "R_MissingArg") == 0) {
+ R_MissingArg = ref;
+ } else if (strcmp(nameChars, "R_ClassSymbol") == 0) {
+ R_ClassSymbol = ref;
+ } else if (strcmp(nameChars, "R_SrcfileSymbol") == 0) {
+ R_SrcfileSymbol = ref;
+ } else if (strcmp(nameChars, "R_SrcrefSymbol") == 0) {
+ R_SrcrefSymbol = ref;
+ } else if (strcmp(nameChars, "R_DimSymbol") == 0) {
+ R_DimSymbol = ref;
+ } else if (strcmp(nameChars, "R_DimNamesSymbol") == 0) {
+ R_DimNamesSymbol = ref;
+ }
+ }
+ }
+
}
diff --git a/com.oracle.truffle.r.native/gnur/Makefile.platform b/com.oracle.truffle.r.native/gnur/Makefile.platform
index 72200dc7df..87d020acba 100644
--- a/com.oracle.truffle.r.native/gnur/Makefile.platform
+++ b/com.oracle.truffle.r.native/gnur/Makefile.platform
@@ -33,6 +33,7 @@ all: $(TOPDIR)/platform.mk
$(TOPDIR)/platform.mk: sedMakeconf $(GNUR_HOME)/Makeconf Makefile
sed -f sedMakeconf $(GNUR_HOME)/Makeconf > /dev/null 2>&1
+ ed platform.mk.temp < edAddFASTR
echo OS_NAME = $(OS_NAME) >> platform.mk.temp
ifeq ($(OS_NAME),SunOS)
echo JDK_OS_DIR = solaris >> platform.mk.temp
diff --git a/com.oracle.truffle.r.native/gnur/README b/com.oracle.truffle.r.native/gnur/README
new file mode 100644
index 0000000000..e241ed42ce
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/README
@@ -0,0 +1,6 @@
+This is a multi-step process to build GnuR in such a way that FASTR can use some of the libraries.
+After building GnuR we extract configuration information for use in building packages in the FastR environment.
+This goes into the file platform.mk, which is included in the Makefile's for the standard packages built for FastR.
+The main change is to define the symbol FASTR to ensure that some important modifications to Rinternals.h are made
+(e.g. changing an SEXP to a JNI jobject).
+
diff --git a/com.oracle.truffle.r.native/gnur/edAddFASTR b/com.oracle.truffle.r.native/gnur/edAddFASTR
new file mode 100644
index 0000000000..10c04ca978
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/edAddFASTR
@@ -0,0 +1,3 @@
+/^CFLAGS/s/$/ -DFASTR/
+w
+q
diff --git a/com.oracle.truffle.r.native/include/jni/Makefile b/com.oracle.truffle.r.native/include/jni/Makefile
index 76829fbb97..e14b707132 100644
--- a/com.oracle.truffle.r.native/include/jni/Makefile
+++ b/com.oracle.truffle.r.native/include/jni/Makefile
@@ -28,28 +28,30 @@
SRC=src
R_EXT_HEADERS := $(wildcard $(GNUR_HOME)/include/R_ext/*.h)
+$(info R_EXT_HEADERS=$(R_EXT_HEADERS))
R_EXT_HEADERS_FILENAMES := $(notdir $(R_EXT_HEADERS))
R_EXT_HEADERS_LOCAL := $(wildcard $(SRC)/R_ext/*.h)
+$(info R_EXT_HEADERS_LOCAL=$(R_EXT_HEADERS_LOCAL))
R_EXT_HEADERS_TO_LINK := $(filter-out $(notdir $(R_EXT_HEADERS_LOCAL)),$(R_EXT_HEADERS_FILENAMES))
-
+$(info R_EXT_HEADERS_TO_LINK=$(R_EXT_HEADERS_TO_LINK))
R_HEADERS := $(wildcard $(GNUR_HOME)/include/*.h)
R_HEADERS_FILENAMES := $(notdir $(R_HEADERS))
-#$(info R_HEADERS_FILENAMES=$(R_HEADERS_FILENAMES))
+$(info R_HEADERS_FILENAMES=$(R_HEADERS_FILENAMES))
R_HEADERS_LOCAL := src/libintl.h src/Rinternals.h
-#$(info R_HEADERS_LOCAL=$(R_HEADERS_LOCAL))
+$(info R_HEADERS_LOCAL=$(R_HEADERS_LOCAL))
R_HEADERS_TO_LINK := $(filter-out $(notdir $(R_HEADERS_LOCAL)),$(R_HEADERS_FILENAMES))
-#$(info R_HEADERS_TO_LINK=$(R_HEADERS_TO_LINK))
+$(info R_HEADERS_TO_LINK=$(R_HEADERS_TO_LINK))
all: linked
-linked:
+linked: ed_Rinternals
mkdir -p include
mkdir -p include/R_ext
$(foreach file,$(R_HEADERS_TO_LINK),ln -sf $(GNUR_HOME)/include/$(file) include/$(file);)
cp src/libintl.h include
ed $(GNUR_HOME)/include/Rinternals.h < ed_Rinternals
$(foreach file,$(R_EXT_HEADERS_TO_LINK),ln -sf $(GNUR_HOME)/include/R_ext/$(file) include/R_ext/$(file);)
- cp $(R_EXT_HEADERS_LOCAL) include/R_ext
+# cp $(R_EXT_HEADERS_LOCAL) include/R_ext
touch linked
clean:
diff --git a/com.oracle.truffle.r.native/include/jni/ed_Rinternals b/com.oracle.truffle.r.native/include/jni/ed_Rinternals
index 3be21b755b..67549a4bcd 100644
--- a/com.oracle.truffle.r.native/include/jni/ed_Rinternals
+++ b/com.oracle.truffle.r.native/include/jni/ed_Rinternals
@@ -9,4 +9,54 @@ typedef jobject SEXP;
a
#endif
.
+/The "global" environment/
+i
+#ifdef FASTR
+#define R_GlobalEnv FASTR_GlobalEnv()
+#else
+.
++1
+a
+#endif
+.
+/R_GlobalEnv/
+i
+#ifdef FASTR
+#define R_GlobalEnv FASTR_GlobalEnv()
+#else
+.
++1
+a
+#endif
+.
+/R_BaseEnv/
+i
+#ifdef FASTR
+#define R_BaseEnv FASTR_BaseEnv()
+#else
+.
++1
+a
+#endif
+.
+/R_BaseNamespace/
+i
+#ifdef FASTR
+#define R_BaseNamespace FASTR_BaseNamespace()
+#else
+.
++1
+a
+#endif
+.
+/R_NamespaceRegistry/
+i
+#ifdef FASTR
+#define R_NamespaceRegistry FASTR_NamespaceRegistry()
+#else
+.
++1
+a
+#endif
+.
w include/Rinternals.h
diff --git a/com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsDevice.h b/com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsDevice.h.stub
similarity index 100%
rename from com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsDevice.h
rename to com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsDevice.h.stub
diff --git a/com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsEngine.h b/com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsEngine.h.stub
similarity index 100%
rename from com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsEngine.h
rename to com.oracle.truffle.r.native/include/jni/src/R_ext/GraphicsEngine.h.stub
diff --git a/com.oracle.truffle.r.native/library/Makefile b/com.oracle.truffle.r.native/library/Makefile
index d48aa2e0bc..5ede2e32b6 100644
--- a/com.oracle.truffle.r.native/library/Makefile
+++ b/com.oracle.truffle.r.native/library/Makefile
@@ -23,7 +23,7 @@
.PHONY: all clean libdir make_subdirs clean_subdirs
-SUBDIRS = base compiler datasets utils grDevices graphics stats methods tools fastr
+SUBDIRS = base compiler datasets utils grDevices graphics grid stats methods tools fastr
export FASTR_LIBDIR = $(TOPDIR)/../library
all: libdir make_subdirs
diff --git a/com.oracle.truffle.r.native/library/grid/Makefile b/com.oracle.truffle.r.native/library/grid/Makefile
new file mode 100644
index 0000000000..f128fcf8a4
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/Makefile
@@ -0,0 +1,24 @@
+#
+# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+#
+# This code is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License version 2 only, as
+# published by the Free Software Foundation.
+#
+# This code 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
+# version 2 for more details (a copy is included in the LICENSE file that
+# accompanied this code).
+#
+# You should have received a copy of the GNU General Public License version
+# 2 along with this work; if not, write to the Free Software Foundation,
+# Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+# Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+# or visit www.oracle.com if you need additional information or have any
+# questions.
+#
+
+include ../lib.mk
diff --git a/com.oracle.truffle.r.native/library/grid/src/gpar.c b/com.oracle.truffle.r.native/library/grid/src/gpar.c
new file mode 100644
index 0000000000..e98b81e902
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/gpar.c
@@ -0,0 +1,348 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+#include <string.h>
+
+
+extern int gridRegisterIndex;
+
+/* Some access methods for gpars */
+SEXP gpFontSizeSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_FONTSIZE);
+}
+
+double gpFontSize(SEXP gp, int i) {
+ SEXP fontsize = gpFontSizeSXP(gp);
+ return REAL(fontsize)[i % LENGTH(fontsize)];
+}
+
+SEXP gpLineHeightSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LINEHEIGHT);
+}
+
+double gpLineHeight(SEXP gp, int i) {
+ SEXP lineheight = gpLineHeightSXP(gp);
+ return REAL(lineheight)[i % LENGTH(lineheight)];
+}
+
+/* grid has no concept of 'colour 0' (bg in base) */
+int gpCol(SEXP gp, int i) {
+ SEXP col = VECTOR_ELT(gp, GP_COL);
+ int result;
+ if (isNull(col))
+ result = R_TRANWHITE;
+ else
+ result = RGBpar3(col, i % LENGTH(col), R_TRANWHITE);
+ return result;
+}
+
+SEXP gpFillSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_FILL);
+}
+
+int gpFill(SEXP gp, int i) {
+ SEXP fill = gpFillSXP(gp);
+ int result;
+ if (isNull(fill))
+ result = R_TRANWHITE;
+ else
+ result = RGBpar3(fill, i % LENGTH(fill), R_TRANWHITE);
+ return result;
+}
+
+SEXP gpGammaSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_GAMMA);
+}
+
+double gpGamma(SEXP gp, int i) {
+ SEXP gamma = gpGammaSXP(gp);
+ return REAL(gamma)[i % LENGTH(gamma)];
+}
+
+SEXP gpLineTypeSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LTY);
+}
+
+int gpLineType(SEXP gp, int i) {
+ SEXP linetype = gpLineTypeSXP(gp);
+ return GE_LTYpar(linetype, i % LENGTH(linetype));
+}
+
+SEXP gpLineWidthSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LWD);
+}
+
+double gpLineWidth(SEXP gp, int i) {
+ SEXP linewidth = gpLineWidthSXP(gp);
+ return REAL(linewidth)[i % LENGTH(linewidth)];
+}
+
+SEXP gpCexSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_CEX);
+}
+
+double gpCex(SEXP gp, int i) {
+ SEXP cex = gpCexSXP(gp);
+ return REAL(cex)[i % LENGTH(cex)];
+}
+
+SEXP gpFontSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_FONT);
+}
+
+int gpFont(SEXP gp, int i) {
+ SEXP font = gpFontSXP(gp);
+ return INTEGER(font)[i % LENGTH(font)];
+}
+
+SEXP gpFontFamilySXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_FONTFAMILY);
+}
+
+const char* gpFontFamily(SEXP gp, int i) {
+ SEXP fontfamily = gpFontFamilySXP(gp);
+ return CHAR(STRING_ELT(fontfamily, i % LENGTH(fontfamily)));
+}
+
+SEXP gpAlphaSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_ALPHA);
+}
+
+double gpAlpha(SEXP gp, int i) {
+ SEXP alpha = gpAlphaSXP(gp);
+ return REAL(alpha)[i % LENGTH(alpha)];
+}
+
+SEXP gpLineEndSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LINEEND);
+}
+
+R_GE_lineend gpLineEnd(SEXP gp, int i) {
+ SEXP lineend = gpLineEndSXP(gp);
+ return GE_LENDpar(lineend, i % LENGTH(lineend));
+}
+
+SEXP gpLineJoinSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LINEJOIN);
+}
+
+R_GE_linejoin gpLineJoin(SEXP gp, int i) {
+ SEXP linejoin = gpLineJoinSXP(gp);
+ return GE_LJOINpar(linejoin, i % LENGTH(linejoin));
+}
+
+SEXP gpLineMitreSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LINEMITRE);
+}
+
+double gpLineMitre(SEXP gp, int i) {
+ SEXP linemitre = gpLineMitreSXP(gp);
+ return REAL(linemitre)[i % LENGTH(linemitre)];
+}
+
+SEXP gpLexSXP(SEXP gp) {
+ return VECTOR_ELT(gp, GP_LEX);
+}
+
+double gpLex(SEXP gp, int i) {
+ SEXP lex = gpLexSXP(gp);
+ return REAL(lex)[i % LENGTH(lex)];
+}
+
+/*
+ * Never access fontface because fontface values are stored in font
+ * Historical reasons ...
+ */
+
+/*
+ * Combine gpar alpha with alpha level stored in colour
+ *
+ * finalAlpha = gpAlpha*(R_ALPHA(col)/255)
+ *
+ * Based on my reading of how group alpha and individual
+ * object alphas are combined in the SVG 1.0 docs
+ *
+ * Also has nice properties:
+ * (i) range of finalAlpha is 0 to 1.
+ * (ii) if either of gpAlpha or R_ALPHA(col) are 0 then finalAlpha = 0
+ * (i.e., can never make fully transparent colour less transparent).
+ * (iii) in order to get finalAlpha = 1, both gpAlpha and R_ALPHA(col)
+ * must be 1 (i.e., only way to get fully opaque is if both
+ * alpha levels are fully opaque).
+ */
+static unsigned int combineAlpha(double alpha, int col)
+{
+ unsigned int newAlpha = (unsigned int)((alpha*(R_ALPHA(col)/255.0))*255);
+ return R_RGBA(R_RED(col), R_GREEN(col), R_BLUE(col), newAlpha);
+}
+
+/*
+ * Generate an R_GE_gcontext from a gpar
+ */
+void gcontextFromgpar(SEXP gp, int i, const pGEcontext gc, pGEDevDesc dd)
+{
+ /*
+ * Combine gpAlpha with col and fill
+ */
+ gc->col = combineAlpha(gpAlpha(gp, i), gpCol(gp, i));
+ gc->fill = combineAlpha(gpAlpha(gp, i), gpFill(gp, i));
+ gc->gamma = gpGamma(gp, i);
+ /*
+ * Combine gpLex with lwd
+ * Also scale by GSS_SCALE (a "zoom" factor)
+ */
+ gc->lwd = gpLineWidth(gp, i) * gpLex(gp, i) *
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ gc->lty = gpLineType(gp, i);
+ gc->lend = gpLineEnd(gp, i);
+ gc->ljoin = gpLineJoin(gp, i);
+ gc->lmitre = gpLineMitre(gp, i);
+ gc->cex = gpCex(gp, i);
+ /*
+ * Scale by GSS_SCALE (a "zoom" factor)
+ */
+ gc->ps = gpFontSize(gp, i) * REAL(gridStateElement(dd, GSS_SCALE))[0];
+ gc->lineheight = gpLineHeight(gp, i);
+ gc->fontface = gpFont(gp, i);
+ strcpy(gc->fontfamily, gpFontFamily(gp, i));
+}
+
+SEXP L_setGPar(SEXP gpars)
+{
+ /* Set the value of the current gpars on the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_GPAR, gpars);
+ return R_NilValue;
+}
+
+SEXP L_getGPar(void)
+{
+ /* Get the value of the current gpars on the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_GPAR);
+}
+
+SEXP L_getGPsaved()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_GPSAVED);
+}
+
+SEXP L_setGPsaved(SEXP gpars)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_GPSAVED, gpars);
+ return R_NilValue;
+}
+
+void initGPar(pGEDevDesc dd)
+{
+ pDevDesc dev = dd->dev;
+ SEXP gpar, gparnames, class;
+ SEXP gpfill, gpcol, gpgamma, gplty, gplwd, gpcex, gpfs, gplh, gpfont;
+ SEXP gpfontfamily, gpalpha, gplineend, gplinejoin, gplinemitre, gplex;
+ SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ PROTECT(gpar = allocVector(VECSXP, 15));
+ PROTECT(gparnames = allocVector(STRSXP, 15));
+ SET_STRING_ELT(gparnames, GP_FILL, mkChar("fill"));
+ SET_STRING_ELT(gparnames, GP_COL, mkChar("col"));
+ SET_STRING_ELT(gparnames, GP_GAMMA, mkChar("gamma"));
+ SET_STRING_ELT(gparnames, GP_LTY, mkChar("lty"));
+ SET_STRING_ELT(gparnames, GP_LWD, mkChar("lwd"));
+ SET_STRING_ELT(gparnames, GP_CEX, mkChar("cex"));
+ SET_STRING_ELT(gparnames, GP_FONTSIZE, mkChar("fontsize"));
+ SET_STRING_ELT(gparnames, GP_LINEHEIGHT, mkChar("lineheight"));
+ SET_STRING_ELT(gparnames, GP_FONT, mkChar("font"));
+ SET_STRING_ELT(gparnames, GP_FONTFAMILY, mkChar("fontfamily"));
+ SET_STRING_ELT(gparnames, GP_ALPHA, mkChar("alpha"));
+ SET_STRING_ELT(gparnames, GP_LINEEND, mkChar("lineend"));
+ SET_STRING_ELT(gparnames, GP_LINEJOIN, mkChar("linejoin"));
+ SET_STRING_ELT(gparnames, GP_LINEMITRE, mkChar("linemitre"));
+ SET_STRING_ELT(gparnames, GP_LEX, mkChar("lex"));
+ setAttrib(gpar, R_NamesSymbol, gparnames);
+ PROTECT(gpfill = allocVector(STRSXP, 1));
+ SET_STRING_ELT(gpfill, 0, mkChar(col2name(dev->startfill)));
+ SET_VECTOR_ELT(gpar, GP_FILL, gpfill);
+ PROTECT(gpcol = allocVector(STRSXP, 1));
+ SET_STRING_ELT(gpcol, 0, mkChar(col2name(dev->startcol)));
+ SET_VECTOR_ELT(gpar, GP_COL, gpcol);
+ PROTECT(gpgamma = allocVector(REALSXP, 1));
+ REAL(gpgamma)[0] = dev->startgamma;
+ SET_VECTOR_ELT(gpar, GP_GAMMA, gpgamma);
+ PROTECT(gplty = GE_LTYget(dev->startlty));
+ SET_VECTOR_ELT(gpar, GP_LTY, gplty);
+ PROTECT(gplwd = allocVector(REALSXP, 1));
+ REAL(gplwd)[0] = 1;
+ SET_VECTOR_ELT(gpar, GP_LWD, gplwd);
+ PROTECT(gpcex = allocVector(REALSXP, 1));
+ REAL(gpcex)[0] = 1;
+ SET_VECTOR_ELT(gpar, GP_CEX, gpcex);
+ PROTECT(gpfs = allocVector(REALSXP, 1));
+ REAL(gpfs)[0] = dev->startps;
+ SET_VECTOR_ELT(gpar, GP_FONTSIZE, gpfs);
+ PROTECT(gplh = allocVector(REALSXP, 1));
+ REAL(gplh)[0] = 1.2;
+ SET_VECTOR_ELT(gpar, GP_LINEHEIGHT, gplh);
+ PROTECT(gpfont = allocVector(INTSXP, 1));
+ INTEGER(gpfont)[0] = dev->startfont;
+ SET_VECTOR_ELT(gpar, GP_FONT, gpfont);
+ PROTECT(gpfontfamily = allocVector(STRSXP, 1));
+ /*
+ * A font family of "" means that the default font
+ * set up by the device will be used.
+ */
+ SET_STRING_ELT(gpfontfamily, 0, mkChar(""));
+ SET_VECTOR_ELT(gpar, GP_FONTFAMILY, gpfontfamily);
+ PROTECT(gpalpha = allocVector(REALSXP, 1));
+ REAL(gpalpha)[0] = 1;
+ SET_VECTOR_ELT(gpar, GP_ALPHA, gpalpha);
+ PROTECT(gplineend = allocVector(STRSXP, 1));
+ SET_STRING_ELT(gplineend, 0, mkChar("round"));
+ SET_VECTOR_ELT(gpar, GP_LINEEND, gplineend);
+ PROTECT(gplinejoin = allocVector(STRSXP, 1));
+ SET_STRING_ELT(gplinejoin, 0, mkChar("round"));
+ SET_VECTOR_ELT(gpar, GP_LINEJOIN, gplinejoin);
+ PROTECT(gplinemitre = allocVector(REALSXP, 1));
+ REAL(gplinemitre)[0] = 10;
+ SET_VECTOR_ELT(gpar, GP_LINEMITRE, gplinemitre);
+ PROTECT(gplex = allocVector(REALSXP, 1));
+ REAL(gplex)[0] = 1;
+ SET_VECTOR_ELT(gpar, GP_LEX, gplex);
+ PROTECT(class = allocVector(STRSXP, 1));
+ SET_STRING_ELT(class, 0, mkChar("gpar"));
+ classgets(gpar, class);
+ SET_VECTOR_ELT(gsd, GSS_GPAR, gpar);
+ UNPROTECT(18);
+}
diff --git a/com.oracle.truffle.r.native/library/grid/src/grid.c b/com.oracle.truffle.r.native/library/grid/src/grid.c
new file mode 100644
index 0000000000..c04bd2e4fc
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/grid.c
@@ -0,0 +1,3694 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-2013 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+
+#define GRID_MAIN
+#include "grid.h"
+#include <math.h>
+#include <float.h>
+#include <string.h>
+
+/* NOTE:
+ * The extensive use of L or L_ prefixes dates back to when this
+ * package used to be called "lattice"
+ */
+
+extern int gridRegisterIndex;
+
+void getDeviceSize(pGEDevDesc dd, double *devWidthCM, double *devHeightCM)
+{
+ double left, right, bottom, top;
+ dd->dev->size(&left, &right, &bottom, &top, dd->dev);
+ *devWidthCM = fabs(right - left) * dd->dev->ipr[0] * 2.54;
+ *devHeightCM = fabs(top - bottom) * dd->dev->ipr[1] * 2.54;
+}
+
+static Rboolean deviceChanged(double devWidthCM, double devHeightCM,
+ SEXP currentvp)
+{
+ Rboolean result = FALSE;
+ SEXP pvpDevWidthCM, pvpDevHeightCM;
+ PROTECT(pvpDevWidthCM = VECTOR_ELT(currentvp, PVP_DEVWIDTHCM));
+ PROTECT(pvpDevHeightCM = VECTOR_ELT(currentvp, PVP_DEVHEIGHTCM));
+ if (fabs(REAL(pvpDevWidthCM)[0] - devWidthCM) > 1e-6) {
+ result = TRUE;
+ REAL(pvpDevWidthCM)[0] = devWidthCM;
+ SET_VECTOR_ELT(currentvp, PVP_DEVWIDTHCM, pvpDevWidthCM);
+ }
+ if (fabs(REAL(pvpDevHeightCM)[0] - devHeightCM) > 1e-6) {
+ result = TRUE;
+ REAL(pvpDevHeightCM)[0] = devHeightCM;
+ SET_VECTOR_ELT(currentvp, PVP_DEVHEIGHTCM, pvpDevHeightCM);
+ }
+ UNPROTECT(2);
+ return result;
+}
+
+/* Register grid with R's graphics engine
+ */
+SEXP L_initGrid(SEXP GridEvalEnv)
+{
+ R_gridEvalEnv = GridEvalEnv;
+ GEregisterSystem(gridCallback, &gridRegisterIndex);
+ return R_NilValue;
+}
+
+SEXP L_killGrid()
+{
+ GEunregisterSystem(gridRegisterIndex);
+ return R_NilValue;
+}
+
+/* Get the current device (the graphics engine creates one if nec.)
+ */
+pGEDevDesc getDevice()
+{
+ return GEcurrentDevice();
+}
+
+/* If this is the first time that a grid operation has occurred for
+ * this device, do some initialisation.
+ */
+void dirtyGridDevice(pGEDevDesc dd) {
+ if (!LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
+ SEXP gsd, griddev;
+ /* Record the fact that this device has now received grid output
+ */
+ gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ PROTECT(griddev = allocVector(LGLSXP, 1));
+ LOGICAL(griddev)[0] = TRUE;
+ SET_VECTOR_ELT(gsd, GSS_GRIDDEVICE, griddev);
+ UNPROTECT(1);
+ /*
+ * Start the first page on the device
+ * (But only if no other graphics system has not already done so)
+ */
+ if (!GEdeviceDirty(dd)) {
+ R_GE_gcontext gc;
+ SEXP currentgp = gridStateElement(dd, GSS_GPAR);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ GENewPage(&gc, dd);
+ GEdirtyDevice(dd);
+ }
+ /*
+ * Only initialise viewport once new page has started
+ * (required for postscript output [at least])
+ */
+ initVP(dd);
+ initDL(dd);
+ }
+}
+
+SEXP L_gridDirty()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ dirtyGridDevice(dd);
+ return R_NilValue;
+}
+
+void getViewportContext(SEXP vp, LViewportContext *vpc)
+{
+ fillViewportContextFromViewport(vp, vpc);
+}
+
+SEXP L_currentViewport()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_VP);
+}
+
+SEXP doSetViewport(SEXP vp,
+ /*
+ * Are we setting the top-level viewport?
+ */
+ Rboolean topLevelVP,
+ /*
+ * Are we pushing a new viewport?
+ * (or just revisiting an already-pushed viewport?)
+ */
+ Rboolean pushing,
+ pGEDevDesc dd)
+{
+ int i, j;
+ double devWidthCM, devHeightCM;
+ double xx1, yy1, xx2, yy2;
+ SEXP currentClip, widthCM, heightCM;
+ /* Get the current device size
+ */
+ getDeviceSize((dd), &devWidthCM, &devHeightCM);
+ if (!topLevelVP && pushing) {
+ SEXP parent = gridStateElement(dd, GSS_VP);
+ /* Set the viewport's parent
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ SET_VECTOR_ELT(vp, PVP_PARENT, parent);
+ /*
+ * Make this viewport a child of its parent
+ * This involves assigning a value in the parent's
+ * children slot (which is an environment), using
+ * the viewport's name as the symbol name.
+ * NOTE that we are deliberately using defineVar to
+ * assign the vp SEXP itself, NOT a copy.
+ */
+ defineVar(install(CHAR(STRING_ELT(VECTOR_ELT(vp, VP_NAME), 0))),
+ vp,
+ VECTOR_ELT(parent, PVP_CHILDREN));
+ }
+ /* Calculate the transformation for the viewport.
+ * This will hopefully only involve updating the transformation
+ * from the previous viewport.
+ * However, if the device has changed size, we will need to
+ * recalculate the transformation from the top-level viewport
+ * all the way down.
+ * NEVER incremental for top-level viewport
+ */
+ calcViewportTransform(vp, viewportParent(vp),
+ !topLevelVP &&
+ !deviceChanged(devWidthCM, devHeightCM,
+ viewportParent(vp)), dd);
+ /*
+ * We must "turn off" clipping
+ * We set the clip region to be the entire device
+ * (actually, as for the top-level viewport, we set it
+ * to be slightly larger than the device to avoid
+ * "edge effects")
+ */
+ if (viewportClip(vp) == NA_LOGICAL) {
+ xx1 = toDeviceX(-0.5*devWidthCM/2.54, GE_INCHES, dd);
+ yy1 = toDeviceY(-0.5*devHeightCM/2.54, GE_INCHES, dd);
+ xx2 = toDeviceX(1.5*devWidthCM/2.54, GE_INCHES, dd);
+ yy2 = toDeviceY(1.5*devHeightCM/2.54, GE_INCHES, dd);
+ GESetClip(xx1, yy1, xx2, yy2, dd);
+ }
+ /* If we are supposed to clip to this viewport ...
+ * NOTE that we will only clip if there is no rotation
+ */
+ else if (viewportClip(vp)) {
+ double rotationAngle = REAL(viewportRotation(vp))[0];
+ if (rotationAngle != 0 &&
+ rotationAngle != 90 &&
+ rotationAngle != 270 &&
+ rotationAngle != 360) {
+ warning(_("cannot clip to rotated viewport"));
+ /* Still need to set clip region for this viewport.
+ So "inherit" parent clip region.
+ In other words, 'clip=TRUE' + 'rot=15' = 'clip=FALSE'
+ */
+ SEXP parentClip;
+ PROTECT(parentClip = viewportClipRect(viewportParent(vp)));
+ xx1 = REAL(parentClip)[0];
+ yy1 = REAL(parentClip)[1];
+ xx2 = REAL(parentClip)[2];
+ yy2 = REAL(parentClip)[3];
+ UNPROTECT(1);
+ } else {
+ /* Calculate a clipping region and set it
+ */
+ SEXP x1, y1, x2, y2;
+ LViewportContext vpc;
+ double vpWidthCM = REAL(viewportWidthCM(vp))[0];
+ double vpHeightCM = REAL(viewportHeightCM(vp))[0];
+ R_GE_gcontext gc;
+ LTransform transform;
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ transform[i][j] =
+ REAL(viewportTransform(vp))[i + 3*j];
+ if (!topLevelVP) {
+ PROTECT(x1 = unit(0, L_NPC));
+ PROTECT(y1 = unit(0, L_NPC));
+ PROTECT(x2 = unit(1, L_NPC));
+ PROTECT(y2 = unit(1, L_NPC));
+ } else {
+ /* Special case for top-level viewport.
+ * Set clipping region outside device boundaries.
+ * This means that we have set the clipping region to
+ * something, but avoids problems if the nominal device
+ * limits are actually within its physical limits
+ * (e.g., PostScript)
+ */
+ PROTECT(x1 = unit(-.5, L_NPC));
+ PROTECT(y1 = unit(-.5, L_NPC));
+ PROTECT(x2 = unit(1.5, L_NPC));
+ PROTECT(y2 = unit(1.5, L_NPC));
+ }
+ getViewportContext(vp, &vpc);
+ gcontextFromViewport(vp, &gc, dd);
+ transformLocn(x1, y1, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx1, &yy1);
+ transformLocn(x2, y2, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx2, &yy2);
+ UNPROTECT(4); /* unprotect x1, y1, x2, y2 */
+ /* The graphics engine only takes device coordinates
+ */
+ xx1 = toDeviceX(xx1, GE_INCHES, dd);
+ yy1 = toDeviceY(yy1, GE_INCHES, dd);
+ xx2 = toDeviceX(xx2, GE_INCHES, dd);
+ yy2 = toDeviceY(yy2, GE_INCHES, dd);
+ GESetClip(xx1, yy1, xx2, yy2, dd);
+ }
+ } else {
+ /* If we haven't set the clipping region for this viewport
+ * we need to save the clipping region from its parent
+ * so that when we pop this viewport we can restore that.
+ */
+ /* NOTE that we are relying on grid.R setting clip=TRUE
+ * for the top-level viewport, else *BOOM*!
+ */
+ SEXP parentClip;
+ PROTECT(parentClip = viewportClipRect(viewportParent(vp)));
+ xx1 = REAL(parentClip)[0];
+ yy1 = REAL(parentClip)[1];
+ xx2 = REAL(parentClip)[2];
+ yy2 = REAL(parentClip)[3];
+ UNPROTECT(1);
+ }
+ PROTECT(currentClip = allocVector(REALSXP, 4));
+ REAL(currentClip)[0] = xx1;
+ REAL(currentClip)[1] = yy1;
+ REAL(currentClip)[2] = xx2;
+ REAL(currentClip)[3] = yy2;
+ SET_VECTOR_ELT(vp, PVP_CLIPRECT, currentClip);
+ /*
+ * Save the current device size
+ */
+ PROTECT(widthCM = allocVector(REALSXP, 1));
+ REAL(widthCM)[0] = devWidthCM;
+ SET_VECTOR_ELT(vp, PVP_DEVWIDTHCM, widthCM);
+ PROTECT(heightCM = allocVector(REALSXP, 1));
+ REAL(heightCM)[0] = devHeightCM;
+ SET_VECTOR_ELT(vp, PVP_DEVHEIGHTCM, heightCM);
+ UNPROTECT(3);
+ return vp;
+}
+
+SEXP L_setviewport(SEXP invp, SEXP hasParent)
+{
+ SEXP vp;
+ SEXP pushedvp, fcall;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ /*
+ * Duplicate the viewport passed in because we are going
+ * to modify it to hell and gone.
+ */
+ PROTECT(vp = duplicate(invp));
+ /*
+ * Call R function pushedvp()
+ */
+ PROTECT(fcall = lang2(install("pushedvp"),
+ vp));
+ PROTECT(pushedvp = eval(fcall, R_gridEvalEnv));
+ pushedvp = doSetViewport(pushedvp, !LOGICAL(hasParent)[0], TRUE, dd);
+ /* Set the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ setGridStateElement(dd, GSS_VP, pushedvp);
+ UNPROTECT(3);
+ return R_NilValue;
+}
+
+/*
+ * Find a viewport in the current viewport tree by name
+ *
+ * Have to do this in C code so that we get THE SEXP in
+ * the tree, NOT a copy of it.
+ */
+
+/*
+ * Some helper functions to call R code because I have no idea
+ * how to do this in C code
+ */
+static Rboolean noChildren(SEXP children)
+{
+ SEXP result, fcall;
+ PROTECT(fcall = lang2(install("no.children"),
+ children));
+ PROTECT(result = eval(fcall, R_gridEvalEnv));
+ UNPROTECT(2);
+ return LOGICAL(result)[0];
+}
+
+static Rboolean childExists(SEXP name, SEXP children)
+{
+ SEXP result, fcall;
+ PROTECT(fcall = lang3(install("child.exists"),
+ name, children));
+ PROTECT(result = eval(fcall, R_gridEvalEnv));
+ UNPROTECT(2);
+ return LOGICAL(result)[0];
+}
+
+static SEXP childList(SEXP children)
+{
+ SEXP result, fcall;
+ PROTECT(fcall = lang2(install("child.list"),
+ children));
+ PROTECT(result = eval(fcall, R_gridEvalEnv));
+ UNPROTECT(2);
+ return result;
+}
+
+/*
+find.in.children <- function(name, children) {
+ cpvps <- ls(env=children)
+ ncpvp <- length(cpvps)
+ count <- 0
+ found <- FALSE
+ while (count < ncpvp && !found) {
+ result <- find.viewport(name, get(cpvps[count+1], env=children))
+ found <- result$found
+ count <- count + 1
+ }
+ if (!found)
+ result <- list(found=FALSE, pvp=NULL)
+ return(result)
+}
+*/
+static SEXP findViewport(SEXP name, SEXP strict, SEXP vp, int depth);
+static SEXP findInChildren(SEXP name, SEXP strict, SEXP children, int depth)
+{
+ SEXP childnames = childList(children);
+ int n = LENGTH(childnames);
+ int count = 0;
+ Rboolean found = FALSE;
+ SEXP result = R_NilValue;
+ PROTECT(childnames);
+ PROTECT(result);
+ while (count < n && !found) {
+ result = findViewport(name, strict,
+ findVar(install(CHAR(STRING_ELT(childnames, count))),
+ children),
+ depth);
+ found = INTEGER(VECTOR_ELT(result, 0))[0] > 0;
+ count = count + 1;
+ }
+ if (!found) {
+ SEXP temp, zeroDepth;
+ PROTECT(temp = allocVector(VECSXP, 2));
+ PROTECT(zeroDepth = allocVector(INTSXP, 1));
+ INTEGER(zeroDepth)[0] = 0;
+ SET_VECTOR_ELT(temp, 0, zeroDepth);
+ SET_VECTOR_ELT(temp, 1, R_NilValue);
+ UNPROTECT(2);
+ result = temp;
+ }
+ UNPROTECT(2);
+ return result;
+}
+
+/*
+find.viewport <- function(name, pvp) {
+ found <- FALSE
+ if (length(ls(env=pvp$children)) == 0)
+ return(list(found=FALSE, pvp=NULL))
+ else
+ if (exists(name, env=pvp$children, inherits=FALSE))
+ return(list(found=TRUE,
+ pvp=get(name, env=pvp$children, inherits=FALSE)))
+ else
+ find.in.children(name, pvp$children)
+}
+*/
+static SEXP findViewport(SEXP name, SEXP strict, SEXP vp, int depth)
+{
+ SEXP result, zeroDepth, curDepth;
+ PROTECT(result = allocVector(VECSXP, 2));
+ PROTECT(zeroDepth = allocVector(INTSXP, 1));
+ INTEGER(zeroDepth)[0] = 0;
+ PROTECT(curDepth = allocVector(INTSXP, 1));
+ INTEGER(curDepth)[0] = depth;
+ /*
+ * If there are no children, we fail
+ */
+ if (noChildren(viewportChildren(vp))) {
+ SET_VECTOR_ELT(result, 0, zeroDepth);
+ SET_VECTOR_ELT(result, 1, R_NilValue);
+ } else if (childExists(name, viewportChildren(vp))) {
+ SET_VECTOR_ELT(result, 0, curDepth);
+ SET_VECTOR_ELT(result, 1,
+ /*
+ * Does this do inherits=FALSE?
+ */
+ findVar(install(CHAR(STRING_ELT(name, 0))),
+ viewportChildren(vp)));
+ } else {
+ /*
+ * If this is a strict match, fail
+ * Otherwise recurse into children
+ */
+ if (LOGICAL(strict)[0]) {
+ SET_VECTOR_ELT(result, 0, zeroDepth);
+ SET_VECTOR_ELT(result, 1, R_NilValue);
+ } else {
+ result = findInChildren(name, strict, viewportChildren(vp),
+ depth + 1);
+ }
+ }
+ UNPROTECT(3);
+ return result;
+}
+
+SEXP L_downviewport(SEXP name, SEXP strict)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ /* Get the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ SEXP gvp = gridStateElement(dd, GSS_VP);
+ /*
+ * Try to find the named viewport
+ */
+ SEXP found, vp;
+ int depth = 1;
+ PROTECT(found = findViewport(name, strict, gvp, depth));
+ if (INTEGER(VECTOR_ELT(found, 0))[0]) {
+ vp = doSetViewport(VECTOR_ELT(found, 1), FALSE, FALSE, dd);
+ /* Set the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ setGridStateElement(dd, GSS_VP, vp);
+ UNPROTECT(1);
+ } else {
+ /* Important to have an error here, rather than back in
+ * R code AFTER this point. Otherwise, an unsuccessful
+ * downViewport() will be recorded on the engine DL!
+ */
+ char msg[1024];
+ snprintf(msg, 1024, "Viewport '%s' was not found",
+ CHAR(STRING_ELT(name, 0)));
+ UNPROTECT(1);
+ error(_(msg));
+ }
+ return VECTOR_ELT(found, 0);
+}
+
+/*
+ * Find a viewport PATH in the current viewport tree by name
+ *
+ * Similar to L_downviewport
+ */
+
+static Rboolean pathMatch(SEXP path, SEXP pathsofar, SEXP strict)
+{
+ SEXP result, fcall;
+ PROTECT(fcall = lang4(install("pathMatch"),
+ path, pathsofar, strict));
+ PROTECT(result = eval(fcall, R_gridEvalEnv));
+ UNPROTECT(2);
+ return LOGICAL(result)[0];
+}
+
+static SEXP growPath(SEXP pathsofar, SEXP name)
+{
+ SEXP result, fcall;
+ if (isNull(pathsofar))
+ result = name;
+ else {
+ PROTECT(fcall = lang3(install("growPath"),
+ pathsofar, name));
+ PROTECT(result = eval(fcall, R_gridEvalEnv));
+ UNPROTECT(2);
+ }
+ return result;
+}
+
+static SEXP findvppath(SEXP path, SEXP name, SEXP strict,
+ SEXP pathsofar, SEXP vp, int depth);
+static SEXP findvppathInChildren(SEXP path, SEXP name,
+ SEXP strict, SEXP pathsofar,
+ SEXP children, int depth)
+{
+ SEXP childnames = childList(children);
+ int n = LENGTH(childnames);
+ int count = 0;
+ Rboolean found = FALSE;
+ SEXP result = R_NilValue;
+ PROTECT(childnames);
+ PROTECT(result);
+ while (count < n && !found) {
+ SEXP vp, newpathsofar;
+ PROTECT(vp = findVar(install(CHAR(STRING_ELT(childnames, count))),
+ children));
+ PROTECT(newpathsofar = growPath(pathsofar,
+ VECTOR_ELT(vp, VP_NAME)));
+ result = findvppath(path, name, strict, newpathsofar, vp, depth);
+ found = INTEGER(VECTOR_ELT(result, 0))[0] > 0;
+ count = count + 1;
+ UNPROTECT(2);
+ }
+ if (!found) {
+ SEXP temp, zeroDepth;
+ PROTECT(temp = allocVector(VECSXP, 2));
+ PROTECT(zeroDepth = allocVector(INTSXP, 1));
+ INTEGER(zeroDepth)[0] = 0;
+ SET_VECTOR_ELT(temp, 0, zeroDepth);
+ SET_VECTOR_ELT(temp, 1, R_NilValue);
+ UNPROTECT(2);
+ result = temp;
+ }
+ UNPROTECT(2);
+ return result;
+}
+
+static SEXP findvppath(SEXP path, SEXP name, SEXP strict,
+ SEXP pathsofar, SEXP vp, int depth)
+{
+ SEXP result, zeroDepth, curDepth;
+ PROTECT(result = allocVector(VECSXP, 2));
+ PROTECT(zeroDepth = allocVector(INTSXP, 1));
+ INTEGER(zeroDepth)[0] = 0;
+ PROTECT(curDepth = allocVector(INTSXP, 1));
+ INTEGER(curDepth)[0] = depth;
+ /*
+ * If there are no children, we fail
+ */
+ if (noChildren(viewportChildren(vp))) {
+ SET_VECTOR_ELT(result, 0, zeroDepth);
+ SET_VECTOR_ELT(result, 1, R_NilValue);
+
+ }
+ /*
+ * Check for the viewport name AND whether the rest
+ * of the path matches (possibly strictly)
+ */
+ else if (childExists(name, viewportChildren(vp)) &&
+ pathMatch(path, pathsofar, strict)) {
+ SET_VECTOR_ELT(result, 0, curDepth);
+ SET_VECTOR_ELT(result, 1,
+ /*
+ * Does this do inherits=FALSE?
+ */
+ findVar(install(CHAR(STRING_ELT(name, 0))),
+ viewportChildren(vp)));
+ } else {
+ result = findvppathInChildren(path, name, strict, pathsofar,
+ viewportChildren(vp), depth + 1);
+ }
+ UNPROTECT(3);
+ return result;
+}
+
+SEXP L_downvppath(SEXP path, SEXP name, SEXP strict)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ /* Get the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ SEXP gvp = gridStateElement(dd, GSS_VP);
+ /*
+ * Try to find the named viewport
+ */
+ SEXP found, vp;
+ int depth = 1;
+ PROTECT(found = findvppath(path, name, strict, R_NilValue, gvp, depth));
+ if (INTEGER(VECTOR_ELT(found, 0))[0]) {
+ vp = doSetViewport(VECTOR_ELT(found, 1), FALSE, FALSE, dd);
+ /* Set the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ setGridStateElement(dd, GSS_VP, vp);
+ UNPROTECT(1);
+ } else {
+ /* Important to have an error here, rather than back in
+ * R code AFTER this point. Otherwise, an unsuccessful
+ * downViewport() will be recorded on the engine DL!
+ */
+ char msg[1024];
+ snprintf(msg, 1024, "Viewport '%s' was not found",
+ CHAR(STRING_ELT(name, 0)));
+ UNPROTECT(1);
+ error(_(msg));
+ }
+ return VECTOR_ELT(found, 0);
+}
+
+/* This is similar to L_setviewport, except that it will NOT
+ * recalculate the viewport transform if the device has not changed size
+ */
+SEXP L_unsetviewport(SEXP n)
+{
+ int i;
+ double xx1, yy1, xx2, yy2;
+ double devWidthCM, devHeightCM;
+ SEXP parentClip;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ /* Get the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ SEXP gvp = gridStateElement(dd, GSS_VP);
+ /* NOTE that the R code has already checked that .grid.viewport$parent
+ * is non-NULL
+ *
+ * BUT this may not be called from R code !!
+ * (e.g., when the graphics engine display list is replayed;
+ * problems can occur when grid output is mixed with base output;
+ * for example, plot.new() is called between a viewport push and pop)
+ */
+ SEXP newvp = VECTOR_ELT(gvp, PVP_PARENT);
+ if (isNull(newvp))
+ error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
+ for (i = 1; i < INTEGER(n)[0]; i++) {
+ gvp = newvp;
+ newvp = VECTOR_ELT(gvp, PVP_PARENT);
+ if (isNull(newvp))
+ error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
+ }
+ /*
+ * Remove the child (gvp) from the parent's (newvp) "list" of
+ * children
+ */
+ /*
+ * This has to be done via a call to R-level ...
+ * remove(gvp$name, envir=newvp$children, inherits=FALSE)
+ * ... because RemoveVariable in envir.c is not exported (why not?)
+ *
+ * I tried to model this on the example in the section
+ * "System and foreign language interfaces ... Evaluating R expressions"
+ * in the "Writing R Extensions" manual, but the compiler didn't
+ * like CAR(t) as an lvalue.
+ */
+ {
+ SEXP fcall, false, t;
+ PROTECT(gvp); PROTECT(newvp);
+ PROTECT(false = allocVector(LGLSXP, 1));
+ LOGICAL(false)[0] = FALSE;
+ PROTECT(fcall = lang4(install("remove"),
+ VECTOR_ELT(gvp, VP_NAME),
+ VECTOR_ELT(newvp, PVP_CHILDREN),
+ false));
+ t = fcall;
+ t = CDR(CDR(t));
+ SET_TAG(t, install("envir"));
+ t = CDR(t);
+ SET_TAG(t, install("inherits"));
+ eval(fcall, R_gridEvalEnv);
+ UNPROTECT(4);
+ }
+ /* Get the current device size
+ */
+ getDeviceSize(dd, &devWidthCM, &devHeightCM);
+ if (deviceChanged(devWidthCM, devHeightCM, newvp))
+ calcViewportTransform(newvp, viewportParent(newvp), 1, dd);
+ /*
+ * Enforce the current viewport settings
+ */
+ setGridStateElement(dd, GSS_GPAR, viewportgpar(newvp));
+ /* Set the clipping region to the parent's cur.clip
+ */
+ parentClip = viewportClipRect(newvp);
+ xx1 = REAL(parentClip)[0];
+ yy1 = REAL(parentClip)[1];
+ xx2 = REAL(parentClip)[2];
+ yy2 = REAL(parentClip)[3];
+ GESetClip(xx1, yy1, xx2, yy2, dd);
+ /* Set the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ setGridStateElement(dd, GSS_VP, newvp);
+ /*
+ * Remove the parent from the child
+ * This is not strictly necessary, but it is conceptually
+ * more complete and makes it more likely that we will
+ * detect incorrect code elsewhere (because it is likely to
+ * trigger a segfault if other code is incorrect)
+ *
+ * NOTE: Do NOT do this any earlier or you will
+ * remove the PROTECTive benefit of newvp pointing
+ * to part of the (global) grid state
+ */
+ SET_VECTOR_ELT(gvp, PVP_PARENT, R_NilValue);
+ return R_NilValue;
+}
+
+/* This is similar to L_unsetviewport, except that it will NOT
+ * modify parent-child relations
+ */
+SEXP L_upviewport(SEXP n)
+{
+ int i;
+ double xx1, yy1, xx2, yy2;
+ double devWidthCM, devHeightCM;
+ SEXP parentClip;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ /* Get the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ SEXP gvp = gridStateElement(dd, GSS_VP);
+ SEXP newvp = VECTOR_ELT(gvp, PVP_PARENT);
+ if (isNull(newvp))
+ error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
+ for (i = 1; i < INTEGER(n)[0]; i++) {
+ gvp = newvp;
+ newvp = VECTOR_ELT(gvp, PVP_PARENT);
+ if (isNull(newvp))
+ error(_("cannot pop the top-level viewport ('grid' and 'graphics' output mixed?)"));
+ }
+ /* Get the current device size
+ */
+ getDeviceSize(dd, &devWidthCM, &devHeightCM);
+ if (deviceChanged(devWidthCM, devHeightCM, newvp))
+ calcViewportTransform(newvp, viewportParent(newvp), 1, dd);
+ /*
+ * Enforce the current viewport settings
+ */
+ setGridStateElement(dd, GSS_GPAR, viewportgpar(newvp));
+ /* Set the clipping region to the parent's cur.clip
+ */
+ parentClip = viewportClipRect(newvp);
+ xx1 = REAL(parentClip)[0];
+ yy1 = REAL(parentClip)[1];
+ xx2 = REAL(parentClip)[2];
+ yy2 = REAL(parentClip)[3];
+ GESetClip(xx1, yy1, xx2, yy2, dd);
+#if 0
+ /* This is a VERY short term fix to avoid mucking
+ * with the core graphics during feature freeze
+ * It should be removed post R 1.4 release
+ */
+ dd->dev->clipLeft = fmin2(xx1, xx2);
+ dd->dev->clipRight = fmax2(xx1, xx2);
+ dd->dev->clipTop = fmax2(yy1, yy2);
+ dd->dev->clipBottom = fmin2(yy1, yy2);
+#endif
+ /* Set the value of the current viewport for the current device
+ * Need to do this in here so that redrawing via R BASE display
+ * list works
+ */
+ setGridStateElement(dd, GSS_VP, newvp);
+ return R_NilValue;
+}
+
+SEXP L_getDisplayList()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_DL);
+}
+
+SEXP L_setDisplayList(SEXP dl)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_DL, dl);
+ return R_NilValue;
+}
+
+/*
+ * Get the element at index on the DL
+ */
+SEXP L_getDLelt(SEXP index)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ SEXP dl, result;
+ PROTECT(dl = gridStateElement(dd, GSS_DL));
+ result = VECTOR_ELT(dl, INTEGER(index)[0]);
+ UNPROTECT(1);
+ return result;
+}
+
+/* Add an element to the display list at the current location
+ * Location is maintained in R code
+ */
+SEXP L_setDLelt(SEXP value)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ SEXP dl;
+ PROTECT(dl = gridStateElement(dd, GSS_DL));
+ SET_VECTOR_ELT(dl, INTEGER(gridStateElement(dd, GSS_DLINDEX))[0], value);
+ UNPROTECT(1);
+ return R_NilValue;
+}
+
+SEXP L_getDLindex()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_DLINDEX);
+}
+
+SEXP L_setDLindex(SEXP index)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_DLINDEX, index);
+ return R_NilValue;
+}
+
+SEXP L_getDLon()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_DLON);
+}
+
+SEXP L_setDLon(SEXP value)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ SEXP prev;
+ prev = gridStateElement(dd, GSS_DLON);
+ setGridStateElement(dd, GSS_DLON, value);
+ return prev;
+}
+
+SEXP L_getEngineDLon()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_ENGINEDLON);
+}
+
+SEXP L_setEngineDLon(SEXP value)
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_ENGINEDLON, value);
+ return R_NilValue;
+}
+
+SEXP L_getCurrentGrob()
+{
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_CURRGROB);
+}
+
+SEXP L_setCurrentGrob(SEXP value)
+{
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_CURRGROB, value);
+ return R_NilValue;
+}
+
+SEXP L_getEngineRecording()
+{
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_ENGINERECORDING);
+}
+
+SEXP L_setEngineRecording(SEXP value)
+{
+ pGEDevDesc dd = getDevice();
+ setGridStateElement(dd, GSS_ENGINERECORDING, value);
+ return R_NilValue;
+}
+
+SEXP L_currentGPar()
+{
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ return gridStateElement(dd, GSS_GPAR);
+}
+
+SEXP L_newpagerecording()
+{
+ pGEDevDesc dd = getDevice();
+ if (dd->ask) {
+ NewFrameConfirm(dd->dev);
+ /*
+ * User may have killed device during pause for prompt
+ */
+ if (NoDevices())
+ error(_("attempt to plot on null device"));
+ else
+ /*
+ * Should throw an error if dd != GECurrentDevice ?
+ */
+ dd = GEcurrentDevice();
+ }
+ GEinitDisplayList(dd);
+ return R_NilValue;
+}
+
+SEXP L_newpage()
+{
+ pGEDevDesc dd = getDevice();
+ R_GE_gcontext gc;
+ /*
+ * Has the device been drawn on yet?
+ */
+ Rboolean deviceDirty = GEdeviceDirty(dd);
+ /*
+ * Has the device been drawn on BY GRID yet?
+ */
+ Rboolean deviceGridDirty = LOGICAL(gridStateElement(dd,
+ GSS_GRIDDEVICE))[0];
+ /*
+ * Initialise grid on device
+ * If no drawing on device yet, does a new page
+ */
+ if (!deviceGridDirty) {
+ dirtyGridDevice(dd);
+ }
+ /*
+ * If device has previously been drawn on (by grid or other system)
+ * do a new page
+ */
+ if (deviceGridDirty || deviceDirty) {
+ SEXP currentgp = gridStateElement(dd, GSS_GPAR);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ GENewPage(&gc, dd);
+ }
+ return R_NilValue;
+}
+
+SEXP L_initGPar()
+{
+ pGEDevDesc dd = getDevice();
+ initGPar(dd);
+ return R_NilValue;
+}
+
+SEXP L_initViewportStack()
+{
+ pGEDevDesc dd = getDevice();
+ initVP(dd);
+ return R_NilValue;
+}
+
+SEXP L_initDisplayList()
+{
+ pGEDevDesc dd = getDevice();
+ initDL(dd);
+ return R_NilValue;
+}
+
+void getViewportTransform(SEXP currentvp,
+ pGEDevDesc dd,
+ double *vpWidthCM, double *vpHeightCM,
+ LTransform transform, double *rotationAngle)
+{
+ int i, j;
+ double devWidthCM, devHeightCM;
+ getDeviceSize((dd), &devWidthCM, &devHeightCM) ;
+ if (deviceChanged(devWidthCM, devHeightCM, currentvp)) {
+ /* IF the device has changed, recalculate the viewport transform
+ */
+ calcViewportTransform(currentvp, viewportParent(currentvp), 1, dd);
+ }
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ transform[i][j] =
+ REAL(viewportTransform(currentvp))[i + 3*j];
+ *rotationAngle = REAL(viewportRotation(currentvp))[0];
+ *vpWidthCM = REAL(viewportWidthCM(currentvp))[0];
+ *vpHeightCM = REAL(viewportHeightCM(currentvp))[0];
+}
+
+
+/***************************
+ * CONVERSION FUNCTIONS
+ ***************************
+ */
+
+/*
+ * WITHIN THE CURRENT VIEWPORT ...
+ *
+ * Given a unit object and whether it is a location/dimension,
+ * convert to location/dimension in unit B
+ *
+ * NOTE: When this is used to convert a mouse click on a device to
+ * a location/dimension, the conversion of the mouse click to
+ * a unit within the current viewport has to be done elsewhere.
+ * e.g., in interactive.R, this is done by applying the inverse
+ * of the current viewport transformation to get a location in
+ * inches within the current viewport.
+ *
+ * This should ideally create a unit object to ensure that the
+ * values it returns are treated as values in the correct
+ * coordinate system. For now, this is MUCH easier to do in
+ * R code, so it is the responsibility of the R code calling this
+ * to create the unit object correctly/honestly.
+ *
+ * NOTE also that the unitto supplied should be a "valid" integer
+ * (the best way to get that is to use the valid.units()
+ * function in unit.R)
+ *
+ * what = 0 means x, 1 means y, 2 means width, 3 means height
+ */
+SEXP L_convert(SEXP x, SEXP whatfrom,
+ SEXP whatto, SEXP unitto) {
+ int i, nx;
+ SEXP answer;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ int TOunit, FROMaxis, TOaxis;
+ Rboolean relConvert;
+ /*
+ * Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ /*
+ * We do not need the current transformation, but
+ * we need the side effects of calculating it in
+ * case the device has been resized (or only just created)
+ */
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ nx = unitLength(x);
+ PROTECT(answer = allocVector(REALSXP, nx));
+ for (i=0; i<nx; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ TOunit = INTEGER(unitto)[i % LENGTH(unitto)];
+ FROMaxis = INTEGER(whatfrom)[0];
+ TOaxis = INTEGER(whatto)[0];
+ /*
+ * Special case: FROM unit is just a plain, relative unit AND
+ * TO unit is relative AND
+ * NOT converting from 'x' to 'y' (or vice versa) ...
+ *
+ * ... AND relevant widthCM or heightCM is zero
+ *
+ * In these cases do NOT transform thru INCHES
+ * (to avoid divide-by-zero, but still do something useful)
+ */
+ relConvert = (!isUnitArithmetic(x) && !isUnitList(x) &&
+ (unitUnit(x, i) == L_NATIVE || unitUnit(x, i) == L_NPC) &&
+ (TOunit == L_NATIVE || TOunit == L_NPC) &&
+ ((FROMaxis == TOaxis) ||
+ (FROMaxis == 0 && TOaxis == 2) ||
+ (FROMaxis == 2 && TOaxis == 0) ||
+ (FROMaxis == 1 && TOaxis == 3) ||
+ (FROMaxis == 3 && TOaxis == 1)));
+ /*
+ * First, convert the unit object passed in to a value in INCHES
+ * (within the current viewport)
+ */
+ switch (FROMaxis) {
+ case 0:
+ if (relConvert && vpWidthCM < 1e-6) {
+ REAL(answer)[i] =
+ transformXYtoNPC(unitValue(x, i), unitUnit(x, i),
+ vpc.xscalemin, vpc.xscalemax);
+ } else {
+ relConvert = FALSE;
+ REAL(answer)[i] =
+ transformXtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 1:
+ if (relConvert && vpHeightCM < 1e-6) {
+ REAL(answer)[i] =
+ transformXYtoNPC(unitValue(x, i), unitUnit(x, i),
+ vpc.yscalemin, vpc.yscalemax);
+ } else {
+ relConvert = FALSE;
+ REAL(answer)[i] =
+ transformYtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 2:
+ if (relConvert && vpWidthCM < 1e-6) {
+ REAL(answer)[i] =
+ transformWHtoNPC(unitValue(x, i), unitUnit(x, i),
+ vpc.xscalemin, vpc.xscalemax);
+ } else {
+ relConvert = FALSE;
+ REAL(answer)[i] =
+ transformWidthtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 3:
+ if (relConvert && vpHeightCM < 1e-6) {
+ REAL(answer)[i] =
+ transformWHtoNPC(unitValue(x, i), unitUnit(x, i),
+ vpc.yscalemin, vpc.yscalemax);
+ } else {
+ relConvert = FALSE;
+ REAL(answer)[i] =
+ transformHeighttoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ }
+ /*
+ * Now, convert the values in INCHES to a value in the specified
+ * coordinate system
+ * (within the current viewport)
+ *
+ * BUT do NOT do this step for the special "relConvert" case
+ */
+ switch (TOaxis) {
+ case 0:
+ if (relConvert) {
+ REAL(answer)[i] = transformXYfromNPC(REAL(answer)[i], TOunit,
+ vpc.xscalemin,
+ vpc.xscalemax);
+ } else {
+ REAL(answer)[i] =
+ transformXYFromINCHES(REAL(answer)[i], TOunit,
+ vpc.xscalemin,
+ vpc.xscalemax,
+ &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 1:
+ if (relConvert) {
+ REAL(answer)[i] = transformXYfromNPC(REAL(answer)[i], TOunit,
+ vpc.yscalemin,
+ vpc.yscalemax);
+ } else {
+ REAL(answer)[i] =
+ transformXYFromINCHES(REAL(answer)[i], TOunit,
+ vpc.yscalemin,
+ vpc.yscalemax,
+ &gc,
+ vpHeightCM, vpWidthCM,
+ dd);
+ }
+ break;
+ case 2:
+ if (relConvert) {
+ REAL(answer)[i] = transformWHfromNPC(REAL(answer)[i], TOunit,
+ vpc.xscalemin,
+ vpc.xscalemax);
+ } else {
+ REAL(answer)[i] =
+ transformWidthHeightFromINCHES(REAL(answer)[i], TOunit,
+ vpc.xscalemin,
+ vpc.xscalemax,
+ &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 3:
+ if (relConvert) {
+ REAL(answer)[i] = transformWHfromNPC(REAL(answer)[i], TOunit,
+ vpc.yscalemin,
+ vpc.yscalemax);
+ } else {
+ REAL(answer)[i] =
+ transformWidthHeightFromINCHES(REAL(answer)[i], TOunit,
+ vpc.yscalemin,
+ vpc.yscalemax,
+ &gc,
+ vpHeightCM, vpWidthCM,
+ dd);
+ break;
+ }
+ }
+ }
+ UNPROTECT(1);
+ return answer;
+}
+
+/*
+ * Given a layout.pos.row and a layout.pos.col, calculate
+ * the region allocated by the layout of the current viewport
+ *
+ * Not a conversion as such, but similarly vulnerable to device resizing
+ */
+SEXP L_layoutRegion(SEXP layoutPosRow, SEXP layoutPosCol) {
+ LViewportLocation vpl;
+ SEXP answer;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LTransform transform;
+ SEXP currentvp;
+ /*
+ * Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ //currentgp = gridStateElement(dd, GSS_GPAR);
+ /*
+ * We do not need the current transformation, but
+ * we need the side effects of calculating it in
+ * case the device has been resized (or only just created)
+ */
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ /*
+ * Only proceed if there is a layout currently defined
+ */
+ if (isNull(viewportLayout(currentvp)))
+ error(_("there is no layout defined"));
+ /*
+ * The result is a numeric containing left, bottom, width, and height
+ */
+ PROTECT(answer = allocVector(REALSXP, 4));
+ /*
+ * NOTE: We are assuming here that calcViewportLocationFromLayout
+ * returns the allocated region with a ("left", "bottom")
+ * justification. This is CURRENTLY true, but ...
+ */
+ calcViewportLocationFromLayout(layoutPosRow,
+ layoutPosCol,
+ currentvp,
+ &vpl);
+ /*
+ * I am not returning the units created in C code
+ * because they do not have the units attribute set
+ * so they do not behave nicely back in R code.
+ * Instead, I take the values and my knowledge that they
+ * are NPC units and construct real unit objects back in
+ * R code.
+ */
+ REAL(answer)[0] = unitValue(vpl.x, 0);
+ REAL(answer)[1] = unitValue(vpl.y, 0);
+ REAL(answer)[2] = unitValue(vpl.width, 0);
+ REAL(answer)[3] = unitValue(vpl.height, 0);
+ UNPROTECT(1);
+ return answer;
+}
+
+/***************************
+ * EDGE DETECTION
+ ***************************
+ */
+
+/*
+ * Calculate the point on the edge of a rectangle at angle theta
+ * 0 = East, 180 = West, etc ...
+ * Assumes that x- and y-values are in INCHES
+ * Assumes that theta is within [0, 360)
+ */
+static void rectEdge(double xmin, double ymin, double xmax, double ymax,
+ double theta,
+ double *edgex, double *edgey)
+{
+ double xm = (xmin + xmax)/2;
+ double ym = (ymin + ymax)/2;
+ double dx = (xmax - xmin)/2;
+ double dy = (ymax - ymin)/2;
+ /*
+ * FIXME: Special case 0 width or 0 height
+ */
+ /*
+ * Special case angles
+ */
+ if (theta == 0) {
+ *edgex = xmax;
+ *edgey = ym;
+ } else if (theta == 270) {
+ *edgex = xm;
+ *edgey = ymin;
+ } else if (theta == 180) {
+ *edgex = xmin;
+ *edgey = ym;
+ } else if (theta == 90) {
+ *edgex = xm;
+ *edgey = ymax;
+ } else {
+ double cutoff = dy/dx;
+ double angle = theta/180*M_PI;
+ double tanTheta = tan(angle);
+ double cosTheta = cos(angle);
+ double sinTheta = sin(angle);
+ if (fabs(tanTheta) < cutoff) { /* Intersect with side */
+ if (cosTheta > 0) { /* Right side */
+ *edgex = xmax;
+ *edgey = ym + tanTheta*dx;
+ } else { /* Left side */
+ *edgex = xmin;
+ *edgey = ym - tanTheta*dx;
+ }
+ } else { /* Intersect with top/bottom */
+ if (sinTheta > 0) { /* Top */
+ *edgey = ymax;
+ *edgex = xm + dy/tanTheta;
+ } else { /* Bottom */
+ *edgey = ymin;
+ *edgex = xm - dy/tanTheta;
+ }
+ }
+ }
+}
+
+/*
+ * Calculate the point on the edge of a rectangle at angle theta
+ * 0 = East, 180 = West, etc ...
+ * Assumes that x- and y-values are in INCHES
+ * Assumes that theta is within [0, 360)
+ */
+static void circleEdge(double x, double y, double r,
+ double theta,
+ double *edgex, double *edgey)
+{
+ double angle = theta/180*M_PI;
+ *edgex = x + r*cos(angle);
+ *edgey = y + r*sin(angle);
+}
+
+/*
+ * Calculate the point on the edge of a *convex* polygon at angle theta
+ * 0 = East, 180 = West, etc ...
+ * Assumes that x- and y-values are in INCHES
+ * Assumes that vertices are in clock-wise order
+ * Assumes that theta is within [0, 360)
+ */
+static void polygonEdge(double *x, double *y, int n,
+ double theta,
+ double *edgex, double *edgey) {
+ int i, v1, v2;
+ double xm, ym;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ int found = 0;
+ double angle = theta/180*M_PI;
+ double vangle1, vangle2;
+ /*
+ * Find "centre" of polygon
+ */
+ for (i=0; i<n; i++) {
+ if (x[i] < xmin)
+ xmin = x[i];
+ if (x[i] > xmax)
+ xmax = x[i];
+ if (y[i] < ymin)
+ ymin = y[i];
+ if (y[i] > ymax)
+ ymax = y[i];
+ }
+ xm = (xmin + xmax)/2;
+ ym = (ymin + ymax)/2;
+ /*
+ * Special case zero-width or zero-height
+ */
+ if (fabs(xmin - xmax) < 1e-6) {
+ *edgex = xmin;
+ if (theta == 90)
+ *edgey = ymax;
+ else if (theta == 270)
+ *edgey = ymin;
+ else
+ *edgey = ym;
+ return;
+ }
+ if (fabs(ymin - ymax) < 1e-6) {
+ *edgey = ymin;
+ if (theta == 0)
+ *edgex = xmax;
+ else if (theta == 180)
+ *edgex = xmin;
+ else
+ *edgex = xm;
+ return;
+ }
+ /*
+ * Find edge that intersects line from centre at angle theta
+ */
+ for (i=0; i<n; i++) {
+ v1 = i;
+ v2 = v1 + 1;
+ if (v2 == n)
+ v2 = 0;
+ /*
+ * Result of atan2 is in range -PI, PI so convert to
+ * 0, 360 to correspond to angle
+ */
+ vangle1 = atan2(y[v1] - ym, x[v1] - xm);
+ if (vangle1 < 0)
+ vangle1 = vangle1 + 2*M_PI;
+ vangle2 = atan2(y[v2] - ym, x[v2] - xm);
+ if (vangle2 < 0)
+ vangle2 = vangle2 + 2*M_PI;
+ /*
+ * If vangle1 < vangle2 then angles are either side of 0
+ * so check is more complicated
+ */
+ if ((vangle1 >= vangle2 &&
+ vangle1 >= angle && vangle2 < angle) ||
+ (vangle1 < vangle2 &&
+ ((vangle1 >= angle && 0 <= angle) ||
+ (vangle2 < angle && 2*M_PI >= angle)))) {
+ found = 1;
+ break;
+ }
+ }
+ /*
+ * Find intersection point of "line from centre to bounding rect"
+ * and edge
+ */
+ if (found) {
+ double x1 = xm;
+ double y1 = ym;
+ double x2, y2;
+ double x3 = x[v1];
+ double y3 = y[v1];
+ double x4 = x[v2];
+ double y4 = y[v2];
+ double numa, denom, ua;
+ rectEdge(xmin, ymin, xmax, ymax, theta,
+ &x2, &y2);
+ numa = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
+ denom = ((y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1));
+ ua = numa/denom;
+ if (!R_FINITE(ua)) {
+ /*
+ * Should only happen if lines are parallel, which
+ * shouldn't happen! Unless, perhaps the polygon has
+ * zero extent vertically or horizontally ... ?
+ */
+ error(_("polygon edge not found (zero-width or zero-height?)"));
+ }
+ /*
+ * numb = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
+ * ub = numb/denom;
+ */
+ *edgex = x1 + ua*(x2 - x1);
+ *edgey = y1 + ua*(y2 - y1);
+ } else {
+ error(_("polygon edge not found"));
+ }
+}
+
+/*
+ * Given a set of points, calculate the convex hull then
+ * find the edge of that hull
+ *
+ * NOTE: assumes that 'grDevices' package has been loaded
+ * so that chull() is available (grid depends on grDevices)
+ */
+static void hullEdge(double *x, double *y, int n,
+ double theta,
+ double *edgex, double *edgey)
+{
+ const void *vmax;
+ int i, nh;
+ double *hx, *hy;
+ SEXP xin, yin, chullFn, R_fcall, hull;
+ int adjust = 0;
+ double *xkeep, *ykeep;
+ vmax = vmaxget();
+ /* Remove any NA's because chull() can't cope with them */
+ xkeep = (double *) R_alloc(n, sizeof(double));
+ ykeep = (double *) R_alloc(n, sizeof(double));
+ for (i=0; i<n; i++) {
+ if (!R_FINITE(x[i]) || !R_FINITE(y[i])) {
+ adjust--;
+ } else {
+ xkeep[i + adjust] = x[i];
+ ykeep[i + adjust] = y[i];
+ }
+ }
+ n = n + adjust;
+ PROTECT(xin = allocVector(REALSXP, n));
+ PROTECT(yin = allocVector(REALSXP, n));
+ for (i=0; i<n; i++) {
+ REAL(xin)[i] = xkeep[i];
+ REAL(yin)[i] = ykeep[i];
+ }
+ /*
+ * Determine convex hull
+ */
+ PROTECT(chullFn = findFun(install("chull"), R_gridEvalEnv));
+ PROTECT(R_fcall = lang3(chullFn, xin, yin));
+ PROTECT(hull = eval(R_fcall, R_gridEvalEnv));
+ nh = LENGTH(hull);
+ hx = (double *) R_alloc(nh, sizeof(double));
+ hy = (double *) R_alloc(nh, sizeof(double));
+ for (i=0; i<nh; i++) {
+ hx[i] = x[INTEGER(hull)[i] - 1];
+ hy[i] = y[INTEGER(hull)[i] - 1];
+ }
+ /*
+ * Find edge of that hull
+ */
+ polygonEdge(hx, hy, nh, theta,
+ edgex, edgey);
+ vmaxset(vmax);
+ UNPROTECT(5);
+}
+
+/***************************
+ * DRAWING PRIMITIVES
+ ***************************
+ */
+
+/*
+ * Draw an arrow head, given the vertices of the arrow head.
+ * Assume vertices are in DEVICE coordinates.
+ */
+static void drawArrow(double *x, double *y, SEXP type, int i,
+ const pGEcontext gc, pGEDevDesc dd)
+{
+ int nt = LENGTH(type);
+ switch (INTEGER(type)[i % nt]) {
+ case 1:
+ GEPolyline(3, x, y, gc, dd);
+ break;
+ case 2:
+ GEPolygon(3, x, y, gc, dd);
+ break;
+ }
+}
+
+/*
+ * Calculate vertices for drawing an arrow head.
+ * Assumes that x and y locations are in INCHES.
+ * Returns vertices in DEVICE coordinates.
+ */
+static void calcArrow(double x1, double y1,
+ double x2, double y2,
+ SEXP angle, SEXP length, int i,
+ LViewportContext vpc,
+ double vpWidthCM, double vpHeightCM,
+ double *vertx, double *verty,
+ const pGEcontext gc, pGEDevDesc dd)
+{
+ int na = LENGTH(angle);
+ int nl = LENGTH(length);
+ double xc, yc, rot;
+ double l1, l2, l, a;
+ l1 = transformWidthtoINCHES(length, i % nl, vpc, gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ l2 = transformHeighttoINCHES(length, i % nl, vpc, gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ l = fmin2(l1, l2);
+ a = DEG2RAD * REAL(angle)[i % na];
+ xc = x2 - x1;
+ yc = y2 - y1;
+ rot= atan2(yc, xc);
+ vertx[0] = toDeviceX(x1 + l * cos(rot+a),
+ GE_INCHES, dd);
+ verty[0] = toDeviceY(y1 + l * sin(rot+a),
+ GE_INCHES, dd);
+ vertx[1] = toDeviceX(x1,
+ GE_INCHES, dd);
+ verty[1] = toDeviceY(y1,
+ GE_INCHES, dd);
+ vertx[2] = toDeviceX(x1 + l * cos(rot-a),
+ GE_INCHES, dd);
+ verty[2] = toDeviceY(y1 + l * sin(rot-a),
+ GE_INCHES, dd);
+}
+
+/*
+ * Assumes x and y are at least length 2
+ * Also assumes x and y are in DEVICE coordinates
+ */
+static void arrows(double *x, double *y, int n,
+ SEXP arrow, int i,
+ /*
+ * Which ends we are allowed to draw arrow heads on
+ * (we may be drawing a line segment that has been
+ * broken by NAs)
+ */
+ Rboolean start, Rboolean end,
+ LViewportContext vpc,
+ double vpWidthCM, double vpHeightCM,
+ const pGEcontext gc, pGEDevDesc dd)
+{
+ /*
+ * Write a checkArrow() function to make
+ * sure 'a' is a valid arrow description ?
+ * If someone manages to sneak in a
+ * corrupt arrow description ... BOOM!
+ */
+ SEXP ends = VECTOR_ELT(arrow, GRID_ARROWENDS);
+ int ne = LENGTH(ends);
+ double vertx[3], verty[3];
+ Rboolean first, last;
+ if (n < 2)
+ error(_("require at least two points to draw arrow"));
+ first = TRUE;
+ last = TRUE;
+ switch (INTEGER(ends)[i % ne]) {
+ case 2:
+ first = FALSE;
+ break;
+ case 1:
+ last = FALSE;
+ break;
+ }
+ if (first && start) {
+ calcArrow(fromDeviceX(x[0], GE_INCHES, dd),
+ fromDeviceY(y[0], GE_INCHES, dd),
+ fromDeviceX(x[1], GE_INCHES, dd),
+ fromDeviceY(y[1], GE_INCHES, dd),
+ VECTOR_ELT(arrow, GRID_ARROWANGLE),
+ VECTOR_ELT(arrow, GRID_ARROWLENGTH),
+ i, vpc, vpWidthCM, vpHeightCM, vertx, verty, gc, dd);
+ drawArrow(vertx, verty,
+ VECTOR_ELT(arrow, GRID_ARROWTYPE), i,
+ gc, dd);
+ }
+ if (last && end) {
+ calcArrow(fromDeviceX(x[n - 1], GE_INCHES, dd),
+ fromDeviceY(y[n - 1], GE_INCHES, dd),
+ fromDeviceX(x[n - 2], GE_INCHES, dd),
+ fromDeviceY(y[n - 2], GE_INCHES, dd),
+ VECTOR_ELT(arrow, GRID_ARROWANGLE),
+ VECTOR_ELT(arrow, GRID_ARROWLENGTH),
+ i, vpc, vpWidthCM, vpHeightCM, vertx, verty, gc, dd);
+ drawArrow(vertx, verty,
+ VECTOR_ELT(arrow, GRID_ARROWTYPE), i,
+ gc, dd);
+ }
+}
+
+SEXP L_moveTo(SEXP x, SEXP y)
+{
+ double xx, yy;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP devloc, prevloc;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ PROTECT(prevloc = gridStateElement(dd, GSS_PREVLOC));
+ PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ /* Convert the x and y values to CM locations */
+ transformLocn(x, y, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ /*
+ * Non-finite values are ok here
+ * L_lineTo figures out what to draw
+ * when values are non-finite
+ */
+ REAL(prevloc)[0] = REAL(devloc)[0];
+ REAL(prevloc)[1] = REAL(devloc)[1];
+ REAL(devloc)[0] = xx;
+ REAL(devloc)[1] = yy;
+ UNPROTECT(2);
+ return R_NilValue;
+}
+
+SEXP L_lineTo(SEXP x, SEXP y, SEXP arrow)
+{
+ double xx0, yy0, xx1, yy1;
+ double xx, yy;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP devloc, prevloc;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ PROTECT(prevloc = gridStateElement(dd, GSS_PREVLOC));
+ PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ /* Convert the x and y values to CM locations */
+ transformLocn(x, y, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ REAL(prevloc)[0] = REAL(devloc)[0];
+ REAL(prevloc)[1] = REAL(devloc)[1];
+ REAL(devloc)[0] = xx;
+ REAL(devloc)[1] = yy;
+ /* The graphics engine only takes device coordinates
+ */
+ xx0 = toDeviceX(REAL(prevloc)[0], GE_INCHES, dd);
+ yy0 = toDeviceY(REAL(prevloc)[1], GE_INCHES, dd),
+ xx1 = toDeviceX(xx, GE_INCHES, dd);
+ yy1 = toDeviceY(yy, GE_INCHES, dd);
+ if (R_FINITE(xx0) && R_FINITE(yy0) &&
+ R_FINITE(xx1) && R_FINITE(yy1)) {
+ GEMode(1, dd);
+ GELine(xx0, yy0, xx1, yy1, &gc, dd);
+ if (!isNull(arrow)) {
+ double ax[2], ay[2];
+ ax[0] = xx0;
+ ax[1] = xx1;
+ ay[0] = yy0;
+ ay[1] = yy1;
+ arrows(ax, ay, 2,
+ arrow, 0, TRUE, TRUE,
+ vpc, vpWidthCM, vpHeightCM, &gc, dd);
+ }
+ GEMode(0, dd);
+ }
+ UNPROTECT(2);
+ return R_NilValue;
+}
+
+/* We are assuming here that the R code has checked that x and y
+ * are unit objects and that vp is a viewport
+ */
+SEXP L_lines(SEXP x, SEXP y, SEXP index, SEXP arrow)
+{
+ int i, j, nx, nl, start=0;
+ double *xx, *yy;
+ double xold, yold;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ const void *vmax;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ GEMode(1, dd);
+ /*
+ * Number of lines
+ */
+ nl = LENGTH(index);
+ for (j=0; j<nl; j++) {
+ SEXP indices = VECTOR_ELT(index, j);
+ gcontextFromgpar(currentgp, j, &gc, dd);
+ /*
+ * Number of vertices
+ *
+ * x and y same length forced in R code
+ */
+ nx = LENGTH(indices);
+ /* Convert the x and y values to CM locations */
+ vmax = vmaxget();
+ xx = (double *) R_alloc(nx, sizeof(double));
+ yy = (double *) R_alloc(nx, sizeof(double));
+ xold = NA_REAL;
+ yold = NA_REAL;
+ for (i=0; i<nx; i++) {
+ transformLocn(x, y, INTEGER(indices)[i] - 1, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[i]), &(yy[i]));
+ /* The graphics engine only takes device coordinates
+ */
+ xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
+ yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
+ if ((R_FINITE(xx[i]) && R_FINITE(yy[i])) &&
+ !(R_FINITE(xold) && R_FINITE(yold)))
+ start = i;
+ else if ((R_FINITE(xold) && R_FINITE(yold)) &&
+ !(R_FINITE(xx[i]) && R_FINITE(yy[i]))) {
+ if (i-start > 1) {
+ GEPolyline(i-start, xx+start, yy+start, &gc, dd);
+ if (!isNull(arrow)) {
+ /*
+ * Can draw an arrow at the start if the points
+ * include the first point.
+ * CANNOT draw an arrow at the end point
+ * because we have just broken the line for an NA.
+ */
+ arrows(xx+start, yy+start, i-start,
+ arrow, j, start == 0, FALSE,
+ vpc, vpWidthCM, vpHeightCM, &gc, dd);
+ }
+ }
+ }
+ else if ((R_FINITE(xold) && R_FINITE(yold)) &&
+ (i == nx-1)) {
+ GEPolyline(nx-start, xx+start, yy+start, &gc, dd);
+ if (!isNull(arrow)) {
+ /*
+ * Can draw an arrow at the start if the points
+ * include the first point.
+ * Can draw an arrow at the end point.
+ */
+ arrows(xx+start, yy+start, nx-start,
+ arrow, j, start == 0, TRUE,
+ vpc, vpWidthCM, vpHeightCM, &gc, dd);
+ }
+ }
+ xold = xx[i];
+ yold = yy[i];
+ }
+ vmaxset(vmax);
+ }
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+/* We are assuming here that the R code has checked that x and y
+ * are unit objects
+ */
+SEXP gridXspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index,
+ double theta, Rboolean draw, Rboolean trace)
+{
+ int i, j, nx, np, nloc;
+ double *xx, *yy, *ss;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP tracePts = R_NilValue;
+ SEXP result = R_NilValue;
+ double edgex, edgey;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ /*
+ * Number of xsplines
+ */
+ np = LENGTH(index);
+ PROTECT(tracePts = allocVector(VECSXP, np));
+ nloc = 0;
+ for (i=0; i<np; i++) {
+ const void *vmax;
+ SEXP indices = VECTOR_ELT(index, i);
+ SEXP points;
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * Number of vertices
+ *
+ * Check in R code that x and y same length
+ */
+ nx = LENGTH(indices);
+ /* Convert the x and y values to CM locations */
+ vmax = vmaxget();
+ if (draw)
+ GEMode(1, dd);
+ xx = (double *) R_alloc(nx, sizeof(double));
+ yy = (double *) R_alloc(nx, sizeof(double));
+ ss = (double *) R_alloc(nx, sizeof(double));
+ for (j=0; j<nx; j++) {
+ ss[j] = REAL(s)[(INTEGER(indices)[j] - 1) % LENGTH(s)];
+ /*
+ * If drawing, convert to INCHES on device
+ * If just calculating bounds, convert to INCHES within current vp
+ */
+ if (draw) {
+ transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[j]), &(yy[j]));
+ } else {
+ xx[j] = transformXtoINCHES(x, INTEGER(indices)[j] - 1,
+ vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ yy[j] = transformYtoINCHES(y, INTEGER(indices)[j] - 1,
+ vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ /* The graphics engine only takes device coordinates
+ */
+ xx[j] = toDeviceX(xx[j], GE_INCHES, dd);
+ yy[j] = toDeviceY(yy[j], GE_INCHES, dd);
+ if (!(R_FINITE(xx[j]) && R_FINITE(yy[j]))) {
+ error(_("non-finite control point in Xspline"));
+ }
+ }
+ PROTECT(points = GEXspline(nx, xx, yy, ss,
+ LOGICAL(o)[0], LOGICAL(rep)[0],
+ draw, &gc, dd));
+ {
+ /*
+ * In some cases, GEXspline seems to produce identical points
+ * (at least observed at end of spline)
+ * so trim identical points from the ends
+ * (so arrow heads are drawn at correct angle)
+ */
+ int np = LENGTH(VECTOR_ELT(points, 0));
+ double *px = REAL(VECTOR_ELT(points, 0));
+ double *py = REAL(VECTOR_ELT(points, 1));
+ int start = 0;
+ int end = np - 1;
+ /*
+ * DEBUGGING ...
+ int k;
+ for (k=0; k<np; k++) {
+ GESymbol(px[k], py[k], 16, 3, &gc, dd);
+ }
+ * ... DEBUGGING
+ */
+ while (np > 1 &&
+ (px[start] == px[start + 1]) &&
+ (py[start] == py[start + 1])) {
+ start++;
+ np--;
+ }
+ while (np > 1 &&
+ (px[end] == px[end - 1]) &&
+ (py[end] == py[end - 1])) {
+ end--;
+ np--;
+ }
+ if (trace) {
+ int k;
+ int count = end - start + 1;
+ double *keepXptr, *keepYptr;
+ SEXP keepPoints, keepX, keepY;
+ PROTECT(keepPoints = allocVector(VECSXP, 2));
+ PROTECT(keepX = allocVector(REALSXP, count));
+ PROTECT(keepY = allocVector(REALSXP, count));
+ keepXptr = REAL(keepX);
+ keepYptr = REAL(keepY);
+ for (k=start; k<(end + 1); k++) {
+ keepXptr[k - start] = fromDeviceX(px[k], GE_INCHES, dd);
+ keepYptr[k - start] = fromDeviceY(py[k], GE_INCHES, dd);
+ }
+ SET_VECTOR_ELT(keepPoints, 0, keepX);
+ SET_VECTOR_ELT(keepPoints, 1, keepY);
+ SET_VECTOR_ELT(tracePts, i, keepPoints);
+ UNPROTECT(3); /* keepPoints & keepX & keepY */
+ }
+ if (draw && !isNull(a) && !isNull(points)) {
+ /*
+ * Can draw an arrow at the either end.
+ */
+ arrows(&(px[start]), &(py[start]), np,
+ a, i, TRUE, TRUE,
+ vpc, vpWidthCM, vpHeightCM, &gc, dd);
+ }
+ if (!draw && !trace && !isNull(points)) {
+ /*
+ * Update bounds
+ */
+ int j, n = LENGTH(VECTOR_ELT(points, 0));
+ double *pxx = (double *) R_alloc(n, sizeof(double));
+ double *pyy = (double *) R_alloc(n, sizeof(double));
+ for (j=0; j<n; j++) {
+ pxx[j] = fromDeviceX(px[j], GE_INCHES, dd);
+ pyy[j] = fromDeviceY(py[j], GE_INCHES, dd);
+ if (R_FINITE(pxx[j]) && R_FINITE(pyy[j])) {
+ if (pxx[j] < xmin)
+ xmin = pxx[j];
+ if (pxx[j] > xmax)
+ xmax = pxx[j];
+ if (pyy[j] < ymin)
+ ymin = pyy[j];
+ if (pyy[j] > ymax)
+ ymax = pyy[j];
+ nloc++;
+ }
+ }
+ /*
+ * Calculate edgex and edgey for case where this is
+ * the only xspline
+ */
+ hullEdge(pxx, pyy, n, theta, &edgex, &edgey);
+ }
+ } /* End of trimming-redundant-points code */
+ UNPROTECT(1); /* points */
+ if (draw)
+ GEMode(0, dd);
+ vmaxset(vmax);
+ }
+ if (!draw && !trace && nloc > 0) {
+ PROTECT(result = allocVector(REALSXP, 4));
+ /*
+ * If there is more than one xspline, just produce edge
+ * based on bounding rect of all xsplines
+ */
+ if (np > 1) {
+ rectEdge(xmin, ymin, xmax, ymax, theta,
+ &edgex, &edgey);
+ }
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(result)[0] = edgex /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[1] = edgey /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[2] = (xmax - xmin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[3] = (ymax - ymin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ UNPROTECT(1); /* result */
+ } else if (trace) {
+ result = tracePts;
+ }
+ UNPROTECT(1); /* tracePts */
+ return result;
+}
+
+SEXP L_xspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index)
+{
+ gridXspline(x, y, s, o, a, rep, index, 0, TRUE, FALSE);
+ return R_NilValue;
+}
+
+SEXP L_xsplineBounds(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
+ SEXP index, SEXP theta)
+{
+ return gridXspline(x, y, s, o, a, rep, index, REAL(theta)[0],
+ FALSE, FALSE);
+}
+
+SEXP L_xsplinePoints(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
+ SEXP index, SEXP theta)
+{
+ return gridXspline(x, y, s, o, a, rep, index, REAL(theta)[0],
+ FALSE, TRUE);
+}
+
+SEXP L_segments(SEXP x0, SEXP y0, SEXP x1, SEXP y1, SEXP arrow)
+{
+ int i, nx0, ny0, nx1, ny1, maxn;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ maxn = nx0 = unitLength(x0);
+ ny0 = unitLength(y0);
+ nx1 = unitLength(x1);
+ ny1 = unitLength(y1);
+ if (ny0 > maxn)
+ maxn = ny0;
+ if (nx1 > maxn)
+ maxn = nx1;
+ if (ny1 > maxn)
+ maxn = ny1;
+ /* Convert the x and y values to INCHES locations */
+ /* FIXME: Need to check for NaN's and NA's
+ */
+ GEMode(1, dd);
+ for (i=0; i<maxn; i++) {
+ double xx0, yy0, xx1, yy1;
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ transformLocn(x0, y0, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xx0, &yy0);
+ transformLocn(x1, y1, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xx1, &yy1);
+ /* The graphics engine only takes device coordinates
+ */
+ xx0 = toDeviceX(xx0, GE_INCHES, dd);
+ yy0 = toDeviceY(yy0, GE_INCHES, dd);
+ xx1 = toDeviceX(xx1, GE_INCHES, dd);
+ yy1 = toDeviceY(yy1, GE_INCHES, dd);
+ if (R_FINITE(xx0) && R_FINITE(yy0) &&
+ R_FINITE(xx1) && R_FINITE(yy1)) {
+ GELine(xx0, yy0, xx1, yy1, &gc, dd);
+ if (!isNull(arrow)) {
+ double ax[2], ay[2];
+ ax[0] = xx0;
+ ax[1] = xx1;
+ ay[0] = yy0;
+ ay[1] = yy1;
+ arrows(ax, ay, 2,
+ arrow, i, TRUE, TRUE,
+ vpc, vpWidthCM, vpHeightCM, &gc, dd);
+ }
+ }
+ }
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+static int getArrowN(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
+ SEXP y1, SEXP y2, SEXP ynm1, SEXP yn)
+{
+ int nx2, nxnm1, nxn, ny1, ny2, nynm1, nyn, maxn;
+ maxn = 0;
+ /*
+ * x1, y1, xnm1, and ynm1 could be NULL if this is adding
+ * arrows to a line.to
+ */
+ if (isNull(y1))
+ ny1 = 0;
+ else
+ ny1 = unitLength(y1);
+ nx2 = unitLength(x2);
+ ny2 = unitLength(y2);
+ if (isNull(xnm1))
+ nxnm1 = 0;
+ else
+ nxnm1 = unitLength(xnm1);
+ if (isNull(ynm1))
+ nynm1 = 0;
+ else
+ nynm1 = unitLength(ynm1);
+ nxn = unitLength(xn);
+ nyn = unitLength(yn);
+ if (ny1 > maxn)
+ maxn = ny1;
+ if (nx2 > maxn)
+ maxn = nx2;
+ if (ny2 > maxn)
+ maxn = ny2;
+ if (nxnm1 > maxn)
+ maxn = nxnm1;
+ if (nynm1 > maxn)
+ maxn = nynm1;
+ if (nxn > maxn)
+ maxn = nxn;
+ if (nyn > maxn)
+ maxn = nyn;
+ return maxn;
+}
+
+SEXP L_arrows(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
+ SEXP y1, SEXP y2, SEXP ynm1, SEXP yn,
+ SEXP angle, SEXP length, SEXP ends, SEXP type)
+{
+ int i, maxn;
+ int ne;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ Rboolean first, last;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP devloc = R_NilValue; /* -Wall */
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ maxn = getArrowN(x1, x2, xnm1, xn,
+ y1, y2, ynm1, yn);
+ ne = LENGTH(ends);
+ /* Convert the x and y values to INCHES locations */
+ /* FIXME: Need to check for NaN's and NA's
+ */
+ GEMode(1, dd);
+ for (i=0; i<maxn; i++) {
+ double xx1, xx2, xxnm1, xxn, yy1, yy2, yynm1, yyn;
+ double vertx[3];
+ double verty[3];
+ first = TRUE;
+ last = TRUE;
+ switch (INTEGER(ends)[i % ne]) {
+ case 2:
+ first = FALSE;
+ break;
+ case 1:
+ last = FALSE;
+ break;
+ }
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * If we're adding arrows to a line.to
+ * x1 will be NULL
+ */
+ if (isNull(x1))
+ PROTECT(devloc = gridStateElement(dd, GSS_CURRLOC));
+ if (first) {
+ if (isNull(x1)) {
+ xx1 = REAL(devloc)[0];
+ yy1 = REAL(devloc)[1];
+ } else
+ transformLocn(x1, y1, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xx1, &yy1);
+ transformLocn(x2, y2, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xx2, &yy2);
+ calcArrow(xx1, yy1, xx2, yy2, angle, length, i,
+ vpc, vpWidthCM, vpHeightCM,
+ vertx, verty, &gc, dd);
+ /*
+ * Only draw arrow if both ends of first segment
+ * are not non-finite
+ */
+ if (R_FINITE(toDeviceX(xx2, GE_INCHES, dd)) &&
+ R_FINITE(toDeviceY(yy2, GE_INCHES, dd)) &&
+ R_FINITE(vertx[1]) && R_FINITE(verty[1]))
+ drawArrow(vertx, verty, type, i, &gc, dd);
+ }
+ if (last) {
+ if (isNull(xnm1)) {
+ xxnm1 = REAL(devloc)[0];
+ yynm1 = REAL(devloc)[1];
+ } else
+ transformLocn(xnm1, ynm1, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xxnm1, &yynm1);
+ transformLocn(xn, yn, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, transform, &xxn, &yyn);
+ calcArrow(xxn, yyn, xxnm1, yynm1, angle, length, i,
+ vpc, vpWidthCM, vpHeightCM,
+ vertx, verty, &gc, dd);
+ /*
+ * Only draw arrow if both ends of laste segment are
+ * not non-finite
+ */
+ if (R_FINITE(toDeviceX(xxnm1, GE_INCHES, dd)) &&
+ R_FINITE(toDeviceY(yynm1, GE_INCHES, dd)) &&
+ R_FINITE(vertx[1]) && R_FINITE(verty[1]))
+ drawArrow(vertx, verty, type, i, &gc, dd);
+ }
+ if (isNull(x1))
+ UNPROTECT(1);
+ }
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+SEXP L_polygon(SEXP x, SEXP y, SEXP index)
+{
+ int i, j, nx, np, start=0;
+ double *xx, *yy;
+ double xold, yold;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ GEMode(1, dd);
+ /*
+ * Number of polygons
+ */
+ np = LENGTH(index);
+ for (i=0; i<np; i++) {
+ const void *vmax;
+ SEXP indices = VECTOR_ELT(index, i);
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * Number of vertices
+ *
+ * Check in R code that x and y same length
+ */
+ nx = LENGTH(indices);
+ /* Convert the x and y values to CM locations */
+ vmax = vmaxget();
+ xx = (double *) R_alloc(nx + 1, sizeof(double));
+ yy = (double *) R_alloc(nx + 1, sizeof(double));
+ xold = NA_REAL;
+ yold = NA_REAL;
+ for (j=0; j<nx; j++) {
+ transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[j]), &(yy[j]));
+ /* The graphics engine only takes device coordinates
+ */
+ xx[j] = toDeviceX(xx[j], GE_INCHES, dd);
+ yy[j] = toDeviceY(yy[j], GE_INCHES, dd);
+ if ((R_FINITE(xx[j]) && R_FINITE(yy[j])) &&
+ !(R_FINITE(xold) && R_FINITE(yold)))
+ start = j; /* first point of current segment */
+ else if ((R_FINITE(xold) && R_FINITE(yold)) &&
+ !(R_FINITE(xx[j]) && R_FINITE(yy[j]))) {
+ if (j-start > 1) {
+ GEPolygon(j-start, xx+start, yy+start, &gc, dd);
+ }
+ }
+ else if ((R_FINITE(xold) && R_FINITE(yold)) && (j == nx-1)) {
+ /* last */
+ GEPolygon(nx-start, xx+start, yy+start, &gc, dd);
+ }
+ xold = xx[j];
+ yold = yy[j];
+ }
+ vmaxset(vmax);
+ }
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+static SEXP gridCircle(SEXP x, SEXP y, SEXP r,
+ double theta, Rboolean draw)
+{
+ int i, nx, ny, nr, ncirc;
+ double xx, yy, rr1, rr2, rr = 0.0 /* -Wall */;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP result = R_NilValue;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ double edgex, edgey;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ nx = unitLength(x);
+ ny = unitLength(y);
+ nr = unitLength(r);
+ if (ny > nx)
+ nx = ny;
+ if (nr > nx)
+ nx = nr;
+ if (draw) {
+ GEMode(1, dd);
+ }
+ ncirc = 0;
+ for (i=0; i<nx; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * If drawing, convert to INCHES on device
+ * If just calculating bounds, convert to INCHES within current vp
+ */
+ if (draw) {
+ transformLocn(x, y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ } else {
+ xx = transformXtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ yy = transformYtoINCHES(y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ /* These two will give the same answer unless r is in "native",
+ * "npc", or some other relative units; in those cases, just
+ * take the smaller of the two values.
+ */
+ rr1 = transformWidthtoINCHES(r, i % nr, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ rr2 = transformHeighttoINCHES(r, i % nr, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ /*
+ * A negative radius is silently converted to absolute value
+ */
+ rr = fmin2(fabs(rr1), fabs(rr2));
+ if (R_FINITE(xx) && R_FINITE(yy) && R_FINITE(rr)) {
+ if (draw) {
+ /* The graphics engine only takes device coordinates
+ */
+ xx = toDeviceX(xx, GE_INCHES, dd);
+ yy = toDeviceY(yy, GE_INCHES, dd);
+ rr = toDeviceWidth(rr, GE_INCHES, dd);
+ GECircle(xx, yy, rr, &gc, dd);
+ } else {
+ if (xx + rr < xmin)
+ xmin = xx + rr;
+ if (xx + rr > xmax)
+ xmax = xx + rr;
+ if (xx - rr < xmin)
+ xmin = xx - rr;
+ if (xx - rr > xmax)
+ xmax = xx - rr;
+ if (yy + rr < ymin)
+ ymin = yy + rr;
+ if (yy + rr > ymax)
+ ymax = yy + rr;
+ if (yy - rr < ymin)
+ ymin = yy - rr;
+ if (yy - rr > ymax)
+ ymax = yy - rr;
+ ncirc++;
+ }
+ }
+ }
+ if (draw) {
+ GEMode(0, dd);
+ } else if (ncirc > 0) {
+ result = allocVector(REALSXP, 4);
+ if (ncirc == 1) {
+ /*
+ * Produce edge of actual circle
+ */
+ circleEdge(xx, yy, rr, theta, &edgex, &edgey);
+ } else {
+ /*
+ * Produce edge of rect bounding all circles
+ */
+ rectEdge(xmin, ymin, xmax, ymax, theta,
+ &edgex, &edgey);
+ }
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(result)[0] = edgex /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[1] = edgey /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[2] = (xmax - xmin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[3] = (ymax - ymin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ }
+ return result;
+}
+
+SEXP L_circle(SEXP x, SEXP y, SEXP r)
+{
+ gridCircle(x, y, r, 0, TRUE);
+ return R_NilValue;
+}
+
+SEXP L_circleBounds(SEXP x, SEXP y, SEXP r, SEXP theta)
+{
+ return gridCircle(x, y, r, REAL(theta)[0], FALSE);
+}
+
+/* We are assuming here that the R code has checked that
+ * x, y, w, and h are all unit objects and that vp is a viewport
+ */
+static SEXP gridRect(SEXP x, SEXP y, SEXP w, SEXP h,
+ SEXP hjust, SEXP vjust, double theta, Rboolean draw)
+{
+ double xx, yy, ww, hh;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ int i, ny, nw, nh, maxn, nrect;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP result = R_NilValue;
+ double edgex, edgey;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ maxn = unitLength(x);
+ ny = unitLength(y);
+ nw = unitLength(w);
+ nh = unitLength(h);
+ if (ny > maxn)
+ maxn = ny;
+ if (nw > maxn)
+ maxn = nw;
+ if (nh > maxn)
+ maxn = nh;
+ if (draw) {
+ GEMode(1, dd);
+ }
+ nrect = 0;
+ for (i=0; i<maxn; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * If drawing, convert to INCHES on device
+ * If just calculating bounds, convert to INCHES within current vp
+ */
+ if (draw) {
+ transformLocn(x, y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ } else {
+ xx = transformXtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ yy = transformYtoINCHES(y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ ww = transformWidthtoINCHES(w, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ hh = transformHeighttoINCHES(h, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ /* If the total rotation angle is zero then we can draw a
+ * rectangle as the devices understand rectangles
+ * Otherwise we have to draw a polygon equivalent.
+ */
+ if (draw) {
+ if (rotationAngle == 0) {
+ xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
+ yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
+ /* The graphics engine only takes device coordinates
+ */
+ xx = toDeviceX(xx, GE_INCHES, dd);
+ yy = toDeviceY(yy, GE_INCHES, dd);
+ ww = toDeviceWidth(ww, GE_INCHES, dd);
+ hh = toDeviceHeight(hh, GE_INCHES, dd);
+ if (R_FINITE(xx) && R_FINITE(yy) &&
+ R_FINITE(ww) && R_FINITE(hh))
+ GERect(xx, yy, xx + ww, yy + hh, &gc, dd);
+ } else {
+ /* We have to do a little bit of work to figure out where the
+ * corners of the rectangle are.
+ */
+ double xxx[5], yyy[5], xadj, yadj;
+ double dw, dh;
+ SEXP zeroInches, xadjInches, yadjInches, wwInches, hhInches;
+ int tmpcol;
+ PROTECT(zeroInches = unit(0, L_INCHES));
+ /* Find bottom-left location */
+ justification(ww, hh,
+ REAL(hjust)[i % LENGTH(hjust)],
+ REAL(vjust)[i % LENGTH(vjust)],
+ &xadj, &yadj);
+ PROTECT(xadjInches = unit(xadj, L_INCHES));
+ PROTECT(yadjInches = unit(yadj, L_INCHES));
+ transformDimn(xadjInches, yadjInches, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, rotationAngle,
+ &dw, &dh);
+ xxx[0] = xx + dw;
+ yyy[0] = yy + dh;
+ /* Find top-left location */
+ PROTECT(hhInches = unit(hh, L_INCHES));
+ transformDimn(zeroInches, hhInches, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, rotationAngle,
+ &dw, &dh);
+ xxx[1] = xxx[0] + dw;
+ yyy[1] = yyy[0] + dh;
+ /* Find top-right location */
+ PROTECT(wwInches = unit(ww, L_INCHES));
+ transformDimn(wwInches, hhInches, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, rotationAngle,
+ &dw, &dh);
+ xxx[2] = xxx[0] + dw;
+ yyy[2] = yyy[0] + dh;
+ /* Find bottom-right location */
+ transformDimn(wwInches, zeroInches, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, rotationAngle,
+ &dw, &dh);
+ xxx[3] = xxx[0] + dw;
+ yyy[3] = yyy[0] + dh;
+ if (R_FINITE(xxx[0]) && R_FINITE(yyy[0]) &&
+ R_FINITE(xxx[1]) && R_FINITE(yyy[1]) &&
+ R_FINITE(xxx[2]) && R_FINITE(yyy[2]) &&
+ R_FINITE(xxx[3]) && R_FINITE(yyy[3])) {
+ /* The graphics engine only takes device coordinates
+ */
+ xxx[0] = toDeviceX(xxx[0], GE_INCHES, dd);
+ yyy[0] = toDeviceY(yyy[0], GE_INCHES, dd);
+ xxx[1] = toDeviceX(xxx[1], GE_INCHES, dd);
+ yyy[1] = toDeviceY(yyy[1], GE_INCHES, dd);
+ xxx[2] = toDeviceX(xxx[2], GE_INCHES, dd);
+ yyy[2] = toDeviceY(yyy[2], GE_INCHES, dd);
+ xxx[3] = toDeviceX(xxx[3], GE_INCHES, dd);
+ yyy[3] = toDeviceY(yyy[3], GE_INCHES, dd);
+ /* Close the polygon */
+ xxx[4] = xxx[0];
+ yyy[4] = yyy[0];
+ /* Do separate fill and border to avoid border being
+ * drawn on clipping boundary when there is a fill
+ */
+ tmpcol = gc.col;
+ gc.col = R_TRANWHITE;
+ GEPolygon(5, xxx, yyy, &gc, dd);
+ gc.col = tmpcol;
+ gc.fill = R_TRANWHITE;
+ GEPolygon(5, xxx, yyy, &gc, dd);
+ }
+ UNPROTECT(5);
+ }
+ } else { /* Just calculating boundary */
+ xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
+ yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
+ if (R_FINITE(xx) && R_FINITE(yy) &&
+ R_FINITE(ww) && R_FINITE(hh)) {
+ if (xx < xmin)
+ xmin = xx;
+ if (xx > xmax)
+ xmax = xx;
+ if (xx + ww < xmin)
+ xmin = xx + ww;
+ if (xx + ww > xmax)
+ xmax = xx + ww;
+ if (yy < ymin)
+ ymin = yy;
+ if (yy > ymax)
+ ymax = yy;
+ if (yy + hh < ymin)
+ ymin = yy + hh;
+ if (yy + hh > ymax)
+ ymax = yy + hh;
+ /*
+ * Calculate edgex and edgey for case where this is
+ * the only rect
+ */
+ rectEdge(xx, yy, xx + ww, yy + hh, theta,
+ &edgex, &edgey);
+ nrect++;
+ }
+ }
+ }
+ if (draw) {
+ GEMode(0, dd);
+ }
+ if (nrect > 0) {
+ result = allocVector(REALSXP, 4);
+ /*
+ * If there is more than one rect, just produce edge
+ * based on bounding rect of all rects
+ */
+ if (nrect > 1) {
+ rectEdge(xmin, ymin, xmax, ymax, theta,
+ &edgex, &edgey);
+ }
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(result)[0] = edgex /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[1] = edgey /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[2] = (xmax - xmin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[3] = (ymax - ymin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ }
+ return result;
+}
+
+SEXP L_rect(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust)
+{
+ gridRect(x, y, w, h, hjust, vjust, 0, TRUE);
+ return R_NilValue;
+}
+
+SEXP L_rectBounds(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust,
+ SEXP theta)
+{
+ return gridRect(x, y, w, h, hjust, vjust, REAL(theta)[0], FALSE);
+}
+
+/* FIXME: need to add L_pathBounds ? */
+
+SEXP L_path(SEXP x, SEXP y, SEXP index, SEXP rule)
+{
+ int i, j, k, npoly, *nper, ntot;
+ double *xx, *yy;
+ const void *vmax;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ GEMode(1, dd);
+ vmax = vmaxget();
+ /*
+ * Number of polygons
+ */
+ npoly = LENGTH(index);
+ /*
+ * Total number of points and
+ * Number of points per polygon
+ */
+ ntot = 0;
+ nper = (int *) R_alloc(npoly, sizeof(int));
+ for (i=0; i < npoly; i++) {
+ nper[i] = LENGTH(VECTOR_ELT(index, i));
+ ntot = ntot + nper[i];
+ }
+ xx = (double *) R_alloc(ntot, sizeof(double));
+ yy = (double *) R_alloc(ntot, sizeof(double));
+ k = 0;
+ for (i=0; i < npoly; i++) {
+ SEXP indices = VECTOR_ELT(index, i);
+ for (j=0; j < nper[i]; j++) {
+ transformLocn(x, y, INTEGER(indices)[j] - 1, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[k]), &(yy[k]));
+ /* The graphics engine only takes device coordinates
+ */
+ xx[k] = toDeviceX(xx[k], GE_INCHES, dd);
+ yy[k] = toDeviceY(yy[k], GE_INCHES, dd);
+ /* NO NA values allowed in 'x' or 'y'
+ */
+ if (!R_FINITE(xx[k]) || !R_FINITE(yy[k]))
+ error(_("non-finite x or y in graphics path"));
+ k++;
+ }
+ }
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ GEPath(xx, yy, npoly, nper, INTEGER(rule)[0], &gc, dd);
+ vmaxset(vmax);
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+/* FIXME: need to add L_rasterBounds */
+
+/* FIXME: Add more checks on correct inputs,
+ e.g., Raster should be a matrix of R colors */
+SEXP L_raster(SEXP raster, SEXP x, SEXP y, SEXP w, SEXP h,
+ SEXP hjust, SEXP vjust, SEXP interpolate)
+{
+ const void *vmax;
+ int i, n, ny, nw, nh, maxn;
+ double xx, yy, ww, hh;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP dim;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ unsigned int *image;
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ /* Convert the raster matrix to R internal colours */
+ n = LENGTH(raster);
+ if (n <= 0) {
+ error(_("Empty raster"));
+ }
+ vmax = vmaxget();
+ /* raster is rather inefficient so allow a native representation as
+ an integer array which requires no conversion */
+ if (inherits(raster, "nativeRaster") && isInteger(raster)) {
+ image = (unsigned int*) INTEGER(raster);
+ } else {
+ image = (unsigned int*) R_alloc(n, sizeof(unsigned int));
+ for (i=0; i<n; i++) {
+ image[i] = RGBpar3(raster, i, R_TRANWHITE);
+ }
+ }
+ dim = getAttrib(raster, R_DimSymbol);
+ maxn = unitLength(x);
+ ny = unitLength(y);
+ nw = unitLength(w);
+ nh = unitLength(h);
+ if (ny > maxn)
+ maxn = ny;
+ if (nw > maxn)
+ maxn = nw;
+ if (nh > maxn)
+ maxn = nh;
+ GEMode(1, dd);
+ for (i=0; i<maxn; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ transformLocn(x, y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ ww = transformWidthtoINCHES(w, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ hh = transformHeighttoINCHES(h, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ if (rotationAngle == 0) {
+ xx = justifyX(xx, ww, REAL(hjust)[i % LENGTH(hjust)]);
+ yy = justifyY(yy, hh, REAL(vjust)[i % LENGTH(vjust)]);
+ /* The graphics engine only takes device coordinates
+ */
+ xx = toDeviceX(xx, GE_INCHES, dd);
+ yy = toDeviceY(yy, GE_INCHES, dd);
+ ww = toDeviceWidth(ww, GE_INCHES, dd);
+ hh = toDeviceHeight(hh, GE_INCHES, dd);
+ if (R_FINITE(xx) && R_FINITE(yy) &&
+ R_FINITE(ww) && R_FINITE(hh))
+ GERaster(image, INTEGER(dim)[1], INTEGER(dim)[0],
+ xx, yy, ww, hh, rotationAngle,
+ LOGICAL(interpolate)[i % LENGTH(interpolate)],
+ &gc, dd);
+ } else {
+ /* We have to do a little bit of work to figure out where the
+ * bottom-left corner of the image is.
+ */
+ double xbl, ybl, xadj, yadj;
+ double dw, dh;
+ SEXP xadjInches, yadjInches;
+ /* Find bottom-left location */
+ justification(ww, hh,
+ REAL(hjust)[i % LENGTH(hjust)],
+ REAL(vjust)[i % LENGTH(vjust)],
+ &xadj, &yadj);
+ PROTECT(xadjInches = unit(xadj, L_INCHES));
+ PROTECT(yadjInches = unit(yadj, L_INCHES));
+ transformDimn(xadjInches, yadjInches, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd, rotationAngle,
+ &dw, &dh);
+ xbl = xx + dw;
+ ybl = yy + dh;
+ xbl = toDeviceX(xbl, GE_INCHES, dd);
+ ybl = toDeviceY(ybl, GE_INCHES, dd);
+ ww = toDeviceWidth(ww, GE_INCHES, dd);
+ hh = toDeviceHeight(hh, GE_INCHES, dd);
+ if (R_FINITE(xbl) && R_FINITE(ybl) &&
+ R_FINITE(ww) && R_FINITE(hh)) {
+ /* The graphics engine only takes device coordinates
+ */
+ GERaster(image, INTEGER(dim)[1], INTEGER(dim)[0],
+ xbl, ybl, ww, hh, rotationAngle,
+ LOGICAL(interpolate)[i % LENGTH(interpolate)],
+ &gc, dd);
+ }
+ UNPROTECT(2);
+ }
+ }
+ GEMode(0, dd);
+ vmaxset(vmax);
+ return R_NilValue;
+}
+
+SEXP L_cap()
+{
+ int i, col, row, nrow, ncol, size;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ int *rint;
+ SEXP raster;
+ /* The raster is R internal colours, so convert to
+ * R external colours (strings)
+ * AND the raster is BY ROW so need to rearrange it
+ * to be BY COLUMN (though the dimensions are correct) */
+ SEXP image, idim;
+
+ PROTECT(raster = GECap(dd));
+ /* Non-complying devices will return NULL */
+ if (isNull(raster)) {
+ image = raster;
+ } else {
+ size = LENGTH(raster);
+ nrow = INTEGER(getAttrib(raster, R_DimSymbol))[0];
+ ncol = INTEGER(getAttrib(raster, R_DimSymbol))[1];
+
+ PROTECT(image = allocVector(STRSXP, size));
+ rint = INTEGER(raster);
+ for (i=0; i<size; i++) {
+ col = i % ncol + 1;
+ row = i / ncol + 1;
+ SET_STRING_ELT(image, (col - 1)*nrow + row - 1,
+ mkChar(col2name(rint[i])));
+ }
+
+ PROTECT(idim = allocVector(INTSXP, 2));
+ INTEGER(idim)[0] = nrow;
+ INTEGER(idim)[1] = ncol;
+ setAttrib(image, R_DimSymbol, idim);
+
+ UNPROTECT(2);
+ }
+ UNPROTECT(1);
+ return image;
+}
+
+/*
+ * Code to draw OR size text
+ * Combined to avoid code replication
+ */
+static SEXP gridText(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
+ SEXP rot, SEXP checkOverlap, double theta, Rboolean draw)
+{
+ int i, nx, ny;
+ double *xx, *yy;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP txt, result = R_NilValue;
+ double edgex, edgey;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ /*
+ * Bounding rectangles for checking overlapping
+ * Initialised to shut up compiler
+ */
+ LRect *bounds = NULL;
+ LRect trect;
+ int numBounds = 0;
+ int overlapChecking = LOGICAL(checkOverlap)[0];
+ const void *vmax;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ nx = unitLength(x);
+ ny = unitLength(y);
+ if (ny > nx)
+ nx = ny;
+ vmax = vmaxget();
+ xx = (double *) R_alloc(nx, sizeof(double));
+ yy = (double *) R_alloc(nx, sizeof(double));
+ for (i=0; i<nx; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * If drawing, convert to INCHES on device
+ * If just calculating bounds, convert to INCHES within current vp
+ */
+ if (draw) {
+ transformLocn(x, y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[i]), &(yy[i]));
+ } else {
+ xx[i] = transformXtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ yy[i] = transformYtoINCHES(y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ }
+ /* The label can be a string or an expression
+ */
+ PROTECT(txt = label);
+ if (isSymbol(txt) || isLanguage(txt))
+ txt = coerceVector(txt, EXPRSXP);
+ else if (!isExpression(txt))
+ txt = coerceVector(txt, STRSXP);
+ if (overlapChecking || !draw) {
+ bounds = (LRect *) R_alloc(nx, sizeof(LRect));
+ }
+ /*
+ * Check we have any text to draw
+ */
+ if (LENGTH(txt) > 0) {
+ int ntxt = 0;
+ if (draw) {
+ /*
+ * Drawing text
+ */
+ GEMode(1, dd);
+ }
+ for (i=0; i<nx; i++) {
+ int doDrawing = 1;
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ /*
+ * Generate bounding boxes when checking for overlap
+ * or sizing text
+ */
+ if (overlapChecking || !draw) {
+ int j = 0;
+ textRect(xx[i], yy[i], txt, i, &gc,
+ REAL(hjust)[i % LENGTH(hjust)],
+ REAL(vjust)[i % LENGTH(vjust)],
+ /*
+ * When calculating bounding rect for text
+ * only consider rotation of text within
+ * local context, not relative to device
+ * (so don't add rotationAngle)
+ */
+ numeric(rot, i % LENGTH(rot)),
+ dd, &trect);
+ while (doDrawing && (j < numBounds))
+ if (intersect(trect, bounds[j++]))
+ doDrawing = 0;
+ if (doDrawing) {
+ copyRect(trect, &(bounds[numBounds]));
+ numBounds++;
+ }
+ }
+ if (draw && doDrawing) {
+ /* The graphics engine only takes device coordinates
+ */
+ xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
+ yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
+ if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ if (isExpression(txt))
+ GEMathText(xx[i], yy[i],
+ VECTOR_ELT(txt, i % LENGTH(txt)),
+ REAL(hjust)[i % LENGTH(hjust)],
+ REAL(vjust)[i % LENGTH(vjust)],
+ numeric(rot, i % LENGTH(rot)) +
+ rotationAngle,
+ &gc, dd);
+ else
+ GEText(xx[i], yy[i],
+ CHAR(STRING_ELT(txt, i % LENGTH(txt))),
+ (gc.fontface == 5) ? CE_SYMBOL :
+ getCharCE(STRING_ELT(txt, i % LENGTH(txt))),
+ REAL(hjust)[i % LENGTH(hjust)],
+ REAL(vjust)[i % LENGTH(vjust)],
+ numeric(rot, i % LENGTH(rot)) +
+ rotationAngle,
+ &gc, dd);
+ }
+ }
+ if (!draw) {
+ double minx, maxx, miny, maxy;
+ /*
+ * Sizing text
+ */
+ if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
+ minx = fmin2(trect.x1,
+ fmin2(trect.x2,
+ fmin2(trect.x3, trect.x4)));
+ if (minx < xmin)
+ xmin = minx;
+ maxx = fmax2(trect.x1,
+ fmax2(trect.x2,
+ fmax2(trect.x3, trect.x4)));
+ if (maxx > xmax)
+ xmax = maxx;
+ miny = fmin2(trect.y1,
+ fmin2(trect.y2,
+ fmin2(trect.y3, trect.y4)));
+ if (miny < ymin)
+ ymin = miny;
+ maxy = fmax2(trect.y1,
+ fmax2(trect.y2,
+ fmax2(trect.y3, trect.y4)));
+ if (maxy > ymax)
+ ymax = maxy;
+ /*
+ * Calculate edgex and edgey for case where this is
+ * the only rect
+ */
+ {
+ double xxx[4], yyy[4];
+ /*
+ * Must be in clock-wise order for polygonEdge
+ */
+ xxx[0] = trect.x4; yyy[0] = trect.y4;
+ xxx[1] = trect.x3; yyy[1] = trect.y3;
+ xxx[2] = trect.x2; yyy[2] = trect.y2;
+ xxx[3] = trect.x1; yyy[3] = trect.y1;
+ polygonEdge(xxx, yyy, 4, theta,
+ &edgex, &edgey);
+ }
+ ntxt++;
+ }
+ }
+ }
+ if (draw) {
+ GEMode(0, dd);
+ }
+ if (ntxt > 0) {
+ result = allocVector(REALSXP, 4);
+ /*
+ * If there is more than one text, just produce edge
+ * based on bounding rect of all text
+ */
+ if (ntxt > 1) {
+ /*
+ * Produce edge of rect bounding all text
+ */
+ rectEdge(xmin, ymin, xmax, ymax, theta,
+ &edgex, &edgey);
+ }
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(result)[0] = edgex /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[1] = edgey /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[2] = (xmax - xmin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[3] = (ymax - ymin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ }
+ }
+ vmaxset(vmax);
+ UNPROTECT(1);
+ return result;
+}
+
+SEXP L_text(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
+ SEXP rot, SEXP checkOverlap)
+{
+ gridText(label, x, y, hjust, vjust, rot, checkOverlap, 0, TRUE);
+ return R_NilValue;
+}
+
+/*
+ * Return four values representing boundary of text (which may consist
+ * of multiple pieces of text, unaligned, and/or rotated)
+ * in INCHES.
+ *
+ * Result is (xmin, xmax, ymin, ymax)
+ *
+ * Return NULL if no text to draw; R code will generate unit from that
+ */
+SEXP L_textBounds(SEXP label, SEXP x, SEXP y,
+ SEXP hjust, SEXP vjust, SEXP rot, SEXP theta)
+{
+ SEXP checkOverlap = allocVector(LGLSXP, 1);
+ LOGICAL(checkOverlap)[0] = FALSE;
+ return gridText(label, x, y, hjust, vjust, rot, checkOverlap,
+ REAL(theta)[0], FALSE);
+}
+
+SEXP L_points(SEXP x, SEXP y, SEXP pch, SEXP size)
+{
+ int i, nx, npch;
+ /* double *xx, *yy;*/
+ double *xx, *yy;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ double symbolSize;
+ const void *vmax;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ nx = unitLength(x);
+ npch = LENGTH(pch);
+ /* Convert the x and y values to CM locations */
+ vmax = vmaxget();
+ xx = (double *) R_alloc(nx, sizeof(double));
+ yy = (double *) R_alloc(nx, sizeof(double));
+ for (i=0; i<nx; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ transformLocn(x, y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &(xx[i]), &(yy[i]));
+ /* The graphics engine only takes device coordinates
+ */
+ xx[i] = toDeviceX(xx[i], GE_INCHES, dd);
+ yy[i] = toDeviceY(yy[i], GE_INCHES, dd);
+ }
+ GEMode(1, dd);
+ for (i=0; i<nx; i++)
+ if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
+ /* FIXME: The symbols will not respond to viewport
+ * rotations !!!
+ */
+ int ipch = NA_INTEGER /* -Wall */;
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ symbolSize = transformWidthtoINCHES(size, i, vpc, &gc,
+ vpWidthCM, vpHeightCM, dd);
+ /* The graphics engine only takes device coordinates
+ */
+ symbolSize = toDeviceWidth(symbolSize, GE_INCHES, dd);
+ if (R_FINITE(symbolSize)) {
+ /*
+ * FIXME:
+ * Resolve any differences between this and FixupPch()
+ * in plot.c ?
+ */
+ if (isString(pch)) {
+ ipch = GEstring_to_pch(STRING_ELT(pch, i % npch));
+ } else if (isInteger(pch)) {
+ ipch = INTEGER(pch)[i % npch];
+ } else if (isReal(pch)) {
+ ipch = R_FINITE(REAL(pch)[i % npch]) ?
+ (int) REAL(pch)[i % npch] : NA_INTEGER;
+ } else error(_("invalid plotting symbol"));
+ /*
+ * special case for pch = "."
+ */
+ if (ipch == 46) symbolSize = gpCex(currentgp, i);
+ /*
+ * FIXME:
+ * For character-based symbols, we need to modify
+ * gc->cex so that the FONT size corresponds to
+ * the specified symbolSize.
+ */
+ GESymbol(xx[i], yy[i], ipch, symbolSize, &gc, dd);
+ }
+ }
+ GEMode(0, dd);
+ vmaxset(vmax);
+ return R_NilValue;
+}
+
+SEXP L_clip(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust)
+{
+ double xx, yy, ww, hh;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp, currentClip;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ GEMode(1, dd);
+ /*
+ * Only set ONE clip rectangle (i.e., NOT vectorised)
+ */
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ transformLocn(x, y, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd,
+ transform,
+ &xx, &yy);
+ ww = transformWidthtoINCHES(w, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ hh = transformHeighttoINCHES(h, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ /*
+ * We can ONLY clip if the total rotation angle is zero.
+ */
+ if (rotationAngle == 0) {
+ xx = justifyX(xx, ww, REAL(hjust)[0]);
+ yy = justifyY(yy, hh, REAL(vjust)[0]);
+ /* The graphics engine only takes device coordinates
+ */
+ xx = toDeviceX(xx, GE_INCHES, dd);
+ yy = toDeviceY(yy, GE_INCHES, dd);
+ ww = toDeviceWidth(ww, GE_INCHES, dd);
+ hh = toDeviceHeight(hh, GE_INCHES, dd);
+ if (R_FINITE(xx) && R_FINITE(yy) &&
+ R_FINITE(ww) && R_FINITE(hh)) {
+ GESetClip(xx, yy, xx + ww, yy + hh, dd);
+ /*
+ * ALSO set the current clip region for the
+ * current viewport so that, if a viewport
+ * is pushed within the current viewport,
+ * when that viewport gets popped again,
+ * the clip region returns to what was set
+ * by THIS clipGrob (NOT to the current
+ * viewport's previous setting)
+ */
+ PROTECT(currentClip = allocVector(REALSXP, 4));
+ REAL(currentClip)[0] = xx;
+ REAL(currentClip)[1] = yy;
+ REAL(currentClip)[2] = xx + ww;
+ REAL(currentClip)[3] = yy + hh;
+ SET_VECTOR_ELT(currentvp, PVP_CLIPRECT, currentClip);
+ UNPROTECT(1);
+ }
+ } else {
+ warning(_("unable to clip to rotated rectangle"));
+ }
+ GEMode(0, dd);
+ return R_NilValue;
+}
+
+SEXP L_pretty(SEXP scale) {
+ double min = numeric(scale, 0);
+ double max = numeric(scale, 1);
+ double temp;
+ /* FIXME: This is just a dummy pointer because we do not have
+ * log scales. This will cause death and destruction if it is
+ * not addressed when log scales are added !
+ */
+ double *usr = NULL;
+ double axp[3];
+ /* FIXME: Default preferred number of ticks hard coded ! */
+ int n = 5;
+ Rboolean swap = min > max;
+ /*
+ * Feature:
+ * like R, something like xscale = c(100,0) just works
+ */
+ if(swap) {
+ temp = min; min = max; max = temp;
+ }
+
+ GEPretty(&min, &max, &n);
+
+ if(swap) {
+ temp = min; min = max; max = temp;
+ }
+
+ axp[0] = min;
+ axp[1] = max;
+ axp[2] = n;
+ /* FIXME: "log" flag hard-coded to FALSE because we do not
+ * have log scales yet
+ */
+ return Rf_CreateAtVector(axp, usr, n, FALSE);
+}
+
+/*
+ * NOTE: This does not go through the graphics engine, but
+ * skips straight to the device to obtain a mouse click.
+ * This is because I do not want to put a GELocator in the
+ * graphics engine; that would be a crappy long term solution.
+ * I will wait for a better event-loop/call-back solution before
+ * doing something with the graphics engine.
+ * This is a stop gap in the meantime.
+ *
+ * The answer is in INCHES
+ */
+
+SEXP L_locator() {
+ double x = 0;
+ double y = 0;
+ SEXP answer;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ GEMode(2, dd);
+ PROTECT(answer = allocVector(REALSXP, 2));
+ /*
+ * Get a mouse click
+ * Fails if user did not click mouse button 1
+ */
+ if(dd->dev->locator && dd->dev->locator(&x, &y, dd->dev)) {
+ REAL(answer)[0] = fromDeviceX(x, GE_INCHES, dd);
+ REAL(answer)[1] = fromDeviceY(y, GE_INCHES, dd);
+ } else {
+ REAL(answer)[0] = NA_REAL;
+ REAL(answer)[1] = NA_REAL;
+ }
+ UNPROTECT(1);
+ GEMode(0, dd);
+ return answer;
+}
+
+/*
+ * ****************************************
+ * Calculating boundaries of primitives
+ *
+ * ****************************************
+ */
+
+/*
+ * Return four values representing boundary of set of locations
+ * in INCHES.
+ *
+ * Result is (xmin, xmax, ymin, ymax)
+ *
+ * Used for lines, segments, polygons
+ */
+SEXP L_locnBounds(SEXP x, SEXP y, SEXP theta)
+{
+ int i, nx, ny, nloc;
+ double *xx, *yy;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP result = R_NilValue;
+ const void *vmax;
+ double xmin = DOUBLE_XMAX;
+ double xmax = -DOUBLE_XMAX;
+ double ymin = DOUBLE_XMAX;
+ double ymax = -DOUBLE_XMAX;
+ double edgex, edgey;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ nx = unitLength(x);
+ ny = unitLength(y);
+ if (ny > nx)
+ nx = ny;
+ nloc = 0;
+ vmax = vmaxget();
+ if (nx > 0) {
+ xx = (double *) R_alloc(nx, sizeof(double));
+ yy = (double *) R_alloc(nx, sizeof(double));
+ for (i=0; i<nx; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ xx[i] = transformXtoINCHES(x, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ yy[i] = transformYtoINCHES(y, i, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ /*
+ * Determine min/max x/y values
+ */
+ if (R_FINITE(xx[i]) && R_FINITE(yy[i])) {
+ if (xx[i] < xmin)
+ xmin = xx[i];
+ if (xx[i] > xmax)
+ xmax = xx[i];
+ if (yy[i] < ymin)
+ ymin = yy[i];
+ if (yy[i] > ymax)
+ ymax = yy[i];
+ nloc++;
+ }
+ }
+ }
+ if (nloc > 0) {
+ hullEdge(xx, yy, nx, REAL(theta)[0], &edgex, &edgey);
+ result = allocVector(REALSXP, 4);
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(result)[0] = edgex /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[1] = edgey /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[2] = (xmax - xmin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(result)[3] = (ymax - ymin) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ }
+ vmaxset(vmax);
+ return result;
+}
+
+/*
+ * ****************************************
+ * Calculating text metrics
+ *
+ * ****************************************
+ */
+SEXP L_stringMetric(SEXP label)
+{
+ int i, n;
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform;
+ SEXP currentvp, currentgp;
+ SEXP txt;
+ SEXP result = R_NilValue;
+ SEXP ascent = R_NilValue;
+ SEXP descent = R_NilValue;
+ SEXP width = R_NilValue;
+ const void *vmax;
+ double asc, dsc, wid;
+ /* Get the current device
+ */
+ pGEDevDesc dd = getDevice();
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ getViewportContext(currentvp, &vpc);
+ /* The label can be a string or an expression: is protected.
+ */
+ txt = label;
+ if (isSymbol(txt) || isLanguage(txt))
+ txt = coerceVector(txt, EXPRSXP);
+ else if (!isExpression(txt))
+ txt = coerceVector(txt, STRSXP);
+ PROTECT(txt);
+ n = LENGTH(txt);
+ vmax = vmaxget();
+ PROTECT(ascent = allocVector(REALSXP, n));
+ PROTECT(descent = allocVector(REALSXP, n));
+ PROTECT(width = allocVector(REALSXP, n));
+ if (n > 0) {
+ for (i=0; i<n; i++) {
+ gcontextFromgpar(currentgp, i, &gc, dd);
+ if (isExpression(txt))
+ GEExpressionMetric(VECTOR_ELT(txt, i % LENGTH(txt)), &gc,
+ &asc, &dsc, &wid,
+ dd);
+ else
+ GEStrMetric(CHAR(STRING_ELT(txt, i)),
+ getCharCE(STRING_ELT(txt, i)), &gc,
+ &asc, &dsc, &wid,
+ dd);
+ /*
+ * Reverse the scale adjustment (zoom factor)
+ * when calculating physical value to return to user-level
+ */
+ REAL(ascent)[i] = fromDeviceHeight(asc, GE_INCHES, dd) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(descent)[i] = fromDeviceHeight(dsc, GE_INCHES, dd) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ REAL(width)[i] = fromDeviceWidth(wid, GE_INCHES, dd) /
+ REAL(gridStateElement(dd, GSS_SCALE))[0];
+ }
+ }
+ PROTECT(result = allocVector(VECSXP, 3));
+ SET_VECTOR_ELT(result, 0, ascent);
+ SET_VECTOR_ELT(result, 1, descent);
+ SET_VECTOR_ELT(result, 2, width);
+ vmaxset(vmax);
+ UNPROTECT(5);
+ return result;
+}
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/grid.h b/com.oracle.truffle.r.native/library/grid/src/grid.h
new file mode 100644
index 0000000000..81ac600478
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/grid.h
@@ -0,0 +1,633 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-8 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include <Rconfig.h>
+#include <Rinternals.h>
+#include <Rmath.h>
+
+#include <R_ext/Constants.h>
+#include <R_ext/GraphicsEngine.h>
+
+#include <Rinternals.h>
+#ifdef ENABLE_NLS
+#include <libintl.h>
+#define _(String) dgettext ("grid", String)
+#else
+#define _(String) (String)
+#endif
+
+/* All grid type names are prefixed with an "L"
+ * All grid global variable names are prefixed with an "L_"
+ */
+
+/* This information is stored with R's graphics engine so that
+ * grid can have state information per device and grid output can
+ * be maintained on multiple devices.
+ */
+
+#define GSS_DEVSIZE 0
+#define GSS_CURRLOC 1
+#define GSS_DL 2
+#define GSS_DLINDEX 3
+#define GSS_DLON 4
+#define GSS_GPAR 5
+#define GSS_GPSAVED 6
+#define GSS_VP 7
+#define GSS_GLOBALINDEX 8
+#define GSS_GRIDDEVICE 9
+#define GSS_PREVLOC 10
+#define GSS_ENGINEDLON 11
+#define GSS_CURRGROB 12
+#define GSS_ENGINERECORDING 13
+/* #define GSS_ASK 14 unused in R >= 2.7.0 */
+#define GSS_SCALE 15
+
+/*
+ * Structure of a viewport
+ */
+#define VP_X 0
+#define VP_Y 1
+#define VP_WIDTH 2
+#define VP_HEIGHT 3
+#define VP_JUST 4
+#define VP_GP 5
+#define VP_CLIP 6
+#define VP_XSCALE 7
+#define VP_YSCALE 8
+#define VP_ANGLE 9
+#define VP_LAYOUT 10
+#define VP_LPOSROW 11
+#define VP_LPOSCOL 12
+#define VP_VALIDJUST 13
+#define VP_VALIDLPOSROW 14
+#define VP_VALIDLPOSCOL 15
+#define VP_NAME 16
+/*
+ * Additional structure of a pushedvp
+ */
+#define PVP_PARENTGPAR 17
+#define PVP_GPAR 18
+#define PVP_TRANS 19
+#define PVP_WIDTHS 20
+#define PVP_HEIGHTS 21
+#define PVP_WIDTHCM 22
+#define PVP_HEIGHTCM 23
+#define PVP_ROTATION 24
+#define PVP_CLIPRECT 25
+#define PVP_PARENT 26
+#define PVP_CHILDREN 27
+#define PVP_DEVWIDTHCM 28
+#define PVP_DEVHEIGHTCM 29
+
+/*
+ * Structure of a layout
+ */
+#define LAYOUT_NROW 0
+#define LAYOUT_NCOL 1
+#define LAYOUT_WIDTHS 2
+#define LAYOUT_HEIGHTS 3
+#define LAYOUT_RESPECT 4
+#define LAYOUT_VRESPECT 5
+#define LAYOUT_MRESPECT 6
+#define LAYOUT_JUST 7
+#define LAYOUT_VJUST 8
+
+#define GP_FILL 0
+#define GP_COL 1
+#define GP_GAMMA 2
+#define GP_LTY 3
+#define GP_LWD 4
+#define GP_CEX 5
+#define GP_FONTSIZE 6
+#define GP_LINEHEIGHT 7
+#define GP_FONT 8
+#define GP_FONTFAMILY 9
+#define GP_ALPHA 10
+#define GP_LINEEND 11
+#define GP_LINEJOIN 12
+#define GP_LINEMITRE 13
+#define GP_LEX 14
+/*
+ * Keep fontface at the end because it is never used in C code
+ */
+#define GP_FONTFACE 15
+
+/*
+ * Structure of an arrow description
+ */
+#define GRID_ARROWANGLE 0
+#define GRID_ARROWLENGTH 1
+#define GRID_ARROWENDS 2
+#define GRID_ARROWTYPE 3
+
+typedef double LTransform[3][3];
+
+typedef double LLocation[3];
+
+typedef enum {
+ L_adding = 1,
+ L_subtracting = 2,
+ L_summing = 3,
+ L_plain = 4,
+ L_maximising = 5,
+ L_minimising = 6,
+ L_multiplying = 7
+} LNullArithmeticMode;
+
+/* NOTE: The order of the enums here must match the order of the
+ * strings in unit.R
+ */
+typedef enum {
+ L_NPC = 0,
+ L_CM = 1,
+ L_INCHES = 2,
+ L_LINES = 3,
+ L_NATIVE = 4,
+ L_NULL = 5, /* only used in layout specifications (?) */
+ L_SNPC = 6,
+ L_MM = 7,
+ /* Some units based on TeX's definition thereof
+ */
+ L_POINTS = 8, /* 72.27 pt = 1 in */
+ L_PICAS = 9, /* 1 pc = 12 pt */
+ L_BIGPOINTS = 10, /* 72 bp = 1 in */
+ L_DIDA = 11, /* 1157 dd = 1238 pt */
+ L_CICERO = 12, /* 1 cc = 12 dd */
+ L_SCALEDPOINTS = 13, /* 65536 sp = 1pt */
+ /* Some units which require an object to query for a value.
+ */
+ L_STRINGWIDTH = 14,
+ L_STRINGHEIGHT = 15,
+ L_STRINGASCENT = 16,
+ L_STRINGDESCENT = 17,
+ /* L_LINES now means multiples of the line height.
+ * This is multiples of the font size.
+ */
+ L_CHAR = 18,
+ L_GROBX = 19,
+ L_GROBY = 20,
+ L_GROBWIDTH = 21,
+ L_GROBHEIGHT = 22,
+ L_GROBASCENT = 23,
+ L_GROBDESCENT = 24,
+ /*
+ * No longer used
+ */
+ L_MYLINES = 103,
+ L_MYCHAR = 104,
+ L_MYSTRINGWIDTH = 105,
+ L_MYSTRINGHEIGHT = 106
+} LUnit;
+
+typedef enum {
+ L_LEFT = 0,
+ L_RIGHT = 1,
+ L_BOTTOM = 2,
+ L_TOP = 3,
+ L_CENTRE = 4,
+ L_CENTER = 5
+} LJustification;
+
+/* An arbitrarily-oriented rectangle.
+ * The vertices are assumed to be in order going anticlockwise
+ * around the rectangle.
+ */
+typedef struct {
+ double x1;
+ double x2;
+ double x3;
+ double x4;
+ double y1;
+ double y2;
+ double y3;
+ double y4;
+} LRect;
+
+/* A description of the location of a viewport */
+typedef struct {
+ SEXP x;
+ SEXP y;
+ SEXP width;
+ SEXP height;
+ double hjust;
+ double vjust;
+} LViewportLocation;
+
+/* Components of a viewport which provide coordinate information
+ * for children of the viewport
+ */
+typedef struct {
+ double xscalemin;
+ double xscalemax;
+ double yscalemin;
+ double yscalemax;
+} LViewportContext;
+
+/* Evaluation environment */
+#ifndef GRID_MAIN
+extern SEXP R_gridEvalEnv;
+#else
+SEXP R_gridEvalEnv;
+#endif
+
+
+/* Functions called by R code
+ * (from all over the place)
+ */
+SEXP L_initGrid(SEXP GridEvalEnv);
+SEXP L_killGrid();
+SEXP L_gridDirty();
+SEXP L_currentViewport();
+SEXP L_setviewport(SEXP vp, SEXP hasParent);
+SEXP L_downviewport(SEXP vp, SEXP strict);
+SEXP L_downvppath(SEXP path, SEXP name, SEXP strict);
+SEXP L_unsetviewport(SEXP last);
+SEXP L_upviewport(SEXP last);
+SEXP L_getDisplayList();
+SEXP L_setDisplayList(SEXP dl);
+SEXP L_getDLelt(SEXP index);
+SEXP L_setDLelt(SEXP value);
+SEXP L_getDLindex();
+SEXP L_setDLindex(SEXP index);
+SEXP L_getDLon();
+SEXP L_setDLon(SEXP value);
+SEXP L_getEngineDLon();
+SEXP L_setEngineDLon(SEXP value);
+SEXP L_getCurrentGrob();
+SEXP L_setCurrentGrob(SEXP value);
+SEXP L_getEngineRecording();
+SEXP L_setEngineRecording(SEXP value);
+SEXP L_currentGPar();
+SEXP L_newpagerecording();
+SEXP L_newpage();
+SEXP L_initGPar();
+SEXP L_initViewportStack();
+SEXP L_initDisplayList();
+SEXP L_convertToNative(SEXP x, SEXP what);
+SEXP L_moveTo(SEXP x, SEXP y);
+SEXP L_lineTo(SEXP x, SEXP y, SEXP arrow);
+SEXP L_lines(SEXP x, SEXP y, SEXP index, SEXP arrow);
+SEXP L_segments(SEXP x0, SEXP y0, SEXP x1, SEXP y1, SEXP arrow);
+SEXP L_arrows(SEXP x1, SEXP x2, SEXP xnm1, SEXP xn,
+ SEXP y1, SEXP y2, SEXP ynm1, SEXP yn,
+ SEXP angle, SEXP length, SEXP ends, SEXP type);
+SEXP L_path(SEXP x, SEXP y, SEXP index, SEXP rule);
+SEXP L_polygon(SEXP x, SEXP y, SEXP index);
+SEXP L_xspline(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, SEXP index);
+SEXP L_circle(SEXP x, SEXP y, SEXP r);
+SEXP L_rect(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust);
+SEXP L_raster(SEXP raster, SEXP x, SEXP y, SEXP w, SEXP h,
+ SEXP hjust, SEXP vjust, SEXP interpolate);
+SEXP L_cap();
+SEXP L_text(SEXP label, SEXP x, SEXP y, SEXP hjust, SEXP vjust,
+ SEXP rot, SEXP checkOverlap);
+SEXP L_points(SEXP x, SEXP y, SEXP pch, SEXP size);
+SEXP L_clip(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust);
+SEXP L_pretty(SEXP scale);
+SEXP L_locator();
+SEXP L_convert(SEXP x, SEXP whatfrom,
+ SEXP whatto, SEXP unitto);
+SEXP L_layoutRegion(SEXP layoutPosRow, SEXP layoutPosCol);
+
+SEXP L_stringMetric(SEXP label);
+
+/* From matrix.c */
+double locationX(LLocation l);
+
+double locationY(LLocation l);
+
+void copyTransform(LTransform t1, LTransform t2);
+
+void invTransform(LTransform t, LTransform invt);
+
+void identity(LTransform m);
+
+void translation(double tx, double ty, LTransform m);
+
+void scaling(double sx, double sy, LTransform m);
+
+void rotation(double theta, LTransform m);
+
+void multiply(LTransform m1, LTransform m2, LTransform m);
+
+void location(double x, double y, LLocation v);
+
+void trans(LLocation vin, LTransform m, LLocation vout);
+
+/* From unit.c */
+int isUnitArithmetic(SEXP ua);
+
+int isUnitList(SEXP ul);
+
+SEXP unit(double value, int unit);
+
+double unitValue(SEXP unit, int index);
+
+int unitUnit(SEXP unit, int index);
+
+SEXP unitData(SEXP unit, int index);
+
+int unitLength(SEXP u);
+
+extern int L_nullLayoutMode;
+
+double pureNullUnitValue(SEXP unit, int index);
+
+int pureNullUnit(SEXP unit, int index, pGEDevDesc dd);
+
+double transformX(SEXP x, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd);
+
+double transformY(SEXP y, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd);
+
+double transformWidth(SEXP width, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd);
+
+double transformHeight(SEXP height, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd);
+
+double transformXtoINCHES(SEXP x, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd);
+
+double transformYtoINCHES(SEXP y, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd);
+
+void transformLocn(SEXP x, SEXP y, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd,
+ LTransform t,
+ double *xx, double *yy);
+
+double transformWidthtoINCHES(SEXP w, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd);
+
+double transformHeighttoINCHES(SEXP h, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd);
+
+void transformDimn(SEXP w, SEXP h, int index, LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd,
+ double rotationAngle,
+ double *ww, double *hh);
+
+double transformXYFromINCHES(double location, int unit,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ pGEDevDesc dd);
+
+double transformWidthHeightFromINCHES(double value, int unit,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ pGEDevDesc dd);
+
+double transformXYtoNPC(double x, int from, double min, double max);
+
+double transformWHtoNPC(double x, int from, double min, double max);
+
+double transformXYfromNPC(double x, int to, double min, double max);
+
+double transformWHfromNPC(double x, int to, double min, double max);
+
+/* From just.c */
+double justifyX(double x, double width, double hjust);
+
+double justifyY(double y, double height, double vjust);
+
+double convertJust(int vjust);
+
+void justification(double width, double height, double hjust, double vjust,
+ double *hadj, double *vadj);
+
+/* From util.c */
+SEXP getListElement(SEXP list, char *str);
+
+void setListElement(SEXP list, char *str, SEXP value);
+
+SEXP getSymbolValue(char *symbolName);
+
+void setSymbolValue(char *symbolName, SEXP value);
+
+double numeric(SEXP x, int index);
+
+void rect(double x1, double x2, double x3, double x4,
+ double y1, double y2, double y3, double y4,
+ LRect *r);
+
+void copyRect(LRect r1, LRect *r);
+
+int intersect(LRect r1, LRect r2);
+
+void textRect(double x, double y, SEXP text, int i,
+ const pGEcontext gc,
+ double xadj, double yadj,
+ double rot, pGEDevDesc dd, LRect *r);
+
+/* From gpar.c */
+double gpFontSize(SEXP gp, int i);
+
+double gpLineHeight(SEXP gp, int i);
+
+int gpCol(SEXP gp, int i);
+
+SEXP gpFillSXP(SEXP gp);
+
+int gpFill(SEXP gp, int i);
+
+double gpGamma(SEXP gp, int i);
+
+int gpLineType(SEXP gp, int i);
+
+double gpLineWidth(SEXP gp, int i);
+
+double gpCex(SEXP gp, int i);
+
+int gpFont(SEXP gp, int i);
+
+const char* gpFontFamily(SEXP gp, int i);
+
+SEXP gpFontSXP(SEXP gp);
+
+SEXP gpFontFamilySXP(SEXP gp);
+
+SEXP gpFontSizeSXP(SEXP gp);
+
+SEXP gpLineHeightSXP(SEXP gp);
+
+void gcontextFromgpar(SEXP gp, int i, const pGEcontext gc, pGEDevDesc dd);
+
+void initGPar(pGEDevDesc dd);
+
+/* From viewport.c */
+SEXP viewportX(SEXP vp);
+
+SEXP viewportY(SEXP vp);
+
+SEXP viewportWidth(SEXP vp);
+
+SEXP viewportHeight(SEXP vp);
+
+SEXP viewportgpar(SEXP vp);
+
+const char* viewportFontFamily(SEXP vp);
+
+int viewportFont(SEXP vp);
+
+double viewportFontSize(SEXP vp);
+
+double viewportLineHeight(SEXP vp);
+
+Rboolean viewportClip(SEXP vp);
+
+SEXP viewportClipRect(SEXP vp);
+
+double viewportXScaleMin(SEXP vp);
+
+double viewportXScaleMax(SEXP vp);
+
+double viewportYScaleMin(SEXP vp);
+
+double viewportYScaleMax(SEXP vp);
+
+double viewportHJust(SEXP v);
+
+double viewportVJust(SEXP vp);
+
+SEXP viewportLayoutPosRow(SEXP vp);
+
+SEXP viewportLayoutPosCol(SEXP vp);
+
+SEXP viewportLayout(SEXP vp);
+
+SEXP viewportParent(SEXP vp);
+
+SEXP viewportTransform(SEXP vp);
+
+SEXP viewportLayoutWidths(SEXP vp);
+
+SEXP viewportLayoutHeights(SEXP vp);
+
+SEXP viewportWidthCM(SEXP vp);
+
+SEXP viewportHeightCM(SEXP vp);
+
+SEXP viewportRotation(SEXP vp);
+
+SEXP viewportParent(SEXP vp);
+
+SEXP viewportChildren(SEXP vp);
+
+SEXP viewportDevWidthCM(SEXP vp);
+
+SEXP viewportDevHeightCM(SEXP vp);
+
+void fillViewportContextFromViewport(SEXP vp, LViewportContext *vpc);
+
+void copyViewportContext(LViewportContext vpc1, LViewportContext *vpc2);
+
+void gcontextFromViewport(SEXP vp, const pGEcontext gc, pGEDevDesc dd);
+
+void calcViewportTransform(SEXP vp, SEXP parent, Rboolean incremental,
+ pGEDevDesc dd);
+
+void initVP(pGEDevDesc dd);
+
+/* From layout.c */
+Rboolean checkPosRowPosCol(SEXP viewport, SEXP parent);
+
+void calcViewportLayout(SEXP viewport,
+ double parentWidthCM,
+ double parentHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd);
+
+void calcViewportLocationFromLayout(SEXP layoutPosRow,
+ SEXP layoutPosCol,
+ SEXP parent,
+ LViewportLocation *vpl);
+
+/* From state.c */
+void initDL(pGEDevDesc dd);
+
+SEXP gridStateElement(pGEDevDesc dd, int elementIndex);
+
+void setGridStateElement(pGEDevDesc dd, int elementIndex, SEXP value);
+
+SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data);
+
+/* From grid.c */
+SEXP doSetViewport(SEXP vp,
+ Rboolean topLevelVP,
+ Rboolean pushing,
+ pGEDevDesc dd);
+
+void getDeviceSize(pGEDevDesc dd, double *devWidthCM, double *devHeightCM);
+
+/* This is, confusingly, a wrapper for GEcurrentDevice */
+pGEDevDesc getDevice();
+
+void getViewportTransform(SEXP currentvp,
+ pGEDevDesc dd,
+ double *vpWidthCM, double *vpHeightCM,
+ LTransform transform, double *rotationAngle);
+
+SEXP L_circleBounds(SEXP x, SEXP y, SEXP r, SEXP theta);
+SEXP L_locnBounds(SEXP x, SEXP y, SEXP theta);
+SEXP L_rectBounds(SEXP x, SEXP y, SEXP w, SEXP h, SEXP hjust, SEXP vjust,
+ SEXP theta);
+SEXP L_textBounds(SEXP label, SEXP x, SEXP y,
+ SEXP hjust, SEXP vjust, SEXP rot, SEXP theta);
+SEXP L_xsplineBounds(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
+ SEXP index, SEXP theta);
+SEXP L_xsplinePoints(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep,
+ SEXP index, SEXP theta);
+
+/* From unit.c */
+SEXP validUnits(SEXP units);
+
+/* From gpar.c */
+SEXP L_getGPar(void);
+SEXP L_setGPar(SEXP gpars);
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/just.c b/com.oracle.truffle.r.native/library/grid/src/just.c
new file mode 100644
index 0000000000..c005c35956
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/just.c
@@ -0,0 +1,128 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+
+/* Modify a location for the correct justification */
+
+/* These tranformations assume that x and width are in the same units */
+/* FIXME: I don't think we check anywhere that a horizontal justification
+ * is not L_BOTTOM or L_TOP (i.e., meaningless). Ditto for checking
+ * vertical justification.
+ */
+double justifyX(double x, double width, double hjust) {
+ return x - width*hjust;
+ /*
+ * From when hjust and vjust were enums
+ *
+ double result = 0;
+ switch (hjust) {
+ case L_LEFT:
+ result = x;
+ break;
+ case L_RIGHT:
+ result = x - width;
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ result = x - width/2;
+ break;
+ }
+ return result;
+ */
+}
+
+double justifyY(double y, double height, double vjust) {
+ return y - height*vjust;
+ /*
+ * From when hjust and vjust were enums
+ *
+ double result = 0;
+ switch (vjust) {
+ case L_BOTTOM:
+ result = y;
+ break;
+ case L_TOP:
+ result = y - height;
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ result = y - height/2;
+ break;
+ }
+ return result;
+ */
+}
+
+/* Convert enum justification into 0..1 justification */
+double convertJust(int just) {
+ double result = 0;
+ switch (just) {
+ case L_BOTTOM:
+ case L_LEFT:
+ result = 0;
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ result = .5;
+ break;
+ case L_TOP:
+ case L_RIGHT:
+ result = 1;
+ break;
+ }
+ return result;
+}
+
+/* Return the amount of justification required
+ */
+void justification(double width, double height, double hjust, double vjust,
+ double *hadj, double *vadj)
+{
+ *hadj = -width*hjust;
+ *vadj = -height*vjust;
+ /*
+ * From when hjust and vjust were enums
+ switch (hjust) {
+ case L_LEFT:
+ *hadj = 0;
+ break;
+ case L_RIGHT:
+ *hadj = -width;
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ *hadj = -width/2;
+ break;
+ }
+ switch (vjust) {
+ case L_BOTTOM:
+ *vadj = 0;
+ break;
+ case L_TOP:
+ *vadj = -height;
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ *vadj = -height/2;
+ break;
+ }
+ */
+}
diff --git a/com.oracle.truffle.r.native/library/grid/src/layout.c b/com.oracle.truffle.r.native/library/grid/src/layout.c
new file mode 100644
index 0000000000..f338862e7b
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/layout.c
@@ -0,0 +1,648 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-2013 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+
+/* This stuff always returns an LViewportLocation in "npc" units
+ */
+
+int layoutNRow(SEXP l) {
+ return INTEGER(VECTOR_ELT(l, LAYOUT_NROW))[0];
+}
+
+int layoutNCol(SEXP l) {
+ return INTEGER(VECTOR_ELT(l, LAYOUT_NCOL))[0];
+}
+
+SEXP layoutWidths(SEXP l) {
+ return VECTOR_ELT(l, LAYOUT_WIDTHS);
+}
+
+SEXP layoutHeights(SEXP l) {
+ return VECTOR_ELT(l, LAYOUT_HEIGHTS);
+}
+
+int layoutRespect(SEXP l) {
+ return INTEGER(VECTOR_ELT(l, LAYOUT_VRESPECT))[0];
+}
+
+int* layoutRespectMat(SEXP l) {
+ return INTEGER(VECTOR_ELT(l, LAYOUT_MRESPECT));
+}
+
+double layoutHJust(SEXP l) {
+ return REAL(VECTOR_ELT(l, LAYOUT_VJUST))[0];
+}
+
+double layoutVJust(SEXP l) {
+ return REAL(VECTOR_ELT(l, LAYOUT_VJUST))[1];
+}
+
+Rboolean relativeUnit(SEXP unit, int index,
+ pGEDevDesc dd) {
+ return pureNullUnit(unit, index, dd);
+}
+
+void findRelWidths(SEXP layout, int *relativeWidths,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ for (i=0; i<layoutNCol(layout); i++)
+ relativeWidths[i] = relativeUnit(widths, i, dd);
+}
+
+void findRelHeights(SEXP layout, int *relativeHeights,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP heights = layoutHeights(layout);
+ for (i=0; i<layoutNRow(layout); i++)
+ relativeHeights[i] = relativeUnit(heights, i, dd);
+}
+
+void allocateKnownWidths(SEXP layout,
+ int *relativeWidths,
+ double parentWidthCM, double parentHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd,
+ double *npcWidths, double *widthLeftCM)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ for (i=0; i<layoutNCol(layout); i++)
+ if (!relativeWidths[i]) {
+ npcWidths[i] = transformWidth(widths, i, parentContext,
+ parentgc,
+ parentWidthCM, parentHeightCM,
+ 0, 0, dd)*2.54;
+ *widthLeftCM -= npcWidths[i];
+ }
+}
+
+void allocateKnownHeights(SEXP layout,
+ int *relativeHeights,
+ double parentWidthCM, double parentHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd,
+ double *npcHeights, double *heightLeftCM)
+{
+ int i;
+ SEXP heights = layoutHeights(layout);
+ for (i=0; i<layoutNRow(layout); i++)
+ if (!relativeHeights[i]) {
+ npcHeights[i] = transformHeight(heights, i, parentContext,
+ parentgc,
+ parentWidthCM, parentHeightCM,
+ 0, 0, dd)*2.54;
+ *heightLeftCM -= npcHeights[i];
+ }
+}
+
+int colRespected(int col, SEXP layout) {
+ int i;
+ int result = 0;
+ int respect = layoutRespect(layout);
+ int *respectMat = layoutRespectMat(layout);
+ if (respect == 1)
+ result = 1;
+ else
+ for (i=0; i<layoutNRow(layout); i++)
+ if (respectMat[col*layoutNRow(layout) + i] != 0)
+ result = 1;
+ return result;
+}
+
+int rowRespected(int row, SEXP layout) {
+ int i;
+ int result = 0;
+ int respect = layoutRespect(layout);
+ int *respectMat = layoutRespectMat(layout);
+ if (respect == 1)
+ result = 1;
+ else
+ for (i=0; i<layoutNCol(layout); i++)
+ if (respectMat[i*layoutNRow(layout) + row] != 0)
+ result = 1;
+ return result;
+}
+
+/*
+ * These sum up ALL relative widths and heights (unit = "null")
+ * Some effort is made to find all truly null units
+ * (e.g., including a grobwidth unit where the grob's width is null)
+ */
+double totalWidth(SEXP layout, int *relativeWidths,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ double totalWidth = 0;
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ totalWidth += transformWidth(widths, i, parentContext,
+ parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd);
+ return totalWidth;
+}
+
+double totalHeight(SEXP layout, int *relativeHeights,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP heights = layoutHeights(layout);
+ double totalHeight = 0;
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ totalHeight += transformHeight(heights, i, parentContext,
+ parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd);
+ return totalHeight;
+}
+
+void allocateRespected(SEXP layout,
+ int *relativeWidths, int *relativeHeights,
+ double *reducedWidthCM, double *reducedHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd,
+ double *npcWidths, double *npcHeights)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ SEXP heights = layoutHeights(layout);
+ int respect = layoutRespect(layout);
+ double sumWidth = totalWidth(layout, relativeWidths, parentContext,
+ parentgc, dd);
+ double sumHeight = totalHeight(layout, relativeHeights, parentContext,
+ parentgc, dd);
+ double denom, mult;
+ double tempWidthCM = *reducedWidthCM;
+ double tempHeightCM = *reducedHeightCM;
+ if (respect > 0) {
+ /* Determine whether aspect ratio of available space is
+ * bigger or smaller than aspect ratio of layout
+ */
+ // NB: widths could be zero
+ // if ((tempHeightCM / tempWidthCM) > (sumHeight / sumWidth)) {
+ if ( tempHeightCM * sumWidth > sumHeight * tempWidthCM) {
+ denom = sumWidth;
+ mult = tempWidthCM;
+ }
+ else {
+ denom = sumHeight;
+ mult = tempHeightCM;
+ }
+ /* Allocate respected widths
+ */
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ if (colRespected(i, layout)) {
+ /*
+ * Special case of respect, but sumHeight = 0.
+ * Action is to allocate widths as if unrespected.
+ * Ok to test == 0 because will only be 0 if
+ * all relative heights are actually exactly 0.
+ */
+ if (sumHeight == 0) {
+ denom = sumWidth;
+ mult = tempWidthCM;
+ }
+ /* Build a unit SEXP with a single value and no data
+ */
+ npcWidths[i] = pureNullUnitValue(widths, i) /
+ denom*mult;
+ *reducedWidthCM -= npcWidths[i];
+ }
+ /* Allocate respected heights
+ */
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ if (rowRespected(i, layout)) {
+ /*
+ * Special case of respect, but sumWidth = 0.
+ * Action is to allocate widths as if unrespected.
+ * Ok to test == 0 because will only be 0 if
+ * all relative heights are actually exactly 0.
+ */
+ if (sumWidth == 0) {
+ denom = sumHeight;
+ mult = tempHeightCM;
+ }
+ npcHeights[i] = pureNullUnitValue(heights, i) /
+ denom*mult;
+ *reducedHeightCM -= npcHeights[i];
+ }
+ }
+}
+
+void setRespectedZero(SEXP layout,
+ int *relativeWidths, int *relativeHeights,
+ double *npcWidths, double *npcHeights)
+{
+ int i;
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ if (colRespected(i, layout))
+ npcWidths[i] = 0;
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ if (rowRespected(i, layout))
+ npcHeights[i] = 0;
+}
+
+/* These sum up unrespected relative widths and heights (unit = "null")
+ */
+double totalUnrespectedWidth(SEXP layout, int *relativeWidths,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ double totalWidth = 0;
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ if (!colRespected(i, layout))
+ totalWidth += transformWidth(widths, i, parentContext,
+ parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd);
+ return totalWidth;
+}
+
+double totalUnrespectedHeight(SEXP layout, int *relativeHeights,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP heights = layoutHeights(layout);
+ double totalHeight = 0;
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ if (!rowRespected(i, layout))
+ totalHeight += transformHeight(heights, i, parentContext,
+ parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd);
+ return totalHeight;
+}
+
+
+void setRemainingWidthZero(SEXP layout,
+ int *relativeWidths,
+ double *npcWidths)
+{
+ int i;
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ if (!colRespected(i, layout))
+ npcWidths[i] = 0;
+}
+
+void allocateRemainingWidth(SEXP layout, int *relativeWidths,
+ double remainingWidthCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd,
+ double *npcWidths)
+{
+ int i;
+ SEXP widths = layoutWidths(layout);
+ double sumWidth;
+ sumWidth = totalUnrespectedWidth(layout, relativeWidths,
+ parentContext, parentgc, dd);
+ if (sumWidth > 0) {
+ for (i=0; i<layoutNCol(layout); i++)
+ if (relativeWidths[i])
+ if (!colRespected(i, layout))
+ npcWidths[i] = remainingWidthCM*
+ transformWidth(widths, i, parentContext, parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd)/
+ sumWidth;
+ } else {
+ /*
+ * If ALL relative widths are zero then they all get
+ * allocated zero width
+ */
+ setRemainingWidthZero(layout, relativeWidths, npcWidths);
+ }
+}
+
+void setRemainingHeightZero(SEXP layout,
+ int *relativeHeights,
+ double *npcHeights)
+{
+ int i;
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ if (!rowRespected(i, layout))
+ npcHeights[i] = 0;
+}
+
+void allocateRemainingHeight(SEXP layout, int *relativeHeights,
+ double remainingHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd,
+ double *npcHeights)
+{
+ int i;
+ SEXP heights = layoutHeights(layout);
+ double sumHeight;
+ sumHeight = totalUnrespectedHeight(layout, relativeHeights,
+ parentContext, parentgc, dd);
+ if (sumHeight > 0) {
+ for (i=0; i<layoutNRow(layout); i++)
+ if (relativeHeights[i])
+ if (!rowRespected(i, layout))
+ npcHeights[i] = remainingHeightCM*
+ transformHeight(heights, i, parentContext, parentgc,
+ /*
+ * NOTE: 0, 0, here is ok
+ * because we are only
+ * obtaining "null" units
+ */
+ 0, 0, 1, 0, dd)/
+ sumHeight;
+ } else {
+ /*
+ * If ALL relative heights are zero then they all get
+ * allocated zero height
+ */
+ setRemainingHeightZero(layout, relativeHeights, npcHeights);
+ }
+}
+
+static double sumDims(double dims[], int from, int to)
+{
+ int i;
+ double s = 0;
+ for (i = from; i < to + 1; i++)
+ s = s + dims[i];
+ return s;
+}
+
+static void subRegion(SEXP layout,
+ int minrow, int maxrow, int mincol, int maxcol,
+ double widths[], double heights[],
+ double parentWidthCM, double parentHeightCM,
+ double *left, double *bottom,
+ double *width, double *height)
+{
+ double hjust = layoutHJust(layout);
+ double vjust = layoutVJust(layout);
+ double totalWidth = sumDims(widths, 0, layoutNCol(layout) - 1);
+ double totalHeight = sumDims(heights, 0, layoutNRow(layout) - 1);
+ *width = sumDims(widths, mincol, maxcol);
+ *height = sumDims(heights, minrow, maxrow);
+ /* widths and heights are in CM */
+ *left = parentWidthCM*hjust - totalWidth*hjust +
+ sumDims(widths, 0, mincol - 1);
+ *bottom = parentHeightCM*vjust + (1 - vjust)*totalHeight -
+ sumDims(heights, 0, maxrow);
+ /*
+ * From when hjust and vjust were enums
+ *
+ switch (layoutHJust(layout)) {
+ case L_LEFT:
+ *left = sumDims(widths, 0, mincol - 1);
+ break;
+ case L_RIGHT:
+ *left = 1 - sumDims(widths, mincol, layoutNCol(layout) - 1);
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ *left = (0.5 - totalWidth/2) + sumDims(widths, 0, mincol - 1);
+ break;
+ }
+ switch (layoutVJust(layout)) {
+ case L_BOTTOM:
+ *bottom = totalHeight - sumDims(heights, 0, maxrow);
+ break;
+ case L_TOP:
+ *bottom = 1 - sumDims(heights, 0, maxrow);
+ break;
+ case L_CENTRE:
+ case L_CENTER:
+ *bottom = (0.5 - totalHeight/2) + totalHeight
+ - sumDims(heights, 0, maxrow);
+ }
+ */
+}
+
+void calcViewportLayout(SEXP viewport,
+ double parentWidthCM,
+ double parentHeightCM,
+ LViewportContext parentContext,
+ const pGEcontext parentgc,
+ pGEDevDesc dd)
+{
+ int i;
+ SEXP currentWidths, currentHeights;
+ SEXP layout = viewportLayout(viewport);
+ double *npcWidths = (double *) R_alloc(layoutNCol(layout), sizeof(double));
+ double *npcHeights = (double *) R_alloc(layoutNRow(layout),
+ sizeof(double));
+ int *relativeWidths = (int *) R_alloc(layoutNCol(layout), sizeof(int));
+ int *relativeHeights = (int *) R_alloc(layoutNRow(layout), sizeof(int));
+ double reducedWidthCM = parentWidthCM;
+ double reducedHeightCM = parentHeightCM;
+ /* Figure out which rows and cols have relative heights and widths
+ */
+ findRelWidths(layout, relativeWidths, dd);
+ findRelHeights(layout, relativeHeights, dd);
+ /* For any width or height which has a unit other than "null"
+ * we can immediately figure out its physical size.
+ * We do this and return the widthCM and heightCM
+ * remaining after these widths and heights have been allocated
+ */
+ allocateKnownWidths(layout, relativeWidths,
+ parentWidthCM, parentHeightCM,
+ parentContext, parentgc,
+ dd, npcWidths,
+ &reducedWidthCM);
+ allocateKnownHeights(layout, relativeHeights,
+ parentWidthCM, parentHeightCM,
+ parentContext, parentgc,
+ dd, npcHeights,
+ &reducedHeightCM);
+
+ /* Now allocate respected widths and heights and return
+ * widthCM and heightCM remaining
+ */
+ if (reducedWidthCM > 0 ||
+ reducedHeightCM > 0) {
+ allocateRespected(layout, relativeWidths, relativeHeights,
+ &reducedWidthCM, &reducedHeightCM,
+ parentContext, parentgc, dd,
+ npcWidths, npcHeights);
+ } else {
+ /*
+ * IF EITHER we started with ZERO widthCM and heightCM
+ * OR we've used up all the widthCM and heightCM
+ * THEN all respected widths/heights get ZERO
+ */
+ setRespectedZero(layout, relativeWidths, relativeHeights,
+ npcWidths, npcHeights);
+ }
+ /* Now allocate relative widths and heights (unit = "null")
+ * in the remaining space
+ */
+ if (reducedWidthCM > 0) {
+ allocateRemainingWidth(layout, relativeWidths,
+ reducedWidthCM,
+ parentContext, parentgc, dd, npcWidths);
+ } else {
+ /*
+ * IF EITHER we started with ZERO width
+ * OR we've used up all the width
+ * THEN any relative widths get ZERO
+ */
+ setRemainingWidthZero(layout, relativeWidths, npcWidths);
+ }
+ if (reducedHeightCM > 0) {
+ allocateRemainingHeight(layout, relativeHeights,
+ reducedHeightCM,
+ parentContext, parentgc, dd, npcHeights);
+ } else {
+ /*
+ * IF EITHER we started with ZERO height
+ * OR we've used up all the height
+ * THEN any relative heights get ZERO
+ */
+ setRemainingHeightZero(layout, relativeHeights, npcHeights);
+ }
+ /* Record the widths and heights in the viewport
+ */
+ PROTECT(currentWidths = allocVector(REALSXP, layoutNCol(layout)));
+ PROTECT(currentHeights = allocVector(REALSXP, layoutNRow(layout)));
+ for (i=0; i<layoutNCol(layout); i++) {
+ /* Layout widths are stored in CM
+ */
+ REAL(currentWidths)[i] = npcWidths[i];
+ }
+ for (i=0; i<layoutNRow(layout); i++) {
+ /* Layout heights are stored in CM
+ */
+ REAL(currentHeights)[i] = npcHeights[i];
+ }
+ SET_VECTOR_ELT(viewport, PVP_WIDTHS, currentWidths);
+ SET_VECTOR_ELT(viewport, PVP_HEIGHTS, currentHeights);
+ UNPROTECT(2);
+}
+
+Rboolean checkPosRowPosCol(SEXP vp, SEXP parent)
+{
+ int ncol = layoutNCol(viewportLayout(parent));
+ int nrow = layoutNRow(viewportLayout(parent));
+ if (!isNull(viewportLayoutPosRow(vp)) &&
+ (INTEGER(viewportLayoutPosRow(vp))[0] < 1 ||
+ INTEGER(viewportLayoutPosRow(vp))[1] > nrow))
+ error(_("invalid 'layout.pos.row'"));
+ if (!isNull(viewportLayoutPosCol(vp)) &&
+ (INTEGER(viewportLayoutPosCol(vp))[0] < 1 ||
+ INTEGER(viewportLayoutPosCol(vp))[1] > ncol))
+ error(_("invalid 'layout.pos.col'"));
+ return TRUE;
+}
+
+void calcViewportLocationFromLayout(SEXP layoutPosRow,
+ SEXP layoutPosCol,
+ SEXP parent,
+ LViewportLocation *vpl)
+{
+ int minrow, maxrow, mincol, maxcol;
+ double x, y, width, height;
+ SEXP vpx, vpy, vpwidth, vpheight;
+ SEXP layout = viewportLayout(parent);
+ /* It is possible for ONE of layoutPosRow and layoutPosCol to
+ * be NULL; this is interpreted as "occupy all rows/cols"
+ * NOTE: The " - 1" is there because R is 1-based and C is zero-based
+ */
+ if (isNull(layoutPosRow)) {
+ minrow = 0;
+ maxrow = layoutNRow(layout) - 1;
+ } else {
+ minrow = INTEGER(layoutPosRow)[0] - 1;
+ maxrow = INTEGER(layoutPosRow)[1] - 1;
+ }
+ if (isNull(layoutPosCol)) {
+ mincol = 0;
+ maxcol = layoutNCol(layout) - 1;
+ } else {
+ mincol = INTEGER(layoutPosCol)[0] - 1;
+ maxcol = INTEGER(layoutPosCol)[1] - 1;
+ }
+ /* Put the relevant values into vpl */
+ subRegion(viewportLayout(parent), minrow, maxrow, mincol, maxcol,
+ REAL(viewportLayoutWidths(parent)),
+ REAL(viewportLayoutHeights(parent)),
+ REAL(viewportWidthCM(parent))[0],
+ REAL(viewportHeightCM(parent))[0],
+ &x, &y, &width, &height);
+ /* Layout widths and heights are stored in CM
+ */
+ PROTECT(vpx = unit(x, L_CM));
+ vpl->x = vpx;
+ PROTECT(vpy = unit(y, L_CM));
+ vpl->y = vpy;
+ PROTECT(vpwidth = unit(width, L_CM));
+ vpl->width = vpwidth;
+ PROTECT(vpheight = unit(height, L_CM));
+ vpl->height = vpheight;
+ vpl->hjust = 0;
+ vpl->vjust = 0;
+ /* Question: Is there any chance that these newly-allocated
+ * unit SEXPs will get corrupted after this unprotect ??
+ */
+ UNPROTECT(4);
+}
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/matrix.c b/com.oracle.truffle.r.native/library/grid/src/matrix.c
new file mode 100644
index 0000000000..edae7088d0
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/matrix.c
@@ -0,0 +1,153 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+
+/* Code for matrices, matrix multiplication, etc for performing
+ * 2D affine transformations: translations, scaling, and rotations.
+ */
+
+double locationX(LLocation l) {
+ return l[0];
+}
+
+double locationY(LLocation l) {
+ return l[1];
+}
+
+void copyTransform(LTransform t1, LTransform t2)
+{
+ int i, j;
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ t2[i][j] = t1[i][j];
+}
+
+void invTransform(LTransform t, LTransform invt)
+{
+ double det = t[0][0]*(t[2][2]*t[1][1] - t[2][1]*t[1][2]) -
+ t[1][0]*(t[2][2]*t[0][1] - t[2][1]*t[0][2]) +
+ t[2][0]*(t[1][2]*t[0][1] - t[1][1]*t[0][2]);
+ if (det == 0)
+ error(_("singular transformation matrix"));
+ invt[0][0] = 1/det*(t[2][2]*t[1][1] - t[2][1]*t[1][2]);
+ invt[0][1] = -1/det*(t[2][2]*t[0][1] - t[2][1]*t[0][2]);
+ invt[0][2] = 1/det*(t[1][2]*t[0][1] - t[1][1]*t[0][2]);
+ invt[1][0] = -1/det*(t[2][2]*t[1][0] - t[2][0]*t[1][2]);
+ invt[1][1] = 1/det*(t[2][2]*t[0][0] - t[2][0]*t[0][2]);
+ invt[1][2] = -1/det*(t[1][2]*t[0][0] - t[1][0]*t[0][2]);
+ invt[2][0] = 1/det*(t[2][1]*t[1][0] - t[2][0]*t[1][1]);
+ invt[2][1] = -1/det*(t[2][1]*t[0][0] - t[2][0]*t[0][1]);
+ invt[2][2] = 1/det*(t[1][1]*t[0][0] - t[1][0]*t[0][1]);
+}
+
+void identity(LTransform m)
+{
+ int i, j;
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ if (i == j)
+ m[i][j] = 1;
+ else
+ m[i][j] = 0;
+}
+
+void translation(double tx, double ty, LTransform m)
+{
+ identity(m);
+ m[2][0] = tx;
+ m[2][1] = ty;
+}
+
+void scaling(double sx, double sy, LTransform m)
+{
+ identity(m);
+ m[0][0] = sx;
+ m[1][1] = sy;
+}
+
+void rotation(double theta, LTransform m)
+{
+ double thetarad = theta/180*M_PI;
+ double costheta = cos(thetarad);
+ double sintheta = sin(thetarad);
+ identity(m);
+ m[0][0] = costheta;
+ m[0][1] = sintheta;
+ m[1][0] = -sintheta;
+ m[1][1] = costheta;
+}
+
+void multiply(LTransform m1, LTransform m2, LTransform m)
+{
+ m[0][0] = m1[0][0]*m2[0][0] + m1[0][1]*m2[1][0] + m1[0][2]*m2[2][0];
+ m[0][1] = m1[0][0]*m2[0][1] + m1[0][1]*m2[1][1] + m1[0][2]*m2[2][1];
+ m[0][2] = m1[0][0]*m2[0][2] + m1[0][1]*m2[1][2] + m1[0][2]*m2[2][2];
+ m[1][0] = m1[1][0]*m2[0][0] + m1[1][1]*m2[1][0] + m1[1][2]*m2[2][0];
+ m[1][1] = m1[1][0]*m2[0][1] + m1[1][1]*m2[1][1] + m1[1][2]*m2[2][1];
+ m[1][2] = m1[1][0]*m2[0][2] + m1[1][1]*m2[1][2] + m1[1][2]*m2[2][2];
+ m[2][0] = m1[2][0]*m2[0][0] + m1[2][1]*m2[1][0] + m1[2][2]*m2[2][0];
+ m[2][1] = m1[2][0]*m2[0][1] + m1[2][1]*m2[1][1] + m1[2][2]*m2[2][1];
+ m[2][2] = m1[2][0]*m2[0][2] + m1[2][1]*m2[1][2] + m1[2][2]*m2[2][2];
+}
+
+void location(double x, double y, LLocation v)
+{
+ v[0] = x;
+ v[1] = y;
+ v[2] = 1;
+}
+
+void trans(LLocation vin, LTransform m, LLocation vout)
+{
+ vout[0] = vin[0]*m[0][0] + vin[1]*m[1][0] + vin[2]*m[2][0];
+ vout[1] = vin[0]*m[0][1] + vin[1]*m[1][1] + vin[2]*m[2][1];
+ vout[2] = vin[0]*m[0][2] + vin[1]*m[1][2] + vin[2]*m[2][2];
+}
+
+/* Testing code
+ * Need to undocument main() below and add #include <math.h> at top of file
+ * Correct answers are "2.67 2.00 1.00" for m4=identity
+ * and "0.00 2.00 1.00" for m4=rotation
+ */
+
+/*
+ main()
+ {
+ LLocation v1, v2;
+ LTransform m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11;
+ location(9, 10, v1);
+ translation(-5, -6, m1);
+ scaling(1/7.0, 1/8.0, m2);
+ scaling(7, 8, m3);
+ identity(m4);
+ rotation(3.141592 / 2, m4);
+ translation(4, 4, m5);
+ scaling(1/3.0, 1/4.0, m6);
+ multiply(m1, m2, m7);
+ multiply(m7, m3, m8);
+ multiply(m8, m4, m9);
+ multiply(m9, m5, m10);
+ multiply(m10, m6, m11);
+ transform(v1, m11, v2);
+ printf("%1.2f %1.2f %1.2f\n", v2[0], v2[1], v2[2]);
+ }
+*/
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/register.c b/com.oracle.truffle.r.native/library/grid/src/register.c
new file mode 100644
index 0000000000..43c2075a34
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/register.c
@@ -0,0 +1,100 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-12 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+/* Code to register grid functions with R
+ */
+#include <R_ext/Rdynload.h>
+#include "grid.h"
+
+static const R_CallMethodDef callMethods[] = {
+ {"L_initGrid", (DL_FUNC) &L_initGrid, 1},
+ {"L_killGrid", (DL_FUNC) &L_killGrid, 0},
+ {"L_gridDirty", (DL_FUNC) &L_gridDirty, 0},
+ {"L_currentViewport", (DL_FUNC) &L_currentViewport, 0},
+ {"L_setviewport", (DL_FUNC) &L_setviewport, 2},
+ {"L_downviewport", (DL_FUNC) &L_downviewport, 2},
+ {"L_downvppath", (DL_FUNC) &L_downvppath, 3},
+ {"L_unsetviewport", (DL_FUNC) &L_unsetviewport, 1},
+ {"L_upviewport", (DL_FUNC) &L_upviewport, 1},
+ {"L_getDisplayList", (DL_FUNC) &L_getDisplayList, 0},
+ {"L_setDisplayList", (DL_FUNC) &L_setDisplayList, 1},
+ {"L_getDLelt", (DL_FUNC) &L_getDLelt, 1},
+ {"L_setDLelt", (DL_FUNC) &L_setDLelt, 1},
+ {"L_getDLindex", (DL_FUNC) &L_getDLindex, 0},
+ {"L_setDLindex", (DL_FUNC) &L_setDLindex, 1},
+ {"L_getDLon", (DL_FUNC) &L_getDLon, 0},
+ {"L_setDLon", (DL_FUNC) &L_setDLon, 1},
+ {"L_getEngineDLon", (DL_FUNC) &L_getEngineDLon, 0},
+ {"L_setEngineDLon", (DL_FUNC) &L_setEngineDLon, 1},
+ {"L_getCurrentGrob", (DL_FUNC) &L_getCurrentGrob, 0},
+ {"L_setCurrentGrob", (DL_FUNC) &L_setCurrentGrob, 1},
+ {"L_getEngineRecording", (DL_FUNC) &L_getEngineRecording, 0},
+ {"L_setEngineRecording", (DL_FUNC) &L_setEngineRecording, 1},
+ {"L_currentGPar", (DL_FUNC) &L_currentGPar, 0},
+ {"L_newpagerecording", (DL_FUNC) &L_newpagerecording, 0},
+ {"L_newpage", (DL_FUNC) &L_newpage, 0},
+ {"L_initGPar", (DL_FUNC) &L_initGPar, 0},
+ {"L_initViewportStack", (DL_FUNC) &L_initViewportStack, 0},
+ {"L_initDisplayList", (DL_FUNC) &L_initDisplayList, 0},
+ {"L_moveTo", (DL_FUNC) &L_moveTo, 2},
+ {"L_lineTo", (DL_FUNC) &L_lineTo, 3},
+ {"L_lines", (DL_FUNC) &L_lines, 4},
+ {"L_segments", (DL_FUNC) &L_segments, 5},
+ {"L_arrows", (DL_FUNC) &L_arrows, 12},
+ {"L_path", (DL_FUNC) &L_path, 4},
+ {"L_polygon", (DL_FUNC) &L_polygon, 3},
+ {"L_xspline", (DL_FUNC) &L_xspline, 7},
+ {"L_circle", (DL_FUNC) &L_circle, 3},
+ {"L_rect", (DL_FUNC) &L_rect, 6},
+ {"L_raster", (DL_FUNC) &L_raster, 8},
+ {"L_cap", (DL_FUNC) &L_cap, 0},
+ {"L_text", (DL_FUNC) &L_text, 7},
+ {"L_points", (DL_FUNC) &L_points, 4},
+ {"L_clip", (DL_FUNC) &L_clip, 6},
+ {"L_pretty", (DL_FUNC) &L_pretty, 1},
+ {"L_locator", (DL_FUNC) &L_locator, 0},
+ {"L_convert", (DL_FUNC) &L_convert, 4},
+ {"L_layoutRegion", (DL_FUNC) &L_layoutRegion, 2},
+ {"validUnits", (DL_FUNC) &validUnits, 1},
+ {"L_getGPar", (DL_FUNC) &L_getGPar, 0},
+ {"L_setGPar", (DL_FUNC) &L_setGPar, 1},
+ {"L_circleBounds", (DL_FUNC) &L_circleBounds, 4},
+ {"L_locnBounds", (DL_FUNC) &L_locnBounds, 3},
+ {"L_rectBounds", (DL_FUNC) &L_rectBounds, 7},
+ {"L_textBounds", (DL_FUNC) &L_textBounds, 7},
+ {"L_xsplineBounds", (DL_FUNC) &L_xsplineBounds, 8},
+ {"L_xsplinePoints", (DL_FUNC) &L_xsplinePoints, 8},
+ {"L_stringMetric", (DL_FUNC) &L_stringMetric, 1},
+ { NULL, NULL, 0 }
+};
+
+
+void
+#ifdef HAVE_VISIBILITY_ATTRIBUTE
+__attribute__ ((visibility ("default")))
+#endif
+R_init_grid(DllInfo *dll)
+{
+ /* No .C, .Fortran, or .External routines => NULL
+ */
+ R_registerRoutines(dll, NULL, callMethods, NULL, NULL);
+ R_useDynamicSymbols(dll, FALSE);
+ R_forceSymbols(dll, FALSE);
+}
diff --git a/com.oracle.truffle.r.native/library/grid/src/state.c b/com.oracle.truffle.r.native/library/grid/src/state.c
new file mode 100644
index 0000000000..a6e68d670e
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/state.c
@@ -0,0 +1,302 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-5 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+
+int gridRegisterIndex;
+
+/* The gridSystemState (per device) consists of
+ * GSS_DEVSIZE 0 = current size of device
+ * GSS_CURRLOC 1 = current location of grid "pen"
+ * GSS_DL 2 = grid display list
+ * GSS_DLINDEX 3 = display list index
+ * GSS_DLON 4 = is the display list on?
+ * GSS_GPAR 5 = gpar settings
+ * GSS_GPSAVED 6 = previous gpar settings
+ * GSS_VP 7 = viewport
+ * GSS_GLOBALINDEX 8 = index of this system state in the global list of states
+ * GSS_GRIDDEVICE 9 = does this device contain grid output?
+ * GSS_PREVLOC 10 = previous location of grid "pen"
+ * GSS_ENGINEDLON 11 = are we using the graphics engine's display list?
+ * GSS_CURRGROB 12 = current grob being drawn (for determining
+ * the list of grobs to search when evaluating a grobwidth/height
+ * unit via gPath)
+ * GSS_ENGINERECORDING 13 = are we already inside a .Call.graphics call?
+ * Used by grid.Call.graphics to avoid unnecessary recording on
+ * engine display list
+ * [GSS_ASK 14 = should we prompt the user before starting a new page?
+ * Replaced by per-device setting as from R 2.7.0.]
+ * GSS_SCALE 15 = a scale or "zoom" factor for all output
+ * (to support "fit to window" resizing on windows device)
+ *
+ * NOTE: if you add to this list you MUST change the size of the vector
+ * allocated in createGridSystemState() below.
+*/
+
+SEXP createGridSystemState()
+{
+ return allocVector(VECSXP, 16);
+}
+
+void initDL(pGEDevDesc dd)
+{
+ SEXP dl, dlindex;
+ SEXP vp = gridStateElement(dd, GSS_VP);
+ SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ /* The top-level viewport goes at the start of the display list
+ */
+ PROTECT(dl = allocVector(VECSXP, 100));
+ SET_VECTOR_ELT(dl, 0, vp);
+ SET_VECTOR_ELT(gsd, GSS_DL, dl);
+ PROTECT(dlindex = allocVector(INTSXP, 1));
+ INTEGER(dlindex)[0] = 1;
+ SET_VECTOR_ELT(gsd, GSS_DLINDEX, dlindex);
+ UNPROTECT(2);
+}
+
+/*
+ * This is used to init some bits of the system state
+ * Called when a grahpics engine redraw is about to occur
+ * NOTE that it does not init all of the state, in particular,
+ * the display list is not initialised here (see initDL),
+ * nor is the ROOT viewport (see initVP),
+ * nor is the current gpar (see initGP)
+ */
+void initOtherState(pGEDevDesc dd)
+{
+ SEXP currloc, prevloc, recording;
+ SEXP state = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ currloc = VECTOR_ELT(state, GSS_CURRLOC);
+ REAL(currloc)[0] = NA_REAL;
+ REAL(currloc)[1] = NA_REAL;
+ prevloc = VECTOR_ELT(state, GSS_PREVLOC);
+ REAL(prevloc)[0] = NA_REAL;
+ REAL(prevloc)[1] = NA_REAL;
+ SET_VECTOR_ELT(state, GSS_CURRGROB, R_NilValue);
+ recording = VECTOR_ELT(state, GSS_ENGINERECORDING);
+ LOGICAL(recording)[0] = FALSE;
+ SET_VECTOR_ELT(state, GSS_ENGINERECORDING, recording);
+}
+
+void fillGridSystemState(SEXP state, pGEDevDesc dd)
+{
+ SEXP devsize, currloc, prevloc;
+
+ PROTECT(state);
+ devsize = allocVector(REALSXP, 2);
+ REAL(devsize)[0] = 0;
+ REAL(devsize)[1] = 0;
+ SET_VECTOR_ELT(state, GSS_DEVSIZE, devsize);
+ /* "current location"
+ * Initial setting relies on the fact that all values sent to devices
+ * are in INCHES; so (0, 0) is the bottom-left corner of the device.
+ */
+ currloc = allocVector(REALSXP, 2);
+ REAL(currloc)[0] = NA_REAL;
+ REAL(currloc)[1] = NA_REAL;
+ SET_VECTOR_ELT(state, GSS_CURRLOC, currloc);
+ prevloc = allocVector(REALSXP, 2);
+ REAL(prevloc)[0] = NA_REAL;
+ REAL(prevloc)[1] = NA_REAL;
+ SET_VECTOR_ELT(state, GSS_PREVLOC, prevloc);
+ SET_VECTOR_ELT(state, GSS_DLON, ScalarLogical(TRUE));
+ SET_VECTOR_ELT(state, GSS_ENGINEDLON, ScalarLogical(TRUE));
+ SET_VECTOR_ELT(state, GSS_CURRGROB, R_NilValue);
+ SET_VECTOR_ELT(state, GSS_ENGINERECORDING, ScalarLogical(FALSE));
+ initGPar(dd);
+ SET_VECTOR_ELT(state, GSS_GPSAVED, R_NilValue);
+ /* Do NOT initialise top-level viewport or grid display list for
+ * this device until there is some grid output
+ */
+ SET_VECTOR_ELT(state, GSS_GLOBALINDEX, R_NilValue);
+ /* Note that no grid output has occurred on the device yet.
+ */
+ SET_VECTOR_ELT(state, GSS_GRIDDEVICE, ScalarLogical(FALSE));
+#if 0
+ SET_VECTOR_ELT(state, GSS_ASK, ScalarLogical(dd->ask));
+#endif
+ SET_VECTOR_ELT(state, GSS_SCALE, ScalarReal(1.0));
+ UNPROTECT(1);
+}
+
+SEXP gridStateElement(pGEDevDesc dd, int elementIndex)
+{
+ return VECTOR_ELT((SEXP) dd->gesd[gridRegisterIndex]->systemSpecific,
+ elementIndex);
+}
+
+void setGridStateElement(pGEDevDesc dd, int elementIndex, SEXP value)
+{
+ SET_VECTOR_ELT((SEXP) dd->gesd[gridRegisterIndex]->systemSpecific,
+ elementIndex, value);
+}
+
+static void deglobaliseState(SEXP state)
+{
+ int index = INTEGER(VECTOR_ELT(state, GSS_GLOBALINDEX))[0];
+ SET_VECTOR_ELT(findVar(install(".GRID.STATE"), R_gridEvalEnv),
+ index, R_NilValue);
+}
+
+static int findStateSlot()
+{
+ int i;
+ int result = -1;
+ SEXP globalstate = findVar(install(".GRID.STATE"), R_gridEvalEnv);
+ for (i = 0; i < length(globalstate); i++)
+ if (VECTOR_ELT(globalstate, i) == R_NilValue) {
+ result = i;
+ break;
+ }
+ if (result < 0)
+ error(_("unable to store 'grid' state. Too many devices open?"));
+ return result;
+}
+
+static void globaliseState(SEXP state)
+{
+ int index = findStateSlot();
+ SEXP globalstate, indexsxp;
+ PROTECT(globalstate = findVar(install(".GRID.STATE"), R_gridEvalEnv));
+ /* Record the index for deglobalisation
+ */
+ PROTECT(indexsxp = allocVector(INTSXP, 1));
+ INTEGER(indexsxp)[0] = index;
+ SET_VECTOR_ELT(state, GSS_GLOBALINDEX, indexsxp);
+ SET_VECTOR_ELT(globalstate, index, state);
+ UNPROTECT(2);
+}
+
+SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data) {
+ SEXP result = R_NilValue;
+ SEXP valid, scale;
+ SEXP gridState;
+ GESystemDesc *sd;
+ SEXP currentgp;
+ SEXP gsd;
+ SEXP devsize;
+ R_GE_gcontext gc;
+ switch (task) {
+ case GE_InitState:
+ /* Create the initial grid state for a device
+ */
+ PROTECT(gridState = createGridSystemState());
+ /* Store that state with the device for easy retrieval
+ */
+ sd = dd->gesd[gridRegisterIndex];
+ sd->systemSpecific = (void*) gridState;
+ /* Initialise the grid state for a device
+ */
+ fillGridSystemState(gridState, dd);
+ /* Also store the state beneath a top-level variable so
+ * that it does not get garbage-collected
+ */
+ globaliseState(gridState);
+ /* Indicate success */
+ result = R_BlankString;
+ UNPROTECT(1);
+ break;
+ case GE_FinaliseState:
+ sd = dd->gesd[gridRegisterIndex];
+ /* Simply detach the system state from the global variable
+ * and it will be garbage-collected
+ */
+ deglobaliseState((SEXP) sd->systemSpecific);
+ /* Also set the device pointer to NULL
+ */
+ sd->systemSpecific = NULL;
+ break;
+ case GE_SaveState:
+ break;
+ case GE_RestoreState:
+ gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ PROTECT(devsize = allocVector(REALSXP, 2));
+ getDeviceSize(dd, &(REAL(devsize)[0]), &(REAL(devsize)[1]));
+ SET_VECTOR_ELT(gsd, GSS_DEVSIZE, devsize);
+ UNPROTECT(1);
+ /* Only bother to do any grid drawing setup
+ * if there has been grid output
+ * on this device.
+ */
+ if (LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
+ if (LOGICAL(gridStateElement(dd, GSS_ENGINEDLON))[0]) {
+ /* The graphics engine is about to replay the display list
+ * So we "clear" the device and reset the grid graphics state
+ */
+ /* There are two main situations in which this occurs:
+ * (i) a screen is resized
+ * In this case, it is ok-ish to do a GENewPage
+ * because that has the desired effect and no
+ * undesirable effects because it only happens on
+ * a screen device -- a new page is the same as
+ * clearing the screen
+ * (ii) output on one device is copied to another device
+ * In this case, a GENewPage is NOT a good thing, however,
+ * here we will start with a new device and it will not
+ * have any grid output so this section will not get called
+ * SO we will not get any unwanted blank pages.
+ *
+ * All this is a bit fragile; ultimately, what would be ideal
+ * is a dev->clearPage primitive for all devices in addition
+ * to the dev->newPage primitive
+ */
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ GENewPage(&gc, dd);
+ initGPar(dd);
+ initVP(dd);
+ initOtherState(dd);
+ } else {
+ /*
+ * If we have turned off the graphics engine's display list
+ * then we have to redraw the scene ourselves
+ */
+ SEXP fcall;
+ PROTECT(fcall = lang1(install("draw.all")));
+ eval(fcall, R_gridEvalEnv);
+ UNPROTECT(1);
+ }
+ }
+ break;
+ case GE_CopyState:
+ break;
+ case GE_CheckPlot:
+ PROTECT(valid = allocVector(LGLSXP, 1));
+ LOGICAL(valid)[0] = TRUE;
+ UNPROTECT(1);
+ result = valid;
+ case GE_SaveSnapshotState:
+ break;
+ case GE_RestoreSnapshotState:
+ break;
+ case GE_ScalePS:
+ /*
+ * data is a numeric scale factor
+ */
+ PROTECT(scale = allocVector(REALSXP, 1));
+ REAL(scale)[0] = REAL(gridStateElement(dd, GSS_SCALE))[0]*
+ REAL(data)[0];
+ setGridStateElement(dd, GSS_SCALE, scale);
+ UNPROTECT(1);
+ break;
+ }
+ return result;
+}
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/unit.c b/com.oracle.truffle.r.native/library/grid/src/unit.c
new file mode 100644
index 0000000000..2d9459ed7b
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/unit.c
@@ -0,0 +1,1923 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-2013 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+#include <math.h>
+#include <float.h>
+#include <string.h>
+
+int isUnitArithmetic(SEXP ua) {
+ return inherits(ua, "unit.arithmetic");
+}
+
+int isUnitList(SEXP ul) {
+ return inherits(ul, "unit.list");
+}
+
+/* Function to build a single-value unit SEXP internally.
+ * Cannot build units requiring data as yet.
+ */
+SEXP unit(double value, int unit)
+{
+ SEXP u, units, classname;
+ PROTECT(u = ScalarReal(value));
+ PROTECT(units = ScalarInteger(unit));
+ /* NOTE that we do not set the "unit" attribute */
+ setAttrib(u, install("valid.unit"), units);
+ setAttrib(u, install("data"), R_NilValue);
+ PROTECT(classname = mkString("unit"));
+ classgets(u, classname);
+ UNPROTECT(3);
+ return u;
+}
+
+/* Accessor functions for unit objects
+ */
+
+/*
+ * This is an attempt to extract a single numeric value from
+ * a unit. This is ONLY designed for use on "simple" units
+ * (i.e., NOT unitLists or unitArithmetics)
+ */
+double unitValue(SEXP unit, int index) {
+ /* Recycle values if necessary (used in unit arithmetic)
+ */
+ int n = LENGTH(unit);
+ return numeric(unit, index % n);
+}
+
+int unitUnit(SEXP unit, int index) {
+ SEXP units = getAttrib(unit, install("valid.unit"));
+ /* Recycle units if necessary
+ */
+ int n = LENGTH(units);
+ return INTEGER(units)[index % n];
+}
+
+SEXP unitData(SEXP unit, int index) {
+ SEXP result;
+ SEXP data = getAttrib(unit, install("data"));
+ if (isNull(data))
+ result = R_NilValue;
+ else if(TYPEOF(data) == VECSXP) {
+ /* Recycle data if necessary
+ */
+ int n = LENGTH(data);
+ result = VECTOR_ELT(data, index % n);
+ } else {
+ warning("unit attribute 'data' is of incorrect type");
+ return R_NilValue;
+ }
+ return result;
+}
+
+/* Accessor functions for unit arithmetic object
+ */
+const char* fName(SEXP ua) {
+ return CHAR(STRING_ELT(getListElement(ua, "fname"), 0));
+}
+
+SEXP arg1(SEXP ua) {
+ return getListElement(ua, "arg1");
+}
+
+SEXP arg2(SEXP ua) {
+ return getListElement(ua, "arg2");
+}
+
+int fNameMatch(SEXP ua, char *aString) {
+ return !strcmp(fName(ua), aString);
+}
+
+int addOp(SEXP ua) {
+ return fNameMatch(ua, "+");
+}
+
+int minusOp(SEXP ua) {
+ return fNameMatch(ua, "-");
+}
+
+int timesOp(SEXP ua) {
+ return fNameMatch(ua, "*");
+}
+
+int fOp(SEXP ua) {
+ return addOp(ua) || minusOp(ua) || timesOp(ua);
+}
+
+int minFunc(SEXP ua) {
+ return fNameMatch(ua, "min");
+}
+
+int maxFunc(SEXP ua) {
+ return fNameMatch(ua, "max");
+}
+
+int sumFunc(SEXP ua) {
+ return fNameMatch(ua, "sum");
+}
+
+/* Functions in lattice.c should use this to determine the length
+ * of a unit/unitArithmetic object rather than just LENGTH.
+ */
+int unitLength(SEXP u)
+{
+ int result = 0;
+ if (isUnitList(u))
+ result = LENGTH(u);
+ else if (isUnitArithmetic(u))
+ if (fOp(u)) {
+ if (timesOp(u)) {
+ /*
+ * arg1 is always the numeric vector
+ */
+ int n1 = LENGTH(arg1(u));
+ int n2 = unitLength(arg2(u));
+ result = (n1 > n2) ? n1 : n2;
+ } else { /* must be "+" or "-" */
+ int n1 = unitLength(arg1(u));
+ int n2 = unitLength(arg2(u));
+ result = (n1 > n2) ? n1 : n2;
+ }
+ } else /* must be "min" or "max" or "sum" */
+ result = 1; /* unitLength(arg1(u)); */
+ else /* Must be a unit object */
+ result = LENGTH(u);
+ return result;
+}
+
+
+/**************************
+ * Code for handling "null" units
+ **************************
+ */
+
+/* Global mode indicators:
+ * The value returned for a "null" unit depends on ...
+ * (i) whether layout is calling for evaluation of a "pure null" unit
+ * (in which case, the value of the "null" unit is returned)
+ * (ii) the sort of arithmetic that is being performed
+ * (in which case, an "identity" value is returned)
+ */
+
+/*
+ * Evaluate a "null" _value_ dependent on the evaluation context
+ */
+static double evaluateNullUnit(double value, double thisCM,
+ int nullLayoutMode, int nullArithmeticMode) {
+ double result = value;
+ if (!nullLayoutMode)
+ switch (nullArithmeticMode) {
+ case L_plain:
+ case L_adding:
+ case L_subtracting:
+ case L_summing:
+ result = 0;
+ break;
+ case L_multiplying:
+ result = 0;
+ break;
+ case L_maximising:
+ result = 0;
+ break;
+ case L_minimising:
+ result = thisCM;
+ break;
+ }
+ return result;
+}
+
+/*
+ * Evaluate a "null" _unit_
+ * This is used by layout code to get a single "null" _value_
+ * from a pureNullUnit (which may be a unitList or a unitArithmetic)
+ *
+ * This must ONLY be called on a unit which has passed the
+ * pureNullUnit test below.
+ */
+double pureNullUnitValue(SEXP unit, int index)
+{
+ double result = 0;
+ if (isUnitArithmetic(unit)) {
+ int i;
+ if (addOp(unit)) {
+ result = pureNullUnitValue(arg1(unit), index) +
+ pureNullUnitValue(arg2(unit), index);
+ }
+ else if (minusOp(unit)) {
+ result = pureNullUnitValue(arg1(unit), index) -
+ pureNullUnitValue(arg2(unit), index);
+ }
+ else if (timesOp(unit)) {
+ result = REAL(arg1(unit))[index] *
+ pureNullUnitValue(arg2(unit), index);
+ }
+ else if (minFunc(unit)) {
+ int n = unitLength(arg1(unit));
+ double temp = DBL_MAX;
+ result = pureNullUnitValue(arg1(unit), 0);
+ for (i=1; i<n; i++) {
+ temp = pureNullUnitValue(arg1(unit), i);
+ if (temp < result)
+ result = temp;
+ }
+ }
+ else if (maxFunc(unit)) {
+ int n = unitLength(arg1(unit));
+ double temp = DBL_MIN;
+ result = pureNullUnitValue(arg1(unit), 0);
+ for (i=1; i<n; i++) {
+ temp = pureNullUnitValue(arg1(unit), i);
+ if (temp > result)
+ result = temp;
+ }
+ }
+ else if (sumFunc(unit)) {
+ int n = unitLength(arg1(unit));
+ result = 0.0;
+ for (i=0; i<n; i++) {
+ result += pureNullUnitValue(arg1(unit), i);
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ } else if (isUnitList(unit)) {
+ /*
+ * Recycle if necessary; it is up to the calling code
+ * to limit indices to unit length if desired
+ */
+ int n = unitLength(unit);
+ result = pureNullUnitValue(VECTOR_ELT(unit, index % n), 0);
+ } else
+ result = unitValue(unit, index);
+ return result;
+}
+
+int pureNullUnitArithmetic(SEXP unit, int index, pGEDevDesc dd);
+
+int pureNullUnit(SEXP unit, int index, pGEDevDesc dd) {
+ int result;
+ if (isUnitArithmetic(unit))
+ result = pureNullUnitArithmetic(unit, index, dd);
+ else if (isUnitList(unit)) {
+ /*
+ * Recycle if necessary; it is up to the calling code
+ * to limit indices to unit length if desired
+ */
+ int n = unitLength(unit);
+ result = pureNullUnit(VECTOR_ELT(unit, index % n), 0, dd);
+ } else { /* Just a plain unit */
+ /* Special case: if "grobwidth" or "grobheight" unit
+ * and width/height(grob) is pure null
+ */
+ if (unitUnit(unit, index) == L_GROBWIDTH) {
+ SEXP grob, updatedgrob, width;
+ SEXP widthPreFn, widthFn, widthPostFn, findGrobFn;
+ SEXP R_fcall0, R_fcall1, R_fcall2, R_fcall3;
+ SEXP savedgpar, savedgrob;
+ /*
+ * The data could be a gPath to a grob
+ * In this case, need to find the grob first, and in order
+ * to do that correctly, need to call pre/postDraw code
+ */
+ PROTECT(grob = unitData(unit, index));
+ PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
+ PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
+ PROTECT(widthPreFn = findFun(install("preDraw"),
+ R_gridEvalEnv));
+ PROTECT(widthFn = findFun(install("width"), R_gridEvalEnv));
+ PROTECT(widthPostFn = findFun(install("postDraw"),
+ R_gridEvalEnv));
+ if (inherits(grob, "gPath")) {
+ if (isNull(savedgrob)) {
+ PROTECT(findGrobFn = findFun(install("findGrobinDL"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang2(findGrobFn,
+ getListElement(grob, "name")));
+ grob = eval(R_fcall0, R_gridEvalEnv);
+ } else {
+ PROTECT(findGrobFn =findFun(install("findGrobinChildren"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang3(findGrobFn,
+ getListElement(grob, "name"),
+ getListElement(savedgrob,
+ "children")));
+ grob = eval(R_fcall0, R_gridEvalEnv);
+ }
+ UNPROTECT(2);
+ }
+ PROTECT(R_fcall1 = lang2(widthPreFn, grob));
+ PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
+ PROTECT(R_fcall2 = lang2(widthFn, updatedgrob));
+ PROTECT(width = eval(R_fcall2, R_gridEvalEnv));
+ result = pureNullUnit(width, 0, dd);
+ PROTECT(R_fcall3 = lang2(widthPostFn, updatedgrob));
+ eval(R_fcall3, R_gridEvalEnv);
+ setGridStateElement(dd, GSS_GPAR, savedgpar);
+ setGridStateElement(dd, GSS_CURRGROB, savedgrob);
+ UNPROTECT(11);
+ } else if (unitUnit(unit, index) == L_GROBHEIGHT) {
+ SEXP grob, updatedgrob, height;
+ SEXP heightPreFn, heightFn, heightPostFn, findGrobFn;
+ SEXP R_fcall0, R_fcall1, R_fcall2, R_fcall3;
+ SEXP savedgpar, savedgrob;
+ /*
+ * The data could be a gPath to a grob
+ * In this case, need to find the grob first, and in order
+ * to do that correctly, need to call pre/postDraw code
+ */
+ PROTECT(grob = unitData(unit, index));
+ PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
+ PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
+ PROTECT(heightPreFn = findFun(install("preDraw"),
+ R_gridEvalEnv));
+ PROTECT(heightFn = findFun(install("height"), R_gridEvalEnv));
+ PROTECT(heightPostFn = findFun(install("postDraw"),
+ R_gridEvalEnv));
+ if (inherits(grob, "gPath")) {
+ if (isNull(savedgrob)) {
+ PROTECT(findGrobFn = findFun(install("findGrobinDL"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang2(findGrobFn,
+ getListElement(grob, "name")));
+ grob = eval(R_fcall0, R_gridEvalEnv);
+ } else {
+ PROTECT(findGrobFn =findFun(install("findGrobinChildren"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang3(findGrobFn,
+ getListElement(grob, "name"),
+ getListElement(savedgrob,
+ "children")));
+ grob = eval(R_fcall0, R_gridEvalEnv);
+ }
+ UNPROTECT(2);
+ }
+ PROTECT(R_fcall1 = lang2(heightPreFn, grob));
+ PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
+ PROTECT(R_fcall2 = lang2(heightFn, updatedgrob));
+ PROTECT(height = eval(R_fcall2, R_gridEvalEnv));
+ result = pureNullUnit(height, 0, dd);
+ PROTECT(R_fcall3 = lang2(heightPostFn, updatedgrob));
+ eval(R_fcall3, R_gridEvalEnv);
+ setGridStateElement(dd, GSS_GPAR, savedgpar);
+ setGridStateElement(dd, GSS_CURRGROB, savedgrob);
+ UNPROTECT(11);
+ } else
+ result = unitUnit(unit, index) == L_NULL;
+ }
+ return result;
+}
+
+int pureNullUnitArithmetic(SEXP unit, int index, pGEDevDesc dd) {
+ /*
+ * Initialised to shut up compiler
+ */
+ int result = 0;
+ if (addOp(unit) || minusOp(unit)) {
+ result = pureNullUnit(arg1(unit), index, dd) &&
+ pureNullUnit(arg2(unit), index, dd);
+ }
+ else if (timesOp(unit)) {
+ result = pureNullUnit(arg2(unit), index, dd);
+ }
+ else if (minFunc(unit) || maxFunc(unit) || sumFunc(unit)) {
+ int n = unitLength(arg1(unit));
+ int i = 0;
+ result = 1;
+ while (result && i<n) {
+ result = result && pureNullUnit(arg1(unit), i, dd);
+ i += 1;
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ return result;
+}
+
+/**************************
+ * Code for handling "grobwidth" units
+ **************************
+ */
+
+/* NOTE: this code calls back to R code to perform
+ * set.gpar operations, which will impact on grid state variables
+ * BUT that's ok(ish) because we save and restore the relevant state
+ * variables in here so that the overall effect is NULL.
+ *
+ * FIXME: OTOH, the calls back to R Code may also perform
+ * viewport operations. Again, we restore state as much as possible,
+ * but this can "pollute" the viewport tree in some cases.
+ */
+
+double evaluateGrobUnit(double value, SEXP grob,
+ double vpwidthCM, double vpheightCM,
+ int nullLMode, int nullAMode,
+ /*
+ * Evaluation type
+ * 0 = x, 1 = y, 2 = width, 3 = height
+ */
+ int evalType,
+ pGEDevDesc dd)
+{
+ double vpWidthCM, vpHeightCM;
+ double rotationAngle;
+ LViewportContext vpc;
+ R_GE_gcontext gc;
+ LTransform transform, savedTransform;
+ SEXP currentvp, currentgp;
+ SEXP preFn, postFn, findGrobFn;
+ SEXP evalFnx = R_NilValue, evalFny = R_NilValue;
+ SEXP R_fcall0, R_fcall1, R_fcall2x, R_fcall2y, R_fcall3;
+ SEXP savedgpar, savedgrob, updatedgrob;
+ SEXP unitx = R_NilValue, unity = R_NilValue;
+ double result = 0.0;
+ Rboolean protectedGrob = FALSE;
+ /*
+ * We are just doing calculations, not drawing, so
+ * we don't want anything recorded on the graphics engine DL
+ *
+ * FIXME: This should probably be done via a GraphicsEngine.h
+ * function call rather than directly playing with dd->recordGraphics
+ */
+ Rboolean record = dd->recordGraphics;
+ dd->recordGraphics = FALSE;
+ /*
+ * Save the current viewport transform
+ * (use to convert location relative to current viewport)
+ */
+ currentvp = gridStateElement(dd, GSS_VP);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ savedTransform, &rotationAngle);
+ /*
+ * Save the current gpar state and restore it at the end
+ */
+ PROTECT(savedgpar = gridStateElement(dd, GSS_GPAR));
+ /*
+ * Save the current grob and restore it at the end
+ */
+ PROTECT(savedgrob = gridStateElement(dd, GSS_CURRGROB));
+ /*
+ * Set up for calling R functions
+ */
+ PROTECT(preFn = findFun(install("preDraw"), R_gridEvalEnv));
+ switch(evalType) {
+ case 0:
+ case 1:
+ PROTECT(evalFnx = findFun(install("xDetails"), R_gridEvalEnv));
+ PROTECT(evalFny = findFun(install("yDetails"), R_gridEvalEnv));
+ break;
+ case 2:
+ PROTECT(evalFnx = findFun(install("width"), R_gridEvalEnv));
+ break;
+ case 3:
+ PROTECT(evalFny = findFun(install("height"), R_gridEvalEnv));
+ break;
+ case 4:
+ PROTECT(evalFny = findFun(install("ascentDetails"), R_gridEvalEnv));
+ break;
+ case 5:
+ PROTECT(evalFny = findFun(install("descentDetails"), R_gridEvalEnv));
+ break;
+ }
+ PROTECT(postFn = findFun(install("postDraw"), R_gridEvalEnv));
+ /*
+ * If grob is actually a gPath, use it to find an actual grob
+ */
+ if (inherits(grob, "gPath")) {
+ /*
+ * If the current grob is NULL then we are at the top level
+ * and we search the display list, otherwise we search the
+ * children of the current grob
+ *
+ * NOTE: assume here that only gPath of depth == 1 are valid
+ */
+ if (isNull(savedgrob)) {
+ PROTECT(findGrobFn = findFun(install("findGrobinDL"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang2(findGrobFn,
+ getListElement(grob, "name")));
+ PROTECT(grob = eval(R_fcall0, R_gridEvalEnv));
+ } else {
+ PROTECT(findGrobFn = findFun(install("findGrobinChildren"),
+ R_gridEvalEnv));
+ PROTECT(R_fcall0 = lang3(findGrobFn,
+ getListElement(grob, "name"),
+ getListElement(savedgrob, "children")));
+ PROTECT(grob = eval(R_fcall0, R_gridEvalEnv));
+ }
+ /*
+ * Flag to make sure we UNPROTECT these at the end
+ */
+ protectedGrob = TRUE;
+ }
+ /* Call preDraw(grob)
+ */
+ PROTECT(R_fcall1 = lang2(preFn, grob));
+ PROTECT(updatedgrob = eval(R_fcall1, R_gridEvalEnv));
+ /*
+ * The call to preDraw may have pushed viewports and/or
+ * enforced gpar settings, SO we need to re-establish the
+ * current viewport and gpar settings before evaluating the
+ * width unit.
+ *
+ * NOTE: we are really relying on the grid state to be coherent
+ * when we do stuff like this (i.e., not to have changed since
+ * we started evaluating the unit [other than the changes we may
+ * have deliberately made above by calling preDraw]). In other
+ * words we are relying on no other drawing occurring at the
+ * same time as we are doing this evaluation. In other other
+ * words, we are relying on there being only ONE process
+ * (i.e., NOT multi-threaded).
+ */
+ currentvp = gridStateElement(dd, GSS_VP);
+ currentgp = gridStateElement(dd, GSS_GPAR);
+ getViewportTransform(currentvp, dd,
+ &vpWidthCM, &vpHeightCM,
+ transform, &rotationAngle);
+ fillViewportContextFromViewport(currentvp, &vpc);
+ /* Call whatever(grob)
+ * to get the unit representing the x/y/width/height
+ */
+ switch (evalType) {
+ case 0:
+ case 1:
+ /*
+ * When evaluating grobX/grobY, the value of the unit
+ * is an angle that gets passed to xDetails/yDetails
+ */
+ {
+ SEXP val;
+ PROTECT(val = ScalarReal(value));
+ PROTECT(R_fcall2x = lang3(evalFnx, updatedgrob, val));
+ PROTECT(unitx = eval(R_fcall2x, R_gridEvalEnv));
+ PROTECT(R_fcall2y = lang3(evalFny, updatedgrob, val));
+ PROTECT(unity = eval(R_fcall2y, R_gridEvalEnv));
+ }
+ break;
+ case 2:
+ PROTECT(R_fcall2x = lang2(evalFnx, updatedgrob));
+ PROTECT(unitx = eval(R_fcall2x, R_gridEvalEnv));
+ break;
+ case 3:
+ case 4:
+ case 5:
+ PROTECT(R_fcall2y = lang2(evalFny, updatedgrob));
+ PROTECT(unity = eval(R_fcall2y, R_gridEvalEnv));
+ break;
+ }
+ /*
+ * Transform the unit
+ * NOTE: We transform into INCHES so can produce final answer in terms
+ * of NPC for original context
+ */
+ /* Special case for "null" units
+ */
+ gcontextFromgpar(currentgp, 0, &gc, dd);
+ switch(evalType) {
+ case 0:
+ case 1:
+ if (evalType && pureNullUnit(unity, 0, dd)) {
+ result = evaluateNullUnit(pureNullUnitValue(unity, 0),
+ vpWidthCM,
+ nullLMode, nullAMode);
+ } else if (pureNullUnit(unitx, 0, dd)) {
+ result = evaluateNullUnit(pureNullUnitValue(unitx, 0),
+ vpWidthCM,
+ nullLMode, nullAMode);
+ } else {
+ /*
+ * Transform to device (to allow for viewports in grob)
+ * then adjust relative to current viewport.
+ */
+ double xx, yy;
+ LLocation lin, lout;
+ LTransform invt;
+ invTransform(savedTransform, invt);
+ transformLocn(unitx, unity, 0,
+ vpc, &gc,
+ vpWidthCM, vpHeightCM, dd,
+ transform, &xx, &yy);
+ location(xx, yy, lin);
+ trans(lin, invt, lout);
+ xx = locationX(lout);
+ yy = locationY(lout);
+ if (evalType)
+ result = yy;
+ else
+ result = xx;
+ }
+ break;
+ case 2:
+ if (pureNullUnit(unitx, 0, dd)) {
+ result = evaluateNullUnit(pureNullUnitValue(unitx, 0),
+ vpWidthCM,
+ nullLMode, nullAMode);
+ } else {
+ result = transformWidthtoINCHES(unitx, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ case 3:
+ case 4:
+ case 5:
+ if (pureNullUnit(unity, 0, dd)) {
+ result = evaluateNullUnit(pureNullUnitValue(unity, 0),
+ vpWidthCM,
+ nullLMode, nullAMode);
+ } else {
+ result = transformHeighttoINCHES(unity, 0, vpc, &gc,
+ vpWidthCM, vpHeightCM,
+ dd);
+ }
+ break;
+ }
+ /* Call postDraw(grob)
+ */
+ PROTECT(R_fcall3 = lang2(postFn, updatedgrob));
+ eval(R_fcall3, R_gridEvalEnv);
+ /*
+ * Restore the saved gpar state and grob
+ */
+ setGridStateElement(dd, GSS_GPAR, savedgpar);
+ setGridStateElement(dd, GSS_CURRGROB, savedgrob);
+ if (protectedGrob)
+ UNPROTECT(3);
+ switch(evalType) {
+ case 0:
+ case 1:
+ UNPROTECT(14);
+ break;
+ case 2:
+ case 3:
+ case 4:
+ case 5:
+ UNPROTECT(10);
+ }
+ /* Return the transformed width
+ */
+ /*
+ * If there is an error or user-interrupt in the above
+ * evaluation, dd->recordGraphics is set to TRUE
+ * on all graphics devices (see GEonExit(); called in errors.c)
+ */
+ dd->recordGraphics = record;
+ return result;
+}
+
+double evaluateGrobXUnit(double value, SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(value, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 0, dd);
+}
+
+double evaluateGrobYUnit(double value, SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(value, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 1, dd);
+}
+
+double evaluateGrobWidthUnit(SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 2, dd);
+}
+
+double evaluateGrobHeightUnit(SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 3, dd);
+}
+
+double evaluateGrobAscentUnit(SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 4, dd);
+}
+
+double evaluateGrobDescentUnit(SEXP grob,
+ double vpheightCM, double vpwidthCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ return evaluateGrobUnit(1, grob, vpheightCM, vpwidthCM,
+ nullLMode, nullAMode, 5, dd);
+}
+
+/**************************
+ * TRANSFORMATIONS
+ **************************
+ */
+
+/* Map a value from arbitrary units to INCHES */
+
+/*
+ * NULL units are a special case
+ * If L_nullLayoutMode = 1 then the value returned is a NULL unit value
+ * Otherwise it is an INCHES value
+ */
+double transform(double value, int unit, SEXP data,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double asc, dsc, wid;
+ double result = value;
+ switch (unit) {
+ case L_NPC:
+ result = (result * thisCM)/2.54; /* 2.54 cm per inch */
+ break;
+ case L_CM:
+ result = result/2.54;
+ break;
+ case L_INCHES:
+ break;
+ /* FIXME: The following two assume that the pointsize specified
+ * by the user is actually the pointsize provided by the
+ * device. This is NOT a safe assumption
+ * One possibility would be to do a call to GReset(), just so
+ * that mapping() gets called, just so that things like
+ * xNDCPerLine are up-to-date, THEN call GStrHeight("M")
+ * or somesuch.
+ */
+ case L_CHAR:
+ case L_MYCHAR: /* FIXME: Remove this when I can */
+ result = (result * gc->ps * gc->cex)/72; /* 72 points per inch */
+ break;
+ case L_LINES:
+ case L_MYLINES: /* FIXME: Remove this when I can */
+ result = (result * gc->ps * gc->cex * gc->lineheight)/72;
+ break;
+ case L_SNPC:
+ if (thisCM <= otherCM)
+ result = (result * thisCM)/2.54;
+ else
+ result = (result * otherCM)/2.54;
+ break;
+ case L_MM:
+ result = (result/10)/2.54;
+ break;
+ /* Maybe an opportunity for some constants below here (!)
+ */
+ case L_POINTS:
+ result = result/72.27;
+ break;
+ case L_PICAS:
+ result = (result*12)/72.27;
+ break;
+ case L_BIGPOINTS:
+ result = result/72;
+ break;
+ case L_DIDA:
+ result = result/1157*1238/72.27;
+ break;
+ case L_CICERO:
+ result = result*12/1157*1238/72.27;
+ break;
+ case L_SCALEDPOINTS:
+ result = result/65536/72.27;
+ break;
+ case L_STRINGWIDTH:
+ case L_MYSTRINGWIDTH: /* FIXME: Remove this when I can */
+ if (isExpression(data))
+ result = result*
+ fromDeviceWidth(GEExpressionWidth(VECTOR_ELT(data, 0), gc, dd),
+ GE_INCHES, dd);
+ else
+ result = result*
+ fromDeviceWidth(GEStrWidth(CHAR(STRING_ELT(data, 0)),
+ getCharCE(STRING_ELT(data, 0)),
+ gc, dd),
+ GE_INCHES, dd);
+ break;
+ case L_STRINGHEIGHT:
+ case L_MYSTRINGHEIGHT: /* FIXME: Remove this when I can */
+ if (isExpression(data))
+ result = result*
+ fromDeviceHeight(GEExpressionHeight(VECTOR_ELT(data, 0),
+ gc, dd),
+ GE_INCHES, dd);
+ else
+ /* FIXME: what encoding is this? */
+ result = result*
+ fromDeviceHeight(GEStrHeight(CHAR(STRING_ELT(data, 0)), -1,
+ gc, dd),
+ GE_INCHES, dd);
+ break;
+ case L_STRINGASCENT:
+ if (isExpression(data))
+ GEExpressionMetric(VECTOR_ELT(data, 0), gc,
+ &asc, &dsc, &wid,
+ dd);
+ else
+ GEStrMetric(CHAR(STRING_ELT(data, 0)),
+ getCharCE(STRING_ELT(data, 0)), gc,
+ &asc, &dsc, &wid,
+ dd);
+ result = result*fromDeviceHeight(asc, GE_INCHES, dd);
+ break;
+ case L_STRINGDESCENT:
+ if (isExpression(data))
+ GEExpressionMetric(VECTOR_ELT(data, 0), gc,
+ &asc, &dsc, &wid,
+ dd);
+ else
+ GEStrMetric(CHAR(STRING_ELT(data, 0)),
+ getCharCE(STRING_ELT(data, 0)), gc,
+ &asc, &dsc, &wid,
+ dd);
+ result = result*fromDeviceHeight(dsc, GE_INCHES, dd);
+ break;
+ case L_GROBX:
+ result = evaluateGrobXUnit(value, data, thisCM, otherCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_GROBY:
+ result = evaluateGrobYUnit(value, data, otherCM, thisCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_GROBWIDTH:
+ result = value*evaluateGrobWidthUnit(data, thisCM, otherCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_GROBHEIGHT:
+ result = value*evaluateGrobHeightUnit(data, otherCM, thisCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_GROBASCENT:
+ result = value*evaluateGrobAscentUnit(data, otherCM, thisCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_GROBDESCENT:
+ result = value*evaluateGrobDescentUnit(data, otherCM, thisCM,
+ nullLMode, nullAMode, dd);
+ break;
+ case L_NULL:
+ result = evaluateNullUnit(result, thisCM, nullLMode, nullAMode);
+ break;
+ default:
+ error(_("invalid unit or unit not yet implemented"));
+ }
+ /*
+ * For physical units, scale the result by GSS_SCALE (a "zoom" factor)
+ */
+ switch (unit) {
+ case L_INCHES:
+ case L_CM:
+ case L_MM:
+ case L_POINTS:
+ case L_PICAS:
+ case L_BIGPOINTS:
+ case L_DIDA:
+ case L_CICERO:
+ case L_SCALEDPOINTS:
+ result = result * REAL(gridStateElement(dd, GSS_SCALE))[0];
+ break;
+ default:
+ /*
+ * No need to scale relative coordinates (NPC, NATIVE, NULL)
+ * CHAR and LINES already scaled because of scaling in gcontextFromGPar()
+ * Ditto STRINGWIDTH/HEIGHT
+ * GROBWIDTH/HEIGHT recurse into here so scaling already done
+ */
+ break;
+ }
+ return result;
+}
+
+/* FIXME: scales are only linear at the moment */
+double transformLocation(double location, int unit, SEXP data,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double result = location;
+ switch (unit) {
+ case L_NATIVE:
+ /* It is invalid to create a viewport with identical limits on scale
+ * so we are protected from divide-by-zero
+ */
+ result = ((result - scalemin)/(scalemax - scalemin))*thisCM/2.54;
+ break;
+ default:
+ result = transform(location, unit, data, scalemin, scalemax,
+ gc, thisCM, otherCM, nullLMode, nullAMode, dd);
+ }
+ return result;
+}
+
+double transformXArithmetic(SEXP x, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd);
+
+double transformX(SEXP x, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double result;
+ int unit;
+ SEXP data;
+ if (isUnitArithmetic(x))
+ result = transformXArithmetic(x, index, vpc, gc,
+ widthCM, heightCM, nullLMode, dd);
+ else if (isUnitList(x)) {
+ int n = unitLength(x);
+ result = transformX(VECTOR_ELT(x, index % n), 0, vpc, gc,
+ widthCM, heightCM, nullLMode, nullAMode, dd);
+ } else { /* Just a plain unit */
+ int nullamode;
+ if (nullAMode == 0)
+ nullamode = L_plain;
+ else
+ nullamode = nullAMode;
+ result = unitValue(x, index);
+ unit = unitUnit(x, index);
+ PROTECT(data = unitData(x, index));
+ result = transformLocation(result, unit, data,
+ vpc.xscalemin, vpc.xscalemax, gc,
+ widthCM, heightCM,
+ nullLMode,
+ nullamode,
+ dd);
+ UNPROTECT(1);
+ }
+ return result;
+}
+
+double transformYArithmetic(SEXP y, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd);
+
+double transformY(SEXP y, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double result;
+ int unit;
+ SEXP data;
+ if (isUnitArithmetic(y))
+ result = transformYArithmetic(y, index, vpc, gc,
+ widthCM, heightCM, nullLMode, dd);
+ else if (isUnitList(y)) {
+ int n = unitLength(y);
+ result = transformY(VECTOR_ELT(y, index % n), 0, vpc, gc,
+ widthCM, heightCM, nullLMode, nullAMode, dd);
+ } else { /* Just a unit object */
+ int nullamode;
+ if (nullAMode == 0)
+ nullamode = L_plain;
+ else
+ nullamode = nullAMode;
+ result = unitValue(y, index);
+ unit = unitUnit(y, index);
+ PROTECT(data = unitData(y, index));
+ result = transformLocation(result, unit, data,
+ vpc.yscalemin, vpc.yscalemax, gc,
+ heightCM, widthCM,
+ nullLMode,
+ nullamode,
+ dd);
+ UNPROTECT(1);
+ }
+ return result;
+}
+
+double transformDimension(double dim, int unit, SEXP data,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ int nullLMode, int nullAMode,
+ pGEDevDesc dd)
+{
+ double result = dim;
+ switch (unit) {
+ case L_NATIVE:
+ /* It is invalid to create a viewport with identical limits on scale
+ * so we are protected from divide-by-zero
+ */
+ result = ((dim)/(scalemax - scalemin))*thisCM/2.54;
+ break;
+ default:
+ result = transform(dim, unit, data, scalemin, scalemax, gc,
+ thisCM, otherCM, nullLMode, nullAMode, dd);
+ }
+ return result;
+}
+
+double transformWidthArithmetic(SEXP width, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd);
+
+double transformWidth(SEXP width, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double result;
+ int unit;
+ SEXP data;
+ if (isUnitArithmetic(width))
+ result = transformWidthArithmetic(width, index, vpc, gc,
+ widthCM, heightCM, nullLMode, dd);
+ else if (isUnitList(width)) {
+ int n = unitLength(width);
+ result = transformWidth(VECTOR_ELT(width, index % n), 0, vpc, gc,
+ widthCM, heightCM, nullLMode, nullAMode, dd);
+ } else { /* Just a unit object */
+ int nullamode;
+ if (nullAMode == 0)
+ nullamode = L_plain;
+ else
+ nullamode = nullAMode;
+ result = unitValue(width, index);
+ unit = unitUnit(width, index);
+ PROTECT(data = unitData(width, index));
+ result = transformDimension(result, unit, data,
+ vpc.xscalemin, vpc.xscalemax, gc,
+ widthCM, heightCM,
+ nullLMode,
+ nullamode,
+ dd);
+ UNPROTECT(1);
+ }
+ return result;
+}
+
+double transformHeightArithmetic(SEXP height, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd);
+
+double transformHeight(SEXP height, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, int nullAMode, pGEDevDesc dd)
+{
+ double result;
+ int unit;
+ SEXP data;
+ if (isUnitArithmetic(height))
+ result = transformHeightArithmetic(height, index, vpc, gc,
+ widthCM, heightCM, nullLMode, dd);
+ else if (isUnitList(height)) {
+ int n = unitLength(height);
+ result = transformHeight(VECTOR_ELT(height, index % n), 0, vpc, gc,
+ widthCM, heightCM, nullLMode, nullAMode, dd);
+ } else { /* Just a unit object */
+ int nullamode;
+ if (nullAMode == 0)
+ nullamode = L_plain;
+ else
+ nullamode = nullAMode;
+ result = unitValue(height, index);
+ unit = unitUnit(height, index);
+ PROTECT(data = unitData(height, index));
+ result = transformDimension(result, unit, data,
+ vpc.yscalemin, vpc.yscalemax, gc,
+ heightCM, widthCM,
+ nullLMode,
+ nullamode,
+ dd);
+ UNPROTECT(1);
+ }
+ return result;
+}
+
+double transformXArithmetic(SEXP x, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd)
+{
+ int i;
+ double result = 0;
+ if (addOp(x)) {
+ result = transformX(arg1(x), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd) +
+ transformX(arg2(x), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd);
+ }
+ else if (minusOp(x)) {
+ result = transformX(arg1(x), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd) -
+ transformX(arg2(x), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd);
+ }
+ else if (timesOp(x)) {
+ result = REAL(arg1(x))[index % LENGTH(arg1(x))] *
+ transformX(arg2(x), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_multiplying, dd);
+ }
+ else if (minFunc(x)) {
+ int n = unitLength(arg1(x));
+ double temp = DBL_MAX;
+ result = transformX(arg1(x), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformX(arg1(x), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ if (temp < result)
+ result = temp;
+ }
+ }
+ else if (maxFunc(x)) {
+ int n = unitLength(arg1(x));
+ double temp = DBL_MIN;
+ result = transformX(arg1(x), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformX(arg1(x), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ if (temp > result)
+ result = temp;
+ }
+ }
+ else if (sumFunc(x)) {
+ int n = unitLength(arg1(x));
+ result = 0.0;
+ for (i=0; i<n; i++) {
+ result += transformX(arg1(x), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_summing, dd);
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ return result;
+}
+
+double transformYArithmetic(SEXP y, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd)
+{
+ int i;
+ double result = 0;
+ if (addOp(y)) {
+ result = transformY(arg1(y), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd) +
+ transformY(arg2(y), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd);
+ }
+ else if (minusOp(y)) {
+ result = transformY(arg1(y), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd) -
+ transformY(arg2(y), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd);
+ }
+ else if (timesOp(y)) {
+ result = REAL(arg1(y))[index % LENGTH(arg1(y))] *
+ transformY(arg2(y), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_multiplying, dd);
+ }
+ else if (minFunc(y)) {
+ int n = unitLength(arg1(y));
+ double temp = DBL_MAX;
+ result = transformY(arg1(y), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformY(arg1(y), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ if (temp < result)
+ result = temp;
+ }
+ }
+ else if (maxFunc(y)) {
+ int n = unitLength(arg1(y));
+ double temp = DBL_MIN;
+ result = transformY(arg1(y), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformY(arg1(y), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ if (temp > result)
+ result = temp;
+ }
+ }
+ else if (sumFunc(y)) {
+ int n = unitLength(arg1(y));
+ result = 0.0;
+ for (i=0; i<n; i++) {
+ result += transformY(arg1(y), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_summing, dd);
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ return result;
+}
+
+double transformWidthArithmetic(SEXP width, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd)
+{
+ int i;
+ double result = 0;
+ if (addOp(width)) {
+ result = transformWidth(arg1(width), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd) +
+ transformWidth(arg2(width), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd);
+ }
+ else if (minusOp(width)) {
+ result = transformWidth(arg1(width), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd) -
+ transformWidth(arg2(width), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd);
+ }
+ else if (timesOp(width)) {
+ result = REAL(arg1(width))[index % LENGTH(arg1(width))] *
+ transformWidth(arg2(width), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_multiplying, dd);
+ }
+ else if (minFunc(width)) {
+ int n = unitLength(arg1(width));
+ double temp = DBL_MAX;
+ result = transformWidth(arg1(width), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformWidth(arg1(width), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ if (temp < result)
+ result = temp;
+ }
+ }
+ else if (maxFunc(width)) {
+ int n = unitLength(arg1(width));
+ double temp = DBL_MIN;
+ result = transformWidth(arg1(width), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformWidth(arg1(width), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ if (temp > result)
+ result = temp;
+ }
+ }
+ else if (sumFunc(width)) {
+ int n = unitLength(arg1(width));
+ result = 0.0;
+ for (i=0; i<n; i++) {
+ result += transformWidth(arg1(width), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_summing, dd);
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ return result;
+}
+
+double transformHeightArithmetic(SEXP height, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ int nullLMode, pGEDevDesc dd)
+{
+ int i;
+ double result = 0;
+ if (addOp(height)) {
+ result = transformHeight(arg1(height), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd) +
+ transformHeight(arg2(height), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_adding,
+ dd);
+ }
+ else if (minusOp(height)) {
+ result = transformHeight(arg1(height), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd) -
+ transformHeight(arg2(height), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_subtracting,
+ dd);
+ }
+ else if (timesOp(height)) {
+ result = REAL(arg1(height))[index % LENGTH(arg1(height))] *
+ transformHeight(arg2(height), index, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_multiplying, dd);
+ }
+ else if (minFunc(height)) {
+ int n = unitLength(arg1(height));
+ double temp = DBL_MAX;
+ result = transformHeight(arg1(height), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformHeight(arg1(height), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_minimising,
+ dd);
+ if (temp < result)
+ result = temp;
+ }
+ }
+ else if (maxFunc(height)) {
+ int n = unitLength(arg1(height));
+ double temp = DBL_MIN;
+ result = transformHeight(arg1(height), 0, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ for (i=1; i<n; i++) {
+ temp = transformHeight(arg1(height), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_maximising,
+ dd);
+ if (temp > result)
+ result = temp;
+ }
+ }
+ else if (sumFunc(height)) {
+ int n = unitLength(arg1(height));
+ result = 0.0;
+ for (i=0; i<n; i++) {
+ result += transformHeight(arg1(height), i, vpc, gc,
+ widthCM, heightCM,
+ nullLMode, L_summing, dd);
+ }
+ }
+ else
+ error(_("unimplemented unit function"));
+ return result;
+}
+
+/* Code for transforming a location in INCHES using a transformation matrix.
+ * We work in INCHES so that rotations can be incorporated within the
+ * transformation matrix (i.e., the units are the same in both x- and
+ * y-directions).
+ * INCHES rather than CM because the R graphics engine only has INCHES.
+ */
+
+/* The original transform[X | Y | Width | Height] functions
+ * were written to transform to NPC. Rather than muck with them,
+ * I am just wrappering them to get the new transformation to INCHES
+ * In other words, the reason for the apparent inefficiency here
+ * is historical.
+ */
+
+/* It is even more inefficient-looking now because I ended up mucking
+ * with transform() to return INCHES (to fix bug if width/heightCM == 0)
+ * and by then there was too much code that called transformXtoINCHES
+ * to be bothered changing calls to it
+ */
+
+/* The difference between transform*toINCHES and transformLocn/Dimn
+ * is that the former are just converting from one coordinate system
+ * to INCHES; the latter are converting from INCHES relative to
+ * the parent to INCHES relative to the device.
+ */
+double transformXtoINCHES(SEXP x, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd)
+{
+ return transformX(x, index, vpc, gc,
+ widthCM, heightCM, 0, 0, dd);
+}
+
+double transformYtoINCHES(SEXP y, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd)
+{
+ return transformY(y, index, vpc, gc,
+ widthCM, heightCM, 0, 0, dd);
+}
+
+void transformLocn(SEXP x, SEXP y, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd,
+ LTransform t,
+ double *xx, double *yy)
+{
+ LLocation lin, lout;
+ /* x and y are unit objects (i.e., values in any old coordinate
+ * system) so the first step is to convert them both to CM
+ */
+ *xx = transformXtoINCHES(x, index, vpc, gc,
+ widthCM, heightCM, dd);
+ *yy = transformYtoINCHES(y, index, vpc, gc,
+ widthCM, heightCM, dd);
+ location(*xx, *yy, lin);
+ trans(lin, t, lout);
+ *xx = locationX(lout);
+ *yy = locationY(lout);
+}
+
+double transformWidthtoINCHES(SEXP w, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd)
+{
+ return transformWidth(w, index, vpc, gc,
+ widthCM, heightCM, 0, 0, dd);
+}
+
+double transformHeighttoINCHES(SEXP h, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd)
+{
+ return transformHeight(h, index, vpc, gc,
+ widthCM, heightCM, 0, 0, dd);
+}
+
+void transformDimn(SEXP w, SEXP h, int index,
+ LViewportContext vpc,
+ const pGEcontext gc,
+ double widthCM, double heightCM,
+ pGEDevDesc dd,
+ double rotationAngle,
+ double *ww, double *hh)
+{
+ LLocation din, dout;
+ LTransform r;
+ *ww = transformWidthtoINCHES(w, index, vpc, gc,
+ widthCM, heightCM, dd);
+ *hh = transformHeighttoINCHES(h, index, vpc, gc,
+ widthCM, heightCM, dd);
+ location(*ww, *hh, din);
+ rotation(rotationAngle, r);
+ trans(din, r, dout);
+ *ww = locationX(dout);
+ *hh = locationY(dout);
+}
+
+/*
+ * ****************************
+ * Inverse Transformations
+ * ****************************
+ */
+
+/*
+ * Take a value in inches within the viewport and convert to some
+ * other coordinate system
+ */
+
+double transformFromINCHES(double value, int unit,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ pGEDevDesc dd)
+{
+ /*
+ * Convert to NPC
+ */
+ double result = value;
+ switch (unit) {
+ case L_NPC:
+ result = result/(thisCM/2.54);
+ break;
+ case L_CM:
+ result = result*2.54;
+ break;
+ case L_INCHES:
+ break;
+ /* FIXME: The following two assume that the pointsize specified
+ * by the user is actually the pointsize provided by the
+ * device. This is NOT a safe assumption
+ * One possibility would be to do a call to GReset(), just so
+ * that mapping() gets called, just so that things like
+ * xNDCPerLine are up-to-date, THEN call GStrHeight("M")
+ * or somesuch.
+ */
+ case L_CHAR:
+ result = (result*72)/(gc->ps*gc->cex);
+ break;
+ case L_LINES:
+ result = (result*72)/(gc->ps*gc->cex*gc->lineheight);
+ break;
+ case L_MM:
+ result = result*2.54*10;
+ break;
+ /* Maybe an opportunity for some constants below here (!)
+ */
+ case L_POINTS:
+ result = result*72.27;
+ break;
+ case L_PICAS:
+ result = result/12*72.27;
+ break;
+ case L_BIGPOINTS:
+ result = result*72;
+ break;
+ case L_DIDA:
+ result = result/1238*1157*72.27;
+ break;
+ case L_CICERO:
+ result = result/1238*1157*72.27/12;
+ break;
+ case L_SCALEDPOINTS:
+ result = result*65536*72.27;
+ break;
+ /*
+ * I'm not sure the remaining ones makes any sense.
+ * For simplicity, these are just forbidden for now.
+ */
+ case L_SNPC:
+ case L_MYCHAR:
+ case L_MYLINES:
+ case L_STRINGWIDTH:
+ case L_MYSTRINGWIDTH:
+ case L_STRINGHEIGHT:
+ case L_MYSTRINGHEIGHT:
+ case L_GROBX:
+ case L_GROBY:
+ case L_GROBWIDTH:
+ case L_GROBHEIGHT:
+ case L_NULL:
+ default:
+ error(_("invalid unit or unit not yet implemented"));
+ }
+ /*
+ * For physical units, reverse the scale by GSS_SCALE (a "zoom" factor)
+ */
+ switch (unit) {
+ case L_INCHES:
+ case L_CM:
+ case L_MM:
+ case L_POINTS:
+ case L_PICAS:
+ case L_BIGPOINTS:
+ case L_DIDA:
+ case L_CICERO:
+ case L_SCALEDPOINTS:
+ result = result / REAL(gridStateElement(dd, GSS_SCALE))[0];
+ break;
+ default:
+ /*
+ * No need to scale relative coordinates (NPC, NATIVE, NULL)
+ * All other units forbidden anyway
+ */
+ break;
+ }
+ return result;
+}
+
+/*
+ * This corresponds to transform[X|Y]toINCHES() because
+ * it works only within the current viewport, BUT
+ * it is much simpler because it is supplied with a
+ * double value in INCHES (rather than a unit object in
+ * an arbitrary unit).
+ *
+ * For conceptual symmetry, it should probably return a
+ * unit object, but it only returns a double value.
+ * The construction of a unit object with the appropriate
+ * unit must be performed by the calling function (or higher).
+ * This is probably easiest done right up in R code.
+ */
+double transformXYFromINCHES(double location, int unit,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ pGEDevDesc dd)
+{
+ double result = location;
+ /* Special case if "thisCM == 0":
+ * If converting FROM relative unit, result will already be zero
+ * so leave it there.
+ * If converting FROM absolute unit that is zero, ditto.
+ * Otherwise (converting FROM non-zero absolute unit),
+ * converting to relative unit is an error.
+ */
+ if ((unit == L_NATIVE || unit == L_NPC) &&
+ thisCM < 1e-6) {
+ if (result != 0)
+ error(_("Viewport has zero dimension(s)"));
+ } else {
+ switch (unit) {
+ case L_NATIVE:
+ result = scalemin + (result/(thisCM/2.54))*(scalemax - scalemin);
+ break;
+ default:
+ result = transformFromINCHES(location, unit, gc,
+ thisCM, otherCM, dd);
+ }
+ }
+ return result;
+}
+
+double transformWidthHeightFromINCHES(double dimension, int unit,
+ double scalemin, double scalemax,
+ const pGEcontext gc,
+ double thisCM, double otherCM,
+ pGEDevDesc dd)
+{
+ double result = dimension;
+ /* Special case if "thisCM == 0":
+ * If converting FROM relative unit, result will already be zero
+ * so leave it there.
+ * If converting FROM absolute unit that is zero, ditto.
+ * Otherwise (converting FROM non-zero absolute unit),
+ * converting to relative unit is an error.
+ */
+ if ((unit == L_NATIVE || unit == L_NPC) &&
+ thisCM < 1e-6) {
+ if (result != 0)
+ error(_("Viewport has zero dimension(s)"));
+ } else {
+ switch (unit) {
+ case L_NATIVE:
+ result = (result/(thisCM/2.54))*(scalemax - scalemin);
+ break;
+ default:
+ result = transformFromINCHES(dimension, unit, gc,
+ thisCM, otherCM, dd);
+ }
+ }
+ return result;
+}
+
+/*
+ * Special case conversion from relative unit to relative unit,
+ * only used when relevant widthCM or heightCM is zero, so
+ * we cannot transform thru INCHES (or we get divide-by-zero)
+ *
+ * Protected from divide-by-zero here because viewport with
+ * identical scale limits is disallowed.
+ */
+double transformXYtoNPC(double x, int from, double min, double max)
+{
+ double result = x;
+ switch (from) {
+ case L_NPC:
+ break;
+ case L_NATIVE:
+ result = (x - min)/(max - min);
+ break;
+ default:
+ error(_("Unsupported unit conversion"));
+ }
+ return(result);
+}
+
+double transformWHtoNPC(double x, int from, double min, double max)
+{
+ double result = x;
+ switch (from) {
+ case L_NPC:
+ break;
+ case L_NATIVE:
+ result = x/(max - min);
+ break;
+ default:
+ error(_("Unsupported unit conversion"));
+ }
+ return(result);
+}
+
+double transformXYfromNPC(double x, int to, double min, double max)
+{
+ double result = x;
+ switch (to) {
+ case L_NPC:
+ break;
+ case L_NATIVE:
+ result = min + x*(max - min);
+ break;
+ default:
+ error(_("Unsupported unit conversion"));
+ }
+ return(result);
+}
+
+double transformWHfromNPC(double x, int to, double min, double max)
+{
+ double result = x;
+ switch (to) {
+ case L_NPC:
+ break;
+ case L_NATIVE:
+ result = x*(max - min);
+ break;
+ default:
+ error(_("Unsupported unit conversion"));
+ }
+ return(result);
+}
+
+/* Attempt to make validating units faster
+ */
+typedef struct {
+ char *name;
+ int code;
+} UnitTab;
+
+/* NOTE this table must match the order in grid.h
+ */
+static UnitTab UnitTable[] = {
+ { "npc", 0 },
+ { "cm", 1 },
+ { "inches", 2 },
+ { "lines", 3 },
+ { "native", 4 },
+ { "null", 5 },
+ { "snpc", 6 },
+ { "mm", 7 },
+ { "points", 8 },
+ { "picas", 9 },
+ { "bigpts", 10 },
+ { "dida", 11 },
+ { "cicero", 12 },
+ { "scaledpts", 13 },
+ { "strwidth", 14 },
+ { "strheight", 15 },
+ { "strascent", 16 },
+ { "strdescent", 17 },
+
+ { "char", 18 },
+ { "grobx", 19 },
+ { "groby", 20 },
+ { "grobwidth", 21 },
+ { "grobheight", 22 },
+ { "grobascent", 23 },
+ { "grobdescent", 24 },
+
+ { "mylines", 103 },
+ { "mychar", 104 },
+ { "mystrwidth", 105 },
+ { "mystrheight", 106 },
+
+ /*
+ * Some pseudonyms
+ */
+ { "centimetre", 1001 },
+ { "centimetres", 1001 },
+ { "centimeter", 1001 },
+ { "centimeters", 1001 },
+ { "in", 1002 },
+ { "inch", 1002 },
+ { "line", 1003 },
+ { "millimetre", 1007 },
+ { "millimetres", 1007 },
+ { "millimeter", 1007 },
+ { "millimeters", 1007 },
+ { "point", 1008 },
+ { "pt", 1008 },
+
+ { NULL, -1 }
+};
+
+int convertUnit(SEXP unit, int index)
+{
+ int i = 0;
+ int result = 0;
+ int found = 0;
+ while (result >= 0 && !found) {
+ if (UnitTable[i].name == NULL)
+ result = -1;
+ else {
+ found = !strcmp(CHAR(STRING_ELT(unit, index)), UnitTable[i].name);
+ if (found) {
+ result = UnitTable[i].code;
+ /* resolve pseudonyms */
+ if (result > 1000) {
+ result = result - 1000;
+ }
+ }
+ }
+ i += 1;
+ }
+ if (result < 0)
+ error(_("Invalid unit"));
+ return result;
+}
+
+SEXP validUnits(SEXP units)
+{
+ int i;
+ int n = LENGTH(units);
+ SEXP answer = R_NilValue;
+ if (n > 0) {
+ if (isString(units)) {
+ PROTECT(answer = allocVector(INTSXP, n));
+ for (i = 0; i<n; i++)
+ INTEGER(answer)[i] = convertUnit(units, i);
+ UNPROTECT(1);
+ } else {
+ error(_("'units' must be character"));
+ }
+ } else {
+ error(_("'units' must be of length > 0"));
+ }
+ return answer;
+}
+
+
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/util.c b/com.oracle.truffle.r.native/library/grid/src/util.c
new file mode 100644
index 0000000000..3780cb11c9
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/util.c
@@ -0,0 +1,288 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-8 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+#include <string.h>
+
+/* Get the list element named str, or return NULL.
+ * Copied from the Writing R Extensions manual (which copied it from nls)
+ */
+SEXP getListElement(SEXP list, char *str)
+{
+ SEXP elmt = R_NilValue;
+ SEXP names = getAttrib(list, R_NamesSymbol);
+ int i;
+
+ for (i = 0; i < length(list); i++)
+ if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
+ elmt = VECTOR_ELT(list, i);
+ break;
+ }
+ return elmt;
+}
+
+void setListElement(SEXP list, char *str, SEXP value)
+{
+ SEXP names = getAttrib(list, R_NamesSymbol);
+ int i;
+
+ for (i = 0; i < length(list); i++)
+ if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
+ SET_VECTOR_ELT(list, i, value);
+ break;
+ }
+}
+
+/* The lattice R code checks values to make sure that they are numeric
+ * BUT we do not know whether the values are integer or real
+ * SO we have to be careful when extracting numeric values.
+ * This function assumes that x is numeric (obviously).
+ */
+double numeric(SEXP x, int index)
+{
+ if (isReal(x))
+ return REAL(x)[index];
+ else if (isInteger(x))
+ return INTEGER(x)[index];
+ return NA_REAL;
+}
+
+/***********************
+ * Stuff for rectangles
+ ***********************/
+
+/* Fill a rectangle struct
+ */
+void rect(double x1, double x2, double x3, double x4,
+ double y1, double y2, double y3, double y4,
+ LRect *r)
+{
+ r->x1 = x1;
+ r->x2 = x2;
+ r->x3 = x3;
+ r->x4 = x4;
+ r->y1 = y1;
+ r->y2 = y2;
+ r->y3 = y3;
+ r->y4 = y4;
+}
+
+void copyRect(LRect r1, LRect *r)
+{
+ r->x1 = r1.x1;
+ r->x2 = r1.x2;
+ r->x3 = r1.x3;
+ r->x4 = r1.x4;
+ r->y1 = r1.y1;
+ r->y2 = r1.y2;
+ r->y3 = r1.y3;
+ r->y4 = r1.y4;
+}
+
+/* Do two lines intersect ?
+ * Algorithm from Paul Bourke
+ * (http://www.swin.edu.au/astronomy/pbourke/geometry/lineline2d/index.html)
+ */
+int linesIntersect(double x1, double x2, double x3, double x4,
+ double y1, double y2, double y3, double y4)
+{
+ double result = 0;
+ double denom = (y4 - y3)*(x2 - x1) - (x4 - x3)*(y2 - y1);
+ double ua = ((x4 - x3)*(y1 - y3) - (y4 - y3)*(x1 - x3));
+ /* If the lines are parallel ...
+ */
+ if (denom == 0) {
+ /* If the lines are coincident ...
+ */
+ if (ua == 0) {
+ /* If the lines are vertical ...
+ */
+ if (x1 == x2) {
+ /* Compare y-values
+ */
+ if (!((y1 < y3 && fmax2(y1, y2) < fmin2(y3, y4)) ||
+ (y3 < y1 && fmax2(y3, y4) < fmin2(y1, y2))))
+ result = 1;
+ } else {
+ /* Compare x-values
+ */
+ if (!((x1 < x3 && fmax2(x1, x2) < fmin2(x3, x4)) ||
+ (x3 < x1 && fmax2(x3, x4) < fmin2(x1, x2))))
+ result = 1;
+ }
+ }
+ }
+ /* ... otherwise, calculate where the lines intersect ...
+ */
+ else {
+ double ub = ((x2 - x1)*(y1 - y3) - (y2 - y1)*(x1 - x3));
+ ua = ua/denom;
+ ub = ub/denom;
+ /* Check for overlap
+ */
+ if ((ua > 0 && ua < 1) && (ub > 0 && ub < 1))
+ result = 1;
+ }
+ return (int) result;
+}
+
+int edgesIntersect(double x1, double x2, double y1, double y2,
+ LRect r)
+{
+ int result = 0;
+ if (linesIntersect(x1, x2, r.x1, r.x2, y1, y2, r.y1, r.y2) ||
+ linesIntersect(x1, x2, r.x2, r.x3, y1, y2, r.y2, r.y3) ||
+ linesIntersect(x1, x2, r.x3, r.x4, y1, y2, r.y3, r.y4) ||
+ linesIntersect(x1, x2, r.x4, r.x1, y1, y2, r.y4, r.y1))
+ result = 1;
+ return result;
+}
+
+/* Do two rects intersect ?
+ * For each edge in r1, does the edge intersect with any edge in r2 ?
+ * FIXME: Should add first check for non-intersection of
+ * bounding boxes of rects (?)
+ */
+int intersect(LRect r1, LRect r2)
+{
+ int result = 0;
+ if (edgesIntersect(r1.x1, r1.x2, r1.y1, r1.y2, r2) ||
+ edgesIntersect(r1.x2, r1.x3, r1.y2, r1.y3, r2) ||
+ edgesIntersect(r1.x3, r1.x4, r1.y3, r1.y4, r2) ||
+ edgesIntersect(r1.x4, r1.x1, r1.y4, r1.y1, r2))
+ result = 1;
+ return result;
+}
+
+/* Calculate the bounding rectangle for a string.
+ * x and y assumed to be in INCHES.
+ */
+void textRect(double x, double y, SEXP text, int i,
+ const pGEcontext gc,
+ double xadj, double yadj,
+ double rot, pGEDevDesc dd, LRect *r)
+{
+ /* NOTE that we must work in inches for the angles to be correct
+ */
+ LLocation bl, br, tr, tl;
+ LLocation tbl, tbr, ttr, ttl;
+ LTransform thisLocation, thisRotation, thisJustification;
+ LTransform tempTransform, transform;
+ double w, h;
+ if (isExpression(text)) {
+ SEXP expr = VECTOR_ELT(text, i % LENGTH(text));
+ w = fromDeviceWidth(GEExpressionWidth(expr, gc, dd),
+ GE_INCHES, dd);
+ h = fromDeviceHeight(GEExpressionHeight(expr, gc, dd),
+ GE_INCHES, dd);
+ } else {
+ const char* string = CHAR(STRING_ELT(text, i % LENGTH(text)));
+ w = fromDeviceWidth(GEStrWidth(string,
+ (gc->fontface == 5) ? CE_SYMBOL :
+ getCharCE(STRING_ELT(text, i % LENGTH(text))),
+ gc, dd),
+ GE_INCHES, dd);
+ h = fromDeviceHeight(GEStrHeight(string,
+ (gc->fontface == 5) ? CE_SYMBOL :
+ getCharCE(STRING_ELT(text, i % LENGTH(text))),
+ gc, dd),
+ GE_INCHES, dd);
+ }
+ location(0, 0, bl);
+ location(w, 0, br);
+ location(w, h, tr);
+ location(0, h, tl);
+ translation(-xadj*w, -yadj*h, thisJustification);
+ translation(x, y, thisLocation);
+ if (rot != 0)
+ rotation(rot, thisRotation);
+ else
+ identity(thisRotation);
+ /* Position relative to origin of rotation THEN rotate.
+ */
+ multiply(thisJustification, thisRotation, tempTransform);
+ /* Translate to (x, y)
+ */
+ multiply(tempTransform, thisLocation, transform);
+ trans(bl, transform, tbl);
+ trans(br, transform, tbr);
+ trans(tr, transform, ttr);
+ trans(tl, transform, ttl);
+ rect(locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl),
+ locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl),
+ r);
+ /* For debugging, the following prints out an R statement to draw the
+ * bounding box
+ */
+ /*
+ Rprintf("\ngrid.lines(c(%f, %f, %f, %f, %f), c(%f, %f, %f, %f, %f), default.units=\"inches\")\n",
+ locationX(tbl), locationX(tbr), locationX(ttr), locationX(ttl),
+ locationX(tbl),
+ locationY(tbl), locationY(tbr), locationY(ttr), locationY(ttl),
+ locationY(tbl)
+ );
+ */
+}
+
+/***********************
+ * Stuff for making persistent graphical objects
+ ***********************/
+
+/* Will have already created an SEXP in R. This just stores the
+ * SEXP in an external reference so that I can get multiple
+ * references to it.
+ */
+SEXP L_CreateSEXPPtr(SEXP s)
+{
+ /* Allocate a list of length one on the R heap
+ */
+ SEXP data, result;
+ PROTECT(data = allocVector(VECSXP, 1));
+ SET_VECTOR_ELT(data, 0, s);
+ result = R_MakeExternalPtr(data, R_NilValue, data);
+ UNPROTECT(1);
+ return result;
+}
+
+SEXP L_GetSEXPPtr(SEXP sp)
+{
+ SEXP data = R_ExternalPtrAddr(sp);
+ /* Check for NULL ptr
+ * This can occur if, for example, a grid grob is saved
+ * and then loaded. The saved grob has its ptr null'ed
+ */
+ if (data == NULL)
+ error("grid grob object is empty");
+ return VECTOR_ELT(data, 0);
+}
+
+SEXP L_SetSEXPPtr(SEXP sp, SEXP s)
+{
+ SEXP data = R_ExternalPtrAddr(sp);
+ /* Check for NULL ptr
+ * This can occur if, for example, a grid grob is saved
+ * and then loaded. The saved grob has its ptr null'ed
+ */
+ if (data == NULL)
+ error("grid grob object is empty");
+ SET_VECTOR_ELT(data, 0, s);
+ return R_NilValue;
+}
+
diff --git a/com.oracle.truffle.r.native/library/grid/src/viewport.c b/com.oracle.truffle.r.native/library/grid/src/viewport.c
new file mode 100644
index 0000000000..29004412ae
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grid/src/viewport.c
@@ -0,0 +1,397 @@
+/*
+ * R : A Computer Language for Statistical Data Analysis
+ * Copyright (C) 2001-3 Paul Murrell
+ * 2003-5 The R Core Team
+ *
+ * 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, a copy is available at
+ * http://www.r-project.org/Licenses/
+ */
+
+#include "grid.h"
+#include <string.h>
+
+extern int gridRegisterIndex;
+
+/* Some access methods for viewports */
+SEXP viewportX(SEXP vp) {
+ return VECTOR_ELT(vp, VP_X);
+}
+
+SEXP viewportY(SEXP vp) {
+ return VECTOR_ELT(vp, VP_Y);
+}
+
+SEXP viewportWidth(SEXP vp) {
+ return VECTOR_ELT(vp, VP_WIDTH);
+}
+
+SEXP viewportHeight(SEXP vp) {
+ return VECTOR_ELT(vp, VP_HEIGHT);
+}
+
+Rboolean viewportClip(SEXP vp) {
+ return LOGICAL(VECTOR_ELT(vp, VP_CLIP))[0];
+}
+
+double viewportXScaleMin(SEXP vp) {
+ return numeric(VECTOR_ELT(vp, VP_XSCALE), 0);
+}
+
+double viewportXScaleMax(SEXP vp) {
+ return numeric(VECTOR_ELT(vp, VP_XSCALE), 1);
+}
+
+double viewportYScaleMin(SEXP vp) {
+ return numeric(VECTOR_ELT(vp, VP_YSCALE), 0);
+}
+
+double viewportYScaleMax(SEXP vp) {
+ return numeric(VECTOR_ELT(vp, VP_YSCALE), 1);
+}
+
+double viewportAngle(SEXP vp) {
+ return numeric(VECTOR_ELT(vp, VP_ANGLE), 0);
+}
+
+SEXP viewportLayout(SEXP vp) {
+ return VECTOR_ELT(vp, VP_LAYOUT);
+}
+
+double viewportHJust(SEXP vp) {
+ return REAL(VECTOR_ELT(vp, VP_VALIDJUST))[0];
+}
+
+double viewportVJust(SEXP vp) {
+ return REAL(VECTOR_ELT(vp, VP_VALIDJUST))[1];
+}
+
+SEXP viewportLayoutPosRow(SEXP vp) {
+ return VECTOR_ELT(vp, VP_VALIDLPOSROW);
+}
+
+SEXP viewportLayoutPosCol(SEXP vp) {
+ return VECTOR_ELT(vp, VP_VALIDLPOSCOL);
+}
+
+SEXP viewportgpar(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_GPAR);
+}
+
+const char* viewportFontFamily(SEXP vp) {
+ return CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONTFAMILY),
+ 0));
+}
+
+int viewportFont(SEXP vp) {
+ return INTEGER(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONT))[0];
+}
+
+double viewportFontSize(SEXP vp) {
+ return REAL(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_FONTSIZE))[0];
+}
+
+double viewportLineHeight(SEXP vp) {
+ return REAL(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_LINEHEIGHT))[0];
+}
+
+double viewportCex(SEXP vp) {
+ return numeric(VECTOR_ELT(VECTOR_ELT(vp, PVP_GPAR), GP_CEX), 0);
+}
+
+SEXP viewportTransform(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_TRANS);
+}
+
+SEXP viewportLayoutWidths(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_WIDTHS);
+}
+
+SEXP viewportLayoutHeights(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_HEIGHTS);
+}
+
+SEXP viewportWidthCM(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_WIDTHCM);
+}
+
+SEXP viewportHeightCM(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_HEIGHTCM);
+}
+
+SEXP viewportRotation(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_ROTATION);
+}
+
+SEXP viewportClipRect(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_CLIPRECT);
+}
+
+SEXP viewportParent(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_PARENT);
+}
+
+SEXP viewportChildren(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_CHILDREN);
+}
+
+SEXP viewportDevWidthCM(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_DEVWIDTHCM);
+}
+
+SEXP viewportDevHeightCM(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_DEVHEIGHTCM);
+}
+
+SEXP viewportParentGPar(SEXP vp) {
+ return VECTOR_ELT(vp, PVP_PARENTGPAR);
+}
+
+void fillViewportLocationFromViewport(SEXP vp, LViewportLocation *vpl)
+{
+ vpl->x = viewportX(vp);
+ vpl->y = viewportY(vp);
+ vpl->width = viewportWidth(vp);
+ vpl->height = viewportHeight(vp);
+ vpl->hjust = viewportHJust(vp);
+ vpl->vjust = viewportVJust(vp);
+}
+
+void fillViewportContextFromViewport(SEXP vp,
+ LViewportContext *vpc)
+{
+ vpc->xscalemin = viewportXScaleMin(vp);
+ vpc->xscalemax = viewportXScaleMax(vp);
+ vpc->yscalemin = viewportYScaleMin(vp);
+ vpc->yscalemax = viewportYScaleMax(vp);
+}
+
+void copyViewportContext(LViewportContext vpc1, LViewportContext *vpc2)
+{
+ vpc2->xscalemin = vpc1.xscalemin;
+ vpc2->xscalemax = vpc1.xscalemax;
+ vpc2->yscalemin = vpc1.yscalemin;
+ vpc2->yscalemax = vpc1.yscalemax;
+}
+
+void gcontextFromViewport(SEXP vp, const pGEcontext gc, pGEDevDesc dd) {
+ gcontextFromgpar(viewportgpar(vp), 0, gc, dd);
+}
+
+/* The idea is to produce a transformation for this viewport which
+ * will take any location in INCHES and turn it into a location on the
+ * Device in INCHES.
+ * The reason for working in INCHES is because we want to be able to
+ * do rotations as part of the transformation.
+ * If "incremental" is true, then we just work from the "current"
+ * values of the parent. Otherwise, we have to recurse and recalculate
+ * everything from scratch.
+ */
+void calcViewportTransform(SEXP vp, SEXP parent, Rboolean incremental,
+ pGEDevDesc dd)
+{
+ int i, j;
+ double vpWidthCM, vpHeightCM, rotationAngle;
+ double parentWidthCM, parentHeightCM;
+ double xINCHES, yINCHES;
+ double xadj, yadj;
+ double parentAngle;
+ LViewportLocation vpl;
+ LViewportContext vpc, parentContext;
+ R_GE_gcontext gc, parentgc;
+ LTransform thisLocation, thisRotation, thisJustification, thisTransform;
+ LTransform tempTransform, parentTransform, transform;
+ SEXP currentWidthCM, currentHeightCM, currentRotation;
+ SEXP currentTransform;
+ /* This should never be true when we are doing an incremental
+ * calculation
+ */
+ if (isNull(parent)) {
+ /* We have a top-level viewport; the parent is the device
+ */
+ getDeviceSize(dd, &parentWidthCM, &parentHeightCM);
+ /* For a device the transform is the identity transform
+ */
+ identity(parentTransform);
+ /* For a device, xmin=0, ymin=0, xmax=1, ymax=1, and
+ */
+ parentContext.xscalemin = 0;
+ parentContext.yscalemin = 0;
+ parentContext.xscalemax = 1;
+ parentContext.yscalemax = 1;
+ /* FIXME: How do I figure out the device fontsize ?
+ * From ps.options etc, ... ?
+ * FIXME: How do I figure out the device lineheight ??
+ * FIXME: How do I figure out the device cex ??
+ * FIXME: How do I figure out the device font ??
+ * FIXME: How do I figure out the device fontfamily ??
+ */
+ parentgc.ps = 10;
+ parentgc.lineheight = 1.2;
+ parentgc.cex = 1;
+ parentgc.fontface = 1;
+ parentgc.fontfamily[0] = '\0';
+ /* The device is not rotated
+ */
+ parentAngle = 0;
+ fillViewportLocationFromViewport(vp, &vpl);
+ } else {
+ /* Get parent transform (etc ...)
+ * If necessary, recalculate the parent transform (etc ...)
+ */
+ if (!incremental)
+ calcViewportTransform(parent, viewportParent(parent), 0, dd);
+ /* Get information required to transform viewport location
+ */
+ parentWidthCM = REAL(viewportWidthCM(parent))[0];
+ parentHeightCM = REAL(viewportHeightCM(parent))[0];
+ parentAngle = REAL(viewportRotation(parent))[0];
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ parentTransform[i][j] =
+ REAL(viewportTransform(parent))[i +3*j];
+ fillViewportContextFromViewport(parent, &parentContext);
+ /*
+ * Don't get gcontext from parent because the most recent
+ * previous gpar setting may have come from a gTree
+ * So we look at this viewport's parentgpar slot instead
+ *
+ * WAS gcontextFromViewport(parent, &parentgc);
+ */
+ gcontextFromgpar(viewportParentGPar(vp), 0, &parentgc, dd);
+ /* In order for the vp to get its vpl from a layout
+ * it must have specified a layout.pos and the parent
+ * must have a layout
+ * FIXME: Actually, in addition, layout.pos.row and
+ * layout.pos.col must be valid for the layout
+ */
+ if ((isNull(viewportLayoutPosRow(vp)) &&
+ isNull(viewportLayoutPosCol(vp))) ||
+ isNull(viewportLayout(parent)))
+ fillViewportLocationFromViewport(vp, &vpl);
+ else if (checkPosRowPosCol(vp, parent))
+ calcViewportLocationFromLayout(viewportLayoutPosRow(vp),
+ viewportLayoutPosCol(vp),
+ parent,
+ &vpl);
+ }
+ /* NOTE that we are not doing a transformLocn here because
+ * we just want locations and dimensions (in INCHES) relative to
+ * the parent, NOT relative to the device.
+ */
+ /* First, convert the location of the viewport into CM
+ */
+ xINCHES = transformXtoINCHES(vpl.x, 0, parentContext, &parentgc,
+ parentWidthCM, parentHeightCM,
+ dd);
+ yINCHES = transformYtoINCHES(vpl.y, 0, parentContext, &parentgc,
+ parentWidthCM, parentHeightCM,
+ dd);
+ /* Calculate the width and height of the viewport in CM too
+ * so that any viewports within this one can do transformations
+ */
+ vpWidthCM = transformWidthtoINCHES(vpl.width, 0, parentContext, &parentgc,
+ parentWidthCM, parentHeightCM,
+ dd)*2.54;
+ vpHeightCM = transformHeighttoINCHES(vpl.height, 0, parentContext,
+ &parentgc,
+ parentWidthCM,
+ parentHeightCM,
+ dd)*2.54;
+ /* Fall out if location or size are non-finite
+ */
+ if (!R_FINITE(xINCHES) ||
+ !R_FINITE(yINCHES) ||
+ !R_FINITE(vpWidthCM) ||
+ !R_FINITE(vpHeightCM))
+ error(_("non-finite location and/or size for viewport"));
+ /* Determine justification required
+ */
+ justification(vpWidthCM, vpHeightCM, vpl.hjust, vpl.vjust,
+ &xadj, &yadj);
+ /* Next, produce the transformation to add the location of
+ * the viewport to the location.
+ */
+ /* Produce transform for this viewport
+ */
+ translation(xINCHES, yINCHES, thisLocation);
+ if (viewportAngle(vp) != 0)
+ rotation(viewportAngle(vp), thisRotation);
+ else
+ identity(thisRotation);
+ translation(xadj/2.54, yadj/2.54, thisJustification);
+ /* Position relative to origin of rotation THEN rotate.
+ */
+ multiply(thisJustification, thisRotation, tempTransform);
+ /* Translate to bottom-left corner.
+ */
+ multiply(tempTransform, thisLocation, thisTransform);
+ /* Combine with parent's transform
+ */
+ multiply(thisTransform, parentTransform, transform);
+ /* Sum up the rotation angles
+ */
+ rotationAngle = parentAngle + viewportAngle(vp);
+ /* Finally, allocate the rows and columns for this viewport's
+ * layout if it has one
+ */
+ if (!isNull(viewportLayout(vp))) {
+ fillViewportContextFromViewport(vp, &vpc);
+ gcontextFromViewport(vp, &gc, dd);
+ calcViewportLayout(vp, vpWidthCM, vpHeightCM, vpc, &gc, dd);
+ }
+ /* Record all of the answers in the viewport
+ * (the layout calculations are done within calcViewportLayout)
+ */
+ PROTECT(currentWidthCM = ScalarReal(vpWidthCM));
+ PROTECT(currentHeightCM = ScalarReal(vpHeightCM));
+ PROTECT(currentRotation = ScalarReal(rotationAngle));
+ PROTECT(currentTransform = allocMatrix(REALSXP, 3, 3));
+ for (i=0; i<3; i++)
+ for (j=0; j<3; j++)
+ REAL(currentTransform)[i + 3*j] = transform[i][j];
+ SET_VECTOR_ELT(vp, PVP_WIDTHCM, currentWidthCM);
+ SET_VECTOR_ELT(vp, PVP_HEIGHTCM, currentHeightCM);
+ SET_VECTOR_ELT(vp, PVP_ROTATION, currentRotation);
+ SET_VECTOR_ELT(vp, PVP_TRANS, currentTransform);
+ UNPROTECT(4);
+}
+
+void initVP(pGEDevDesc dd)
+{
+ SEXP vpfnname, vpfn, vp;
+ SEXP xscale, yscale;
+ SEXP currentgp = gridStateElement(dd, GSS_GPAR);
+ SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
+ PROTECT(vpfnname = findFun(install("grid.top.level.vp"), R_gridEvalEnv));
+ PROTECT(vpfn = lang1(vpfnname));
+ PROTECT(vp = eval(vpfn, R_GlobalEnv));
+ /*
+ * Set the "native" scale of the top viewport to be the
+ * natural device coordinate system (e.g., points in
+ * postscript, pixels in X11, ...)
+ */
+ PROTECT(xscale = allocVector(REALSXP, 2));
+ REAL(xscale)[0] = dd->dev->left;
+ REAL(xscale)[1] = dd->dev->right;
+ SET_VECTOR_ELT(vp, VP_XSCALE, xscale);
+ PROTECT(yscale = allocVector(REALSXP, 2));
+ REAL(yscale)[0] = dd->dev->bottom;
+ REAL(yscale)[1] = dd->dev->top;
+ SET_VECTOR_ELT(vp, VP_YSCALE, yscale);
+ SET_VECTOR_ELT(vp, PVP_GPAR, currentgp);
+ vp = doSetViewport(vp, TRUE, TRUE, dd);
+ SET_VECTOR_ELT(gsd, GSS_VP, vp);
+ UNPROTECT(5);
+}
+
diff --git a/com.oracle.truffle.r.native/library/lib.mk b/com.oracle.truffle.r.native/library/lib.mk
index 1ece2c3703..72f3be3322 100644
--- a/com.oracle.truffle.r.native/library/lib.mk
+++ b/com.oracle.truffle.r.native/library/lib.mk
@@ -52,6 +52,8 @@ C_OBJECTS := $(subst $(SRC),$(OBJ),$(C_SOURCES:.c=.o))
H_SOURCES := $(wildcard $(SRC)/*.h)
+CFLAGS := $(CFLAGS) -DFASTR
+
LIBDIR := $(OBJ)
# packages seem to use .so even on Mac OS X and no "lib"
diff --git a/com.oracle.truffle.r.native/osextras/Makefile b/com.oracle.truffle.r.native/osextras/Makefile
index ba2ad13e84..19138d1976 100644
--- a/com.oracle.truffle.r.native/osextras/Makefile
+++ b/com.oracle.truffle.r.native/osextras/Makefile
@@ -37,7 +37,7 @@ C_SOURCES := $(wildcard $(SRC)/*.c)
C_LIBNAME := libosextras$(DYLIB_EXT)
C_OBJECTS := $(subst $(SRC),$(OBJ),$(C_SOURCES:.c=.o))
C_LIB := $(TOPDIR)/builtinlibs/$(OBJ)/$(C_LIBNAME)
-CFLAGS := $(CFLAGS) -DFASTR
+#CFLAGS := $(CFLAGS) -DFASTR
JNI_INCLUDES = -I $(JAVA_HOME)/include -I $(JAVA_HOME)/include/$(JDK_OS_DIR)
diff --git a/com.oracle.truffle.r.native/run/edMakeconf.etc b/com.oracle.truffle.r.native/run/edMakeconf.etc
index 3a31b7548f..4e0dff0bb2 100644
--- a/com.oracle.truffle.r.native/run/edMakeconf.etc
+++ b/com.oracle.truffle.r.native/run/edMakeconf.etc
@@ -1,3 +1,4 @@
+/^CFLAGS/s/$/ -DFASTR/
/LIBINTL=/
d
/LIBR =/
diff --git a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
index 9d3e21b195..3228b7b5eb 100644
--- a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
+++ b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
@@ -306,4 +306,21 @@ public class CallRFFIHelper {
static Object validate(Object x) {
return x;
}
+
+ static Object getGlobalEnv() {
+ return RContext.getREnvironmentState().getGlobalEnv();
+ }
+
+ static Object getBaseEnv() {
+ return RContext.getREnvironmentState().getBaseEnv();
+ }
+
+ static Object getBaseNamespace() {
+ return RContext.getREnvironmentState().getBaseNamespace();
+ }
+
+ static Object getNamespaceRegistry() {
+ return RContext.getREnvironmentState().getNamespaceRegistry();
+ }
+
}
diff --git a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIWithJNI.java b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIWithJNI.java
index 1e8f3a64ad..587bca5861 100644
--- a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIWithJNI.java
+++ b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIWithJNI.java
@@ -48,14 +48,56 @@ public class CallRFFIWithJNI implements CallRFFI {
private static final boolean ForceRTLDGlobal = false;
- // The order must match that expected in rfficall.c
- // @formatter:off
- private static final Object[] INITIALIZE_VALUES = new Object[]{
- REnvironment.emptyEnv(),
- RNull.instance, RUnboundValue.instance, RMissing.instance,
- RDataFactory.createSymbol("class")
- };
- // @formatter:on
+ public enum RVariables {
+ R_NilValue(RNull.instance),
+ R_UnboundValue(RUnboundValue.instance),
+ R_MissingArg(RMissing.instance),
+ R_GlobalEnv(null),
+ R_EmptyEnv(REnvironment.emptyEnv()),
+ R_BaseEnv(null),
+ R_BaseNamespace(null),
+ R_NamespaceRegistry(null),
+ R_Srcref(null),
+ R_Bracket2Symbol(null),
+ R_BracketSymbol(null),
+ R_BraceSymbol(null),
+ R_ClassSymbol(RDataFactory.createSymbol("class")),
+ R_DeviceSymbol(null),
+ R_DimNamesSymbol(RDataFactory.createStringVectorFromScalar(RRuntime.DIMNAMES_ATTR_KEY)),
+ R_DimSymbol(RDataFactory.createStringVectorFromScalar(RRuntime.DIM_ATTR_KEY)),
+ R_DollarSymbol(null),
+ R_DotsSymbol(null),
+ R_DropSymbol(null),
+ R_LastvalueSymbol(null),
+ R_LevelsSymbol(null),
+ R_ModeSymbol(null),
+ R_NameSymbol(null),
+ R_NamesSymbol(null),
+ R_NaRmSymbol(null),
+ R_PackageSymbol(null),
+ R_QuoteSymbol(null),
+ R_RowNamesSymbol(null),
+ R_SeedsSymbol(null),
+ R_SourceSymbol(null),
+ R_TspSymbol(null),
+ R_dot_defined(null),
+ R_dot_Method(null),
+ R_dot_target(null),
+ R_SrcrefSymbol(RDataFactory.createSymbol("srcref")),
+ R_SrcfileSymbol(RDataFactory.createSymbol("srcfile")),
+ R_NaString(RDataFactory.createStringVectorFromScalar(RRuntime.STRING_NA)),
+ R_BlankString(RDataFactory.createStringVectorFromScalar(""));
+
+ private Object value;
+
+ RVariables(Object value) {
+ this.value = value;
+ }
+
+ public Object getValue() {
+ return value;
+ }
+ }
/**
* Load the {@code librfficall} library. N.B. this library defines some non-JNI global symbols
@@ -73,7 +115,7 @@ public class CallRFFIWithJNI implements CallRFFI {
throw RError.error(RError.NO_NODE, ex);
}
System.load(librffiPath);
- initialize(INITIALIZE_VALUES);
+ initialize(RVariables.values());
}
private static final Semaphore inCritical = new Semaphore(1, false);
@@ -109,7 +151,7 @@ public class CallRFFIWithJNI implements CallRFFI {
throw RInternalError.unimplemented(".External");
}
- private static native void initialize(Object[] initialValues);
+ private static native void initialize(RVariables[] variables);
private static native Object call(long address, Object[] args);
diff --git a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
index 11f0be5931..581553fd19 100644
--- a/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
+++ b/com.oracle.truffle.r.runtime/src/com/oracle/truffle/r/runtime/env/REnvironment.java
@@ -99,6 +99,8 @@ public abstract class REnvironment extends RAttributeStorage implements RTypedVa
Base getBaseEnv();
+ REnvironment getBaseNamespace();
+
REnvironment getNamespaceRegistry();
REnvironment.SearchPath getSearchPath();
@@ -139,6 +141,10 @@ public abstract class REnvironment extends RAttributeStorage implements RTypedVa
return baseEnv;
}
+ public REnvironment getBaseNamespace() {
+ return baseEnv.getNamespace();
+ }
+
public REnvironment getNamespaceRegistry() {
return namespaceRegistry;
}
diff --git a/com.oracle.truffle.r.test.cran/r/install.cran.packages.R b/com.oracle.truffle.r.test.cran/r/install.cran.packages.R
new file mode 100644
index 0000000000..bdb1406713
--- /dev/null
+++ b/com.oracle.truffle.r.test.cran/r/install.cran.packages.R
@@ -0,0 +1,183 @@
+# A script to install CRAN packages, with a blacklist mechanism starting from a known
+# set of packages that we cannot handle, e.g. Rcpp (due to C++)
+# By default all packages are candidates for installation, but this
+# can be limited by a regexp pattern
+
+args <- commandArgs(TRUE)
+
+usage <- function() {
+ cat("usage: Rscript [--contriburl url] [--verbose | -v] [-dryrun] [--save-blacklist file] [--blacklist file] [package-pattern\n")
+ quit(status=1)
+}
+
+# blacklist is a vector of package (names) that are known to be bad, i.e. uninstallable.
+# the result is a vector of new packages that depend/import/suggest/linkto any package on blacklist
+create.blacklist.with <- function(blacklist) {
+ this.blacklist <- vector()
+
+ trim <- function (x) gsub("^\\s+|\\s+$", "", x)
+
+ strip.version <- function(x) gsub("\\s+\\(.*\\)$", "", x)
+
+ for (i in (1:length(rownames(avail.pkgs)))) {
+ pkg <- avail.pkgs[i, ]
+ if (!(pkg["Package"] %in% blacklist)) {
+ all.deps <- vector()
+ for (dep in c("Depends", "Imports", "LinkingTo")) {
+ deps <- pkg[dep]
+ if (!is.na(dep)) {
+ if (very.verbose) {
+ cat(dep, " deps for: ", pkg["Package"], " ", deps, "\n")
+ }
+ all.deps <- append(all.deps, strip.version(trim(unlist(strsplit(deps, fixed=T, ", ")))))
+ }
+ }
+
+ match.result <- match(blacklist, all.deps, nomatch=0)
+ in.result <- match.result > 0
+ if (any(in.result)) {
+ if (verbose) {
+ names(all.deps) <- NULL
+ cat("adding: ", pkg["Package"], " to blacklist (", all.deps[match.result], ")\n")
+ }
+ this.blacklist <- append(this.blacklist, pkg["Package"])
+ }
+ }
+ }
+
+ names(this.blacklist) <- NULL
+ this.blacklist
+}
+
+# iteratively adds to blacklist until no new blackisted packages are found
+create.blacklist.iter <- function(blacklist) {
+ v <-blacklist
+ result <-v
+ while (length(v) > 0) {
+ v <- create.blacklist.with(result)
+ result <- append(result, v)
+ }
+ result
+}
+
+# known to be uninstallable
+initial.blacklist <- c("Rcpp", "grid", "splines", "parallel")
+
+create.blacklist <- function() {
+ create.blacklist.iter(initial.blacklist)
+}
+
+abort <- function(msg) {
+ print(msg)
+ quit("no", 1)
+}
+
+# find the available packages from contriburl and macth those against pkg.pattern
+# sets global variables avail.pkgs and toinstall.pkgs
+get.pkgs <- function() {
+ avail.pkgs <<- available.packages(contriburl=contriburl, type="source")
+ matched.avail.pkgs <- apply(avail.pkgs, 1, function(x) grepl(pkg.pattern, x["Package"]))
+ toinstall.pkgs <<-avail.pkgs[matched.avail.pkgs, , drop=F]
+}
+
+# performs the installation, or logs what it would install if dry.run = T
+# either creates the blacklist or reads it from a file
+do.install <- function() {
+ get.pkgs()
+
+ if (read.blacklist) {
+ if (is.na(blacklist.file) || !file.exists(blacklist.file)) {
+ abort("blacklist file not set or does not exist")
+ } else {
+ blacklist <- readLines(con=file(blacklist.file))
+ }
+ } else {
+ blacklist <- create.blacklist()
+ }
+
+ if (save.blacklist) {
+ if (is.na(blacklist.file)) {
+ abort("blacklist file not set")
+ } else {
+ writeLines(sort(blacklist), con=blacklist.file)
+ }
+ }
+
+ pkgnames <- rownames(toinstall.pkgs)
+ for (pkgname in pkgnames) {
+ if (pkgname %in% blacklist) {
+ cat("not installing: ", pkgname, " - blacklisted\n")
+ } else {
+ if (dry.run) {
+ cat("would install: ", pkgname, "\n")
+ } else {
+ cat("installing: ", pkgname, "\n")
+ install.packages(pkgname, contriburl=contriburl, type="source", INSTALL_opts="--install-tests")
+ }
+ }
+ }
+}
+
+# parse the command line arguments when run as a script
+parse.args <- function() {
+ while (length(args)) {
+ a <- args[1L]
+ if (a %in% c("-h", "--help")) {
+ usage()
+ } else if (a == "--contriburl") {
+ if (length(args) >= 2L) {
+ contriburl <<- args[2L]
+ args <<- args[-1L]
+ } else {
+ usage()
+ }
+ } else if (a == "--verbose" || a == "-v") {
+ verbose <<- T
+ } else if (a == "-V") {
+ verbose <<- T
+ very.verbose <- T
+ } else if (a == "--dryrun") {
+ dry.run <<- T
+ } else if (a == "--save-blacklist") {
+ save.blacklist <<- T
+ } else if (a == "--read-blacklist") {
+ read.blacklist <<- T
+ } else if (a == "--blacklist") {
+ if (length(args) >= 2L) {
+ blacklist.file <<- args[2L]
+ args <<- args[-1L]
+ } else {
+ usage()
+ }
+ } else {
+ pkg.pattern <<- a
+ break
+ }
+
+ args <<- args[-1L]
+ }
+}
+
+# global variables used by the installation
+contriburl <- Sys.getenv("LOCAL_CRAN_REPO", unset=NA)
+if (is.na(contriburl)) {
+ contriburl <- paste("file://", getwd(), "/cran/LOCAL_REPO/src/contrib", sep="")
+}
+blacklist.file <- Sys.getenv("PACKAGE_BLACKLIST", unset=NA)
+
+pkg.pattern <- "^.*"
+verbose <- F
+very.verbose <- F
+dry.run <- F
+avail.pkgs <- NULL
+toinstall.pkgs <- NULL
+save.blacklist <- F
+read.blacklist <- F
+
+if (!interactive()) {
+ parse.args()
+ do.install()
+}
+
+#tryCatch(url(contriburl, open="r"), error=abort)
+
diff --git a/mx.fastr/mx_fastr.py b/mx.fastr/mx_fastr.py
index 67ae1eb180..9ceb3128ba 100644
--- a/mx.fastr/mx_fastr.py
+++ b/mx.fastr/mx_fastr.py
@@ -136,12 +136,12 @@ def _fastr_gate_runner(args, tasks):
with mx_gate.Task('UnitTests: +EST', tasks) as t:
if t:
- if junit(['--J', '@-DR:+ExperimentalStateTrans', '--tests', _gate_unit_tests()]) != 0:
+ if junit(['--J', '@-DR:+NewStateTransition', '--tests', _gate_unit_tests()]) != 0:
t.abort('unit tests failed')
with mx_gate.Task('UnitTests: -EST', tasks) as t:
if t:
- if junit(['--J', '@-DR:-ExperimentalStateTrans', '--tests', _gate_unit_tests()]) != 0:
+ if junit(['--J', '@-DR:-NewStateTransition', '--tests', _gate_unit_tests()]) != 0:
t.abort('unit tests failed')
mx_gate.add_gate_runner(_fastr_suite, _fastr_gate_runner)
@@ -279,8 +279,11 @@ def _ser_unit_tests():
def _app_unit_tests():
return _test_subpackage('apps')
+def _tck_unit_tests():
+ return _test_subpackage('tck')
+
def _gate_unit_tests():
- return ','.join((_library_unit_tests(), _rffi_unit_tests(), _rpackages_unit_tests(), _builtins_unit_tests(), _functions_unit_tests(), _ser_unit_tests(), _app_unit_tests(), _nodes_unit_tests()))
+ return ','.join((_library_unit_tests(), _rffi_unit_tests(), _rpackages_unit_tests(), _builtins_unit_tests(), _functions_unit_tests(), _ser_unit_tests(), _app_unit_tests(), _nodes_unit_tests(), _tck_unit_tests()))
def _all_unit_tests():
return _gate_unit_tests()
@@ -401,6 +404,11 @@ def runRREPL(args, nonZeroIsFatal=True, extraVmArgs=None):
'''run R repl'''
return runR(args, _rREPLClass(), nonZeroIsFatal=nonZeroIsFatal, extraVmArgs=['-DR:+Instrument'])
+def installcran(args):
+ cran = 'com.oracle.truffle.r.test.cran'
+ join(mx.project(cran).dir, 'r', 'install.cran.packages.R')
+ return runR(args, rscript_command_class())
+
def load_optional_suite(name):
hg_base = mx.get_env('MX_HG_BASE')
urlinfos = None if hg_base is None else [mx.SuiteImportURLInfo(join(hg_base, name), 'hg', mx.vc_system('hg'))]
@@ -434,6 +442,7 @@ _commands = {
'rcmplib' : [rcmplib, ['options']],
'test' : [test, ['options']],
'rrepl' : [runRREPL, '[options]'],
+ 'installcran' : [installcran, '[options]']
}
mx.update_commands(_fastr_suite, _commands)
diff --git a/mx.fastr/suite.py b/mx.fastr/suite.py
index c31aea79bd..4f11e66ae8 100644
--- a/mx.fastr/suite.py
+++ b/mx.fastr/suite.py
@@ -267,6 +267,7 @@ suite = {
"sourceDirs" : ["src"],
"dependencies" : [
"mx:JUNIT",
+ "truffle:TRUFFLE_TCK",
"com.oracle.truffle.r.engine",
],
"checkstyle" : "com.oracle.truffle.r.runtime",
@@ -282,6 +283,12 @@ suite = {
"workingSets" : "FastR",
},
+ "com.oracle.truffle.r.test.cran" : {
+ "sourceDirs" : ["r"],
+ "javaCompliance" : "1.8",
+ "workingSets" : "FastR",
+ },
+
"com.oracle.truffle.r.engine" : {
"sourceDirs" : ["src"],
"dependencies" : [
--
GitLab