diff --git a/com.oracle.truffle.r.native/fficall/Makefile b/com.oracle.truffle.r.native/fficall/Makefile
index 811cca35f9c8d198e0149562ffc84ac1950d063f..96ca7f47c1a5b1c902f33d67ad306e026be86ee4 100644
--- a/com.oracle.truffle.r.native/fficall/Makefile
+++ b/com.oracle.truffle.r.native/fficall/Makefile
@@ -21,10 +21,36 @@
# questions.
#
-.PHONY: all clean
+# Builds libR
-all:
+ifneq (,$(wildcard $(TOPDIR)/platform.mk))
+include $(TOPDIR)/platform.mk
+else
+ifneq ($(MAKECMDGOALS),clean)
+$(error no platform.mk available)
+endif
+endif
+
+.PHONY: all clean objs
+
+C_LIBNAME := libR$(DYLIB_EXT)
+C_LIB := $(FASTR_LIB_DIR)/$(C_LIBNAME)
+
+ifeq ($(OS_NAME), Darwin)
+VERSION_FLAGS := -current_version $(R_VERSION) -compatibility_version $(R_VERSION)
+endif
+
+all: $(C_LIB)
+
+$(C_LIB): objs
+ $(DYLIB_LD) $(DYLIB_LDFLAGS) -o $(C_LIB) $(wildcard lib/*.o) $(VERSION_FLAGS)
+
+objs:
+ $(MAKE) -C src/common all
$(MAKE) -C src/jni all
clean:
+ $(MAKE) -C src/common clean
$(MAKE) -C src/jni clean
+ rm -rf $(C_LIB)
+
diff --git a/com.oracle.truffle.r.native/fficall/README b/com.oracle.truffle.r.native/fficall/README
index 167b8c8113c96d7c5fb442e6b61b6002753f4055..f065aab650d71840f6f56e1f11fa7deafa194033 100644
--- a/com.oracle.truffle.r.native/fficall/README
+++ b/com.oracle.truffle.r.native/fficall/README
@@ -1,29 +1,57 @@
fficall contains the implementation of the R FFI, as described in https://cran.r-project.org/doc/manuals/r-release/R-exts.html.
It's actually a bit more than that as it also contains code copied from GnuR, for example that supports graphics or is sufficiently
-simple that it is neither necessary nor desirable to implement in Java.
+simple that it is neither necessary nor desirable to implement in Java. As this has evolved a better name for 'fficall' would be 'main'
+for compatibility with GnuR.
- There are two sub-directories:
+ There are four sub-directories:
+ include
common
jni
+ variable_defs
+include
+=======
+
+'include' should be thought as analgous to GnuR's src/include, i.e. internal headers needed by the code in 'src/main'.
+What are trying to do by redefining them here is provide a boundary so that we don't accidently capture code from GnuR that
+is specific to the implementation of GnuR that is different in FastR, e.g., the representation of R objects. Evidently not every
+piece of GnuR code or an internal header has that characteristic but this strategy allows us some control to draw the boundary as
+tight as possible. Obviously we want to avoid duplicating (copying) code, as this requires validating the copy when migrating GnuR versions,
+so there are three levels of implementation choice for the content of the header in this directory:
+
+* Leave empty. This allows a #include to succeed and, if code does not actually use any symbols from the header, is ok.
+* Indirect to the real GnuR header. This is potentially dangerous but a simple default for code that uses symbols from the header.
+* Extract specific definitions from the GnuR header into a cut-down version. While this copies code it may be necessary
+ to avoid unwanted aspects of the GnuR header. In principle this can be done by a 'copy with sed' approach.
+
+The indirection requires the use of the quote form of the #include directive. To avoid using a path that is GnuR version dependent,
+the file gnurheaders.mk provides a make variable GNUR_HEADER_DEFS with a set of appropriate -D CFLAGS.
+
+Ideally, code is always compiled in such a way that headers never implicitly read from GnuR, only via the 'include' directory.
+Unfortunately this cannot always be guaranteed as a directive of the form include "foo.h" (as opposed to include <foo.h>) in the
+GnuR C code will always access a header in the same directory as the code being compiled. I.e., only the angle-bracket form can be controlled
+by the -I compiler flag. If this is a problem, the only solution is to 'copy with sed' the .c file and convert the quote form to the
+angle bracket form.
+
+common
+======
'common' contains code that has no explicit JNI dependencies and has been extracted for reuse in other implementations. This code is mostly
-copied/included from GnuR. 'jni' contains the implementation that is based on and has explicit dependencies on Java JNI.
+copied/included from GnuR. N.B. Some modified files have a "_fastr" suffix to avoid a clash with an existing file in GnuR that would match
+the Makefile rule for compiling directly from the GnuR file.
- Note that the 'common' files cannot all be compiled in isolation, as they typically depend on the implementation
- via rffiutils.h (and Rinternals.h). N.B. the GnuR code may "include" header files that are private to the GnuR implementation.
- These must always be replaced with local versions that make sense under FastR. Examples are Defn.h and Internal.h. When code
- is compiled the C compiler include path NEVER reaches into GnuR; all internal headers that are needed must exist in the
- common directory. They may explicitly include the original header but doing it this way ensures that we never accidently
- include an internal header. It is TBD to decide exactly what is needed from the GnuR internal headers. Ideally,
- we would provide versions that are absolutely minimal. Clearly it is a bug if any code that depends on the actual
- GnuR implementation ends up in the FastR library.
+jni
+===
+'jni' contains the implementation that is based on and has explicit dependencies on Java JNI.
- N.B. Some modified files have a "_fastr" suffix to avoid a clash with an existing file in GnuR that would match
- the Makefile rule for compiling directly from the GnuR file.
+The R FFI is rather baroque and defined in large set of header files in the 'include' directory that is a sibling of 'fficall'.
+In GnuR, the implementation of the functions is spread over the GnuR C files in 'src/main'. To ease navigation of the FastR implementation,
+in general, the implementation of the functions in a header file 'Rxxx.h' is stored in the file 'Rxxx.c'.
- The R FFI is rather baroque and defined in large set of header files in the sibling 'include' directory. In GnuR, the implementation
- of the functions is spread over the GnuR C files in 'src/main'. To ease navigation of the FastR implementation, in general,
- the implementation of the functions in a header file 'Rxxx.h' is stored in the file 'Rxxx.c'.
+The points of entry from Java are defined in the file rfficall.c. Various utility functions are defined in rffiutils.{h,c}.
-The points of entry from Java are defined in the file rfficall.c. Various utility functions are defined if rffiutils.{h,c}.
+variable_defs
+=============
+The GnuR FFI defines a large number of (extern) variables the defintiions of which, in GnuR, are scattered across the source files.
+In FastR these are collected into one file, variable_defs.h. However, the actual initialization of the variables is, in general, implementation
+dependent. In order to support a JNI and a non-JNI implementation, the file is stored in a seperate directory.
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Makefile b/com.oracle.truffle.r.native/fficall/src/common/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..8f0a7c7966b86add195292b4fb619c374b5ec2bf
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/common/Makefile
@@ -0,0 +1,91 @@
+#
+# Copyright (c) 2015, 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.
+#
+
+# This builds the GNUR files that are compiled directly, and local overrides
+
+ifneq ($(MAKECMDGOALS),clean)
+include $(TOPDIR)/platform.mk
+endif
+
+.PHONY: all clean copy_appl_objects
+
+# location of compiled code (.o files)
+OBJ = ../../lib
+
+GNUR_APPL_C_FILES = pretty.c interv.c
+GNUR_APPL_SRC = $(GNUR_HOME)/src/appl
+# the Fortran sources are not recompiled, just copied
+GNUR_APPL_F_OBJECTS := $(wildcard $(GNUR_APPL_SRC)/d*.o)
+
+GNUR_MAIN_C_FILES = colors.c devices.c engine.c format.c graphics.c plot.c plot3d.c plotmath.c rlocale.c sort.c
+GNUR_MAIN_SRC = $(GNUR_HOME)/src/main
+
+GNUR_C_OBJECTS := $(addprefix $(OBJ)/, $(GNUR_APPL_C_FILES:.c=.o) $(GNUR_MAIN_C_FILES:.c=.o))
+GNUR_F_OBJECTS := $(GNUR_APPL_F_OBJECTS)
+
+C_SOURCES = $(wildcard *.c)
+C_OBJECTS := $(patsubst %.c,$(OBJ)/%.o,$(C_SOURCES))
+
+F_SOURCES = $(wildcard *.f)
+F_OBJECTS := $(patsubst %.f,$(OBJ)/%.o,$(F_SOURCES))
+
+JNI_INCLUDES = -I $(JAVA_HOME)/include -I $(JAVA_HOME)/include/$(JDK_OS_DIR)
+FFI_INCLUDES = -I$(TOPDIR)/include -I$(TOPDIR)/include/R_ext
+INCLUDES := -I $(abspath ../include) $(JNI_INCLUDES) $(FFI_INCLUDES)
+
+include ../include/gnurheaders.mk
+
+SUPPRESS_WARNINGS := -Wno-int-conversion -Wno-implicit-function-declaration
+
+all: Makefile $(C_OBJECTS) $(F_OBJECTS) $(GNUR_C_OBJECTS) $(GNUR_F_OBJECTS) copy_appl_objects
+
+copy_appl_objects: $(GNUR_APPL_F_OBJECTS)
+ cp $(GNUR_APPL_F_OBJECTS) $(OBJ)
+
+$(C_OBJECTS): | $(OBJ)
+
+$(GNUR_C_OBJECTS): | $(OBJ)
+
+$(GNUR_F_OBJECTS): | $(OBJ)
+
+#CFLAGS := $(CFLAGS) -H
+
+
+$(OBJ):
+ mkdir -p $(OBJ)
+
+$(OBJ)/%.o: $(GNUR_APPL_SRC)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/%.o: $(GNUR_MAIN_SRC)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/%.o: %.c $(TOPDIR)/include/Rinternals.h
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/%.o: %.f
+ $(F77) $(FFLAGS) $(FPICFLAGS) -c $< -o $@
+
+clean:
+ rm -rf $(OBJ)
+
diff --git a/com.oracle.truffle.r.native/fficall/src/common/arithmetic_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/arithmetic_fastr.c
index 07ca55f5f5baa07f003d820fe5c70aef67b95865..77c0d737b6832a1c9fb50448536ebc1be2706c09 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/arithmetic_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/arithmetic_fastr.c
@@ -11,7 +11,7 @@
* All rights reserved.
*/
-#include <rffiutils.h>
+#include <Rinternals.h>
#include <stdlib.h>
// FastR: selected functions from arithmetic.c:
diff --git a/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c
index 7e855712f62c5379469080ce612054d934700c59..dae288af88ba75f0d1793c8c3fc9e5f623ff9c8c 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/coerce_fastr.c
@@ -11,7 +11,7 @@
* All rights reserved.
*/
-#include <rffiutils.h>
+#include <Rinternals.h>
#define _(Source) (Source)
diff --git a/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c
index c0932795aa3ec9b532414a9f41f3eb82687dabb1..04933118b60983ec3bfdeaccc9fab2a4186ed61d 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/inlined_fastr.c
@@ -11,7 +11,7 @@
* All rights reserved.
*/
-#include <rffiutils.h>
+#include <Rinternals.h>
#define INLINE_FUN
diff --git a/com.oracle.truffle.r.native/fficall/src/common/print_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/print_fastr.c
index c17dca824e7e75289c536f6687b01fd752527fa1..d7aec9052fc0ebae5df43cfdcc9ebc51faa56a58 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/print_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/print_fastr.c
@@ -76,7 +76,6 @@
#include <config.h>
#endif
-#include <rffiutils.h>
#include <Defn.h>
#include <Print.h>
#include <R_ext/RS.h>
diff --git a/com.oracle.truffle.r.native/fficall/src/common/printutils_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/printutils_fastr.c
index 646bc692d981db507410283e38d227da3136f0cb..f13eafda634ea60792b37d55dd65249f39fb2b60 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/printutils_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/printutils_fastr.c
@@ -17,7 +17,6 @@
#include <config.h>
#endif
-#include <rffiutils.h>
#include <Defn.h>
#include <Print.h>
diff --git a/com.oracle.truffle.r.native/fficall/src/common/sys_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/sys_fastr.c
index 9e92fb7b2fbe7efd53568107920b2a0a67155790..488fb3e730afab1ee5c9d6c13d387eaa9d28fdde 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/sys_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/sys_fastr.c
@@ -10,10 +10,11 @@
* All rights reserved.
*/
-#include <rffiutils.h>
+#include <Rinternals.h>
// selected functions copied from sys-unix.c and sysutils.c:
+#include <stdlib.h>
#include <sys/stat.h>
static char newFileName[PATH_MAX];
diff --git a/com.oracle.truffle.r.native/fficall/src/common/util_fastr.c b/com.oracle.truffle.r.native/fficall/src/common/util_fastr.c
index 42283f30abf13316474e3139c11950ec609b3ced..cfdeef13006af83482026aa2c685a51ac52223e5 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/util_fastr.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/util_fastr.c
@@ -10,7 +10,7 @@
* All rights reserved.
*/
-#include "rffiutils.h"
+#include <Rinternals.h>
#include <stdlib.h>
#include <R_ext/RS.h>
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Defn.h b/com.oracle.truffle.r.native/fficall/src/include/Defn.h
similarity index 75%
rename from com.oracle.truffle.r.native/fficall/src/common/Defn.h
rename to com.oracle.truffle.r.native/fficall/src/include/Defn.h
index 6f8289a6e6fee9b3bef1bab38c41b95bf87b4c2c..c8902ed8331a8e1a5a181ebf9a101c498dec4bdb 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/Defn.h
+++ b/com.oracle.truffle.r.native/fficall/src/include/Defn.h
@@ -16,7 +16,8 @@
#ifndef DEFN_H_
#define DEFN_H_
-#include <jni.h>
+#define HAVE_ERRNO_H 1
+
#include <stdlib.h>
#include <Rinternals.h>
@@ -49,6 +50,8 @@ extern SEXP R_DevicesSymbol;
extern Rboolean R_Interactive;
extern Rboolean R_Visible;
int R_ReadConsole(const char *, unsigned char *, int, int);
+extern const char *R_Home;
+extern const char *R_TempDir;
//#define HAVE_MBSTATE_T 1 // actually from config.h
@@ -56,6 +59,11 @@ extern Rboolean utf8locale;
extern Rboolean mbcslocale;
extern Rboolean latin1locale;
+#define INI_as(v)
+extern char OutDec INI_as('.');
+extern Rboolean known_to_be_latin1 INI_as(FALSE);
+extern Rboolean known_to_be_utf8 INI_as(FALSE);
+
extern int R_dec_min_exponent;
extern unsigned int max_contour_segments;
@@ -63,5 +71,21 @@ typedef SEXP (*CCODE)(SEXP, SEXP, SEXP, SEXP);
CCODE (PRIMFUN)(SEXP x);
+#define Unix
+#ifdef Unix
+# define OSTYPE "unix"
+# define FILESEP "/"
+#endif /* Unix */
+
+#ifdef Win32
+# define OSTYPE "windows"
+# define FILESEP "/"
+#endif /* Win32 */
+
+#include <wchar.h>
+
+typedef unsigned short ucs2_t;
+
+#define streql(s, t) (!strcmp((s), (t)))
#endif /* DEFN_H_ */
diff --git a/com.oracle.truffle.r.native/fficall/src/include/Fileio.h b/com.oracle.truffle.r.native/fficall/src/include/Fileio.h
new file mode 100644
index 0000000000000000000000000000000000000000..e766e1f3dc878d99fb5eb16bc45eeebaa0fb588a
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/include/Fileio.h
@@ -0,0 +1,17 @@
+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 1995, 1996, 1997 Robert Gentleman and Ross Ihaka
+ * Copyright (c) 1995-2014, The R Core Team
+ * Copyright (c) 2002-2008, The R Foundation
+ * Copyright (c) 2015, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+
+// This is a version of src/include/Fileio.h that is a safe replacement for use with FastR
+// Currently simply redirects to the GnuR version
+
+#include GNUR_FILEIO_H
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Graphics.h b/com.oracle.truffle.r.native/fficall/src/include/Graphics.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/Graphics.h
rename to com.oracle.truffle.r.native/fficall/src/include/Graphics.h
diff --git a/com.oracle.truffle.r.native/fficall/src/common/GraphicsBase.h b/com.oracle.truffle.r.native/fficall/src/include/GraphicsBase.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/GraphicsBase.h
rename to com.oracle.truffle.r.native/fficall/src/include/GraphicsBase.h
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Internal.h b/com.oracle.truffle.r.native/fficall/src/include/Internal.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/Internal.h
rename to com.oracle.truffle.r.native/fficall/src/include/Internal.h
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Print.h b/com.oracle.truffle.r.native/fficall/src/include/Print.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/Print.h
rename to com.oracle.truffle.r.native/fficall/src/include/Print.h
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Rgraphics.h b/com.oracle.truffle.r.native/fficall/src/include/Rgraphics.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/Rgraphics.h
rename to com.oracle.truffle.r.native/fficall/src/include/Rgraphics.h
diff --git a/com.oracle.truffle.r.native/fficall/src/include/config.h b/com.oracle.truffle.r.native/fficall/src/include/config.h
new file mode 100644
index 0000000000000000000000000000000000000000..8852692c104b36637b64dfd7a99a239c6457efb1
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/include/config.h
@@ -0,0 +1,25 @@
+/*
+ * Copyright (c) 2015, 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.
+ */
+
+// (currently) empty replacememnt for GnuR's config.h
+
diff --git a/com.oracle.truffle.r.native/fficall/src/include/contour-common.h b/com.oracle.truffle.r.native/fficall/src/include/contour-common.h
new file mode 100644
index 0000000000000000000000000000000000000000..ac74c45b92dd2c9dd4cf6901c8b884ef4aa60adf
--- /dev/null
+++ b/com.oracle.truffle.r.native/fficall/src/include/contour-common.h
@@ -0,0 +1,17 @@
+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 1995, 1996, 1997 Robert Gentleman and Ross Ihaka
+ * Copyright (c) 1995-2014, The R Core Team
+ * Copyright (c) 2002-2008, The R Foundation
+ * Copyright (c) 2015, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+
+// This is a version of src/main/contour_common.h that is a safe replacement for use with FastR
+// Currently simply redirects to the GnuR version
+
+#include GNUR_CONTOUR_COMMON_H
diff --git a/com.oracle.truffle.r.native/fficall/src/common/common.mk b/com.oracle.truffle.r.native/fficall/src/include/gnurheaders.mk
similarity index 62%
rename from com.oracle.truffle.r.native/fficall/src/common/common.mk
rename to com.oracle.truffle.r.native/fficall/src/include/gnurheaders.mk
index b4c37e5b3c7320b5f430f2091a3f9caf4b6ae56a..1fa197e893fee92cb7186340031a2650fc8ed74f 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/common.mk
+++ b/com.oracle.truffle.r.native/fficall/src/include/gnurheaders.mk
@@ -21,25 +21,12 @@
# questions.
#
-# This defines the GNUR files that are compiled directly, local overrides, plus -D defines that allow the
-# header files that redirect to GnuR versions to be location/version independent. It is included
-# by the actual implementation Makefile, e.g.in ../jni
-
-GNUR_APPL_C_FILES = pretty.c interv.c
-GNUR_APPL_SRC = $(GNUR_HOME)/src/appl
-# the Fortran sources are not recompiled
-GNUR_APPL_F_OBJECTS := $(wildcard $(GNUR_APPL_SRC)/d*.o)
-
-
-GNUR_MAIN_C_FILES = colors.c devices.c engine.c format.c graphics.c plot.c plot3d.c plotmath.c rlocale.c sort.c
-GNUR_MAIN_SRC = $(GNUR_HOME)/src/main
-
-GNUR_C_OBJECTS := $(addprefix $(OBJ)/, $(GNUR_APPL_C_FILES:.c=.o) $(GNUR_MAIN_C_FILES:.c=.o))
-GNUR_F_OBJECTS := $(GNUR_APPL_F_OBJECTS)
-
# headers that we refer to indirectly (allows version/location independence in source)
+GNUR_CONFIG_H := $(GNUR_HOME)/src/include/config.h
+GNUR_CONTOUR_COMMON_H := $(GNUR_HOME)/src/main/contour-common.h
GNUR_GRAPHICS_H := $(GNUR_HOME)/src/include/Graphics.h
GNUR_GRAPHICSBASE_H := $(GNUR_HOME)/src/include/GraphicsBase.h
+GNUR_FILEIO_H := $(GNUR_HOME)/src/include/Fileio.h
GNUR_RGRAPHICS_H := $(GNUR_HOME)/src/include/Rgraphics.h
GNUR_INTERNAL_H := $(GNUR_HOME)/src/include/Internal.h
GNUR_NMATH_H := $(GNUR_HOME)/src/nmath/nmath.h
@@ -48,12 +35,6 @@ GNUR_RLOCALE_H := $(GNUR_HOME)/src/include/rlocale.h
GNUR_HEADER_DEFS := -DGNUR_GRAPHICS_H=\"$(GNUR_GRAPHICS_H)\" -DGNUR_GRAPHICSBASE_H=\"$(GNUR_GRAPHICSBASE_H)\" \
-DGNUR_RGRAPHICS_H=\"$(GNUR_RGRAPHICS_H)\" -DGNUR_INTERNAL_H=\"$(GNUR_INTERNAL_H)\" \
- -DGNUR_NMATH_H=\"$(GNUR_NMATH_H)\" -DGNUR_PRINT_H=\"$(GNUR_PRINT_H)\" -DGNUR_RLOCALE_H=\"$(GNUR_RLOCALE_H)\"
-
-SUPPRESS_WARNINGS := -Wno-int-conversion -Wno-implicit-function-declaration
-
-$(OBJ)/%.o: $(GNUR_APPL_SRC)/%.c
- $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
-
-$(OBJ)/%.o: $(GNUR_MAIN_SRC)/%.c
- $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
+ -DGNUR_NMATH_H=\"$(GNUR_NMATH_H)\" -DGNUR_PRINT_H=\"$(GNUR_PRINT_H)\" -DGNUR_RLOCALE_H=\"$(GNUR_RLOCALE_H)\" \
+ -DGNUR_FILEIO_H=\"$(GNUR_FILEIO_H)\" -DGNUR_CONFIG_H=\"$(GNUR_CONFIG_H)\" \
+ -DGNUR_CONTOUR_COMMON_H=\"$(GNUR_CONTOUR_COMMON_H)\"
diff --git a/com.oracle.truffle.r.native/fficall/src/common/nmath.h b/com.oracle.truffle.r.native/fficall/src/include/nmath.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/nmath.h
rename to com.oracle.truffle.r.native/fficall/src/include/nmath.h
diff --git a/com.oracle.truffle.r.native/fficall/src/common/rlocale.h b/com.oracle.truffle.r.native/fficall/src/include/rlocale.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/rlocale.h
rename to com.oracle.truffle.r.native/fficall/src/include/rlocale.h
diff --git a/com.oracle.truffle.r.native/fficall/src/jni/Makefile b/com.oracle.truffle.r.native/fficall/src/jni/Makefile
index a80a0ca6598eebda26dc66cd079222891ea98f32..cf8d9aea8681906c42d287dfffed4a0a5278beae 100644
--- a/com.oracle.truffle.r.native/fficall/src/jni/Makefile
+++ b/com.oracle.truffle.r.native/fficall/src/jni/Makefile
@@ -21,12 +21,6 @@
# questions.
#
-# Master Makefile for libR. Includes ../common/common.mk to include common files in the build
-
-ifeq ($(TOPDIR),)
- TOPDIR = $(abspath ../../..)
-endif
-
ifneq ($(MAKECMDGOALS),clean)
include $(TOPDIR)/platform.mk
endif
@@ -36,63 +30,34 @@ endif
# location of compiled code (.o files)
OBJ = ../../lib
-COMMON = $(abspath ../common)
-
-include $(COMMON)/common.mk
-
-C_COMMON_SOURCES := $(notdir $(wildcard $(COMMON)/*.c))
-#$(info C_COMMON_SOURCES=$(C_COMMON_SOURCES))
-
-F_COMMON_SOURCES := $(notdir $(wildcard $(COMMON)/*.f))
-F_OBJECTS := $(patsubst %.f,$(OBJ)/%.o,$(F_COMMON_SOURCES))
-
-C_LOCAL_SOURCES := $(wildcard *.c)
-#$(info C_LOCAL_SOURCES=$(C_LOCAL_SOURCES))
-
C_HDRS := $(wildcard *.h)
-C_LIBNAME := libR$(DYLIB_EXT)
-C_LIB := $(FASTR_LIB_DIR)/$(C_LIBNAME)
-C_SOURCES = $(C_LOCAL_SOURCES) $(C_COMMON_SOURCES)
-C_OBJECTS := $(patsubst %.c,$(OBJ)/%.o,$(C_LOCAL_SOURCES)) $(patsubst %.c,$(OBJ)/%.o,$(C_COMMON_SOURCES))
+C_SOURCES = $(wildcard *.c)
+C_OBJECTS := $(patsubst %.c,$(OBJ)/%.o,$(C_SOURCES))
#$(info C_OBJECTS=$(C_OBJECTS))
JNI_INCLUDES = -I $(JAVA_HOME)/include -I $(JAVA_HOME)/include/$(JDK_OS_DIR)
-LOCAL_INCLUDES = -I. -I$(COMMON)
FFI_INCLUDES = -I$(TOPDIR)/include -I$(TOPDIR)/include/R_ext
+LOCAL_INCLUDES = -I . -I $(abspath ../include)
INCLUDES := $(LOCAL_INCLUDES) $(JNI_INCLUDES) $(FFI_INCLUDES)
-ifeq ($(OS_NAME), Darwin)
-VERSION_FLAGS := -current_version $(R_VERSION) -compatibility_version $(R_VERSION)
-endif
-
# uncomment to see exactly where headers are being read from
#CFLAGS := $(CFLAGS) -H
-all: Makefile $(C_LIB)
+all: Makefile $(C_OBJECTS)
-$(C_LIB): $(OBJ) $(C_OBJECTS) $(F_OBJECTS) $(GNUR_F_OBJECTS) $(GNUR_C_OBJECTS)
- $(DYLIB_LD) $(DYLIB_LDFLAGS) -o $(C_LIB) $(C_OBJECTS) $(F_OBJECTS) $(GNUR_C_OBJECTS) $(GNUR_F_OBJECTS) $(VERSION_FLAGS)
-
+$(C_OBJECTS): | $(OBJ)
$(OBJ):
mkdir -p $(OBJ)
-# rule for sources in thgis directory (no connection to GnuR)
$(OBJ)/%.o: %.c $(TOPDIR)/include/Rinternals.h $(C_HDRS)
- $(CC) $(CFLAGS) $(INCLUDES) -c $< -o $@
-
-# rule for common, needs access to GnuR, suppress warnings
-$(OBJ)/%.o: $(COMMON)/%.c $(TOPDIR)/include/Rinternals.h $(C_HDRS)
- $(CC) $(CFLAGS) -DGNUR_HOME=$(GNUR_HOME) $(INCLUDES) $(GNUR_HEADER_DEFS) $(SUPPRESS_WARNINGS) -c $< -o $@
-
-$(OBJ)/%.o: $(COMMON)/%.f
- $(F77) $(FFLAGS) $(FPICFLAGS) -c $< -o $@
+ $(CC) $(CFLAGS) $(INCLUDES) -I../variable_defs -c $< -o $@
# for debugging, to see what's really being compiled
$(OBJ)/%.E: %.c $(TOPDIR)/include/Rinternals.h
$(CC) -E $(CFLAGS) $(INCLUDES) -c $< > $@
clean:
- rm -rf $(OBJ) $(C_LIB)
+ rm -rf $(OBJ)
diff --git a/com.oracle.truffle.r.native/fficall/src/common/variable_defs.h b/com.oracle.truffle.r.native/fficall/src/variable_defs/variable_defs.h
similarity index 100%
rename from com.oracle.truffle.r.native/fficall/src/common/variable_defs.h
rename to com.oracle.truffle.r.native/fficall/src/variable_defs/variable_defs.h
diff --git a/com.oracle.truffle.r.native/library/compiler/Makefile b/com.oracle.truffle.r.native/library/compiler/Makefile
index f128fcf8a4ea847d045bd6a86eda6d24ffe6ae27..5d04f5a44410bd319a9980992892491dd201a5d1 100644
--- a/com.oracle.truffle.r.native/library/compiler/Makefile
+++ b/com.oracle.truffle.r.native/library/compiler/Makefile
@@ -21,4 +21,6 @@
# questions.
#
+NO_LIBRARY := 1
+
include ../lib.mk
diff --git a/com.oracle.truffle.r.native/library/datasets/Makefile b/com.oracle.truffle.r.native/library/datasets/Makefile
index f128fcf8a4ea847d045bd6a86eda6d24ffe6ae27..5d04f5a44410bd319a9980992892491dd201a5d1 100644
--- a/com.oracle.truffle.r.native/library/datasets/Makefile
+++ b/com.oracle.truffle.r.native/library/datasets/Makefile
@@ -21,4 +21,6 @@
# questions.
#
+NO_LIBRARY := 1
+
include ../lib.mk
diff --git a/com.oracle.truffle.r.native/library/grDevices/Makefile b/com.oracle.truffle.r.native/library/grDevices/Makefile
index f128fcf8a4ea847d045bd6a86eda6d24ffe6ae27..70aa2e75d74d3513e405dd46ea0bf71656d170a4 100644
--- a/com.oracle.truffle.r.native/library/grDevices/Makefile
+++ b/com.oracle.truffle.r.native/library/grDevices/Makefile
@@ -21,4 +21,29 @@
# questions.
#
+OBJ = lib
+
+GNUR_INCLUDES := -I$(TOPDIR)/fficall/src/include
+GRDEV_INCLUDES := -I$(GNUR_HOME)/src/library/grDevices
+GNUR_GZIO_H := $(GNUR_HOME)/src/main/gzio.h
+GNUR_SRC_CAIRO := $(GNUR_HOME)/src/library/grDevices/src/cairo
+GNUR_CAIRO_C_SOURCES := $(notdir $(wildcard $(GNUR_SRC_CAIRO)/*.c))
+# not compiling Cairo currently
+GNUR_C_SOURCES := axis_scales.c chull.c colors.c devCairo.c devPS.c devPicTeX.c devQuartz.c \
+ devices.c init.c qdBitmap.c qdPDF.c stubs.c # $(GNUR_CAIRO_C_SOURCES)
+
+GNUR_C_OBJECTS := $(addprefix $(OBJ)/, $(GNUR_C_SOURCES:.c=.o))
+
include ../lib.mk
+include $(TOPDIR)/fficall/src/include/gnurheaders.mk
+
+#CFLAGS := $(CFLAGS) -H
+
+$(OBJ)/%.o: $(GNUR_SRC)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_INCLUDES) $(GNUR_HEADER_DEFS) $(GRDEV_INCLUDES) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/%.o: $(GNUR_SRC_CAIRO)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_INCLUDES) $(GNUR_HEADER_DEFS) $(GRDEV_INCLUDES) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/gzio.o: $(SRC)/gzio.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_INCLUDES) $(GNUR_HEADER_DEFS) -DGNUR_GZIO_H=\"$(GNUR_GZIO_H)\" $(SUPPRESS_WARNINGS) -c $< -o $@
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/Defn.h b/com.oracle.truffle.r.native/library/grDevices/src/Defn.h
deleted file mode 100644
index 1d104ad49f882865220797b79a689ef2a6ec3b98..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/Defn.h
+++ /dev/null
@@ -1,89 +0,0 @@
-/*
- * Copyright (c) 2015, 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.
- */
-
-// selected definitions from the original Defn.h file:
-
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1998--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/
- */
-
-#ifndef DEFN_H_
-#define DEFN_H_
-
-#define HAVE_ERRNO_H 1
-
-#include <Rinternals.h>
-
-#define f_tell ftell
-
-#define INI_as(v)
-#define extern0 extern
-#define attribute_hidden
-
-#define F77_SYMBOL(x) x ## _
-#define F77_QSYMBOL(x) #x "_"
-
-extern char OutDec INI_as('.');
-extern Rboolean known_to_be_latin1 INI_as(FALSE);
-extern Rboolean known_to_be_utf8 INI_as(FALSE);
-extern unsigned int max_contour_segments INI_as(25000);
-
-#define streql(s, t) (!strcmp((s), (t)))
-
-
-#define Unix
-#ifdef Unix
-# define OSTYPE "unix"
-# define FILESEP "/"
-#endif /* Unix */
-
-#ifdef Win32
-# define OSTYPE "windows"
-# define FILESEP "/"
-#endif /* Win32 */
-
-#include <wchar.h>
-
-typedef unsigned short ucs2_t;
-
-extern Rboolean R_Visible;
-extern const char *R_Home;
-extern const char *R_TempDir;
-
-#endif /* DEFN_H_ */
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/axis_scales.c b/com.oracle.truffle.r.native/library/grDevices/src/axis_scales.c
deleted file mode 100644
index c5ab8c478174f73fa9cd8d6f504c1e7134b45b10..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/axis_scales.c
+++ /dev/null
@@ -1,68 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2004-11 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/
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <R.h>
-#include <Rinternals.h>
-#include <R_ext/GraphicsEngine.h>
-
-#include "grDevices.h"
-
-SEXP R_CreateAtVector(SEXP axp, SEXP usr, SEXP nint, SEXP is_log)
-{
- int nint_v = asInteger(nint);
- Rboolean logflag = asLogical(is_log);
-
- axp = coerceVector(axp, REALSXP);
- usr = coerceVector(usr, REALSXP);
- if(LENGTH(axp) != 3) error(_("'%s' must be numeric of length %d"), "axp", 3);
- if(LENGTH(usr) != 2) error(_("'%s' must be numeric of length %d"), "usr", 2);
-
- return CreateAtVector(REAL(axp), REAL(usr), nint_v, logflag);
- // -> ../../../main/plot.c
-}
-
-SEXP R_GAxisPars(SEXP usr, SEXP is_log, SEXP nintLog)
-{
- Rboolean logflag = asLogical(is_log);
- int n = asInteger(nintLog);// will be changed on output ..
- double min, max;
- const char *nms[] = {"axp", "n", ""};
- SEXP axp, ans;
-
- usr = coerceVector(usr, REALSXP);
- if(LENGTH(usr) != 2) error(_("'%s' must be numeric of length %d"), "usr", 2);
- min = REAL(usr)[0];
- max = REAL(usr)[1];
-
- GAxisPars(&min, &max, &n, logflag, 0);// axis = 0 :<==> do not warn.. [TODO!]
- // -> ../../../main/graphics.c
-
- PROTECT(ans = mkNamed(VECSXP, nms));
- SET_VECTOR_ELT(ans, 0, (axp = allocVector(REALSXP, 2)));// protected
- SET_VECTOR_ELT(ans, 1, ScalarInteger(n));
- REAL(axp)[0] = min;
- REAL(axp)[1] = max;
-
- UNPROTECT(1);
- return ans;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.c b/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.c
deleted file mode 100644
index 27164eb8bd84802b244ff7a233f2ace7dfa922ca..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.c
+++ /dev/null
@@ -1,536 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--2014 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/
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-/* This module is only compiled if HAVE_WORKING_CAIRO is true */
-
-/* additional entry points used here
-
- cairo_show_page
- cairo_pdf_surface_create (1.2)
- cairo_ps_surface_create (1.2)
- cairo_ps_surface_set_eps (1.6)
- cairo_surface_write_to_png
- cairo_svg_surface_create (1.2)
- cairo_svg_surface_restrict_to_version (1.2)
-
- */
-
-#ifdef Win32
-//#define HAVE_PANGOCAIRO 1
-#define HAVE_CAIRO_SVG 1
-#define HAVE_CAIRO_PDF 1
-#define HAVE_CAIRO_PS 1
-/* and if not using pango, this selects fontconfig */
-//#define USE_FC 1
-
-# define raise our_raise
-# include <Defn.h>
-# undef raise
-#else
-# include <Defn.h>
-#endif
-
-#define R_USE_PROTOTYPES 1
-#include <R_ext/GraphicsEngine.h>
-#include <Defn.h>
-#include "Fileio.h" /* R_fopen */
-
-#include "cairoBM.h"
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#undef _
-#define _(String) dgettext ("grDevices", String)
-#else
-#define _(String) (String)
-#endif
-
-
-static double RedGamma = 1.0;
-static double GreenGamma = 1.0;
-static double BlueGamma = 1.0;
-
-static void cbm_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- *left = 0.0;
- *right = xd->windowWidth;
- *bottom = xd->windowHeight;
- *top = 0.0;
-}
-
-#define NO_X11 1
-#include "cairoFns.c"
-
-#ifdef Win32
-# include "rbitmap.h"
-#else
-# include "bitmap.h"
-#endif
-
-static Rboolean
-BM_Open(pDevDesc dd, pX11Desc xd, int width, int height)
-{
- cairo_status_t res;
- if (xd->type == PNG || xd->type == JPEG ||
- xd->type == TIFF || xd->type == BMP) {
-#ifdef Win32
- if (!Load_Rbitmap_Dll()) {
- warning("Unable to load Rbitmap.dll");
- return FALSE;
- }
-#endif
- xd->cs = cairo_image_surface_create(CAIRO_FORMAT_ARGB32,
- xd->windowWidth,
- xd->windowHeight);
- } else if (xd->type == PNGdirect) {
- xd->cs = cairo_image_surface_create(CAIRO_FORMAT_ARGB32,
- xd->windowWidth,
- xd->windowHeight);
- } else if(xd->type == SVG || xd->type == PDF || xd->type == PS) {
- /* leave creation to BM_Newpage */
- return TRUE;
- } else
- error(_("unimplemented cairo-based device"));
-
- res = cairo_surface_status(xd->cs);
- if (res != CAIRO_STATUS_SUCCESS) {
- warning("cairo error '%s'", cairo_status_to_string(res));
- return FALSE;
- }
- xd->cc = cairo_create(xd->cs);
- res = cairo_status(xd->cc);
- if (res != CAIRO_STATUS_SUCCESS) {
- warning("cairo error '%s'", cairo_status_to_string(res));
- return FALSE;
- }
- cairo_set_operator(xd->cc, CAIRO_OPERATOR_OVER);
- cairo_reset_clip(xd->cc);
- cairo_set_antialias(xd->cc, xd->antialias);
- return TRUE;
-}
-
-
-static int stride;
-
-static unsigned int Cbitgp(void *xi, int x, int y)
-{
- unsigned int *data = xi;
- return data[x*stride+y];
-}
-
-static void BM_Close_bitmap(pX11Desc xd)
-{
- if (xd->type == PNGdirect) {
- char buf[PATH_MAX];
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- cairo_surface_write_to_png(xd->cs, buf);
- return;
- }
-
- void *xi = cairo_image_surface_get_data(xd->cs);
- if (!xi) {
- warning("BM_Close_bitmap called on non-surface");
- return;
- }
-
- stride = cairo_image_surface_get_stride(xd->cs)/4;
- if (xd->type == PNG)
- R_SaveAsPng(xi, xd->windowWidth, xd->windowHeight,
- Cbitgp, 0, xd->fp, 0, xd->res_dpi);
- else if(xd->type == JPEG)
- R_SaveAsJpeg(xi, xd->windowWidth, xd->windowHeight,
- Cbitgp, 0, xd->quality, xd->fp, xd->res_dpi);
- else if(xd->type == BMP)
- R_SaveAsBmp(xi, xd->windowWidth, xd->windowHeight,
- Cbitgp, 0, xd->fp, xd->res_dpi);
- else {
- char buf[PATH_MAX];
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- R_SaveAsTIFF(xi, xd->windowWidth, xd->windowHeight,
- Cbitgp, 0, R_ExpandFileName(buf), xd->res_dpi,
- xd->quality);
- }
-}
-
-static void BM_NewPage(const pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- char buf[PATH_MAX];
- cairo_status_t res;
-
- xd->npages++;
- if (xd->type == PNG || xd->type == JPEG || xd->type == BMP) {
- if (xd->npages > 1) {
- /* try to preserve the page we do have */
- BM_Close_bitmap(xd);
- if (xd->fp) fclose(xd->fp);
- }
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- xd->fp = R_fopen(R_ExpandFileName(buf), "wb");
- if (!xd->fp)
- error(_("could not open file '%s'"), buf);
- }
- else if(xd->type == PNGdirect || xd->type == TIFF) {
- if (xd->npages > 1) {
- xd->npages--;
- BM_Close_bitmap(xd);
- xd->npages++;
- }
- }
-#ifdef HAVE_CAIRO_SVG
- else if(xd->type == SVG) {
- if (xd->npages > 1 && xd->cs) {
- cairo_show_page(xd->cc);
- if(!xd->onefile) {
- cairo_surface_destroy(xd->cs);
- cairo_destroy(xd->cc);
- }
- }
- if(xd->npages == 1 || !xd->onefile) {
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- xd->cs = cairo_svg_surface_create(R_ExpandFileName(buf),
- (double)xd->windowWidth,
- (double)xd->windowHeight);
- res = cairo_surface_status(xd->cs);
- if (res != CAIRO_STATUS_SUCCESS) {
- xd->cs = NULL;
- error("cairo error '%s'", cairo_status_to_string(res));
- }
- if(xd->onefile)
- cairo_svg_surface_restrict_to_version(xd->cs, CAIRO_SVG_VERSION_1_2);
- xd->cc = cairo_create(xd->cs);
- res = cairo_status(xd->cc);
- if (res != CAIRO_STATUS_SUCCESS) {
- error("cairo error '%s'", cairo_status_to_string(res));
- }
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- }
-#endif
-#ifdef HAVE_CAIRO_PDF
- else if(xd->type == PDF) {
- if (xd->npages > 1) {
- cairo_show_page(xd->cc);
- if(!xd->onefile) {
- cairo_surface_destroy(xd->cs);
- cairo_destroy(xd->cc);
- }
- }
- if(xd->npages == 1 || !xd->onefile) {
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- xd->cs = cairo_pdf_surface_create(R_ExpandFileName(buf),
- (double)xd->windowWidth,
- (double)xd->windowHeight);
- res = cairo_surface_status(xd->cs);
- if (res != CAIRO_STATUS_SUCCESS) {
- error("cairo error '%s'", cairo_status_to_string(res));
- }
- xd->cc = cairo_create(xd->cs);
- res = cairo_status(xd->cc);
- if (res != CAIRO_STATUS_SUCCESS) {
- error("cairo error '%s'", cairo_status_to_string(res));
- }
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- }
-#endif
-#ifdef HAVE_CAIRO_PS
- else if(xd->type == PS) {
- if (xd->npages > 1 && !xd->onefile) {
- cairo_show_page(xd->cc);
- cairo_surface_destroy(xd->cs);
- cairo_destroy(xd->cc);
- }
- if(xd->npages == 1 || !xd->onefile) {
- snprintf(buf, PATH_MAX, xd->filename, xd->npages);
- xd->cs = cairo_ps_surface_create(R_ExpandFileName(buf),
- (double)xd->windowWidth,
- (double)xd->windowHeight);
- res = cairo_surface_status(xd->cs);
- if (res != CAIRO_STATUS_SUCCESS) {
- error("cairo error '%s'", cairo_status_to_string(res));
- }
-// We already require >= 1.2
-#if CAIRO_VERSION_MAJOR > 2 || CAIRO_VERSION_MINOR >= 6
- if(!xd->onefile)
- cairo_ps_surface_set_eps(xd->cs, TRUE);
-#endif
- xd->cc = cairo_create(xd->cs);
- res = cairo_status(xd->cc);
- if (res != CAIRO_STATUS_SUCCESS) {
- error("cairo error '%s'", cairo_status_to_string(res));
- }
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- }
-#endif
- else
- error(_("unimplemented cairo-based device"));
-
- cairo_reset_clip(xd->cc);
- if (xd->type == PNG || xd->type == TIFF|| xd->type == PNGdirect) {
- /* First clear it */
- cairo_set_operator (xd->cc, CAIRO_OPERATOR_CLEAR);
- cairo_paint (xd->cc);
- cairo_set_operator (xd->cc, CAIRO_OPERATOR_OVER);
- xd->fill = gc->fill;
- } else
- xd->fill = R_OPAQUE(gc->fill) ? gc->fill: xd->canvas;
- CairoColor(xd->fill, xd);
- cairo_new_path(xd->cc);
- cairo_paint(xd->cc);
-}
-
-
-static void BM_Close(pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- if (xd->npages)
- if (xd->type == PNG || xd->type == JPEG ||
- xd->type == TIFF || xd->type == BMP || xd->type == PNGdirect)
- BM_Close_bitmap(xd);
- if (xd->fp) fclose(xd->fp);
- if (xd->cc) cairo_show_page(xd->cc);
- if (xd->cs) cairo_surface_destroy(xd->cs);
- if (xd->cc) cairo_destroy(xd->cc);
- free(xd);
-}
-
-
-
-static Rboolean
-BMDeviceDriver(pDevDesc dd, int kind, const char *filename,
- int quality, int width, int height, int ps,
- int bg, int res, int antialias, const char *family)
-{
- pX11Desc xd;
- int res0 = (res > 0) ? res : 72;
- double dps = ps;
-
- /* allocate new device description */
- if (!(xd = (pX11Desc) calloc(1, sizeof(X11Desc)))) return FALSE;
- strcpy(xd->filename, filename);
- xd->quality = quality;
- xd->windowWidth = width;
- xd->windowHeight = height;
- strncpy(xd->basefontfamily, family, 500);
-#ifdef HAVE_PANGOCAIRO
- /* Pango's default resolution is 96 dpi */
- dps *= res0/96.0;
-#else
- dps *= res0/72.0;
-#endif
- xd->pointsize = dps;
- xd->bg = bg;
- xd->res_dpi = res;
- switch(antialias){
- case 1: xd->antialias = CAIRO_ANTIALIAS_DEFAULT; break;
- case 2: xd->antialias = CAIRO_ANTIALIAS_NONE; break;
- case 3: xd->antialias = CAIRO_ANTIALIAS_GRAY; break;
- case 4: xd->antialias = CAIRO_ANTIALIAS_SUBPIXEL; break;
- default: xd->antialias = CAIRO_ANTIALIAS_DEFAULT;
- }
- xd->npages = 0;
- xd->col = R_RGB(0, 0, 0);
- xd->fill = xd->canvas = bg;
- xd->type = kind;
- xd->fp = NULL;
- xd->lty = -1;
- xd->lwd = -1;
- xd->lend = 0;
- xd->ljoin = 0;
-
- if (!BM_Open(dd, xd, width, height)) {
- free(xd);
- return FALSE;
- }
- if (xd->type == SVG || xd->type == PDF || xd->type == PS)
- xd->onefile = quality != 0;
-
- /* Set up Data Structures */
- dd->size = cbm_Size;
- dd->clip = Cairo_Clip;
- dd->rect = Cairo_Rect;
- dd->circle = Cairo_Circle;
- dd->line = Cairo_Line;
- dd->polyline = Cairo_Polyline;
- dd->polygon = Cairo_Polygon;
- dd->path = Cairo_Path;
- dd->raster = Cairo_Raster;
-#ifdef HAVE_PANGOCAIRO
- dd->metricInfo = PangoCairo_MetricInfo;
- dd->strWidth = dd->strWidthUTF8 = PangoCairo_StrWidth;
- dd->text = dd->textUTF8 = PangoCairo_Text;
-#else
- dd->metricInfo = Cairo_MetricInfo;
- dd->strWidth = dd->strWidthUTF8 = Cairo_StrWidth;
- dd->text = dd->textUTF8 = Cairo_Text;
-#endif
- dd->hasTextUTF8 = TRUE;
-#if defined(Win32) && !defined(USE_FC)
- dd->wantSymbolUTF8 = NA_LOGICAL;
-#else
- dd->wantSymbolUTF8 = TRUE;
-#endif
- dd->useRotatedTextInContour = FALSE;
-
- dd->haveTransparency = 2;
- dd->haveRaster = 2;
- switch(xd->type) {
- case PDF:
- case SVG:
- case PNG:
- case PNGdirect:
- dd->haveTransparentBg = 3;
- break;
- case PS:
- dd->haveTransparentBg = 2;
- dd->haveRaster = 3; /* ?? */
- break;
- default: /* TIFF, BMP */
- dd->haveTransparency = 1;
- }
-
- dd->newPage = BM_NewPage;
- dd->close = BM_Close;
-
- dd->left = 0;
- dd->right = width;
- dd->top = 0;
- dd->bottom = height;
- /* rescale points to pixels */
- dd->cra[0] = 0.9 * ps * res0/72.0;
- dd->cra[1] = 1.2 * ps * res0/72.0;
- dd->startps = ps;
- xd->fontscale = dps/ps;
- dd->ipr[0] = dd->ipr[1] = 1.0/res0;
- xd->lwdscale = res0/96.0;
- dd->xCharOffset = 0.4900;
- dd->yCharOffset = 0.3333;
- dd->yLineBias = 0.2;
- dd->canClip= TRUE;
- dd->canHAdj = 2;
- dd->canChangeGamma = FALSE;
- dd->startcol = xd->col;
- dd->startfill = xd->fill;
- dd->startlty = LTY_SOLID;
- dd->startfont = 1;
- dd->displayListOn = FALSE;
- dd->deviceSpecific = (void *) xd;
-
- return TRUE;
-}
-
-const static struct {
- const char * const name;
- X_GTYPE gtype;
-} devtable[] = {
- { "", WINDOW },
- { "", XIMAGE },
- { "png", PNG },
- { "jpeg", JPEG },
- { "svg", SVG },
- { "png", PNGdirect },
- { "cairo_pdf", PDF },
- { "cairo_ps", PS },
- { "tiff", TIFF },
- { "bmp", BMP }
-};
-
-/*
- cairo(filename, type, width, height, pointsize, bg, res, antialias,
- quality, family)
-*/
-SEXP in_Cairo(SEXP args)
-{
- pGEDevDesc gdd;
- SEXP sc;
- const char *filename, *family;
- int type, quality, width, height, pointsize, bgcolor, res, antialias;
- const void *vmax = vmaxget();
-
- args = CDR(args); /* skip entry point name */
- if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
- error(_("invalid '%s' argument"), "filename");
- filename = translateChar(STRING_ELT(CAR(args), 0));
- args = CDR(args);
- type = asInteger(CAR(args));
- if(type == NA_INTEGER || type <= 0)
- error(_("invalid '%s' argument"), "type");
- args = CDR(args);
- width = asInteger(CAR(args));
- if(width == NA_INTEGER || width <= 0)
- error(_("invalid '%s' argument"), "width");
- args = CDR(args);
- height = asInteger(CAR(args));
- if(height == NA_INTEGER || height <= 0)
- error(_("invalid '%s' argument"), "height");
- args = CDR(args);
- pointsize = asInteger(CAR(args));
- if(pointsize == NA_INTEGER || pointsize <= 0)
- error(_("invalid '%s' argument"), "pointsize");
- args = CDR(args);
- sc = CAR(args);
- if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
- error(_("invalid '%s' value"), "bg");
- bgcolor = RGBpar(sc, 0);
- args = CDR(args);
- res = asInteger(CAR(args));
- args = CDR(args);
- antialias = asInteger(CAR(args));
- if(antialias == NA_INTEGER)
- error(_("invalid '%s' argument"), "antialias");
- args = CDR(args);
- quality = asInteger(CAR(args));
- if(quality == NA_INTEGER || quality < 0 || quality > 100)
- error(_("invalid '%s' argument"), "quality");
- args = CDR(args);
- if (!isString(CAR(args)) || LENGTH(CAR(args)) < 1)
- error(_("invalid '%s' argument"), "family");
- family = translateChar(STRING_ELT(CAR(args), 0));
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- /* Allocate and initialize the device driver data */
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc)))) return 0;
- if (!BMDeviceDriver(dev, devtable[type].gtype, filename, quality,
- width, height, pointsize,
- bgcolor, res, antialias, family)) {
- free(dev);
- error(_("unable to start device '%s'"), devtable[type].name);
- }
- gdd = GEcreateDevDesc(dev);
- GEaddDevice2(gdd, devtable[type].name);
- } END_SUSPEND_INTERRUPTS;
-
- vmaxset(vmax);
- return R_NilValue;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.h b/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.h
deleted file mode 100644
index ca36f25837e59cab79a96c9d3a14df2df5d2d256..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.h
+++ /dev/null
@@ -1,101 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1997--2011 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/
- */
-
-#ifndef R_DEV_CAIRO_H
-#define R_DEV_CAIRO_H
-
-#define SYMBOL_FONTFACE 5
-
-typedef enum {
- WINDOW,
- XIMAGE,
- PNG,
- JPEG,
- TIFF,
- PNGdirect,
- SVG,
- PDF,
- PS,
- BMP
-} X_GTYPE;
-
-
-#include <stdio.h>
-
-#ifdef HAVE_PANGOCAIRO
-# include <pango/pango.h>
-# include <pango/pangocairo.h>
-#else
-# include <cairo.h>
-#endif
-#ifdef HAVE_CAIRO_SVG
-# include <cairo-svg.h>
-# endif
-#ifdef HAVE_CAIRO_PDF
-# include <cairo-pdf.h>
-# endif
-#ifdef HAVE_CAIRO_PS
-# include <cairo-ps.h>
-# endif
-
-typedef struct {
- /* Graphics Parameters */
- /* Local device copy so that we can detect */
- /* when parameter changes. */
-
- /* Used to detect changes */
- int lty; /* Line type */
- double lwd;
- R_GE_lineend lend;
- R_GE_linejoin ljoin;
-
- double lwdscale; /* scaling to get a multiple
- of 1/96" */
-
- int col; /* Color */
- int fill;
- int bg; /* bg */
- int canvas; /* Canvas colour */
- int fontface; /* Typeface 1:5 */
- int fontsize; /* Size in points */
- double pointsize; /* Size in points */
- char basefontfamily[500]; /* Initial font family */
-
- int windowWidth; /* Window width (pixels) */
- int windowHeight; /* Window height (pixels) */
- X_GTYPE type; /* Window or pixmap? */
- int npages; /* counter for a pixmap */
- FILE *fp; /* file for a bitmap device */
- char filename[PATH_MAX]; /* filename for a bitmap device */
- int quality; /* JPEG quality/TIFF compression */
-
- int res_dpi; /* used for png/jpeg */
- char title[101];
- Rboolean onefile;
-
- Rboolean useCairo, buffered;
- cairo_t *cc, *xcc;
- cairo_surface_t *cs, *xcs;
- cairo_antialias_t antialias;
-
- double fontscale;
-} X11Desc;
-
-typedef X11Desc* pX11Desc;
-#endif
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoFns.c b/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoFns.c
deleted file mode 100644
index 4e503e76e47b1579ae996d0792033125a49f401f..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoFns.c
+++ /dev/null
@@ -1,890 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2008--2013 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/
- */
-
-
-/* Entry points used
-
- cairo_arc
- cairo_clip
- cairo_close_path
- cairo_create
- cairo_destroy
- cairo_fill_preserve
- cairo_get_source
- cairo_get_target
- cairo_image_surface_create
- cairo_image_surface_create_for_data
- cairo_image_surface_get_data (1.2)
- cairo_image_surface_get_stride
- cairo_line_to
- cairo_move_to
- cairo_new_path
- cairo_paint
- cairo_pattern_set_extend
- cairo_pattern_set_filter
- cairo_rectangle
- cairo_rel_move_to
- cairo_reset_clip
- cairo_restore
- cairo_rotate
- cairo_save
- cairo_scale
- cairo_set_antialias
- cairo_set_dash
- cairo_set_fill_rule
- cairo_set_line_cap
- cairo_set_line_join
- cairo_set_line_width
- cairo_set_miter_limit
- cairo_set_operator
- cairo_set_source_rgb
- cairo_set_source_rgba
- cairo_set_source_surface
- cairo_status
- cairo_status_to_string
- cairo_stroke
- cairo_surface_destroy
- cairo_surface_status
-
- cairo_xlib_surface_create
- cairo_xlib_surface_set_size
-
- cairo_show_text
- cairo_text_extents
-
- cairo_ft_font_face_create_for_ft_face [OS X]
-
- g_object_unref (glib)
-
- pango_cairo_create_layout (1.10)
- pango_cairo_show_layout (1.10)
- pango_font_description_free
- pango_font_description_new
- pango_font_description_set_family
- pango_font_description_set_size
- pango_font_description_set_style
- pango_font_description_set_weight
- pango_layout_get_line
- pango_layout_line_get_pixel_extents
- pango_layout_set_font_description
- pango_layout_set_text
-
-*/
-
-static void CairoColor(unsigned int col, pX11Desc xd)
-{
- unsigned int alpha = R_ALPHA(col);
- double red, blue, green;
-
- red = R_RED(col)/255.0;
- green = R_GREEN(col)/255.0;
- blue = R_BLUE(col)/255.0;
- red = pow(red, RedGamma);
- green = pow(green, GreenGamma);
- blue = pow(blue, BlueGamma);
-
- /* This optimization should not be necessary, but alpha = 1 seems
- to cause image fallback in some backends */
- if (alpha == 255)
- cairo_set_source_rgb(xd->cc, red, green, blue);
- else
- cairo_set_source_rgba(xd->cc, red, green, blue, alpha/255.0);
-}
-
-static void CairoLineType(const pGEcontext gc, pX11Desc xd)
-{
- cairo_t *cc = xd->cc;
- double lwd = gc->lwd;
- cairo_line_cap_t lcap = CAIRO_LINE_CAP_SQUARE;
- cairo_line_join_t ljoin = CAIRO_LINE_JOIN_ROUND;
- switch(gc->lend){
- case GE_ROUND_CAP: lcap = CAIRO_LINE_CAP_ROUND; break;
- case GE_BUTT_CAP: lcap = CAIRO_LINE_CAP_BUTT; break;
- case GE_SQUARE_CAP: lcap = CAIRO_LINE_CAP_SQUARE; break;
- }
- switch(gc->ljoin){
- case GE_ROUND_JOIN: ljoin = CAIRO_LINE_JOIN_ROUND; break;
- case GE_MITRE_JOIN: ljoin = CAIRO_LINE_JOIN_MITER; break;
- case GE_BEVEL_JOIN: ljoin = CAIRO_LINE_JOIN_BEVEL; break;
- }
- cairo_set_line_width(cc, (lwd > 0.01 ? lwd : 0.01) * xd->lwdscale);
- cairo_set_line_cap(cc, lcap);
- cairo_set_line_join(cc, ljoin);
- cairo_set_miter_limit(cc, gc->lmitre);
-
- if (gc->lty == 0 || gc->lty == -1 || gc->lty == NA_INTEGER)
- cairo_set_dash(cc, 0, 0, 0);
- else {
- double ls[16], lwd = (gc->lwd > 1) ? gc->lwd : 1;
- int l;
- /* Use unsigned int otherwise right shift of 'dt'
- may not terminate for loop */
- unsigned int dt = gc->lty;
- for (l = 0; dt != 0; dt >>= 4, l++)
- ls[l] = (dt & 0xF) * lwd * xd->lwdscale;
- cairo_set_dash(cc, ls, l, 0);
- }
-}
-
-static void Cairo_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- if (x1 < x0) { double h = x1; x1 = x0; x0 = h; };
- if (y1 < y0) { double h = y1; y1 = y0; y0 = h; };
-
- cairo_reset_clip(xd->cc);
- cairo_new_path(xd->cc);
- /* Add 1 per X11_Clip */
- cairo_rectangle(xd->cc, x0, y0, x1 - x0 + 1, y1 - y0 + 1);
- cairo_clip(xd->cc);
-}
-
-
-static void Cairo_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- cairo_new_path(xd->cc);
- cairo_rectangle(xd->cc, x0, y0, x1 - x0, y1 - y0);
-
- if (R_ALPHA(gc->fill) > 0) {
- cairo_set_antialias(xd->cc, CAIRO_ANTIALIAS_NONE);
- CairoColor(gc->fill, xd);
- cairo_fill_preserve(xd->cc);
- cairo_set_antialias(xd->cc, xd->antialias);
- }
-
- if (R_ALPHA(gc->col) > 0 && gc->lty != -1) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_stroke(xd->cc);
- }
-}
-
-static void Cairo_Circle(double x, double y, double r,
- const pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- cairo_new_path(xd->cc);
- /* radius 0.5 seems to be visible */
- cairo_arc(xd->cc, x, y, (r > 0.5 ? r : 0.5), 0.0, 2 * M_PI);
-
- if (R_ALPHA(gc->fill) > 0) {
- cairo_set_antialias(xd->cc, CAIRO_ANTIALIAS_NONE);
- CairoColor(gc->fill, xd);
- cairo_fill_preserve(xd->cc);
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- if (R_ALPHA(gc->col) > 0 && gc->lty != -1) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_stroke(xd->cc);
- }
-}
-
-static void Cairo_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- if (R_ALPHA(gc->col) > 0) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_new_path(xd->cc);
- cairo_move_to(xd->cc, x1, y1);
- cairo_line_to(xd->cc, x2, y2);
- cairo_stroke(xd->cc);
- }
-}
-
-static void Cairo_Polyline(int n, double *x, double *y,
- const pGEcontext gc, pDevDesc dd)
-{
- int i;
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- if (R_ALPHA(gc->col) > 0) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_new_path(xd->cc);
- cairo_move_to(xd->cc, x[0], y[0]);
- for(i = 0; i < n; i++) cairo_line_to(xd->cc, x[i], y[i]);
- cairo_stroke(xd->cc);
- }
-}
-
-static void Cairo_Polygon(int n, double *x, double *y,
- const pGEcontext gc, pDevDesc dd)
-{
- int i;
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- cairo_new_path(xd->cc);
- cairo_move_to(xd->cc, x[0], y[0]);
- for(i = 0; i < n; i++) cairo_line_to(xd->cc, x[i], y[i]);
- cairo_close_path(xd->cc);
-
- if (R_ALPHA(gc->fill) > 0) {
- cairo_set_antialias(xd->cc, CAIRO_ANTIALIAS_NONE);
- CairoColor(gc->fill, xd);
- cairo_fill_preserve(xd->cc);
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- if (R_ALPHA(gc->col) > 0 && gc->lty != -1) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_stroke(xd->cc);
- }
-}
-
-static void Cairo_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc, pDevDesc dd)
-{
- int i, j, n;
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- cairo_new_path(xd->cc);
- n = 0;
- for (i=0; i < npoly; i++) {
- cairo_move_to(xd->cc, x[n], y[n]);
- n++;
- for(j=1; j < nper[i]; j++) {
- cairo_line_to(xd->cc, x[n], y[n]);
- n++;
- }
- cairo_close_path(xd->cc);
- }
-
- if (R_ALPHA(gc->fill) > 0) {
- cairo_set_antialias(xd->cc, CAIRO_ANTIALIAS_NONE);
- if (winding)
- cairo_set_fill_rule(xd->cc, CAIRO_FILL_RULE_WINDING);
- else
- cairo_set_fill_rule(xd->cc, CAIRO_FILL_RULE_EVEN_ODD);
- CairoColor(gc->fill, xd);
- cairo_fill_preserve(xd->cc);
- cairo_set_antialias(xd->cc, xd->antialias);
- }
- if (R_ALPHA(gc->col) > 0 && gc->lty != -1) {
- CairoColor(gc->col, xd);
- CairoLineType(gc, xd);
- cairo_stroke(xd->cc);
- }
-}
-
-static cairo_surface_t* createImageSurface(unsigned int *raster, int w, int h)
-{
- int i;
- cairo_surface_t *image;
- unsigned char *imageData;
-
- imageData = (unsigned char *) R_alloc(4*w*h, sizeof(unsigned char));
- /* The R ABGR needs to be converted to a Cairo ARGB
- * AND values need to by premultiplied by alpha
- */
- for (i=0; i<w*h; i++) {
- int alpha = R_ALPHA(raster[i]);
- imageData[i*4 + 3] = (unsigned char) alpha;
- if (alpha < 255) {
- imageData[i*4 + 2] = (unsigned char)(R_RED(raster[i]) * alpha / 255);
- imageData[i*4 + 1] = (unsigned char)(R_GREEN(raster[i]) * alpha / 255);
- imageData[i*4 + 0] = (unsigned char)(R_BLUE(raster[i]) * alpha / 255);
- } else {
- imageData[i*4 + 2] = R_RED(raster[i]);
- imageData[i*4 + 1] = R_GREEN(raster[i]);
- imageData[i*4 + 0] = R_BLUE(raster[i]);
- }
- }
- image = cairo_image_surface_create_for_data(imageData,
- CAIRO_FORMAT_ARGB32,
- w, h,
- 4*w);
- return(image);
-}
-
-
-static void Cairo_Raster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
- int imageWidth, imageHeight;
- const void *vmax = vmaxget();
- cairo_surface_t *image;
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
-
- cairo_save(xd->cc);
-
- /* If we are going to use the graphics engine for interpolation
- * the image used for the Cairo surface is going to be a
- * different size
- */
- if (interpolate && CAIRO_VERSION_MAJOR < 2 && CAIRO_VERSION_MINOR < 6) {
- imageWidth = (int) (width + .5);
- imageHeight = abs((int) (height + .5));
- } else {
- imageWidth = w;
- imageHeight = h;
- }
-
- cairo_translate(xd->cc, x, y);
- cairo_rotate(xd->cc, -rot*M_PI/180);
- cairo_scale(xd->cc, width/imageWidth, height/imageHeight);
- /* Flip vertical first */
- cairo_translate(xd->cc, 0, imageHeight/2.0);
- cairo_scale(xd->cc, 1, -1);
- cairo_translate(xd->cc, 0, -imageHeight/2.0);
-
- if (interpolate) {
- if (CAIRO_VERSION_MAJOR < 2 && CAIRO_VERSION_MINOR < 6) {
- /* CAIRO_EXTEND_PAD not supported for image sources
- * so use graphics engine for interpolation
- */
- unsigned int *rasterImage;
- rasterImage = (unsigned int *) R_alloc(imageWidth * imageHeight,
- sizeof(unsigned int));
- R_GE_rasterInterpolate(raster, w, h,
- rasterImage, imageWidth, imageHeight);
- image = createImageSurface(rasterImage, imageWidth, imageHeight);
- cairo_set_source_surface(xd->cc, image, 0, 0);
- } else {
- image = createImageSurface(raster, w, h);
- cairo_set_source_surface(xd->cc, image, 0, 0);
- cairo_pattern_set_filter(cairo_get_source(xd->cc),
- CAIRO_FILTER_BILINEAR);
- cairo_pattern_set_extend(cairo_get_source(xd->cc),
- CAIRO_EXTEND_PAD);
- }
- } else {
- image = createImageSurface(raster, w, h);
- cairo_set_source_surface(xd->cc, image, 0, 0);
- cairo_pattern_set_filter(cairo_get_source(xd->cc),
- CAIRO_FILTER_NEAREST);
- }
-
- cairo_new_path(xd->cc);
- cairo_rectangle(xd->cc, 0, 0, imageWidth, imageHeight);
- cairo_clip(xd->cc);
- cairo_paint(xd->cc);
-
- cairo_restore(xd->cc);
- cairo_surface_destroy(image);
-
- vmaxset(vmax);
-}
-
-#ifndef NO_X11
-static SEXP Cairo_Cap(pDevDesc dd)
-{
- int i, width, height, size;
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- cairo_surface_t* screen;
- cairo_format_t format;
- unsigned int *screenData;
- SEXP dim, raster = R_NilValue;
- unsigned int *rint;
-
- screen = cairo_surface_reference(cairo_get_target(xd->cc));
- width = cairo_image_surface_get_width(screen);
- height = cairo_image_surface_get_height(screen);
- screenData = (unsigned int*) cairo_image_surface_get_data(screen);
-
- /* The type of image surface will depend on what sort
- * of X11 color model has been used */
- format = cairo_image_surface_get_format(screen);
- /* For now, if format is not RGB24 just bail out */
- if (format != CAIRO_FORMAT_RGB24) {
- cairo_surface_destroy(screen);
- return raster;
- }
-
- size = width*height;
-
- /* FIXME: the screen surface reference will leak if allocVector() fails */
- PROTECT(raster = allocVector(INTSXP, size));
-
- /* Copy each byte of screen to an R matrix.
- * The Cairo RGB24 needs to be converted to an R ABGR32.
- * Cairo uses native endiannes (A=msb,R,G,B=lsb) so use int* instead of char* */
- rint = (unsigned int *) INTEGER(raster);
- for (i = 0; i < size; i++)
- rint[i] = R_RGB((screenData[i] >> 16) & 255, (screenData[i] >> 8) & 255, screenData[i] & 255);
-
- /* Release MY reference to the screen surface (do it here in case anything fails below) */
- cairo_surface_destroy(screen);
-
- PROTECT(dim = allocVector(INTSXP, 2));
- INTEGER(dim)[0] = height;
- INTEGER(dim)[1] = width;
- setAttrib(raster, R_DimSymbol, dim);
-
- UNPROTECT(2);
- return raster;
-}
-#endif
-
-#ifdef HAVE_PANGOCAIRO
-/* ------------- pangocairo section --------------- */
-
-static PangoFontDescription
-*PG_getFont(const pGEcontext gc, double fs, const char *family)
-{
- PangoFontDescription *fontdesc;
- gint face = gc->fontface;
- double size = gc->cex * gc->ps * fs, ssize = PANGO_SCALE * size;
-#ifdef Win32
- const char *times = "Times New Roman", *hv = "Arial";
-#else
- const char *times = "times", *hv = "Helvetica";
-#endif
- if (face < 1 || face > 5) face = 1;
-
- fontdesc = pango_font_description_new();
- if (face == 5)
- pango_font_description_set_family(fontdesc, "symbol");
- else {
- const char *fm = gc->fontfamily;
- if (!fm[0]) fm = family;
- if (streql(fm, "mono")) fm = "courier";
- else if (streql(fm, "serif")) fm = times;
- else if (streql(fm, "sans")) fm = hv;
- pango_font_description_set_family(fontdesc, fm);
- if (face == 2 || face == 4)
- pango_font_description_set_weight(fontdesc, PANGO_WEIGHT_BOLD);
- if (face == 3 || face == 4)
- pango_font_description_set_style(fontdesc, PANGO_STYLE_OBLIQUE);
- }
- /* seems a ssize < 1 gums up pango, PR#14369 */
- if (ssize < 1) ssize = 1.0;
- pango_font_description_set_size(fontdesc, (gint) ssize);
-
- return fontdesc;
-}
-
-static PangoLayout
-*PG_layout(PangoFontDescription *desc, cairo_t *cc, const char *str)
-{
- PangoLayout *layout;
-
- layout = pango_cairo_create_layout(cc);
- pango_layout_set_font_description(layout, desc);
- pango_layout_set_text(layout, str, -1);
- return layout;
-}
-
-static void
-PG_text_extents(cairo_t *cc, PangoLayout *layout,
- gint *lbearing, gint *rbearing,
- gint *width, gint *ascent, gint *descent, int ink)
-{
- PangoRectangle rect, lrect;
-
- // This could be pango_layout_get_line_readonly since 1.16
- // Something like #if PANGO_VERSION_CHECK(1,16,0)
- pango_layout_line_get_pixel_extents(pango_layout_get_line(layout, 0),
- &rect, &lrect);
-
- if (width) *width = lrect.width;
- if (ink) {
- if (ascent) *ascent = PANGO_ASCENT(rect);
- if (descent) *descent = PANGO_DESCENT(rect);
- if (lbearing) *lbearing = PANGO_LBEARING(rect);
- if (rbearing) *rbearing = PANGO_RBEARING(rect);
- } else {
- if (ascent) *ascent = PANGO_ASCENT(lrect);
- if (descent) *descent = PANGO_DESCENT(lrect);
- if (lbearing) *lbearing = PANGO_LBEARING(lrect);
- if (rbearing) *rbearing = PANGO_RBEARING(lrect);
- }
-}
-
-static void
-PangoCairo_MetricInfo(int c, const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- char str[16];
- int Unicode = mbcslocale;
- PangoFontDescription *desc =
- PG_getFont(gc, xd->fontscale, xd->basefontfamily);
- PangoLayout *layout;
- gint iascent, idescent, iwidth;
-
- if (c == 0) c = 77;
- if (c < 0) {c = -c; Unicode = 1;}
-
- if (Unicode) {
- Rf_ucstoutf8(str, (unsigned int) c);
- } else {
- /* Here we assume that c < 256 */
- str[0] = (char) c; str[1] = (char) 0;
- }
- layout = PG_layout(desc, xd->cc, str);
- PG_text_extents(xd->cc, layout, NULL, NULL, &iwidth,
- &iascent, &idescent, 1);
- g_object_unref(layout);
- pango_font_description_free(desc);
- *ascent = iascent;
- *descent = idescent;
- *width = iwidth;
-#if 0
- printf("c = %d, '%s', face %d %f %f %f\n",
- c, str, gc->fontface, *width, *ascent, *descent);
-#endif
-}
-
-
-static double
-PangoCairo_StrWidth(const char *str, const pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- gint width;
- PangoFontDescription *desc =
- PG_getFont(gc, xd->fontscale, xd->basefontfamily);
- PangoLayout *layout = PG_layout(desc, xd->cc, str);
-
- PG_text_extents(xd->cc, layout, NULL, NULL, &width, NULL, NULL, 0);
- g_object_unref(layout);
- pango_font_description_free(desc);
- return (double) width;
-}
-
-static void
-PangoCairo_Text(double x, double y,
- const char *str, double rot, double hadj,
- const pGEcontext gc, pDevDesc dd)
-{
- if (R_ALPHA(gc->col) > 0) {
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- gint ascent, lbearing, width;
- PangoLayout *layout;
- PangoFontDescription *desc =
- PG_getFont(gc, xd->fontscale, xd->basefontfamily);
- cairo_save(xd->cc);
- layout = PG_layout(desc, xd->cc, str);
- PG_text_extents(xd->cc, layout, &lbearing, NULL, &width,
- &ascent, NULL, 0);
- cairo_move_to(xd->cc, x, y);
- if (rot != 0.0) cairo_rotate(xd->cc, -rot/180.*M_PI);
- /* pango has a coord system at top left */
- cairo_rel_move_to(xd->cc, -lbearing - width*hadj, -ascent);
- CairoColor(gc->col, xd);
- pango_cairo_show_layout(xd->cc, layout);
- cairo_restore(xd->cc);
- g_object_unref(layout);
- pango_font_description_free(desc);
- }
-}
-
-#else
-/* ------------- cairo-ft section --------------- */
-
-/* This uses what cairo refers to as its 'toy' interface:
- http://cairographics.org/manual/cairo-text.html
-
- No diagnostics that glyphs are present, no kerning.
- */
-
-#ifdef __APPLE__
-# define USE_FC 1
-#endif
-
-#if CAIRO_HAS_FT_FONT && USE_FC
-
-/* FT implies FC in Cairo */
-#include <cairo-ft.h>
-
-/* cairo font cache - to prevent unnecessary font look ups */
-typedef struct Rc_font_cache_s {
- const char *family;
- int face;
- cairo_font_face_t *font;
- struct Rc_font_cache_s *next;
-} Rc_font_cache_t;
-
-static Rc_font_cache_t *cache, *cache_tail;
-
-static cairo_font_face_t *Rc_findFont(const char *family, int face)
-{
- Rc_font_cache_t *here = cache;
- while (here) {
- if (here->face == face && streql(here->family, family))
- return here->font;
- here = here->next;
- }
- return NULL;
-}
-
-static void Rc_addFont(const char *family, int face, cairo_font_face_t* font)
-{
- Rc_font_cache_t *fc = (Rc_font_cache_t*) malloc(sizeof(Rc_font_cache_t));
- if (!fc) return;
- fc->family = strdup(family);
- fc->face = face;
- fc->font = font;
- fc->next = NULL;
- if (cache)
- cache_tail = cache_tail->next = fc;
- else
- cache = cache_tail = fc;
-}
-
-/* FC patterns to append to font family names */
-static const char *face_styles[4] = {
- ":style=Regular",
- ":style=Bold",
- ":style=Italic",
- ":style=Bold Italic,BoldItalic"
-};
-
-static int fc_loaded;
-static FT_Library ft_library;
-
-/* use FC to find a font, load it in FT and return the Cairo FT font face */
-static cairo_font_face_t *FC_getFont(const char *family, int style)
-{
- FcFontSet *fs;
- FcPattern *pat, *match;
- FcResult result;
- FcChar8 *file;
- char fcname[250]; /* 200 for family + 50 for style */
-
- /* find candidate fonts via FontConfig */
- if (!fc_loaded) {
- if (!FcInit()) return NULL;
- fc_loaded = 1;
- }
- style &= 3;
- strcpy(fcname, family);
- strcat(fcname, face_styles[style]);
- pat = FcNameParse((FcChar8 *)fcname);
- if (!pat) return NULL;
- FcConfigSubstitute (0, pat, FcMatchPattern);
- FcDefaultSubstitute (pat);
- fs = FcFontSetCreate ();
- match = FcFontMatch (0, pat, &result);
- FcPatternDestroy (pat);
- if (!match) {
- FcFontSetDestroy (fs);
- return NULL;
- }
- FcFontSetAdd (fs, match);
-
- /* then try to load the font into FT */
- if (fs) {
- int j = 0, index = 0;
- while (j < fs->nfont) {
- /* find the font file + face index and use it with FreeType */
- if (FcPatternGetString (fs->fonts[j], FC_FILE, 0, &file)
- == FcResultMatch &&
- FcPatternGetInteger(fs->fonts[j], FC_INDEX, 0, &index)
- == FcResultMatch) {
- FT_Face face;
- if (!ft_library && FT_Init_FreeType(&ft_library)) {
- FcFontSetDestroy (fs);
- return NULL;
- }
- /* some FreeType versions have broken index support,
- fall back to index 0 */
- if (!FT_New_Face(ft_library,
- (const char *) file, index, &face) ||
- (index && !FT_New_Face(ft_library,
- (const char *) file, 0, &face))) {
- FcFontSetDestroy (fs);
-
-#ifdef __APPLE__
- /* FreeType is broken on OS X in that face index
- is often wrong (unfortunately even for Helvetica!)
- - we try to find the best match through enumeration.
- And italic and bold are swapped */
- if (style == 2) style = 1; else if (style == 1) style = 2;
- if (face->num_faces > 1 &&
- (face->style_flags & 3) != style) {
- FT_Face alt_face;
- int i = 0;
- while (i < face->num_faces)
- if (!FT_New_Face(ft_library,
- (const char *) file,
- i++, &alt_face)) {
- if ((alt_face->style_flags & 3) == style) {
- FT_Done_Face(face);
- face = alt_face;
- break;
- } else FT_Done_Face(alt_face);
- }
- }
-#endif
-
- return cairo_ft_font_face_create_for_ft_face(face, FT_LOAD_DEFAULT);
- }
- }
- j++;
- }
- FcFontSetDestroy (fs);
- }
- return NULL;
-}
-
-static void FT_getFont(pGEcontext gc, pDevDesc dd, double fs)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- int face = gc->fontface;
- double size = gc->cex * gc->ps *fs;
- cairo_font_face_t *cairo_face = NULL;
- const char *family;
-#ifdef Win32
- char *times = "Times New Roman", *hv = "Arial";
-#else
- char *times = "times", *hv = "Helvetica";
-#endif
-
- if (face < 1 || face > 5) face = 1;
- family = gc->fontfamily;
- if (face == 5) {
-#ifdef Win32
- if (!*family) family = "Standard Symbols L";
-#else
- if (!*family) family = "Symbol";
-#endif
- } else {
- if (!*family) family = xd->basefontfamily;
- if (streql(family, "sans")) family = hv;
- else if (streql(family, "serif")) family = times;
- else if (streql(family, "mono")) family = "Courier";
- }
- /* check the cache first */
- cairo_face = Rc_findFont(family, face);
- if (!cairo_face) {
- cairo_face = FC_getFont(family, face - 1);
- if (!cairo_face) return; /* No message? */
- Rc_addFont(family, face, cairo_face);
- }
- cairo_set_font_face (xd->cc, cairo_face);
- /* FIXME: this should really use cairo_set_font_matrix
- if pixels are non-square on a screen device. */
- cairo_set_font_size (xd->cc, size);
-}
-
-#else
-
-static void FT_getFont(pGEcontext gc, pDevDesc dd, double fs)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- int face = gc->fontface;
- double size = gc->cex * gc->ps *fs;
- char *family;
- int slant = CAIRO_FONT_SLANT_NORMAL, wt = CAIRO_FONT_WEIGHT_NORMAL;
-#ifdef Win32
- char *times = "Times New Roman", *hv = "Arial";
-#else
- char *times = "times", *hv = "Helvetica";
-#endif
-
- if (face < 1 || face > 5) face = 1;
- if (face == 5) family = "Symbol";
- if (face == 2 || face == 4) wt = CAIRO_FONT_WEIGHT_BOLD;
- if (face == 3 || face == 4) slant = CAIRO_FONT_SLANT_ITALIC;
- if (face != 5) {
- /* This is a 'toy', remember?
- The manual recommnends the CSS2 names "serif", "sans-serif",
- "monospace" */
- char *fm = gc->fontfamily;
- if (!fm[0]) fm = xd->basefontfamily;
- if (streql(fm, "mono")) family = "courier";
- else if (streql(fm, "serif")) family = times;
- else if (streql(fm, "sans")) family = hv;
- else if (fm[0]) family = fm;
- }
-
- cairo_select_font_face (xd->cc, family, slant, wt);
- /* FIXME: this should really use cairo_set_font_matrix
- if pixels are non-square on a screen device. */
- cairo_set_font_size (xd->cc, size);
-}
-#endif
-
-static void Cairo_MetricInfo(int c, pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- cairo_text_extents_t exts;
- char str[16];
- int Unicode = mbcslocale;
-
- if (c == 0) c = 77;
- if (c < 0) {c = -c; Unicode = 1;}
-
- if (Unicode) {
- Rf_ucstoutf8(str, (unsigned int) c);
- } else {
- /* Here, we assume that c < 256 */
- str[0] = (char)c; str[1] = 0;
- }
-
- FT_getFont(gc, dd, xd->fontscale);
- cairo_text_extents(xd->cc, str, &exts);
- *ascent = -exts.y_bearing;
- *descent = exts.height + exts.y_bearing;
- *width = exts.x_advance;
-}
-
-static double Cairo_StrWidth(const char *str, pGEcontext gc, pDevDesc dd)
-{
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- cairo_text_extents_t exts;
-
- if (!utf8Valid(str)) error("invalid string in Cairo_StrWidth");
- FT_getFont(gc, dd, xd->fontscale);
- cairo_text_extents(xd->cc, str, &exts);
- return exts.x_advance;
-}
-
-static void Cairo_Text(double x, double y,
- const char *str, double rot, double hadj,
- pGEcontext gc, pDevDesc dd)
-{
- if (!utf8Valid(str)) error("invalid string in Cairo_Text");
- if (R_ALPHA(gc->col) > 0) {
- pX11Desc xd = (pX11Desc) dd->deviceSpecific;
- cairo_save(xd->cc);
- FT_getFont(gc, dd, xd->fontscale);
- cairo_move_to(xd->cc, x, y);
- if (hadj != 0.0 || rot != 0.0) {
- cairo_text_extents_t te;
- cairo_text_extents(xd->cc, str, &te);
- if (rot != 0.0) cairo_rotate(xd->cc, -rot/180.*M_PI);
- if (hadj != 0.0)
- cairo_rel_move_to(xd->cc, -te.x_advance * hadj, 0);
- }
- CairoColor(gc->col, xd);
- cairo_show_text(xd->cc, str);
- cairo_restore(xd->cc);
- }
-}
-#endif
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/chull.c b/com.oracle.truffle.r.native/library/grDevices/src/chull.c
deleted file mode 100644
index 69347dcea61f071633526d96bbcca84b937cd2b6..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/chull.c
+++ /dev/null
@@ -1,441 +0,0 @@
-/*
- * chull finds the convex hull of a set of points in the plane.
- *
- * It is based on a C translation (by f2c) of
- * ACM TOMS algorithm 523 by W. F. Eddy, vol 3 (1977), 398-403, 411-2.
- *
- * converted to double precision, output order altered
- * by B.D. Ripley, March 1999
- *
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <R_ext/Boolean.h> /* TRUE,... */
-
-static void split(int n, double *x,
- int m, int *in,
- int ii, int jj,
- int s,
- int *iabv, int *na, int *maxa,
- int *ibel, int *nb, int *maxb)
-{
-/* split() takes the m points of array x whose
- subscripts are in array in and partitions them by the
- line joining the two points in array x whose subscripts are ii and jj.
- The subscripts of the points above the line are put into array
- iabv, and the subscripts of the points below are put into array ibel.
-
- na and nb are, respectively, the number of points
- above the line and the number below.
- maxa and maxb are the subscripts for array
- x of the point furthest above the line and the point
- furthest below, respectively. if either subset is null
- the corresponding subscript (maxa or maxb) is set to zero.
-
- formal parameters
- INPUT
- n integer total number of data points
- x real array (2,n) (x,y) co-ordinates of the data
- m integer number of points in input subset
- in integer array (m) subscripts for array x of the
- points in the input subset
- ii integer subscript for array x of one point
- on the partitioning line
- jj integer subscript for array x of another
- point on the partitioning line
- s integer switch to determine output.
- refer to comments below
- OUTPUT
- iabv integer array (m) subscripts for array x of the
- points above the partitioning line
- na integer number of elements in iabv
- maxa integer subscript for array x of point
- furthest above the line.
- set to zero if na is zero
- ibel integer array (m) subscripts for array x of the
- points below the partitioning line
- nb integer number of elements in ibel
- maxb integer subscript for array x of point
- furthest below the line.
- set to zero if nb is zero
-
- if s = 2 dont save ibel,nb,maxb.
- if s =-2 dont save iabv,na,maxa.
- otherwise save everything
- if s is positive the array being partitioned is above
- the initial partitioning line.
- if it is negative, then the set of points is below.
-*/
-
- /* Local variables (=0 : -Wall) */
- double a=0, b=0, down, d1, up, xt, z;
- int i, is;
- Rboolean vert, neg_dir=0;
-
- /* Parameter adjustments */
- --x;
-
- xt = x[ii];
- /* Check to see if the line is vertical */
- vert = (x[jj] == xt);
- d1 = x[jj + n] - x[ii + n];
- if (vert) {
- neg_dir = ((s > 0 && d1 < 0.) || (s < 0 && d1 > 0.));
- } else {
- a = d1 / (x[jj] - xt);
- b = x[ii + n] - a * xt;
- }
- up = 0.; *na = 0; *maxa = 0;
- down = 0.; *nb = 0; *maxb = 0;
- for (i = 0; i < m; ++i) {
- is = in[i];
- if (vert) {
- if(neg_dir) z = xt - x[is];
- else z = x[is] - xt;
- } else {
- z = x[is + n] - a * x[is] - b;
- }
- if (z > 0.) { /* the point is ABOVE the line */
- if (s == -2) continue;
- iabv[*na] = is;
- ++(*na);
- if (z >= up) {
- up = z;
- *maxa = *na;
- }
- }
- else if (s != 2 && z < 0.) { /* the point is BELOW the line */
- ibel[*nb] = is;
- ++(*nb);
- if (z <= down) {
- down = z;
- *maxb = *nb;
- }
- }
- }
-}
-
-static void in_chull(int *n, double *x, int *m, int *in,
- int *ia, int *ib, int *ih, int *nh, int *il)
-{
-/* this subroutine determines which of the m points of array
- x whose subscripts are in array in are vertices of the
- minimum area convex polygon containing the m points. the
- subscripts of the vertices are placed in array ih in the
- order they are found. nh is the number of elements in
- array ih and array il. array il is a linked list giving
- the order of the elements of array ih in a counter
- clockwise direction. this algorithm corresponds to a
- preorder traversal of a certain binary tree. each vertex
- of the binary tree represents a subset of the m points.
- at each step the subset of points corresponding to the
- current vertex of the tree is partitioned by a line
- joining two vertices of the convex polygon. the left son
- vertex in the binary tree represents the subset of points
- above the partitioning line and the right son vertex, the
- subset below the line. the leaves of the tree represent
- either null subsets or subsets inside a triangle whose
- vertices coincide with vertices of the convex polygon.
-
- formal parameters
- INPUT
- n integer total number of data points (= nrow(x))
- x real array (2,n) (x,y) co-ordinates of the data
- m integer number of points in the input subset
- in integer array (m) subscripts for array x of the points
- in the input subset
- work area
- ia integer array (m) subscripts for array x of left son subsets.
- see comments after dimension statements
- ib integer array (m) subscripts for array x of right son subsets
-
- OUTPUT
- ih integer array (m) subscripts for array x of the
- vertices of the convex hull
- nh integer number of elements in arrays ih and il.
- == number of vertices of the convex polygon
- il is used internally here.
- il integer array (m) a linked list giving in order in a
- counter-clockwise direction the
- elements of array ih
- the upper end of array ia is used to store temporarily
- the sizes of the subsets which correspond to right son
- vertices, while traversing down the left sons when on the
- left half of the tree, and to store the sizes of the left
- sons while traversing the right sons(down the right half)
- */
-#define y(k) x[k + x_dim1]
-
- Rboolean mine, maxe;
- int i, j, ilinh, ma, mb, kn, mm, kx, mx, mp1, mbb, nia, nib,
- inh, min, mxa, mxb, mxbb;
- int x_dim1, x_offset;
- double d1;
-
- /* Parameter adjustments */
- x_dim1 = *n;
- x_offset = 1;
- x -= x_offset;
- --il;
- --ih;
- --ib;
- --ia;
- --in;
-
- if (*m == 1) {
- goto L_1pt;
- }
- il[1] = 2;
- il[2] = 1;
- kn = in[1];
- kx = in[2];
- if (*m == 2) {
- goto L_2pts;
- }
- mp1 = *m + 1;
- min = 1;
- mx = 1;
- kx = in[1];
- maxe = FALSE;
- mine = FALSE;
- /* find two vertices of the convex hull for the initial partition */
- for (i = 2; i <= *m; ++i) {
- j = in[i];
- if ((d1 = x[j] - x[kx]) < 0.) {
- } else if (d1 == 0) {
- maxe = TRUE;
- } else {
- maxe = FALSE;
- mx = i;
- kx = j;
- }
- if ((d1 = x[j] - x[kn]) < 0.) {
- mine = FALSE;
- min = i;
- kn = j;
- } else if (d1 == 0) {
- mine = TRUE;
- }
- }
-
- if (kx == kn) { /* if the max and min are equal,
- * all m points lie on a vertical line */
- goto L_vertical;
- }
-
- if (maxe || mine) {/* if maxe (or mine) is TRUE, there are several
- maxima (or minima) with equal first coordinates */
-
- if (maxe) {/* have several points with the (same) largest x[] */
- for (i = 1; i <= *m; ++i) {
- j = in[i];
- if (x[j] != x[kx]) continue;
- if (y(j) <= y(kx)) continue;
- mx = i;
- kx = j;
- }
- }
-
- if (mine) {/* have several points with the (same) smallest x[] */
- for (i = 1; i <= *m; ++i) {
- j = in[i];
- if (x[j] != x[kn]) continue;
- if (y(j) >= y(kn)) continue;
- min = i;
- kn = j;
- }
- }
-
- }
-
-/* L7:*/
- ih[1] = kx;
- ih[2] = kn;
- *nh = 3;
- inh = 1;
- nib = 1;
- ma = *m;
- in[mx] = in[*m];
- in[*m] = kx;
- mm = *m - 2;
- if (min == *m) {
- min = mx;
- }
- in[min] = in[*m - 1];
- in[*m - 1] = kn;
-/* begin by partitioning the root of the tree */
- split(*n, &x[x_offset], mm, &in[1],
- ih[1], ih[2],
- 0,
- &ia[1], &mb, &mxa,
- &ib[1], &ia[ma], &mxbb);
-
-/* first traverse the LEFT HALF of the tree */
-
-/* start with the left son */
- L8:
- nib += ia[ma];
- --ma;
- do {
- if (mxa != 0) {
- il[*nh] = il[inh];
- il[inh] = *nh;
- ih[*nh] = ia[mxa];
- ia[mxa] = ia[mb];
- --mb;
- ++(*nh);
- if (mb != 0) {
- ilinh = il[inh];
- split(*n, &x[x_offset], mb, &ia[1],
- ih[inh], ih[ilinh],
- 1,
- &ia[1], &mbb, &mxa,
- &ib[nib], &ia[ma], &mxb);
- mb = mbb;
- goto L8;
- }
-/* then the right son */
- inh = il[inh];
- }
-
- do {
- inh = il[inh];
- ++ma;
- nib -= ia[ma];
- if (ma >= *m) goto L12;
- } while(ia[ma] == 0);
- ilinh = il[inh];
-/* on the left side of the tree, the right son of a right son */
-/* must represent a subset of points which is inside a */
-/* triangle with vertices which are also vertices of the */
-/* convex polygon and hence the subset may be neglected. */
- split(*n, &x[x_offset], ia[ma], &ib[nib],
- ih[inh], ih[ilinh],
- 2,
- &ia[1], &mb, &mxa,
- &ib[nib], &mbb, &mxb);
- ia[ma] = mbb;
- } while(TRUE);
-
-/* now traverse the RIGHT HALF of the tree */
- L12:
- mxb = mxbb;
- ma = *m;
- mb = ia[ma];
- nia = 1;
- ia[ma] = 0;
-/* start with the right son */
- L13:
- nia += ia[ma];
- --ma;
-
- do {
- if (mxb != 0) {
- il[*nh] = il[inh];
- il[inh] = *nh;
- ih[*nh] = ib[mxb];
- ib[mxb] = ib[mb];
- --mb;
- ++(*nh);
- if (mb != 0) {
- ilinh = il[inh];
- split(*n, &x[x_offset], mb, &ib[nib],
- ih[inh], ih[ilinh],
- -1,
- &ia[nia], &ia[ma], &mxa,
- &ib[nib], &mbb, &mxb);
- mb = mbb;
- goto L13;
- }
-
-/* then the left son */
- inh = il[inh];
- }
-
- do {
- inh = il[inh];
- ++ma;
- nia -= ia[ma];
- if (ma == mp1) goto Finis;
- } while(ia[ma] == 0);
- ilinh = il[inh];
-/* on the right side of the tree, the left son of a left son */
-/* must represent a subset of points which is inside a */
-/* triangle with vertices which are also vertices of the */
-/* convex polygon and hence the subset may be neglected. */
- split(*n, &x[x_offset], ia[ma], &ia[nia],
- ih[inh], ih[ilinh],
- -2,
- &ia[nia], &mbb, &mxa,
- &ib[nib], &mb, &mxb);
- } while(TRUE);
-
-/* -------------------------------------------------------------- */
-
- L_vertical:/* all the points lie on a vertical line */
-
- kx = in[1];
- kn = in[1];
- for (i = 1; i <= *m; ++i) {
- j = in[i];
- if (y(j) > y(kx)) {
- mx = i;
- kx = j;
- }
- if (y(j) < y(kn)) {
- min = i;
- kn = j;
- }
- }
- if (kx == kn) goto L_1pt;
-
- L_2pts:/* only two points */
- ih[1] = kx;
- ih[2] = kn;
- if (x[kn] == x[kx] && y(kn) == y(kx))
- *nh = 2;
- else
- *nh = 3;
- goto Finis;
-
- L_1pt:/* only one point */
- *nh = 2;
- ih[1] = in[1];
- il[1] = 1;
-
- Finis:
- --(*nh);
- /* put the results in order, as given by IH */
- for (i = 1; i <= *nh; ++i) {
- ia[i] = ih[i];
- }
- j = il[1];
- for (i = 2; i <= *nh; ++i) {
- ih[i] = ia[j];
- j = il[j];
- }
- return;
-
-#undef y
-} /* chull */
-
-#include <Rinternals.h>
-SEXP chull(SEXP x)
-{
- // x is a two-column matrix
- int n = nrows(x), nh;
- int *in = (int*)R_alloc(n, sizeof(int));
- for (int i = 0; i < n; i++) in[i] = i+1;
- int *ih = (int*)R_alloc(4*n, sizeof(int));
- x = PROTECT(coerceVector(x, REALSXP));
- if(TYPEOF(x) != REALSXP) error("'x' is not numeric");
- in_chull(&n, REAL(x), &n, in, ih+n, ih+2*n, ih, &nh, ih+3*n);
- SEXP ans = allocVector(INTSXP, nh);
- int *ians = INTEGER(ans);
- for (int i = 0; i < nh; i++) ians[i] = ih[nh - 1 -i];
- UNPROTECT(1);
- return ans;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/colors.c b/com.oracle.truffle.r.native/library/grDevices/src/colors.c
deleted file mode 100644
index 376223e1e4bfe58847c71933c6de020964208163..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/colors.c
+++ /dev/null
@@ -1,1583 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1997-2014 The R Core Team
- * Copyright (C) 2003 The R Foundation
- *
- * 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/
- */
-
-/* This should be regarded as part of the graphics engine */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-#include <R_ext/GraphicsEngine.h>
-
-#include "grDevices.h"
-
-static char ColBuf[10];
-static char HexDigits[] = "0123456789ABCDEF";
-
-static
-char *RGB2rgb(unsigned int r, unsigned int g, unsigned int b)
-{
- ColBuf[0] = '#';
- ColBuf[1] = HexDigits[(r >> 4) & 15];
- ColBuf[2] = HexDigits[r & 15];
- ColBuf[3] = HexDigits[(g >> 4) & 15];
- ColBuf[4] = HexDigits[g & 15];
- ColBuf[5] = HexDigits[(b >> 4) & 15];
- ColBuf[6] = HexDigits[b & 15];
- ColBuf[7] = '\0';
- return &ColBuf[0];
-}
-
-static
-char *RGBA2rgb(unsigned int r, unsigned int g, unsigned int b, unsigned int a)
-{
- ColBuf[0] = '#';
- ColBuf[1] = HexDigits[(r >> 4) & 15];
- ColBuf[2] = HexDigits[r & 15];
- ColBuf[3] = HexDigits[(g >> 4) & 15];
- ColBuf[4] = HexDigits[g & 15];
- ColBuf[5] = HexDigits[(b >> 4) & 15];
- ColBuf[6] = HexDigits[b & 15];
- ColBuf[7] = HexDigits[(a >> 4) & 15];
- ColBuf[8] = HexDigits[a & 15];
- ColBuf[9] = '\0';
- return &ColBuf[0];
-}
-
-
-static unsigned int ScaleColor(double x)
-{
- if (ISNA(x))
- error(_("color intensity %s, not in [0,1]"), "NA");
- if (!R_FINITE(x) || x < 0.0 || x > 1.0)
- error(_("color intensity %g, not in [0,1]"), x);
- return (unsigned int)(255*x + 0.5);
-}
-
-static unsigned int CheckColor(int x)
-{
- if (x == NA_INTEGER)
- error(_("color intensity %s, not in 0:255"), "NA");
- if (x < 0 || x > 255)
- error(_("color intensity %d, not in 0:255"), x);
- return (unsigned int)x;
-}
-
-static unsigned int ScaleAlpha(double x)
-{
- if (ISNA(x))
- error(_("alpha level %s, not in [0,1]"), "NA");
- if (!R_FINITE(x) || x < 0.0 || x > 1.0)
- error(_("alpha level %g, not in [0,1]"), x);
- return (unsigned int)(255*x + 0.5);
-}
-
-static unsigned int CheckAlpha(int x)
-{
- if (x == NA_INTEGER)
- error(_("alpha level %s, not in 0:255"), "NA");
- if (x < 0 || x > 255)
- error(_("alpha level %d, not in 0:255"), x);
- return (unsigned int)x;
-}
-
-/* hsv2rgb -- HSV to RGB conversion */
-/* Based on HSV_TO_RGB from Foley and Van Dam First Ed. Page 616 */
-/* See Alvy Ray Smith, Color Gamut Transform Pairs, SIGGRAPH '78 */
-
-static void hsv2rgb(double h, double s, double v,
- double *r, double *g, double *b)
-{
- double f, p, q, t;
- int i;
-
- f = modf(h * 6.0, &t);
- i = ((int) t) % 6;
-
- p = v * (1 - s);
- q = v * (1 - s * f);
- t = v * (1 - (s * (1 - f)));
- switch (i) {
- case 0: *r = v; *g = t; *b = p; break;
- case 1: *r = q; *g = v; *b = p; break;
- case 2: *r = p; *g = v; *b = t; break;
- case 3: *r = p; *g = q; *b = v; break;
- case 4: *r = t; *g = p; *b = v; break;
- case 5: *r = v; *g = p; *b = q; break;
- default:
- error(_("bad hsv to rgb color conversion"));
- }
-}
-
-/* rgb2hsv() -- the reverse (same reference as above)
- * this implementation is adapted from code by Nicholas Lewin-Koh.
- */
-static void rgb2hsv(double r, double g, double b,
- double *h, double *s, double *v)
- /* all (r,g,b, h,s,v) values in [0,1] */
-{
- double min, max, delta;
- Rboolean r_max = TRUE, b_max = FALSE;
- /* Compute min(r,g,b) and max(r,g,b) and remember where max is: */
- min = max = r;
- if(min > g) { /* g < r */
- if(b < g)
- min = b;/* & max = r */
- else { /* g <= b, g < r */
- min = g;
- if(b > r) { max = b; b_max = TRUE; r_max = FALSE; }
- /* else : g <= b <=r */
- }
- } else { /* r <= g */
- if(b > g) {
- max = b; b_max = TRUE; r_max = FALSE; /* & min = r */
- } else { /* b,r <= g */
- max = g; r_max = FALSE; /* & min = r */
- if(b < r) min = b; /* else : r <= b <= g */
- }
- }
-
- *v = max;
- if( max == 0 || (delta = max - min) == 0) {
- /* r = g = b : "gray" : s = h = 0 */
- *s = *h = 0;
- return;
- }
- /* else : */
- *s = delta / max;
-
- if(r_max)
- *h = ( g - b ) / delta; /* between yellow & magenta */
- else if(b_max)
- *h = 4 + ( r - g ) / delta; /* between magenta & cyan */
- else /* g == max */
- *h = 2 + ( b - r ) / delta; /* between cyan & yellow*/
-
- *h /= 6;
- if(*h < 0)
- *h += 1.;
- return;
-}
-
-
-SEXP hsv(SEXP h, SEXP s, SEXP v, SEXP a)
-{
- double hh, ss, vv, aa, r=0., g=0., b=0.; /* -Wall */
- R_xlen_t i, max, nh, ns, nv, na = 1;
-
- PROTECT(h = coerceVector(h,REALSXP));
- PROTECT(s = coerceVector(s,REALSXP));
- PROTECT(v = coerceVector(v,REALSXP));
- if (!isNull(a)) {
- a = coerceVector(a, REALSXP);
- na = XLENGTH(a);
- }
- PROTECT(a);
-
- nh = XLENGTH(h);
- ns = XLENGTH(s);
- nv = XLENGTH(v);
- if (nh <= 0 || ns <= 0 || nv <= 0 || na <= 0) {
- UNPROTECT(4);
- return allocVector(STRSXP, 0);
- }
- max = nh;
- if (max < ns) max = ns;
- if (max < nv) max = nv;
- if (max < na) max = na;
- SEXP c = PROTECT(allocVector(STRSXP, max));
- if(max == 0) return(c);
-
- if(isNull(a)) {
- for (i = 0; i < max; i++) {
- hh = REAL(h)[i % nh];
- ss = REAL(s)[i % ns];
- vv = REAL(v)[i % nv];
- if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1)
- error(_("invalid hsv color"));
- hsv2rgb(hh, ss, vv, &r, &g, &b);
- SET_STRING_ELT(c, i, mkChar(RGB2rgb(ScaleColor(r), ScaleColor(g),
- ScaleColor(b))));
-
- }
- } else {
- for (i = 0; i < max; i++) {
- hh = REAL(h)[i % nh];
- ss = REAL(s)[i % ns];
- vv = REAL(v)[i % nv];
- aa = REAL(a)[i % na];
- if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
- aa < 0 || aa > 1)
- error(_("invalid hsv color"));
- hsv2rgb(hh, ss, vv, &r, &g, &b);
- SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r), ScaleColor(g),
- ScaleColor(b), ScaleAlpha(aa))));
- }
- }
- UNPROTECT(5);
- return c;
-}
-
-/* D65 White Point */
-
-#define WHITE_X 95.047
-#define WHITE_Y 100.000
-#define WHITE_Z 108.883
-#define WHITE_u 0.1978398
-#define WHITE_v 0.4683363
-
-/* Standard CRT Gamma */
-
-#define GAMMA 2.4
-
-static double gtrans(double u)
-{
- if (u > 0.00304)
- return 1.055 * pow(u, (1 / GAMMA)) - 0.055;
- else
- return 12.92 * u;
-}
-
-static int FixupColor(int *r, int *g, int *b)
-{
- int fix = 0;
- if (*r < 0) { *r = 0; fix = 1; } else if (*r > 255) { *r = 255; fix = 1; }
- if (*g < 0) { *g = 0; fix = 1; } else if (*g > 255) { *g = 255; fix = 1; }
- if (*b < 0) { *b = 0; fix = 1; } else if (*b > 255) { *b = 255; fix = 1; }
- return fix;
-}
-
-static void
-hcl2rgb(double h, double c, double l, double *R, double *G, double *B)
-{
- if (l <= 0.0) {
- *R = *G = *B = 0.0;
- return;
- }
- double L, U, V;
- double u, v;
- double X, Y, Z;
-
- /* Step 1 : Convert to CIE-LUV */
-
- h = DEG2RAD * h;
- L = l;
- U = c * cos(h);
- V = c * sin(h);
-
- /* Step 2 : Convert to CIE-XYZ */
-
- if (L <= 0 && U == 0 && V == 0) {
- X = 0; Y = 0; Z = 0;
- }
- else {
- Y = WHITE_Y * ((L > 7.999592) ? pow((L + 16)/116, 3) : L / 903.3);
- u = U / (13 * L) + WHITE_u;
- v = V / (13 * L) + WHITE_v;
- X = 9.0 * Y * u / (4 * v);
- Z = - X / 3 - 5 * Y + 3 * Y / v;
- }
-
- /* Step 4 : CIE-XYZ to sRGB */
-
- *R = gtrans(( 3.240479 * X - 1.537150 * Y - 0.498535 * Z) / WHITE_Y);
- *G = gtrans((-0.969256 * X + 1.875992 * Y + 0.041556 * Z) / WHITE_Y);
- *B = gtrans(( 0.055648 * X - 0.204043 * Y + 1.057311 * Z) / WHITE_Y);
-}
-
-// People call this with non-finite inputs.
-SEXP hcl(SEXP h, SEXP c, SEXP l, SEXP a, SEXP sfixup)
-{
- double H, C, L, A, r, g, b;
- R_xlen_t nh, nc, nl, na = 1, max, i;
- int ir, ig, ib;
- int fixup;
-
- PROTECT(h = coerceVector(h, REALSXP));
- PROTECT(c = coerceVector(c, REALSXP));
- PROTECT(l = coerceVector(l, REALSXP));
- if (!isNull(a)) {
- a = coerceVector(a, REALSXP);
- na = XLENGTH(a);
- }
- PROTECT(a);
- fixup = asLogical(sfixup);
- nh = XLENGTH(h);
- nc = XLENGTH(c);
- nl = XLENGTH(l);
- if (nh <= 0 || nc <= 0 || nl <= 0 || na <= 0) {
- UNPROTECT(4);
- return(allocVector(STRSXP, 0));
- }
- max = nh;
- if (max < nc) max = nc;
- if (max < nl) max = nl;
- if (max < na) max = na;
- SEXP ans = PROTECT(allocVector(STRSXP, max));
- if (isNull(a)) {
- for (i = 0; i < max; i++) {
- H = REAL(h)[i % nh];
- C = REAL(c)[i % nc];
- L = REAL(l)[i % nl];
- if (R_FINITE(H) && R_FINITE(C) && R_FINITE(L)) {
- if (L < 0 || L > WHITE_Y || C < 0) error(_("invalid hcl color"));
- hcl2rgb(H, C, L, &r, &g, &b);
- ir = (int) (255 * r + .5);
- ig = (int) (255 * g + .5);
- ib = (int) (255 * b + .5);
- if (FixupColor(&ir, &ig, &ib) && !fixup)
- SET_STRING_ELT(ans, i, NA_STRING);
- else
- SET_STRING_ELT(ans, i, mkChar(RGB2rgb(ir, ig, ib)));
- } else SET_STRING_ELT(ans, i, NA_STRING);
- }
- } else {
- for (i = 0; i < max; i++) {
- H = REAL(h)[i % nh];
- C = REAL(c)[i % nc];
- L = REAL(l)[i % nl];
- A = REAL(a)[i % na];
- if (!R_FINITE(A)) A = 1;
- if (R_FINITE(H) && R_FINITE(C) && R_FINITE(L)) {
- if (L < 0 || L > WHITE_Y || C < 0 || A < 0 || A > 1)
- error(_("invalid hcl color"));
- hcl2rgb(H, C, L, &r, &g, &b);
- ir = (int) (255 * r + .5);
- ig = (int) (255 * g + .5);
- ib = (int) (255 * b + .5);
- if (FixupColor(&ir, &ig, &ib) && !fixup)
- SET_STRING_ELT(ans, i, NA_STRING);
- else
- SET_STRING_ELT(ans, i, mkChar(RGBA2rgb(ir, ig, ib,
- ScaleAlpha(A))));
- } else SET_STRING_ELT(ans, i, NA_STRING);
- }
- }
- UNPROTECT(5);
- return ans;
-}
-
-#define _R_set_c_RGB(_R,_G,_B) \
- { for (i = 0; i < l_max; i++) \
- SET_STRING_ELT(c, i, mkChar(RGB2rgb(_R,_G,_B))); }
-
-#define _R_set_c_RGBA(_R,_G,_B,_A) \
- { for (i = 0; i < l_max; i++) \
- SET_STRING_ELT(c, i, mkChar(RGBA2rgb(_R,_G,_B,_A))); }
-
-SEXP rgb(SEXP r, SEXP g, SEXP b, SEXP a, SEXP MCV, SEXP nam)
-{
- R_xlen_t i, l_max, nr, ng, nb, na = 1;
- Rboolean max_1 = FALSE;
- double mV = asReal(MCV);
-
- if(!R_FINITE(mV) || mV == 0.)
- error(_("invalid value of 'maxColorValue'"));
- if(mV == 255.) {
- PROTECT(r = coerceVector(r, INTSXP));
- PROTECT(g = coerceVector(g, INTSXP));
- PROTECT(b = coerceVector(b, INTSXP));
- if(!isNull(a)) a = coerceVector(a, INTSXP);
- } else {
- PROTECT(r = coerceVector(r, REALSXP));
- PROTECT(g = coerceVector(g, REALSXP));
- PROTECT(b = coerceVector(b, REALSXP));
- if(!isNull(a)) a = coerceVector(a, REALSXP);
- max_1 = (mV == 1.);
- }
- PROTECT(a);
-
- nr = XLENGTH(r); ng = XLENGTH(g); nb = XLENGTH(b);
- if (!isNull(a)) na = XLENGTH(a);
- if (nr <= 0 || ng <= 0 || nb <= 0 || na <= 0) {
- UNPROTECT(4);
- return allocVector(STRSXP, 0);
- }
- l_max = nr;
- if (l_max < ng) l_max = ng;
- if (l_max < nb) l_max = nb;
- if (l_max < na) l_max = na;
-
- PROTECT(nam = coerceVector(nam, STRSXP));
- if (length(nam) != 0 && length(nam) != l_max)
- error(_("invalid 'names' vector"));
- SEXP c = PROTECT(allocVector(STRSXP, l_max));
-
- if(mV == 255.0) {
- if(isNull(a)) {
- _R_set_c_RGB(CheckColor(INTEGER(r)[i%nr]),
- CheckColor(INTEGER(g)[i%ng]),
- CheckColor(INTEGER(b)[i%nb]));
- } else {
- _R_set_c_RGBA(CheckColor(INTEGER(r)[i%nr]),
- CheckColor(INTEGER(g)[i%ng]),
- CheckColor(INTEGER(b)[i%nb]),
- CheckAlpha(INTEGER(a)[i%na]));
- }
- }
- else if(max_1) {
- if(isNull(a)) {
- _R_set_c_RGB(ScaleColor(REAL(r)[i%nr]),
- ScaleColor(REAL(g)[i%ng]),
- ScaleColor(REAL(b)[i%nb]));
- } else {
- _R_set_c_RGBA(ScaleColor(REAL(r)[i%nr]),
- ScaleColor(REAL(g)[i%ng]),
- ScaleColor(REAL(b)[i%nb]),
- ScaleAlpha(REAL(a)[i%na]));
- }
- }
- else { /* maxColorVal not in {1, 255} */
- if(isNull(a)) {
- _R_set_c_RGB(ScaleColor(REAL(r)[i%nr] / mV),
- ScaleColor(REAL(g)[i%ng] / mV),
- ScaleColor(REAL(b)[i%nb] / mV));
- } else {
- _R_set_c_RGBA(ScaleColor(REAL(r)[i%nr] / mV),
- ScaleColor(REAL(g)[i%ng] / mV),
- ScaleColor(REAL(b)[i%nb] / mV),
- ScaleAlpha(REAL(a)[i%na] / mV));
- }
- }
- if (length(nam) != 0) setAttrib(c, R_NamesSymbol, nam);
- UNPROTECT(6);
- return c;
-}
-
-SEXP gray(SEXP lev, SEXP a)
-{
- SEXP ans;
- double level;
- int i, ilevel, nlev;
-
- lev = PROTECT(coerceVector(lev,REALSXP));
- if(!isNull(a)) a = coerceVector(a,REALSXP);
- PROTECT(a);
- nlev = LENGTH(lev);
- PROTECT(ans = allocVector(STRSXP, nlev));
- if(isNull(a)) {
- for (i = 0; i < nlev; i++) {
- level = REAL(lev)[i];
- if (ISNAN(level) || level < 0 || level > 1)
- error(_("invalid gray level, must be in [0,1]."));
- ilevel = (int)(255 * level + 0.5);
- SET_STRING_ELT(ans, i, mkChar(RGB2rgb(ilevel, ilevel, ilevel)));
- }
- } else {
- int na = length(a);
- for (i = 0; i < (nlev > na ? nlev : na); i++) {
- level = REAL(lev)[i % nlev];
- if (ISNAN(level) || level < 0 || level > 1)
- error(_("invalid gray level, must be in [0,1]."));
- ilevel = (int)(255 * level + 0.5);
- double aa = REAL(a)[i % na];
- SET_STRING_ELT(ans, i, mkChar(RGBA2rgb(ilevel, ilevel, ilevel,
- ScaleAlpha(aa))));
- }
- }
- UNPROTECT(3);
- return ans;
-}
-
-
-
-
-
-SEXP RGB2hsv(SEXP rgb)
-{
-/* (r,g,b) -> (h,s,v) conversion */
- SEXP dd, ans, names, dmns;
- int n, i, i3;
-
- rgb = PROTECT(coerceVector(rgb, REALSXP));
- if(!isMatrix(rgb)) error("rgb is not a matrix (internally)");
- dd = getAttrib(rgb, R_DimSymbol);
- if(INTEGER(dd)[0] != 3) error("rgb must have 3 rows (internally)");
- n = INTEGER(dd)[1];
-
- ans = PROTECT(allocMatrix(REALSXP, 3, n));
- PROTECT(dmns = allocVector(VECSXP, 2));
- /* row names: */
- PROTECT(names = allocVector(STRSXP, 3));
- SET_STRING_ELT(names, 0, mkChar("h"));
- SET_STRING_ELT(names, 1, mkChar("s"));
- SET_STRING_ELT(names, 2, mkChar("v"));
- SET_VECTOR_ELT(dmns, 0, names);
- /* column names if input has: */
- if ((dd = getAttrib(rgb, R_DimNamesSymbol)) != R_NilValue &&
- (names = VECTOR_ELT(dd, 1)) != R_NilValue)
- SET_VECTOR_ELT(dmns, 1, names);
- setAttrib(ans, R_DimNamesSymbol, dmns);
- UNPROTECT(2);/* names, dmns */
-
- for(i = i3 = 0; i < n; i++, i3 += 3) {
- rgb2hsv(REAL(rgb)[i3+ 0], REAL(rgb)[i3+ 1], REAL(rgb)[i3+ 2],
- &REAL(ans)[i3+ 0], &REAL(ans)[i3+ 1], &REAL(ans)[i3 +2]);
- }
- UNPROTECT(2);
- return ans;
-}
-
-
-SEXP col2rgb(SEXP colors, SEXP alpha)
-{
- SEXP ans, names, dmns;
-
- int alph = asLogical(alpha);
- if(alph == NA_LOGICAL) error(_("invalid '%s' value"), "alpha");
- switch(TYPEOF(colors)) {
- case INTSXP:
- case STRSXP:
- break;
- case REALSXP:
- colors = coerceVector(colors, INTSXP);
- break;
- default:
- colors = coerceVector(colors, STRSXP);
- break;
- }
- PROTECT(colors);
- int n = LENGTH(colors);
-
- /* First set up the output matrix */
- PROTECT(ans = allocMatrix(INTSXP, 3+alph, n));
- PROTECT(dmns = allocVector(VECSXP, 2));
- PROTECT(names = allocVector(STRSXP, 3+alph));
- SET_STRING_ELT(names, 0, mkChar("red"));
- SET_STRING_ELT(names, 1, mkChar("green"));
- SET_STRING_ELT(names, 2, mkChar("blue"));
- if(alph) SET_STRING_ELT(names, 3, mkChar("alpha"));
- SET_VECTOR_ELT(dmns, 0, names);
- if ((names = getAttrib(colors, R_NamesSymbol)) != R_NilValue)
- SET_VECTOR_ELT(dmns, 1, names);
- setAttrib(ans, R_DimNamesSymbol, dmns);
-
- for(int i = 0, j = 0; i < n; i++) {
- rcolor icol = inRGBpar3(colors, i, R_TRANWHITE);
- INTEGER(ans)[j++] = R_RED(icol);
- INTEGER(ans)[j++] = R_GREEN(icol);
- INTEGER(ans)[j++] = R_BLUE(icol);
- if(alph) INTEGER(ans)[j++] = R_ALPHA(icol);
- }
- UNPROTECT(4);
- return ans;
-}
-
-
-// ------------------ code for tables to export to main executable --------
-
-#include <ctype.h> /* for tolower, isdigit */
-
-#define MAX_PALETTE_SIZE 1024
-static int PaletteSize = 8;
-static rcolor Palette[MAX_PALETTE_SIZE] = {
- 0xff000000,
- 0xff0000ff,
- 0xff00cd00,
- 0xffff0000,
- 0xffffff00,
- 0xffff00ff,
- 0xff00ffff,
- 0xffbebebe
-};
-
-static rcolor Palette0[MAX_PALETTE_SIZE];
-
-
-/* String comparison ignoring case and squeezing out blanks */
-static int StrMatch(const char *s, const char *t)
-{
- for(;;) {
- if(*s == '\0' && *t == '\0') return 1;
- if(*s == ' ') { s++; continue; }
- if(*t == ' ') { t++; continue; }
- if(tolower(*s++) != tolower(*t++)) return 0;
- }
-}
-
-
-/*
- * Color Specification
- *
- * Colors are stored internally in integers. Each integer is
- * broken into four bytes. The three least significant bytes
- * are used to contain levels of red, green and blue. These
- * levels are integers in the range [0,255].
- *
- * Externally, colors are specified either:
- *
- * a) by name, using a large table of color names,
- *
- * b) by RGB values using a string of the form "#rrggbb"
- * where rr, gg and bb are hex integers giving the level
- * of red green and blue,
- *
- * c) as an index into a user setable palette of colors.
- *
- */
-
-/* Default Color Palette */
-/* Paul Murrell 05/06/02 (2002, probably)
- * Changed "white" to "grey" in the default palette
- * in response to user suggestion
- */
-attribute_hidden
-const char *DefaultPalette[] = {
- "black",
- "red",
- "green3",
- "blue",
- "cyan",
- "magenta",
- "yellow",
- "grey",
- NULL
-};
-
-/* The Table of Known Color Names */
-/* Adapted from the X11 RGB database */
-/* Note: the color "white" was moved to the top of the database
- to avoid its being looked up by col2name as "gray100" */
-
-typedef
-struct colorDataBaseEntry {
- char *name; // X11 Color Name
- char *rgb; // #RRGGBB String, no longer used
- rcolor code; // Internal R Color Code
-} ColorDataBaseEntry;
-
-static ColorDataBaseEntry ColorDataBase[] = {
- /* name rgb code */
- {"white", "#FFFFFF", 0xffffffff},
- {"aliceblue", "#F0F8FF", 0xfffff8f0},
- {"antiquewhite", "#FAEBD7", 0xffd7ebfa},
- {"antiquewhite1", "#FFEFDB", 0xffdbefff},
- {"antiquewhite2", "#EEDFCC", 0xffccdfee},
- {"antiquewhite3", "#CDC0B0", 0xffb0c0cd},
- {"antiquewhite4", "#8B8378", 0xff78838b},
- {"aquamarine", "#7FFFD4", 0xffd4ff7f},
- {"aquamarine1", "#7FFFD4", 0xffd4ff7f},
- {"aquamarine2", "#76EEC6", 0xffc6ee76},
- {"aquamarine3", "#66CDAA", 0xffaacd66},
- {"aquamarine4", "#458B74", 0xff748b45},
- {"azure", "#F0FFFF", 0xfffffff0},
- {"azure1", "#F0FFFF", 0xfffffff0},
- {"azure2", "#E0EEEE", 0xffeeeee0},
- {"azure3", "#C1CDCD", 0xffcdcdc1},
- {"azure4", "#838B8B", 0xff8b8b83},
- {"beige", "#F5F5DC", 0xffdcf5f5},
- {"bisque", "#FFE4C4", 0xffc4e4ff},
- {"bisque1", "#FFE4C4", 0xffc4e4ff},
- {"bisque2", "#EED5B7", 0xffb7d5ee},
- {"bisque3", "#CDB79E", 0xff9eb7cd},
- {"bisque4", "#8B7D6B", 0xff6b7d8b},
- {"black", "#000000", 0xff000000},
- {"blanchedalmond", "#FFEBCD", 0xffcdebff},
- {"blue", "#0000FF", 0xffff0000},
- {"blue1", "#0000FF", 0xffff0000},
- {"blue2", "#0000EE", 0xffee0000},
- {"blue3", "#0000CD", 0xffcd0000},
- {"blue4", "#00008B", 0xff8b0000},
- {"blueviolet", "#8A2BE2", 0xffe22b8a},
- {"brown", "#A52A2A", 0xff2a2aa5},
- {"brown1", "#FF4040", 0xff4040ff},
- {"brown2", "#EE3B3B", 0xff3b3bee},
- {"brown3", "#CD3333", 0xff3333cd},
- {"brown4", "#8B2323", 0xff23238b},
- {"burlywood", "#DEB887", 0xff87b8de},
- {"burlywood1", "#FFD39B", 0xff9bd3ff},
- {"burlywood2", "#EEC591", 0xff91c5ee},
- {"burlywood3", "#CDAA7D", 0xff7daacd},
- {"burlywood4", "#8B7355", 0xff55738b},
- {"cadetblue", "#5F9EA0", 0xffa09e5f},
- {"cadetblue1", "#98F5FF", 0xfffff598},
- {"cadetblue2", "#8EE5EE", 0xffeee58e},
- {"cadetblue3", "#7AC5CD", 0xffcdc57a},
- {"cadetblue4", "#53868B", 0xff8b8653},
- {"chartreuse", "#7FFF00", 0xff00ff7f},
- {"chartreuse1", "#7FFF00", 0xff00ff7f},
- {"chartreuse2", "#76EE00", 0xff00ee76},
- {"chartreuse3", "#66CD00", 0xff00cd66},
- {"chartreuse4", "#458B00", 0xff008b45},
- {"chocolate", "#D2691E", 0xff1e69d2},
- {"chocolate1", "#FF7F24", 0xff247fff},
- {"chocolate2", "#EE7621", 0xff2176ee},
- {"chocolate3", "#CD661D", 0xff1d66cd},
- {"chocolate4", "#8B4513", 0xff13458b},
- {"coral", "#FF7F50", 0xff507fff},
- {"coral1", "#FF7256", 0xff5672ff},
- {"coral2", "#EE6A50", 0xff506aee},
- {"coral3", "#CD5B45", 0xff455bcd},
- {"coral4", "#8B3E2F", 0xff2f3e8b},
- {"cornflowerblue", "#6495ED", 0xffed9564},
- {"cornsilk", "#FFF8DC", 0xffdcf8ff},
- {"cornsilk1", "#FFF8DC", 0xffdcf8ff},
- {"cornsilk2", "#EEE8CD", 0xffcde8ee},
- {"cornsilk3", "#CDC8B1", 0xffb1c8cd},
- {"cornsilk4", "#8B8878", 0xff78888b},
- {"cyan", "#00FFFF", 0xffffff00},
- {"cyan1", "#00FFFF", 0xffffff00},
- {"cyan2", "#00EEEE", 0xffeeee00},
- {"cyan3", "#00CDCD", 0xffcdcd00},
- {"cyan4", "#008B8B", 0xff8b8b00},
- {"darkblue", "#00008B", 0xff8b0000},
- {"darkcyan", "#008B8B", 0xff8b8b00},
- {"darkgoldenrod", "#B8860B", 0xff0b86b8},
- {"darkgoldenrod1", "#FFB90F", 0xff0fb9ff},
- {"darkgoldenrod2", "#EEAD0E", 0xff0eadee},
- {"darkgoldenrod3", "#CD950C", 0xff0c95cd},
- {"darkgoldenrod4", "#8B6508", 0xff08658b},
- {"darkgray", "#A9A9A9", 0xffa9a9a9},
- {"darkgreen", "#006400", 0xff006400},
- {"darkgrey", "#A9A9A9", 0xffa9a9a9},
- {"darkkhaki", "#BDB76B", 0xff6bb7bd},
- {"darkmagenta", "#8B008B", 0xff8b008b},
- {"darkolivegreen", "#556B2F", 0xff2f6b55},
- {"darkolivegreen1", "#CAFF70", 0xff70ffca},
- {"darkolivegreen2", "#BCEE68", 0xff68eebc},
- {"darkolivegreen3", "#A2CD5A", 0xff5acda2},
- {"darkolivegreen4", "#6E8B3D", 0xff3d8b6e},
- {"darkorange", "#FF8C00", 0xff008cff},
- {"darkorange1", "#FF7F00", 0xff007fff},
- {"darkorange2", "#EE7600", 0xff0076ee},
- {"darkorange3", "#CD6600", 0xff0066cd},
- {"darkorange4", "#8B4500", 0xff00458b},
- {"darkorchid", "#9932CC", 0xffcc3299},
- {"darkorchid1", "#BF3EFF", 0xffff3ebf},
- {"darkorchid2", "#B23AEE", 0xffee3ab2},
- {"darkorchid3", "#9A32CD", 0xffcd329a},
- {"darkorchid4", "#68228B", 0xff8b2268},
- {"darkred", "#8B0000", 0xff00008b},
- {"darksalmon", "#E9967A", 0xff7a96e9},
- {"darkseagreen", "#8FBC8F", 0xff8fbc8f},
- {"darkseagreen1", "#C1FFC1", 0xffc1ffc1},
- {"darkseagreen2", "#B4EEB4", 0xffb4eeb4},
- {"darkseagreen3", "#9BCD9B", 0xff9bcd9b},
- {"darkseagreen4", "#698B69", 0xff698b69},
- {"darkslateblue", "#483D8B", 0xff8b3d48},
- {"darkslategray", "#2F4F4F", 0xff4f4f2f},
- {"darkslategray1", "#97FFFF", 0xffffff97},
- {"darkslategray2", "#8DEEEE", 0xffeeee8d},
- {"darkslategray3", "#79CDCD", 0xffcdcd79},
- {"darkslategray4", "#528B8B", 0xff8b8b52},
- {"darkslategrey", "#2F4F4F", 0xff4f4f2f},
- {"darkturquoise", "#00CED1", 0xffd1ce00},
- {"darkviolet", "#9400D3", 0xffd30094},
- {"deeppink", "#FF1493", 0xff9314ff},
- {"deeppink1", "#FF1493", 0xff9314ff},
- {"deeppink2", "#EE1289", 0xff8912ee},
- {"deeppink3", "#CD1076", 0xff7610cd},
- {"deeppink4", "#8B0A50", 0xff500a8b},
- {"deepskyblue", "#00BFFF", 0xffffbf00},
- {"deepskyblue1", "#00BFFF", 0xffffbf00},
- {"deepskyblue2", "#00B2EE", 0xffeeb200},
- {"deepskyblue3", "#009ACD", 0xffcd9a00},
- {"deepskyblue4", "#00688B", 0xff8b6800},
- {"dimgray", "#696969", 0xff696969},
- {"dimgrey", "#696969", 0xff696969},
- {"dodgerblue", "#1E90FF", 0xffff901e},
- {"dodgerblue1", "#1E90FF", 0xffff901e},
- {"dodgerblue2", "#1C86EE", 0xffee861c},
- {"dodgerblue3", "#1874CD", 0xffcd7418},
- {"dodgerblue4", "#104E8B", 0xff8b4e10},
- {"firebrick", "#B22222", 0xff2222b2},
- {"firebrick1", "#FF3030", 0xff3030ff},
- {"firebrick2", "#EE2C2C", 0xff2c2cee},
- {"firebrick3", "#CD2626", 0xff2626cd},
- {"firebrick4", "#8B1A1A", 0xff1a1a8b},
- {"floralwhite", "#FFFAF0", 0xfff0faff},
- {"forestgreen", "#228B22", 0xff228b22},
- {"gainsboro", "#DCDCDC", 0xffdcdcdc},
- {"ghostwhite", "#F8F8FF", 0xfffff8f8},
- {"gold", "#FFD700", 0xff00d7ff},
- {"gold1", "#FFD700", 0xff00d7ff},
- {"gold2", "#EEC900", 0xff00c9ee},
- {"gold3", "#CDAD00", 0xff00adcd},
- {"gold4", "#8B7500", 0xff00758b},
- {"goldenrod", "#DAA520", 0xff20a5da},
- {"goldenrod1", "#FFC125", 0xff25c1ff},
- {"goldenrod2", "#EEB422", 0xff22b4ee},
- {"goldenrod3", "#CD9B1D", 0xff1d9bcd},
- {"goldenrod4", "#8B6914", 0xff14698b},
- {"gray", "#BEBEBE", 0xffbebebe},
- {"gray0", "#000000", 0xff000000},
- {"gray1", "#030303", 0xff030303},
- {"gray2", "#050505", 0xff050505},
- {"gray3", "#080808", 0xff080808},
- {"gray4", "#0A0A0A", 0xff0a0a0a},
- {"gray5", "#0D0D0D", 0xff0d0d0d},
- {"gray6", "#0F0F0F", 0xff0f0f0f},
- {"gray7", "#121212", 0xff121212},
- {"gray8", "#141414", 0xff141414},
- {"gray9", "#171717", 0xff171717},
- {"gray10", "#1A1A1A", 0xff1a1a1a},
- {"gray11", "#1C1C1C", 0xff1c1c1c},
- {"gray12", "#1F1F1F", 0xff1f1f1f},
- {"gray13", "#212121", 0xff212121},
- {"gray14", "#242424", 0xff242424},
- {"gray15", "#262626", 0xff262626},
- {"gray16", "#292929", 0xff292929},
- {"gray17", "#2B2B2B", 0xff2b2b2b},
- {"gray18", "#2E2E2E", 0xff2e2e2e},
- {"gray19", "#303030", 0xff303030},
- {"gray20", "#333333", 0xff333333},
- {"gray21", "#363636", 0xff363636},
- {"gray22", "#383838", 0xff383838},
- {"gray23", "#3B3B3B", 0xff3b3b3b},
- {"gray24", "#3D3D3D", 0xff3d3d3d},
- {"gray25", "#404040", 0xff404040},
- {"gray26", "#424242", 0xff424242},
- {"gray27", "#454545", 0xff454545},
- {"gray28", "#474747", 0xff474747},
- {"gray29", "#4A4A4A", 0xff4a4a4a},
- {"gray30", "#4D4D4D", 0xff4d4d4d},
- {"gray31", "#4F4F4F", 0xff4f4f4f},
- {"gray32", "#525252", 0xff525252},
- {"gray33", "#545454", 0xff545454},
- {"gray34", "#575757", 0xff575757},
- {"gray35", "#595959", 0xff595959},
- {"gray36", "#5C5C5C", 0xff5c5c5c},
- {"gray37", "#5E5E5E", 0xff5e5e5e},
- {"gray38", "#616161", 0xff616161},
- {"gray39", "#636363", 0xff636363},
- {"gray40", "#666666", 0xff666666},
- {"gray41", "#696969", 0xff696969},
- {"gray42", "#6B6B6B", 0xff6b6b6b},
- {"gray43", "#6E6E6E", 0xff6e6e6e},
- {"gray44", "#707070", 0xff707070},
- {"gray45", "#737373", 0xff737373},
- {"gray46", "#757575", 0xff757575},
- {"gray47", "#787878", 0xff787878},
- {"gray48", "#7A7A7A", 0xff7a7a7a},
- {"gray49", "#7D7D7D", 0xff7d7d7d},
- {"gray50", "#7F7F7F", 0xff7f7f7f},
- {"gray51", "#828282", 0xff828282},
- {"gray52", "#858585", 0xff858585},
- {"gray53", "#878787", 0xff878787},
- {"gray54", "#8A8A8A", 0xff8a8a8a},
- {"gray55", "#8C8C8C", 0xff8c8c8c},
- {"gray56", "#8F8F8F", 0xff8f8f8f},
- {"gray57", "#919191", 0xff919191},
- {"gray58", "#949494", 0xff949494},
- {"gray59", "#969696", 0xff969696},
- {"gray60", "#999999", 0xff999999},
- {"gray61", "#9C9C9C", 0xff9c9c9c},
- {"gray62", "#9E9E9E", 0xff9e9e9e},
- {"gray63", "#A1A1A1", 0xffa1a1a1},
- {"gray64", "#A3A3A3", 0xffa3a3a3},
- {"gray65", "#A6A6A6", 0xffa6a6a6},
- {"gray66", "#A8A8A8", 0xffa8a8a8},
- {"gray67", "#ABABAB", 0xffababab},
- {"gray68", "#ADADAD", 0xffadadad},
- {"gray69", "#B0B0B0", 0xffb0b0b0},
- {"gray70", "#B3B3B3", 0xffb3b3b3},
- {"gray71", "#B5B5B5", 0xffb5b5b5},
- {"gray72", "#B8B8B8", 0xffb8b8b8},
- {"gray73", "#BABABA", 0xffbababa},
- {"gray74", "#BDBDBD", 0xffbdbdbd},
- {"gray75", "#BFBFBF", 0xffbfbfbf},
- {"gray76", "#C2C2C2", 0xffc2c2c2},
- {"gray77", "#C4C4C4", 0xffc4c4c4},
- {"gray78", "#C7C7C7", 0xffc7c7c7},
- {"gray79", "#C9C9C9", 0xffc9c9c9},
- {"gray80", "#CCCCCC", 0xffcccccc},
- {"gray81", "#CFCFCF", 0xffcfcfcf},
- {"gray82", "#D1D1D1", 0xffd1d1d1},
- {"gray83", "#D4D4D4", 0xffd4d4d4},
- {"gray84", "#D6D6D6", 0xffd6d6d6},
- {"gray85", "#D9D9D9", 0xffd9d9d9},
- {"gray86", "#DBDBDB", 0xffdbdbdb},
- {"gray87", "#DEDEDE", 0xffdedede},
- {"gray88", "#E0E0E0", 0xffe0e0e0},
- {"gray89", "#E3E3E3", 0xffe3e3e3},
- {"gray90", "#E5E5E5", 0xffe5e5e5},
- {"gray91", "#E8E8E8", 0xffe8e8e8},
- {"gray92", "#EBEBEB", 0xffebebeb},
- {"gray93", "#EDEDED", 0xffededed},
- {"gray94", "#F0F0F0", 0xfff0f0f0},
- {"gray95", "#F2F2F2", 0xfff2f2f2},
- {"gray96", "#F5F5F5", 0xfff5f5f5},
- {"gray97", "#F7F7F7", 0xfff7f7f7},
- {"gray98", "#FAFAFA", 0xfffafafa},
- {"gray99", "#FCFCFC", 0xfffcfcfc},
- {"gray100", "#FFFFFF", 0xffffffff},
- {"green", "#00FF00", 0xff00ff00},
- {"green1", "#00FF00", 0xff00ff00},
- {"green2", "#00EE00", 0xff00ee00},
- {"green3", "#00CD00", 0xff00cd00},
- {"green4", "#008B00", 0xff008b00},
- {"greenyellow", "#ADFF2F", 0xff2fffad},
- {"grey", "#BEBEBE", 0xffbebebe},
- {"grey0", "#000000", 0xff000000},
- {"grey1", "#030303", 0xff030303},
- {"grey2", "#050505", 0xff050505},
- {"grey3", "#080808", 0xff080808},
- {"grey4", "#0A0A0A", 0xff0a0a0a},
- {"grey5", "#0D0D0D", 0xff0d0d0d},
- {"grey6", "#0F0F0F", 0xff0f0f0f},
- {"grey7", "#121212", 0xff121212},
- {"grey8", "#141414", 0xff141414},
- {"grey9", "#171717", 0xff171717},
- {"grey10", "#1A1A1A", 0xff1a1a1a},
- {"grey11", "#1C1C1C", 0xff1c1c1c},
- {"grey12", "#1F1F1F", 0xff1f1f1f},
- {"grey13", "#212121", 0xff212121},
- {"grey14", "#242424", 0xff242424},
- {"grey15", "#262626", 0xff262626},
- {"grey16", "#292929", 0xff292929},
- {"grey17", "#2B2B2B", 0xff2b2b2b},
- {"grey18", "#2E2E2E", 0xff2e2e2e},
- {"grey19", "#303030", 0xff303030},
- {"grey20", "#333333", 0xff333333},
- {"grey21", "#363636", 0xff363636},
- {"grey22", "#383838", 0xff383838},
- {"grey23", "#3B3B3B", 0xff3b3b3b},
- {"grey24", "#3D3D3D", 0xff3d3d3d},
- {"grey25", "#404040", 0xff404040},
- {"grey26", "#424242", 0xff424242},
- {"grey27", "#454545", 0xff454545},
- {"grey28", "#474747", 0xff474747},
- {"grey29", "#4A4A4A", 0xff4a4a4a},
- {"grey30", "#4D4D4D", 0xff4d4d4d},
- {"grey31", "#4F4F4F", 0xff4f4f4f},
- {"grey32", "#525252", 0xff525252},
- {"grey33", "#545454", 0xff545454},
- {"grey34", "#575757", 0xff575757},
- {"grey35", "#595959", 0xff595959},
- {"grey36", "#5C5C5C", 0xff5c5c5c},
- {"grey37", "#5E5E5E", 0xff5e5e5e},
- {"grey38", "#616161", 0xff616161},
- {"grey39", "#636363", 0xff636363},
- {"grey40", "#666666", 0xff666666},
- {"grey41", "#696969", 0xff696969},
- {"grey42", "#6B6B6B", 0xff6b6b6b},
- {"grey43", "#6E6E6E", 0xff6e6e6e},
- {"grey44", "#707070", 0xff707070},
- {"grey45", "#737373", 0xff737373},
- {"grey46", "#757575", 0xff757575},
- {"grey47", "#787878", 0xff787878},
- {"grey48", "#7A7A7A", 0xff7a7a7a},
- {"grey49", "#7D7D7D", 0xff7d7d7d},
- {"grey50", "#7F7F7F", 0xff7f7f7f},
- {"grey51", "#828282", 0xff828282},
- {"grey52", "#858585", 0xff858585},
- {"grey53", "#878787", 0xff878787},
- {"grey54", "#8A8A8A", 0xff8a8a8a},
- {"grey55", "#8C8C8C", 0xff8c8c8c},
- {"grey56", "#8F8F8F", 0xff8f8f8f},
- {"grey57", "#919191", 0xff919191},
- {"grey58", "#949494", 0xff949494},
- {"grey59", "#969696", 0xff969696},
- {"grey60", "#999999", 0xff999999},
- {"grey61", "#9C9C9C", 0xff9c9c9c},
- {"grey62", "#9E9E9E", 0xff9e9e9e},
- {"grey63", "#A1A1A1", 0xffa1a1a1},
- {"grey64", "#A3A3A3", 0xffa3a3a3},
- {"grey65", "#A6A6A6", 0xffa6a6a6},
- {"grey66", "#A8A8A8", 0xffa8a8a8},
- {"grey67", "#ABABAB", 0xffababab},
- {"grey68", "#ADADAD", 0xffadadad},
- {"grey69", "#B0B0B0", 0xffb0b0b0},
- {"grey70", "#B3B3B3", 0xffb3b3b3},
- {"grey71", "#B5B5B5", 0xffb5b5b5},
- {"grey72", "#B8B8B8", 0xffb8b8b8},
- {"grey73", "#BABABA", 0xffbababa},
- {"grey74", "#BDBDBD", 0xffbdbdbd},
- {"grey75", "#BFBFBF", 0xffbfbfbf},
- {"grey76", "#C2C2C2", 0xffc2c2c2},
- {"grey77", "#C4C4C4", 0xffc4c4c4},
- {"grey78", "#C7C7C7", 0xffc7c7c7},
- {"grey79", "#C9C9C9", 0xffc9c9c9},
- {"grey80", "#CCCCCC", 0xffcccccc},
- {"grey81", "#CFCFCF", 0xffcfcfcf},
- {"grey82", "#D1D1D1", 0xffd1d1d1},
- {"grey83", "#D4D4D4", 0xffd4d4d4},
- {"grey84", "#D6D6D6", 0xffd6d6d6},
- {"grey85", "#D9D9D9", 0xffd9d9d9},
- {"grey86", "#DBDBDB", 0xffdbdbdb},
- {"grey87", "#DEDEDE", 0xffdedede},
- {"grey88", "#E0E0E0", 0xffe0e0e0},
- {"grey89", "#E3E3E3", 0xffe3e3e3},
- {"grey90", "#E5E5E5", 0xffe5e5e5},
- {"grey91", "#E8E8E8", 0xffe8e8e8},
- {"grey92", "#EBEBEB", 0xffebebeb},
- {"grey93", "#EDEDED", 0xffededed},
- {"grey94", "#F0F0F0", 0xfff0f0f0},
- {"grey95", "#F2F2F2", 0xfff2f2f2},
- {"grey96", "#F5F5F5", 0xfff5f5f5},
- {"grey97", "#F7F7F7", 0xfff7f7f7},
- {"grey98", "#FAFAFA", 0xfffafafa},
- {"grey99", "#FCFCFC", 0xfffcfcfc},
- {"grey100", "#FFFFFF", 0xffffffff},
- {"honeydew", "#F0FFF0", 0xfff0fff0},
- {"honeydew1", "#F0FFF0", 0xfff0fff0},
- {"honeydew2", "#E0EEE0", 0xffe0eee0},
- {"honeydew3", "#C1CDC1", 0xffc1cdc1},
- {"honeydew4", "#838B83", 0xff838b83},
- {"hotpink", "#FF69B4", 0xffb469ff},
- {"hotpink1", "#FF6EB4", 0xffb46eff},
- {"hotpink2", "#EE6AA7", 0xffa76aee},
- {"hotpink3", "#CD6090", 0xff9060cd},
- {"hotpink4", "#8B3A62", 0xff623a8b},
- {"indianred", "#CD5C5C", 0xff5c5ccd},
- {"indianred1", "#FF6A6A", 0xff6a6aff},
- {"indianred2", "#EE6363", 0xff6363ee},
- {"indianred3", "#CD5555", 0xff5555cd},
- {"indianred4", "#8B3A3A", 0xff3a3a8b},
- {"ivory", "#FFFFF0", 0xfff0ffff},
- {"ivory1", "#FFFFF0", 0xfff0ffff},
- {"ivory2", "#EEEEE0", 0xffe0eeee},
- {"ivory3", "#CDCDC1", 0xffc1cdcd},
- {"ivory4", "#8B8B83", 0xff838b8b},
- {"khaki", "#F0E68C", 0xff8ce6f0},
- {"khaki1", "#FFF68F", 0xff8ff6ff},
- {"khaki2", "#EEE685", 0xff85e6ee},
- {"khaki3", "#CDC673", 0xff73c6cd},
- {"khaki4", "#8B864E", 0xff4e868b},
- {"lavender", "#E6E6FA", 0xfffae6e6},
- {"lavenderblush", "#FFF0F5", 0xfff5f0ff},
- {"lavenderblush1", "#FFF0F5", 0xfff5f0ff},
- {"lavenderblush2", "#EEE0E5", 0xffe5e0ee},
- {"lavenderblush3", "#CDC1C5", 0xffc5c1cd},
- {"lavenderblush4", "#8B8386", 0xff86838b},
- {"lawngreen", "#7CFC00", 0xff00fc7c},
- {"lemonchiffon", "#FFFACD", 0xffcdfaff},
- {"lemonchiffon1", "#FFFACD", 0xffcdfaff},
- {"lemonchiffon2", "#EEE9BF", 0xffbfe9ee},
- {"lemonchiffon3", "#CDC9A5", 0xffa5c9cd},
- {"lemonchiffon4", "#8B8970", 0xff70898b},
- {"lightblue", "#ADD8E6", 0xffe6d8ad},
- {"lightblue1", "#BFEFFF", 0xffffefbf},
- {"lightblue2", "#B2DFEE", 0xffeedfb2},
- {"lightblue3", "#9AC0CD", 0xffcdc09a},
- {"lightblue4", "#68838B", 0xff8b8368},
- {"lightcoral", "#F08080", 0xff8080f0},
- {"lightcyan", "#E0FFFF", 0xffffffe0},
- {"lightcyan1", "#E0FFFF", 0xffffffe0},
- {"lightcyan2", "#D1EEEE", 0xffeeeed1},
- {"lightcyan3", "#B4CDCD", 0xffcdcdb4},
- {"lightcyan4", "#7A8B8B", 0xff8b8b7a},
- {"lightgoldenrod", "#EEDD82", 0xff82ddee},
- {"lightgoldenrod1", "#FFEC8B", 0xff8becff},
- {"lightgoldenrod2", "#EEDC82", 0xff82dcee},
- {"lightgoldenrod3", "#CDBE70", 0xff70becd},
- {"lightgoldenrod4", "#8B814C", 0xff4c818b},
- {"lightgoldenrodyellow", "#FAFAD2", 0xffd2fafa},
- {"lightgray", "#D3D3D3", 0xffd3d3d3},
- {"lightgreen", "#90EE90", 0xff90ee90},
- {"lightgrey", "#D3D3D3", 0xffd3d3d3},
- {"lightpink", "#FFB6C1", 0xffc1b6ff},
- {"lightpink1", "#FFAEB9", 0xffb9aeff},
- {"lightpink2", "#EEA2AD", 0xffada2ee},
- {"lightpink3", "#CD8C95", 0xff958ccd},
- {"lightpink4", "#8B5F65", 0xff655f8b},
- {"lightsalmon", "#FFA07A", 0xff7aa0ff},
- {"lightsalmon1", "#FFA07A", 0xff7aa0ff},
- {"lightsalmon2", "#EE9572", 0xff7295ee},
- {"lightsalmon3", "#CD8162", 0xff6281cd},
- {"lightsalmon4", "#8B5742", 0xff42578b},
- {"lightseagreen", "#20B2AA", 0xffaab220},
- {"lightskyblue", "#87CEFA", 0xffface87},
- {"lightskyblue1", "#B0E2FF", 0xffffe2b0},
- {"lightskyblue2", "#A4D3EE", 0xffeed3a4},
- {"lightskyblue3", "#8DB6CD", 0xffcdb68d},
- {"lightskyblue4", "#607B8B", 0xff8b7b60},
- {"lightslateblue", "#8470FF", 0xffff7084},
- {"lightslategray", "#778899", 0xff998877},
- {"lightslategrey", "#778899", 0xff998877},
- {"lightsteelblue", "#B0C4DE", 0xffdec4b0},
- {"lightsteelblue1", "#CAE1FF", 0xffffe1ca},
- {"lightsteelblue2", "#BCD2EE", 0xffeed2bc},
- {"lightsteelblue3", "#A2B5CD", 0xffcdb5a2},
- {"lightsteelblue4", "#6E7B8B", 0xff8b7b6e},
- {"lightyellow", "#FFFFE0", 0xffe0ffff},
- {"lightyellow1", "#FFFFE0", 0xffe0ffff},
- {"lightyellow2", "#EEEED1", 0xffd1eeee},
- {"lightyellow3", "#CDCDB4", 0xffb4cdcd},
- {"lightyellow4", "#8B8B7A", 0xff7a8b8b},
- {"limegreen", "#32CD32", 0xff32cd32},
- {"linen", "#FAF0E6", 0xffe6f0fa},
- {"magenta", "#FF00FF", 0xffff00ff},
- {"magenta1", "#FF00FF", 0xffff00ff},
- {"magenta2", "#EE00EE", 0xffee00ee},
- {"magenta3", "#CD00CD", 0xffcd00cd},
- {"magenta4", "#8B008B", 0xff8b008b},
- {"maroon", "#B03060", 0xff6030b0},
- {"maroon1", "#FF34B3", 0xffb334ff},
- {"maroon2", "#EE30A7", 0xffa730ee},
- {"maroon3", "#CD2990", 0xff9029cd},
- {"maroon4", "#8B1C62", 0xff621c8b},
- {"mediumaquamarine", "#66CDAA", 0xffaacd66},
- {"mediumblue", "#0000CD", 0xffcd0000},
- {"mediumorchid", "#BA55D3", 0xffd355ba},
- {"mediumorchid1", "#E066FF", 0xffff66e0},
- {"mediumorchid2", "#D15FEE", 0xffee5fd1},
- {"mediumorchid3", "#B452CD", 0xffcd52b4},
- {"mediumorchid4", "#7A378B", 0xff8b377a},
- {"mediumpurple", "#9370DB", 0xffdb7093},
- {"mediumpurple1", "#AB82FF", 0xffff82ab},
- {"mediumpurple2", "#9F79EE", 0xffee799f},
- {"mediumpurple3", "#8968CD", 0xffcd6889},
- {"mediumpurple4", "#5D478B", 0xff8b475d},
- {"mediumseagreen", "#3CB371", 0xff71b33c},
- {"mediumslateblue", "#7B68EE", 0xffee687b},
- {"mediumspringgreen", "#00FA9A", 0xff9afa00},
- {"mediumturquoise", "#48D1CC", 0xffccd148},
- {"mediumvioletred", "#C71585", 0xff8515c7},
- {"midnightblue", "#191970", 0xff701919},
- {"mintcream", "#F5FFFA", 0xfffafff5},
- {"mistyrose", "#FFE4E1", 0xffe1e4ff},
- {"mistyrose1", "#FFE4E1", 0xffe1e4ff},
- {"mistyrose2", "#EED5D2", 0xffd2d5ee},
- {"mistyrose3", "#CDB7B5", 0xffb5b7cd},
- {"mistyrose4", "#8B7D7B", 0xff7b7d8b},
- {"moccasin", "#FFE4B5", 0xffb5e4ff},
- {"navajowhite", "#FFDEAD", 0xffaddeff},
- {"navajowhite1", "#FFDEAD", 0xffaddeff},
- {"navajowhite2", "#EECFA1", 0xffa1cfee},
- {"navajowhite3", "#CDB38B", 0xff8bb3cd},
- {"navajowhite4", "#8B795E", 0xff5e798b},
- {"navy", "#000080", 0xff800000},
- {"navyblue", "#000080", 0xff800000},
- {"oldlace", "#FDF5E6", 0xffe6f5fd},
- {"olivedrab", "#6B8E23", 0xff238e6b},
- {"olivedrab1", "#C0FF3E", 0xff3effc0},
- {"olivedrab2", "#B3EE3A", 0xff3aeeb3},
- {"olivedrab3", "#9ACD32", 0xff32cd9a},
- {"olivedrab4", "#698B22", 0xff228b69},
- {"orange", "#FFA500", 0xff00a5ff},
- {"orange1", "#FFA500", 0xff00a5ff},
- {"orange2", "#EE9A00", 0xff009aee},
- {"orange3", "#CD8500", 0xff0085cd},
- {"orange4", "#8B5A00", 0xff005a8b},
- {"orangered", "#FF4500", 0xff0045ff},
- {"orangered1", "#FF4500", 0xff0045ff},
- {"orangered2", "#EE4000", 0xff0040ee},
- {"orangered3", "#CD3700", 0xff0037cd},
- {"orangered4", "#8B2500", 0xff00258b},
- {"orchid", "#DA70D6", 0xffd670da},
- {"orchid1", "#FF83FA", 0xfffa83ff},
- {"orchid2", "#EE7AE9", 0xffe97aee},
- {"orchid3", "#CD69C9", 0xffc969cd},
- {"orchid4", "#8B4789", 0xff89478b},
- {"palegoldenrod", "#EEE8AA", 0xffaae8ee},
- {"palegreen", "#98FB98", 0xff98fb98},
- {"palegreen1", "#9AFF9A", 0xff9aff9a},
- {"palegreen2", "#90EE90", 0xff90ee90},
- {"palegreen3", "#7CCD7C", 0xff7ccd7c},
- {"palegreen4", "#548B54", 0xff548b54},
- {"paleturquoise", "#AFEEEE", 0xffeeeeaf},
- {"paleturquoise1", "#BBFFFF", 0xffffffbb},
- {"paleturquoise2", "#AEEEEE", 0xffeeeeae},
- {"paleturquoise3", "#96CDCD", 0xffcdcd96},
- {"paleturquoise4", "#668B8B", 0xff8b8b66},
- {"palevioletred", "#DB7093", 0xff9370db},
- {"palevioletred1", "#FF82AB", 0xffab82ff},
- {"palevioletred2", "#EE799F", 0xff9f79ee},
- {"palevioletred3", "#CD6889", 0xff8968cd},
- {"palevioletred4", "#8B475D", 0xff5d478b},
- {"papayawhip", "#FFEFD5", 0xffd5efff},
- {"peachpuff", "#FFDAB9", 0xffb9daff},
- {"peachpuff1", "#FFDAB9", 0xffb9daff},
- {"peachpuff2", "#EECBAD", 0xffadcbee},
- {"peachpuff3", "#CDAF95", 0xff95afcd},
- {"peachpuff4", "#8B7765", 0xff65778b},
- {"peru", "#CD853F", 0xff3f85cd},
- {"pink", "#FFC0CB", 0xffcbc0ff},
- {"pink1", "#FFB5C5", 0xffc5b5ff},
- {"pink2", "#EEA9B8", 0xffb8a9ee},
- {"pink3", "#CD919E", 0xff9e91cd},
- {"pink4", "#8B636C", 0xff6c638b},
- {"plum", "#DDA0DD", 0xffdda0dd},
- {"plum1", "#FFBBFF", 0xffffbbff},
- {"plum2", "#EEAEEE", 0xffeeaeee},
- {"plum3", "#CD96CD", 0xffcd96cd},
- {"plum4", "#8B668B", 0xff8b668b},
- {"powderblue", "#B0E0E6", 0xffe6e0b0},
- {"purple", "#A020F0", 0xfff020a0},
- {"purple1", "#9B30FF", 0xffff309b},
- {"purple2", "#912CEE", 0xffee2c91},
- {"purple3", "#7D26CD", 0xffcd267d},
- {"purple4", "#551A8B", 0xff8b1a55},
- {"red", "#FF0000", 0xff0000ff},
- {"red1", "#FF0000", 0xff0000ff},
- {"red2", "#EE0000", 0xff0000ee},
- {"red3", "#CD0000", 0xff0000cd},
- {"red4", "#8B0000", 0xff00008b},
- {"rosybrown", "#BC8F8F", 0xff8f8fbc},
- {"rosybrown1", "#FFC1C1", 0xffc1c1ff},
- {"rosybrown2", "#EEB4B4", 0xffb4b4ee},
- {"rosybrown3", "#CD9B9B", 0xff9b9bcd},
- {"rosybrown4", "#8B6969", 0xff69698b},
- {"royalblue", "#4169E1", 0xffe16941},
- {"royalblue1", "#4876FF", 0xffff7648},
- {"royalblue2", "#436EEE", 0xffee6e43},
- {"royalblue3", "#3A5FCD", 0xffcd5f3a},
- {"royalblue4", "#27408B", 0xff8b4027},
- {"saddlebrown", "#8B4513", 0xff13458b},
- {"salmon", "#FA8072", 0xff7280fa},
- {"salmon1", "#FF8C69", 0xff698cff},
- {"salmon2", "#EE8262", 0xff6282ee},
- {"salmon3", "#CD7054", 0xff5470cd},
- {"salmon4", "#8B4C39", 0xff394c8b},
- {"sandybrown", "#F4A460", 0xff60a4f4},
- {"seagreen", "#2E8B57", 0xff578b2e},
- {"seagreen1", "#54FF9F", 0xff9fff54},
- {"seagreen2", "#4EEE94", 0xff94ee4e},
- {"seagreen3", "#43CD80", 0xff80cd43},
- {"seagreen4", "#2E8B57", 0xff578b2e},
- {"seashell", "#FFF5EE", 0xffeef5ff},
- {"seashell1", "#FFF5EE", 0xffeef5ff},
- {"seashell2", "#EEE5DE", 0xffdee5ee},
- {"seashell3", "#CDC5BF", 0xffbfc5cd},
- {"seashell4", "#8B8682", 0xff82868b},
- {"sienna", "#A0522D", 0xff2d52a0},
- {"sienna1", "#FF8247", 0xff4782ff},
- {"sienna2", "#EE7942", 0xff4279ee},
- {"sienna3", "#CD6839", 0xff3968cd},
- {"sienna4", "#8B4726", 0xff26478b},
- {"skyblue", "#87CEEB", 0xffebce87},
- {"skyblue1", "#87CEFF", 0xffffce87},
- {"skyblue2", "#7EC0EE", 0xffeec07e},
- {"skyblue3", "#6CA6CD", 0xffcda66c},
- {"skyblue4", "#4A708B", 0xff8b704a},
- {"slateblue", "#6A5ACD", 0xffcd5a6a},
- {"slateblue1", "#836FFF", 0xffff6f83},
- {"slateblue2", "#7A67EE", 0xffee677a},
- {"slateblue3", "#6959CD", 0xffcd5969},
- {"slateblue4", "#473C8B", 0xff8b3c47},
- {"slategray", "#708090", 0xff908070},
- {"slategray1", "#C6E2FF", 0xffffe2c6},
- {"slategray2", "#B9D3EE", 0xffeed3b9},
- {"slategray3", "#9FB6CD", 0xffcdb69f},
- {"slategray4", "#6C7B8B", 0xff8b7b6c},
- {"slategrey", "#708090", 0xff908070},
- {"snow", "#FFFAFA", 0xfffafaff},
- {"snow1", "#FFFAFA", 0xfffafaff},
- {"snow2", "#EEE9E9", 0xffe9e9ee},
- {"snow3", "#CDC9C9", 0xffc9c9cd},
- {"snow4", "#8B8989", 0xff89898b},
- {"springgreen", "#00FF7F", 0xff7fff00},
- {"springgreen1", "#00FF7F", 0xff7fff00},
- {"springgreen2", "#00EE76", 0xff76ee00},
- {"springgreen3", "#00CD66", 0xff66cd00},
- {"springgreen4", "#008B45", 0xff458b00},
- {"steelblue", "#4682B4", 0xffb48246},
- {"steelblue1", "#63B8FF", 0xffffb863},
- {"steelblue2", "#5CACEE", 0xffeeac5c},
- {"steelblue3", "#4F94CD", 0xffcd944f},
- {"steelblue4", "#36648B", 0xff8b6436},
- {"tan", "#D2B48C", 0xff8cb4d2},
- {"tan1", "#FFA54F", 0xff4fa5ff},
- {"tan2", "#EE9A49", 0xff499aee},
- {"tan3", "#CD853F", 0xff3f85cd},
- {"tan4", "#8B5A2B", 0xff2b5a8b},
- {"thistle", "#D8BFD8", 0xffd8bfd8},
- {"thistle1", "#FFE1FF", 0xffffe1ff},
- {"thistle2", "#EED2EE", 0xffeed2ee},
- {"thistle3", "#CDB5CD", 0xffcdb5cd},
- {"thistle4", "#8B7B8B", 0xff8b7b8b},
- {"tomato", "#FF6347", 0xff4763ff},
- {"tomato1", "#FF6347", 0xff4763ff},
- {"tomato2", "#EE5C42", 0xff425cee},
- {"tomato3", "#CD4F39", 0xff394fcd},
- {"tomato4", "#8B3626", 0xff26368b},
- {"turquoise", "#40E0D0", 0xffd0e040},
- {"turquoise1", "#00F5FF", 0xfffff500},
- {"turquoise2", "#00E5EE", 0xffeee500},
- {"turquoise3", "#00C5CD", 0xffcdc500},
- {"turquoise4", "#00868B", 0xff8b8600},
- {"violet", "#EE82EE", 0xffee82ee},
- {"violetred", "#D02090", 0xff9020d0},
- {"violetred1", "#FF3E96", 0xff963eff},
- {"violetred2", "#EE3A8C", 0xff8c3aee},
- {"violetred3", "#CD3278", 0xff7832cd},
- {"violetred4", "#8B2252", 0xff52228b},
- {"wheat", "#F5DEB3", 0xffb3def5},
- {"wheat1", "#FFE7BA", 0xffbae7ff},
- {"wheat2", "#EED8AE", 0xffaed8ee},
- {"wheat3", "#CDBA96", 0xff96bacd},
- {"wheat4", "#8B7E66", 0xff667e8b},
- {"whitesmoke", "#F5F5F5", 0xfff5f5f5},
- {"yellow", "#FFFF00", 0xff00ffff},
- {"yellow1", "#FFFF00", 0xff00ffff},
- {"yellow2", "#EEEE00", 0xff00eeee},
- {"yellow3", "#CDCD00", 0xff00cdcd},
- {"yellow4", "#8B8B00", 0xff008b8b},
- {"yellowgreen", "#9ACD32", 0xff32cd9a},
- {NULL, NULL, 0}
-};
-
-
-/* Hex Digit to Integer Conversion */
-
-static unsigned int hexdigit(int digit)
-{
- if('0' <= digit && digit <= '9') return digit - '0';
- if('A' <= digit && digit <= 'F') return 10 + digit - 'A';
- if('a' <= digit && digit <= 'f') return 10 + digit - 'a';
- /*else */ error(_("invalid hex digit in 'color' or 'lty'"));
- return digit; /* never occurs (-Wall) */
-}
-
-
-/* #RRGGBB[AA] String to Internal Color Code */
-static rcolor rgb2col(const char *rgb)
-{
- unsigned int r = 0, g = 0, b = 0, a = 0; /* -Wall */
- if(rgb[0] != '#')
- error(_("invalid RGB specification"));
- switch (strlen(rgb)) {
- case 9:
- a = 16 * hexdigit(rgb[7]) + hexdigit(rgb[8]);
- case 7:
- r = 16 * hexdigit(rgb[1]) + hexdigit(rgb[2]);
- g = 16 * hexdigit(rgb[3]) + hexdigit(rgb[4]);
- b = 16 * hexdigit(rgb[5]) + hexdigit(rgb[6]);
- break;
- default:
- error(_("invalid RGB specification"));
- }
- if (strlen(rgb) == 7)
- return R_RGB(r, g, b);
- else
- return R_RGBA(r, g, b, a);
-}
-
-/* External Color Name to Internal Color Code */
-
-static rcolor name2col(const char *nm)
-{
- int i;
- if(strcmp(nm, "NA") == 0 || strcmp(nm, "transparent") == 0)
- /*
- * Paul 01/07/04 (2004-07-01?)
- *
- * Used to be set to NA_INTEGER.
- *
- * Now set to fully transparent white.
- *
- * In some cases, fully transparent gets caught by
- * the graphics engine and no drawing occurs, but
- * in other cases, transparent colours are passed to devices.
- *
- * All devices should respond to fully transparent by
- * not drawing.
- */
- return R_TRANWHITE;
- for(i = 0; ColorDataBase[i].name ; i++) {
- if(StrMatch(ColorDataBase[i].name, nm))
- return ColorDataBase[i].code;
- }
- error(_("invalid color name '%s'"), nm);
- return 0U; /* never occurs but avoid compiler warnings */
-}
-
-
-/* Internal to External Color Representation */
-/* Search the color name database first */
-/* If this fails, create an #RRGGBB string */
-
-const char *incol2name(rcolor col)
-{
- static char ColBuf[10]; // used for return value
-
- if(R_OPAQUE(col)) {
- for(int i = 0 ; ColorDataBase[i].name ; i++) {
- if(col == ColorDataBase[i].code)
- return ColorDataBase[i].name;
- }
- ColBuf[0] = '#';
- ColBuf[1] = HexDigits[(col >> 4) & 15];
- ColBuf[2] = HexDigits[(col ) & 15];
- ColBuf[3] = HexDigits[(col >> 12) & 15];
- ColBuf[4] = HexDigits[(col >> 8) & 15];
- ColBuf[5] = HexDigits[(col >> 20) & 15];
- ColBuf[6] = HexDigits[(col >> 16) & 15];
- ColBuf[7] = '\0';
- return &ColBuf[0];
- } else if (R_TRANSPARENT(col)) {
- return "transparent";
- } else {
- ColBuf[0] = '#';
- ColBuf[1] = HexDigits[(col >> 4) & 15];
- ColBuf[2] = HexDigits[(col ) & 15];
- ColBuf[3] = HexDigits[(col >> 12) & 15];
- ColBuf[4] = HexDigits[(col >> 8) & 15];
- ColBuf[5] = HexDigits[(col >> 20) & 15];
- ColBuf[6] = HexDigits[(col >> 16) & 15];
- ColBuf[7] = HexDigits[(col >> 28) & 15];
- ColBuf[8] = HexDigits[(col >> 24) & 15];
- ColBuf[9] = '\0';
- return &ColBuf[0];
- }
-}
-
-static rcolor str2col(const char *s, rcolor bg)
-{
- if(s[0] == '#') return rgb2col(s);
- else if(isdigit((int)s[0])) {
- char *ptr;
- int indx = (int) strtod(s, &ptr);
- if(*ptr) error(_("invalid color specification \"%s\""), s);
- if (indx == 0) return bg;
- return Palette[(indx-1) % PaletteSize];
- } else return name2col(s);
-}
-
-rcolor inR_GE_str2col(const char *s)
-{
- if (streql(s, "0"))
- error(_("invalid color specification \"%s\""), s);
- return str2col(s, R_TRANWHITE); // bg is irrelevant
-}
-
-/* Convert a sexp element to an R color desc */
-/* We Assume that Checks Have Been Done */
-
-
-rcolor inRGBpar3(SEXP x, int i, rcolor bg)
-{
- int indx;
- switch(TYPEOF(x))
- {
- case STRSXP:
- return str2col(CHAR(STRING_ELT(x, i)), bg);
- case LGLSXP:
- indx = LOGICAL(x)[i];
- if (indx == NA_LOGICAL) return R_TRANWHITE;
- break;
- case INTSXP:
- indx = INTEGER(x)[i];
- if (indx == NA_INTEGER) return R_TRANWHITE;
- break;
- case REALSXP:
- if(!R_FINITE(REAL(x)[i])) return R_TRANWHITE;
- indx = (int) REAL(x)[i];
- break;
- default:
- warning(_("supplied color is neither numeric nor character"));
- return bg;
- }
- if (indx < 0)
- error(_("numerical color values must be >= 0, found %d"), indx);
- if (indx == 0) return bg;
- else return Palette[(indx-1) % PaletteSize];
-}
-
-SEXP palette(SEXP val)
-{
- SEXP ans;
- rcolor color[MAX_PALETTE_SIZE];
- int i, n;
-
- if (!isString(val)) error(_("invalid argument type"));
- /* Record the current palette */
- PROTECT(ans = allocVector(STRSXP, PaletteSize));
- for (i = 0; i < PaletteSize; i++)
- SET_STRING_ELT(ans, i, mkChar(incol2name(Palette[i])));
- if ((n = length(val)) == 1) {
- if (StrMatch("default", CHAR(STRING_ELT(val, 0)))) {
- int i;
- for (i = 0; (i < MAX_PALETTE_SIZE) && DefaultPalette[i]; i++)
- Palette[i] = name2col(DefaultPalette[i]);
- PaletteSize = i;
- } else error(_("unknown palette (need >= 2 colors)"));
- }
- else if (n > 1) {
- if (n > MAX_PALETTE_SIZE)
- error(_("maximum number of colors is %d"), MAX_PALETTE_SIZE);
- for (i = 0; i < n; i++) {
- const char *s = CHAR(STRING_ELT(val, i));
- color[i] = (s[0] == '#') ? rgb2col(s) : name2col(s);
- }
- for (i = 0; i < n; i++)
- Palette[i] = color[i];
- PaletteSize = n;
- }
- UNPROTECT(1);
- return ans;
-}
-
-/* A version using 'rcolor' type */
-SEXP palette2(SEXP val)
-{
- SEXP ans = PROTECT(allocVector(INTSXP, PaletteSize));
- int n = length(val), *ians = INTEGER(ans);
- for (int i = 0; i < PaletteSize; i++) ians[i] = (int)Palette[i];
- if (n) {
- if (TYPEOF(val) != INTSXP) error("requires INTSXP argment");
- if (n > MAX_PALETTE_SIZE)
- error(_("maximum number of colors is %d"), MAX_PALETTE_SIZE);
- for (int i = 0; i < n; i++) Palette[i] = (rcolor)INTEGER(val)[i];
- PaletteSize = n;
- }
- UNPROTECT(1);
- return ans;
-}
-
-SEXP colors(void)
-{
- int n;
-
- for (n = 0; ColorDataBase[n].name != NULL; n++) ;
- SEXP ans = PROTECT(allocVector(STRSXP, n));
- for (n = 0; ColorDataBase[n].name != NULL; n++)
- SET_STRING_ELT(ans, n, mkChar(ColorDataBase[n].name));
- UNPROTECT(1);
- return ans;
-}
-
-/* Used to push/pop palette when replaying display list */
-static void savePalette(Rboolean save)
-{
- if (save)
- for (int i = 0; i < PaletteSize; i++)
- Palette0[i] = Palette[i];
- else
- for (int i = 0; i < PaletteSize; i++)
- Palette[i] = Palette0[i];
-}
-
-/* same as src/main/colors.c */
-typedef unsigned int (*F1)(SEXP x, int i, unsigned int bg);
-typedef const char * (*F2)(unsigned int col);
-typedef unsigned int (*F3)(const char *s);
-typedef void (*F4)(Rboolean save);
-
-void Rg_set_col_ptrs(F1 f1, F2 f2, F3 f3, F4 f4);
-
-void initPalette(void)
-{
- Rg_set_col_ptrs(&inRGBpar3, &incol2name, &inR_GE_str2col, &savePalette);
-
- /* Initialize the Color Database: we now pre-compute this
- for(int i = 0 ; ColorDataBase[i].name ; i++)
- ColorDataBase[i].code = rgb2col(ColorDataBase[i].rgb);
-
- Install Default Palette: precomputed
- int i;
- for(i = 0 ; DefaultPalette[i] ; i++)
- Palette[i] = name2col(DefaultPalette[i]);
- PaletteSize = i; // 8
- */
-}
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devCairo.c b/com.oracle.truffle.r.native/library/grDevices/src/devCairo.c
deleted file mode 100644
index 504cb8bfc2ccdca3b799ae4ffc9d5dd53320f287..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devCairo.c
+++ /dev/null
@@ -1,55 +0,0 @@
-/*
- * R : A Computer Langage for Statistical Data Analysis
- * Copyright (C) 2011 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/
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-
-
-#include <R_ext/Rdynload.h>
-int R_cairoCdynload(int local, int now);
-
-typedef SEXP (*R_cairo)(SEXP args);
-
-static R_cairo R_devCairo;
-
-static int Load_Rcairo_Dll(void)
-{
- static int initialized = 0;
-
- if (initialized) return initialized;
- initialized = -1;
-
- int res = R_cairoCdynload(1, 1);
- if(!res) return initialized;
- R_devCairo = (R_cairo) R_FindSymbol("in_Cairo", "cairo", NULL);
- if (!R_devCairo) error("failed to load cairo DLL");
- initialized = 1;
- return initialized;
-}
-
-
-SEXP devCairo(SEXP args)
-{
- if (Load_Rcairo_Dll() < 0) warning("failed to load cairo DLL");
- else (R_devCairo)(args);
- return R_NilValue;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devPS.c b/com.oracle.truffle.r.native/library/grDevices/src/devPS.c
deleted file mode 100644
index 331827ef0b537c8bb9036eb30b54433dd3ea0908..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devPS.c
+++ /dev/null
@@ -1,8432 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1998--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/
- */
-
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-
-#include <stdio.h>
-#include <ctype.h>
-#include <limits.h> /* required for MB_LEN_MAX */
-
-#include <wchar.h>
-#include <wctype.h>
-static void
-mbcsToSbcs(const char *in, char *out, const char *encoding, int enc);
-
-
-#include <R_ext/Riconv.h>
-
-#include <Rmath.h> /* for fround */
-#define R_USE_PROTOTYPES 1
-#include <R_ext/GraphicsEngine.h>
-#include <R_ext/Error.h>
-#include <R_ext/RS.h>
-#include "main_Fileio.h"
-#include "grDevices.h"
-
-#ifdef HAVE_ERRNO_H
-#include <errno.h>
-#else
-extern int errno;
-#endif
-
-#include "zlib.h"
-
-#ifndef max
-#define max(a,b) ((a > b) ? a : b)
-#endif
-
-#define _(String) (String)
-
-#include "../../../gnur/R-3.1.3/src/main/gzio.h"
-
-///* from connections.o */
-//extern gzFile R_gzopen (const char *path, const char *mode);
-//extern char *R_gzgets(gzFile file, char *buf, int len);
-//extern int R_gzclose (gzFile file);
-
-#define INVALID_COL 0xff0a0b0c
-
-/* Define this to use hyphen except in -[0-9] */
-#undef USE_HYPHEN
-/* In ISOLatin1, minus is 45 and hyphen is 173 */
-#ifdef USE_HYPHEN
-static char PS_hyphen = 173;
-#endif
-
-#define USERAFM 999
-
-/* Part 0. AFM File Names */
-
-static const char *CIDBoldFontStr1 =
-"16 dict begin\n"
-" /basecidfont exch def\n"
-" /basefont-H /.basefont-H /Identity-H [ basecidfont ] composefont def\n"
-" /basefont-V /.basefont-V /Identity-V [ basecidfont ] composefont def\n"
-" /CIDFontName dup basecidfont exch get def\n"
-" /CIDFontType 1 def\n"
-" /CIDSystemInfo dup basecidfont exch get def\n"
-" /FontInfo dup basecidfont exch get def\n"
-" /FontMatrix [ 1 0 0 1 0 0 ] def\n"
-" /FontBBox [\n"
-" basecidfont /FontBBox get cvx exec\n"
-" 4 2 roll basecidfont /FontMatrix get transform\n"
-" 4 2 roll basecidfont /FontMatrix get transform\n"
-" ] def\n"
-" /cid 2 string def\n";
-static const char *CIDBoldFontStr2 =
-" /BuildGlyph {\n"
-" gsave\n"
-" exch begin\n"
-" dup 256 idiv cid exch 0 exch put\n"
-" 256 mod cid exch 1 exch put\n"
-" rootfont\n"
-" /WMode known { rootfont /WMode get 1 eq } { false } ifelse\n"
-" { basefont-V } { basefont-H } ifelse setfont\n"
-" .03 setlinewidth 1 setlinejoin\n"
-" newpath\n"
-" 0 0 moveto cid false charpath stroke\n"
-" 0 0 moveto cid show\n"
-" currentpoint setcharwidth\n"
-" end\n"
-" grestore\n"
-" } bind def\n"
-" currentdict\n"
-"end\n"
-"/CIDFont defineresource pop\n";
-
-
-/* Part 1. AFM File Parsing. */
-
-/* These are the basic entities in the AFM file */
-
-#define BUFSIZE 512
-#define NA_SHORT -30000
-
-typedef struct {
- unsigned char c1;
- unsigned char c2;
- short kern;
-} KP;
-
-typedef struct {
- short FontBBox[4];
- short CapHeight;
- short XHeight;
- short Descender;
- short Ascender;
- short StemH;
- short StemV;
- short ItalicAngle;
- struct {
- short WX;
- short BBox[4];
- } CharInfo[256];
- KP *KernPairs;
- short KPstart[256];
- short KPend[256];
- short nKP;
- short IsFixedPitch;
-} FontMetricInfo;
-
-enum {
- Empty,
- StartFontMetrics,
- Comment,
- FontName,
- EncodingScheme,
- FullName,
- FamilyName,
- Weight,
- ItalicAngle,
- IsFixedPitch,
- UnderlinePosition,
- UnderlineThickness,
- Version,
- Notice,
- FontBBox,
- CapHeight,
- XHeight,
- Descender,
- Ascender,
- StartCharMetrics,
- C,
- CH,
- EndCharMetrics,
- StartKernData,
- StartKernPairs,
- KPX,
- EndKernPairs,
- EndKernData,
- StartComposites,
- CC,
- EndComposites,
- EndFontMetrics,
- StdHW,
- StdVW,
- CharacterSet,
- Unknown
-};
-
-static const struct {
- const char *keyword;
- const int code;
-}
-KeyWordDictionary[] = {
- { "StartFontMetrics", StartFontMetrics },
- { "Comment", Comment },
- { "FontName", FontName },
- { "EncodingScheme", EncodingScheme },
- { "FullName", FullName },
- { "FamilyName", FamilyName },
- { "Weight", Weight },
- { "ItalicAngle", ItalicAngle },
- { "IsFixedPitch", IsFixedPitch },
- { "UnderlinePosition", UnderlinePosition },
- { "UnderlineThickness", UnderlineThickness },
- { "Version", Version },
- { "Notice", Notice },
- { "FontBBox", FontBBox },
- { "CapHeight", CapHeight },
- { "XHeight", XHeight },
- { "Descender", Descender },
- { "Ascender", Ascender },
- { "StartCharMetrics", StartCharMetrics },
- { "C ", C },
- { "CH ", CH },
- { "EndCharMetrics", EndCharMetrics },
- { "StartKernData", StartKernData },
- { "StartKernPairs", StartKernPairs },
- { "KPX ", KPX },
- { "EndKernPairs", EndKernPairs },
- { "EndKernData", EndKernData },
- { "StartComposites", StartComposites },
- { "CC ", CC },
- { "EndComposites", EndComposites },
- { "EndFontMetrics", EndFontMetrics },
- { "StdHW", StdHW },
- { "StdVW", StdVW },
- { "CharacterSet", CharacterSet},
- { NULL, Unknown },
-};
-
-static int MatchKey(char const * l, char const * k)
-{
- while (*k)
- if (*k++ != *l++) return 0;
- return 1;
-}
-
-static int KeyType(const char * const s)
-{
- int i;
- if (*s == '\n')
- return Empty;
- for (i = 0; KeyWordDictionary[i].keyword; i++)
- if (MatchKey(s, KeyWordDictionary[i].keyword))
- return KeyWordDictionary[i].code;
-// printf("Unknown %s\n", s); // not needed, PR#15057 found it annoying
- return Unknown;
-}
-
-static char *SkipToNextItem(char *p)
-{
- while (!isspace((int)*p)) p++;
- while (isspace((int)*p)) p++;
- return p;
-}
-
-static char *SkipToNextKey(char *p)
-{
- while (*p != ';') p++;
- p++;
- while (isspace((int)*p)) p++;
- return p;
-}
-
-static int GetFontBBox(const char *buf, FontMetricInfo *metrics)
-{
- if (sscanf(buf, "FontBBox %hd %hd %hd %hd",
- &(metrics->FontBBox[0]),
- &(metrics->FontBBox[1]),
- &(metrics->FontBBox[2]),
- &(metrics->FontBBox[3])) != 4) return 0;
-#ifdef DEBUG_PS2
- Rprintf("FontBBox %d %d %d %d\n",
- (metrics->FontBBox[0]),
- (metrics->FontBBox[1]),
- (metrics->FontBBox[2]),
- (metrics->FontBBox[3]));
-#endif
- return 1;
-}
-
-/* The longest named Adobe glyph is 39 chars:
- whitediamondcontainingblacksmalldiamond
- */
-typedef struct {
- char cname[40];
-} CNAME;
-
-
-/* If reencode > 0, remap to new encoding */
-static int GetCharInfo(char *buf, FontMetricInfo *metrics,
- CNAME *charnames, CNAME *encnames,
- int reencode)
-{
- char *p = buf, charname[40];
- int nchar, nchar2 = -1, i;
- short WX;
-
- if (!MatchKey(buf, "C ")) return 0;
- p = SkipToNextItem(p);
- sscanf(p, "%d", &nchar);
- if ((nchar < 0 || nchar > 255) && !reencode) return 1;
- p = SkipToNextKey(p);
-
- if (!MatchKey(p, "WX")) return 0;
- p = SkipToNextItem(p);
- sscanf(p, "%hd", &WX);
- p = SkipToNextKey(p);
-
- if (!MatchKey(p, "N ")) return 0;
- p = SkipToNextItem(p);
- if(reencode) {
- sscanf(p, "%s", charname);
-#ifdef DEBUG_PS2
- Rprintf("char name %s\n", charname);
-#endif
- /* a few chars appear twice in ISOLatin1 */
- nchar = nchar2 = -1;
- for (i = 0; i < 256; i++)
- if(!strcmp(charname, encnames[i].cname)) {
- strcpy(charnames[i].cname, charname);
- if(nchar == -1) nchar = i; else nchar2 = i;
- }
- if (nchar == -1) return 1;
- } else {
- sscanf(p, "%s", charnames[nchar].cname);
- }
- metrics->CharInfo[nchar].WX = WX;
- p = SkipToNextKey(p);
-
- if (!MatchKey(p, "B ")) return 0;
- p = SkipToNextItem(p);
- sscanf(p, "%hd %hd %hd %hd",
- &(metrics->CharInfo[nchar].BBox[0]),
- &(metrics->CharInfo[nchar].BBox[1]),
- &(metrics->CharInfo[nchar].BBox[2]),
- &(metrics->CharInfo[nchar].BBox[3]));
-
-#ifdef DEBUG_PS2
- Rprintf("nchar = %d %d %d %d %d %d\n", nchar,
- metrics->CharInfo[nchar].WX,
- metrics->CharInfo[nchar].BBox[0],
- metrics->CharInfo[nchar].BBox[1],
- metrics->CharInfo[nchar].BBox[2],
- metrics->CharInfo[nchar].BBox[3]);
-#endif
- if (nchar2 > 0) {
- metrics->CharInfo[nchar2].WX = WX;
- sscanf(p, "%hd %hd %hd %hd",
- &(metrics->CharInfo[nchar2].BBox[0]),
- &(metrics->CharInfo[nchar2].BBox[1]),
- &(metrics->CharInfo[nchar2].BBox[2]),
- &(metrics->CharInfo[nchar2].BBox[3]));
-
-#ifdef DEBUG_PS2
- Rprintf("nchar = %d %d %d %d %d %d\n", nchar2,
- metrics->CharInfo[nchar2].WX,
- metrics->CharInfo[nchar2].BBox[0],
- metrics->CharInfo[nchar2].BBox[1],
- metrics->CharInfo[nchar2].BBox[2],
- metrics->CharInfo[nchar2].BBox[3]);
-#endif
- }
- return 1;
-}
-
-static int GetKPX(char *buf, int nkp, FontMetricInfo *metrics,
- CNAME *charnames)
-{
- char *p = buf, c1[50], c2[50];
- int i, done = 0;
-
- p = SkipToNextItem(p);
- sscanf(p, "%s %s %hd", c1, c2, &(metrics->KernPairs[nkp].kern));
- if (streql(c1, "space") || streql(c2, "space")) return 0;
- for(i = 0; i < 256; i++) {
- if (!strcmp(c1, charnames[i].cname)) {
- metrics->KernPairs[nkp].c1 = (unsigned char) i;
- done++;
- break;
- }
- }
- for(i = 0; i < 256; i++)
- if (!strcmp(c2, charnames[i].cname)) {
- metrics->KernPairs[nkp].c2 = (unsigned char) i;
- done++;
- break;
- }
- return (done==2);
-}
-
-/* Encode File Parsing. */
-/* Statics here are OK, as all the calls are in one initialization
- so no concurrency (until threads?) */
-
-typedef struct {
- /* Probably can make buf and p0 local variables. Only p needs to be
- stored across calls. Need to investigate this more closely. */
- char buf[1000];
- char *p;
- char *p0;
-} EncodingInputState;
-
-/* read in the next encoding item, separated by white space. */
-static int GetNextItem(FILE *fp, char *dest, int c, EncodingInputState *state)
-{
- if (c < 0) state->p = NULL;
- while (1) {
- if (feof(fp)) { state->p = NULL; return 1; }
- if (!state->p || *state->p == '\n' || *state->p == '\0') {
- state->p = fgets(state->buf, 1000, fp);
- }
- /* check for incomplete encoding file */
- if(!state->p) return 1;
- while (isspace((int)* state->p)) state->p++;
- if (state->p == '\0' || *state->p == '%'|| *state->p == '\n') { state->p = NULL; continue; }
- state->p0 = state->p;
- while (!isspace((int)*state->p)) state->p++;
- if (state->p != '\0') *state->p++ = '\0';
- if(c == 45) strcpy(dest, "/minus"); else strcpy(dest, state->p0);
- break;
- }
- return 0;
-}
-
-/*
- * Convert the encoding file name into a name to be used with iconv()
- * in mbcsToSbcs()
- *
- * FIXME: Doesn't trim path/to/encfile (i.e., doesn't handle
- * custom encoding file selected by user).
- * Also assumes that encpath has ".enc" suffix supplied
- * (not required by R interface)
- */
-
-static int pathcmp(const char *encpath, const char *comparison) {
- char pathcopy[PATH_MAX];
- char *p1, *p2;
- strcpy(pathcopy, encpath);
- /*
- * Strip path/to/encfile/
- */
- p1 = &(pathcopy[0]);
- while ((p2 = strchr(p1, FILESEP[0]))) {
- p1 = p2 + sizeof(char);
- }
- /*
- * Strip suffix
- */
- p2 = (strchr(p1, '.'));
- if (p2)
- *p2 = '\0';
- return strcmp(p1, comparison);
-}
-
-static void seticonvName(const char *encpath, char *convname)
-{
- /*
- * Default to "latin1"
- */
- char *p;
- strcpy(convname, "latin1");
- if(pathcmp(encpath, "ISOLatin1")==0)
- strcpy(convname, "latin1");
- else if(pathcmp(encpath, "ISOLatin2")==0)
- strcpy(convname, "latin2");
- else if(pathcmp(encpath, "ISOLatin7")==0)
- strcpy(convname, "latin7");
- else if(pathcmp(encpath, "ISOLatin9")==0)
- strcpy(convname, "latin-9");
- else if (pathcmp(encpath, "WinAnsi")==0)
- strcpy(convname, "CP1252");
- else {
- /*
- * Last resort = trim .enc off encpath to produce convname
- */
- strcpy(convname, encpath);
- p = strrchr(convname, '.');
- if(p) *p = '\0';
- }
-}
-
-/* Load encoding array from a file: defaults to the R_HOME/library/grDevices/afm directory */
-
-/*
- * encpath gives the file to read from
- * encname is filled with the encoding name from the file
- * encconvname is filled with a "translation" of the encoding name into
- * one that can be used with iconv()
- * encnames is filled with the character names from the file
- * enccode is filled with the raw source of the file
- */
-static int
-LoadEncoding(const char *encpath, char *encname,
- char *encconvname, CNAME *encnames,
- char *enccode, Rboolean isPDF)
-{
- char buf[BUFSIZE];
- int i;
- FILE *fp;
- EncodingInputState state;
- state.p = state.p0 = NULL;
-
- seticonvName(encpath, encconvname);
-
- if(strchr(encpath, FILESEP[0])) strcpy(buf, encpath);
- else snprintf(buf, BUFSIZE,"%s%slibrary%sgrDevices%senc%s%s",
- R_Home, FILESEP, FILESEP, FILESEP, FILESEP, encpath);
-#ifdef DEBUG_PS
- Rprintf("encoding path is %s\n", buf);
-#endif
- if (!(fp = R_fopen(R_ExpandFileName(buf), "r"))) {
- strcat(buf, ".enc");
- if (!(fp = R_fopen(R_ExpandFileName(buf), "r"))) return 0;
- }
- if (GetNextItem(fp, buf, -1, &state)) return 0; /* encoding name */
- strcpy(encname, buf+1);
- if (!isPDF) snprintf(enccode, 5000, "/%s [\n", encname);
- else enccode[0] = '\0';
- if (GetNextItem(fp, buf, 0, &state)) { fclose(fp); return 0;} /* [ */
- for(i = 0; i < 256; i++) {
- if (GetNextItem(fp, buf, i, &state)) { fclose(fp); return 0; }
- strcpy(encnames[i].cname, buf+1);
- strcat(enccode, " /"); strcat(enccode, encnames[i].cname);
- if(i%8 == 7) strcat(enccode, "\n");
- }
- if (GetNextItem(fp, buf, 0, &state)) { fclose(fp); return 0;} /* ] */
- fclose(fp);
- if (!isPDF) strcat(enccode,"]\n");
- return 1;
-}
-
-/* Load font metrics from a file: defaults to the
- R_HOME/library/grDevices/afm directory */
-static int
-PostScriptLoadFontMetrics(const char * const fontpath,
- FontMetricInfo *metrics,
- char *fontname,
- CNAME *charnames,
- CNAME *encnames,
- int reencode)
-{
- char buf[BUFSIZE], *p, truth[10];
- int mode, i = 0, j, ii, nKPX=0;
- gzFile fp;
-
- if(strchr(fontpath, FILESEP[0])) strcpy(buf, fontpath);
- else
- snprintf(buf, BUFSIZE,"%s%slibrary%sgrDevices%safm%s%s.gz",
- R_Home, FILESEP, FILESEP, FILESEP, FILESEP, fontpath);
-#ifdef DEBUG_PS
- Rprintf("afmpath is %s\n", buf);
- Rprintf("reencode is %d\n", reencode);
-#endif
-
- if (!(fp = R_gzopen(R_ExpandFileName(buf), "rb"))) {
- /* try uncompressed version */
- snprintf(buf, BUFSIZE,"%s%slibrary%sgrDevices%safm%s%s",
- R_Home, FILESEP, FILESEP, FILESEP, FILESEP, fontpath);
- if (!(fp = R_gzopen(R_ExpandFileName(buf), "rb"))) {
- warning(_("afm file '%s' could not be opened"),
- R_ExpandFileName(buf));
- return 0;
- }
- }
-
- metrics->KernPairs = NULL;
- metrics->CapHeight = metrics->XHeight = metrics->Descender =
- metrics->Ascender = metrics->StemH = metrics->StemV = NA_SHORT;
- metrics->IsFixedPitch = -1;
- metrics->ItalicAngle = 0;
- mode = 0;
- for (ii = 0; ii < 256; ii++) {
- charnames[ii].cname[0] = '\0';
- metrics->CharInfo[ii].WX = NA_SHORT;
- for(j = 0; j < 4; j++) metrics->CharInfo[ii].BBox[j] = 0;
- }
- while (R_gzgets(fp, buf, BUFSIZE)) {
- switch(KeyType(buf)) {
-
- case StartFontMetrics:
- mode = StartFontMetrics;
- break;
-
- case EndFontMetrics:
- mode = 0;
- break;
-
- case FontBBox:
- if (!GetFontBBox(buf, metrics)) {
- warning("'FontBBox' could not be parsed");
- goto pserror;
- }
- break;
-
- case C:
- if (mode != StartFontMetrics) goto pserror;
- if (!GetCharInfo(buf, metrics, charnames, encnames, reencode)) {
- warning("'CharInfo' could not be parsed");
- goto pserror;
- }
- break;
-
- case StartKernData:
- mode = StartKernData;
- break;
-
- case StartKernPairs:
- if(mode != StartKernData) goto pserror;
- p = SkipToNextItem(buf);
- sscanf(p, "%d", &nKPX);
- if(nKPX > 0) {
- /* nPKX == 0 should not happen, but has */
- metrics->KernPairs = (KP *) malloc(nKPX * sizeof(KP));
- if (!metrics->KernPairs) goto pserror;
- }
- break;
-
- case KPX:
- if(mode != StartKernData || i >= nKPX) goto pserror;
- if (GetKPX(buf, i, metrics, charnames)) i++;
- break;
-
- case EndKernData:
- mode = 0;
- break;
-
- case Unknown:
- warning(_("unknown AFM entity encountered"));
- break;
-
- case FontName:
- p = SkipToNextItem(buf);
- sscanf(p, "%[^\n\f\r]", fontname);
- break;
-
- case CapHeight:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->CapHeight);
- break;
-
- case XHeight:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->XHeight);
- break;
-
- case Ascender:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->Ascender);
- break;
-
- case Descender:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->Descender);
- break;
-
- case StdHW:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->StemH);
- break;
-
- case StdVW:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->StemV);
- break;
-
- case ItalicAngle:
- p = SkipToNextItem(buf);
- sscanf(p, "%hd", &metrics->ItalicAngle);
- break;
-
- case IsFixedPitch:
- p = SkipToNextItem(buf);
- sscanf(p, "%[^\n\f\r]", truth);
- metrics->IsFixedPitch = strcmp(truth, "true") == 0;
- break;
-
- case Empty:
- default:
- break;
- }
- }
- metrics->nKP = (short) i;
- R_gzclose(fp);
- /* Make an index for kern-pair searches: relies on having contiguous
- blocks by first char for efficiency, but works in all cases. */
- {
- short ind, tmp;
- for (j = 0; j < 256; j++) {
- metrics->KPstart[j] = (short) i;
- metrics->KPend[j] = 0;
- }
- for (j = 0; j < i; j++) {
- ind = metrics->KernPairs[j].c1;
- tmp = metrics->KPstart[ind];
- if(j < tmp) metrics->KPstart[ind] = (short) j;
- tmp = metrics->KPend[ind];
- if(j > tmp) metrics->KPend[ind] = (short) j;
- }
- }
- return 1;
-pserror:
- R_gzclose(fp);
- return 0;
-}
-
-
-extern int Ri18n_wcwidth(wchar_t c);
-
-
-static double
- PostScriptStringWidth(const unsigned char *str, int enc,
- FontMetricInfo *metrics,
- Rboolean useKerning,
- int face, const char *encoding)
-{
- int sum = 0, i;
- short wx;
- const unsigned char *p = NULL, *str1 = str;
- unsigned char p1, p2;
-
- int status;
- if(!metrics && (face % 5) != 0) {
- /* This is the CID font case, and should only happen for
- non-symbol fonts. So we assume monospaced with multipliers.
- We need to remap even if we are in a SBCS, should we get to here */
- size_t ucslen;
- ucslen = mbcsToUcs2((char *)str, NULL, 0, enc);
- if (ucslen != (size_t)-1) {
- /* We convert the characters but not the terminator here */
- R_CheckStack2(ucslen * sizeof(ucs2_t));
- ucs2_t ucs2s[ucslen];
- status = (int) mbcsToUcs2((char *)str, ucs2s, (int) ucslen, enc);
- if (status >= 0)
- for(i = 0 ; i < ucslen ; i++) {
- wx = (short)(500 * Ri18n_wcwidth(ucs2s[i]));
- /* printf("width for U+%04x is %d\n", ucs2s[i], wx); */
- sum += wx;
- }
- else
- warning(_("invalid string in '%s'"), "PostScriptStringWidth");
- return 0.001 * sum;
- } else {
- warning(_("invalid string in '%s'"), "PostScriptStringWidth");
- return 0.0;
- }
- } else
- if(!strIsASCII((char *) str) &&
- /*
- * Every fifth font is a symbol font:
- * see postscriptFonts()
- */
- (face % 5) != 0) {
- R_CheckStack2(strlen((char *)str)+1);
- char buff[strlen((char *)str)+1];
- /* Output string cannot be longer */
- mbcsToSbcs((char *)str, buff, encoding, enc);
- str1 = (unsigned char *)buff;
- }
-
- /* safety */
- if(!metrics) return 0.0;
-
-
- /* Now we know we have an 8-bit encoded string in the encoding to
- be used for output. */
- for (p = str1; *p; p++) {
-#ifdef USE_HYPHEN
- if (*p == '-' && !isdigit(p[1]))
- wx = metrics->CharInfo[(int)PS_hyphen].WX;
- else
-#endif
- wx = metrics->CharInfo[*p].WX;
- if(wx == NA_SHORT)
- warning(_("font width unknown for character 0x%x"), *p);
- else sum += wx;
-
- if(useKerning) {
- /* check for kerning adjustment */
- p1 = p[0]; p2 = p[1];
- for (i = metrics->KPstart[p1]; i < metrics->KPend[p1]; i++)
- /* second test is a safety check: should all start with p1 */
- if(metrics->KernPairs[i].c2 == p2 &&
- metrics->KernPairs[i].c1 == p1) {
- sum += metrics->KernPairs[i].kern;
- break;
- }
- }
- }
- return 0.001 * sum;
-}
-
-
-/* Be careful about the assumptions here. In an 8-bit locale 0 <= c < 256
- and it is in the encoding in use. As it is not going to be
- re-encoded when text is output, it is correct not to re-encode here.
-
- When called in an MBCS locale and font != 5, chars < 128 are sent
- as is (we assume that is ASCII) and others are re-encoded to
- Unicode in GEText (and interpreted as Unicode in GESymbol).
-*/
-# ifdef WORDS_BIGENDIAN
-static const char UCS2ENC[] = "UCS-2BE";
-# else
-static const char UCS2ENC[] = "UCS-2LE";
-# endif
-
-static void
-PostScriptMetricInfo(int c, double *ascent, double *descent, double *width,
- FontMetricInfo *metrics,
- Rboolean isSymbol,
- const char *encoding)
-{
- Rboolean Unicode = mbcslocale;
-
- if (c == 0) {
- *ascent = 0.001 * metrics->FontBBox[3];
- *descent = -0.001 * metrics->FontBBox[1];
- *width = 0.001 * (metrics->FontBBox[2] - metrics->FontBBox[0]);
- return;
- }
-
- if (c < 0) { Unicode = TRUE; c = -c; }
- /* We don't need the restriction to 65536 here any more as we could
- convert from UCS4ENC, but there are few language chars above 65536. */
- if(Unicode && !isSymbol && c >= 128 && c < 65536) { /* Unicode */
- void *cd = NULL;
- const char *i_buf; char *o_buf, out[2];
- size_t i_len, o_len, status;
- unsigned short w[2];
-
- if ((void*)-1 == (cd = Riconv_open(encoding, UCS2ENC)))
- error(_("unknown encoding '%s' in 'PostScriptMetricInfo'"),
- encoding);
-
- /* Here we use terminated strings, but could use one char */
- w[0] = (unsigned short) c; w[1] = 0;
- i_buf = (char *)w;
- i_len = 4;
- o_buf = out;
- o_len = 2;
- status = Riconv(cd, &i_buf, (size_t *)&i_len,
- (char **)&o_buf, (size_t *)&o_len);
- Riconv_close(cd);
- if (status == (size_t)-1) {
- *ascent = 0;
- *descent = 0;
- *width = 0;
- warning(_("font metrics unknown for Unicode character U+%04x"), c);
- return;
- } else {
- c = out[0] & 0xff;
- }
- }
-
- if (c > 255) { /* Unicode */
- *ascent = 0;
- *descent = 0;
- *width = 0;
- warning(_("font metrics unknown for Unicode character U+%04x"), c);
- } else {
- short wx;
-
- *ascent = 0.001 * metrics->CharInfo[c].BBox[3];
- *descent = -0.001 * metrics->CharInfo[c].BBox[1];
- wx = metrics->CharInfo[c].WX;
- if(wx == NA_SHORT) {
- warning(_("font metrics unknown for character 0x%x"), c);
- wx = 0;
- }
- *width = 0.001 * wx;
- }
-}
-
-static void
-PostScriptCIDMetricInfo(int c, double *ascent, double *descent, double *width)
-{
- /* calling in a SBCS is probably not intentional, but we should try to
- cope sensibly. */
- if(!mbcslocale && c > 0) {
- if (c > 255)
- error(_("invalid character (%04x) sent to 'PostScriptCIDMetricInfo' in a single-byte locale"),
- c);
- else {
- /* convert to UCS-2 to use wcwidth. */
- char str[2]={0,0};
- ucs2_t out;
- str[0] = (char) c;
- if(mbcsToUcs2(str, &out, 1, CE_NATIVE) == (size_t)-1)
- error(_("invalid character sent to 'PostScriptCIDMetricInfo' in a single-byte locale"));
- c = out;
- }
- }
-
- /* Design values for all CJK fonts */
- *ascent = 0.880;
- *descent = -0.120;
- if (c == 0 || c > 65535) *width = 1.; else *width = 0.5*Ri18n_wcwidth(c);
-}
-
-
-/*******************************************************
- * Data structures and functions for loading Type 1 fonts into an R session.
- *
- * Used by PostScript, XFig and PDF drivers.
- *
- * The idea is that font information is only loaded once for each font
- * within an R session. Also, each encoding is only loaded once per
- * session. A global list of loaded fonts and a global list of
- * loaded encodings are maintained. Devices maintain their own list
- * of fonts and encodings used on the device; the elements of these
- * lists are just pointers to the elements of the global lists.
- *
- * Cleaning up device lists just involves free'ing the lists themselves.
- * When the R session closes, the actual font and encoding information
- * is unloaded using the global lists.
- */
-
-/*
- * Information about one Type 1 font
- */
-typedef struct CIDFontInfo {
- char name[50];
-} CIDFontInfo, *cidfontinfo;
-
-typedef struct T1FontInfo {
- char name[50];
- FontMetricInfo metrics;
- CNAME charnames[256];
-} Type1FontInfo, *type1fontinfo;
-
-/*
- * Information about a font encoding
- */
-typedef struct EncInfo {
- char encpath[PATH_MAX];
- char name[100]; /* Name written to PostScript/PDF file */
- char convname[50]; /* Name used in mbcsToSbcs() with iconv() */
- CNAME encnames[256];
- char enccode[5000];
-} EncodingInfo, *encodinginfo;
-
-/*
- * Information about a font family
- * (5 fonts representing plain, bold, italic, bolditalic, and symbol)
- *
- * The name is a graphics engine font family name
- * (distinct from the Type 1 font name)
- */
-typedef struct CIDFontFamily {
- char fxname[50];
- cidfontinfo cidfonts[4];
- type1fontinfo symfont;
- char cmap[50];
- char encoding[50];
-} CIDFontFamily, *cidfontfamily;
-
-typedef struct T1FontFamily {
- char fxname[50];
- type1fontinfo fonts[5];
- encodinginfo encoding;
-} Type1FontFamily, *type1fontfamily;
-
-/*
- * A list of Type 1 font families
- *
- * Used to keep track of fonts currently loaded in the session
- * AND by each device to keep track of fonts currently used on the device.
- */
-typedef struct CIDFontList {
- cidfontfamily cidfamily;
- struct CIDFontList *next;
-} CIDFontList, *cidfontlist;
-
-typedef struct T1FontList {
- type1fontfamily family;
- struct T1FontList *next;
-} Type1FontList, *type1fontlist;
-
-/*
- * Same as type 1 font list, but for encodings.
- */
-typedef struct EncList {
- encodinginfo encoding;
- struct EncList *next;
-} EncodingList, *encodinglist;
-
-/*
- * Various constructors and destructors
- */
-static cidfontinfo makeCIDFont()
-{
- cidfontinfo font = (CIDFontInfo *) malloc(sizeof(CIDFontInfo));
- if (!font)
- warning(_("failed to allocate CID font info"));
- return font;
-}
-
-static type1fontinfo makeType1Font()
-{
- type1fontinfo font = (Type1FontInfo *) malloc(sizeof(Type1FontInfo));
- /*
- * Initialise font->metrics.KernPairs to NULL
- * so that we know NOT to free it if we fail to
- * load this font and have to
- * bail out and free this type1fontinfo
- */
- font->metrics.KernPairs = NULL;
- if (!font)
- warning(_("failed to allocate Type 1 font info"));
- return font;
-}
-
-static void freeCIDFont(cidfontinfo font)
-{
- free(font);
-}
-
-static void freeType1Font(type1fontinfo font)
-{
- if (font->metrics.KernPairs)
- free(font->metrics.KernPairs);
- free(font);
-}
-
-static encodinginfo makeEncoding()
-{
- encodinginfo encoding = (EncodingInfo *) malloc(sizeof(EncodingInfo));
- if (!encoding)
- warning(_("failed to allocate encoding info"));
- return encoding;
-}
-
-static void freeEncoding(encodinginfo encoding)
-{
- free(encoding);
-}
-
-static cidfontfamily makeCIDFontFamily()
-{
- cidfontfamily family = (CIDFontFamily *) malloc(sizeof(CIDFontFamily));
- if (family) {
- int i;
- for (i = 0; i < 4; i++)
- family->cidfonts[i] = NULL;
- family->symfont = NULL;
- } else
- warning(_("failed to allocate CID font family"));
- return family;
-}
-
-static type1fontfamily makeFontFamily()
-{
- type1fontfamily family = (Type1FontFamily *) malloc(sizeof(Type1FontFamily));
- if (family) {
- int i;
- for (i = 0; i < 5; i++)
- family->fonts[i] = NULL;
- family->encoding = NULL;
- } else
- warning(_("failed to allocate Type 1 font family"));
- return family;
-}
-/*
- * Frees a font family, including fonts, but NOT encoding
- *
- * Used by global font list to free all fonts loaded in session
- * (should not be used by devices; else may free fonts more than once)
- *
- * Encodings are freed using the global encoding list
- * (to ensure that each encoding is only freed once)
- */
-static void freeCIDFontFamily(cidfontfamily family)
-{
- int i;
- for (i = 0; i < 4; i++)
- if (family->cidfonts[i])
- freeCIDFont(family->cidfonts[i]);
- if (family->symfont)
- freeType1Font(family->symfont);
- free(family);
-}
-
-static void freeFontFamily(type1fontfamily family)
-{
- int i;
- for (i=0; i<5; i++)
- if (family->fonts[i])
- freeType1Font(family->fonts[i]);
- free(family);
-}
-
-static cidfontlist makeCIDFontList()
-{
- cidfontlist fontlist = (CIDFontList *) malloc(sizeof(CIDFontList));
- if (fontlist) {
- fontlist->cidfamily = NULL;
- fontlist->next = NULL;
- } else
- warning(_("failed to allocate font list"));
- return fontlist;
-}
-
-static type1fontlist makeFontList()
-{
- type1fontlist fontlist = (Type1FontList *) malloc(sizeof(Type1FontList));
- if (fontlist) {
- fontlist->family = NULL;
- fontlist->next = NULL;
- } else
- warning(_("failed to allocate font list"));
- return fontlist;
-}
-
-/*
- * Just free the Type1FontList structure, do NOT free elements it points to
- *
- * Used by both global font list and devices to free the font lists
- * (global font list separately takes care of the fonts pointed to)
- */
-static void freeCIDFontList(cidfontlist fontlist) {
- /*
- * These will help to find any errors if attempt to
- * use freed font list.
- */
- fontlist->cidfamily = NULL;
- fontlist->next = NULL;
- free(fontlist);
-}
-static void freeFontList(type1fontlist fontlist) {
- /*
- * These will help to find any errors if attempt to
- * use freed font list.
- */
- fontlist->family = NULL;
- fontlist->next = NULL;
- free(fontlist);
-}
-
-static void freeDeviceCIDFontList(cidfontlist fontlist) {
- if (fontlist) {
- if (fontlist->next)
- freeDeviceCIDFontList(fontlist->next);
- freeCIDFontList(fontlist);
- }
-}
-static void freeDeviceFontList(type1fontlist fontlist) {
- if (fontlist) {
- if (fontlist->next)
- freeDeviceFontList(fontlist->next);
- freeFontList(fontlist);
- }
-}
-
-static encodinglist makeEncList()
-{
- encodinglist enclist = (EncodingList *) malloc(sizeof(EncodingList));
- if (enclist) {
- enclist->encoding = NULL;
- enclist->next = NULL;
- } else
- warning(_("failed to allocated encoding list"));
- return enclist;
-}
-
-static void freeEncList(encodinglist enclist)
-{
- enclist->encoding = NULL;
- enclist->next = NULL;
- free(enclist);
-}
-
-static void freeDeviceEncList(encodinglist enclist) {
- if (enclist) {
- if (enclist->next)
- freeDeviceEncList(enclist->next);
- freeEncList(enclist);
- }
-}
-
-/*
- * Global list of fonts and encodings that have been loaded this session
- */
-static cidfontlist loadedCIDFonts = NULL;
-static type1fontlist loadedFonts = NULL;
-static encodinglist loadedEncodings = NULL;
-/*
- * There are separate PostScript and PDF font databases at R level
- * so MUST have separate C level records too
- * (because SAME device-independent font family name could map
- * to DIFFERENT font for PostScript and PDF)
- */
-static cidfontlist PDFloadedCIDFonts = NULL;
-static type1fontlist PDFloadedFonts = NULL;
-static encodinglist PDFloadedEncodings = NULL;
-
-/*
- * Names of R level font databases
- */
-static char PostScriptFonts[] = ".PostScript.Fonts";
-static char PDFFonts[] = ".PDF.Fonts";
-
-/*
- * Free the above globals
- *
- * NOTE that freeing the font families does NOT free the encodings
- * Hence we free all encodings first.
- */
-
-/* NB this is exported, and was at some point used by KillAllDevices
- in src/main/graphics.c. That would be a problem now it is in a
- separate DLL.
-*/
-#if 0
-void freeType1Fonts()
-{
- encodinglist enclist = loadedEncodings;
- type1fontlist fl = loadedFonts;
- cidfontlist cidfl = loadedCIDFonts;
- type1fontlist pdffl = PDFloadedFonts;
- cidfontlist pdfcidfl = PDFloadedCIDFonts;
- while (enclist) {
- enclist = enclist->next;
- freeEncoding(loadedEncodings->encoding);
- freeEncList(loadedEncodings);
- loadedEncodings = enclist;
- }
- while (fl) {
- fl = fl->next;
- freeFontFamily(loadedFonts->family);
- freeFontList(loadedFonts);
- loadedFonts = fl;
- }
- while (cidfl) {
- cidfl = cidfl->next;
- freeCIDFontFamily(loadedCIDFonts->cidfamily);
- freeCIDFontList(loadedCIDFonts);
- loadedCIDFonts = cidfl;
- }
- while (pdffl) {
- pdffl = pdffl->next;
- freeFontFamily(PDFloadedFonts->family);
- freeFontList(PDFloadedFonts);
- PDFloadedFonts = pdffl;
- }
- while (pdfcidfl) {
- pdfcidfl = pdfcidfl->next;
- freeCIDFontFamily(PDFloadedCIDFonts->cidfamily);
- freeCIDFontList(PDFloadedCIDFonts);
- PDFloadedCIDFonts = pdfcidfl;
- }
-}
-#endif
-
-/*
- * Given a path to an encoding file,
- * find an EncodingInfo that corresponds
- */
-static encodinginfo
-findEncoding(const char *encpath, encodinglist deviceEncodings, Rboolean isPDF)
-{
- encodinglist enclist = isPDF ? PDFloadedEncodings : loadedEncodings;
- encodinginfo encoding = NULL;
- int found = 0;
- /*
- * "default" is a special encoding which means use the
- * default (FIRST) encoding set up ON THIS DEVICE.
- */
- if (!strcmp(encpath, "default")) {
- found = 1;
- encoding = deviceEncodings->encoding;
- } else {
- while (enclist && !found) {
- found = !strcmp(encpath, enclist->encoding->encpath);
- if (found)
- encoding = enclist->encoding;
- enclist = enclist->next;
- }
- }
- return encoding;
-}
-
-/*
- * Find an encoding in device encoding list
- */
-static encodinginfo
-findDeviceEncoding(const char *encpath, encodinglist enclist, int *index)
-{
- encodinginfo encoding = NULL;
- int found = 0;
- *index = 0;
- while (enclist && !found) {
- found = !strcmp(encpath, enclist->encoding->encpath);
- if (found)
- encoding = enclist->encoding;
- enclist = enclist->next;
- *index = *index + 1;
- }
- return encoding;
-}
-
-/*
- * Utility to avoid string overrun
- */
-static void safestrcpy(char *dest, const char *src, int maxlen)
-{
- if (strlen(src) < maxlen)
- strcpy(dest, src);
- else {
- warning(_("truncated string which was too long for copy"));
- strncpy(dest, src, maxlen-1);
- dest[maxlen-1] = '\0';
- }
-}
-
-/*
- * Add an encoding to the list of loaded encodings ...
- *
- * ... and return the new encoding
- */
-static encodinginfo addEncoding(const char *encpath, Rboolean isPDF)
-{
- encodinginfo encoding = makeEncoding();
- if (encoding) {
- if (LoadEncoding(encpath,
- encoding->name,
- encoding->convname,
- encoding->encnames,
- encoding->enccode,
- isPDF)) {
- encodinglist newenc = makeEncList();
- if (!newenc) {
- freeEncoding(encoding);
- encoding = NULL;
- } else {
- encodinglist enclist =
- isPDF ? PDFloadedEncodings : loadedEncodings;
- safestrcpy(encoding->encpath, encpath, PATH_MAX);
- newenc->encoding = encoding;
- if (!enclist) {
- if(isPDF) PDFloadedEncodings = newenc;
- else loadedEncodings = newenc;
- } else {
- while (enclist->next)
- enclist = enclist->next;
- enclist->next = newenc;
- }
- }
- } else {
- warning(_("failed to load encoding file '%s'"), encpath);
- freeEncoding(encoding);
- encoding = NULL;
- }
- } else
- encoding = NULL;
- return encoding;
-}
-
-/*
- * Add an encoding to a list of device encodings ...
- *
- * ... and return the new list
- */
-static encodinglist addDeviceEncoding(encodinginfo encoding,
- encodinglist devEncs)
-{
- encodinglist newenc = makeEncList();
- if (!newenc) {
- devEncs = NULL;
- } else {
- encodinglist enclist = devEncs;
- newenc->encoding = encoding;
- if (!devEncs)
- devEncs = newenc;
- else {
- while (enclist->next)
- enclist = enclist->next;
- enclist->next = newenc;
- }
- }
- return devEncs;
-}
-
-/*
- * Given a graphics engine font family name,
- * find a Type1FontFamily that corresponds
- *
- * If get fxname match, check whether the encoding in the
- * R database is "default"
- * (i.e., the graphics engine font family encoding is unspecified)
- * If it is "default" then check that the loaded encoding is the
- * same as the encoding we want. A matching encoding is defined
- * as one which leads to the same iconvname (see seticonvName()).
- * This could perhaps be made more rigorous by actually looking inside
- * the relevant encoding file for the encoding name.
- *
- * If the encoding we want is NULL, then we just don't care.
- *
- * Returns NULL if can't find font in loadedFonts
- */
-
-static const char *getFontEncoding(const char *family, const char *fontdbname);
-
-static type1fontfamily
-findLoadedFont(const char *name, const char *encoding, Rboolean isPDF)
-{
- type1fontlist fontlist;
- type1fontfamily font = NULL;
- char *fontdbname;
- int found = 0;
-
- if (isPDF) {
- fontlist = PDFloadedFonts;
- fontdbname = PDFFonts;
- } else {
- fontlist = loadedFonts;
- fontdbname = PostScriptFonts;
- }
- while (fontlist && !found) {
- found = !strcmp(name, fontlist->family->fxname);
- if (found) {
- font = fontlist->family;
- if (encoding) {
- char encconvname[50];
- const char *encname = getFontEncoding(name, fontdbname);
- seticonvName(encoding, encconvname);
- if (!strcmp(encname, "default") &&
- strcmp(fontlist->family->encoding->convname,
- encconvname)) {
- font = NULL;
- found = 0;
- }
- }
- }
- fontlist = fontlist->next;
- }
- return font;
-}
-
-SEXP Type1FontInUse(SEXP name, SEXP isPDF)
-{
- if (!isString(name) || LENGTH(name) > 1)
- error(_("invalid font name or more than one font name"));
- return ScalarLogical(
- findLoadedFont(CHAR(STRING_ELT(name, 0)), NULL, asLogical(isPDF))
- != NULL);
-}
-
-static cidfontfamily findLoadedCIDFont(const char *family, Rboolean isPDF)
-{
- cidfontlist fontlist;
- cidfontfamily font = NULL;
- int found = 0;
-
- if (isPDF) {
- fontlist = PDFloadedCIDFonts;
- } else {
- fontlist = loadedCIDFonts;
- }
- while (fontlist && !found) {
- found = !strcmp(family, fontlist->cidfamily->cidfonts[0]->name);
- if (found)
- font = fontlist->cidfamily;
- fontlist = fontlist->next;
- }
-#ifdef PS_DEBUG
- if(found)
- Rprintf("findLoadedCIDFont found = %s\n",family);
-#endif
- return font;
-}
-
-SEXP CIDFontInUse(SEXP name, SEXP isPDF)
-{
- if (!isString(name) || LENGTH(name) > 1)
- error(_("invalid font name or more than one font name"));
- return ScalarLogical(
- findLoadedCIDFont(CHAR(STRING_ELT(name, 0)), asLogical(isPDF))
- != NULL);
-}
-
-/*
- * Find a font in device font list
- */
-static cidfontfamily
-findDeviceCIDFont(const char *name, cidfontlist fontlist, int *index)
-{
- cidfontfamily font = NULL;
- int found = 0;
- *index = 0;
- /*
- * If the graphics engine font family is ""
- * just use the default font that was loaded when the device
- * was created.
- * This will (MUST) be the first font in the device
- */
-#ifdef DEBUG_PS
- Rprintf("findDeviceCIDFont=%s\n", name);
- Rprintf("? cidfontlist %s\n", (fontlist) ? "found" : "not found");
-#endif
-
- if (strlen(name) > 0) {
- while (fontlist && !found) {
-#ifdef DEBUG_PS
- Rprintf("findDeviceCIDFont=%s\n", name);
- Rprintf("findDeviceCIDFont fontlist->cidfamily->name=%s\n",
- fontlist->cidfamily->fxname);
-#endif
-
- found = !strcmp(name, fontlist->cidfamily->fxname);
- if (found)
- font = fontlist->cidfamily;
- fontlist = fontlist->next;
- *index = *index + 1;
- }
- } else {
- font = fontlist->cidfamily;
- *index = 1;
- }
-#ifdef DEBUG_PS
- Rprintf("findDeviceCIDFont find index=%d\n", *index);
- Rprintf("findDeviceCIDFont find font=%s\n", (font) ? "Found" : "NULL");
-#endif
- return font;
-}
-
-/*
- * Must only be called once a device has at least one font added
- * (i.e., after the default font has been added)
- */
-static type1fontfamily
-findDeviceFont(const char *name, type1fontlist fontlist, int *index)
-{
- type1fontfamily font = NULL;
- int found = 0;
- *index = 0;
- /*
- * If the graphics engine font family is ""
- * just use the default font that was loaded when the device
- * was created.
- * This will (MUST) be the first font in the device
- */
- if (strlen(name) > 0) {
- while (fontlist && !found) {
- found = !strcmp(name, fontlist->family->fxname);
- if (found)
- font = fontlist->family;
- fontlist = fontlist->next;
- *index = *index + 1;
- }
- } else {
- font = fontlist->family;
- *index = 1;
- }
- return font;
-}
-
-/*
- * Get an R-level font database
- */
-static SEXP getFontDB(const char *fontdbname) {
- SEXP graphicsNS, PSenv;
- SEXP fontdb;
- PROTECT(graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices"))));
- PROTECT(PSenv = findVar(install(".PSenv"), graphicsNS));
- /* under lazy loading this will be a promise on first use */
- if(TYPEOF(PSenv) == PROMSXP) {
- PROTECT(PSenv);
- PSenv = eval(PSenv, graphicsNS);
- UNPROTECT(1);
- }
- PROTECT(fontdb = findVar(install(fontdbname), PSenv));
- UNPROTECT(3);
- return fontdb;
-}
-
-/*
- * Get an R-level font object
- */
-static SEXP getFont(const char *family, const char *fontdbname) {
- int i, nfonts;
- SEXP result = R_NilValue;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- SEXP fontnames;
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- result = VECTOR_ELT(fontdb, i);
- }
- }
- if (!found)
- warning(_("font family '%s' not found in PostScript font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Get the path to the afm file for a user-specifed font
- * given a graphics engine font family and the face
- * index (0..4)
- *
- * Do this by looking up the font name in the PostScript
- * font database
- */
-static const char*
-fontMetricsFileName(const char *family, int faceIndex,
- const char *fontdbname)
-{
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- SEXP fontnames;
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i = 0; i < nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 1 means vector of font afm file paths */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 1),
- faceIndex));
- }
- }
- if (!found)
- warning(_("font family '%s' not found in PostScript font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-static const char *getFontType(const char *family, const char *fontdbname)
-{
- return CHAR(STRING_ELT(getAttrib(getFont(family, fontdbname),
- R_ClassSymbol), 0));
-}
-
-static Rboolean isType1Font(const char *family, const char *fontdbname,
- type1fontfamily defaultFont)
-{
- /*
- * If family is "" then we're referring to the default device
- * font, so the test is just whether the default font is
- * type1
- *
- * If loading font, send NULL for defaultFont
- */
- if (strlen(family) == 0) {
- if (defaultFont)
- return TRUE;
- else
- return FALSE;
- } else
- return !strcmp(getFontType(family, fontdbname),
- "Type1Font");
-}
-
-static Rboolean isCIDFont(const char *family, const char *fontdbname,
- cidfontfamily defaultCIDFont) {
- /*
- * If family is "" then we're referring to the default device
- * font, so the test is just whether the default font is
- * type1
- *
- * If loading font, send NULL for defaultCIDFont
- */
- if (strlen(family) == 0) {
- if (defaultCIDFont)
- return TRUE;
- else
- return FALSE;
- } else
- return !strcmp(getFontType(family, fontdbname),
- "CIDFont");
-}
-
-/*
- * Get encoding name from font database
- */
-static const char *getFontEncoding(const char *family, const char *fontdbname)
-{
- SEXP fontnames;
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 2 means 'encoding' element */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 2), 0));
- }
- }
- if (!found)
- warning(_("font encoding for family '%s' not found in font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Get Font name from font database
- */
-static const char *getFontName(const char *family, const char *fontdbname)
-{
- SEXP fontnames;
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 0 means 'family' element */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 0), 0));
- }
- }
- if (!found)
- warning(_("font CMap for family '%s' not found in font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Get CMap name from font database
- */
-static const char *getFontCMap(const char *family, const char *fontdbname)
-{
- SEXP fontnames;
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 2 means 'cmap' element */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 2), 0));
- }
- }
- if (!found)
- warning(_("font CMap for family '%s' not found in font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Get Encoding name from CID font in font database
- */
-static const char *
-getCIDFontEncoding(const char *family, const char *fontdbname)
-{
- SEXP fontnames;
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(fontdbname);
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 3 means 'encoding' element */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 3), 0));
- }
- }
- if (!found)
- warning(_("font encoding for family '%s' not found in font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Get Encoding name from CID font in font database
- */
-static const char *getCIDFontPDFResource(const char *family)
-{
- SEXP fontnames;
- int i, nfonts;
- const char *result = NULL;
- int found = 0;
- SEXP fontdb = getFontDB(PDFFonts);
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- for (i=0; i<nfonts && !found; i++) {
- const char *fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- /* 4 means 'pdfresource' element */
- result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 4), 0));
- }
- }
- if (!found)
- warning(_("font encoding for family '%s' not found in font database"),
- family);
- UNPROTECT(1);
- return result;
-}
-
-/*
- * Add a graphics engine font family/encoding to the list of loaded fonts ...
- *
- * ... and return the new font
- */
-static cidfontfamily addLoadedCIDFont(cidfontfamily font, Rboolean isPDF)
-{
- cidfontlist newfont = makeCIDFontList();
- if (!newfont) {
- freeCIDFontFamily(font);
- font = NULL;
- } else {
- cidfontlist fontlist;
- if (isPDF)
- fontlist = PDFloadedCIDFonts;
- else
- fontlist = loadedCIDFonts;
- newfont->cidfamily = font;
- if (!fontlist) {
- if (isPDF)
- PDFloadedCIDFonts = newfont;
- else
- loadedCIDFonts = newfont;
- } else {
- while (fontlist->next)
- fontlist = fontlist->next;
- fontlist->next = newfont;
- }
- }
- return font;
-}
-static type1fontfamily addLoadedFont(type1fontfamily font,
- Rboolean isPDF)
-{
- type1fontlist newfont = makeFontList();
- if (!newfont) {
- freeFontFamily(font);
- font = NULL;
- } else {
- type1fontlist fontlist;
- if (isPDF)
- fontlist = PDFloadedFonts;
- else
- fontlist = loadedFonts;
- newfont->family = font;
- if (!fontlist) {
- if (isPDF)
- PDFloadedFonts = newfont;
- else
- loadedFonts = newfont;
- } else {
- while (fontlist->next)
- fontlist = fontlist->next;
- fontlist->next = newfont;
- }
- }
- return font;
-}
-
-/*
- * Add a font from a graphics engine font family name
- */
-static cidfontfamily addCIDFont(const char *name, Rboolean isPDF)
-{
- cidfontfamily fontfamily = makeCIDFontFamily();
- char *fontdbname;
- if (isPDF)
- fontdbname = PDFFonts;
- else
- fontdbname = PostScriptFonts;
- if (fontfamily) {
- int i;
- const char *cmap = getFontCMap(name, fontdbname);
- if (!cmap) {
- freeCIDFontFamily(fontfamily);
- fontfamily = NULL;
- } else {
- /*
- * Set the name of the font
- */
- safestrcpy(fontfamily->fxname, name, 50);
- /*
- * Get the font CMap
- */
- safestrcpy(fontfamily->cmap, cmap, 50);
- /*
- * Get the font Encoding (name)
- *
- * If we have got here then we know there is a
- * match in the font database because we already
- * have the CMap => don't need to check for failure
- */
- safestrcpy(fontfamily->encoding,
- getCIDFontEncoding(name, fontdbname), 50);
- /*
- * Load font info
- */
- for(i = 0; i < 4; i++) {
- fontfamily->cidfonts[i] = makeCIDFont();
- /*
- * Use name from R object font database.
- */
- safestrcpy(fontfamily->cidfonts[i]->name,
- getFontName(name, fontdbname), 50);
- }
- /*
- * Load the (Type 1!) symbol font
- *
- * Gratuitous loop of length 1 so "break" jumps to end of loop
- */
- for (i = 0; i < 1; i++) {
- type1fontinfo font = makeType1Font();
- const char *afmpath = fontMetricsFileName(name, 4, fontdbname);
- if (!font) {
- freeCIDFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- if (!afmpath) {
- freeCIDFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- fontfamily->symfont = font;
- if (!PostScriptLoadFontMetrics(afmpath,
- &(fontfamily->symfont->metrics),
- fontfamily->symfont->name,
- fontfamily->symfont->charnames,
- /*
- * Reencode all but
- * symbol face
- */
- NULL, 0)) {
- warning(_("cannot load afm file '%s'"), afmpath);
- freeCIDFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- }
- /*
- * Add font
- */
- if (fontfamily)
- fontfamily = addLoadedCIDFont(fontfamily, isPDF);
- }
- } else
- fontfamily = NULL;
-#ifdef DEBUG_PS
- Rprintf("%d fontfamily = %s\n", __LINE__, (fontfamily) ? "set" : "null");
- Rprintf("%d addCIDFont = %s\n", __LINE__, fontfamily->fxname);
-#endif
- return fontfamily;
-}
-
-static type1fontfamily addFont(const char *name, Rboolean isPDF,
- encodinglist deviceEncodings)
-{
- type1fontfamily fontfamily = makeFontFamily();
- char *fontdbname;
- if (isPDF)
- fontdbname = PDFFonts;
- else
- fontdbname = PostScriptFonts;
- if (fontfamily) {
- int i;
- encodinginfo encoding;
- const char *encpath = getFontEncoding(name, fontdbname);
- if (!encpath) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- } else {
- /*
- * Set the name of the font
- */
- safestrcpy(fontfamily->fxname, name, 50);
- /*
- * Find or add encoding
- */
- if (!(encoding = findEncoding(encpath, deviceEncodings, isPDF)))
- encoding = addEncoding(encpath, isPDF);
- if (!encoding) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- } else {
- /*
- * Load font info
- */
- fontfamily->encoding = encoding;
- for(i = 0; i < 5 ; i++) {
- type1fontinfo font = makeType1Font();
- const char *afmpath = fontMetricsFileName(name, i, fontdbname);
- if (!font) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- if (!afmpath) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- fontfamily->fonts[i] = font;
- if (!PostScriptLoadFontMetrics(afmpath,
- &(fontfamily->fonts[i]->metrics),
- fontfamily->fonts[i]->name,
- fontfamily->fonts[i]->charnames,
- /*
- * Reencode all but
- * symbol face
- */
- encoding->encnames,
- (i < 4)?1:0)) {
- warning(_("cannot load afm file '%s'"), afmpath);
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- }
- /*
- * Add font
- */
- if (fontfamily)
- fontfamily = addLoadedFont(fontfamily, isPDF);
- }
- }
- } else
- fontfamily = NULL;
- return fontfamily;
-}
-
-/*
- * Add a default font family/encoding to the list of loaded fonts ...
- *
- * ... using a set of AFM paths ...
- *
- * ... and return the new font
- */
-
-static type1fontfamily
-addDefaultFontFromAFMs(const char *encpath, const char **afmpaths,
- Rboolean isPDF,
- encodinglist deviceEncodings)
-{
- encodinginfo encoding;
- type1fontfamily fontfamily = makeFontFamily();
- if (fontfamily) {
- int i;
- if (!(encoding = findEncoding(encpath, deviceEncodings, isPDF)))
- encoding = addEncoding(encpath, isPDF);
- if (!encoding) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- } else {
- /*
- * This is the device default font, so set the
- * graphics engine font family name to ""
- */
- fontfamily->fxname[0] ='\0';
- /*
- * Load font info
- */
- fontfamily->encoding = encoding;
- for(i = 0; i < 5 ; i++) {
- type1fontinfo font = makeType1Font();
- if (!font) {
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- fontfamily->fonts[i] = font;
- if (!PostScriptLoadFontMetrics(afmpaths[i],
- &(fontfamily->fonts[i]->metrics),
- fontfamily->fonts[i]->name,
- fontfamily->fonts[i]->charnames,
- /*
- * Reencode all but
- * symbol face
- */
- encoding->encnames,
- (i < 4)?1:0)) {
- warning(_("cannot load afm file '%s'"), afmpaths[i]);
- freeFontFamily(fontfamily);
- fontfamily = NULL;
- break;
- }
- }
- /*
- * Add font
- */
- if (fontfamily)
- fontfamily = addLoadedFont(fontfamily, isPDF);
- }
- } else
- fontfamily = NULL;
- return fontfamily;
-}
-
-/*
- * Add a graphics engine font family/encoding to a list of device fonts ...
- *
- * ... and return the new font list
- */
-static cidfontlist addDeviceCIDFont(cidfontfamily font,
- cidfontlist devFonts,
- int *index)
-{
- cidfontlist newfont = makeCIDFontList();
- *index = 0;
- if (!newfont) {
- devFonts = NULL;
- } else {
- cidfontlist fontlist = devFonts;
- newfont->cidfamily = font;
- *index = 1;
- if (!devFonts) {
- devFonts = newfont;
- } else {
- while (fontlist->next) {
- fontlist = fontlist->next;
- *index = *index + 1;
- }
- fontlist->next = newfont;
- }
- }
- return devFonts;
-}
-static type1fontlist addDeviceFont(type1fontfamily font,
- type1fontlist devFonts,
- int *index)
-{
- type1fontlist newfont = makeFontList();
- *index = 0;
- if (!newfont) {
- devFonts = NULL;
- } else {
- type1fontlist fontlist = devFonts;
- newfont->family = font;
- *index = 1;
- if (!devFonts) {
- devFonts = newfont;
- } else {
- while (fontlist->next) {
- fontlist = fontlist->next;
- *index = *index + 1;
- }
- fontlist->next = newfont;
- }
- }
- return devFonts;
-}
-
-/*
-***********************************************************
-*/
-
-/* Part 2. Device Driver State. */
-
-typedef struct {
- char filename[PATH_MAX];
- int open_type;
-
- char papername[64]; /* paper name */
- int paperwidth; /* paper width in big points (1/72 in) */
- int paperheight; /* paper height in big points */
- Rboolean landscape; /* landscape mode */
- int pageno; /* page number */
- int fileno; /* file number */
-
- int maxpointsize;
-
- double width; /* plot width in inches */
- double height; /* plot height in inches */
- double pagewidth; /* page width in inches */
- double pageheight; /* page height in inches */
- Rboolean pagecentre;/* centre image on page? */
- Rboolean printit; /* print page at close? */
- char command[2*PATH_MAX];
- char title[1024];
- char colormodel[30];
-
- FILE *psfp; /* output file */
-
- Rboolean onefile; /* EPSF header etc*/
- Rboolean paperspecial; /* suppress %%Orientation */
- Rboolean warn_trans; /* have we warned about translucent cols? */
- Rboolean useKern;
- Rboolean fillOddEven; /* polygon fill mode */
-
- /* This group of variables track the current device status.
- * They should only be set by routines that emit PostScript code. */
- struct {
- double lwd; /* line width */
- int lty; /* line type */
- R_GE_lineend lend;
- R_GE_linejoin ljoin;
- double lmitre;
- int font;
- int cidfont;
- int fontsize; /* font size in points */
- rcolor col; /* color */
- rcolor fill; /* fill color */
- } current;
-
- /*
- * Fonts and encodings used on the device
- */
- type1fontlist fonts;
- cidfontlist cidfonts;
- encodinglist encodings;
- /*
- * These next two just record the default device font
- */
- type1fontfamily defaultFont;
- cidfontfamily defaultCIDFont;
-}
-PostScriptDesc;
-
-/* Part 3. Graphics Support Code. */
-
-static void specialCaseCM(FILE *fp, type1fontfamily family, int familynum)
-{
- fprintf(fp, "%% begin encoding\n");
- fprintf(fp, "/SymbolEncoding [\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /space /exclam /universal /numbersign /existential /percent /ampersand /suchthat\n");
- fprintf(fp, " /parenleft /parenright /asteriskmath /plus /comma /minus /period /slash\n");
- fprintf(fp, " /zero /one /two /three /four /five /six /seven\n");
- fprintf(fp, " /eight /nine /colon /semicolon /less /equal /greater /question\n");
- fprintf(fp, " /congruent /Alpha /Beta /Chi /Delta /Epsilon /Phi /Gamma\n");
- fprintf(fp, " /Eta /Iota /theta1 /Kappa /Lambda /Mu /Nu /Omicron\n");
- fprintf(fp, " /Pi /Theta /Rho /Sigma /Tau /Upsilon /sigma1 /Omega\n");
- fprintf(fp, " /Xi /Psi /Zeta /bracketleft /therefore /bracketright /perpendicular /underscore\n");
- fprintf(fp, " /radicalex /alpha /beta /chi /delta /epsilon /phi /gamma\n");
- fprintf(fp, " /eta /iota /phi1 /kappa /lambda /mu /nu /omicron\n");
- fprintf(fp, " /pi /theta /rho /sigma /tau /upsilon /omega1 /omega\n");
- fprintf(fp, " /xi /psi /zeta /braceleft /bar /braceright /similar /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
- fprintf(fp, " /Euro /Upsilon1 /minute /lessequal /fraction /infinity /florin /club\n");
- fprintf(fp, " /diamond /heart /spade /arrowboth /arrowleft /arrowup /arrowright /arrowdown\n");
- fprintf(fp, " /degree /plusminus /second /greaterequal /multiply /proportional /partialdiff /bullet\n");
- fprintf(fp, " /divide /notequal /equivalence /approxequal /ellipsis /arrowvertex /arrowhorizex /carriagereturn\n");
- fprintf(fp, " /aleph /Ifraktur /Rfraktur /weierstrass /circlemultiply /circleplus /emptyset /intersection\n");
- fprintf(fp, " /union /propersuperset /reflexsuperset /notsubset /propersubset /reflexsubset /element /notelement\n");
- fprintf(fp, " /angle /gradient /registerserif /copyrightserif /trademarkserif /product /radical /dotmath\n");
- fprintf(fp, " /logicalnot /logicaland /logicalor /arrowdblboth /arrowdblleft /arrowdblup /arrowdblright /arrowdbldown\n");
- fprintf(fp, " /lozenge /angleleft /registersans /copyrightsans /trademarksans /summation /parenlefttp /parenleftex\n");
- fprintf(fp, " /parenleftbt /bracketlefttp /bracketleftex /bracketleftbt /bracelefttp /braceleftmid /braceleftbt /braceex\n");
- fprintf(fp, " /.notdef /angleright /integral /integraltp /integralex /integralbt /parenrighttp /parenrightex\n");
- fprintf(fp, " /parenrightbt /bracketrighttp /bracketrightex /bracketrightbt /bracerighttp /bracerightmid /bracerightbt /.notdef\n");
- fprintf(fp, "] def\n");
- fprintf(fp, "%% end encoding\n");
- fprintf(fp, "/mergefonts\n");
- fprintf(fp, "{ /targetencoding exch def\n");
- fprintf(fp, " /fontarray exch def\n");
- fprintf(fp, " fontarray 0 get dup maxlength dict begin\n");
- fprintf(fp, " { 1 index /FID ne { def } { pop pop } ifelse } forall\n");
- fprintf(fp, " %% Create a new dictionary\n");
- fprintf(fp, " /CharStrings 256 dict def\n");
- fprintf(fp, " %% Add a definition of .notdef\n");
- fprintf(fp, " fontarray\n");
- fprintf(fp, " { /CharStrings get dup /.notdef known\n");
- fprintf(fp, " { /.notdef get /result exch def exit }\n");
- fprintf(fp, " { pop } ifelse\n");
- fprintf(fp, " } forall\n");
- fprintf(fp, " CharStrings /.notdef result put\n");
- fprintf(fp, " %% Add in the other definitions\n");
- fprintf(fp, " targetencoding\n");
- fprintf(fp, " { /code exch def\n");
- fprintf(fp, " %% Check that it is not a .notdef\n");
- fprintf(fp, " code /.notdef eq\n");
- fprintf(fp, " { /.notdef }\n");
- fprintf(fp, " { fontarray\n");
- fprintf(fp, " { /CharStrings get dup code known\n");
- fprintf(fp, " { code get /result exch def /found true def exit }\n");
- fprintf(fp, " { pop /found false def } ifelse\n");
- fprintf(fp, " } forall\n");
- fprintf(fp, " %% define character if it was found and accumulate encoding\n");
- fprintf(fp, " found { CharStrings code result put code } { /.notdef } ifelse\n");
- fprintf(fp, " } ifelse\n");
- fprintf(fp, " } forall\n");
- fprintf(fp, " %% grab new encoding off of stack\n");
- fprintf(fp, " 256 array astore /Encoding exch def\n");
- fprintf(fp, " %% Undefine some local variables\n");
- fprintf(fp, " currentdict /fontarray undef\n");
- fprintf(fp, " currentdict /targetencoding undef\n");
- fprintf(fp, " currentdict /code undef\n");
- fprintf(fp, " currentdict /result undef\n");
- fprintf(fp, " currentdict /found undef\n");
- fprintf(fp, " %% Leave new font on the stack\n");
- fprintf(fp, " currentdict\n");
- fprintf(fp, " end\n");
- fprintf(fp, "} def\n");
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- family->fonts[0]->name);
- fprintf(fp, "%%%%IncludeResource: font CMSY10\n");
- fprintf(fp, "[ /%s findfont /CMSY10 findfont ] %s mergefonts\n",
- family->fonts[0]->name, family->encoding->name);
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 1);
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- family->fonts[1]->name);
- fprintf(fp, "%%%%IncludeResource: font CMBSY10\n");
- fprintf(fp, "[ /%s findfont /CMBSY10 findfont ] %s mergefonts\n",
- family->fonts[1]->name, family->encoding->name);
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 2);
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- family->fonts[2]->name);
- fprintf(fp, "[ /%s findfont /CMSY10 findfont ] %s mergefonts\n",
- family->fonts[2]->name, family->encoding->name);
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 3);
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- family->fonts[3]->name);
- fprintf(fp, "[ /%s findfont /CMBSY10 findfont ] %s mergefonts\n",
- family->fonts[3]->name, family->encoding->name);
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 4);
- fprintf(fp, "%%%%IncludeResource: font CMMI10\n");
- fprintf(fp, "[ /CMR10 findfont /CMSY10 findfont /CMMI10 findfont ] SymbolEncoding mergefonts\n");
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 5);
-}
-
-static void PSEncodeFonts(FILE *fp, PostScriptDesc *pd)
-{
- type1fontlist fonts = pd->fonts;
- int familynum = 1;
- int haveWrittenDefaultEnc = 0;
- cidfontlist cidfonts = pd->cidfonts;
- int cidfamilynum = 1;
-
- while (fonts) {
- int dontcare;
- /*
- * Has the encoding already been used on the device?
- */
- encodinginfo encoding =
- findDeviceEncoding(fonts->family->encoding->encpath,
- pd->encodings, &dontcare);
- /*
- * If we've added the encoding to the device then it has been
- * written to file ...
- *
- * ... UNLESS this is the default encoding for the device, in
- * which case it has been added, but not written to file.
- *
- * Use haveWrittenDefaultEnc to make sure we only do it once.
- */
- if (!encoding ||
- (encoding == pd->encodings->encoding && !haveWrittenDefaultEnc)) {
- /*
- * Don't need to add default encoding again.
- */
- if (encoding != pd->encodings->encoding) {
- /*
- * The encoding should have been loaded when the
- * font was loaded
- */
- encoding = findEncoding(fonts->family->encoding->encpath,
- pd->encodings, FALSE);
- if (!encoding)
- warning(_("corrupt loaded encodings; encoding not recorded"));
- else {
- /*
- * Record encoding on device's list of encodings so
- * don't write same encoding more than once
- */
- encodinglist enclist = addDeviceEncoding(encoding,
- pd->encodings);
- if (enclist)
- pd->encodings = enclist;
- else
- warning(_("failed to record device encoding"));
- }
- } else {
- /*
- * Make sure we only write default encoding once.
- */
- haveWrittenDefaultEnc = 1;
- }
- /*
- * Include encoding unless it is ISOLatin1Encoding,
- * which is predefined
- */
- if (strcmp(fonts->family->encoding->name, "ISOLatin1Encoding"))
- fprintf(fp, "%% begin encoding\n%s def\n%% end encoding\n",
- fonts->family->encoding->enccode);
- }
- if(strcmp(fonts->family->fonts[4]->name,
- "CMSY10 CMBSY10 CMMI10") == 0) {
- /* use different ps fragment for CM fonts */
- specialCaseCM(fp, fonts->family, familynum);
- } else {
- int i;
- for (i = 0; i < 4 ; i++) {
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- fonts->family->fonts[i]->name);
- fprintf(fp, "/%s findfont\n",
- fonts->family->fonts[i]->name);
- fprintf(fp, "dup length dict begin\n");
- fprintf(fp, " {1 index /FID ne {def} {pop pop} ifelse} forall\n");
- fprintf(fp, " /Encoding %s def\n",
- fonts->family->encoding->name);
- fprintf(fp, " currentdict\n");
- fprintf(fp, " end\n");
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + i + 1);
- }
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- fonts->family->fonts[4]->name);
- fprintf(fp, "/%s findfont\n",
- fonts->family->fonts[4]->name);
- fprintf(fp, "dup length dict begin\n");
- fprintf(fp, " {1 index /FID ne {def} {pop pop} ifelse} forall\n");
- fprintf(fp, " currentdict\n");
- fprintf(fp, " end\n");
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + 5);
- }
-
- familynum++;
- fonts = fonts->next;
- }
- while(cidfonts) {
- int i;
- char *name = cidfonts->cidfamily->cidfonts[0]->name;
- fprintf(fp, "%%%%IncludeResource: CID fake Bold font %s\n", name);
- fprintf(fp, "/%s-Bold\n/%s /CIDFont findresource\n", name, name);
- fprintf(fp, "%s", CIDBoldFontStr1);
- fprintf(fp, "%s", CIDBoldFontStr2);
- for (i = 0; i < 4 ; i++) {
- char *fmt = NULL /* -Wall */;
- fprintf(fp, "%%%%IncludeResource: CID font %s-%s\n", name,
- cidfonts->cidfamily->cmap);
- switch(i) {
- case 0: fmt = "/%s-%s findfont\n";
- break;
- case 1: fmt = "/%s-Bold-%s findfont\n";
- break;
- case 2: fmt = "/%s-%s findfont [1 0 .3 1 0 0] makefont\n";
- break;
- case 3: fmt = "/%s-Bold-%s findfont [1 0 .3 1 0 0] makefont\n";
- break;
- default:
- break;
- }
- fprintf(fp, fmt, name, cidfonts->cidfamily->cmap);
- fprintf(fp, "dup length dict begin\n");
- fprintf(fp, " {1 index /FID ne {def} {pop pop} ifelse} forall\n");
- fprintf(fp, " currentdict\n");
- fprintf(fp, " end\n");
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + (cidfamilynum - 1)*5 + i + 1);
- }
- /*
- * Symbol font
- */
- fprintf(fp, "%%%%IncludeResource: font %s\n",
- cidfonts->cidfamily->symfont->name);
- fprintf(fp, "/%s findfont\n",
- cidfonts->cidfamily->symfont->name);
- fprintf(fp, "dup length dict begin\n");
- fprintf(fp, " {1 index /FID ne {def} {pop pop} ifelse} forall\n");
- fprintf(fp, " currentdict\n");
- fprintf(fp, " end\n");
- fprintf(fp, "/Font%d exch definefont pop\n",
- (familynum - 1)*5 + (cidfamilynum - 1)*5 + 5);
- cidfamilynum++;
- cidfonts = cidfonts->next;
- }
-}
-
-/* The variables "paperwidth" and "paperheight" give the dimensions */
-/* of the (unrotated) printer page in points whereas the graphics */
-/* region box is for the rotated page. */
-
-static void PSFileHeader(FILE *fp,
- const char *papername, double paperwidth,
- double paperheight, Rboolean landscape,
- int EPSFheader, Rboolean paperspecial,
- double left, double bottom, double right, double top,
- const char *title,
- PostScriptDesc *pd)
-{
- int i;
- SEXP prolog;
- type1fontlist fonts = pd->fonts;
- int firstfont = 1;
-
- if(EPSFheader)
- fprintf(fp, "%%!PS-Adobe-3.0 EPSF-3.0\n");
- else
- fprintf(fp, "%%!PS-Adobe-3.0\n");
- /*
- * DocumentNeededResources names all fonts
- */
- while (fonts) {
- for (i=0; i<5; i++)
- if (firstfont) {
- fprintf(fp, "%%%%DocumentNeededResources: font %s\n",
- fonts->family->fonts[0]->name);
- firstfont = 0;
- } else
- fprintf(fp, "%%%%+ font %s\n", fonts->family->fonts[i]->name);
- fonts = fonts->next;
- }
-
- if(!EPSFheader)
- fprintf(fp, "%%%%DocumentMedia: %s %.0f %.0f 0 () ()\n",
- papername, paperwidth, paperheight);
- fprintf(fp, "%%%%Title: %s\n", title);
- fprintf(fp, "%%%%Creator: R Software\n");
- fprintf(fp, "%%%%Pages: (atend)\n");
- if (!EPSFheader && !paperspecial) { /* gs gets confused by this */
- if (landscape)
- fprintf(fp, "%%%%Orientation: Landscape\n");
- else
- fprintf(fp, "%%%%Orientation: Portrait\n");
- }
- fprintf(fp, "%%%%BoundingBox: %.0f %.0f %.0f %.0f\n",
- left, bottom, right, top);
- fprintf(fp, "%%%%EndComments\n");
- fprintf(fp, "%%%%BeginProlog\n");
- fprintf(fp, "/bp { gs");
- if (streql(pd->colormodel, "srgb")) fprintf(fp, " sRGB");
- if (landscape)
- fprintf(fp, " %.2f 0 translate 90 rotate", paperwidth);
- fprintf(fp, " gs } def\n");
- prolog = findVar(install(".ps.prolog"), R_GlobalEnv);
- if(prolog == R_UnboundValue) {
- /* if no object is visible, look in the graphics namespace */
- SEXP graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices")));
- prolog = findVar(install(".ps.prolog"), graphicsNS);
- /* under lazy loading this will be a promise on first use */
- if(TYPEOF(prolog) == PROMSXP) {
- PROTECT(prolog);
- prolog = eval(prolog, graphicsNS);
- UNPROTECT(1);
- }
- }
- if(!isString(prolog))
- error(_("object '.ps.prolog' is not a character vector"));
- fprintf(fp, "%% begin .ps.prolog\n");
- for (i = 0; i < length(prolog); i++)
- fprintf(fp, "%s\n", CHAR(STRING_ELT(prolog, i)));
- fprintf(fp, "%% end .ps.prolog\n");
- if (streql(pd->colormodel, "srgb+gray") || streql(pd->colormodel, "srgb")) {
- SEXP graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices")));
- prolog = findVar(install(".ps.prolog.srgb"), graphicsNS);
- /* under lazy loading this will be a promise on first use */
- if(TYPEOF(prolog) == PROMSXP) {
- PROTECT(prolog);
- prolog = eval(prolog, graphicsNS);
- UNPROTECT(1);
- }
- for (i = 0; i < length(prolog); i++)
- fprintf(fp, "%s\n", CHAR(STRING_ELT(prolog, i)));
- }
- if (streql(pd->colormodel, "srgb+gray"))
- fprintf(fp, "/srgb { sRGB setcolor } bind def\n");
- else if (streql(pd->colormodel, "srgb"))
- fprintf(fp, "/srgb { setcolor } bind def\n");
- PSEncodeFonts(fp, pd);
-
- fprintf(fp, "%%%%EndProlog\n");
-}
-
-static void PostScriptFileTrailer(FILE *fp, int pageno)
-{
- fprintf(fp, "ep\n");
- fprintf(fp, "%%%%Trailer\n");
- fprintf(fp, "%%%%Pages: %d\n", pageno);
- fprintf(fp, "%%%%EOF\n");
-}
-
-static void PostScriptStartPage(FILE *fp, int pageno)
-{
- fprintf(fp, "%%%%Page: %d %d\n", pageno, pageno);
- fprintf(fp, "bp\n");
-}
-
-static void PostScriptEndPage(FILE *fp)
-{
- fprintf(fp, "ep\n");
-}
-
-static void PostScriptSetClipRect(FILE *fp, double x0, double x1,
- double y0, double y1)
-{
- fprintf(fp, "%.2f %.2f %.2f %.2f cl\n", x0, y0, x1, y1);
-}
-
-static void PostScriptSetLineWidth(FILE *fp, double linewidth)
-{
- /* Must not allow line width to be zero */
- if (linewidth < .01)
- linewidth = .01;
- fprintf(fp, "%.2f setlinewidth\n", linewidth);
-}
-
-static void PostScriptSetLineEnd(FILE *fp, R_GE_lineend lend)
-{
- int lineend = 1; /* -Wall */
- switch (lend) {
- case GE_ROUND_CAP:
- lineend = 1;
- break;
- case GE_BUTT_CAP:
- lineend = 0;
- break;
- case GE_SQUARE_CAP:
- lineend = 2;
- break;
- default:
- error(_("invalid line end"));
- }
- fprintf(fp, "%1d setlinecap\n", lineend);
-}
-
-static void PostScriptSetLineJoin(FILE *fp, R_GE_linejoin ljoin)
-{
- int linejoin = 1; /* -Wall */
- switch (ljoin) {
- case GE_ROUND_JOIN:
- linejoin = 1;
- break;
- case GE_MITRE_JOIN:
- linejoin = 0;
- break;
- case GE_BEVEL_JOIN:
- linejoin = 2;
- break;
- default:
- error(_("invalid line join"));
- }
- fprintf(fp, "%1d setlinejoin\n", linejoin);
-}
-
-static void PostScriptSetLineMitre(FILE *fp, double linemitre)
-{
- if (linemitre < 1)
- error(_("invalid line mitre"));
- fprintf(fp, "%.2f setmiterlimit\n", linemitre);
-}
-
-static void PostScriptSetFont(FILE *fp, int fontnum, double size)
-{
- fprintf(fp, "/Font%d findfont %.0f s\n", fontnum, size);
-}
-
-static void
-PostScriptSetLineTexture(FILE *fp, const char *dashlist, int nlty,
- double lwd, int lend)
-{
-/* use same macro for Postscript and PDF */
-/* Historically the adjustment was 1 to allow for round end caps.
- As from 2.11.0, no adjustment is done for butt endcaps.
- The + 1 adjustment on the 'off' segments seems wrong, but it
- has been left in for back-compatibility
-*/
-#define PP_SetLineTexture(_CMD_, adj) \
- double dash[8], a = adj; \
- int i; \
- Rboolean allzero = TRUE; \
- for (i = 0; i < nlty; i++) { \
- dash[i] = lwd * \
- ((i % 2) ? (dashlist[i] + a) \
- : ((nlty == 1 && dashlist[i] == 1.) ? 1. : dashlist[i] - a) ); \
- if (dash[i] < 0) dash[i] = 0; \
- if (dash[i] > .01) allzero = FALSE; \
- } \
- fprintf(fp,"["); \
- if (!allzero) { \
- for (i = 0; i < nlty; i++) { \
- fprintf(fp," %.2f", dash[i]); \
- } \
- } \
- fprintf(fp,"] 0 %s\n", _CMD_)
-
- PP_SetLineTexture("setdash", (lend == GE_BUTT_CAP) ? 0. : 1.);
-}
-
-
-static void PostScriptMoveTo(FILE *fp, double x, double y)
-{
- fprintf(fp, "%.2f %.2f m\n", x, y);
-}
-
-static void PostScriptRLineTo(FILE *fp, double x0, double y0,
- double x1, double y1)
-{
- double x = fround(x1, 2) - fround(x0, 2),
- y = fround(y1, 2) - fround(y0, 2);
- /* Warning: some machines seem to compute these differently from
- others, and we do want to diff the output. x and y should be
- above around 0.01 or negligible (1e-14), and it is the latter case
- we are watching out for here.
- */
-
- if(fabs(x) < 0.005) fprintf(fp, "0"); else fprintf(fp, "%.2f", x);
- if(fabs(y) < 0.005) fprintf(fp, " 0"); else fprintf(fp, " %.2f", y);
- fprintf(fp, " l\n");
-}
-
-static void PostScriptStartPath(FILE *fp)
-{
- fprintf(fp, "np\n");
-}
-
-static void PostScriptEndPath(FILE *fp)
-{
- fprintf(fp, "o\n");
-}
-
-static void PostScriptRectangle(FILE *fp, double x0, double y0,
- double x1, double y1)
-{
- fprintf(fp, "%.2f %.2f %.2f %.2f r ", x0, y0, x1-x0, y1-y0);
-}
-
-static void PostScriptCircle(FILE *fp, double x, double y, double r)
-{
- fprintf(fp, "%.2f %.2f %.2f c ", x, y, r);
-}
-
-static void PostScriptWriteString(FILE *fp, const char *str, size_t nb)
-{
- size_t i;
-
- fputc('(', fp);
- for (i = 0 ; i < nb && *str; i++, str++)
- switch(*str) {
- case '\n':
- fprintf(fp, "\\n");
- break;
- case '\\':
- fprintf(fp, "\\\\");
- break;
- case '-':
-#ifdef USE_HYPHEN
- if (!isdigit((int)str[1]))
- fputc(PS_hyphen, fp);
- else
-#endif
- fputc(*str, fp);
- break;
- case '(':
- case ')':
- fprintf(fp, "\\%c", *str);
- break;
- default:
- fputc(*str, fp);
- break;
- }
- fputc(')', fp);
-}
-
-
-static FontMetricInfo *metricInfo(const char *, int, PostScriptDesc *);
-
-static void PostScriptText(FILE *fp, double x, double y,
- const char *str, size_t nb, double xc, double rot,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
-
- fprintf(fp, "%.2f %.2f ", x, y);
-
- PostScriptWriteString(fp, str, nb);
-
- if(xc == 0) fprintf(fp, " 0");
- else if(xc == 0.5) fprintf(fp, " .5");
- else if(xc == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.2f", xc);
-
- if(rot == 0) fprintf(fp, " 0");
- else if(rot == 90) fprintf(fp, " 90");
- else fprintf(fp, " %.2f", rot);
-
- fprintf(fp, " t\n");
-}
-
-static void PostScriptText2(FILE *fp, double x, double y,
- const char *str, size_t nb,
- Rboolean relative, double rot,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
-
- if(relative) {
- fprintf(fp, "\n%.3f ", x);
- PostScriptWriteString(fp, str, nb);
- fprintf(fp, " tb");
- } else {
- fprintf(fp, "%.2f %.2f ", x, y);
- PostScriptWriteString(fp, str, nb);
- if(rot == 0) fprintf(fp, " 0");
- else if(rot == 90) fprintf(fp, " 90");
- else fprintf(fp, " %.2f", rot);
- fprintf(fp, " ta");
- }
-}
-
-static void PostScriptHexText(FILE *fp, double x, double y,
- const char *str, size_t strlen,
- double xc, double rot)
-{
- unsigned char *p = (unsigned char *)str;
- size_t i;
-
- fprintf(fp, "%.2f %.2f ", x, y);
- fprintf(fp, "<");
- for(i = 0; i < strlen; i++) fprintf(fp, "%02x", *p++);
- fprintf(fp, ">");
-
- if(xc == 0) fprintf(fp, " 0");
- else if(xc == 0.5) fprintf(fp, " .5");
- else if(xc == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.2f", xc);
-
- if(rot == 0) fprintf(fp, " 0");
- else if(rot == 90) fprintf(fp, " 90");
- else fprintf(fp, " %.2f", rot);
-
- fprintf(fp, " t\n");
-}
-
-static void
-PostScriptTextKern(FILE *fp, double x, double y,
- const char *str, double xc, double rot,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- int face = gc->fontface;
- FontMetricInfo *metrics;
- size_t i, n, nout = 0;
- int j, w;
- unsigned char p1, p2;
- double fac = 0.001 * floor(gc->cex * gc->ps + 0.5);
- Rboolean relative = FALSE;
- Rboolean haveKerning = FALSE;
-
- if(face < 1 || face > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), face);
- face = 1;
- }
- /* check if this is T1 -- should be, but be safe*/
- if(!isType1Font(gc->fontfamily, PostScriptFonts, pd->defaultFont)) {
- PostScriptText(fp, x, y, str, strlen(str), xc, rot, gc, dd);
- return;
- }
- metrics = metricInfo(gc->fontfamily, face, pd);
-
- n = strlen(str);
- if (n < 1) return;
- /* First check for any kerning */
- for(i = 0; i < n-1; i++) {
- p1 = str[i];
- p2 = str[i+1];
-#ifdef USE_HYPHEN
- if (p1 == '-' && !isdigit((int)p2))
- p1 = (unsigned char)PS_hyphen;
-#endif
- for (j = metrics->KPstart[p1]; j < metrics->KPend[p1]; j++)
- if(metrics->KernPairs[j].c2 == p2 &&
- metrics->KernPairs[j].c1 == p1) {
- haveKerning = TRUE;
- break;
- }
- }
-
- if(haveKerning) {
- /* We have to start at the left edge, as we are going
- to do this in pieces */
- if (xc != 0) {
- double rot1 = rot * M_PI/180.;
- int w = 0; short wx;
- for(i = 0; i < n; i++) {
- unsigned char p1 = str[i];
- wx = metrics->CharInfo[(int)p1].WX;
- w += (wx == NA_SHORT) ? 0 : wx;
- }
- x -= xc*fac*cos(rot1)*w;
- y -= xc*fac*sin(rot1)*w;
- }
- for(i = 0; i < n-1; i++) {
- p1 = str[i];
- p2 = str[i+1];
-#ifdef USE_HYPHEN
- if (p1 == '-' && !isdigit((int)p2))
- p1 = (unsigned char)PS_hyphen;
-#endif
- for (j = metrics->KPstart[p1]; j < metrics->KPend[p1]; j++)
- if(metrics->KernPairs[j].c2 == p2 &&
- metrics->KernPairs[j].c1 == p1) {
- PostScriptText2(fp, x, y, str+nout, i+1-nout,
- relative, rot, gc, dd);
- nout = i+1;
- w = metrics->KernPairs[j].kern;
- x = fac*w; y = 0;
- relative = TRUE;
- break;
- }
- }
- PostScriptText2(fp, x, y, str+nout, n-nout, relative, rot, gc, dd);
- fprintf(fp, " gr\n");
- } else
- PostScriptText(fp, x, y, str, strlen(str), xc, rot, gc, dd);
-}
-
-/* Device Driver Actions */
-
-static void PS_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd);
-static void PS_Close(pDevDesc dd);
-static void PS_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd);
-static void PS_NewPage(const pGEcontext gc,
- pDevDesc dd);
-static Rboolean PS_Open(pDevDesc, PostScriptDesc*);
-static void PS_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Raster(unsigned int *raster, int w, int h,
- double x, double y, double width, double height,
- double rot, Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd);
-static void PS_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd);
-static double PS_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-static double PS_StrWidthUTF8(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void PS_TextUTF8(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-
-/* PostScript Support (formerly in PostScript.c) */
-
-static void PostScriptSetCol(FILE *fp, double r, double g, double b,
- PostScriptDesc *pd)
-{
- const char *mm = pd->colormodel;
- if(r == g && g == b &&
- !(streql(mm, "cmyk") || streql(mm, "srgb")
- || streql(mm, "rgb-nogray")) ) { /* grey */
- if(r == 0) fprintf(fp, "0");
- else if (r == 1) fprintf(fp, "1");
- else fprintf(fp, "%.4f", r);
- fprintf(fp," setgray");
- } else {
- if(strcmp(mm, "gray") == 0) {
- fprintf(fp, "%.4f setgray", 0.213*r + 0.715*g + 0.072*b);
- // error(_("only gray colors are allowed in this color model"));
- } else if(strcmp(mm, "cmyk") == 0) {
- double c = 1.0-r, m=1.0-g, y=1.0-b, k=c;
- k = fmin2(k, m);
- k = fmin2(k, y);
- if(k == 1.0) c = m = y = 0.0;
- else { c = (c-k)/(1-k); m = (m-k)/(1-k); y = (y-k)/(1-k); }
- /* else {c /= (1.-k); m /= (1.-k); y /= (1.-k);} */
- if(c == 0) fprintf(fp, "0");
- else if (c == 1) fprintf(fp, "1");
- else fprintf(fp, "%.4f", c);
- if(m == 0) fprintf(fp, " 0");
- else if (m == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.4f", m);
- if(y == 0) fprintf(fp, " 0");
- else if (y == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.4f", y);
- if(k == 0) fprintf(fp, " 0");
- else if (k == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.4f", k);
- fprintf(fp," setcmykcolor\n");
- } else {
- if(r == 0) fprintf(fp, "0");
- else if (r == 1) fprintf(fp, "1");
- else fprintf(fp, "%.4f", r);
- if(g == 0) fprintf(fp, " 0");
- else if (g == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.4f", g);
- if(b == 0) fprintf(fp, " 0");
- else if (b == 1) fprintf(fp, " 1");
- else fprintf(fp, " %.4f", b);
- if (streql(mm, "srgb+gray") || streql(mm, "srgb"))
- fprintf(fp," srgb");
- else fprintf(fp," rgb");
- }
- }
-}
-
-static void PostScriptSetFill(FILE *fp, double r, double g, double b,
- PostScriptDesc *pd)
-{
- fprintf(fp,"/bg { ");
- PostScriptSetCol(fp, r, g, b, pd);
- fprintf(fp, " } def\n");
-}
-
-
-
-/* Driver Support Routines */
-
-static void SetColor(int, pDevDesc);
-static void SetFill(int, pDevDesc);
-static void SetFont(int, int, pDevDesc);
-static void SetLineStyle(const pGEcontext, pDevDesc dd);
-static void Invalidate(pDevDesc);
-
-static void PS_cleanup(int stage, pDevDesc dd, PostScriptDesc *pd);
-
-
-Rboolean
-PSDeviceDriver(pDevDesc dd, const char *file, const char *paper,
- const char *family, const char **afmpaths, const char *encoding,
- const char *bg, const char *fg, double width, double height,
- Rboolean horizontal, double ps,
- Rboolean onefile, Rboolean pagecentre, Rboolean printit,
- const char *cmd, const char *title, SEXP fonts,
- const char *colormodel, int useKern, Rboolean fillOddEven)
-{
- /* If we need to bail out with some sort of "error"
- then we must free(dd) */
-
- double xoff, yoff, pointsize;
- rcolor setbg, setfg;
- encodinginfo enc;
- encodinglist enclist;
- type1fontfamily font;
- cidfontfamily cidfont = NULL;
- int gotFont;
-
- PostScriptDesc *pd;
-
- /* Check and extract the device parameters */
-
- if(strlen(file) > PATH_MAX - 1) {
- free(dd);
- error(_("filename too long in %s()"), "postscript");
- }
-
- /* allocate new postscript device description */
- if (!(pd = (PostScriptDesc *) malloc(sizeof(PostScriptDesc)))) {
- free(dd);
- error(_("memory allocation problem in %s()"), "postscript");
- }
-
- /* from here on, if need to bail out with "error", must also */
- /* free(pd) */
-
- /* initialise postscript device description */
- strcpy(pd->filename, file);
- strcpy(pd->papername, paper);
- strncpy(pd->title, title, 1024);
- if (streql(colormodel, "grey")) strcpy(pd->colormodel, "grey");
- else strncpy(pd->colormodel, colormodel, 30);
- pd->useKern = (useKern != 0);
- pd->fillOddEven = fillOddEven;
-
- if(strlen(encoding) > PATH_MAX - 1) {
- PS_cleanup(1, dd, pd);
- error(_("encoding path is too long in %s()"), "postscript");
- }
- /*
- * Load the default encoding AS THE FIRST ENCODING FOR THIS DEVICE.
- *
- * encpath MUST NOT BE "default"
- */
- pd->encodings = NULL;
- if (!(enc = findEncoding(encoding, pd->encodings, FALSE)))
- enc = addEncoding(encoding, 0);
- if (enc && (enclist = addDeviceEncoding(enc, pd->encodings))) {
- pd->encodings = enclist;
- } else {
- PS_cleanup(1, dd, pd);
- error(_("failed to load encoding file in %s()"), "postscript");
- }
-
- /*****************************
- * Load fonts
- *****************************/
- pd->fonts = NULL;
- pd->cidfonts = NULL;
-
- gotFont = 0;
- /*
- * If user specified afms then assume the font hasn't been loaded
- * Could lead to redundant extra loading of a font, but not often(?)
- */
- if (!strcmp(family, "User")) {
- font = addDefaultFontFromAFMs(encoding, afmpaths, 0, pd->encodings);
- } else {
- /*
- * Otherwise, family is a device-independent font family.
- * One of the elements of postscriptFonts().
- * NOTE this is the first font loaded on this device!
- */
- /*
- * Check first whether this font has been loaded
- * in this R session
- */
- font = findLoadedFont(family, encoding, FALSE);
- cidfont = findLoadedCIDFont(family, FALSE);
- if (!(font || cidfont)) {
- /*
- * If the font has not been loaded yet, load it.
- *
- * The family SHOULD be in the font database to get this far.
- * (checked at R level in postscript() in postscript.R)
- */
- if (isType1Font(family, PostScriptFonts, NULL)) {
- font = addFont(family, FALSE, pd->encodings);
- } else if (isCIDFont(family, PostScriptFonts, NULL)) {
- cidfont = addCIDFont(family, FALSE);
- } else {
- /*
- * Should NOT get here.
- * AND if we do, we should free
- */
- PS_cleanup(3, dd, pd);
- error(_("invalid font type"));
- }
- }
- }
- if (font || cidfont) {
- /*
- * At this point the font is loaded, so add it to the
- * device's list of fonts.
- *
- * If the user specified a vector of AFMs, it is a Type 1 font
- */
- if (!strcmp(family, "User") ||
- isType1Font(family, PostScriptFonts, NULL)) {
- pd->fonts = addDeviceFont(font, pd->fonts, &gotFont);
- pd->defaultFont = pd->fonts->family;
- pd->defaultCIDFont = NULL;
- } else /* (isCIDFont(family, PostScriptFonts)) */ {
- pd->cidfonts = addDeviceCIDFont(cidfont, pd->cidfonts, &gotFont);
- pd->defaultFont = NULL;
- pd->defaultCIDFont = pd->cidfonts->cidfamily;
- }
- }
- if (!gotFont) {
- PS_cleanup(3, dd, pd);
- error(_("failed to initialise default PostScript font"));
- }
-
- /*
- * Load the font names sent in via the fonts arg
- * NOTE that these are the font names specified at the
- * R-level, NOT the translated font names.
- */
- if (!isNull(fonts)) {
- int i, dontcare, gotFonts = 0, nfonts = LENGTH(fonts);
- type1fontlist fontlist;
- cidfontlist cidfontlist;
- for (i = 0; i < nfonts; i++) {
- int index, cidindex;
- const char *name = CHAR(STRING_ELT(fonts, i));
- /*
- * Check first whether this device is already
- * using this font.
- */
- if (findDeviceFont(name, pd->fonts, &index) ||
- findDeviceCIDFont(name, pd->cidfonts, &cidindex))
- gotFonts++;
- else {
- /*
- * Check whether the font is loaded and, if not,
- * load it.
- */
- font = findLoadedFont(name, encoding, FALSE);
- cidfont = findLoadedCIDFont(name, FALSE);
- if (!(font || cidfont)) {
- if (isType1Font(name, PostScriptFonts, NULL)) {
- font = addFont(name, FALSE, pd->encodings);
- } else if (isCIDFont(name, PostScriptFonts, NULL)) {
- cidfont = addCIDFont(name, FALSE);
- } else {
- /*
- * Should NOT get here.
- */
- PS_cleanup(4, dd, pd);
- error(_("invalid font type"));
- }
- }
- /*
- * Once the font is loaded, add it to the device's
- * list of fonts.
- */
- if (font || cidfont) {
- if (isType1Font(name, PostScriptFonts, NULL)) {
- if ((fontlist = addDeviceFont(font, pd->fonts,
- &dontcare))) {
- pd->fonts = fontlist;
- gotFonts++;
- }
- } else /* (isCIDFont(family, PostScriptFonts)) */ {
- if ((cidfontlist = addDeviceCIDFont(cidfont,
- pd->cidfonts,
- &dontcare))) {
- pd->cidfonts = cidfontlist;
- gotFonts++;
- }
- }
- }
- }
- }
- if (gotFonts < nfonts) {
- PS_cleanup(4, dd, pd);
- error(_("failed to initialise additional PostScript fonts"));
- }
- }
- /*****************************
- * END Load fonts
- *****************************/
-
- setbg = R_GE_str2col(bg);
- setfg = R_GE_str2col(fg);
-
- pd->width = width;
- pd->height = height;
- pd->landscape = horizontal;
- pointsize = floor(ps);
- if(R_TRANSPARENT(setbg) && R_TRANSPARENT(setfg)) {
- PS_cleanup(4, dd, pd);
- error(_("invalid foreground/background color (postscript)"));
- }
- pd->printit = printit;
- if(strlen(cmd) > 2*PATH_MAX - 1) {
- PS_cleanup(4, dd, pd);
- error(_("'command' is too long"));
- }
- strcpy(pd->command, cmd);
- if (printit && strlen(cmd) == 0) {
- PS_cleanup(4, dd, pd);
- error(_("'postscript(print.it=TRUE)' used with an empty 'print' command"));
- }
- strcpy(pd->command, cmd);
-
-
- /* Deal with paper and plot size and orientation */
-
- pd->paperspecial = FALSE;
- if(!strcmp(pd->papername, "Default") ||
- !strcmp(pd->papername, "default")) {
- SEXP s = STRING_ELT(GetOption1(install("papersize")), 0);
- if(s != NA_STRING && strlen(CHAR(s)) > 0)
- strcpy(pd->papername, CHAR(s));
- else strcpy(pd->papername, "a4");
- }
- if(!strcmp(pd->papername, "A4") ||
- !strcmp(pd->papername, "a4")) {
- pd->pagewidth = 21.0 / 2.54;
- pd->pageheight = 29.7 /2.54;
- }
- else if(!strcmp(pd->papername, "Letter") ||
- !strcmp(pd->papername, "letter") ||
- !strcmp(pd->papername, "US") ||
- !strcmp(pd->papername, "us")) {
- pd->pagewidth = 8.5;
- pd->pageheight = 11.0;
- }
- else if(!strcmp(pd->papername, "Legal") ||
- !strcmp(pd->papername, "legal")) {
- pd->pagewidth = 8.5;
- pd->pageheight = 14.0;
- }
- else if(!strcmp(pd->papername, "Executive") ||
- !strcmp(pd->papername, "executive")) {
- pd->pagewidth = 7.25;
- pd->pageheight = 10.5;
- }
- else if(!strcmp(pd->papername, "special")) {
- if(pd->landscape) {
- pd->pagewidth = height;
- pd->pageheight = width;
- } else {
- pd->pagewidth = width;
- pd->pageheight = height;
- }
- pd->paperspecial = TRUE;
- }
- else {
- PS_cleanup(4, dd, pd);
- error(_("invalid page type '%s' (postscript)"), pd->papername);
- }
- pd->pagecentre = pagecentre;
- pd->paperwidth = (int)(72 * pd->pagewidth);
- pd->paperheight = (int)(72 * pd->pageheight);
- pd->onefile = onefile;
- if(pd->landscape) {
- double tmp;
- tmp = pd->pagewidth;
- pd->pagewidth = pd->pageheight;
- pd->pageheight = tmp;
- }
- if(strcmp(pd->papername, "special"))
- {
- if(pd->width < 0.1 || pd->width > pd->pagewidth-0.5)
- pd->width = pd->pagewidth-0.5;
- if(pd->height < 0.1 || pd->height > pd->pageheight-0.5)
- pd->height = pd->pageheight-0.5;
- }
- if(pagecentre)
- {
- xoff = (pd->pagewidth - pd->width)/2.0;
- yoff = (pd->pageheight - pd->height)/2.0;
- } else {
- xoff = yoff = 0.0;
- }
- pd->maxpointsize = (int)(72.0 * ((pd->pageheight > pd->pagewidth) ?
- pd->pageheight : pd->pagewidth));
- pd->pageno = pd->fileno = 0;
- pd->warn_trans = FALSE;
-
- /* Base Pointsize */
- /* Nominal Character Sizes in Pixels */
- /* Only right for 12 point font. */
- /* Max pointsize suggested by Peter Dalgaard */
-
- if(pointsize < 6.0) pointsize = 6.0;
- if(pointsize > pd->maxpointsize) pointsize = pd->maxpointsize;
- dd->startps = pointsize;
- dd->startfont = 1;
- dd->startlty = 0;
- dd->startfill = setbg;
- dd->startcol = setfg;
- dd->startgamma = 1;
-
- /* Set graphics parameters that must be set by device driver. */
- /* Page dimensions in points. */
-
- dd->left = 72 * xoff; /* left */
- dd->right = 72 * (xoff + pd->width); /* right */
- dd->bottom = 72 * yoff; /* bottom */
- dd->top = 72 * (yoff + pd->height); /* top */
- dd->clipLeft = dd->left; dd->clipRight = dd->right;
- dd->clipBottom = dd->bottom; dd->clipTop = dd->top;
-
- dd->cra[0] = 0.9 * pointsize;
- dd->cra[1] = 1.2 * pointsize;
-
- /* Character Addressing Offsets */
- /* These offsets should center a single */
- /* plotting character over the plotting point. */
- /* Pure guesswork and eyeballing ... */
-
- dd->xCharOffset = 0.4900;
- dd->yCharOffset = 0.3333;
- dd->yLineBias = 0.2;
-
- /* Inches per Raster Unit */
- /* We use points (72 dots per inch) */
-
- dd->ipr[0] = 1.0/72.0;
- dd->ipr[1] = 1.0/72.0;
- /* GREset(.) dd->gp.mkh = dd->gp.cra[0] * dd->gp.ipr[0]; */
-
- dd->canClip = TRUE;
- dd->canHAdj = 2;
- dd->canChangeGamma = FALSE;
-
- /* Start the driver */
- PS_Open(dd, pd);
-
- dd->close = PS_Close;
- dd->size = PS_Size;
- dd->newPage = PS_NewPage;
- dd->clip = PS_Clip;
- dd->text = PS_Text;
- dd->strWidth = PS_StrWidth;
- dd->metricInfo = PS_MetricInfo;
- dd->rect = PS_Rect;
- dd->path = PS_Path;
- dd->raster = PS_Raster;
- dd->circle = PS_Circle;
- dd->line = PS_Line;
- dd->polygon = PS_Polygon;
- dd->polyline = PS_Polyline;
- /* dd->locator = PS_Locator;
- dd->mode = PS_Mode; */
- dd->hasTextUTF8 = TRUE;
- dd->textUTF8 = PS_TextUTF8;
- dd->strWidthUTF8 = PS_StrWidthUTF8;
- dd->useRotatedTextInContour = TRUE;
- dd->haveTransparency = 1;
- dd->haveTransparentBg = 2;
- dd->haveRaster = 3; /* non-missing colours */
-
- dd->deviceSpecific = (void *) pd;
- dd->displayListOn = FALSE;
- return TRUE;
-}
-
-static void CheckAlpha(int color, PostScriptDesc *pd)
-{
- unsigned int alpha = R_ALPHA(color);
- if (alpha > 0 && alpha < 255 && !pd->warn_trans) {
- warning(_("semi-transparency is not supported on this device: reported only once per page"));
- pd->warn_trans = TRUE;
- }
-}
-
-static void SetColor(int color, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- if(color != pd->current.col) {
- PostScriptSetCol(pd->psfp,
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0, pd);
- fprintf(pd->psfp, "\n");
- pd->current.col = color;
- }
-}
-
-static void SetFill(int color, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- if(color != pd->current.fill) {
- PostScriptSetFill(pd->psfp,
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0, pd);
- pd->current.fill = color;
- }
-}
-
-/* Note that the line texture is scaled by the line width. */
-
-static void SetLineStyle(const pGEcontext gc, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- char dashlist[8];
- int i;
- int newlty = gc->lty;
- double newlwd = gc->lwd;
- R_GE_lineend newlend = gc->lend;
- R_GE_linejoin newljoin = gc->ljoin;
- double newlmitre = gc->lmitre;
-
- if (pd->current.lty != newlty || pd->current.lwd != newlwd) {
- pd->current.lwd = newlwd;
- pd->current.lty = newlty;
- PostScriptSetLineWidth(pd->psfp, newlwd * 0.75);
- /* process lty : */
- for(i = 0; i < 8 && newlty & 15 ; i++) {
- dashlist[i] = newlty & 15;
- newlty = newlty >> 4;
- }
- PostScriptSetLineTexture(pd->psfp, dashlist, i, newlwd * 0.75, newlend);
- }
- if (pd->current.lend != newlend) {
- pd->current.lend = newlend;
- PostScriptSetLineEnd(pd->psfp, newlend);
- }
- if (pd->current.ljoin != newljoin) {
- pd->current.ljoin = newljoin;
- PostScriptSetLineJoin(pd->psfp, newljoin);
- }
- if (pd->current.lmitre != newlmitre) {
- pd->current.lmitre = newlmitre;
- PostScriptSetLineMitre(pd->psfp, newlmitre);
- }
-}
-
-static void SetFont(int font, int size, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- if(size < 1 || size > pd->maxpointsize)
- size = 10;
- if (size != pd->current.fontsize || font != pd->current.font) {
- PostScriptSetFont(pd->psfp, font, size);
- pd->current.fontsize = size;
- pd->current.font = font;
- }
-}
-
-static void PS_cleanup(int stage, pDevDesc dd, PostScriptDesc *pd)
-{
- switch (stage) {
- case 4: /* Allocated fonts */
- freeDeviceFontList(pd->fonts);
- freeDeviceCIDFontList(pd->cidfonts);
- case 3: /* Allocated encodings */
- freeDeviceEncList(pd->encodings);
- case 1: /* Allocated PDFDesc */
- free(pd);
- free(dd);
- }
-}
-
-
-static Rboolean PS_Open(pDevDesc dd, PostScriptDesc *pd)
-{
- char buf[512];
-
- if (strlen(pd->filename) == 0) {
- if(strlen(pd->command) == 0) return FALSE;
- errno = 0;
- pd->psfp = R_popen(pd->command, "w");
- pd->open_type = 1;
- if (!pd->psfp || errno != 0) {
- PS_cleanup(4, dd, pd);
- error(_("cannot open 'postscript' pipe to '%s'"), pd->command);
- return FALSE;
- }
- } else if (pd->filename[0] == '|') {
- errno = 0;
- pd->psfp = R_popen(pd->filename + 1, "w");
- pd->open_type = 1;
- if (!pd->psfp || errno != 0) {
- PS_cleanup(4, dd, pd);
- error(_("cannot open 'postscript' pipe to '%s'"),
- pd->filename + 1);
- return FALSE;
- }
- } else {
- snprintf(buf, 512, pd->filename, pd->fileno + 1); /* file 1 to start */
- pd->psfp = R_fopen(R_ExpandFileName(buf), "w");
- pd->open_type = 0;
- }
- if (!pd->psfp) {
- PS_cleanup(4, dd, pd);
- error(_("cannot open file '%s'"), buf);
- return FALSE;
- }
-
- if(pd->landscape)
- PSFileHeader(pd->psfp,
- pd->papername,
- pd->paperwidth,
- pd->paperheight,
- pd->landscape,
- !(pd->onefile),
- pd->paperspecial,
- dd->bottom,
- dd->left,
- dd->top,
- dd->right,
- pd->title,
- pd);
- else
- PSFileHeader(pd->psfp,
- pd->papername,
- pd->paperwidth,
- pd->paperheight,
- pd->landscape,
- !(pd->onefile),
- pd->paperspecial,
- dd->left,
- dd->bottom,
- dd->right,
- dd->top,
- pd->title,
- pd);
-
- return TRUE;
-}
-
-/* The driver keeps track of the current values of colors, fonts and
- line parameters, to save emitting some PostScript. In some cases,
- the state becomes unknown, notably after changing the clipping and
- at the start of a new page, so we have the following routine to
- invalidate the saved values, which in turn causes the parameters to
- be set before usage.
-
- Called at the start of each page and by PS_Clip (since that
- does a grestore).
-*/
-
-static void Invalidate(pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- pd->current.font = -1;
- pd->current.fontsize = -1;
- pd->current.lwd = -1;
- pd->current.lty = -1;
- pd->current.lend = 0;
- pd->current.ljoin = 0;
- pd->current.lmitre = 0;
- pd->current.col = INVALID_COL;
- pd->current.fill = INVALID_COL;
-}
-
-static void PS_Clip(double x0, double x1, double y0, double y1, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- PostScriptSetClipRect(pd->psfp, x0, x1, y0, y1);
- /* clipping does grestore so invalidate monitor variables */
- Invalidate(dd);
-}
-
-static void PS_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- *left = dd->left;
- *right = dd->right;
- *bottom = dd->bottom;
- *top = dd->top;
-}
-
-static void PostScriptClose(pDevDesc dd);
-
-static void PS_NewPage(const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
-
- if(pd->onefile) {
- if(++pd->pageno > 1) PostScriptEndPage(pd->psfp);
- } else if(pd->pageno > 0) {
- PostScriptClose(dd);
- pd->fileno++;
- PS_Open(dd, pd);
- pd->pageno = 1;
- } else pd->pageno++;
- PostScriptStartPage(pd->psfp, pd->pageno);
- Invalidate(dd);
- CheckAlpha(gc->fill, pd);
- if(R_OPAQUE(gc->fill)) {
- /*
- * Override some gc settings
- */
- gc->col = R_TRANWHITE;
- PS_Rect(0, 0, 72.0 * pd->pagewidth, 72.0 * pd->pageheight, gc, dd);
- }
- pd->warn_trans = FALSE;
-}
-
-#ifdef Win32
-#include "run.h" /* for runcmd */
-#endif
-static void PostScriptClose(pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- PostScriptFileTrailer(pd->psfp, pd->pageno);
- if(pd->open_type == 1)
- pclose(pd->psfp);
- else {
- fclose(pd->psfp);
- if (pd->printit) {
- char buff[3*PATH_MAX+ 10];
- int err = 0;
- /* This should not be possible: the command is limited
- to 2*PATH_MAX */
- if(strlen(pd->command) + strlen(pd->filename) > 3*PATH_MAX) {
- warning(_("error from postscript() in running:\n %s"),
- pd->command);
- return;
- }
- strcpy(buff, pd->command);
- strcat(buff, " ");
- strcat(buff, pd->filename);
-/* Rprintf("buff is %s\n", buff); */
-#ifdef Unix
- err = R_system(buff);
-#endif
-#ifdef Win32
- err = Rf_runcmd(buff, CE_NATIVE, 0, 0, NULL, NULL, NULL);
-#endif
- if (err)
- warning(_("error from postscript() in running:\n %s"),
- buff);
- }
- }
-}
-
-static void PS_Close(pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- PostScriptClose(dd);
- freeDeviceCIDFontList(pd->cidfonts);
- freeDeviceFontList(pd->fonts);
- freeDeviceEncList(pd->encodings);
- pd->cidfonts = NULL;
- pd->fonts = NULL;
- pd->encodings = NULL;
- free(pd);
-}
-
-static FontMetricInfo
-*CIDsymbolmetricInfo(const char *family, PostScriptDesc *pd)
-{
- FontMetricInfo *result = NULL;
- int fontIndex;
- cidfontfamily fontfamily;
-
- fontfamily = findDeviceCIDFont(family, pd->cidfonts, &fontIndex);
- if (fontfamily) {
- /* (Type 1!) symbol font */
- result = &(fontfamily->symfont->metrics);
- } else
- error(_("CID family '%s' not included in postscript() device"),
- family);
- return result;
-}
-
-static FontMetricInfo *metricInfo(const char *family, int face,
- PostScriptDesc *pd) {
- FontMetricInfo *result = NULL;
- int fontIndex;
- type1fontfamily fontfamily = findDeviceFont(family, pd->fonts, &fontIndex);
- if (fontfamily) {
- if(face < 1 || face > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"),
- face);
- face = 1;
- }
- result = &(fontfamily->fonts[face-1]->metrics);
- } else
- error(_("family '%s' not included in postscript() device"), family);
- return result;
-}
-
-static char *convname(const char *family, PostScriptDesc *pd) {
- char *result = NULL;
- int fontIndex;
- type1fontfamily fontfamily = findDeviceFont(family, pd->fonts, &fontIndex);
- if (fontfamily)
- result = fontfamily->encoding->convname;
- else
- error(_("family '%s' not included in postscript() device"), family);
- return result;
-}
-
-static double PS_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
- if (isType1Font(gc->fontfamily, PostScriptFonts, pd->defaultFont)) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- metricInfo(gc->fontfamily, face, pd),
- pd->useKern, face,
- convname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily, PostScriptFonts) */
- if (face < 5) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- NULL, FALSE, face, NULL);
- } else {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- /* Send symbol face metric info */
- CIDsymbolmetricInfo(gc->fontfamily, pd),
- FALSE, face, NULL);
- }
- }
-}
-
-static double PS_StrWidthUTF8(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
- if (isType1Font(gc->fontfamily, PostScriptFonts, pd->defaultFont)) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- metricInfo(gc->fontfamily, face, pd),
- pd->useKern, face,
- convname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily, PostScriptFonts) */
- if (face < 5) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- NULL, FALSE, face, NULL);
- } else {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- /* Send symbol face metric info */
- CIDsymbolmetricInfo(gc->fontfamily, pd),
- FALSE, face, NULL);
- }
- }
-}
-
-static void PS_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
-
- if (isType1Font(gc->fontfamily, PostScriptFonts, pd->defaultFont)) {
- PostScriptMetricInfo(c, ascent, descent, width,
- metricInfo(gc->fontfamily, face, pd),
- face == 5, convname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily, PostScriptFonts) */
- if (face < 5) {
- PostScriptCIDMetricInfo(c, ascent, descent, width);
- } else {
- PostScriptMetricInfo(c, ascent, descent, width,
- CIDsymbolmetricInfo(gc->fontfamily, pd),
- TRUE, "");
- }
- }
- *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
- *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
- *width = floor(gc->cex * gc->ps + 0.5) * *width;
-}
-
-static void PS_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int code;
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- /* code is set as follows */
- /* code == 0, nothing to draw */
- /* code == 1, outline only */
- /* code == 2, fill only */
- /* code == 3, outline and fill */
-
- CheckAlpha(gc->fill, pd);
- CheckAlpha(gc->col, pd);
- code = 2 * (R_OPAQUE(gc->fill)) + (R_OPAQUE(gc->col));
-
- if (code) {
- if(code & 2)
- SetFill(gc->fill, dd);
- if(code & 1) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- }
- PostScriptRectangle(pd->psfp, x0, y0, x1, y1);
- fprintf(pd->psfp, "p%d\n", code);
- }
-}
-
-typedef rcolor * rcolorPtr;
-
-static void PS_imagedata(rcolorPtr raster,
- int w, int h,
- PostScriptDesc *pd)
-{
- /* Each original byte is translated to two hex digits
- (representing a number between 0 and 255) */
- for (int i = 0; i < w*h; i++)
- fprintf(pd->psfp, "%02x%02x%02x",
- R_RED(raster[i]), R_GREEN(raster[i]), R_BLUE(raster[i]));
-}
-
-static void PS_grayimagedata(rcolorPtr raster,
- int w, int h,
- PostScriptDesc *pd)
-{
- /* Weights as in PDF gray conversion */
- for (int i = 0; i < w*h; i++) {
- double r = 0.213 * R_RED(raster[i]) + 0.715 * R_GREEN(raster[i])
- + 0.072 * R_BLUE(raster[i]);
- fprintf(pd->psfp, "%02x", (int)(r+0.49));
- }
-}
-
-/* Could support 'colormodel = "cmyk"' */
-static void PS_writeRaster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- /* This takes the simple approach of creating an inline
- * image.
- * There is no support for semitransparent images, not even
- * for transparent pixels (missing values in image(useRaster = TRUE) ).
- *
- * The version in R < 2.13.2 used colorimage, hence the DeviceRGB
- * colour space.
- */
-
- /* Now we are using level-2 features, there are other things we could do
- (a) encode the data more compactly, e.g. using
- /DataSource currentfile /ASCII85Decode filter /FlateDecode filter def
-
- (b) add a mask with ImageType 3: see PLRM 3rd ed section 4.10.6.
-
- (c) interpolation (done but disabled, as at least ghostscript
- seems to ignore the request, and Mac preview always
- interpolates.)
-
- (d) sRGB colorspace (done)
- */
-
- /* Save graphics state */
- fprintf(pd->psfp, "gsave\n");
- /* set the colour space: this form of the image operator uses the
- current colour space. */
- if (streql(pd->colormodel, "srgb+gray"))
- fprintf(pd->psfp, "sRGB\n");
- else if (streql(pd->colormodel, "srgb")) /* set for page */ ;
- else if (streql(pd->colormodel, "gray"))
- fprintf(pd->psfp, "/DeviceGray setcolorspace\n");
- else
- fprintf(pd->psfp, "/DeviceRGB setcolorspace\n");
- /* translate */
- fprintf(pd->psfp, "%.2f %.2f translate\n", x, y);
- /* rotate */
- if (rot != 0.0) fprintf(pd->psfp, "%.2f rotate\n", rot);
- /* scale */
- fprintf(pd->psfp, "%.2f %.2f scale\n", width, height);
- /* write dictionary */
- fprintf(pd->psfp, "8 dict dup begin\n");
- fprintf(pd->psfp, " /ImageType 1 def\n");
- fprintf(pd->psfp, " /Width %d def\n", w);
- fprintf(pd->psfp, " /Height %d def\n", h);
- fprintf(pd->psfp, " /BitsPerComponent 8 def\n");
- if (interpolate)
- fprintf(pd->psfp, " /Interpolate true def\n");
- if (streql(pd->colormodel, "gray"))
- fprintf(pd->psfp, " /Decode [0 1] def\n");
- else
- fprintf(pd->psfp, " /Decode [0 1 0 1 0 1] def\n");
- fprintf(pd->psfp, " /DataSource currentfile /ASCIIHexDecode filter def\n");
- fprintf(pd->psfp, " /ImageMatrix [%d 0 0 %d 0 %d] def\n", w, -h, h);
- fprintf(pd->psfp, "end\n");
- fprintf(pd->psfp, "image\n");
- /* now the data */
- if (streql(pd->colormodel, "gray"))
- PS_grayimagedata(raster, w, h, pd);
- else
- PS_imagedata(raster, w, h, pd);
- fprintf(pd->psfp, ">\n");
- /* Restore graphics state */
- fprintf(pd->psfp, "grestore\n");
-}
-
-/* see comments above */
-#define OLD 1
-static void PS_Raster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
-#ifdef OLD
- if (interpolate) {
- /* Generate a new raster
- * which is interpolated from the original
- * Assume a resolution for the new raster of 72 dpi
- * Ideally would allow user to set this.
- */
- const void *vmax;
- vmax = vmaxget();
- int newW = (int) width;
- int newH = (int) height;
- unsigned int *newRaster =
- (unsigned int *) R_alloc(newW * newH, sizeof(unsigned int));
-
- R_GE_rasterInterpolate(raster, w, h,
- newRaster, newW, newH);
- PS_writeRaster(newRaster, newW, newH,
- x, y, width, height, rot, FALSE, dd);
- vmaxset(vmax);
- } else {
- PS_writeRaster(raster, w, h,
- x, y, width, height, rot, FALSE, dd);
- }
-#else
- PS_writeRaster(raster, w, h,
- x, y, width, height, rot, interpolate, dd);
-#endif
-}
-
-static void PS_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int code;
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- /* code is set as follows */
- /* code == 0, nothing to draw */
- /* code == 1, outline only */
- /* code == 2, fill only */
- /* code == 3, outline and fill */
-
- CheckAlpha(gc->fill, pd);
- CheckAlpha(gc->col, pd);
- code = 2 * (R_OPAQUE(gc->fill)) + (R_OPAQUE(gc->col));
-
- if (code) {
- if(code & 2)
- SetFill(gc->fill, dd);
- if(code & 1) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- }
- PostScriptCircle(pd->psfp, x, y, r);
- fprintf(pd->psfp, "p%d\n", code);
- }
-}
-
-static void PS_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- CheckAlpha(gc->col, pd);
- /* FIXME : clip to the device extents here */
- if(R_OPAQUE(gc->col)) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- PostScriptStartPath(pd->psfp);
- PostScriptMoveTo(pd->psfp, x1, y1);
- PostScriptRLineTo(pd->psfp, x1, y1, x2, y2);
- /* fprintf(pd->psfp, "%.2f %.2f rl\n", x2 - x1, y2 - y1);*/
- PostScriptEndPath(pd->psfp);
- }
-}
-
-static void PS_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd;
- int i, code;
-
- pd = (PostScriptDesc *) dd->deviceSpecific;
-
- /* code is set as follows */
- /* code == 0, nothing to draw */
- /* code == 1, outline only */
- /* code == 2, fill only */
- /* code == 3, outline and fill */
- /* code == 6, eofill only */
- /* code == 7, outline and eofill */
-
- CheckAlpha(gc->fill, pd);
- CheckAlpha(gc->col, pd);
- code = 2 * (R_OPAQUE(gc->fill)) + (R_OPAQUE(gc->col));
-
- if (code) {
- if(code & 2) {
- SetFill(gc->fill, dd);
- if (pd->fillOddEven) code |= 4;
- }
- if(code & 1) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- }
- fprintf(pd->psfp, "np\n");
- fprintf(pd->psfp, " %.2f %.2f m\n", x[0], y[0]);
- for(i = 1 ; i < n ; i++)
- if (i % 100 == 0)
- fprintf(pd->psfp, "%.2f %.2f lineto\n", x[i], y[i]);
- else
- PostScriptRLineTo(pd->psfp, x[i-1], y[i-1], x[i], y[i]);
- fprintf(pd->psfp, "cp p%d\n", code);
- }
-}
-
-static void PS_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd;
- int i, j, index, code;
-
- pd = (PostScriptDesc *) dd->deviceSpecific;
-
- /* code is set as follows */
- /* code == 0, nothing to draw */
- /* code == 1, outline only */
- /* code == 2, fill only */
- /* code == 3, outline and fill */
- /* code == 6, eofill only */
- /* code == 7, outline and eofill */
-
- CheckAlpha(gc->fill, pd);
- CheckAlpha(gc->col, pd);
- code = 2 * (R_OPAQUE(gc->fill)) + (R_OPAQUE(gc->col));
-
- if (code) {
- if(code & 2) {
- SetFill(gc->fill, dd);
- if (!winding) code |= 4;
- }
- if(code & 1) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- }
- fprintf(pd->psfp, "np\n");
- index = 0;
- for (i = 0; i < npoly; i++) {
- fprintf(pd->psfp, " %.2f %.2f m\n", x[index], y[index]);
- index++;
- for(j = 1; j < nper[i]; j++) {
- if (j % 100 == 0)
- fprintf(pd->psfp, "%.2f %.2f lineto\n",
- x[index], y[index]);
- else
- PostScriptRLineTo(pd->psfp, x[index-1], y[index-1],
- x[index], y[index]);
- index++;
- }
- fprintf(pd->psfp, "cp\n");
- }
- fprintf(pd->psfp, "p%d\n", code);
- }
-}
-
-static void PS_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PostScriptDesc *pd;
- int i;
-
- pd = (PostScriptDesc*) dd->deviceSpecific;
- CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- SetColor(gc->col, dd);
- SetLineStyle(gc, dd);
- fprintf(pd->psfp, "np\n");
- fprintf(pd->psfp, "%.2f %.2f m\n", x[0], y[0]);
- for(i = 1 ; i < n ; i++) {
- /* split up solid lines (only) into chunks of size 1000 */
- if(gc->lty == 0 && i%1000 == 0)
- fprintf(pd->psfp, "currentpoint o m\n");
- if (i % 100 == 0)
- fprintf(pd->psfp, "%.2f %.2f lineto\n", x[i], y[i]);
- else
- PostScriptRLineTo(pd->psfp, x[i-1], y[i-1], x[i], y[i]);
- }
- fprintf(pd->psfp, "o\n");
- }
-}
-
-static int translateFont(char *family, int style, PostScriptDesc *pd)
-{
- int result = style;
- type1fontfamily fontfamily;
- int fontIndex;
- if(style < 1 || style > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), style);
- style = 1;
- }
- fontfamily = findDeviceFont(family, pd->fonts, &fontIndex);
- if (fontfamily) {
- result = (fontIndex - 1)*5 + style;
- } else {
- warning(_("family '%s' not included in postscript() device"), family);
- }
- return result;
-}
-
-static int numFonts(type1fontlist fonts) {
- int i = 0;
- while (fonts) {
- i++;
- fonts = fonts->next;
- }
- return i;
-}
-
-static int translateCIDFont(char *family, int style, PostScriptDesc *pd)
-{
- int result = style;
- cidfontfamily fontfamily;
- int fontIndex;
- if(style < 1 || style > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), style);
- style = 1;
- }
- fontfamily = findDeviceCIDFont(family, pd->cidfonts, &fontIndex);
- if (fontfamily) {
- /*
- * CID fonts all listed after all Type 1 fonts.
- */
- result = (numFonts(pd->fonts)*5) + (fontIndex - 1)*5 + style;
- } else {
- warning(_("family '%s' not included in postscript() device"), family);
- }
- return result;
-}
-
-static void drawSimpleText(double x, double y, const char *str,
- double rot, double hadj,
- int font,
- const pGEcontext gc,
- pDevDesc dd) {
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- SetFont(font,
- (int)floor(gc->cex * gc->ps + 0.5),dd);
- CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- SetColor(gc->col, dd);
- if(pd->useKern)
- PostScriptTextKern(pd->psfp, x, y, str, hadj, rot, gc, dd);
- else
- PostScriptText(pd->psfp, x, y, str, strlen(str), hadj, rot, gc, dd);
- }
-}
-
-/* <FIXME> it would make sense to cache 'cd' here, but we would also
- need to know if the current locale's charset changes. However,
- currently this is only called in a UTF-8 locale.
- */
-static void mbcsToSbcs(const char *in, char *out, const char *encoding,
- int enc)
-{
- void *cd = NULL;
- const char *i_buf; char *o_buf;
- size_t i_len, o_len, status;
-
-#if 0
- if(enc != CE_UTF8 &&
- ( !strcmp(encoding, "latin1") || !strcmp(encoding, "ISOLatin1")) ) {
- mbcsToLatin1(in, out); /* more tolerant */
- return;
- }
-#endif
-
- if ((void*)-1 ==
- (cd = Riconv_open(encoding, (enc == CE_UTF8) ? "UTF-8" : "")))
- error(_("unknown encoding '%s' in 'mbcsToSbcs'"), encoding);
-
- i_buf = (char *) in;
- i_len = strlen(in)+1; /* include terminator */
- o_buf = (char *) out;
- o_len = i_len; /* must be the same or fewer chars */
-next_char:
- status = Riconv(cd, &i_buf, &i_len, &o_buf, &o_len);
- /* libiconv 1.13 gives EINVAL on \xe0 in UTF-8 (as used in fBasics) */
- if(status == (size_t) -1 && (errno == EILSEQ || errno == EINVAL)) {
- warning(_("conversion failure on '%s' in 'mbcsToSbcs': dot substituted for <%02x>"),
- in, (unsigned char) *i_buf),
- *o_buf++ = '.'; i_buf++; o_len--; i_len--;
- if(i_len > 0) goto next_char;
- }
-
- Riconv_close(cd);
- if (status == (size_t)-1) /* internal error? */
- error("conversion failure from %s to %s on '%s' in 'mbcsToSbcs'",
- (enc == CE_UTF8) ? "UTF-8" : "native", encoding, in);
-}
-
-static void PS_Text0(double x, double y, const char *str, int enc,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- const char *str1 = str;
- char *buff;
-
- PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-
- if (gc->fontface == 5) {
- if (isCIDFont(gc->fontfamily, PostScriptFonts, pd->defaultCIDFont)) {
- drawSimpleText(x, y, str, rot, hadj,
- translateCIDFont(gc->fontfamily, gc->fontface, pd),
- gc, dd);
- return;
- } else {
- drawSimpleText(x, y, str, rot, hadj,
- translateFont(gc->fontfamily, gc->fontface, pd),
- gc, dd);
- return;
- }
- }
-
- /* No symbol fonts from now on */
-
- if (isCIDFont(gc->fontfamily, PostScriptFonts, pd->defaultCIDFont)) {
- /* NB, we could be in a SBCS here */
- size_t ucslen;
- int fontIndex;
-
- /*
- * CID convert optimize PS encoding == locale encode case
- */
- cidfontfamily cidfont = findDeviceCIDFont(gc->fontfamily,
- pd->cidfonts,
- &fontIndex);
- if(!cidfont)
- error(_("family '%s' not included in postscript() device"),
- gc->fontfamily);
-
- if (!dd->hasTextUTF8 &&
- !strcmp(locale2charset(NULL), cidfont->encoding)) {
- SetFont(translateCIDFont(gc->fontfamily, gc->fontface, pd),
- (int)floor(gc->cex * gc->ps + 0.5),dd);
- CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- SetColor(gc->col, dd);
- PostScriptHexText(pd->psfp, x, y, str, strlen(str), hadj, rot);
- }
- return;
- }
-
- /*
- * CID convert PS encoding != locale encode case
- */
- ucslen = (dd->hasTextUTF8) ? Rf_utf8towcs(NULL, str, 0) : mbstowcs(NULL, str, 0);
- if (ucslen != (size_t)-1) {
- void *cd;
- const char *i_buf; char *o_buf;
- size_t nb, i_len, o_len, buflen = ucslen * sizeof(ucs2_t);
- size_t status;
-
- cd = (void*) Riconv_open(cidfont->encoding,
- (enc == CE_UTF8) ? "UTF-8" : "");
- if(cd == (void*)-1) {
- warning(_("failed open converter to encoding '%s'"),
- cidfont->encoding);
- return;
- }
-
- R_CheckStack2(buflen);
- unsigned char buf[buflen];
-
- i_buf = (char *)str;
- o_buf = (char *)buf;
- i_len = strlen(str); /* do not include terminator */
- nb = o_len = buflen;
-
- status = Riconv(cd, &i_buf, (size_t *)&i_len,
- (char **)&o_buf, (size_t *)&o_len);
-
- Riconv_close(cd);
- if(status == (size_t)-1)
- warning(_("failed in text conversion to encoding '%s'"),
- cidfont->encoding);
- else {
- SetFont(translateCIDFont(gc->fontfamily, gc->fontface, pd),
- (int)floor(gc->cex * gc->ps + 0.5), dd);
- CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- SetColor(gc->col, dd);
- PostScriptHexText(pd->psfp, x, y, (char *)buf,
- nb - o_len, hadj, rot);
- }
- }
- return;
- } else {
- warning(_("invalid string in '%s'"), "PS_Text");
- return;
- }
- }
-
- /* Now using single-byte non-symbol font.
-
- Was utf8locale, but it is not entirely obvious that only UTF-8
- needs re-encoding, although we don't have any other MBCSs that
- can sensibly be mapped to a SBCS.
- It would be perverse (but possible) to write English in a
- CJK MBCS.
- */
- if((enc == CE_UTF8 || mbcslocale) && !strIsASCII(str)) {
- R_CheckStack2(strlen(str)+1);
- buff = alloca(strlen(str)+1); /* Output string cannot be longer */
- mbcsToSbcs(str, buff, convname(gc->fontfamily, pd), enc);
- str1 = buff;
- }
- drawSimpleText(x, y, str1, rot, hadj,
- translateFont(gc->fontfamily, gc->fontface, pd),
- gc, dd);
-}
-
-static void PS_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PS_Text0(x, y, str, CE_NATIVE, rot, hadj, gc, dd);
-}
-
-static void PS_TextUTF8(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PS_Text0(x, y, str, CE_UTF8, rot, hadj, gc, dd);
-}
-
-
-
-/***********************************************************************
-
- XFig driver shares font handling
-
-************************************************************************/
-
-
-
-typedef struct {
- char filename[PATH_MAX];
-
- char papername[64]; /* paper name */
- int paperwidth; /* paper width in big points (1/72 in) */
- int paperheight; /* paper height in big points */
- Rboolean landscape; /* landscape mode */
- int pageno; /* page number */
-
- int fontnum; /* font number in XFig */
- int maxpointsize;
-
- double width; /* plot width in inches */
- double height; /* plot height in inches */
- double pagewidth; /* page width in inches */
- double pageheight; /* page height in inches */
- Rboolean pagecentre; /* centre image on page? */
-
- double lwd; /* current line width */
- int lty; /* current line type */
- rcolor col; /* current color */
- rcolor fill; /* current fill color */
- rcolor bg; /* background color */
- int XFigColors[534];
- int nXFigColors;
-
- FILE *psfp; /* output file */
- FILE *tmpfp; /* temp file */
- char tmpname[PATH_MAX];
-
- Rboolean onefile;
- Rboolean warn_trans; /* have we warned about translucent cols? */
- int ymax; /* used to invert coord system */
- char encoding[50]; /* for writing text */
-
- Rboolean textspecial; /* use textspecial flag in xfig for latex integration */
- Rboolean defaultfont; /* use the default font in xfig */
-
- /*
- * Fonts and encodings used on the device
- *
- * ASSUME ONLY ONE (DEFAULT) FOR NOW
- */
- type1fontlist fonts;
- encodinglist encodings;
-} XFigDesc;
-
-static void
-XF_FileHeader(FILE *fp, const char *papername, Rboolean landscape,
- Rboolean onefile)
-{
- fprintf(fp, "#FIG 3.2\n");
- fprintf(fp, landscape ? "Landscape\n" : "Portrait\n");
- fprintf(fp, "Flush Left\nInches\n");
- /* Fix */fprintf(fp, "%s\n", papername);
- fprintf(fp, "100.0\n");
- fprintf(fp, onefile ? "Multiple\n" : "Single\n");
- fprintf(fp, "-2\n"); /* no background */
- fprintf(fp, "1200 2\n"); /* coordinate system */
- fprintf(fp, "# End of XFig header\n");
-}
-
-static void XF_FileTrailer(FILE *fp)
-{
- fprintf(fp, "# end of XFig file\n");
-}
-
-
-static void XF_EndPage(FILE *fp)
-{
- fprintf(fp, "# end of XFig page\n");
-}
-
-static void XF_WriteString(FILE *fp, const char *str)
-{
- unsigned int c;
- for ( ; *str; str++) {
- c = (unsigned char)*str;
- if (c > 127) {
- fprintf(fp, "\\%o", c);
- } else {
- switch(*str) {
- case '\n':
- fprintf(fp, "\\n");
- break;
- case '\\':
- fprintf(fp, "\\\\");
- break;
- default:
- fputc(*str, fp);
- break;
- }
- }
- }
-}
-
-static void XF_CheckAlpha(int color, XFigDesc *pd)
-{
- unsigned int alpha = R_ALPHA(color);
- if (alpha > 0 && alpha < 255 && !pd->warn_trans) {
- warning(_("semi-transparency is not supported on this device: reported only once per page"));
- pd->warn_trans = TRUE;
- }
-}
-
-
-static int XF_SetColor(int color, XFigDesc *pd)
-{
- int i;
- if(!R_OPAQUE(color)) return -1;
- color = color & 0xffffff;
- for (i = 0; i < pd->nXFigColors; i++)
- if(color == pd->XFigColors[i]) return i;
- if(pd->nXFigColors == 534)
- error(_("ran out of colors in xfig()"));
- /* new colour */
- fprintf(pd->psfp, "0 %d #%02x%02x%02x\n", pd->nXFigColors,
- R_RED(color), R_GREEN(color), R_BLUE(color));
- pd->XFigColors[pd->nXFigColors] = color;
- return pd->nXFigColors++;
-}
-
-static void XFconvert(double *x, double *y, XFigDesc *pd)
-{
- (*x) *= 16.667;
- (*y) = pd->ymax - 16.667*(*y);
-}
-
-
-static int XF_SetLty(int lty)
-{
- switch(lty) {
- case LTY_BLANK:
- return -1;
- case LTY_SOLID:
- return 0;
- case LTY_DASHED:
- return 1;
- case LTY_DOTTED:
- return 2;
- case LTY_DOTDASH:
- return 3;
- default:
- warning(_("unimplemented line texture %08x: using Dash-double-dotted"),
- lty);
- return 4;
- }
-}
-
-/* Device Driver Actions */
-
-static void XFig_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd);
-static void XFig_Close(pDevDesc dd);
-static void XFig_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd);
-static void XFig_NewPage(const pGEcontext gc, pDevDesc dd);
-static void XFig_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd);
-static double XFig_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void XFig_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-static Rboolean XFig_Open(pDevDesc, XFigDesc*);
-
-/*
- * Values taken from FIG format definition
- */
-static int XFigBaseNum(const char *name)
-{
- int i;
- if (!strcmp(name, "Times"))
- i = 0;
- else if (!strcmp(name, "AvantGarde"))
- i = 4;
- else if (!strcmp(name, "Bookman"))
- i = 8;
- else if (!strcmp(name, "Courier"))
- i = 12;
- else if (!strcmp(name, "Helvetica"))
- i = 16;
- else if (!strcmp(name, "Helvetica-Narrow"))
- i = 20;
- else if (!strcmp(name, "NewCenturySchoolbook"))
- i = 24;
- else if (!strcmp(name, "Palatino"))
- i = 28;
- else {
- warning(_("unknown postscript font family '%s', using Helvetica"),
- name);
- i = 16;
- }
- return i;
-}
-
-static void XF_resetColors(XFigDesc *pd)
-{
- int i;
- for(i = 0; i < 32; i++) pd->XFigColors[i] = 0;
- pd->XFigColors[7] = 0xffffff; /* white */
- pd->nXFigColors = 32;
-}
-
-/* Driver Support Routines */
-
-static Rboolean
-XFigDeviceDriver(pDevDesc dd, const char *file, const char *paper,
- const char *family,
- const char *bg, const char *fg,
- double width, double height,
- Rboolean horizontal, double ps,
- Rboolean onefile, Rboolean pagecentre,
- Rboolean defaultfont, Rboolean textspecial,
- const char *encoding)
-{
- /* If we need to bail out with some sort of "error" */
- /* then we must free(dd) */
-
- int gotFont;
- double xoff, yoff, pointsize;
- XFigDesc *pd;
- type1fontfamily font;
- encodinginfo enc;
- encodinglist enclist;
-
- /* Check and extract the device parameters */
-
- if(strlen(file) > PATH_MAX - 1) {
- free(dd);
- error(_("filename too long in %s()"), "xfig");
- }
-
- /* allocate new xfig device description */
- if (!(pd = (XFigDesc *) malloc(sizeof(XFigDesc)))) {
- free(dd);
- error(_("memory allocation problem in %s()"), "xfig");
- return FALSE;
- }
-
- /* from here on, if need to bail out with "error", must also */
- /* free(pd) */
-
- /* initialize xfig device description */
- strcpy(pd->filename, file);
- strcpy(pd->papername, paper);
- pd->fontnum = XFigBaseNum(family);
- /* this might have changed the family, so update */
- if(pd->fontnum == 16) family = "Helvetica";
- pd->bg = R_GE_str2col(bg);
- pd->col = R_GE_str2col(fg);
- pd->fill = R_TRANWHITE;
- pd->width = width;
- pd->height = height;
- pd->landscape = horizontal;
- pd->textspecial = textspecial;
- pd->defaultfont = defaultfont;
- pointsize = floor(ps);
- if(R_TRANSPARENT(pd->bg) && R_TRANSPARENT(pd->col)) {
- free(dd);
- free(pd);
- error(_("invalid foreground/background color (xfig)"));
- }
- pd->warn_trans = FALSE;
-
- /*
- * Load the default encoding AS THE FIRST ENCODING FOR THIS DEVICE.
- */
- pd->encodings = NULL;
- if (!(enc = findEncoding("ISOLatin1.enc", pd->encodings, FALSE)))
- enc = addEncoding("ISOLatin1.enc", 0);
- if (enc && (enclist = addDeviceEncoding(enc, pd->encodings))) {
- pd->encodings = enclist;
- } else {
- free(dd);
- free(pd);
- error(_("failed to load encoding file in %s()"), "xfig");
- }
-
- /* Load default font */
- pd->fonts = NULL;
-
- gotFont = 0;
- font = findLoadedFont(family, "ISOLatin1.enc", FALSE);
- if (!font) {
- /*
- * If the font has not been loaded yet, load it.
- *
- * The family SHOULD be in the font database to get this far.
- * (checked at R level in postscript() in postscript.R)
- */
- if (isType1Font(family, PostScriptFonts, NULL)) {
- font = addFont(family, FALSE, pd->encodings);
- } else {
- error(_("only Type 1 fonts supported for XFig"));
- }
- }
- if (font) {
- /*
- * At this point the font is loaded, so add it to the
- * device's list of fonts.
- */
- pd->fonts = addDeviceFont(font, pd->fonts, &gotFont);
- }
- if (!gotFont) {
- free(dd);
- free(pd);
- error(_("failed to initialise default XFig font"));
- }
-
- /* Deal with paper and plot size and orientation */
-
- if(!strcmp(pd->papername, "Default") ||
- !strcmp(pd->papername, "default")) {
- SEXP s = STRING_ELT(GetOption1(install("papersize")), 0);
- if(s != NA_STRING && strlen(CHAR(s)) > 0)
- strcpy(pd->papername, CHAR(s));
- else strcpy(pd->papername, "A4");
- }
- if(!strcmp(pd->papername, "A4") ||
- !strcmp(pd->papername, "a4")) {
- strcpy(pd->papername, "A4");
- pd->pagewidth = 21.0 / 2.54;
- pd->pageheight = 29.7 / 2.54;
- }
- else if(!strcmp(pd->papername, "Letter") ||
- !strcmp(pd->papername, "letter")) {
- strcpy(pd->papername, "Letter");
- pd->pagewidth = 8.5;
- pd->pageheight = 11.0;
- }
- else if(!strcmp(pd->papername, "Legal") ||
- !strcmp(pd->papername, "legal")) {
- strcpy(pd->papername, "Legal");
- pd->pagewidth = 8.5;
- pd->pageheight = 14.0;
- }
- else {
- freeDeviceFontList(pd->fonts);
- freeDeviceEncList(pd->encodings);
- pd->fonts = NULL;
- pd->encodings = NULL;
- free(dd);
- free(pd);
- error(_("invalid page type '%s' (xfig)"), pd->papername);
- }
- pd->pagecentre = pagecentre;
- pd->paperwidth = (int)(72 * pd->pagewidth);
- pd->paperheight = (int)(72 * pd->pageheight);
- if(!onefile) {
- char *p = strrchr(pd->filename, '%');
- if(!p)
- warning(_("xfig(%s, onefile=FALSE) will only return the last plot"), pd->filename);
- }
- if(pd->landscape) {
- double tmp;
- tmp = pd->pagewidth;
- pd->pagewidth = pd->pageheight;
- pd->pageheight = tmp;
- }
- if(pd->width < 0.1 || pd->width > pd->pagewidth-0.5)
- pd->width = pd->pagewidth-0.5;
- if(pd->height < 0.1 || pd->height > pd->pageheight-0.5)
- pd->height = pd->pageheight-0.5;
- if(pagecentre) {
- xoff = (pd->pagewidth - pd->width)/2.0;
- yoff = (pd->pageheight - pd->height)/2.0;
- } else {
- xoff = yoff = 0.0;
- }
- if(pagecentre)
- pd->ymax = (int)(1200.0 * pd->pageheight);
- else
- pd->ymax = (int)(1200.0 * pd->height);
- pd->onefile = onefile;
- pd->maxpointsize = (int)(72.0 * ((pd->pageheight > pd->pagewidth) ?
- pd->pageheight : pd->pagewidth));
- pd->pageno = 0;
- /* Base Pointsize */
- /* Nominal Character Sizes in Pixels */
- /* Only right for 12 point font. */
- /* Max pointsize suggested by Peter Dalgaard */
-
- if(pointsize < 6.0) pointsize = 6.0;
- if(pointsize > pd->maxpointsize) pointsize = pd->maxpointsize;
- dd->startps = pointsize;
- dd->startlty = LTY_SOLID;
- dd->startfont = 1;
- dd->startfill = pd->bg;
- dd->startcol = pd->col;
- dd->startgamma = 1;
-
- /* Set graphics parameters that must be set by device driver. */
- /* Page dimensions in points. */
-
- dd->left = 72 * xoff; /* left */
- dd->right = 72 * (xoff + pd->width); /* right */
- dd->bottom = 72 * yoff; /* bottom */
- dd->top = 72 * (yoff + pd->height); /* top */
- dd->clipLeft = dd->left; dd->clipRight = dd->right;
- dd->clipBottom = dd->bottom; dd->clipTop = dd->top;
-
- dd->cra[0] = 0.9 * pointsize;
- dd->cra[1] = 1.2 * pointsize;
-
- /* Character Addressing Offsets */
- /* These offsets should center a single */
- /* plotting character over the plotting point. */
- /* Pure guesswork and eyeballing ... */
-
- dd->xCharOffset = 0.4900;
- dd->yCharOffset = 0.3333;
- dd->yLineBias = 0.2;
-
- /* Inches per Raster Unit */
- /* 1200 dpi */
- dd->ipr[0] = 1.0/72.0;
- dd->ipr[1] = 1.0/72.0;
-
- dd->canClip = FALSE;
- dd->canHAdj = 1; /* 0, 0.5, 1 */
- dd->canChangeGamma = FALSE;
- strncpy(pd->encoding, encoding, 50);
-
- XF_resetColors(pd);
-
- /* Start the driver */
-
- XFig_Open(dd, pd);
-
- dd->close = XFig_Close;
- dd->size = XFig_Size;
- dd->newPage = XFig_NewPage;
- dd->clip = XFig_Clip;
- dd->text = XFig_Text;
- dd->strWidth = XFig_StrWidth;
- dd->metricInfo = XFig_MetricInfo;
- dd->rect = XFig_Rect;
- /* dd->path = XFig_Path;
- dd->raster = XFig_Raster;
- dd->cap = XFig_Cap; */
- dd->circle = XFig_Circle;
- dd->line = XFig_Line;
- dd->polygon = XFig_Polygon;
- dd->polyline = XFig_Polyline;
- /* dd->locator = XFig_Locator;
- dd->mode = XFig_Mode; */
- dd->hasTextUTF8 = FALSE;
- dd->useRotatedTextInContour = FALSE; /* maybe */
- dd->haveTransparency = 1;
- dd->haveTransparentBg = 1;
- dd->haveRaster = 1;
- dd->haveCapture = 1;
- dd->haveLocator = 1;
-
- dd->deviceSpecific = (void *) pd;
- dd->displayListOn = FALSE;
- return 1;
-}
-
-static void XFig_cleanup(pDevDesc dd, XFigDesc *pd)
-{
- freeDeviceFontList(pd->fonts);
- freeDeviceEncList(pd->encodings);
- pd->fonts = NULL;
- pd->encodings = NULL;
- free(dd);
- free(pd);
-}
-
-
-static Rboolean XFig_Open(pDevDesc dd, XFigDesc *pd)
-{
- char buf[512], *tmp;
-
- if (strlen(pd->filename) == 0) {
- XFig_cleanup(dd, pd);
- error(_("empty file name"));
- return FALSE;
- } else {
- snprintf(buf, 512, pd->filename, pd->pageno + 1); /* page 1 to start */
- pd->psfp = R_fopen(R_ExpandFileName(buf), "w");
- }
- if (!pd->psfp) {
- XFig_cleanup(dd, pd);
- error(_("cannot open file '%s'"), buf);
- return FALSE;
- }
- /* assume tmpname is less than PATH_MAX */
- tmp = R_tmpnam("Rxfig", R_TempDir);
- strcpy(pd->tmpname, tmp);
- free(tmp);
- pd->tmpfp = R_fopen(pd->tmpname, "w");
- if (!pd->tmpfp) {
- fclose(pd->psfp);
- XFig_cleanup(dd, pd);
- error(_("cannot open file '%s'"), pd->tmpname);
- return FALSE;
- }
- XF_FileHeader(pd->psfp, pd->papername, pd->landscape, pd->onefile);
- pd->pageno = 0;
- return TRUE;
-}
-
-
-static void XFig_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd)
-{
-}
-
-static void XFig_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- *left = dd->left;
- *right = dd->right;
- *bottom = dd->bottom;
- *top = dd->top;
-}
-
-#define CHUNK 10000
-static void XFig_NewPage(const pGEcontext gc,
- pDevDesc dd)
-{
- char buf[PATH_MAX];
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
-
- pd->pageno++;
- if(pd->onefile) {
- fprintf(pd->tmpfp, "#Start of page %d\n", pd->pageno);
- if(pd->pageno > 1) XF_EndPage(pd->tmpfp);
- } else {
- char buffer[CHUNK];
- size_t nread, res;
- if(pd->pageno == 1) return;
- XF_FileTrailer(pd->tmpfp);
- fclose(pd->tmpfp);
- pd->tmpfp = R_fopen(pd->tmpname, "r");
- while(1) {
- nread = fread(buffer, 1, CHUNK, pd->tmpfp);
- if(nread > 0) {
- res = fwrite(buffer, 1, nread, pd->psfp);
- if(res != nread) error(_("write failed"));
- }
- if(nread < CHUNK) break;
- }
- fclose(pd->tmpfp);
- fclose(pd->psfp);
- snprintf(buf, PATH_MAX, pd->filename, pd->pageno);
- pd->psfp = R_fopen(R_ExpandFileName(buf), "w");
- pd->tmpfp = R_fopen(pd->tmpname, "w");
- XF_FileHeader(pd->psfp, pd->papername, pd->landscape, pd->onefile);
- XF_resetColors(pd);
- }
- XF_CheckAlpha(gc->fill, pd);
- if(R_OPAQUE(gc->fill)) {
- FILE *fp = pd->tmpfp;
- int cbg = XF_SetColor(gc->fill, pd);
- int ix0, iy0, ix1, iy1;
- double x0 = 0.0, y0 = 0.0, x1 = 72.0 * pd->pagewidth,
- y1 = 72.0 * pd->pageheight;
- XFconvert(&x0, &y0, pd); XFconvert(&x1, &y1, pd);
- ix0 = (int)x0; iy0 = (int)y0; ix1 = (int)x1; iy1 = (int)y1;
- fprintf(fp, "2 2 "); /* Polyline */
- fprintf(fp, "%d %d ", 0, 0); /* style, thickness */
- fprintf(fp, "%d %d ", cbg, cbg); /* pen colour fill colour */
- fprintf(fp, "200 0 20 4.0 0 0 -1 0 0 ");
- fprintf(fp, "%d\n", 5); /* number of points */
- fprintf(fp, "%d %d ", ix0, iy0);
- fprintf(fp, "%d %d ", ix0, iy1);
- fprintf(fp, "%d %d ", ix1, iy1);
- fprintf(fp, "%d %d ", ix1, iy0);
- fprintf(fp, "%d %d\n", ix0, iy0);
- }
- pd->warn_trans = FALSE;
-}
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-static void XFig_Close(pDevDesc dd)
-{
- char buf[CHUNK];
- size_t nread, res;
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
-
- XF_FileTrailer(pd->tmpfp);
- fclose(pd->tmpfp);
- pd->tmpfp = R_fopen(pd->tmpname, "r");
- while(1) {
- nread = fread(buf, 1, CHUNK, pd->tmpfp);
- if(nread > 0) {
- res = fwrite(buf, 1, nread, pd->psfp);
- if(res != nread) error(_("write failed"));
- }
- if(nread < CHUNK) break;
- }
- fclose(pd->tmpfp);
- unlink(pd->tmpname);
- fclose(pd->psfp);
- free(pd);
-}
-
-static void XFig_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- int ix0, iy0, ix1, iy1;
- int cbg = XF_SetColor(gc->fill, pd), cfg = XF_SetColor(gc->col, pd), cpen,
- dofill, lty = XF_SetLty(gc->lty), lwd = (int)(gc->lwd*0.833 + 0.5);
-
- if(lty < 0) return;
-
- XF_CheckAlpha(gc->col, pd);
- XF_CheckAlpha(gc->fill, pd);
- cpen = (R_OPAQUE(gc->col))? cfg: -1;
- dofill = (R_OPAQUE(gc->fill))? 20: -1;
-
- XFconvert(&x0, &y0, pd);
- XFconvert(&x1, &y1, pd);
- ix0 = (int)x0; iy0 = (int)y0; ix1 = (int)x1; iy1 = (int)y1;
- fprintf(fp, "2 2 "); /* Polyline */
- fprintf(fp, "%d %d ", lty, lwd>0?lwd:1); /* style, thickness */
- fprintf(fp, "%d %d ", cpen, cbg); /* pen colour fill colour */
- fprintf(fp, "100 0 %d ", dofill); /* depth, pen style, area fill */
- fprintf(fp, "%.2f 0 0 -1 0 0 ", 4.0*lwd); /* style value, join .... */
- fprintf(fp, "%d\n", 5); /* number of points */
- fprintf(fp, " %d %d ", ix0, iy0);
- fprintf(fp, " %d %d ", ix0, iy1);
- fprintf(fp, " %d %d ", ix1, iy1);
- fprintf(fp, " %d %d ", ix1, iy0);
- fprintf(fp, " %d %d\n", ix0, iy0);
-}
-
-static void XFig_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- int ix, iy, ir;
- int cbg = XF_SetColor(gc->fill, pd), cfg = XF_SetColor(gc->col, pd), cpen,
- dofill, lty = XF_SetLty(gc->lty), lwd = (int)(gc->lwd*0.833 + 0.5);
-
- if(lty < 0) return;
-
- XF_CheckAlpha(gc->col, pd);
- XF_CheckAlpha(gc->fill, pd);
- cpen = (R_OPAQUE(gc->col))? cfg: -1;
- dofill = (R_OPAQUE(gc->fill))? 20: -1;
-
- XFconvert(&x, &y, pd);
- ix = (int)x; iy = (int)y; ir = (int)(16.667*r);
-
- fprintf(fp, "1 3 "); /* Circle + radius */
- fprintf(fp, "%d %d ", lty, lwd>0?lwd:1); /* style, thickness */
- fprintf(fp, "%d %d ", cpen, cbg); /* pen colour fill colour */
- fprintf(fp, "100 0 %d ", dofill); /* depth, pen style, area fill */
- fprintf(fp, "%.2f 1 0 ", 4.0*lwd); /* style value, direction, x, angle */
- fprintf(fp, " %d %d %d %d %d %d %d %d \n",
- ix, iy, ir, ir, ix, iy, ix+ir, iy);
-}
-
-static void XFig_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- int lty = XF_SetLty(gc->lty), lwd = (int)(gc->lwd*0.833 + 0.5);
-
- if(lty < 0) return;
-
- XFconvert(&x1, &y1, pd);
- XFconvert(&x2, &y2, pd);
- XF_CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- fprintf(fp, "2 1 "); /* Polyline */
- fprintf(fp, "%d %d ", lty, lwd>0?lwd:1); /* style, thickness */
- fprintf(fp, "%d %d ", XF_SetColor(gc->col, pd), 7);
- /* pen colour fill colour */
- fprintf(fp, "100 0 -1 "); /* depth, pen style, area fill */
- fprintf(fp, "%.2f 0 0 -1 0 0 ", 4.0*lwd); /* style value, join .... */
- fprintf(fp, "%d\n", 2); /* number of points */
- fprintf(fp, "%d %d %d %d\n", (int)x1, (int)y1, (int)x2, (int)y2);
- }
-}
-
-static void XFig_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- double xx, yy;
- int i;
- int cbg = XF_SetColor(gc->fill, pd), cfg = XF_SetColor(gc->col, pd), cpen,
- dofill, lty = XF_SetLty(gc->lty), lwd = (int)(gc->lwd*0.833 + 0.5);
-
- if(lty < 0) return;
-
- XF_CheckAlpha(gc->col, pd);
- XF_CheckAlpha(gc->fill, pd);
- cpen = (R_OPAQUE(gc->col))? cfg: -1;
- dofill = (R_OPAQUE(gc->fill))? 20: -1;
-
- fprintf(fp, "2 3 "); /* Polyline */
- fprintf(fp, "%d %d ", lty, lwd>0?lwd:1); /* style, thickness */
- fprintf(fp, "%d %d ", cpen, cbg); /* pen colour fill colour */
- fprintf(fp, "100 0 %d ", dofill); /* depth, pen style, area fill */
- fprintf(fp, "%.2f 0 0 -1 0 0 ", 4.0*lwd); /* style value, join .... */
- fprintf(fp, "%d\n", n+1); /* number of points */
- /* close the path */
- for(i = 0 ; i <= n ; i++) {
- xx = x[i%n];
- yy = y[i%n];
- XFconvert(&xx, &yy, pd);
- fprintf(fp, " %d %d\n", (int)xx, (int)yy);
- }
-}
-
-static void XFig_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc*) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- double xx, yy;
- int i, lty = XF_SetLty(gc->lty), lwd = (int)(gc->lwd*0.833 + 0.5);
-
- XF_CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col) && lty >= 0) {
- fprintf(fp, "2 1 "); /* Polyline */
- fprintf(fp, "%d %d ", lty, lwd>0?lwd:1); /* style, thickness */
- fprintf(fp, "%d %d ", XF_SetColor(gc->col, pd), 7); /* pen colour fill colour */
- fprintf(fp, "100 0 -1 "); /* depth, pen style, area fill */
- fprintf(fp, "%.2f 0 0 -1 0 0 ", 4.0*lwd); /* style value, join .... */
- fprintf(fp, "%d\n", n); /* number of points */
- for(i = 0 ; i < n ; i++) {
- xx = x[i];
- yy = y[i];
- XFconvert(&xx, &yy, pd);
- fprintf(fp, " %d %d\n", (int)xx, (int)yy);
- }
- }
-}
-
-static const int styles[4] = {0,2,1,3};
-
-static void XFig_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- FILE *fp = pd->tmpfp;
- int fontnum, style = gc->fontface;
- double size = floor(gc->cex * gc->ps + 0.5);
- const char *str1 = str;
- char *buf;
-
- if(style < 1 || style > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), style);
- style = 1;
- }
- if(style == 5) fontnum = 32;
- else fontnum = pd->fontnum + styles[style-1];
-
- /*
- * xfig -international hoge.fig
- * mapping multibyte(EUC only) string Times{Romani,Bold} font Only
- */
- if ( mbcslocale && style != 5 )
- if (!strncmp("EUC", locale2charset(NULL), 3))
- fontnum = ((style & 1) ^ 1 ) << 1 ;
-
- XFconvert(&x, &y, pd);
- XF_CheckAlpha(gc->col, pd);
- if(R_OPAQUE(gc->col)) {
- fprintf(fp, "4 %d ", (int)floor(2*hadj)); /* Text, how justified */
- fprintf(fp, "%d 100 0 ", XF_SetColor(gc->col, pd));
- /* color, depth, pen_style */
- fprintf(fp, "%d %d %.4f %d ", pd->defaultfont?-1:fontnum, (int)size, rot * DEG2RAD,pd->textspecial?6:4);
- /* font pointsize angle flags (Postscript font) */
- fprintf(fp, "%d %d ", (int)(size*12),
- (int)(16.667*XFig_StrWidth(str, gc, dd) +0.5));
- fprintf(fp, "%d %d ", (int)x, (int)y);
- if(strcmp(pd->encoding, "none") != 0) {
- /* reencode the text */
- void *cd;
- const char *i_buf; char *o_buf;
- size_t i_len, o_len, status;
- size_t buflen = MB_LEN_MAX*strlen(str) + 1;
-
- cd = (void*)Riconv_open(pd->encoding, "");
- if(cd == (void*)-1) {
- warning(_("unable to use encoding '%s'"), pd->encoding);
- } else {
- R_CheckStack2(buflen);
- buf = (char *) alloca(buflen);
- i_buf = (char *) str;
- o_buf = buf;
- i_len = strlen(str) + 1; /* including terminator */
- o_len = buflen;
- status = Riconv(cd, &i_buf, &i_len, &o_buf, &o_len);
- Riconv_close(cd);
- if(status == (size_t)-1)
- warning(_("failed in text conversion to encoding '%s'"),
- pd->encoding);
- else str1 = buf;
- }
- }
- XF_WriteString(fp, str1);
- fprintf(fp, "\\001\n");
- }
-}
-
-static double XFig_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
-
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- &(pd->fonts->family->fonts[face-1]->metrics),
- FALSE, face, "latin1");
-}
-
-static void XFig_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- XFigDesc *pd = (XFigDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(face < 1 || face > 5) face = 1;
-
- PostScriptMetricInfo(c, ascent, descent, width,
- &(pd->fonts->family->fonts[face-1]->metrics),
- face == 5, "");
- *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
- *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
- *width = floor(gc->cex * gc->ps + 0.5) * *width;
-}
-
-
-
-/***********************************************************************
-
- PDF driver also shares font handling
-
-************************************************************************/
-
-typedef struct {
- rcolorPtr raster;
- int w;
- int h;
- Rboolean interpolate;
- int nobj; /* The object number when written out */
- int nmaskobj; /* The mask object number */
-} rasterImage;
-
-typedef struct {
- char filename[PATH_MAX];
- int open_type;
- char cmd[PATH_MAX];
-
- char papername[64]; /* paper name */
- int paperwidth; /* paper width in big points (1/72 in) */
- int paperheight; /* paper height in big points */
- int pageno; /* page number */
- int fileno; /* file number */
-
- int maxpointsize;
-
- double width; /* plot width in inches */
- double height; /* plot height in inches */
- double pagewidth; /* page width in inches */
- double pageheight; /* page height in inches */
- Rboolean pagecentre; /* centre image on page? */
- Rboolean onefile; /* one file or one file per page? */
-
- FILE *pdffp; /* output file */
- FILE *mainfp;
- FILE *pipefp;
-
- /* This group of variables track the current device status.
- * They should only be set by routines that emit PDF. */
- struct {
- double lwd; /* line width */
- int lty; /* line type */
- R_GE_lineend lend;
- R_GE_linejoin ljoin;
- double lmitre;
- int fontsize; /* font size in points */
- rcolor col; /* color */
- rcolor fill; /* fill color */
- rcolor bg; /* color */
- int srgb_fg, srgb_bg; /* Are stroke and fill colorspaces set? */
- } current;
-
- /*
- * This is a record of the alpha transparency levels used during
- * drawing to the device.
- * Only allow 256 different alpha levels
- * (because R uses 8-bit alpha channel).
- * "alphas" is a record of alphas used so far (unused set to -1)
- * There are separate alpha levels for stroking and filling
- * (i.e., col and fill)
- */
- short colAlpha[256];
- short fillAlpha[256];
- Rboolean usedAlpha;
-
- /*
- * What version of PDF are we trying to work with?
- * This is used (so far) for implementing transparency and CID fonts
- * Alphas are only used if version is at least 1.4
- */
- int versionMajor;
- int versionMinor;
-
- int nobjs; /* number of objects */
- int *pos; /* object positions */
- int max_nobjs; /* current allocation size */
- int *pageobj; /* page object numbers */
- int pagemax;
- int startstream; /* position of start of current stream */
- Rboolean inText;
- char title[1024];
- char colormodel[30];
- Rboolean dingbats, useKern;
- Rboolean fillOddEven; /* polygon fill mode */
- Rboolean useCompression;
- char tmpname[PATH_MAX]; /* used before compression */
-
- /*
- * Fonts and encodings used on the device
- */
- type1fontlist fonts;
- cidfontlist cidfonts;
- encodinglist encodings;
- /*
- * These next two just record the default device font
- */
- type1fontfamily defaultFont;
- cidfontfamily defaultCIDFont;
- /* Record if fonts are used */
- Rboolean fontUsed[100];
-
- /* Raster images used on the device */
- rasterImage *rasters;
- int numRasters; /* number in use */
- int writtenRasters; /* number written out */
- int maxRasters; /* size of array allocated */
- /* Soft masks for raster images */
- int *masks;
- int numMasks;
-
- /* Is the device "offline" (does not write out to a file) */
- Rboolean offline;
-}
-PDFDesc;
-
-/* Macro for driver actions to check for "offline" device and bail out */
-
-#define PDF_checkOffline() if (pd->offline) return
-
-/* Device Driver Actions */
-
-static Rboolean PDF_Open(pDevDesc, PDFDesc*);
-static void PDF_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd);
-static void PDF_Close(pDevDesc dd);
-static void PDF_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd);
-void PDF_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd);
-static void PDF_NewPage(const pGEcontext gc, pDevDesc dd);
-static void PDF_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Raster(unsigned int *raster, int w, int h,
- double x, double y, double width, double height,
- double rot, Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd);
-static void PDF_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd);
-double PDF_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-static double PDF_StrWidthUTF8(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void PDF_TextUTF8(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-
-/***********************************************************************
- * Some stuff for recording raster images
- */
-/* Detect an image by non-NULL rasters[] */
-static rasterImage* initRasterArray(int numRasters)
-{
- int i;
- /* why not use calloc? */
- rasterImage* rasters = malloc(numRasters*sizeof(rasterImage));
- if (rasters) {
- for (i = 0; i < numRasters; i++) {
- rasters[i].raster = NULL;
- }
- } /* else error thrown in PDFDeviceDriver */
- return rasters;
-}
-
-/* Add a raster (by making a copy)
- * Return value indicates whether the image is semi-transparent
- */
-static int addRaster(rcolorPtr raster, int w, int h,
- Rboolean interpolate, PDFDesc *pd)
-{
- int i, alpha = 0;
- rcolorPtr newRaster;
-
- if (pd->numRasters == pd->maxRasters) {
- int new = 2*pd->maxRasters;
- void *tmp;
- /* Do it this way so previous pointer is retained if it fails */
- tmp = realloc(pd->masks, new*sizeof(int));
- if(!tmp) error(_("failed to increase 'maxRaster'"));
- pd->masks = tmp;
- tmp = realloc(pd->rasters, new*sizeof(rasterImage));
- if(!tmp) error(_("failed to increase 'maxRaster'"));
- pd->rasters = tmp;
- for (i = pd->maxRasters; i < new; i++) {
- pd->rasters[i].raster = NULL;
- pd->masks[i] = -1;
- }
- pd->maxRasters = new;
- }
-
- newRaster = malloc(w*h*sizeof(rcolor));
-
- if (!newRaster)
- error(_("unable to allocate raster image"));
-
- for (i = 0; i < w*h; i++) {
- newRaster[i] = raster[i];
- if (!alpha && R_ALPHA(raster[i]) < 255) alpha = 1;
- }
- pd->rasters[pd->numRasters].raster = newRaster;
- pd->rasters[pd->numRasters].w = w;
- pd->rasters[pd->numRasters].h = h;
- pd->rasters[pd->numRasters].interpolate = interpolate;
- pd->rasters[pd->numRasters].nobj = -1; /* not yet written out */
- pd->rasters[pd->numRasters].nmaskobj = -1; /* not yet written out */
-
- /* If any of the pixels are not opaque, we need to add
- * a mask as well */
- if (alpha)
- pd->masks[pd->numRasters] = pd->numMasks++;
-
- pd->numRasters++;
-
- return alpha;
-}
-
-static void killRasterArray(rasterImage *rasters, int numRasters) {
- int i;
- for (i = 0; i < numRasters; i++)
- if (rasters[i].raster != NULL) free(rasters[i].raster);
-}
-
-/* Detect a mask by masks[] >= 0 */
-static int* initMaskArray(int numRasters) {
- int i;
- int* masks = malloc(numRasters*sizeof(int));
- if (masks) {
- for (i = 0; i < numRasters; i++) masks[i] = -1;
- } /* else error thrown in PDFDeviceDriver */
- return masks;
-}
-
-static void writeRasterXObject(rasterImage raster, int n,
- int mask, int maskObj, PDFDesc *pd)
-{
- Bytef *buf, *buf2, *p;
- uLong inlen;
-
- if (streql(pd->colormodel, "gray")) {
- inlen = raster.w * raster.h;
- p = buf = Calloc(inlen, Bytef);
- for(int i = 0; i < raster.w * raster.h; i++) {
- double r = 0.213 * R_RED(raster.raster[i])
- + 0.715 * R_GREEN(raster.raster[i])
- + 0.072 * R_BLUE(raster.raster[i]);
- *p++ = (Bytef)(r + 0.49);
- }
- } else {
- inlen = 3 * raster.w * raster.h;
- p = buf = Calloc(inlen, Bytef);
- for(int i = 0; i < raster.w * raster.h; i++) {
- *p++ = R_RED(raster.raster[i]);
- *p++ = R_GREEN(raster.raster[i]);
- *p++ = R_BLUE(raster.raster[i]);
- }
- }
- uLong outlen = inlen;
- if (pd->useCompression) {
- outlen = (int)(1.001*inlen + 20);
- buf2 = Calloc(outlen, Bytef);
- int res = compress(buf2, &outlen, buf, inlen);
- if(res != Z_OK) error("internal error %d in writeRasterXObject", res);
- Free(buf);
- buf = buf2;
- }
- fprintf(pd->pdffp, "%d 0 obj <<\n", n);
- fprintf(pd->pdffp, " /Type /XObject\n");
- fprintf(pd->pdffp, " /Subtype /Image\n");
- fprintf(pd->pdffp, " /Width %d\n", raster.w);
- fprintf(pd->pdffp, " /Height %d\n", raster.h);
- if (streql(pd->colormodel, "gray"))
- fprintf(pd->pdffp, " /ColorSpace /DeviceGray\n");
- else if (streql(pd->colormodel, "srgb"))
- fprintf(pd->pdffp, " /ColorSpace 5 0 R\n"); /* sRGB */
- else
- fprintf(pd->pdffp, " /ColorSpace /DeviceRGB\n");
- fprintf(pd->pdffp, " /BitsPerComponent 8\n");
- fprintf(pd->pdffp, " /Length %u\n", (unsigned)
- (pd->useCompression ? outlen : 2 * outlen + 1));
- if (raster.interpolate)
- fprintf(pd->pdffp, " /Interpolate true\n");
- if (pd->useCompression)
- fprintf(pd->pdffp, " /Filter /FlateDecode\n");
- else
- fprintf(pd->pdffp, " /Filter /ASCIIHexDecode\n");
- if (mask >= 0)
- fprintf(pd->pdffp, " /SMask %d 0 R\n", maskObj);
- fprintf(pd->pdffp, " >>\nstream\n");
- if (pd->useCompression) {
- size_t res = fwrite(buf, 1, outlen, pd->pdffp);
- if(res != outlen) error(_("write failed"));
- } else {
- for(int i = 0; i < outlen; i++)
- fprintf(pd->pdffp, "%02x", buf[i]);
- fprintf(pd->pdffp, ">\n");
- }
- Free(buf);
- fprintf(pd->pdffp, "endstream\nendobj\n");
-}
-
-static void writeMaskXObject(rasterImage raster, int n, PDFDesc *pd)
-{
- Bytef *buf, *buf2, *p;
- uLong inlen = raster.w * raster.h, outlen = inlen;
- p = buf = Calloc(outlen, Bytef);
- for(int i = 0; i < raster.w * raster.h; i++)
- *p++ = R_ALPHA(raster.raster[i]);
- if (pd->useCompression) {
- outlen = (uLong)(1.001*inlen + 20);
- buf2 = Calloc(outlen, Bytef);
- int res = compress(buf2, &outlen, buf, inlen);
- if(res != Z_OK) error("internal error %d in writeRasterXObject", res);
- Free(buf);
- buf = buf2;
- }
- fprintf(pd->pdffp, "%d 0 obj <<\n", n);
- fprintf(pd->pdffp, " /Type /XObject\n");
- fprintf(pd->pdffp, " /Subtype /Image\n");
- fprintf(pd->pdffp, " /Width %d\n", raster.w);
- fprintf(pd->pdffp, " /Height %d\n", raster.h);
- /* This is not a mask but a 'soft mask' */
- fprintf(pd->pdffp, " /ColorSpace /DeviceGray\n");
- fprintf(pd->pdffp, " /BitsPerComponent 8\n");
- fprintf(pd->pdffp, " /Length %u\n", (unsigned)
- (pd->useCompression ? outlen : 2 * outlen + 1));
- if (raster.interpolate)
- fprintf(pd->pdffp, " /Interpolate true\n");
- if (pd->useCompression)
- fprintf(pd->pdffp, " /Filter /FlateDecode\n");
- else
- fprintf(pd->pdffp, " /Filter /ASCIIHexDecode\n");
- fprintf(pd->pdffp, " >>\nstream\n");
- if (pd->useCompression) {
- size_t res = fwrite(buf, 1, outlen, pd->pdffp);
- if(res != outlen) error(_("write failed"));
- } else {
- for(int i = 0; i < outlen; i++)
- fprintf(pd->pdffp, "%02x", buf[i]);
- fprintf(pd->pdffp, ">\n");
- }
- Free(buf);
- fprintf(pd->pdffp, "endstream\nendobj\n");
-}
-
-/***********************************************************************
- * Some stuff for fonts
- */
-/*
- * Add a graphics engine font family to the list of fonts used on a
- * PDF device ...
- *
- * ... AND add the font encoding to the list of encodings used on the
- * device (if necessary)
- */
-/*
- * Differs from addDeviceFont (used in PostScript device)
- * because we do not need to immediately write font
- * information to file. In PDF, the font information is
- * all written at the end as part of the file footer.
- */
-static Rboolean addPDFDeviceCIDfont(cidfontfamily family,
- PDFDesc *pd,
- int *fontIndex)
-{
- Rboolean result = FALSE;
- cidfontlist fontlist = addDeviceCIDFont(family, pd->cidfonts, fontIndex);
- if (fontlist) {
- pd->cidfonts = fontlist;
- result = TRUE;
- }
- return result;
-}
-
-static Rboolean addPDFDevicefont(type1fontfamily family,
- PDFDesc *pd,
- int *fontIndex)
-{
- Rboolean result = FALSE;
- type1fontlist fontlist = addDeviceFont(family, pd->fonts, fontIndex);
- if (fontlist) {
- int dontcare;
- encodinginfo encoding =
- findDeviceEncoding(family->encoding->encpath,
- pd->encodings, &dontcare);
- if (encoding) {
- pd->fonts = fontlist;
- result = TRUE;
- } else {
- /*
- * The encoding should have been loaded when the font was loaded
- */
- encoding = findEncoding(family->encoding->encpath,
- pd->encodings, TRUE);
- if (!encoding) {
- warning(_("corrupt loaded encodings; font not added"));
- } else {
- encodinglist enclist = addDeviceEncoding(encoding,
- pd->encodings);
- if (enclist) {
- pd->fonts = fontlist;
- pd->encodings = enclist;
- result = TRUE;
- } else
- warning(_("failed to record device encoding; font not added"));
- }
- }
- }
- return result;
-}
-
-static void PDFcleanup(int stage, PDFDesc *pd) {
- switch (stage) {
- case 6: /* Allocated masks */
- free(pd->masks);
- case 5: /* Allocated rasters */
- free(pd->rasters);
- case 4: /* Allocated fonts */
- freeDeviceFontList(pd->fonts);
- freeDeviceCIDFontList(pd->cidfonts);
- freeDeviceEncList(pd->encodings);
- pd->fonts = NULL;
- pd->cidfonts = NULL;
- pd->encodings = NULL;
- case 3: /* Allocated pageobj */
- free(pd->pageobj);
- case 2: /* Allocated pos */
- free(pd->pos);
- case 1: /* Allocated PDFDesc */
- free(pd);
- }
-}
-
-Rboolean
-PDFDeviceDriver(pDevDesc dd, const char *file, const char *paper,
- const char *family, const char **afmpaths,
- const char *encoding,
- const char *bg, const char *fg, double width, double height,
- double ps, int onefile, int pagecentre,
- const char *title, SEXP fonts,
- int versionMajor, int versionMinor,
- const char *colormodel, int dingbats, int useKern,
- Rboolean fillOddEven, Rboolean useCompression)
-{
- /* If we need to bail out with some sort of "error" */
- /* then we must free(dd) */
-
- int i, gotFont;
- double xoff = 0.0, yoff = 0.0, pointsize;
- rcolor setbg, setfg;
- encodinginfo enc;
- encodinglist enclist;
- type1fontfamily font;
- cidfontfamily cidfont = NULL;
-
- PDFDesc *pd;
-
- /* Check and extract the device parameters */
-
- /* 'file' could be NULL */
- if(file && strlen(file) > PATH_MAX - 1) {
- /* not yet created PDFcleanup(0, pd); */
- free(dd);
- error(_("filename too long in %s()"), "pdf");
- }
-
- /* allocate new PDF device description */
- if (!(pd = (PDFDesc *) malloc(sizeof(PDFDesc)))) {
- free(dd);
- error(_("memory allocation problem in %s()"), "pdf");
- }
- /* from here on, if need to bail out with "error", must also
- free(pd) */
-
- pd->versionMajor = versionMajor;
- pd->versionMinor = versionMinor;
-
- /* This is checked at the start of every page. We typically have
- three objects per page plus one or two for each raster image,
- so this is an ample initial allocation.
- */
- pd->max_nobjs = 2000;
- pd->pos = (int *) calloc(pd->max_nobjs, sizeof(int));
- if(!pd->pos) {
- PDFcleanup(1, pd);
- free(dd);
- error("cannot allocate pd->pos");
- }
- /* This one is dynamic: initial allocation */
- pd->pagemax = 100;
- pd->pageobj = (int *) calloc(pd->pagemax, sizeof(int));
- if(!pd->pageobj) {
- PDFcleanup(2, pd);
- free(dd);
- error("cannot allocate pd->pageobj");
- }
-
-
- /* initialize PDF device description */
- /* 'file' could be NULL */
- if (file)
- strcpy(pd->filename, file);
- else
- strcpy(pd->filename, "nullPDF");
- strcpy(pd->papername, paper);
- strncpy(pd->title, title, 1024);
- memset(pd->fontUsed, 0, 100*sizeof(Rboolean));
- if (streql(colormodel, "grey")) strcpy(pd->colormodel, "gray");
- else strncpy(pd->colormodel, colormodel, 30);
- pd->dingbats = (dingbats != 0);
- pd->useKern = (useKern != 0);
- pd->fillOddEven = fillOddEven;
- pd->useCompression = useCompression;
- if(useCompression && pd->versionMajor == 1 && pd->versionMinor < 2) {
- pd->versionMinor = 2;
- warning(_("increasing the PDF version to 1.2"));
- }
-
- pd->width = width;
- pd->height = height;
-
- if (file)
- pd->offline = FALSE;
- else
- pd->offline = TRUE;
-
- if(strlen(encoding) > PATH_MAX - 1) {
- PDFcleanup(3, pd);
- free(dd);
- error(_("encoding path is too long in %s()"), "pdf");
- }
- /*
- * Load the default encoding AS THE FIRST ENCODING FOR THIS DEVICE.
- *
- * encpath MUST NOT BE "default"
- */
- pd->encodings = NULL;
- if (!(enc = findEncoding(encoding, pd->encodings, TRUE)))
- enc = addEncoding(encoding, 1);
- if (enc && (enclist = addDeviceEncoding(enc,
- pd->encodings))) {
- pd->encodings = enclist;
- } else {
- PDFcleanup(3, pd);
- free(dd);
- error(_("failed to load default encoding"));
- }
-
- /*****************************
- * Load fonts
- *****************************/
- pd->fonts = NULL;
- pd->cidfonts = NULL;
-
- gotFont = 0;
- /*
- * If user specified afms then assume the font hasn't been loaded
- * Could lead to redundant extra loading of a font, but not often(?)
- */
- if (!strcmp(family, "User")) {
- font = addDefaultFontFromAFMs(encoding, afmpaths, 0, pd->encodings);
- } else {
- /*
- * Otherwise, family is a device-independent font family.
- * One of the elements of pdfFonts().
- * NOTE this is the first font loaded on this device!
- */
- /*
- * Check first whether this font has been loaded
- * in this R session
- */
- font = findLoadedFont(family, encoding, TRUE);
- cidfont = findLoadedCIDFont(family, TRUE);
- if (!(font || cidfont)) {
- /*
- * If the font has not been loaded yet, load it.
- *
- * The family SHOULD be in the font database to get this far.
- * (checked at R level in postscript() in postscript.R)
- */
- if (isType1Font(family, PDFFonts, NULL)) {
- font = addFont(family, TRUE, pd->encodings);
- } else if (isCIDFont(family, PDFFonts, NULL)) {
- cidfont = addCIDFont(family, TRUE);
- } else {
- /*
- * Should NOT get here.
- */
- error(_("invalid font type"));
- }
- }
- }
- if (font || cidfont) {
- /*
- * At this point the font is loaded, so add it to the
- * device's list of fonts.
- */
- if (!strcmp(family, "User") ||
- isType1Font(family, PDFFonts, NULL)) {
- addPDFDevicefont(font, pd, &gotFont);
- pd->defaultFont = pd->fonts->family;
- pd->defaultCIDFont = NULL;
- } else /* (isCIDFont(family, PDFFonts)) */ {
- addPDFDeviceCIDfont(cidfont, pd, &gotFont);
- pd->defaultFont = NULL;
- pd->defaultCIDFont = pd->cidfonts->cidfamily;
- }
- }
- if (!gotFont) {
- PDFcleanup(3, pd);
- free(dd);
- error(_("failed to initialise default PDF font"));
- }
-
- /*
- * Load the font names sent in via the fonts arg
- * NOTE that these are the font names specified at the
- * R-level, NOT the translated font names.
- */
- if (!isNull(fonts)) {
- int i, dontcare, gotFonts = 0, nfonts = LENGTH(fonts);
- for (i = 0; i < nfonts; i++) {
- int index, cidindex;
- const char *name = CHAR(STRING_ELT(fonts, i));
- if (findDeviceFont(name, pd->fonts, &index) ||
- findDeviceCIDFont(name, pd->cidfonts, &cidindex))
- gotFonts++;
- else {
- /*
- * Check whether the font is loaded and, if not,
- * load it.
- */
- font = findLoadedFont(name, encoding, TRUE);
- cidfont = findLoadedCIDFont(name, TRUE);
- if (!(font || cidfont)) {
- if (isType1Font(name, PDFFonts, NULL)) {
- font = addFont(name, TRUE, pd->encodings);
- } else if (isCIDFont(name, PDFFonts, NULL)) {
- cidfont = addCIDFont(name, TRUE);
- } else {
- /*
- * Should NOT get here.
- */
- error(_("invalid font type"));
- }
- }
- /*
- * Once the font is loaded, add it to the device's
- * list of fonts.
- */
- if (font || cidfont) {
- if (isType1Font(name, PDFFonts, NULL)) {
- if (addPDFDevicefont(font, pd, &dontcare)) {
- gotFonts++;
- }
- } else /* (isCIDFont(family, PDFFonts)) */ {
- if (addPDFDeviceCIDfont(cidfont, pd, &dontcare)) {
- gotFonts++;
- }
- }
- }
- }
- }
- if (gotFonts < nfonts) {
- PDFcleanup(4, pd);
- free(dd);
- error(_("failed to initialise additional PDF fonts"));
- }
- }
- /*****************************
- * END Load fonts
- *****************************/
-
- pd->numRasters = pd->writtenRasters = 0;
- pd->maxRasters = 64; /* dynamic */
- pd->rasters = initRasterArray(pd->maxRasters);
- if (!pd->rasters) {
- PDFcleanup(4, pd);
- free(dd);
- error(_("failed to allocate rasters"));
- }
- pd->numMasks = 0;
- pd->masks = initMaskArray(pd->maxRasters);
- if (!pd->masks) {
- PDFcleanup(5, pd);
- free(dd);
- error(_("failed to allocate masks"));
- }
-
- setbg = R_GE_str2col(bg);
- setfg = R_GE_str2col(fg);
-
- /*
- * Initialise all alphas to -1
- */
- pd->usedAlpha = FALSE;
- for (i = 0; i < 256; i++) {
- pd->colAlpha[i] = -1;
- pd->fillAlpha[i] = -1;
- }
-
- /* Deal with paper and plot size and orientation */
-
- if(!strcmp(pd->papername, "Default") ||
- !strcmp(pd->papername, "default")) {
- SEXP s = STRING_ELT(GetOption1(install("papersize")), 0);
- if(s != NA_STRING && strlen(CHAR(s)) > 0)
- strcpy(pd->papername, CHAR(s));
- else strcpy(pd->papername, "a4");
- }
- if(!strcmp(pd->papername, "A4") ||
- !strcmp(pd->papername, "a4")) {
- pd->pagewidth = 21.0 / 2.54;
- pd->pageheight = 29.7 /2.54;
- }
- else if(!strcmp(pd->papername, "A4r") ||
- !strcmp(pd->papername, "a4r")) {
- pd->pageheight = 21.0 / 2.54;
- pd->pagewidth = 29.7 /2.54;
- }
- else if(!strcmp(pd->papername, "Letter") ||
- !strcmp(pd->papername, "letter") ||
- !strcmp(pd->papername, "US") ||
- !strcmp(pd->papername, "us")) {
- pd->pagewidth = 8.5;
- pd->pageheight = 11.0;
- }
- else if(!strcmp(pd->papername, "USr") ||
- !strcmp(pd->papername, "usr")) {
- pd->pageheight = 8.5;
- pd->pagewidth = 11.0;
- }
- else if(!strcmp(pd->papername, "Legal") ||
- !strcmp(pd->papername, "legal")) {
- pd->pagewidth = 8.5;
- pd->pageheight = 14.0;
- }
- else if(!strcmp(pd->papername, "Executive") ||
- !strcmp(pd->papername, "executive")) {
- pd->pagewidth = 7.25;
- pd->pageheight = 10.5;
- }
- else if(!strcmp(pd->papername, "special")) {
- pd->pagewidth = width;
- pd->pageheight = height;
- }
- else {
- PDFcleanup(6, pd);
- free(dd);
- error(_("invalid paper type '%s' (pdf)"), pd->papername);
- }
- pd->pagecentre = pagecentre;
- pd->paperwidth = (int)(72 * pd->pagewidth);
- pd->paperheight = (int)(72 * pd->pageheight);
- if(strcmp(pd->papername, "special"))
- {
- if(pd->width < 0.1 || pd->width > pd->pagewidth-0.5)
- pd->width = pd->pagewidth-0.5;
- if(pd->height < 0.1 || pd->height > pd->pageheight-0.5)
- pd->height = pd->pageheight-0.5;
- }
- if(pagecentre)
- {
- xoff = (pd->pagewidth - pd->width)/2.0;
- yoff = (pd->pageheight - pd->height)/2.0;
- } else {
- xoff = yoff = 0.0;
- }
-
- pointsize = floor(ps);
- if(R_TRANSPARENT(setbg) && R_TRANSPARENT(setfg)) {
- PDFcleanup(6, pd);
- free(dd);
- error(_("invalid foreground/background color (pdf)"));
- }
-
- pd->onefile = onefile;
- pd->maxpointsize = (int)(72.0 * ((pd->pageheight > pd->pagewidth) ?
- pd->pageheight : pd->pagewidth));
- pd->pageno = pd->fileno = 0;
- /* Base Pointsize */
- /* Nominal Character Sizes in Pixels */
- /* Only right for 12 point font. */
- /* Max pointsize suggested by Peter Dalgaard */
-
- if(pointsize < 6.0) pointsize = 6.0;
- if(pointsize > pd->maxpointsize) pointsize = pd->maxpointsize;
- dd->startps = pointsize;
- dd->startlty = 0;
- dd->startfont = 1;
- dd->startfill = setbg;
- dd->startcol = setfg;
- dd->startgamma = 1;
-
- /* Set graphics parameters that must be set by device driver. */
- /* Page dimensions in points. */
-
- dd->left = 72 * xoff; /* left */
- dd->right = 72 * (xoff + pd->width); /* right */
- dd->bottom = 72 * yoff; /* bottom */
- dd->top = 72 * (yoff + pd->height); /* top */
- dd->clipLeft = dd->left; dd->clipRight = dd->right;
- dd->clipBottom = dd->bottom; dd->clipTop = dd->top;
-
- dd->cra[0] = 0.9 * pointsize;
- dd->cra[1] = 1.2 * pointsize;
-
- /* Character Addressing Offsets */
- /* These offsets should center a single */
- /* plotting character over the plotting point. */
- /* Pure guesswork and eyeballing ... */
-
- dd->xCharOffset = 0.4900;
- dd->yCharOffset = 0.3333;
- dd->yLineBias = 0.2;
-
- /* Inches per Raster Unit */
- /* 1200 dpi */
- dd->ipr[0] = 1.0/72.0;
- dd->ipr[1] = 1.0/72.0;
-
- dd->canClip = TRUE;
- dd->canHAdj = 0;
- dd->canChangeGamma = FALSE;
-
- /* Start the driver */
- PDF_Open(dd, pd); /* errors on failure */
-
- dd->close = PDF_Close;
- dd->size = PDF_Size;
- dd->newPage = PDF_NewPage;
- dd->clip = PDF_Clip;
- dd->text = PDF_Text;
- dd->strWidth = PDF_StrWidth;
- dd->metricInfo = PDF_MetricInfo;
- dd->rect = PDF_Rect;
- dd->path = PDF_Path;
- dd->raster = PDF_Raster;
- dd->circle = PDF_Circle;
- dd->line = PDF_Line;
- dd->polygon = PDF_Polygon;
- dd->polyline = PDF_Polyline;
- /* dd->locator = PDF_Locator;
- dd->mode = PDF_Mode; */
- dd->hasTextUTF8 = TRUE;
- dd->textUTF8 = PDF_TextUTF8;
- dd->strWidthUTF8 = PDF_StrWidthUTF8;
- dd->useRotatedTextInContour = TRUE;
- dd->haveTransparency = 2;
- dd->haveTransparentBg = 3;
- dd->haveRaster = 2;
-
- dd->deviceSpecific = (void *) pd;
- dd->displayListOn = FALSE;
- return TRUE;
-}
-
-/* Called at the start of a page and when clipping is reset */
-static void PDF_Invalidate(pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- pd->current.fontsize = -1;
- pd->current.lwd = -1;
- pd->current.lty = -1;
- pd->current.lend = 0;
- pd->current.ljoin = 0;
- pd->current.lmitre = 0;
- /* page starts with black as the default fill and stroke colours */
- pd->current.col = INVALID_COL;
- pd->current.fill = INVALID_COL;
- pd->current.bg = INVALID_COL;
- pd->current.srgb_fg = pd->current.srgb_bg = 0;
-}
-
-
-/*
- * Search through the alphas used so far and return
- * existing index if there is one.
- * Otherwise, add alpha to the list and return new index
- */
-static int alphaIndex(int alpha, short *alphas) {
- int i, found = 0;
- for (i = 0; i < 256 && !found; i++) {
- if (alphas[i] < 0) {
- alphas[i] = (short) alpha;
- found = 1;
- }
- else if (alpha == alphas[i])
- found = 1;
- }
- if (!found)
- error(_("invalid 'alpha' value in PDF"));
- return i;
-}
-
-/*
- * colAlpha graphics state parameter dictionaries are named
- * /GS1 to /GS256
- * fillAlpha graphics state parameter dictionaries are named
- * /GS257 to /GS512
- */
-static int colAlphaIndex(int alpha, PDFDesc *pd) {
- return alphaIndex(alpha, pd->colAlpha);
-}
-
-static int fillAlphaIndex(int alpha, PDFDesc *pd) {
- return alphaIndex(alpha, pd->fillAlpha) + 256;
-}
-
-/*
- * Does the version support alpha transparency?
- * As from R 2.4.0 bump the version number so it does.
- */
-static void alphaVersion(PDFDesc *pd) {
- if(pd->versionMajor == 1 && pd->versionMinor < 4) {
- pd->versionMinor = 4;
- warning(_("increasing the PDF version to 1.4"));
- }
- pd->usedAlpha = TRUE;
-}
-
-/*
- * Do we need to bother with semi-transparency?
- */
-static int semiTransparent(int col)
-{
- return !(R_OPAQUE(col) || R_TRANSPARENT(col));
-}
-
-static void PDF_SetLineColor(int color, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- if(color != pd->current.col) {
- unsigned int alpha = R_ALPHA(color);
- if (0 < alpha && alpha < 255) alphaVersion(pd);
- if (pd->usedAlpha) {
- /*
- * Apply graphics state parameter dictionary
- * to set alpha
- */
- fprintf(pd->pdffp, "/GS%i gs\n", colAlphaIndex(alpha, pd));
- }
- if(streql(pd->colormodel, "gray")) {
- double r = R_RED(color)/255.0, g = R_GREEN(color)/255.0,
- b = R_BLUE(color)/255.0;
- /* weights from C-9 of
- http://www.faqs.org/faqs/graphics/colorspace-faq/
- Those from C-11 might be more appropriate.
- */
- fprintf(pd->pdffp, "%.3f G\n", (0.213*r+0.715*g+0.072*b));
- } else if(streql(pd->colormodel, "cmyk")) {
- double r = R_RED(color)/255.0, g = R_GREEN(color)/255.0,
- b = R_BLUE(color)/255.0;
- double c = 1.0-r, m = 1.0-g, y = 1.0-b, k = c;
- k = fmin2(k, m);
- k = fmin2(k, y);
- if(k == 1.0) c = m = y = 0.0;
- else { c = (c-k)/(1-k); m = (m-k)/(1-k); y = (y-k)/(1-k); }
- fprintf(pd->pdffp, "%.3f %.3f %.3f %.3f K\n", c, m, y, k);
- } else if(streql(pd->colormodel, "rgb")) {
- fprintf(pd->pdffp, "%.3f %.3f %.3f RG\n",
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0);
- } else {
- if (!streql(pd->colormodel, "srgb"))
- warning(_("unknown 'colormodel', using 'srgb'"));
- if (!pd->current.srgb_bg) {
- fprintf(pd->pdffp, "/sRGB CS\n");
- pd->current.srgb_bg = 1;
- }
- fprintf(pd->pdffp, "%.3f %.3f %.3f SCN\n",
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0);
- }
- pd->current.col = color;
- }
-}
-
-static void PDF_SetFill(int color, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- if(color != pd->current.fill) {
- unsigned int alpha = R_ALPHA(color);
- if (0 < alpha && alpha < 255) alphaVersion(pd);
- if (pd->usedAlpha) {
- /*
- * Apply graphics state parameter dictionary
- * to set alpha
- */
- fprintf(pd->pdffp, "/GS%i gs\n", fillAlphaIndex(alpha, pd));
- }
- if(streql(pd->colormodel, "gray")) {
- double r = R_RED(color)/255.0, g = R_GREEN(color)/255.0,
- b = R_BLUE(color)/255.0;
- fprintf(pd->pdffp, "%.3f g\n", (0.213*r+0.715*g+0.072*b));
- } else if(streql(pd->colormodel, "cmyk")) {
- double r = R_RED(color)/255.0, g = R_GREEN(color)/255.0,
- b = R_BLUE(color)/255.0;
- double c = 1.0-r, m = 1.0-g, y = 1.0-b, k = c;
- k = fmin2(k, m);
- k = fmin2(k, y);
- if(k == 1.0) c = m = y = 0.0;
- else { c = (c-k)/(1-k); m = (m-k)/(1-k); y = (y-k)/(1-k); }
- fprintf(pd->pdffp, "%.3f %.3f %.3f %.3f k\n", c, m, y, k);
- } else if(streql(pd->colormodel, "rgb")) {
- fprintf(pd->pdffp, "%.3f %.3f %.3f rg\n",
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0);
- } else {
- if (!streql(pd->colormodel, "srgb"))
- warning(_("unknown 'colormodel', using 'srgb'"));
- if (!pd->current.srgb_fg) {
- fprintf(pd->pdffp, "/sRGB cs\n");
- pd->current.srgb_fg = 1;
- }
- fprintf(pd->pdffp, "%.3f %.3f %.3f scn\n",
- R_RED(color)/255.0,
- R_GREEN(color)/255.0,
- R_BLUE(color)/255.0);
- }
-
- pd->current.fill = color;
- }
-}
-
-static void PDFSetLineEnd(FILE *fp, R_GE_lineend lend)
-{
- int lineend = 1; /* -Wall */
- switch (lend) {
- case GE_ROUND_CAP:
- lineend = 1;
- break;
- case GE_BUTT_CAP:
- lineend = 0;
- break;
- case GE_SQUARE_CAP:
- lineend = 2;
- break;
- default:
- error(_("invalid line end"));
- }
- fprintf(fp, "%1d J\n", lineend);
-}
-
-static void PDFSetLineJoin(FILE *fp, R_GE_linejoin ljoin)
-{
- int linejoin = 1; /* -Wall */
- switch (ljoin) {
- case GE_ROUND_JOIN:
- linejoin = 1;
- break;
- case GE_MITRE_JOIN:
- linejoin = 0;
- break;
- case GE_BEVEL_JOIN:
- linejoin = 2;
- break;
- default:
- error(_("invalid line join"));
- }
- fprintf(fp, "%1d j\n", linejoin);
-}
-
-/* Note that the line texture is scaled by the line width.*/
-static void PDFSetLineTexture(FILE *fp, const char *dashlist, int nlty,
- double lwd, int lend)
-{
- PP_SetLineTexture("d", (lend == GE_BUTT_CAP) ? 0. : 1.);
-}
-
-static void PDF_SetLineStyle(const pGEcontext gc, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- char dashlist[8];
- int i;
- int newlty = gc->lty;
- double linewidth;
- double newlwd = gc->lwd;
- R_GE_lineend newlend = gc->lend;
- R_GE_linejoin newljoin = gc->ljoin;
- double newlmitre = gc->lmitre;
-
- if (pd->current.lty != newlty || pd->current.lwd != newlwd ||
- pd->current.lend != newlend) {
- pd->current.lwd = newlwd;
- pd->current.lty = newlty;
- linewidth = newlwd * 0.75;
- /* Must not allow line width to be zero */
- if (linewidth < .01)
- linewidth = .01;
- fprintf(pd->pdffp, "%.2f w\n", linewidth);
- /* process lty : */
- for(i = 0; i < 8 && newlty & 15 ; i++) {
- dashlist[i] = newlty & 15;
- newlty = newlty >> 4;
- }
- PDFSetLineTexture(pd->pdffp, dashlist, i, newlwd * 0.75, newlend);
- }
- if (pd->current.lend != newlend) {
- pd->current.lend = newlend;
- PDFSetLineEnd(pd->pdffp, newlend);
- }
- if (pd->current.ljoin != newljoin) {
- pd->current.ljoin = newljoin;
- PDFSetLineJoin(pd->pdffp, newljoin);
- }
- if (pd->current.lmitre != newlmitre) {
- pd->current.lmitre = newlmitre;
- fprintf(pd->pdffp, "%.2f M\n", newlmitre);
- }
-}
-
-/* This was an optimization that has effectively been disabled in
- 2.8.0, to avoid repeatedly going in and out of text mode. Howver,
- Acrobat puts all text rendering calls in BT...ET into a single
- transparency group, and other viewers do not. So for consistent
- rendering we put each text() call into a separate group.
-*/
-static void texton(PDFDesc *pd)
-{
- fprintf(pd->pdffp, "BT\n");
- pd->inText = TRUE;
-}
-
-static void textoff(PDFDesc *pd)
-{
- fprintf(pd->pdffp, "ET\n");
- pd->inText = FALSE;
-}
-
-static void PDF_Encodings(PDFDesc *pd)
-{
- encodinglist enclist = pd->encodings;
-
- while (enclist) {
- encodinginfo encoding = enclist->encoding;
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-
- fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Encoding ", pd->nobjs);
- if (strcmp(encoding->name, "WinAnsiEncoding") == 0 ||
- strcmp(encoding->name, "MacRomanEncoding") == 0 ||
- strcmp(encoding->name, "PDFDocEncoding") == 0) {
- fprintf(pd->pdffp, "/BaseEncoding /%s\n", encoding->name);
- fprintf(pd->pdffp, "/Differences [ 45/minus ]\n");
- } else if (strcmp(encoding->name, "ISOLatin1Encoding") == 0) {
- fprintf(pd->pdffp, "/BaseEncoding /WinAnsiEncoding\n");
- fprintf(pd->pdffp, "/Differences [ 45/minus 96/quoteleft\n144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n/dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space]\n");
- } else {
- int enc_first;
- int c = 0;
- int len;
- char buf[128];
- for(enc_first=0;encoding->enccode[enc_first]!='[' &&
- encoding->enccode[enc_first]!='\0' ;enc_first++);
- if (enc_first >= strlen(encoding->enccode))
- enc_first=0;
- fprintf(pd->pdffp, "/BaseEncoding /PDFDocEncoding\n");
- fprintf(pd->pdffp, "/Differences [\n");
- while(encoding->enccode[enc_first]) {
- switch (encoding->enccode[enc_first]) {
- case ' ':
- case '\t':
- case '\n':
- case '[':
- case ']':
- enc_first++;
- continue;
- }
- for(len=0;
- (encoding->enccode[enc_first+len]!=' ') &&
- (encoding->enccode[enc_first+len]!=']') &&
- (encoding->enccode[enc_first+len]!='\t') &&
- (encoding->enccode[enc_first+len]!='\0') &&
- (encoding->enccode[enc_first+len]!='\n') ;
- len++);
- memcpy(buf,encoding->enccode + enc_first , len);
- buf[len]='\0';
- fprintf(pd->pdffp, " %d%s", c, buf);
- if ( (c+1) % 8 == 0 ) fprintf(pd->pdffp, "\n");
- c++;
- enc_first+=len;
- }
- fprintf(pd->pdffp, "\n]\n");
- }
- fprintf(pd->pdffp, ">>\nendobj\n");
-
- enclist = enclist->next;
- }
-}
-
-/* Read sRGB profile from icc/srgb.flate
- * HexCode original from
- * http://code.google.com/p/ghostscript/source/browse/trunk/gs/iccprofiles/srgb.icc
- */
-#define BUFSIZE2 10000
-static void PDFwritesRGBcolorspace(PDFDesc *pd)
-{
- char buf[BUFSIZE2];
- FILE *fp;
-
- snprintf(buf, BUFSIZE2, "%s%slibrary%sgrDevices%sicc%s%s",
- R_Home, FILESEP, FILESEP, FILESEP, FILESEP,
- pd->useCompression ? "srgb.flate" : "srgb");
- if (!(fp = R_fopen(R_ExpandFileName(buf), "rb")))
- error(_("failed to load sRGB colorspace file"));
- size_t res = fread(buf, 1, BUFSIZE2, fp);
- res = fwrite(buf, 1, res, pd->pdffp);
- fclose(fp);
-}
-
-#include <time.h> // for time_t, time, localtime
-#include <Rversion.h>
-
-static void PDF_startfile(PDFDesc *pd)
-{
- struct tm *ltm;
- time_t ct;
-
- pd->nobjs = 0;
- pd->pageno = 0;
- /*
- * I destroy it when I open in Japanese environment carelessly
- */
- fprintf(pd->pdffp, "%%PDF-%i.%i\n%%\x81\xe2\x81\xe3\x81\xcf\x81\xd3\x5c\x72\n",
- pd->versionMajor, pd->versionMinor);
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-
- /* Object 1 is Info node. Date format is from the PDF manual */
-
- ct = time(NULL);
- ltm = localtime(&ct);
- fprintf(pd->pdffp,
- "1 0 obj\n<<\n/CreationDate (D:%04d%02d%02d%02d%02d%02d)\n",
- 1900 + ltm->tm_year, ltm->tm_mon+1, ltm->tm_mday,
- ltm->tm_hour, ltm->tm_min, ltm->tm_sec);
- fprintf(pd->pdffp,
- "/ModDate (D:%04d%02d%02d%02d%02d%02d)\n",
- 1900 + ltm->tm_year, ltm->tm_mon+1, ltm->tm_mday,
- ltm->tm_hour, ltm->tm_min, ltm->tm_sec);
- fprintf(pd->pdffp, "/Title (%s)\n", pd->title);
- fprintf(pd->pdffp, "/Producer (R %s.%s)\n/Creator (R)\n>>\nendobj\n",
- R_MAJOR, R_MINOR);
-
- /* Object 2 is the Catalog, pointing to pages list in object 3 (at end) */
-
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "2 0 obj\n<< /Type /Catalog /Pages 3 0 R >>\nendobj\n");
-
- /* Objects at the end */
- pd->nobjs += 2;
- if (streql(pd->colormodel, "srgb")) pd->nobjs += 2;
-}
-
-static const char *Base14[] =
-{
- "Courier", "Courier-Oblique", "Courier-Bold", "Courier-BoldOblique",
- "Helvetica", "Helvetica-Oblique", "Helvetica-Bold",
- "Helvetica-BoldOblique", "Symbol", "Times-Roman", "Times-Italic",
- "Times-Bold", "Times-BoldItalic", "ZapfDingbats"
-};
-
-static int isBase14(const char *name)
-{
- int i;
- for(i = 0; i < 14; i++)
- if(strcmp(name, Base14[i]) == 0) return 1;
- return 0;
-}
-
-static const char *KnownSanSerif[] =
-{
- "AvantGarde", "Helvetica-Narrow", "URWGothic", "NimbusSan"
-};
-
-
-static int isSans(const char *name)
-{
- int i;
- for(i = 0; i < 4; i++)
- if(strncmp(name, KnownSanSerif[i], strlen(KnownSanSerif[i])) == 0)
- return 1;
- return 0;
-}
-
-#define boldslant(x) ((x==3)?",BoldItalic":((x==2)?",Italic":((x==1)?",Bold":"")))
-
-#if defined(BUFSIZ) && (BUFSIZ > 512)
-/* OS's buffer size in stdio.h, probably.
- Windows has 512, Solaris 1024, glibc 8192
- */
-# define APPENDBUFSIZE BUFSIZ
-#else
-# define APPENDBUFSIZE 512
-#endif
-
-static void PDF_endfile(PDFDesc *pd)
-{
- int i, startxref, tempnobj, nenc, nfonts, cidnfonts, firstencobj;
- int nraster, nmask;
-
- /* object 3 lists all the pages */
-
- pd->pos[3] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "3 0 obj\n<< /Type /Pages /Kids [ ");
- for(i = 0; i < pd->pageno; i++)
- fprintf(pd->pdffp, "%d 0 R ", pd->pageobj[i]);
-
- fprintf(pd->pdffp,
- "] /Count %d /MediaBox [0 0 %d %d] >>\nendobj\n",
- pd->pageno,
- (int) (0.5 + pd->paperwidth), (int) (0.5 + pd->paperheight));
-
- /* Object 4 is the standard resources dict for each page */
-
- /* Count how many images and masks */
- nraster = pd->numRasters;
- nmask = pd->numMasks;
-
- if(pd->nobjs + nraster + nmask + 500 >= pd->max_nobjs) {
- int new = pd->nobjs + nraster + nmask + 500;
- void *tmp = realloc(pd->pos, new * sizeof(int));
- if(!tmp)
- error("unable to increase object limit: please shutdown the pdf device");
- pd->pos = (int *) tmp;
- pd->max_nobjs = new;
- }
-
- pd->pos[4] = (int) ftell(pd->pdffp);
-
- /* The resource dictionary for each page */
- /* ProcSet is regarded as obsolete as from PDF 1.4 */
- if (nraster > 0) {
- if (nmask > 0) {
- fprintf(pd->pdffp,
- "4 0 obj\n<<\n/ProcSet [/PDF /Text /ImageC /ImageB]\n/Font <<");
-
- } else {
- fprintf(pd->pdffp,
- "4 0 obj\n<<\n/ProcSet [/PDF /Text /ImageC]\n/Font <<");
- }
- } else {
- /* fonts */
- fprintf(pd->pdffp,
- "4 0 obj\n<<\n/ProcSet [/PDF /Text]\n/Font <<");
- }
-
- /* Count how many encodings will be included:
- * fonts come after encodings */
- nenc = 0;
- if (pd->encodings) {
- encodinglist enclist = pd->encodings;
- while (enclist) {
- nenc++;
- enclist = enclist->next;
- }
- }
- /* Should be a default text font at least, plus possibly others */
- tempnobj = pd->nobjs + nenc;
-
- /* Dingbats always F1 */
- if(pd->fontUsed[1]) fprintf(pd->pdffp, " /F1 %d 0 R ", ++tempnobj);
-
- nfonts = 2;
- if (pd->fonts) {
- type1fontlist fontlist = pd->fonts;
- while (fontlist) {
- for (i = 0; i < 5; i++) {
- if(nfonts >= 100 || pd->fontUsed[nfonts]) {
- fprintf(pd->pdffp, "/F%d %d 0 R ", nfonts, ++tempnobj);
- /* Allow for the font descriptor object, if present */
- if(!isBase14(fontlist->family->fonts[i]->name)) tempnobj++;
- }
- nfonts++;
- }
- fontlist = fontlist->next;
- }
- }
- cidnfonts = 0;
- if (pd->cidfonts) {
- cidfontlist fontlist = pd->cidfonts;
- while (fontlist) {
- for (i = 0; i < 5; i++) {
- fprintf(pd->pdffp, "/F%d %d 0 R ",
- 1000 + cidnfonts + 1, ++tempnobj);
- cidnfonts++;
- }
- fontlist = fontlist->next;
- }
- }
- fprintf(pd->pdffp, ">>\n");
-
- if (nraster > 0) {
- /* image XObjects */
- fprintf(pd->pdffp, "/XObject <<\n");
- for (i = 0; i < nraster; i++) {
- fprintf(pd->pdffp, " /Im%d %d 0 R\n", i, pd->rasters[i].nobj);
- if (pd->masks[i] >= 0)
- fprintf(pd->pdffp, " /Mask%d %d 0 R\n",
- pd->masks[i], pd->rasters[i].nmaskobj);
- }
- fprintf(pd->pdffp, ">>\n");
- }
-
- /* graphics state parameter dictionaries */
- fprintf(pd->pdffp, "/ExtGState << ");
- for (i = 0; i < 256 && pd->colAlpha[i] >= 0; i++)
- fprintf(pd->pdffp, "/GS%i %d 0 R ", i + 1, ++tempnobj);
- for (i = 0; i < 256 && pd->fillAlpha[i] >= 0; i++)
- fprintf(pd->pdffp, "/GS%i %d 0 R ", i + 257, ++tempnobj);
- /* Special state to set AIS if we have soft masks */
- if (nmask > 0)
- fprintf(pd->pdffp, "/GSais %d 0 R ", ++tempnobj);
- fprintf(pd->pdffp, ">>\n");
-
- if (streql(pd->colormodel, "srgb")) {
- /* Objects 5 and 6 are the sRGB color space, if required */
- fprintf(pd->pdffp, "/ColorSpace << /sRGB 5 0 R >>\n");
- fprintf(pd->pdffp, ">>\nendobj\n");
- pd->pos[5] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "5 0 obj\n[/ICCBased 6 0 R]\nendobj\n");
- pd->pos[6] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "6 0 obj\n");
- PDFwritesRGBcolorspace(pd);
- fprintf(pd->pdffp, "endobj\n");
- } else {
- fprintf(pd->pdffp, ">>\nendobj\n");
- }
-
- if(tempnobj >= pd->max_nobjs) {
- int new = tempnobj + 500;
- void *tmp = realloc(pd->pos, new * sizeof(int));
- if(!tmp)
- error("unable to increase object limit: please shutdown the pdf device");
- pd->pos = (int *) tmp;
- pd->max_nobjs = new;
- }
-
- /*
- * Write out objects representing the encodings
- */
-
- firstencobj = pd->nobjs;
- PDF_Encodings(pd);
-
- /*
- * Write out objects representing the fonts
- */
-
- if (pd->fontUsed[1]) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "%d 0 obj\n<< /Type /Font /Subtype /Type1 /Name /F1 /BaseFont /ZapfDingbats >>\nendobj\n", pd->nobjs);
- }
-
-
- nfonts = 2;
- if (pd->fonts) {
- type1fontlist fontlist = pd->fonts;
- while (fontlist) {
- FontMetricInfo *metrics;
- /*
- * Find the index of the device encoding
- * This really should be there
- */
- int encIndex;
- encodinginfo encoding =
- findDeviceEncoding(fontlist->family->encoding->encpath,
- pd->encodings, &encIndex);
- if (!encoding)
- error(_("corrupt encodings in PDF device"));
- for (i = 0; i < 5; i++) {
- if (nfonts >= 100 || pd->fontUsed[nfonts]) {
- type1fontinfo fn = fontlist->family->fonts[i];
- int base = isBase14(fn->name);
- metrics = &fn->metrics;
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "%d 0 obj\n<< /Type /Font /Subtype /Type1 /Name /F%d /BaseFont /%s\n",
- pd->nobjs,
- nfonts,
- fn->name);
- if (!base) {
- int ii, first, last, tmp;
- for(first = 1, ii = 0; ii < 255; ii++)
- if(metrics->CharInfo[ii].WX != NA_SHORT) {
- first = ii;
- break;
- }
- for(last = 255, ii = 254; ii >= 0; ii--)
- if(metrics->CharInfo[ii].WX != NA_SHORT) {
- last = ii + 1;
- break;
- }
- fprintf(pd->pdffp,
- "/FirstChar %d /LastChar %d /Widths [\n",
- first, last);
- for (ii = first; ii <= last; ii++) {
- tmp = metrics->CharInfo[ii].WX;
- fprintf(pd->pdffp, " %d", tmp==NA_SHORT ? 0 : tmp);
- if ((ii + 1) % 15 == 0) fprintf(pd->pdffp, "\n");
- }
- fprintf(pd->pdffp, "]\n");
- fprintf(pd->pdffp, "/FontDescriptor %d 0 R\n",
- pd->nobjs + 1);
- }
- if(i < 4)
- fprintf(pd->pdffp, "/Encoding %d 0 R ",
- /* Encodings come after dingbats font which is
- * object 5 */
- encIndex + firstencobj);
- fprintf(pd->pdffp, ">>\nendobj\n");
- if(!base) {
- /* write font descriptor */
- int flags = 32 /*bit 6, non-symbolic*/ +
- ((i==2 || i==3) ? 64/* italic */: 0) +
- (metrics->IsFixedPitch > 0 ? 1 : 0) +
- (isSans(fn->name) ? 0 : 2);
- /* <FIXME> we have no real way to know
- if this is serif or not */
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp,
- "%d 0 obj <<\n"
- " /Type /FontDescriptor\n"
- " /FontName /%s\n"
- " /Flags %d\n"
- " /FontBBox [%d %d %d %d]\n"
- " /CapHeight %d\n /Ascent %d\n /Descent %d\n"
- " /ItalicAngle %d\n /XHeight %d\n /StemV %d\n"
- ">>\nendobj\n",
- pd->nobjs,
- fn->name,
- (i == 4) ? 4 : flags,
- metrics->FontBBox[0], metrics->FontBBox[1],
- metrics->FontBBox[2], metrics->FontBBox[3],
- metrics->CapHeight, metrics->Ascender,
- metrics->Descender,
- metrics->ItalicAngle, metrics->XHeight,
- (metrics->StemV != NA_SHORT) ? metrics->StemV :
- (i==2 || i==3) ? 140 : 83);
- }
- }
- nfonts++;
- }
- fontlist = fontlist->next;
- }
- }
- cidnfonts = 0;
- if (pd->cidfonts) {
- cidfontlist fontlist = pd->cidfonts;
- if(pd->versionMajor == 1 && pd->versionMinor < 3) {
- pd->versionMinor = 3;
- warning(_("increasing the PDF version to 1.3"));
- }
- while (fontlist) {
- for (i = 0; i < 4; i++) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp,
- /** format **/
- "%d 0 obj\n"
- "<<\n"
- " /Type /Font\n"
- " /Subtype /Type0\n"
- " /Name /F%d\n"
- " /BaseFont /%s%s\n"
- " /DescendantFonts [\n"
- " <<\n"
- " /Type /Font\n"
- " /Subtype /CIDFontType0\n"
- " /BaseFont /%s%s\n"
- " %s"
- " >>\n"
- " ]\n"
- " /Encoding /%s\n"
- ">>\n"
- "endobj\n",
- /** vararg **/
- pd->nobjs, /* pdf objnum */
- 1000 + cidnfonts + 1, /* - face */
- fontlist->cidfamily->cidfonts[i]->name,/* /BaseFont*/
- boldslant(i), /* - boldslant */
- fontlist->cidfamily->cidfonts[i]->name,/* /BaseFont*/
- boldslant(i), /* - boldslant */
- /* Resource */
- /*
- * Pull the resource out of R object
- * Hopefully one day this will be unnecessary
- */
- getCIDFontPDFResource(fontlist->cidfamily->fxname),
- fontlist->cidfamily->cmap /* /Encoding */
- );
- cidnfonts++;
- }
- /* Symbol face does not use encoding */
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F%d\n/BaseFont /%s\n>>\nendobj\n",
- pd->nobjs,
- 1000 + cidnfonts + 1,
- fontlist->cidfamily->symfont->name);
- cidnfonts++;
- fontlist = fontlist->next;
- }
- }
-
- /*
- * Write out objects representing the graphics state parameter
- * dictionaries for alpha transparency
- */
- for (i = 0; i < 256 && pd->colAlpha[i] >= 0; i++) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp,
- "%d 0 obj\n<<\n/Type /ExtGState\n/CA %1.3f >>\nendobj\n",
- pd->nobjs, pd->colAlpha[i]/255.0);
- }
- for (i = 0; i < 256 && pd->fillAlpha[i] >= 0; i++) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp,
- "%d 0 obj\n<<\n/Type /ExtGState\n/ca %1.3f\n>>\nendobj\n",
- pd->nobjs, pd->fillAlpha[i]/255.0);
- }
-
- if (nmask > 0) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp,
- "%d 0 obj\n<<\n/Type /ExtGState\n/AIS false\n>>\nendobj\n",
- pd->nobjs);
- }
-
- /* write out xref table */
-
- startxref = (int) ftell(pd->pdffp);
- /* items here must be exactly 20 bytes including terminator */
- fprintf(pd->pdffp, "xref\n0 %d\n", pd->nobjs+1);
- fprintf(pd->pdffp, "0000000000 65535 f \n");
- for(i = 1; i <= pd->nobjs; i++)
- fprintf(pd->pdffp, "%010d 00000 n \n", pd->pos[i]);
- fprintf(pd->pdffp,
- "trailer\n<< /Size %d /Info 1 0 R /Root 2 0 R >>\nstartxref\n%d\n",
- pd->nobjs+1, startxref);
- fprintf(pd->pdffp, "%%%%EOF\n");
-
- /* now seek back and update the header */
- rewind(pd->pdffp);
- fprintf(pd->pdffp, "%%PDF-%i.%i\n", pd->versionMajor, pd->versionMinor);
- fclose(pd->pdffp);
- if (pd->open_type == 1) {
- char buf[APPENDBUFSIZE];
- size_t nc;
- pd->pdffp = R_fopen(pd->filename, "rb");
- while((nc = fread(buf, 1, APPENDBUFSIZE, pd->pdffp))) {
- if(nc != fwrite(buf, 1, nc, pd->pipefp))
- error("write error");
- if (nc < APPENDBUFSIZE) break;
- }
- fclose(pd->pdffp);
- pclose(pd->pipefp);
- unlink(pd->filename);
- }
-}
-
-
-static Rboolean PDF_Open(pDevDesc dd, PDFDesc *pd)
-{
- char buf[512];
-
- if (pd->offline)
- return TRUE;
-
- if (pd->filename[0] == '|') {
- strncpy(pd->cmd, pd->filename + 1, PATH_MAX);
- char *tmp = R_tmpnam("Rpdf", R_TempDir);
- strncpy(pd->filename, tmp, PATH_MAX);
- free(tmp);
- errno = 0;
- pd->pipefp = R_popen(pd->cmd, "w");
- if (!pd->pipefp || errno != 0) {
- PDFcleanup(6, pd);
- error(_("cannot open 'pdf' pipe to '%s'"), pd->cmd);
- return FALSE;
- }
- pd->open_type = 1;
- if (!pd->onefile) {
- pd->onefile = TRUE;
- warning(_("file = \"|cmd\" implies 'onefile = TRUE'"));
- }
- } else pd->open_type = 0;
- snprintf(buf, 512, pd->filename, pd->fileno + 1); /* file 1 to start */
- /* NB: this must be binary to get tell positions and line endings right,
- as well as allowing binary streams */
- pd->mainfp = R_fopen(R_ExpandFileName(buf), "wb");
- if (!pd->mainfp) {
- PDFcleanup(6, pd);
- free(dd);
- error(_("cannot open file '%s'"), buf);
- }
- pd->pdffp = pd->mainfp;
-
- PDF_startfile(pd);
- return TRUE;
-}
-
-static void pdfClip(double x0, double x1, double y0, double y1, PDFDesc *pd)
-{
- if(x0 != 0.0 || y0 != 0.0 || x1 != 72*pd->width || y1 != 72*pd->height)
- fprintf(pd->pdffp, "Q q %.2f %.2f %.2f %.2f re W n\n",
- x0, y0, x1 - x0, y1 - y0);
- else fprintf(pd->pdffp, "Q q\n");
-}
-
-static void PDF_Clip(double x0, double x1, double y0, double y1, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- PDF_checkOffline();
-
- if(pd->inText) textoff(pd);
- pdfClip(x0, x1, y0, y1, pd);
- PDF_Invalidate(dd);
-}
-
-static void PDF_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- *left = dd->left;
- *right = dd->right;
- *bottom = dd->bottom;
- *top = dd->top;
-}
-
-static void PDF_endpage(PDFDesc *pd)
-{
- if(pd->inText) textoff(pd);
- fprintf(pd->pdffp, "Q\n");
- if (pd->useCompression) {
- fflush(pd->pdffp);
- fseek(pd->pdffp, 0, SEEK_END);
- unsigned int len = (unsigned int) ftell(pd->pdffp);
- fseek(pd->pdffp, 0, SEEK_SET);
- Bytef *buf = Calloc(len, Bytef);
- uLong outlen = (uLong)(1.001*len + 20);
- Bytef *buf2 = Calloc(outlen, Bytef);
- size_t res = fread(buf, 1, len, pd->pdffp);
- if (res < len) error("internal read error in PDF_endpage");
- fclose(pd->pdffp);
- unlink(pd->tmpname);
- pd->pdffp = pd->mainfp;
- int res2 = compress(buf2, &outlen, buf, len);
- if(res2 != Z_OK)
- error("internal compression error %d in PDF_endpage", res2);
- fprintf(pd->pdffp, "%d 0 obj\n<<\n/Length %d /Filter /FlateDecode\n>>\nstream\n",
- pd->nobjs, (int) outlen);
- size_t nwrite = fwrite(buf2, 1, outlen, pd->pdffp);
- if(nwrite != outlen) error(_("write failed"));
- Free(buf); Free(buf2);
- fprintf(pd->pdffp, "endstream\nendobj\n");
- } else {
- int here = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "endstream\nendobj\n");
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- fprintf(pd->pdffp, "%d 0 obj\n%d\nendobj\n", pd->nobjs,
- here - pd->startstream);
- }
-
- if(pd->nobjs + 2*(pd->numRasters-pd->writtenRasters) + 500
- >= pd->max_nobjs) {
- int new = pd->nobjs + 2*(pd->numRasters-pd->writtenRasters) + 2000;
- void *tmp = realloc(pd->pos, new * sizeof(int));
- if(!tmp)
- error("unable to increase object limit: please shutdown the pdf device");
- pd->pos = (int *) tmp;
- pd->max_nobjs = new;
- }
-
- /* Write out any new rasters */
- for (int i = pd->writtenRasters; i < pd->numRasters; i++) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- pd->rasters[i].nobj = pd->nobjs;
- writeRasterXObject(pd->rasters[i], pd->nobjs,
- pd->masks[i], pd->nobjs+1, pd);
- if (pd->masks[i] >= 0) {
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- pd->rasters[i].nmaskobj = pd->nobjs;
- writeMaskXObject(pd->rasters[i], pd->nobjs, pd);
- }
- free(pd->rasters[i].raster);
- pd->rasters[i].raster = NULL;
- pd->writtenRasters = pd->numRasters;
- }
-}
-
-#define R_VIS(col) (R_ALPHA(col) > 0)
-
-static void PDF_NewPage(const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- char buf[512];
-
- PDF_checkOffline();
-
- if(pd->pageno >= pd->pagemax) {
- void * tmp = realloc(pd->pageobj, 2*pd->pagemax * sizeof(int));
- if(!tmp)
- error("unable to increase page limit: please shutdown the pdf device");
- pd->pageobj = (int *) tmp;
- pd->pagemax *= 2;
- }
- if(pd->nobjs + 500 >= pd->max_nobjs) {
- int new = pd->max_nobjs + 2000;
- void *tmp = realloc(pd->pos, new * sizeof(int));
- if(!tmp)
- error("unable to increase object limit: please shutdown the pdf device");
- pd->pos = (int *) tmp;
- pd->max_nobjs = new;
- }
-
-
- if(pd->pageno > 0) {
- PDF_endpage(pd);
- if(!pd->onefile) {
- PDF_endfile(pd);
- pd->fileno++;
- snprintf(buf, 512, pd->filename, pd->fileno + 1); /* file 1 to start */
- pd->mainfp = R_fopen(R_ExpandFileName(buf), "wb");
- if (!pd->mainfp)
- error(_("cannot open 'pdf' file argument '%s'\n please shut down the PDF device"), buf);
- pd->pdffp = pd->mainfp;
- PDF_startfile(pd);
- }
- }
-
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- pd->pageobj[pd->pageno++] = pd->nobjs;
- fprintf(pd->pdffp, "%d 0 obj\n<< /Type /Page /Parent 3 0 R /Contents %d 0 R /Resources 4 0 R >>\nendobj\n",
- pd->nobjs, pd->nobjs+1);
- pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
- if (pd->useCompression) {
- char *tmp = R_tmpnam("pdf", R_TempDir);
- /* assume tmpname is less than PATH_MAX */
- strcpy(pd->tmpname, tmp);
- pd->pdffp = fopen(tmp, "w+b");
- free(tmp);
- if(! pd->pdffp) error("cannot open file '%s', reason %s",
- tmp, strerror(errno));
- } else {
- fprintf(pd->pdffp, "%d 0 obj\n<<\n/Length %d 0 R\n>>\nstream\n",
- pd->nobjs, pd->nobjs + 1);
- pd->startstream = (int) ftell(pd->pdffp);
- }
-
- /*
- * Line end/join/mitre now controlled by user
- * Same old defaults
- * .. but they are still needed because SetXXX produces the corresponding
- * command only if the value changes - so we have to define base defaults
- * according to the values reset by Invalidate. I'm pretty sure about j/J
- * but not so about M because Invalidate uses 0 yet the default used to be
- * 10.
- *
- * fprintf(pd->pdffp, "1 J 1 j 10 M q\n");
- */
- fprintf(pd->pdffp, "1 J 1 j q\n");
- PDF_Invalidate(dd);
- if(R_VIS(gc->fill)) {
- PDF_SetFill(gc->fill, dd);
- fprintf(pd->pdffp, "0 0 %.2f %.2f re f\n",
- 72.0 * pd->width, 72.0 * pd->height);
- }
- pd->inText = FALSE;
-}
-
-static void PDF_Close(pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- if (!pd->offline) {
- if(pd->pageno > 0) PDF_endpage(pd);
- PDF_endfile(pd);
- /* may no longer be needed */
- killRasterArray(pd->rasters, pd->maxRasters);
- }
- PDFcleanup(6, pd); /* which frees masks and rasters */
-}
-
-static void PDF_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int code;
-
- PDF_checkOffline();
-
- code = 2 * (R_VIS(gc->fill)) + (R_VIS(gc->col));
- if (code) {
- if(pd->inText) textoff(pd);
- if(code & 2)
- PDF_SetFill(gc->fill, dd);
- if(code & 1) {
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- }
- fprintf(pd->pdffp, "%.2f %.2f %.2f %.2f re", x0, y0, x1-x0, y1-y0);
- switch(code) {
- case 1: fprintf(pd->pdffp, " S\n"); break;
- case 2: fprintf(pd->pdffp, " f\n"); break;
- case 3: fprintf(pd->pdffp, " B\n"); break;
- }
- }
-}
-
-#ifdef SIMPLE_RASTER
-/* Maybe reincoporate this simpler approach as an alternative
- * (for opaque raster images) because it has the advantage of
- * NOT keeping the raster in memory until the PDF file is complete
- */
-static void PDF_Raster(unsigned int *raster,
- int w, int h,
- double x, double y,
- double width, double height,
- double rot, Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- double angle, cosa, sina;
-
- PDF_checkOffline();
-
- /* This takes the simple approach of creating an inline
- * image. This is not recommended for larger images
- * because it makes more work for the PDF viewer.
- * It also does not allow for semitransparent images.
- */
- if(pd->inText) textoff(pd);
- /* Save graphics state */
- fprintf(pd->pdffp, "q\n");
- /* translate */
- fprintf(pd->pdffp,
- "1 0 0 1 %.2f %.2f cm\n",
- x, y);
- /* rotate */
- angle = rot*M_PI/180;
- cosa = cos(angle);
- sina = sin(angle);
- fprintf(pd->pdffp,
- "%.2f %.2f %.2f %.2f 0 0 cm\n",
- cosa, sina, -sina, cosa);
- /* scale */
- fprintf(pd->pdffp,
- "%.2f 0 0 %.2f 0 0 cm\n",
- width, height);
- /* Begin image */
- fprintf(pd->pdffp, "BI\n");
- /* Image characteristics */
- /* Use ASCIIHexDecode filter for now, just because
- * it's easier to implement */
- fprintf(pd->pdffp,
- " /W %d\n /H %d\n /CS /RGB\n /BPC 8\n /F [/AHx]\n",
- w, h);
- if (interpolate) {
- fprintf(pd->pdffp, " /I true\n");
- }
- /* Begin image data */
- fprintf(pd->pdffp, "ID\n");
- /* The image stream */
- PDF_imagedata(raster, w, h, pd);
- /* End image */
- fprintf(pd->pdffp, "EI\n");
- /* Restore graphics state */
- fprintf(pd->pdffp, "Q\n");
-}
-#else
-
-static void PDF_Raster(unsigned int *raster,
- int w, int h,
- double x, double y,
- double width, double height,
- double rot, Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- double angle, cosa, sina;
- int alpha;
-
- PDF_checkOffline();
-
- /* Record the raster so can write it out when page is finished */
- alpha = addRaster(raster, w, h, interpolate, pd);
-
- if(pd->inText) textoff(pd);
- /* Save graphics state */
- fprintf(pd->pdffp, "q\n");
- /* Need to set AIS graphics state parameter ? */
- if (alpha) fprintf(pd->pdffp, "/GSais gs\n");
- /* translate */
- fprintf(pd->pdffp,
- "1 0 0 1 %.2f %.2f cm\n",
- x, y);
- /* rotate */
- angle = rot*M_PI/180;
- cosa = cos(angle);
- sina = sin(angle);
- fprintf(pd->pdffp,
- "%.2f %.2f %.2f %.2f 0 0 cm\n",
- cosa, sina, -sina, cosa);
- /* scale */
- fprintf(pd->pdffp,
- "%.2f 0 0 %.2f 0 0 cm\n",
- width, height);
- /* Refer to XObject which will be written to file when page is finished */
- fprintf(pd->pdffp, "/Im%d Do\n", pd->numRasters - 1);
- /* Restore graphics state */
- fprintf(pd->pdffp, "Q\n");
-}
-
-#endif
-
-/* r is in device coords */
-static void PDF_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int code, tr;
- double xx, yy, a;
-
- PDF_checkOffline();
-
- if (r <= 0.0) return; /* since PR#14797 use 0-sized pch=1, but now
- GECircle omits such circles */
-
- code = 2 * (R_VIS(gc->fill)) + (R_VIS(gc->col));
- if (code) {
- if(code & 2)
- PDF_SetFill(gc->fill, dd);
- if(code & 1) {
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- }
- }
- if (code) {
- if (semiTransparent(gc->col) || semiTransparent(gc->fill)
- || r > 10 || !pd->dingbats) {
- /*
- * Due to possible bug in Acrobat Reader for rendering
- * semi-transparent text, only ever draw Bezier curves
- * regardless of circle size. Otherwise use font up to 20pt
- */
- {
- /* Use four Bezier curves, hand-fitted to quadrants */
- double s = 0.55 * r;
- if(pd->inText) textoff(pd);
- fprintf(pd->pdffp, " %.2f %.2f m\n", x - r, y);
- fprintf(pd->pdffp, " %.2f %.2f %.2f %.2f %.2f %.2f c\n",
- x - r, y + s, x - s, y + r, x, y + r);
- fprintf(pd->pdffp, " %.2f %.2f %.2f %.2f %.2f %.2f c\n",
- x + s, y + r, x + r, y + s, x + r, y);
- fprintf(pd->pdffp, " %.2f %.2f %.2f %.2f %.2f %.2f c\n",
- x + r, y - s, x + s, y - r, x, y - r);
- fprintf(pd->pdffp, " %.2f %.2f %.2f %.2f %.2f %.2f c\n",
- x - s, y - r, x - r, y - s, x - r, y);
- switch(code) {
- case 1: fprintf(pd->pdffp, "S\n"); break;
- case 2: fprintf(pd->pdffp, "f\n"); break;
- case 3: fprintf(pd->pdffp, "B\n"); break;
- }
- }
- } else {
- pd->fontUsed[1] = TRUE;
- /* Use char 108 in Dingbats, which is a solid disc
- afm is C 108 ; WX 791 ; N a71 ; B 35 -14 757 708 ;
- so diameter = 0.722 * size
- centre = (0.396, 0.347) * size
- */
- a = 2./0.722 * r;
- if (a < 0.01) return; // avoid 0 dims below.
- xx = x - 0.396*a;
- yy = y - 0.347*a;
- tr = (R_OPAQUE(gc->fill)) +
- 2 * (R_OPAQUE(gc->col)) - 1;
- if(!pd->inText) texton(pd);
- fprintf(pd->pdffp,
- "/F1 1 Tf %d Tr %.2f 0 0 %.2f %.2f %.2f Tm",
- tr, a, a, xx, yy);
- fprintf(pd->pdffp, " (l) Tj 0 Tr\n");
- textoff(pd); /* added in 2.8.0 */
- }
- }
-}
-
-static void PDF_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- PDF_checkOffline();
-
- if(!R_VIS(gc->col)) return;
-
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- if(pd->inText) textoff(pd);
- fprintf(pd->pdffp, "%.2f %.2f m %.2f %.2f l S\n", x1, y1, x2, y2);
-}
-
-static void PDF_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- double xx, yy;
- int i, code;
-
- PDF_checkOffline();
-
- code = 2 * (R_VIS(gc->fill)) + (R_VIS(gc->col));
- if (code) {
- if(pd->inText) textoff(pd);
- if(code & 2)
- PDF_SetFill(gc->fill, dd);
- if(code & 1) {
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- }
- xx = x[0];
- yy = y[0];
- fprintf(pd->pdffp, "%.2f %.2f m\n", xx, yy);
- for(i = 1 ; i < n ; i++) {
- xx = x[i];
- yy = y[i];
- fprintf(pd->pdffp, "%.2f %.2f l\n", xx, yy);
- }
- if (pd->fillOddEven) {
- switch(code) {
- case 1: fprintf(pd->pdffp, "s\n"); break;
- case 2: fprintf(pd->pdffp, "h f*\n"); break;
- case 3: fprintf(pd->pdffp, "b*\n"); break;
- }
- } else {
- switch(code) {
- case 1: fprintf(pd->pdffp, "s\n"); break;
- case 2: fprintf(pd->pdffp, "h f\n"); break;
- case 3: fprintf(pd->pdffp, "b\n"); break;
- }
- }
- }
-}
-
-static void PDF_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- double xx, yy;
- int i, j, index, code;
-
- PDF_checkOffline();
-
- code = 2 * (R_VIS(gc->fill)) + (R_VIS(gc->col));
- if (code) {
- if(pd->inText) textoff(pd);
- if(code & 2)
- PDF_SetFill(gc->fill, dd);
- if(code & 1) {
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- }
- index = 0;
- for (i=0; i < npoly; i++) {
- xx = x[index];
- yy = y[index];
- index++;
- fprintf(pd->pdffp, "%.2f %.2f m\n", xx, yy);
- for(j=1; j < nper[i]; j++) {
- xx = x[index];
- yy = y[index];
- index++;
- fprintf(pd->pdffp, "%.2f %.2f l\n", xx, yy);
- }
- if (i < npoly - 1)
- fprintf(pd->pdffp, "h\n");
- }
- if (winding) {
- switch(code) {
- case 1: fprintf(pd->pdffp, "s\n"); break;
- case 2: fprintf(pd->pdffp, "h f\n"); break;
- case 3: fprintf(pd->pdffp, "b\n"); break;
- }
- } else {
- switch(code) {
- case 1: fprintf(pd->pdffp, "s\n"); break;
- case 2: fprintf(pd->pdffp, "h f*\n"); break;
- case 3: fprintf(pd->pdffp, "b*\n"); break;
- }
- }
- }
-}
-
-static void PDF_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc*) dd->deviceSpecific;
- double xx, yy;
- int i;
-
- PDF_checkOffline();
-
- if(pd->inText) textoff(pd);
- if(R_VIS(gc->col)) {
- PDF_SetLineColor(gc->col, dd);
- PDF_SetLineStyle(gc, dd);
- xx = x[0];
- yy = y[0];
- fprintf(pd->pdffp, "%.2f %.2f m\n", xx, yy);
- for(i = 1 ; i < n ; i++) {
- xx = x[i];
- yy = y[i];
- fprintf(pd->pdffp, "%.2f %.2f l\n", xx, yy);
- }
- fprintf(pd->pdffp, "S\n");
- }
-}
-
-static int PDFfontNumber(const char *family, int face, PDFDesc *pd)
-{
- /* DingBats is font 1 */
- int num = 1;
-
- if (strlen(family) > 0) {
- int fontIndex, cidfontIndex;
- /*
- * Try to find font in already loaded fonts
- */
- type1fontfamily fontfamily = findDeviceFont(family, pd->fonts,
- &fontIndex);
- cidfontfamily cidfontfamily = findDeviceCIDFont(family, pd->cidfonts,
- &cidfontIndex);
- if (fontfamily)
- num = (fontIndex - 1)*5 + 1 + face;
- else if (cidfontfamily)
- /*
- * Use very high font number for CID fonts to avoid
- * Type 1 fonts
- */
- num = 1000 + (cidfontIndex - 1)*5 + face;
- else {
- /*
- * Check whether the font is loaded and, if not,
- * load it.
- */
- fontfamily = findLoadedFont(family,
- pd->encodings->encoding->encpath,
- TRUE);
- cidfontfamily = findLoadedCIDFont(family, TRUE);
- if (!(fontfamily || cidfontfamily)) {
- if (isType1Font(family, PDFFonts, NULL)) {
- fontfamily = addFont(family, TRUE, pd->encodings);
- } else if (isCIDFont(family, PDFFonts, NULL)) {
- cidfontfamily = addCIDFont(family, TRUE);
- } else {
- /*
- * Should NOT get here.
- */
- error(_("invalid font type"));
- }
- }
- /*
- * Once the font is loaded, add it to the device's
- * list of fonts.
- */
- if (fontfamily || cidfontfamily) {
- if (isType1Font(family, PDFFonts, NULL)) {
- if (addPDFDevicefont(fontfamily, pd, &fontIndex)) {
- num = (fontIndex - 1)*5 + 1 + face;
- } else {
- fontfamily = NULL;
- }
- } else /* (isCIDFont(family, PDFFonts)) */ {
- if (addPDFDeviceCIDfont(cidfontfamily, pd,
- &cidfontIndex)) {
- num = 1000 + (cidfontIndex - 1)*5 + face;
- } else {
- cidfontfamily = NULL;
- }
- }
- }
- }
- if (!(fontfamily || cidfontfamily))
- error(_("failed to find or load PDF font"));
- } else {
- if (isType1Font(family, PDFFonts, pd->defaultFont))
- num = 1 + face;
- else
- num = 1000 + face;
- }
- if(num < 100) pd->fontUsed[num] = TRUE;
- return num;
-}
-
-/* added for 2.9.0 (donated by Ei-ji Nakama) : */
-static void PDFWriteT1KerningString(FILE *fp, const char *str,
- FontMetricInfo *metrics,
- const pGEcontext gc)
-{
- unsigned char p1, p2;
- size_t i, n;
- int j, ary_buf[128], *ary;
- Rboolean haveKerning = FALSE;
-
- n = strlen(str);
- if (n < 1) return;
- if(n > sizeof(ary_buf)/sizeof(int))
- ary = Calloc(n, int);
- else ary = ary_buf;
-
- for(i = 0; i < n-1; i++) {
- ary[i] = 0.;
- p1 = str[i];
- p2 = str[i+1];
-#ifdef USE_HYPHEN
- if (p1 == '-' && !isdigit((int)p2))
- p1 = (unsigned char)PS_hyphen;
-#endif
- for (j = metrics->KPstart[p1]; j < metrics->KPend[p1]; j++)
- if(metrics->KernPairs[j].c2 == p2 &&
- metrics->KernPairs[j].c1 == p1) {
- ary[i] += metrics->KernPairs[j].kern;
- haveKerning = TRUE;
- break;
- }
- }
- ary[i] = 0;
- if(haveKerning) {
- fputc('[', fp); fputc('(', fp);
- for(i = 0; str[i]; i++) {
- switch(str[i]) {
- case '\n':
- fprintf(fp, "\\n");
- break;
- case '\\':
- fprintf(fp, "\\\\");
- break;
- case '-':
-#ifdef USE_HYPHEN
- if (!isdigit((int)str[i+1]))
- fputc(PS_hyphen, fp);
- else
-#endif
- fputc(str[i], fp);
- break;
- case '(':
- case ')':
- fprintf(fp, "\\%c", str[i]);
- break;
- default:
- fputc(str[i], fp);
- break;
- }
- if( ary[i] != 0 && str[i+1] ) fprintf(fp, ") %d (", -ary[i]);
- }
- fprintf(fp, ")] TJ\n");
- } else {
- PostScriptWriteString(fp, str, strlen(str));
- fprintf(fp, " Tj\n");
- }
-
- if(ary != ary_buf) Free(ary);
-}
-
-static FontMetricInfo *PDFmetricInfo(const char *, int, PDFDesc *);
-static void PDFSimpleText(double x, double y, const char *str,
- double rot, double hadj,
- int font,
- const pGEcontext gc,
- pDevDesc dd) {
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int size = (int)floor(gc->cex * gc->ps + 0.5);
- int face = gc->fontface;
- double a, b, bm, rot1;
-
- if(!R_VIS(gc->col) || size <= 0) return;
-
- if(face < 1 || face > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), face);
- face = 1;
- }
- rot1 = rot * DEG2RAD;
- a = size * cos(rot1);
- b = size * sin(rot1);
- bm = -b;
- /* avoid printing -0.00 on rotated text */
- if(fabs(a) < 0.01) a = 0.0;
- if(fabs(b) < 0.01) {b = 0.0; bm = 0.0;}
- if(!pd->inText) texton(pd);
- PDF_SetFill(gc->col, dd);
- fprintf(pd->pdffp, "/F%d 1 Tf %.2f %.2f %.2f %.2f %.2f %.2f Tm ",
- font,
- a, b, bm, a, x, y);
- if (pd->useKern &&
- isType1Font(gc->fontfamily, PDFFonts, pd->defaultFont)) {
- PDFWriteT1KerningString(pd->pdffp, str,
- PDFmetricInfo(gc->fontfamily, face, pd), gc);
- } else {
- PostScriptWriteString(pd->pdffp, str, strlen(str));
- fprintf(pd->pdffp, " Tj\n");
- }
- textoff(pd); /* added in 2.8.0 */
-}
-
-static char *PDFconvname(const char *family, PDFDesc *pd);
-
-static void PDF_Text0(double x, double y, const char *str, int enc,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int size = (int) floor(gc->cex * gc->ps + 0.5);
- int face = gc->fontface;
- double a, b, bm, rot1;
- char *buff;
- const char *str1;
-
- PDF_checkOffline();
-
- if(!R_VIS(gc->col) || size <= 0) return;
-
- if(face < 1 || face > 5) {
- warning(_("attempt to use invalid font %d replaced by font 1"), face);
- face = 1;
- }
- if (face == 5) {
- PDFSimpleText(x, y, str, rot, hadj,
- PDFfontNumber(gc->fontfamily, face, pd),
- gc, dd);
- return;
- }
-
- rot1 = rot * DEG2RAD;
- a = size * cos(rot1);
- b = size * sin(rot1);
- bm = -b;
- /* avoid printing -0.00 on rotated text */
- if(fabs(a) < 0.01) a = 0.0;
- if(fabs(b) < 0.01) {b = 0.0; bm = 0.0;}
- if(!pd->inText) texton(pd);
-
- if(isCIDFont(gc->fontfamily, PDFFonts, pd->defaultCIDFont) && face != 5) {
- /* NB we could be in a SBCS here */
- size_t ucslen;
- unsigned char *p;
- int fontIndex;
-
- /*
- * CID convert optimize PDF encoding == locale encode case
- */
- cidfontfamily cidfont = findDeviceCIDFont(gc->fontfamily,
- pd->cidfonts,
- &fontIndex);
- if (!cidfont) {
- int dontcare;
- /*
- * Try to load the font
- */
- cidfont = addCIDFont(gc->fontfamily, 1);
- if (cidfont) {
- if (!addPDFDeviceCIDfont(cidfont, pd, &dontcare)) {
- cidfont = NULL;
- }
- }
- }
- if (!cidfont)
- error(_("failed to find or load PDF CID font"));
- if(!dd->hasTextUTF8 &&
- !strcmp(locale2charset(NULL), cidfont->encoding)) {
- PDF_SetFill(gc->col, dd);
- fprintf(pd->pdffp,
- "/F%d 1 Tf %.2f %.2f %.2f %.2f %.2f %.2f Tm ",
- PDFfontNumber(gc->fontfamily, face, pd),
- a, b, bm, a, x, y);
-
- fprintf(pd->pdffp, "<");
- p = (unsigned char *) str;
- while(*p)
- fprintf(pd->pdffp, "%02x", *p++);
- fprintf(pd->pdffp, ">");
- fprintf(pd->pdffp, " Tj\n");
- return;
- }
-
- /*
- * CID convert PDF encoding != locale encode case
- */
- ucslen = (dd->hasTextUTF8) ? Rf_utf8towcs(NULL, str, 0): mbstowcs(NULL, str, 0);
- if (ucslen != (size_t)-1) {
- void *cd;
- const char *i_buf; char *o_buf;
- size_t i, nb, i_len, o_len, buflen = ucslen*sizeof(ucs2_t);
- size_t status;
-
- cd = (void*)Riconv_open(cidfont->encoding,
- (enc == CE_UTF8) ? "UTF-8": "");
- if(cd == (void*)-1) return;
-
- R_CheckStack2(buflen);
- unsigned char buf[buflen];
-
- i_buf = (char *)str;
- o_buf = (char *)buf;
- i_len = strlen(str); /* no terminator,
- as output a byte at a time */
- nb = o_len = buflen;
-
- status = Riconv(cd, &i_buf, (size_t *)&i_len,
- (char **)&o_buf, (size_t *)&o_len);
-
- Riconv_close(cd);
- if(status == (size_t)-1)
- warning(_("failed in text conversion to encoding '%s'"),
- cidfont->encoding);
- else {
- unsigned char *p;
- PDF_SetFill(gc->col, dd);
- fprintf(pd->pdffp,
- "/F%d 1 Tf %.2f %.2f %.2f %.2f %.2f %.2f Tm <",
- PDFfontNumber(gc->fontfamily, face, pd),
- a, b, bm, a, x, y);
- for(i = 0, p = buf; i < nb - o_len; i++)
- fprintf(pd->pdffp, "%02x", *p++);
- fprintf(pd->pdffp, "> Tj\n");
- }
- return;
- } else {
- warning(_("invalid string in '%s'"), "PDF_Text");
- return;
- }
- }
-
- PDF_SetFill(gc->col, dd);
- fprintf(pd->pdffp, "/F%d 1 Tf %.2f %.2f %.2f %.2f %.2f %.2f Tm ",
- PDFfontNumber(gc->fontfamily, face, pd),
- a, b, bm, a, x, y);
- if((enc == CE_UTF8 || mbcslocale) && !strIsASCII(str) && face < 5) {
- /* face 5 handled above */
- R_CheckStack2(strlen(str)+1);
- buff = alloca(strlen(str)+1); /* Output string cannot be longer */
- mbcsToSbcs(str, buff, PDFconvname(gc->fontfamily, pd), enc);
- str1 = buff;
- } else str1 = str;
-
- if (pd->useKern &&
- isType1Font(gc->fontfamily, PDFFonts, pd->defaultFont)) {
- PDFWriteT1KerningString(pd->pdffp, str1,
- PDFmetricInfo(gc->fontfamily, face, pd), gc);
- } else{
- PostScriptWriteString(pd->pdffp, str1, strlen(str1));
- fprintf(pd->pdffp, " Tj\n");
- }
- textoff(pd); /* added in 2.8.0 */
-}
-
-static void PDF_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDF_Text0(x, y, str, CE_NATIVE, rot, hadj, gc, dd);
-}
-
-static void PDF_TextUTF8(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDF_Text0(x, y, str, CE_UTF8, rot, hadj, gc, dd);
-}
-
-static FontMetricInfo
-*PDFCIDsymbolmetricInfo(const char *family, PDFDesc *pd)
-{
- FontMetricInfo *result = NULL;
- if (strlen(family) > 0) {
- int dontcare;
- /*
- * Find the family in pd->cidfonts
- */
- cidfontfamily fontfamily = findDeviceCIDFont(family,
- pd->cidfonts,
- &dontcare);
- if (fontfamily)
- result = &(fontfamily->symfont->metrics);
- else {
- /*
- * Try to load the font
- */
- fontfamily = addCIDFont(family, 1);
- if (fontfamily) {
- if (addPDFDeviceCIDfont(fontfamily, pd, &dontcare)) {
- result = &(fontfamily->symfont->metrics);
- } else {
- fontfamily = NULL;
- }
- }
- }
- if (!fontfamily)
- error(_("failed to find or load PDF CID font"));
- } else {
- result = &(pd->cidfonts->cidfamily->symfont->metrics);
- }
- return result;
-}
-
-static FontMetricInfo
-*PDFmetricInfo(const char *family, int face, PDFDesc *pd)
-{
- FontMetricInfo *result = NULL;
- if (strlen(family) > 0) {
- int dontcare;
- /*
- * Find the family in pd->fonts
- */
- type1fontfamily fontfamily = findDeviceFont(family, pd->fonts,
- &dontcare);
- if (fontfamily)
- result = &(fontfamily->fonts[face-1]->metrics);
- else {
- /*
- * Check whether the font is loaded and, if not,
- * load it.
- */
- fontfamily = findLoadedFont(family,
- pd->encodings->encoding->encpath,
- TRUE);
- if (!fontfamily) {
- fontfamily = addFont(family, TRUE, pd->encodings);
- }
- /*
- * Once the font is loaded, add it to the device's
- * list of fonts.
- */
- if (fontfamily) {
- int dontcare;
- if (addPDFDevicefont(fontfamily, pd, &dontcare)) {
- result = &(fontfamily->fonts[face-1]->metrics);
- } else {
- fontfamily = NULL;
- }
- }
- }
- if (!fontfamily)
- error(_("failed to find or load PDF font"));
- } else {
- result = &(pd->fonts->family->fonts[face-1]->metrics);
- }
- return result;
-}
-
-static char
-*PDFconvname(const char *family, PDFDesc *pd)
-{
- char *result = (pd->fonts) ? pd->fonts->family->encoding->convname : "latin1";
- /* pd->fonts is NULL when CIDfonts are used */
-
- if (strlen(family) > 0) {
- int dontcare;
- /*
- * Find the family in pd->fonts
- */
- type1fontfamily fontfamily = findDeviceFont(family, pd->fonts,
- &dontcare);
- if (fontfamily)
- result = fontfamily->encoding->convname;
- else {
- /*
- * Check whether the font is loaded and, if not,
- * load it.
- */
- fontfamily = findLoadedFont(family,
- pd->encodings->encoding->encpath,
- TRUE);
- if (!fontfamily) {
- fontfamily = addFont(family, TRUE, pd->encodings);
- }
- /*
- * Once the font is loaded, add it to the device's
- * list of fonts.
- */
- if (fontfamily) {
- int dontcare;
- if (addPDFDevicefont(fontfamily, pd, &dontcare)) {
- result = fontfamily->encoding->convname;
- } else {
- fontfamily = NULL;
- }
- }
- }
- if (!fontfamily)
- error(_("failed to find or load PDF font"));
- }
- return result;
-}
-
-double PDF_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
-
- if(gc->fontface < 1 || gc->fontface > 5) gc->fontface = 1;
- if (isType1Font(gc->fontfamily, PDFFonts, pd->defaultFont)) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- PDFmetricInfo(gc->fontfamily,
- gc->fontface, pd),
- pd->useKern, gc->fontface,
- PDFconvname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily) */
- if (gc->fontface < 5) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- NULL, FALSE, gc->fontface, NULL);
- } else {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_NATIVE,
- PDFCIDsymbolmetricInfo(gc->fontfamily,
- pd),
- FALSE, gc->fontface, NULL);
- }
- }
-}
-
-static double PDF_StrWidthUTF8(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(gc->fontface < 1 || gc->fontface > 5) gc->fontface = 1;
- if (isType1Font(gc->fontfamily, PDFFonts, pd->defaultFont)) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- PDFmetricInfo(gc->fontfamily,
- gc->fontface, pd),
- pd->useKern, gc->fontface,
- PDFconvname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily) */
- if (face < 5) {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- NULL, FALSE, gc->fontface, NULL);
- } else {
- return floor(gc->cex * gc->ps + 0.5) *
- PostScriptStringWidth((const unsigned char *)str, CE_UTF8,
- PDFCIDsymbolmetricInfo(gc->fontfamily,
- pd),
- FALSE, gc->fontface, NULL);
- }
- }
-}
-
-void PDF_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
- int face = gc->fontface;
-
- if(gc->fontface < 1 || gc->fontface > 5) gc->fontface = 1;
- if (isType1Font(gc->fontfamily, PDFFonts, pd->defaultFont)) {
- PostScriptMetricInfo(c, ascent, descent, width,
- PDFmetricInfo(gc->fontfamily,
- gc->fontface, pd),
- face == 5, PDFconvname(gc->fontfamily, pd));
- } else { /* cidfont(gc->fontfamily) */
- if (face < 5) {
- PostScriptCIDMetricInfo(c, ascent, descent, width);
- } else {
- PostScriptMetricInfo(c, ascent, descent, width,
- PDFCIDsymbolmetricInfo(gc->fontfamily, pd),
- TRUE, "");
- }
- }
- *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
- *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
- *width = floor(gc->cex * gc->ps + 0.5) * *width;
-}
-
-
-/* PostScript Device Driver Parameters:
- * ------------------------
- * file = output filename
- * paper = paper type
- * family = typeface = "family"
- * encoding = char encoding file name
- * cidfamily = char encoding file name for CID fonts
- * bg = background color
- * fg = foreground color
- * width = width in inches
- * height = height in inches
- * horizontal = {TRUE: landscape; FALSE: portrait}
- * ps = pointsize
- * onefile = {TRUE: normal; FALSE: single EPSF page}
- * pagecentre = centre plot region on paper?
- * printit = 'print' after closing device?
- * command = 'print' command
- * title = character string
- * fonts
- * colorModel
- * useKerning
- * fillOddEven
- */
-
-SEXP PostScript(SEXP args)
-{
- pGEDevDesc gdd;
- const void *vmax;
- const char *file, *paper, *family=NULL, *bg, *fg, *cmd;
- const char *afms[5];
- const char *encoding, *title, call[] = "postscript", *colormodel;
- int i, horizontal, onefile, pagecentre, printit, useKern;
- double height, width, ps;
- SEXP fam, fonts;
- Rboolean fillOddEven;
-
- vmax = vmaxget();
- args = CDR(args); /* skip entry point name */
- file = translateChar(asChar(CAR(args))); args = CDR(args);
- paper = CHAR(asChar(CAR(args))); args = CDR(args);
-
- /* 'family' can be either one string or a 5-vector of afmpaths. */
- fam = CAR(args); args = CDR(args);
- if(length(fam) == 1)
- family = CHAR(asChar(fam));
- else if(length(fam) == 5) {
- if(!isString(fam)) error(_("invalid 'family' parameter in %s"), call);
- family = "User";
- for(i = 0; i < 5; i++) afms[i] = CHAR(STRING_ELT(fam, i));
- } else
- error(_("invalid 'family' parameter in %s"), call);
-
- encoding = CHAR(asChar(CAR(args))); args = CDR(args);
- bg = CHAR(asChar(CAR(args))); args = CDR(args);
- fg = CHAR(asChar(CAR(args))); args = CDR(args);
- width = asReal(CAR(args)); args = CDR(args);
- height = asReal(CAR(args)); args = CDR(args);
- horizontal = asLogical(CAR(args));args = CDR(args);
- if(horizontal == NA_LOGICAL)
- horizontal = 1;
- ps = asReal(CAR(args)); args = CDR(args);
- onefile = asLogical(CAR(args)); args = CDR(args);
- pagecentre = asLogical(CAR(args));args = CDR(args);
- printit = asLogical(CAR(args)); args = CDR(args);
- cmd = CHAR(asChar(CAR(args))); args = CDR(args);
- title = translateChar(asChar(CAR(args))); args = CDR(args);
- fonts = CAR(args); args = CDR(args);
- if (!isNull(fonts) && !isString(fonts))
- error(_("invalid 'fonts' parameter in %s"), call);
- colormodel = CHAR(asChar(CAR(args))); args = CDR(args);
- useKern = asLogical(CAR(args)); args = CDR(args);
- if (useKern == NA_LOGICAL) useKern = 1;
- fillOddEven = asLogical(CAR(args));
- if (fillOddEven == NA_LOGICAL)
- error(_("invalid value of '%s'"), "fillOddEven");
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc))))
- return 0;
- if(!PSDeviceDriver(dev, file, paper, family, afms, encoding, bg, fg,
- width, height, (double)horizontal, ps, onefile,
- pagecentre, printit, cmd, title, fonts,
- colormodel, useKern, fillOddEven)) {
- /* we no longer get here: error is thrown in PSDeviceDriver */
- error(_("unable to start %s() device"), "postscript");
- }
- gdd = GEcreateDevDesc(dev);
- GEaddDevice2(gdd, "postscript");
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
-
-
-
-/* XFig Device Driver Parameters:
- * ------------------------
- * file = output filename
- * paper = paper type
- * family = typeface = "family"
- * bg = background color
- * fg = foreground color
- * width = width in inches
- * height = height in inches
- * horizontal = {TRUE: landscape; FALSE: portrait}
- * ps = pointsize
- * onefile = {TRUE: normal; FALSE: single EPSF page}
- * pagecentre = centre plot region on paper?
- * defaultfont = {TRUE: use xfig default font; FALSE: use R font}
- * textspecial = {TRUE: use textspecial; FALSE: use standard font}
- *
- * encoding
- */
-
-SEXP XFig(SEXP args)
-{
- pGEDevDesc gdd;
- const void *vmax;
- const char *file, *paper, *family, *bg, *fg, *encoding;
- int horizontal, onefile, pagecentre, defaultfont, textspecial;
- double height, width, ps;
-
- vmax = vmaxget();
- args = CDR(args); /* skip entry point name */
- file = translateChar(asChar(CAR(args))); args = CDR(args);
- paper = CHAR(asChar(CAR(args))); args = CDR(args);
- family = CHAR(asChar(CAR(args))); args = CDR(args);
- bg = CHAR(asChar(CAR(args))); args = CDR(args);
- fg = CHAR(asChar(CAR(args))); args = CDR(args);
- width = asReal(CAR(args)); args = CDR(args);
- height = asReal(CAR(args)); args = CDR(args);
- horizontal = asLogical(CAR(args));args = CDR(args);
- if(horizontal == NA_LOGICAL)
- horizontal = 1;
- ps = asReal(CAR(args)); args = CDR(args);
- onefile = asLogical(CAR(args)); args = CDR(args);
- pagecentre = asLogical(CAR(args));args = CDR(args);
- defaultfont = asLogical(CAR(args)); args = CDR(args);
- textspecial = asLogical(CAR(args)); args = CDR(args);
- encoding = CHAR(asChar(CAR(args)));
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc))))
- return 0;
- if(!XFigDeviceDriver(dev, file, paper, family, bg, fg, width, height,
- (double) horizontal, ps, onefile, pagecentre, defaultfont, textspecial,
- encoding)) {
- /* we no longer get here: error is thrown in XFigDeviceDriver */
- error(_("unable to start %s() device"), "xfig");
- }
- gdd = GEcreateDevDesc(dev);
- GEaddDevice2(gdd, "xfig");
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
-
-
-/* PDF Device Driver Parameters:
- * ------------------------
- * file = output filename
- * paper = paper type
- * family = typeface = "family"
- * encoding = char encoding file name
- * cidfamily = char encoding file name for CID fonts
- * bg = background color
- * fg = foreground color
- * width = width in inches
- * height = height in inches
- * ps = pointsize
- * onefile = {TRUE: normal; FALSE: single page per file}
- * title
- * fonts
- * versionMajor
- * versionMinor
- * colormodel
- * useDingbats
- * forceLetterSpacing
- * fillOddEven
- */
-
-SEXP PDF(SEXP args)
-{
- pGEDevDesc gdd;
- const void *vmax;
- const char *file, *paper, *encoding, *family = NULL /* -Wall */,
- *bg, *fg, *title, call[] = "PDF", *colormodel;
- const char *afms[5];
- double height, width, ps;
- int i, onefile, pagecentre, major, minor, dingbats, useKern, useCompression;
- SEXP fam, fonts;
- Rboolean fillOddEven;
-
- vmax = vmaxget();
- args = CDR(args); /* skip entry point name */
- if (isNull(CAR(args)))
- file = NULL;
- else
- file = translateChar(asChar(CAR(args))); args = CDR(args);
- paper = CHAR(asChar(CAR(args))); args = CDR(args);
- fam = CAR(args); args = CDR(args);
- if(length(fam) == 1)
- family = CHAR(asChar(fam));
- else if(length(fam) == 5) {
- if(!isString(fam)) error(_("invalid 'family' parameter in %s"), call);
- family = "User";
- for(i = 0; i < 5; i++) afms[i] = CHAR(STRING_ELT(fam, i));
- } else
- error(_("invalid 'family' parameter in %s"), call);
- encoding = CHAR(asChar(CAR(args))); args = CDR(args);
- bg = CHAR(asChar(CAR(args))); args = CDR(args);
- fg = CHAR(asChar(CAR(args))); args = CDR(args);
- width = asReal(CAR(args)); args = CDR(args);
- height = asReal(CAR(args)); args = CDR(args);
- ps = asReal(CAR(args)); args = CDR(args);
- onefile = asLogical(CAR(args)); args = CDR(args);
- pagecentre = asLogical(CAR(args));args = CDR(args);
- title = translateChar(asChar(CAR(args))); args = CDR(args);
- fonts = CAR(args); args = CDR(args);
- if (!isNull(fonts) && !isString(fonts))
- error(_("invalid 'fonts' parameter in %s"), call);
- major = asInteger(CAR(args)); args = CDR(args);
- minor = asInteger(CAR(args)); args = CDR(args);
- colormodel = CHAR(asChar(CAR(args))); args = CDR(args);
- dingbats = asLogical(CAR(args)); args = CDR(args);
- if (dingbats == NA_LOGICAL) dingbats = 1;
- useKern = asLogical(CAR(args)); args = CDR(args);
- if (useKern == NA_LOGICAL) useKern = 1;
- fillOddEven = asLogical(CAR(args)); args = CDR(args);
- if (fillOddEven == NA_LOGICAL)
- error(_("invalid value of '%s'"), "fillOddEven");
- useCompression = asLogical(CAR(args)); args = CDR(args);
- if (useCompression == NA_LOGICAL)
- error(_("invalid value of '%s'"), "useCompression");
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc))))
- return 0;
- if(!PDFDeviceDriver(dev, file, paper, family, afms, encoding, bg, fg,
- width, height, ps, onefile, pagecentre,
- title, fonts, major, minor, colormodel,
- dingbats, useKern, fillOddEven,
- useCompression)) {
- /* we no longer get here: error is thrown in PDFDeviceDriver */
- error(_("unable to start %s() device"), "pdf");
- }
- gdd = GEcreateDevDesc(dev);
- GEaddDevice2(gdd, "pdf");
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devPicTeX.c b/com.oracle.truffle.r.native/library/grDevices/src/devPicTeX.c
deleted file mode 100644
index e857a64219ddd9177b2ce5059762b969f1728bf1..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devPicTeX.c
+++ /dev/null
@@ -1,747 +0,0 @@
-/*
- * A PicTeX device, (C) 1996 Valerio Aimale, for
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 2001-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/
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "Defn.h"
-
-# include "main_rlocale.h" /* includes wchar.h */
-
-#define R_USE_PROTOTYPES 1
-#include <R_ext/GraphicsEngine.h>
-#include "main_Fileio.h"
-#include "grDevices.h"
-
- /* device-specific information per picTeX device */
-
-#define DOTSperIN 72.27
-#define in2dots(x) (DOTSperIN * x)
-
-typedef struct {
- FILE *texfp;
- char filename[128];
- int pageno;
- int landscape;
- double width;
- double height;
- double pagewidth;
- double pageheight;
- double xlast;
- double ylast;
- double clipleft, clipright, cliptop, clipbottom;
- double clippedx0, clippedy0, clippedx1, clippedy1;
- int lty;
- rcolor col;
- rcolor fill;
- int fontsize;
- int fontface;
- Rboolean debug;
-} picTeXDesc;
-
-
- /* Global device information */
-
-static const double charwidth[4][128] = {
-{
- 0.5416690, 0.8333360, 0.7777810, 0.6111145, 0.6666690, 0.7083380, 0.7222240,
- 0.7777810, 0.7222240, 0.7777810, 0.7222240, 0.5833360, 0.5361130, 0.5361130,
- 0.8138910, 0.8138910, 0.2388900, 0.2666680, 0.5000020, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.6666700, 0.4444460, 0.4805580, 0.7222240, 0.7777810,
- 0.5000020, 0.8611145, 0.9722260, 0.7777810, 0.2388900, 0.3194460, 0.5000020,
- 0.8333360, 0.5000020, 0.8333360, 0.7583360, 0.2777790, 0.3888900, 0.3888900,
- 0.5000020, 0.7777810, 0.2777790, 0.3333340, 0.2777790, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.2777790, 0.2777790, 0.3194460, 0.7777810, 0.4722240,
- 0.4722240, 0.6666690, 0.6666700, 0.6666700, 0.6388910, 0.7222260, 0.5972240,
- 0.5694475, 0.6666690, 0.7083380, 0.2777810, 0.4722240, 0.6944480, 0.5416690,
- 0.8750050, 0.7083380, 0.7361130, 0.6388910, 0.7361130, 0.6458360, 0.5555570,
- 0.6805570, 0.6875050, 0.6666700, 0.9444480, 0.6666700, 0.6666700, 0.6111130,
- 0.2888900, 0.5000020, 0.2888900, 0.5000020, 0.2777790, 0.2777790, 0.4805570,
- 0.5166680, 0.4444460, 0.5166680, 0.4444460, 0.3055570, 0.5000020, 0.5166680,
- 0.2388900, 0.2666680, 0.4888920, 0.2388900, 0.7944470, 0.5166680, 0.5000020,
- 0.5166680, 0.5166680, 0.3416690, 0.3833340, 0.3611120, 0.5166680, 0.4611130,
- 0.6833360, 0.4611130, 0.4611130, 0.4347230, 0.5000020, 1.0000030, 0.5000020,
- 0.5000020, 0.5000020
-},
-{
- 0.5805590, 0.9166720, 0.8555600, 0.6722260, 0.7333370, 0.7944490, 0.7944490,
- 0.8555600, 0.7944490, 0.8555600, 0.7944490, 0.6416700, 0.5861150, 0.5861150,
- 0.8916720, 0.8916720, 0.2555570, 0.2861130, 0.5500030, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.7333370, 0.4888920, 0.5652800, 0.7944490, 0.8555600,
- 0.5500030, 0.9472275, 1.0694500, 0.8555600, 0.2555570, 0.3666690, 0.5583360,
- 0.9166720, 0.5500030, 1.0291190, 0.8305610, 0.3055570, 0.4277800, 0.4277800,
- 0.5500030, 0.8555600, 0.3055570, 0.3666690, 0.3055570, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.3055570, 0.3055570, 0.3666690, 0.8555600, 0.5194470,
- 0.5194470, 0.7333370, 0.7333370, 0.7333370, 0.7027820, 0.7944490, 0.6416700,
- 0.6111145, 0.7333370, 0.7944490, 0.3305570, 0.5194470, 0.7638930, 0.5805590,
- 0.9777830, 0.7944490, 0.7944490, 0.7027820, 0.7944490, 0.7027820, 0.6111145,
- 0.7333370, 0.7638930, 0.7333370, 1.0388950, 0.7333370, 0.7333370, 0.6722260,
- 0.3430580, 0.5583360, 0.3430580, 0.5500030, 0.3055570, 0.3055570, 0.5250030,
- 0.5611140, 0.4888920, 0.5611140, 0.5111140, 0.3361130, 0.5500030, 0.5611140,
- 0.2555570, 0.2861130, 0.5305590, 0.2555570, 0.8666720, 0.5611140, 0.5500030,
- 0.5611140, 0.5611140, 0.3722250, 0.4216690, 0.4041690, 0.5611140, 0.5000030,
- 0.7444490, 0.5000030, 0.5000030, 0.4763920, 0.5500030, 1.1000060, 0.5500030,
- 0.5500030, 0.550003 },
-{
- 0.5416690, 0.8333360, 0.7777810, 0.6111145, 0.6666690, 0.7083380, 0.7222240,
- 0.7777810, 0.7222240, 0.7777810, 0.7222240, 0.5833360, 0.5361130, 0.5361130,
- 0.8138910, 0.8138910, 0.2388900, 0.2666680, 0.5000020, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.7375210, 0.4444460, 0.4805580, 0.7222240, 0.7777810,
- 0.5000020, 0.8611145, 0.9722260, 0.7777810, 0.2388900, 0.3194460, 0.5000020,
- 0.8333360, 0.5000020, 0.8333360, 0.7583360, 0.2777790, 0.3888900, 0.3888900,
- 0.5000020, 0.7777810, 0.2777790, 0.3333340, 0.2777790, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020, 0.5000020,
- 0.5000020, 0.5000020, 0.2777790, 0.2777790, 0.3194460, 0.7777810, 0.4722240,
- 0.4722240, 0.6666690, 0.6666700, 0.6666700, 0.6388910, 0.7222260, 0.5972240,
- 0.5694475, 0.6666690, 0.7083380, 0.2777810, 0.4722240, 0.6944480, 0.5416690,
- 0.8750050, 0.7083380, 0.7361130, 0.6388910, 0.7361130, 0.6458360, 0.5555570,
- 0.6805570, 0.6875050, 0.6666700, 0.9444480, 0.6666700, 0.6666700, 0.6111130,
- 0.2888900, 0.5000020, 0.2888900, 0.5000020, 0.2777790, 0.2777790, 0.4805570,
- 0.5166680, 0.4444460, 0.5166680, 0.4444460, 0.3055570, 0.5000020, 0.5166680,
- 0.2388900, 0.2666680, 0.4888920, 0.2388900, 0.7944470, 0.5166680, 0.5000020,
- 0.5166680, 0.5166680, 0.3416690, 0.3833340, 0.3611120, 0.5166680, 0.4611130,
- 0.6833360, 0.4611130, 0.4611130, 0.4347230, 0.5000020, 1.0000030, 0.5000020,
- 0.5000020, 0.5000020 },
-{
- 0.5805590, 0.9166720, 0.8555600, 0.6722260, 0.7333370, 0.7944490, 0.7944490,
- 0.8555600, 0.7944490, 0.8555600, 0.7944490, 0.6416700, 0.5861150, 0.5861150,
- 0.8916720, 0.8916720, 0.2555570, 0.2861130, 0.5500030, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.8002530, 0.4888920, 0.5652800, 0.7944490, 0.8555600,
- 0.5500030, 0.9472275, 1.0694500, 0.8555600, 0.2555570, 0.3666690, 0.5583360,
- 0.9166720, 0.5500030, 1.0291190, 0.8305610, 0.3055570, 0.4277800, 0.4277800,
- 0.5500030, 0.8555600, 0.3055570, 0.3666690, 0.3055570, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030, 0.5500030,
- 0.5500030, 0.5500030, 0.3055570, 0.3055570, 0.3666690, 0.8555600, 0.5194470,
- 0.5194470, 0.7333370, 0.7333370, 0.7333370, 0.7027820, 0.7944490, 0.6416700,
- 0.6111145, 0.7333370, 0.7944490, 0.3305570, 0.5194470, 0.7638930, 0.5805590,
- 0.9777830, 0.7944490, 0.7944490, 0.7027820, 0.7944490, 0.7027820, 0.6111145,
- 0.7333370, 0.7638930, 0.7333370, 1.0388950, 0.7333370, 0.7333370, 0.6722260,
- 0.3430580, 0.5583360, 0.3430580, 0.5500030, 0.3055570, 0.3055570, 0.5250030,
- 0.5611140, 0.4888920, 0.5611140, 0.5111140, 0.3361130, 0.5500030, 0.5611140,
- 0.2555570, 0.2861130, 0.5305590, 0.2555570, 0.8666720, 0.5611140, 0.5500030,
- 0.5611140, 0.5611140, 0.3722250, 0.4216690, 0.4041690, 0.5611140, 0.5000030,
- 0.7444490, 0.5000030, 0.5000030, 0.4763920, 0.5500030, 1.1000060, 0.5500030,
- 0.5500030, 0.550003
-}
-};
-
-static const char * const fontname[] = {
- "cmss10",
- "cmssbx10",
- "cmssi10",
- "cmssxi10"
-};
-
-
- /* Device driver actions */
-
-static void PicTeX_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd);
-static void PicTeX_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd);
-static void PicTeX_Close(pDevDesc dd);
-static void PicTeX_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd);
-static void PicTeX_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd);
-static void PicTeX_NewPage(const pGEcontext gc, pDevDesc dd);
-static void PicTeX_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void PicTeX_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd);
-static void PicTeX_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd);
-static double PicTeX_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void PicTeX_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-static Rboolean PicTeX_Open(pDevDesc, picTeXDesc*);
-
- /* Support routines */
-
-static void SetLinetype(int newlty, double newlwd, pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- int i, templty;
- ptd->lty = newlty;
- if (ptd->lty) {
- fprintf(ptd->texfp,"\\setdashpattern <");
- for(i=0 ; i<8 && newlty&15 ; i++) {
- int lwd = (int)newlwd * newlty;
- fprintf(ptd->texfp,"%dpt", lwd & 15);
- templty = newlty>>4;
- if ((i+1)<8 && templty&15) fprintf(ptd->texfp,", ");
- newlty = newlty>>4;
- }
- fprintf(ptd->texfp,">\n");
- } else fprintf(ptd->texfp,"\\setsolid\n");
-}
-
-
-static void SetFont(int face, int size, picTeXDesc *ptd)
-{
- int lface=face, lsize= size;
- if(lface < 1 || lface > 4 ) lface = 1;
- if(lsize < 1 || lsize > 24) lsize = 10;
- if(lsize != ptd->fontsize || lface != ptd->fontface) {
- fprintf(ptd->texfp, "\\font\\picfont %s at %dpt\\picfont\n",
- fontname[lface-1], lsize);
- ptd->fontsize = lsize;
- ptd->fontface = lface;
- }
-}
-
-static void PicTeX_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- /* metric information not available => return 0,0,0 */
- *ascent = 0.0;
- *descent = 0.0;
- *width = 0.0;
-}
-
- /* Initialize the device */
-
-static Rboolean PicTeX_Open(pDevDesc dd, picTeXDesc *ptd)
-{
- ptd->fontsize = 0;
- ptd->fontface = 0;
- ptd->debug = FALSE;
- if (!(ptd->texfp = R_fopen(R_ExpandFileName(ptd->filename), "w")))
- return FALSE;
- fprintf(ptd->texfp, "\\hbox{\\beginpicture\n");
- fprintf(ptd->texfp, "\\setcoordinatesystem units <1pt,1pt>\n");
- fprintf(ptd->texfp,
- "\\setplotarea x from 0 to %.2f, y from 0 to %.2f\n",
- in2dots(ptd->width), in2dots(ptd->height));
- fprintf(ptd->texfp,"\\setlinear\n");
- fprintf(ptd->texfp, "\\font\\picfont cmss10\\picfont\n");
- SetFont(1, 10, ptd);
- ptd->pageno++;
- return TRUE;
-}
-
-
- /* Interactive Resize */
-
-static void PicTeX_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- *left = dd->left; /* left */
- *right = dd->right;/* right */
- *bottom = dd->bottom; /* bottom */
- *top = dd->top;/* top */
-}
-
-static void PicTeX_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- if(ptd->debug)
- fprintf(ptd->texfp, "%% Setting Clip Region to %.2f %.2f %.2f %.2f\n",
- x0, y0, x1, y1);
- ptd->clipleft = x0;
- ptd->clipright = x1;
- ptd->clipbottom = y0;
- ptd->cliptop = y1;
-}
-
- /* Start a new page */
-
-static void PicTeX_NewPage(const pGEcontext gc,
- pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- int face, size;
- if (ptd->pageno) {
- fprintf(ptd->texfp, "\\endpicture\n}\n\n\n");
- fprintf(ptd->texfp, "\\hbox{\\beginpicture\n");
- fprintf(ptd->texfp, "\\setcoordinatesystem units <1pt,1pt>\n");
- fprintf(ptd->texfp,
- "\\setplotarea x from 0 to %.2f, y from 0 to %.2f\n",
- in2dots(ptd->width), in2dots(ptd->height));
- fprintf(ptd->texfp,"\\setlinear\n");
- fprintf(ptd->texfp, "\\font\\picfont cmss10\\picfont\n");
- }
- ptd->pageno++;
- face = ptd->fontface;
- size = ptd->fontsize;
- ptd->fontface = 0;
- ptd->fontsize = 0;
- SetFont(face, size, ptd);
-}
-
- /* Close down the driver */
-
-static void PicTeX_Close(pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- fprintf(ptd->texfp, "\\endpicture\n}\n");
- fclose(ptd->texfp);
-
- free(ptd);
-}
-
- /* Draw To */
-
-static void PicTeX_ClipLine(double x0, double y0, double x1, double y1,
- picTeXDesc *ptd)
-{
- ptd->clippedx0 = x0; ptd->clippedx1 = x1;
- ptd->clippedy0 = y0; ptd->clippedy1 = y1;
-
- if ((ptd->clippedx0 < ptd->clipleft &&
- ptd->clippedx1 < ptd->clipleft) ||
- (ptd->clippedx0 > ptd->clipright &&
- ptd->clippedx1 > ptd->clipright) ||
- (ptd->clippedy0 < ptd->clipbottom &&
- ptd->clippedy1 < ptd->clipbottom) ||
- (ptd->clippedy0 > ptd->cliptop &&
- ptd->clippedy1 > ptd->cliptop)) {
- ptd->clippedx0 = ptd->clippedx1;
- ptd->clippedy0 = ptd->clippedy1;
- return;
- }
-
- /*Clipping Left */
- if (ptd->clippedx1 >= ptd->clipleft && ptd->clippedx0 < ptd->clipleft) {
- ptd->clippedy0 = ((ptd->clippedy1-ptd->clippedy0) /
- (ptd->clippedx1-ptd->clippedx0) *
- (ptd->clipleft-ptd->clippedx0)) +
- ptd->clippedy0;
- ptd->clippedx0 = ptd->clipleft;
- }
- if (ptd->clippedx1 <= ptd->clipleft && ptd->clippedx0 > ptd->clipleft) {
- ptd->clippedy1 = ((ptd->clippedy1-ptd->clippedy0) /
- (ptd->clippedx1-ptd->clippedx0) *
- (ptd->clipleft-ptd->clippedx0)) +
- ptd->clippedy0;
- ptd->clippedx1 = ptd->clipleft;
- }
- /* Clipping Right */
- if (ptd->clippedx1 >= ptd->clipright &&
- ptd->clippedx0 < ptd->clipright) {
- ptd->clippedy1 = ((ptd->clippedy1-ptd->clippedy0) /
- (ptd->clippedx1-ptd->clippedx0) *
- (ptd->clipright-ptd->clippedx0)) +
- ptd->clippedy0;
- ptd->clippedx1 = ptd->clipright;
- }
- if (ptd->clippedx1 <= ptd->clipright &&
- ptd->clippedx0 > ptd->clipright) {
- ptd->clippedy0 = ((ptd->clippedy1-ptd->clippedy0) /
- (ptd->clippedx1-ptd->clippedx0) *
- (ptd->clipright-ptd->clippedx0)) +
- ptd->clippedy0;
- ptd->clippedx0 = ptd->clipright;
- }
- /*Clipping Bottom */
- if (ptd->clippedy1 >= ptd->clipbottom &&
- ptd->clippedy0 < ptd->clipbottom ) {
- ptd->clippedx0 = ((ptd->clippedx1-ptd->clippedx0) /
- (ptd->clippedy1-ptd->clippedy0) *
- (ptd->clipbottom -ptd->clippedy0)) +
- ptd->clippedx0;
- ptd->clippedy0 = ptd->clipbottom ;
- }
- if (ptd->clippedy1 <= ptd->clipbottom &&
- ptd->clippedy0 > ptd->clipbottom ) {
- ptd->clippedx1 = ((ptd->clippedx1-ptd->clippedx0) /
- (ptd->clippedy1-ptd->clippedy0) *
- (ptd->clipbottom -ptd->clippedy0)) +
- ptd->clippedx0;
- ptd->clippedy1 = ptd->clipbottom ;
- }
- /*Clipping Top */
- if (ptd->clippedy1 >= ptd->cliptop && ptd->clippedy0 < ptd->cliptop ) {
- ptd->clippedx1 = ((ptd->clippedx1-ptd->clippedx0) /
- (ptd->clippedy1-ptd->clippedy0) *
- (ptd->cliptop -ptd->clippedy0)) +
- ptd->clippedx0;
- ptd->clippedy1 = ptd->cliptop ;
- }
- if (ptd->clippedy1 <= ptd->cliptop && ptd->clippedy0 > ptd->cliptop ) {
- ptd->clippedx0 = ((ptd->clippedx1-ptd->clippedx0) /
- (ptd->clippedy1-ptd->clippedy0) *
- (ptd->cliptop -ptd->clippedy0)) +
- ptd->clippedx0;
- ptd->clippedy0 = ptd->cliptop ;
- }
-}
-
-static void PicTeX_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- if (x1 != x2 || y1 != y2) {
- SetLinetype(gc->lty, gc->lwd, dd);
- if(ptd->debug)
- fprintf(ptd->texfp,
- "%% Drawing line from %.2f, %.2f to %.2f, %.2f\n",
- x1, y1, x2, y2);
- PicTeX_ClipLine(x1, y1, x2, y2, ptd);
- if (ptd->debug)
- fprintf(ptd->texfp,
- "%% Drawing clipped line from %.2f, %.2f to %.2f, %.2f\n",
- ptd->clippedx0, ptd->clippedy0,
- ptd->clippedx1, ptd->clippedy1);
- fprintf(ptd->texfp, "\\plot %.2f %.2f %.2f %.2f /\n",
- ptd->clippedx0, ptd->clippedy0,
- ptd->clippedx1, ptd->clippedy1);
- }
-}
-
-static void PicTeX_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- double x1, y1, x2, y2;
- int i;
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- SetLinetype(gc->lty, gc->lwd, dd);
- x1 = x[0];
- y1 = y[0];
- for (i = 1; i < n; i++) {
- x2 = x[i];
- y2 = y[i];
- PicTeX_ClipLine(x1, y1, x2, y2, ptd);
- fprintf(ptd->texfp, "\\plot %.2f %.2f %.2f %.2f /\n",
- ptd->clippedx0, ptd->clippedy0,
- ptd->clippedx1, ptd->clippedy1);
- x1 = x2;
- y1 = y2;
- }
-}
-
- /* String Width in Rasters */
- /* For the current font in pointsize fontsize */
-
-static double PicTeX_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- const char *p;
- int size;
- double sum;
-
- size = (int)(gc->cex * gc->ps + 0.5);
- SetFont(gc->fontface, size, ptd);
- sum = 0;
- if(mbcslocale && ptd->fontface != 5) {
- /* This version at least uses the state of the MBCS */
- size_t i, ucslen = mbcsToUcs2(str, NULL, 0, CE_NATIVE);
- if (ucslen != (size_t)-1) {
- ucs2_t ucs[ucslen];
- int status = (int) mbcsToUcs2(str, ucs, (int)ucslen, CE_NATIVE);
- if (status >= 0)
- for (i = 0; i < ucslen; i++)
- if(ucs[i] < 128) sum += charwidth[ptd->fontface-1][ucs[i]];
- else sum += (double) Ri18n_wcwidth(ucs[i]) * 0.5; /* A guess */
- else
- warning(_("invalid string in '%s'"), "PicTeX_StrWidth");
- } else
- warning(_("invalid string in '%s'"), "PicTeX_StrWidth");
- } else
- for(p = str; *p; p++)
- sum += charwidth[ptd->fontface-1][(int)*p];
-
- return sum * ptd->fontsize;
-}
-
-
-/* Possibly Filled Rectangle */
-static void PicTeX_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd)
-{
- double x[4], y[4];
-
- x[0] = x0; y[0] = y0;
- x[1] = x0; y[1] = y1;
- x[2] = x1; y[2] = y1;
- x[3] = x1; y[3] = y0;
- PicTeX_Polygon(4, x, y, gc, dd);
-}
-
-
-static void PicTeX_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd)
-{
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- fprintf(ptd->texfp,
- "\\circulararc 360 degrees from %.2f %.2f center at %.2f %.2f\n",
- x, (y + r), x, y);
-}
-
-static void PicTeX_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- double x1, y1, x2, y2;
- int i;
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- SetLinetype(gc->lty, gc->lwd, dd);
- x1 = x[0];
- y1 = y[0];
- for (i=1; i<n; i++) {
- x2 = x[i];
- y2 = y[i];
- PicTeX_ClipLine(x1, y1, x2, y2, ptd);
- fprintf(ptd->texfp, "\\plot %.2f %.2f %.2f %.2f /\n",
- ptd->clippedx0, ptd->clippedy0,
- ptd->clippedx1, ptd->clippedy1);
- x1 = x2;
- y1 = y2;
- }
- x2 = x[0];
- y2 = y[0];
- PicTeX_ClipLine(x1, y1, x2, y2, ptd);
- fprintf(ptd->texfp, "\\plot %.2f %.2f %.2f %.2f /\n",
- ptd->clippedx0, ptd->clippedy0,
- ptd->clippedx1, ptd->clippedy1);
-}
-
-/* TeX Text Translations */
-static void textext(const char *str, picTeXDesc *ptd)
-{
- fputc('{', ptd->texfp);
- for( ; *str ; str++)
- switch(*str) {
- case '$':
- fprintf(ptd->texfp, "\\$");
- break;
-
- case '%':
- fprintf(ptd->texfp, "\\%%");
- break;
-
- case '{':
- fprintf(ptd->texfp, "\\{");
- break;
-
- case '}':
- fprintf(ptd->texfp, "\\}");
- break;
-
- case '^':
- fprintf(ptd->texfp, "\\^{}");
- break;
-
- default:
- fputc(*str, ptd->texfp);
- break;
- }
- fprintf(ptd->texfp,"} ");
-}
-
-/* Rotated Text */
-
-static void PicTeX_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int size;
- double xoff = 0.0, yoff = 0.0;
- picTeXDesc *ptd = (picTeXDesc *) dd->deviceSpecific;
-
- size = (int)(gc->cex * gc->ps + 0.5);
- SetFont(gc->fontface, size, ptd);
- if(ptd->debug)
- fprintf(ptd->texfp,
- "%% Writing string of length %.2f, at %.2f %.2f, xc = %.2f yc = %.2f\n",
- (double)PicTeX_StrWidth(str, gc, dd),
- x, y, 0.0, 0.0);
-#if 0 /* Original */
- fprintf(ptd->texfp,"\\put ");
- textext(str, ptd);
- if (rot == 90 )
- fprintf(ptd->texfp," [rB] <%.2fpt,%.2fpt>", xoff, yoff);
- else fprintf(ptd->texfp," [lB] <%.2fpt,%.2fpt>", xoff, yoff);
-#else /* use rotatebox */
- if (rot == 90 ){
- fprintf(ptd->texfp,"\\put {\\rotatebox{%d}",(int)rot);
- textext(str, ptd);
- fprintf(ptd->texfp,"} [rB] <%.2fpt,%.2fpt>", xoff, yoff);
- } else {
- fprintf(ptd->texfp,"\\put ");
- textext(str, ptd);
- fprintf(ptd->texfp," [lB] <%.2fpt,%.2fpt>", xoff, yoff);
- }
-#endif
- fprintf(ptd->texfp," at %.2f %.2f\n", x, y);
-}
-
-static
-Rboolean PicTeXDeviceDriver(pDevDesc dd, const char *filename,
- const char *bg, const char *fg,
- double width, double height,
- Rboolean debug)
-{
- picTeXDesc *ptd;
-
- if (!(ptd = (picTeXDesc *) malloc(sizeof(picTeXDesc))))
- return FALSE;
-
- strcpy(ptd->filename, filename);
-
- dd->startfill = R_GE_str2col(bg);
- dd->startcol = R_GE_str2col(fg);
- dd->startps = 10;
- dd->startlty = 0;
- dd->startfont = 1;
- dd->startgamma = 1;
-
- dd->close = PicTeX_Close;
- dd->clip = PicTeX_Clip;
- dd->size = PicTeX_Size;
- dd->newPage = PicTeX_NewPage;
- dd->line = PicTeX_Line;
- dd->text = PicTeX_Text;
- dd->strWidth = PicTeX_StrWidth;
- dd->rect = PicTeX_Rect;
- dd->circle = PicTeX_Circle;
- /* dd->path = PicTeX_Path; not implemented */
- dd->polygon = PicTeX_Polygon;
- dd->polyline = PicTeX_Polyline;
- dd->metricInfo = PicTeX_MetricInfo;
- dd->hasTextUTF8 = FALSE;
- dd->useRotatedTextInContour = FALSE;
-
- /* Screen Dimensions in Pixels */
-
- dd->left = 0; /* left */
- dd->right = in2dots(width);/* right */
- dd->bottom = 0; /* bottom */
- dd->top = in2dots(height);/* top */
- dd->clipLeft = dd->left; dd->clipRight = dd->right;
- dd->clipBottom = dd->bottom; dd->clipTop = dd->top;
- ptd->width = width;
- ptd->height = height;
-
- if( ! PicTeX_Open(dd, ptd) )
- return FALSE;
-
- /* Base Pointsize */
- /* Nominal Character Sizes in Pixels */
-
- dd->cra[0] = 9;
- dd->cra[1] = 12;
-
- /* Character Addressing Offsets */
- /* These offsets should center a single */
- /* plotting character over the plotting point. */
- /* Pure guesswork and eyeballing ... */
-
- dd->xCharOffset = 0; /*0.4900;*/
- dd->yCharOffset = 0; /*0.3333;*/
- dd->yLineBias = 0; /*0.1;*/
-
- /* Inches per Raster Unit */
- /* We use printer points, i.e. 72.27 dots per inch : */
- dd->ipr[0] = dd->ipr[1] = 1./DOTSperIN;
-
- dd->canClip = TRUE;
- dd->canHAdj = 0;
- dd->canChangeGamma = FALSE;
-
- ptd->lty = 1;
- ptd->pageno = 0;
- ptd->debug = debug;
-
- dd->haveTransparency = 1;
- dd->haveTransparentBg = 2;
-
- dd->deviceSpecific = (void *) ptd;
- dd->displayListOn = FALSE;
- return TRUE;
-}
-
-/* PicTeX Device Driver Parameters
- * --------------------
- * file = output filename
- * bg = background color
- * fg = foreground color
- * width = width in inches
- * height = height in inches
- * debug = Rboolean; if TRUE, write TeX-Comments into output.
- */
-
-SEXP PicTeX(SEXP args)
-{
- pGEDevDesc dd;
- const char *file, *bg, *fg;
- double height, width;
- Rboolean debug;
-
- const void *vmax = vmaxget();
- args = CDR(args); /* skip entry point name */
- file = translateChar(asChar(CAR(args))); args = CDR(args);
- bg = CHAR(asChar(CAR(args))); args = CDR(args);
- fg = CHAR(asChar(CAR(args))); args = CDR(args);
- width = asReal(CAR(args)); args = CDR(args);
- height = asReal(CAR(args)); args = CDR(args);
- debug = asLogical(CAR(args)); args = CDR(args);
- if(debug == NA_LOGICAL) debug = FALSE;
-
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc))))
- return 0;
- if(!PicTeXDeviceDriver(dev, file, bg, fg, width, height, debug)) {
- free(dev);
- error(_("unable to start %s() device"), "pictex");
- }
- dd = GEcreateDevDesc(dev);
- GEaddDevice2(dd, "pictex");
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devQuartz.c b/com.oracle.truffle.r.native/library/grDevices/src/devQuartz.c
deleted file mode 100644
index a0af5c2720074a93199f977496337a96779eeb35..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devQuartz.c
+++ /dev/null
@@ -1,1626 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2007-11 The R Foundation
- *
- * 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/
- *
- * Modular Quartz device for Mac OS X
- *
- * Partially based on code by Byron Ellis
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#if HAVE_AQUA
-
-#include "Defn.h"
-#include <Rinternals.h>
-#define R_USE_PROTOTYPES 1
-#include <R_ext/GraphicsEngine.h>
-/* This sets ptr_QuartzBackend as a symbol in this file */
-#define IN_AQUA_C 1
-#include <R_ext/QuartzDevice.h>
-
-#include "grDevices.h"
-
-#include <CoreFoundation/CoreFoundation.h>
-
-#define DEVQUARTZ_VERSION 1 /* first public Quartz API version */
-
-#define QBE_NATIVE 1 /* either Cocoa or Carbon depending on the OS X version */
-#define QBE_COCOA 2 /* internal Cocoa */
-#define QBE_CARBON 3 /* internal Carbon */
-#define QBE_BITMAP 4 /* bitmap file creating */
-#define QBE_PDF 5 /* PDF file creating */
-
-typedef struct moduleTypes_s {
- const char *type;
- const char *subst;
- int qbe; /* Quartz back-end */
-} quartz_module_t;
-
-/* list of internally supported output modules */
-const quartz_module_t quartz_modules[] = {
- { "", 0, QBE_NATIVE },
- { "native", 0, QBE_NATIVE },
- { "cocoa", 0, QBE_COCOA },
- { "carbon", 0, QBE_CARBON },
- { "pdf", 0, QBE_PDF },
- { "png", "public.png", QBE_BITMAP },
- { "jpeg", "public.jpeg", QBE_BITMAP },
- { "jpg", "public.jpeg", QBE_BITMAP },
- { "jpeg2000","public.jpeg-2000", QBE_BITMAP },
- { "tiff", "public.tiff", QBE_BITMAP },
- { "tif", "public.tiff", QBE_BITMAP },
- { "gif", "com.compuserve.gif", QBE_BITMAP },
- { "psd", "com.adobe.photoshop-image", QBE_BITMAP },
- { "bmp", "com.microsoft.bmp", QBE_BITMAP },
- { "sgi", "com.sgi.sgi-image", QBE_BITMAP },
- { "pict", "com.apple.pict", QBE_BITMAP },
- { 0, 0, 0} };
-
-
-
-/* for compatibility with OS X <10.5 */
-#ifndef CGFLOAT_DEFINED
-typedef float CGFloat;
-#define CGFLOAT_MIN FLT_MIN
-#define CGFLOAT_MAX FLT_MAX
-#define CGFLOAT_IS_DOUBLE 0
-#define CGFLOAT_DEFINED 1
-#endif
-
-typedef struct QuartzSpecific_s {
- double ps;
- double scalex, scaley; /* resolution correction: px/pt ratio */
- double width,height; /* size (in inches) */
- double tscale; /* text scale (resolution independent,
- i.e. it constitutes a text zoom factor */
- int dirty; /* dirtly flag. Not acted upon by the Quartz
- core, but QC sets it whenever a drawing
- operation is performed (see detailed
- description in R_ext/QuartzDevice.h) */
- int gstate; /* gstate counter */
- int async; /* asynchronous drawing (i.e. context was
- not ready for an operation) */
- int bg; /* background color */
- int canvas; /* background color */
- int antialias,smooth;/* smoothing flags (only aa makes any sense) */
- int flags; /* additional QDFLAGs */
- int holdlevel; /* hold level */
- int redraw; /* redraw flag is set when replaying
- and inhibits syncs on Mode */
- CGRect clipRect; /* clipping rectangle */
- pDevDesc dev; /* device structure holding this one */
- CGFontRef font; /* currently used font */
-
- void* userInfo; /* pointer to a module-dependent space */
-
- /* callbacks - except for getCGContext all others are optional */
- CGContextRef (*getCGContext)(QuartzDesc_t dev, void *userInfo);
- int (*locatePoint)(QuartzDesc_t dev, void *userInfo, double *x, double *y);
- void (*close)(QuartzDesc_t dev, void *userInfo);
- void (*newPage)(QuartzDesc_t dev, void *userInfo, int flags);
- void (*state)(QuartzDesc_t dev, void *userInfo, int state);
- void* (*par)(QuartzDesc_t dev, void *userInfo, int set, const char *key, void *value);
- void (*sync)(QuartzDesc_t dev, void *userInfo);
- void* (*cap)(QuartzDesc_t dev, void*userInfo);
-} QuartzDesc;
-
-/* coordinates:
- - R graphics (positions etc., usually points)
- - real size (e.g. inches)
- - display view (usually pixels)
-
- bookkeeping:
- - QuartzDevice.width/height: inches
- - R GE size (.._Size): points
- - physical (on-screen) coordinates : pixels
-
-the current implementation uses points as plotting units (i.e. this is what
-Quartz tells R), but the canvas is specified in pixels. The scalex/y factors
-specify the conversion factor between pixels and points.
-We are *not* using R's scaling facilities, because R doesn't work with
-non-square pixels (e.g. circles become ellipses).
-
-FIXME: yes it does -- ipr is a two-element array.
- -- not entirely, because it uses text (e.g. "o") as symbols which is rendered
- in 1:1 aspect ratio and thus is squished on displays with non-square pixels
-(That being a bug in Quartz, then!)
-
-Actually, dp not points are used.
-*/
-
-#pragma mark QuartzDevice API (for modules)
-
-/* Update should be called when ps or tscale change.
- Conservatively, it should be called on scale change, too, in case
- we decide to abandon the CTM approach */
-static void QuartzDevice_Update(QuartzDesc_t desc);
-
-/* this function must be called after a new context is created.
- it primes the context for drawing */
-void QuartzDevice_ResetContext(QuartzDesc_t desc) {
- QuartzDesc *qd = ((QuartzDesc*) desc);
- qd->gstate = 0;
- qd->dirty = 0;
- if (qd->getCGContext) {
- CGContextRef ctx = qd->getCGContext(qd, qd->userInfo);
- if (ctx) {
- CGContextSetAllowsAntialiasing(ctx, qd->antialias);
- CGContextSetShouldSmoothFonts(ctx, qd->smooth);
- CGContextScaleCTM(ctx, qd->scalex, qd->scaley);
- CGContextSaveGState(ctx);
- qd->gstate = 1;
- }
- }
-}
-
-/* Uses (e.g. in window title) seems to assume this is 1-based */
-int QuartzDevice_DevNumber(QuartzDesc_t desc) {
- return 1 + ndevNumber((((QuartzDesc*) desc)->dev));
-}
-
-double QuartzDevice_GetWidth(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->width; }
-double QuartzDevice_GetHeight(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->height; }
-void QuartzDevice_SetSize(QuartzDesc_t desc, double width, double height)
-{
- QuartzDesc *qd = ((QuartzDesc*) desc);
- qd->width = width;
- qd->height = height;
- qd->dev->right = width*72.0;
- qd->dev->bottom = height*72.0;
-}
-
-double QuartzDevice_GetScaledWidth(QuartzDesc_t desc) { QuartzDesc *qd=((QuartzDesc*) desc); return qd->scalex*qd->width*72.0; }
-double QuartzDevice_GetScaledHeight(QuartzDesc_t desc) { QuartzDesc *qd=((QuartzDesc*) desc); return qd->scaley*qd->height*72.0; }
-void QuartzDevice_SetScaledSize(QuartzDesc_t desc, double width, double height) {
- QuartzDesc *qd=((QuartzDesc*) desc);
- QuartzDevice_SetSize(desc, width/qd->scalex/72.0, height/qd->scaley/72.0);
-}
-
-double QuartzDevice_GetXScale(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->scalex; }
-double QuartzDevice_GetYScale(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->scaley; }
-void QuartzDevice_SetScale(QuartzDesc_t desc, double scalex, double scaley) {
- ((QuartzDesc*) desc)->scalex = scalex;
- ((QuartzDesc*) desc)->scaley = scaley;
- QuartzDevice_Update(desc);
-}
-
-double QuartzDevice_GetTextScale(QuartzDesc_t desc) {
- return ((QuartzDesc*) desc)->tscale;
-}
-
-void QuartzDevice_SetTextScale(QuartzDesc_t desc, double scale) {
- ((QuartzDesc*) desc)->tscale = scale;
- QuartzDevice_Update(desc);
-}
-
-double QuartzDevice_GetPointSize(QuartzDesc_t desc) {
- return ((QuartzDesc*) desc)->ps;
-}
-
-void QuartzDevice_SetPointSize(QuartzDesc_t desc, double ps) {
- ((QuartzDesc*) desc)->ps = ps;
- QuartzDevice_Update(desc);
-}
-
-int QuartzDevice_GetDirty(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->dirty; }
-void QuartzDevice_SetDirty(QuartzDesc_t desc,int dirty) { ((QuartzDesc*) desc)->dirty = dirty; }
-
-int QuartzDevice_GetAntialias(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->antialias; }
-void QuartzDevice_SetAntialias(QuartzDesc_t desc,int aa) {
- QuartzDesc *qd = (QuartzDesc*) desc;
- qd->antialias = aa;
- if(NULL != qd->getCGContext)
- CGContextSetAllowsAntialiasing( qd->getCGContext(qd, qd->userInfo), aa );
-}
-
-void QuartzDevice_Kill(QuartzDesc_t desc) {
- pGEDevDesc dd = GEgetDevice(ndevNumber(((QuartzDesc*) desc)->dev));
- if (dd) GEkillDevice(dd);
-}
-
-int QuartzDesc_GetFontSmooth(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->smooth; }
-void QuartzDesc_SetFontSmooth(QuartzDesc_t desc, int fs) {
- QuartzDesc *qd = (QuartzDesc*) desc;
- qd->smooth = fs;
- if(qd->getCGContext)
- CGContextSetShouldSmoothFonts( qd->getCGContext(qd, qd->userInfo), fs);
-}
-
-int QuartzDevice_GetBackground(QuartzDesc_t desc) { return ((QuartzDesc*) desc)->bg; }
-
-static void QuartzDevice_Update(QuartzDesc_t desc)
-{
- QuartzDesc *qd = (QuartzDesc*) desc;
- pDevDesc dev= qd->dev;
-
- /* pre-scaling happens in Quartz (using CTM), so scales should not be
- reflected in R measurements. We tell R to use 72dpi which corresponds
- to plotting in pt coordinates */
- dev->cra[0] = 0.9*qd->ps*qd->tscale;
- dev->cra[1] = 1.2*qd->ps*qd->tscale;
- dev->ipr[0] = 1.0/72.0;
- dev->ipr[1] = 1.0/72.0;
-}
-
-void QuartzDevice_Activate(QuartzDesc_t desc)
-{
- QuartzDesc *qd = (QuartzDesc*) desc;
- if (qd) {
- int n = ndevNumber(qd->dev);
- selectDevice(n);
- }
-}
-
-void QuartzDevice_ReplayDisplayList(QuartzDesc_t desc)
-{
- QuartzDesc *qd = (QuartzDesc*) desc;
- int _dirty = qd->dirty;
- pGEDevDesc gdd = desc2GEDesc(qd->dev);
- qd->redraw = 1;
- /* CHECK this */
- if(gdd->displayList != R_NilValue) GEplayDisplayList(gdd);
- qd->redraw = 0;
- qd->dirty = _dirty; /* we do NOT change the dirty flag */
-}
-
-void* QuartzDevice_GetSnapshot(QuartzDesc_t desc, int last)
-{
- QuartzDesc *qd = (QuartzDesc*) desc;
- pGEDevDesc gd = GEgetDevice(ndevNumber(qd->dev));
- SEXP snap;
- if (last)
- snap = desc2GEDesc(qd->dev)->savedSnapshot;
- else
- snap = GEcreateSnapshot(gd);
- if (R_NilValue == VECTOR_ELT(snap, 0))
- snap = 0;
- return (snap == R_NilValue) ? 0 : snap;
-}
-
-void QuartzDevice_RestoreSnapshot(QuartzDesc_t desc, void* snap)
-{
- QuartzDesc *qd = (QuartzDesc*) desc;
- pGEDevDesc gd = GEgetDevice(ndevNumber(qd->dev));
- if(NULL == snap) return; /*Aw, hell no!*/
- PROTECT((SEXP)snap);
- if(R_NilValue == VECTOR_ELT(snap,0))
- warning("Tried to restore an empty snapshot?");
- qd->redraw = 1;
- GEplaySnapshot((SEXP)snap, gd);
- qd->redraw = 0;
- qd->dirty = 0; /* we reset the dirty flag */
- UNPROTECT(1);
-}
-
-static int quartz_embedding = 0;
-
-static void* QuartzDevice_SetParameter(QuartzDesc_t desc, const char *key, void *value)
-{
- if (desc) { /* backend-specific? pass it on */
- QuartzDesc *qd = (QuartzDesc*) desc;
- return (qd->par) ? qd->par(qd, qd->userInfo, 1, key, value) : NULL;
- } else { /* global? try to handle it */
- if (key) {
- if (!streql(key, QuartzParam_EmbeddingFlags)) {
- if (value) quartz_embedding = ((int*)value)[0];
- return &quartz_embedding;
- }
- }
- }
- return NULL;
-}
-
-void setup_RdotApp(void)
-{
- int eflags = QP_Flags_CFLoop | QP_Flags_Cocoa | QP_Flags_Front;
- QuartzDevice_SetParameter(NULL, QuartzParam_EmbeddingFlags, &eflags);
-}
-
-static void* QuartzDevice_GetParameter(QuartzDesc_t desc, const char *key)
-{
- if (desc) { /* backend-specific? pass it on */
- QuartzDesc *qd = (QuartzDesc*) desc;
- return (qd->par) ? qd->par(qd, qd->userInfo, 0, key, NULL) : NULL;
- } else { /* global? try to handle it */
- if (key) {
- if (!streql(key, QuartzParam_EmbeddingFlags)) return &quartz_embedding;
- }
- }
- return NULL;
-}
-
-#pragma mark RGD API Function Prototypes
-
-static void RQuartz_Close(pDevDesc);
-static void RQuartz_Activate(pDevDesc);
-static void RQuartz_Deactivate(pDevDesc);
-static void RQuartz_Size(double*, double*, double*, double*, pDevDesc);
-static void RQuartz_NewPage(const pGEcontext, pDevDesc);
-static int RQuartz_HoldFlush(pDevDesc, int);
-static void RQuartz_Clip(double, double, double, double, pDevDesc);
-static double RQuartz_StrWidth(const char*, const pGEcontext, pDevDesc);
-static void RQuartz_Text(double, double, const char*, double, double, const pGEcontext, pDevDesc);
-static void RQuartz_Rect(double, double, double, double, const pGEcontext, pDevDesc);
-static void RQuartz_Raster(unsigned int *raster, int w, int h,
- double x, double y, double width, double height,
- double rot, Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd);
-static SEXP RQuartz_Cap(pDevDesc dd);
-static void RQuartz_Circle(double, double, double, const pGEcontext, pDevDesc);
-static void RQuartz_Line(double, double, double, double, const pGEcontext, pDevDesc);
-static void RQuartz_Polyline(int, double*, double*, const pGEcontext, pDevDesc);
-static void RQuartz_Polygon(int, double*, double*, const pGEcontext, pDevDesc);
-static void RQuartz_Path(double*, double*, int, int*, Rboolean, const pGEcontext, pDevDesc);
-static Rboolean RQuartz_Locator(double*, double*, pDevDesc);
-static void RQuartz_Mode(int mode, pDevDesc);
-static void RQuartz_MetricInfo(int, const pGEcontext , double*, double*, double*, pDevDesc);
-
-#pragma mark Quartz device implementation
-
-void* QuartzDevice_Create(void *_dev, QuartzBackend_t *def)
-{
- pDevDesc dev = _dev;
-
- dev->startfill = def->bg;
- dev->startcol = R_RGB(0, 0, 0);
- dev->startps = def->pointsize;
- dev->startfont = 1;
- dev->startlty = LTY_SOLID;
- dev->startgamma= 1;
-
- /* Set up some happy pointers */
- dev->close = RQuartz_Close;
- dev->activate = RQuartz_Activate;
- dev->deactivate = RQuartz_Deactivate;
- dev->size = RQuartz_Size;
- dev->newPage = RQuartz_NewPage;
- dev->clip = RQuartz_Clip;
- dev->strWidth = RQuartz_StrWidth;
- dev->text = RQuartz_Text;
- dev->rect = RQuartz_Rect;
- dev->raster = RQuartz_Raster;
- dev->cap = RQuartz_Cap;
- dev->circle = RQuartz_Circle;
- dev->line = RQuartz_Line;
- dev->polyline = RQuartz_Polyline;
- dev->polygon = RQuartz_Polygon;
- dev->path = RQuartz_Path;
- dev->locator = RQuartz_Locator;
- dev->mode = RQuartz_Mode;
- dev->metricInfo = RQuartz_MetricInfo;
- dev->holdflush = RQuartz_HoldFlush;
- dev->hasTextUTF8 = TRUE;
- dev->textUTF8 = RQuartz_Text;
- dev->strWidthUTF8 = RQuartz_StrWidth;
-
- dev->left = 0;
- dev->top = 0;
-
-
- /* Magic numbers from on high. */
- dev->xCharOffset = 0.4900;
- dev->yCharOffset = 0.3333;
- dev->yLineBias = 0.20; /* This is .2 for PS/PDF devices... */
-
- dev->canClip = TRUE;
- dev->canHAdj = 2;
- dev->canChangeGamma= FALSE;
- dev->displayListOn = (def->flags & QDFLAG_DISPLAY_LIST) ? TRUE : FALSE;
-
- dev->haveTransparency = 2;
- dev->haveTransparentBg = 3; /* FIXME: depends on underlying device */
- dev->haveRaster = 2;
- dev->haveCapture = (def->cap) ? 2 : 1;
- dev->haveLocator = (def->locatePoint) ? 2 : 1;
-
- QuartzDesc *qd = calloc(1, sizeof(QuartzDesc));
- qd->width = def->width;
- qd->height = def->height;
- qd->userInfo = def->userInfo;
- qd->getCGContext=def->getCGContext;
- qd->locatePoint= def->locatePoint;
- qd->close = def->close;
- qd->newPage = def->newPage;
- qd->state = def->state;
- qd->sync = def->sync;
- qd->cap = def->cap;
- qd->scalex = def->scalex;
- qd->scaley = def->scaley;
- qd->tscale = 1.0;
- qd->ps = def->pointsize;
- qd->bg = def->bg;
- qd->canvas = def->canvas;
- qd->antialias = (def->flags & QPFLAG_ANTIALIAS) ? 1 : 0;
- qd->flags = def->flags;
- qd->gstate = 0;
- qd->font = NULL;
-
- dev->deviceSpecific = qd;
- qd->dev = dev;
-
- QuartzDevice_Update(qd);
-
- /* Re-set for bitmap devices later */
- dev->right = def->width*72.0;
- dev->bottom= def->height*72.0;
-
- qd->clipRect = CGRectMake(0, 0, dev->right, dev->bottom);
-
- qd->dirty = 0;
- qd->redraw= 0;
- qd->async = 0;
- qd->holdlevel = 0;
- return (QuartzDesc_t)qd;
-}
-
-static QuartzFunctions_t qfn = {
- QuartzDevice_Create,
- QuartzDevice_DevNumber,
- QuartzDevice_Kill,
- QuartzDevice_ResetContext,
- QuartzDevice_GetWidth,
- QuartzDevice_GetHeight,
- QuartzDevice_SetSize,
- QuartzDevice_GetScaledWidth,
- QuartzDevice_GetScaledHeight,
- QuartzDevice_SetScaledSize,
- QuartzDevice_GetXScale,
- QuartzDevice_GetYScale,
- QuartzDevice_SetScale,
- QuartzDevice_SetTextScale,
- QuartzDevice_GetTextScale,
- QuartzDevice_SetPointSize,
- QuartzDevice_GetPointSize,
- QuartzDevice_GetDirty,
- QuartzDevice_SetDirty,
- QuartzDevice_ReplayDisplayList,
- QuartzDevice_GetSnapshot,
- QuartzDevice_RestoreSnapshot,
- QuartzDevice_GetAntialias,
- QuartzDevice_SetAntialias,
- QuartzDevice_GetBackground,
- QuartzDevice_Activate,
- QuartzDevice_SetParameter,
- QuartzDevice_GetParameter
-};
-
-/* currrently unused: was used by R.app via aqua.c */
-QuartzFunctions_t *getQuartzAPI() {
- return &qfn;
-}
-
-/* old OS X versions has different names for some of the CGFont stuff */
-#if MAC_OS_X_VERSION_MAX_ALLOWED <= MAC_OS_X_VERSION_10_4
-#define CGFontCreateWithFontName CGFontCreateWithName
-#define CGFontGetGlyphBBoxes CGFontGetGlyphBoundingBoxes
-/* The following is a real pain. We have to work around bugs in CoreGraphics
- and Apple's dyloader simultaneously so a 10.4 binary runs on 10.5 as well. */
-typedef void (*RQFontGetGlyphsForUnichars_t)(CGFontRef a, const UniChar b[], CGGlyph c[], size_t d);
-static RQFontGetGlyphsForUnichars_t RQFontGetGlyphsForUnichars;
-#include <dlfcn.h> /* dynamically find the right entry point on initialization */
-__attribute__((constructor)) static void RQ_init() {
- void *r;
- if ((r = dlsym(RTLD_NEXT, "CGFontGetGlyphsForUnichars")) || (r = dlsym(RTLD_NEXT, "CGFontGetGlyphsForUnicodes")) ||
- (r = dlsym(RTLD_DEFAULT, "CGFontGetGlyphsForUnichars")) || (r = dlsym(RTLD_DEFAULT, "CGFontGetGlyphsForUnicodes")))
- RQFontGetGlyphsForUnichars = (RQFontGetGlyphsForUnichars_t) r;
- else
- error("Cannot load CoreGraphics"); /* this should never be reached but I suppose it's better than a hidden segfault */
-}
-#define CGFontGetGlyphsForUnichars RQFontGetGlyphsForUnichars
-/* and some missing declarations */
-extern CGFontRef CGFontCreateWithName(CFStringRef);
-extern bool CGFontGetGlyphAdvances(CGFontRef font, const CGGlyph glyphs[], size_t count, int advances[]);
-extern int CGFontGetUnitsPerEm(CGFontRef font);
-extern bool CGFontGetGlyphBBoxes(CGFontRef font, const CGGlyph glyphs[], size_t count, CGRect bboxes[]);
-#else
-extern void CGFontGetGlyphsForUnichars(CGFontRef, const UniChar[], CGGlyph[], size_t);
-#endif
-
-extern CGFontRef CGContextGetFont(CGContextRef);
-
-#define DEVDESC pDevDesc dd
-#define CTXDESC const pGEcontext gc, pDevDesc dd
-
-#define DEVSPEC QuartzDesc *xd = (QuartzDesc*) dd->deviceSpecific; CGContextRef ctx = xd->getCGContext(xd, xd->userInfo)
-#define DRAWSPEC QuartzDesc *xd = (QuartzDesc*) dd->deviceSpecific; CGContextRef ctx = xd->getCGContext(xd, xd->userInfo); xd->dirty = 1
-#define XD QuartzDesc *xd = (QuartzDesc*) dd->deviceSpecific
-
-#pragma mark Quartz Font Cache
-
-/* Font lookup is expesive yet frequent. Therefore we cache all used ATS fonts (which are global to the app). */
-
-typedef struct font_cache_entry_s {
- ATSFontRef font;
- char *family;
- int face;
-} font_cache_entry_t;
-
-#define max_fonts_per_block 32
-
-typedef struct font_cache_s {
- font_cache_entry_t e[max_fonts_per_block];
- int fonts;
- struct font_cache_s *next;
-} font_cache_t;
-
-font_cache_t font_cache, *font_cache_tail = &font_cache;
-
-static ATSFontRef RQuartz_CacheGetFont(const char *family, int face) {
- font_cache_t *fc = &font_cache;
- while (fc) {
- int i = 0, j = fc->fonts;
- while (i < j) {
- if (face == fc->e[i].face && streql(family, fc->e[i].family))
- return fc->e[i].font;
- i++;
- }
- fc = fc->next;
- }
- return 0;
-}
-
-static void RQuartz_CacheAddFont(const char *family, int face, ATSFontRef font) {
- if (font_cache_tail->fonts >= max_fonts_per_block)
- font_cache_tail = font_cache_tail->next = (font_cache_t*) calloc(1, sizeof(font_cache_t));
- {
- int i = font_cache_tail->fonts;
- font_cache_tail->e[i].font = font;
- font_cache_tail->e[i].family = strdup(family);
- font_cache_tail->e[i].face = face;
- font_cache_tail->fonts++;
- }
-}
-
-#ifdef UNUSED
-static void RQuartz_CacheRelease() {
- font_cache_t *fc = &font_cache;
- while (fc) {
- font_cache_t *next = fc->next;
- int i = 0, j = fc->fonts;
- while (i < j) free(fc->e[i++].family);
- if (fc != &font_cache) free(fc);
- fc = next;
- }
- font_cache.fonts = 0;
-}
-#endif
-
-#pragma mark Device Implementation
-
-/* mapping of virtual family names (e.g "serif") and face to real font names using .Quartzenv$.Quartz.Fonts list */
-const char *RQuartz_LookUpFontName(int fontface, const char *fontfamily)
-{
- const char *mappedFont = 0;
- SEXP ns, env, db, names;
- PROTECT_INDEX index;
- PROTECT(ns = R_FindNamespace(ScalarString(mkChar("grDevices"))));
- PROTECT_WITH_INDEX(env = findVar(install(".Quartzenv"), ns), &index);
- if(TYPEOF(env) == PROMSXP)
- REPROTECT(env = eval(env,ns) ,index);
- PROTECT(db = findVar(install(".Quartz.Fonts"), env));
- PROTECT(names = getAttrib(db, R_NamesSymbol));
- if (*fontfamily) {
- int i;
- for(i = 0; i < length(names); i++)
- if(streql(fontfamily, CHAR(STRING_ELT(names, i)))) {
- mappedFont = CHAR(STRING_ELT(VECTOR_ELT(db, i), fontface - 1));
- break;
- }
- }
- UNPROTECT(4);
- return mappedFont;
-}
-
-/* get a font according to the current graphics context */
-CGFontRef RQuartz_Font(CTXDESC)
-{
- const char *fontName = NULL, *fontFamily = gc->fontfamily;
- ATSFontRef atsFont = 0;
- int fontFace = gc->fontface;
- if (fontFace < 1 || fontFace > 5) fontFace = 1; /* just being paranoid */
- if (fontFace == 5)
- fontName = "Symbol";
- else
- fontName = RQuartz_LookUpFontName(fontFace, fontFamily[0] ? fontFamily : "default");
- if (fontName) {
- atsFont = RQuartz_CacheGetFont(fontName, 0); /* face is 0 because we are passing a true font name */
- if (!atsFont) { /* not in the cache, get it */
- CFStringRef cfFontName = CFStringCreateWithCString(NULL, fontName, kCFStringEncodingUTF8);
- atsFont = ATSFontFindFromName(cfFontName, kATSOptionFlagsDefault);
- if (!atsFont)
- atsFont = ATSFontFindFromPostScriptName(cfFontName, kATSOptionFlagsDefault);
- CFRelease(cfFontName);
- if (!atsFont) {
- warning(_("font \"%s\" could not be found for family \"%s\""), fontName, fontFamily);
- return NULL;
- }
- RQuartz_CacheAddFont(fontName, 0, atsFont);
- }
- } else { /* the real font name could not be looked up. We must use cache and/or find the right font by family and face */
- if (!fontFamily[0]) fontFamily = "Arial";
- /* Arial is the default, because Helvetica doesn't have Oblique
- on 10.4 - maybe change later? */
- atsFont = RQuartz_CacheGetFont(fontFamily, fontFace);
- if (!atsFont) { /* not in the cache? Then we need to find the
- proper font name from the family name and face */
- /* as it turns out kATSFontFilterSelectorFontFamily is not
- implemented in OS X (!!) so there is no way to query for a
- font from a specific family. Therefore we have to use
- text-matching heuristics ... very nasty ... */
- char compositeFontName[256];
- /* CFStringRef cfFontName; */
- if (strlen(fontFamily) > 210) error(_("font family name is too long"));
- while (!atsFont) { /* try different faces until exhausted or successful */
- strcpy(compositeFontName, fontFamily);
- if (fontFace == 2 || fontFace == 4) strcat(compositeFontName, " Bold");
- if (fontFace == 3 || fontFace == 4) strcat(compositeFontName, " Italic");
- CFStringRef cfFontName = CFStringCreateWithCString(NULL, compositeFontName, kCFStringEncodingUTF8);
- atsFont = ATSFontFindFromName(cfFontName, kATSOptionFlagsDefault);
- if (!atsFont) atsFont = ATSFontFindFromPostScriptName(cfFontName, kATSOptionFlagsDefault);
- CFRelease(cfFontName);
- if (!atsFont) {
- if (fontFace == 1) { /* more guessing - fontFace == 1 may need Regular or Roman */
- strcat(compositeFontName," Regular");
- cfFontName = CFStringCreateWithCString(NULL, compositeFontName, kCFStringEncodingUTF8);
- atsFont = ATSFontFindFromName(cfFontName, kATSOptionFlagsDefault);
- CFRelease(cfFontName);
- if (!atsFont) {
- strcpy(compositeFontName, fontFamily);
- strcat(compositeFontName," Roman");
- cfFontName = CFStringCreateWithCString(NULL, compositeFontName, kCFStringEncodingUTF8);
- atsFont = ATSFontFindFromName(cfFontName, kATSOptionFlagsDefault);
- CFRelease(cfFontName);
- }
- } else if (fontFace == 3 || fontFace == 4) { /* Oblique is sometimes used instead of Italic (e.g. in Helvetica) */
- strcpy(compositeFontName, fontFamily);
- if (fontFace == 4) strcat(compositeFontName, " Bold");
- strcat(compositeFontName," Oblique");
- cfFontName = CFStringCreateWithCString(NULL, compositeFontName, kCFStringEncodingUTF8);
- atsFont = ATSFontFindFromName(cfFontName, kATSOptionFlagsDefault);
- CFRelease(cfFontName);
- }
- }
- if (!atsFont) { /* try to fall back to a more plain face */
- if (fontFace == 4) fontFace = 2;
- else if (fontFace != 1) fontFace = 1;
- else break;
- atsFont = RQuartz_CacheGetFont(fontFamily, fontFace);
- if (atsFont) break;
- }
- }
- if (!atsFont)
- warning(_("no font could be found for family \"%s\""), fontFamily);
- else
- RQuartz_CacheAddFont(fontFamily, fontFace, atsFont);
- }
- }
-
- return CGFontCreateWithPlatformFont(&atsFont);
-}
-
-#define RQUARTZ_FILL (1)
-#define RQUARTZ_STROKE (1<<1)
-#define RQUARTZ_LINE (1<<2)
-
-static void RQuartz_SetFont(CGContextRef ctx, const pGEcontext gc, QuartzDesc *xd) {
- CGFontRef font = RQuartz_Font(gc, NULL);
- if (font) {
- CGContextSetFont(ctx, font);
- if (font != xd->font) {
- if (xd->font) CGFontRelease(xd->font);
- xd->font = font;
- }
- }
- CGContextSetFontSize(ctx, gc->cex * gc->ps);
-}
-
-/* pre-10.5 doesn't have kCGColorSpaceGenericRGB so fall back to kCGColorSpaceGenericRGB */
-#if MAC_OS_X_VERSION_10_4 >= MAC_OS_X_VERSION_MAX_ALLOWED
-#define kCGColorSpaceSRGB kCGColorSpaceGenericRGB
-#endif
-
-void RQuartz_Set(CGContextRef ctx,const pGEcontext gc,int flags) {
- CGColorSpaceRef cs = CGColorSpaceCreateWithName(kCGColorSpaceSRGB);
- if(flags & RQUARTZ_FILL) {
- int fill = gc->fill;
- CGFloat fillColor[] = { R_RED(fill)/255.0,
- R_GREEN(fill)/255.0,
- R_BLUE(fill)/255.0,
- R_ALPHA(fill)/255.0 };
- CGColorRef fillColorRef = CGColorCreate(cs, fillColor);
- CGContextSetFillColorWithColor(ctx, fillColorRef);
- CGColorRelease(fillColorRef);
- }
- if(flags & RQUARTZ_STROKE) {
- int stroke = gc->col;
- CGFloat strokeColor[] = { R_RED(stroke)/255.0,
- R_GREEN(stroke)/255.0,
- R_BLUE(stroke)/255.0,
- R_ALPHA(stroke)/255.0 };
- CGColorRef strokeColorRef = CGColorCreate(cs, strokeColor);
- CGContextSetStrokeColorWithColor(ctx, strokeColorRef);
- CGColorRelease(strokeColorRef);
- }
- if(flags & RQUARTZ_LINE) {
- CGFloat dashlist[8];
- int i, ndash = 0;
- int lty = gc->lty;
- float lwd = (float)(gc->lwd * 0.75);
- CGContextSetLineWidth(ctx, lwd);
-
- for(i = 0; i < 8 && lty; i++) {
- dashlist[ndash++] = (lwd >= 1 ? lwd : 1) * (lty & 15);
- lty >>= 4;
- }
- CGContextSetLineDash(ctx, 0, dashlist, ndash);
- CGLineCap cap = kCGLineCapButt;
- switch(gc->lend) {
- case GE_ROUND_CAP: cap = kCGLineCapRound; break;
- case GE_BUTT_CAP: cap = kCGLineCapButt; break;
- case GE_SQUARE_CAP: cap = kCGLineCapSquare; break;
- }
- CGContextSetLineCap(ctx,cap);
- CGLineJoin join = kCGLineJoinRound;
- switch(gc->ljoin) {
- case GE_ROUND_JOIN: join = kCGLineJoinRound; break;
- case GE_MITRE_JOIN: join = kCGLineJoinMiter; break;
- case GE_BEVEL_JOIN: join = kCGLineJoinBevel; break;
- }
- CGContextSetLineJoin(ctx, join);
- CGContextSetMiterLimit(ctx, gc->lmitre);
- }
- CGColorSpaceRelease(cs);
-}
-
-#define SET(X) RQuartz_Set(ctx, gc, (X))
-#define NOCTX { xd->async = 1; return; }
-#define NOCTXR(V) { xd->async = 1; return(V); }
-
-
-static void RQuartz_Close(DEVDESC)
-{
- XD;
- if (xd->close) xd->close(xd, xd->userInfo);
-}
-
-static void RQuartz_Activate(DEVDESC)
-{
- XD;
- if (xd->state) xd->state(xd, xd->userInfo, 1);
-}
-
-static void RQuartz_Deactivate(DEVDESC)
-{
- XD;
- if (xd->state) xd->state(xd, xd->userInfo, 0);
-}
-
-static void RQuartz_Size(double *left, double *right, double *bottom, double *top, DEVDESC)
-{
- XD;
- *left = *top = 0;
- *right = QuartzDevice_GetWidth(xd) * 72.0;
- *bottom = QuartzDevice_GetHeight(xd) * 72.0;
-}
-
-static void RQuartz_NewPage(CTXDESC)
-{
- {
- DRAWSPEC;
- ctx = NULL;
- if (xd->newPage) xd->newPage(xd, xd->userInfo, xd->redraw ? QNPF_REDRAW : 0);
- }
- { /* we have to re-fetch the status *after* newPage since it may have changed it */
- DRAWSPEC;
- if (!ctx) NOCTX;
- {
- CGRect bounds = CGRectMake(0, 0,
- QuartzDevice_GetScaledWidth(xd) * 72.0,
- QuartzDevice_GetScaledHeight(xd) * 72.0);
- /* reset the clipping region by restoring the base GC.
- If there is no GC on the stack then the clipping region was never set. */
- if (xd->gstate > 0) {
- CGContextRestoreGState(ctx);
- CGContextSaveGState(ctx);
- /* no need to modify gstate since we don't modify the stack */
- }
- /* The logic is to paint the canvas then gc->fill.
- (The canvas colour is set to 0 on non-screen devices.)
- */
- if (R_ALPHA(xd->canvas) > 0 && !R_OPAQUE(gc->fill)) {
- /* Paint the canvas colour. */
- int savefill = gc->fill;
- CGContextClearRect(ctx, bounds);
- gc->fill = xd->canvas;
- SET(RQUARTZ_FILL);
- CGContextFillRect(ctx, bounds);
- gc->fill = savefill;
- }
- SET(RQUARTZ_FILL); /* this will fill with gc->fill */
- CGContextFillRect(ctx, bounds);
- }
- }
-}
-
-static int RQuartz_HoldFlush(DEVDESC, int level)
-{
- int ol;
- XD;
- /* FIXME: should we check for interactive? */
- ol = xd->holdlevel;
- xd->holdlevel += level;
- if (xd->holdlevel < 0) xd->holdlevel = 0;
- if (xd->holdlevel == 0) { /* flush */
- /* trigger flush */
- if (xd->sync)
- xd->sync(xd, xd->userInfo);
- else {
- CGContextRef ctx = xd->getCGContext(xd, xd->userInfo);
- if (ctx)
- CGContextSynchronize(ctx);
- }
- } else if (ol == 0) { /* first hold */
- /* could display a wait cursor or something ... */
- }
- return xd->holdlevel;
-}
-
-static void RQuartz_Clip(double x0, double x1, double y0, double y1, DEVDESC)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- if(xd->gstate > 0) {
- --xd->gstate;
- CGContextRestoreGState(ctx);
- }
- CGContextSaveGState(ctx);
- xd->gstate++;
- if(x1 > x0) { double t = x1; x1 = x0;x0 = t; }
- if(y1 > y0) { double t = y1; y1 = y0;y0 = t; }
- xd->clipRect = CGRectMake(x0, y0, x1 - x0, y1 - y0);
- CGContextClipToRect(ctx, xd->clipRect);
-}
-
-/* non-symbol text is sent in UTF-8 */
-static CFStringRef text2unichar(CTXDESC, const char *text, UniChar **buffer, int *free)
-{
- CFStringRef str;
- if(gc->fontface == 5)
- str = CFStringCreateWithCString(NULL, text, kCFStringEncodingMacSymbol);
- else {
- str = CFStringCreateWithCString(NULL, text, kCFStringEncodingUTF8);
- /* Try fallback Latin1 encoding if UTF8 doesn't work
- -- should no longer be needed. */
- if(!str)
- CFStringCreateWithCString(NULL, text, kCFStringEncodingISOLatin1);
- }
- if (!str) return NULL;
- *buffer = (UniChar*) CFStringGetCharactersPtr(str);
- if (*buffer == NULL) {
- CFIndex length = CFStringGetLength(str);
- /* FIXME: check allocation */
- *buffer = malloc(length * sizeof(UniChar));
- CFStringGetCharacters(str, CFRangeMake(0, length), *buffer);
- *free = 1;
- }
- return str;
-}
-
-static double RQuartz_StrWidth(const char *text, CTXDESC)
-{
- DEVSPEC;
- if (!ctx) NOCTXR(strlen(text) * 10.0); /* for sanity reasons */
- RQuartz_SetFont(ctx, gc, xd);
-
- CGFontRef font = CGContextGetFont(ctx);
- float aScale = (float)((gc->cex * gc->ps * xd->tscale) /
- CGFontGetUnitsPerEm(font));
- UniChar *buffer;
- CGGlyph *glyphs;
- int *advances;
- int Free = 0, len;
- CFStringRef str = text2unichar(gc, dd, text, &buffer, &Free);
- if (!str) return 0.0; /* invalid text contents */
- len = (int) CFStringGetLength(str);
- /* FIXME: check allocations */
- glyphs = malloc(sizeof(CGGlyph) * len);
- advances = malloc(sizeof(int) * len);
- CGFontGetGlyphsForUnichars(font, buffer, glyphs, len);
- CGFontGetGlyphAdvances(font, glyphs, len, advances);
- float width = 0.0; /* aScale*CGFontGetLeading(CGContextGetFont(ctx)); */
- for(int i = 0; i < len; i++) width += aScale * advances[i];
- free(advances);
- free(glyphs);
- if(Free) free(buffer);
- CFRelease(str);
- return width;
-}
-
-static void RQuartz_Text(double x, double y, const char *text, double rot, double hadj, CTXDESC)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- /* A stupid hack because R isn't consistent. */
- int fill = gc->fill;
- gc->fill = gc->col;
- SET(RQUARTZ_FILL | RQUARTZ_STROKE);
- RQuartz_SetFont(ctx, gc, xd);
- gc->fill = fill;
- CGFontRef font = CGContextGetFont(ctx);
- float aScale = (float) ((gc->cex * gc->ps * xd->tscale) /
- CGFontGetUnitsPerEm(font));
- UniChar *buffer;
- CGGlyph *glyphs;
-
- int Free = 0, len, i;
- float width = 0.0;
- CFStringRef str = text2unichar(gc, dd, text, &buffer, &Free);
- if (!str) return; /* invalid text contents */
- len = (int) CFStringGetLength(str);
- /* FIXME: check allocations */
- glyphs = malloc(sizeof(CGGlyph) * len);
- CGFontGetGlyphsForUnichars(font, buffer, glyphs, len);
- int *advances = malloc(sizeof(int) * len);
- CGSize *g_adv = malloc(sizeof(CGSize) * len);
-
- CGFontGetGlyphAdvances(font, glyphs, len, advances);
- for(i =0 ; i < len; i++) {
- width += advances[i] * aScale;
- g_adv[i] = CGSizeMake(aScale * advances[i] * cos(-DEG2RAD*rot), aScale*advances[i]*sin(-DEG2RAD * rot));
- }
- free(advances);
- CGContextSetTextMatrix(ctx,
- CGAffineTransformConcat(CGAffineTransformMakeScale(1.0, -1.0),
- CGAffineTransformMakeRotation(-DEG2RAD * rot)));
- double ax = (width * hadj) * cos(-DEG2RAD * rot);
- double ay = (width * hadj) * sin(-DEG2RAD * rot);
- /* double h = CGFontGetXHeight(CGContextGetFont(ctx))*aScale; */
- CGContextSetTextPosition(ctx, x - ax, y - ay);
- /* Rprintf("%s,%.2f %.2f (%.2f,%.2f) (%d,%f)\n",text,hadj,width,ax,ay,CGFontGetUnitsPerEm(CGContextGetFont(ctx)),CGContextGetFontSize(ctx)); */
- CGContextShowGlyphsWithAdvances(ctx,glyphs, g_adv, len);
- free(glyphs);
- free(g_adv);
- if(Free) free(buffer);
- CFRelease(str);
-}
-
-static void RQuartz_Rect(double x0, double y0, double x1, double y1, CTXDESC)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_FILL | RQUARTZ_STROKE | RQUARTZ_LINE);
- if (xd->flags & QDFLAG_RASTERIZED) {
- /* in the case of borderless rectangles snap them to pixels.
- this solves issues with image() without introducing other artifacts.
- other approaches (disabling anti-aliasing, drawing background first,
- snapping rect with borders) don't work as well, because they have
- unwanted visual side-effects. */
- if (R_ALPHA(gc->fill) > 0 && R_ALPHA(gc->col) == 0) {
- /* store original values in case we need to go back */
- double ox0 = x0, ox1 = x1, oy0 = y0, oy1 = y1;
- x0 = (round(x0 * xd->scalex)) / xd->scalex;
- x1 = (round(x1 * xd->scalex)) / xd->scalex;
- y0 = (round(y0 * xd->scaley)) / xd->scaley;
- y1 = (round(y1 * xd->scaley)) / xd->scaley;
- /* work-around for PR#13744 - make sure the width or height
- does not drop to 0 because of aligning. */
- if (x0 == x1 && (ox0 != ox1)) x1 += ox1 - ox0;
- if (y0 == y1 && (oy0 != oy1)) y1 += oy1 - oy0;
- }
- }
- CGContextBeginPath(ctx);
- CGContextAddRect(ctx, CGRectMake(x0, y0, x1 - x0, y1 - y0));
- CGContextDrawPath(ctx, kCGPathFillStroke);
-}
-
-static void RQuartz_Raster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- CGDataProviderRef dp;
- CGColorSpaceRef cs;
- CGImageRef img;
-
- /* Create a "data provider" containing the raster data */
- dp = CGDataProviderCreateWithData(NULL, (void *) raster, 4*w*h, NULL);
-
- cs = CGColorSpaceCreateWithName(kCGColorSpaceSRGB);
-
- /* Create a quartz image from the data provider */
- img = CGImageCreate(w, h,
- 8, /* bits per channel */
- 32, /* bits per pixel */
- 4*w, /* bytes per row */
- cs, /* color space */
- /* R uses AGBR which is so unusual (inverted RGBA) that it corresponds to endinness inverse(!) to the host with alpha last (=RGBA). */
-#ifdef __BIG_ENDIAN__
- kCGImageAlphaLast | kCGBitmapByteOrder32Little,
-#else
- kCGImageAlphaLast | kCGBitmapByteOrder32Big,
-#endif
- dp, /* data provider */
- NULL,/* decode array */
- 1, /* interpolate (interpolation type below) */
- kCGRenderingIntentDefault);
-
- if (height < 0) {
- y = y + height;
- height = -height;
- }
-
- CGContextSaveGState(ctx);
- /* Translate by height of image */
- CGContextTranslateCTM(ctx, 0.0, height);
- /* Flip vertical */
- CGContextScaleCTM(ctx, 1.0, -1.0);
- /* Translate to position */
- CGContextTranslateCTM(ctx, x, -y);
- /* Rotate */
- CGContextRotateCTM(ctx, rot*M_PI/180.0);
- /* Determine interpolation method */
- if (interpolate)
- CGContextSetInterpolationQuality(ctx, kCGInterpolationDefault);
- else
- CGContextSetInterpolationQuality(ctx, kCGInterpolationNone);
- /* Draw the quartz image */
- CGContextDrawImage(ctx, CGRectMake(0, 0, width, height), img);
- CGContextRestoreGState(ctx);
-
- /* Tidy up */
- CGColorSpaceRelease(cs);
- CGDataProviderRelease(dp);
- CGImageRelease(img);
-}
-
-static SEXP RQuartz_Cap(pDevDesc dd)
-{
- SEXP raster = R_NilValue;
- DRAWSPEC;
- if (!ctx) NOCTXR(raster);
-
- if (xd->cap)
- raster = (SEXP) xd->cap(xd, xd->userInfo);
-
- return raster;
-}
-
-static void RQuartz_Circle(double x, double y, double r, CTXDESC)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_FILL | RQUARTZ_STROKE | RQUARTZ_LINE);
- double r2 = 2.0*r;
- CGContextBeginPath(ctx);
- CGContextAddEllipseInRect(ctx,CGRectMake(x-r,y-r,r2,r2));
- CGContextDrawPath(ctx,kCGPathFillStroke);
-}
-
-static void RQuartz_Line(double x1, double y1, double x2, double y2, CTXDESC)
-{
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_STROKE | RQUARTZ_LINE);
- CGContextBeginPath(ctx);
- CGContextMoveToPoint(ctx, x1, y1);
- CGContextAddLineToPoint(ctx, x2, y2);
- CGContextStrokePath(ctx);
-}
-
-#define max_segments 100
-
-static void RQuartz_Polyline(int n, double *x, double *y, CTXDESC)
-{
- if (n < 2) return;
- int i = 0;
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_STROKE | RQUARTZ_LINE);
-
- /* CGContextStrokeLineSegments turned out to be a bad idea due to
- Leopard restarting dashes for each segment.
- CGContextAddLineToPoint is fast enough.
- The only remaining problem is that Quartz seems to restart
- dashes at segment breakup points. We should make the segments
- break-up an optional feature and possibly fix the underlying
- problem (software rendering).
- */
-
- while (i < n) {
- int j = i + max_segments;
- if (j > n) j = n;
- CGContextBeginPath(ctx);
- if (i) i--; /* start at the last point of the preceding chunk */
- CGContextMoveToPoint(ctx, x[i], y[i]);
- while(++i < j)
- CGContextAddLineToPoint(ctx, x[i], y[i]);
- CGContextStrokePath(ctx);
- }
-}
-
-static void RQuartz_Polygon(int n, double *x, double *y, CTXDESC)
-{
- if (n < 2) return;
- int i;
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_FILL | RQUARTZ_STROKE | RQUARTZ_LINE);
- CGContextBeginPath(ctx);
- CGContextMoveToPoint(ctx, x[0], y[0]);
- for(i = 1; i < n; i++)
- CGContextAddLineToPoint(ctx, x[i], y[i]);
- CGContextClosePath(ctx);
- CGContextDrawPath(ctx, kCGPathFillStroke);
-}
-
-static void RQuartz_Path(double *x, double *y,
- int npoly, int* nper,
- Rboolean winding,
- CTXDESC)
-{
- int i, j, index;
- DRAWSPEC;
- if (!ctx) NOCTX;
- SET(RQUARTZ_FILL | RQUARTZ_STROKE | RQUARTZ_LINE);
- index = 0;
- CGContextBeginPath(ctx);
- for (i=0; i < npoly; i++) {
- CGContextMoveToPoint(ctx, x[index], y[index]);
- index++;
- for(j=1; j < nper[i]; j++) {
- CGContextAddLineToPoint(ctx, x[index], y[index]);
- index++;
- }
- CGContextClosePath(ctx);
- }
- if (winding) {
- CGContextDrawPath(ctx, kCGPathFillStroke);
- } else {
- CGContextDrawPath(ctx, kCGPathEOFillStroke);
- }
-}
-
-static void RQuartz_Mode(int mode, DEVDESC)
-{
- DEVSPEC;
- if (!ctx) NOCTX;
- /* don't do anything in redraw as we can signal the end */
- if (xd->redraw) return;
- /* mode=0 -> drawing complete, signal sync */
- if (mode == 0 && xd->holdlevel == 0) {
- if (xd->sync)
- xd->sync(xd, xd->userInfo);
- else
- CGContextSynchronize(ctx);
- }
-}
-
-static void
-RQuartz_MetricInfo(int c, const pGEcontext gc,
- double *ascent, double *descent, double *width,
- pDevDesc dd)
-{
- DRAWSPEC;
- if (!ctx) { /* dummy data if we have no context, for sanity reasons */
- *ascent = 10.0;
- *descent= 2.0;
- *width = 9.0;
- NOCTX;
- }
- RQuartz_SetFont(ctx, gc, xd);
- {
- CGFontRef font = CGContextGetFont(ctx);
- float aScale = (float)((gc->cex * gc->ps * xd->tscale) /
- CGFontGetUnitsPerEm(font));
- UniChar *buffer, single;
- CGGlyph glyphs[8];
- CFStringRef str = NULL;
- int free_buffer = 0, len;
- *width = *ascent = *descent = 0.0; /* data for bail-out cases */
- if (c >= 0 && c <= ((mbcslocale && gc->fontface != 5) ? 127 : 255)) {
- char text[2] = { (char)c, 0 };
- str = text2unichar(gc, dd, text, &buffer, &free_buffer);
- if(!str) return;
- len = (int) CFStringGetLength(str);
- if (len > 7) return; /* this is basically impossible,
- but you never know */
- } else {
- single = (UniChar) ((c < 0) ? -c : c);
- buffer = &single;
- len = 1;
- }
- *width = 0.0;
- CGFontGetGlyphsForUnichars(font, buffer, glyphs, len);
- {
- int i;
- int advances[8];
- CGRect bboxes[8];
- CGFontGetGlyphAdvances(font, glyphs, len, advances);
- CGFontGetGlyphBBoxes(font, glyphs, len, bboxes);
- for(i = 0; i < len; i++)
- *width += advances[i] * aScale;
- *ascent = aScale * (bboxes[0].size.height + bboxes[0].origin.y);
- *descent = -aScale * bboxes[0].origin.y;
- }
- if (free_buffer) free(buffer);
- if (str) CFRelease(str);
- }
-}
-
-static Rboolean RQuartz_Locator(double *x, double *y, DEVDESC)
-{
- Rboolean res;
- DEVSPEC;
- ctx = NULL;
- if (!xd->locatePoint)
- return FALSE;
- res = xd->locatePoint(xd, xd->userInfo, x, y);
- *x/=xd->scalex;
- *y/=xd->scaley;
- return res;
-}
-
-#pragma mark -
-#pragma mark R Interface
-
-#include "qdCocoa.h"
-#include "qdBitmap.h"
-#include "qdPDF.h"
-/* disabled for now until we get to test in on 10.3 #include "qdCarbon.h" */
-
-/* current fake */
-QuartzDesc_t
-QuartzCarbon_DeviceCreate(pDevDesc dd, QuartzFunctions_t *fn, QuartzParameters_t *par)
-{
- return NULL;
-}
-
-#define ARG(HOW,WHAT) HOW(CAR(WHAT));WHAT = CDR(WHAT)
-
-/* C version of the Quartz call (experimental)
- Quartz descriptor on success, NULL on failure.
- If errorCode is not NULL, it will contain the error code on exit */
-QuartzDesc_t
-Quartz_C(QuartzParameters_t *par, quartz_create_fn_t q_create, int *errorCode)
-{
- if (!q_create || !par) {
- if (errorCode) errorCode[0] = -4;
- return NULL;
- }
- {
- const void *vmax = vmaxget();
- QuartzDesc_t qd = NULL;
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- {
- const char *devname = "quartz_off_screen";
- /* FIXME: check this allocation */
- pDevDesc dev = calloc(1, sizeof(DevDesc));
-
- if (!dev) {
- if (errorCode) errorCode[0] = -2;
- return NULL;
- }
- if (!(qd = q_create(dev, &qfn, par))) {
- vmaxset(vmax);
- free(dev);
- if (errorCode) errorCode[0] = -3;
- return NULL;
- }
- if(streql(par->type, "") || streql(par->type, "native")
- || streql(par->type, "cocoa") || streql(par->type, "carbon"))
- devname = "quartz";
- gsetVar(R_DeviceSymbol, mkString(devname), R_BaseEnv);
- pGEDevDesc dd = GEcreateDevDesc(dev);
- GEaddDevice(dd);
- GEinitDisplayList(dd);
- vmaxset(vmax);
- }
- return qd;
- }
-}
-
-/* ARGS: type, file, width, height, ps, family, antialias,
- title, bg, canvas, dpi */
-SEXP Quartz(SEXP args)
-{
- SEXP tmps, bgs, canvass;
- double width, height, ps;
- Rboolean antialias;
- int quartzpos, bg, canvas, module = 0;
- double mydpi[2], *dpi = 0;
- const char *type, *mtype = 0, *family, *title;
- char *file = NULL;
- QuartzDesc_t qd = NULL;
-
- const void *vmax = vmaxget();
- /* Get function arguments */
- args = CDR(args); /* Skip the call */
- if (TYPEOF(CAR(args)) != STRSXP || LENGTH(CAR(args)) < 1)
- type = "";
- else
- type = CHAR(STRING_ELT(CAR(args), 0));
- args = CDR(args);
- /* we may want to support connections at some point, but not yet ... */
- tmps = CAR(args); args = CDR(args);
- if (isNull(tmps))
- file = NULL;
- else if (isString(tmps) && LENGTH(tmps) >= 1) {
- const char *tmp = R_ExpandFileName(CHAR(STRING_ELT(tmps, 0)));
- file = R_alloc(strlen(tmp) + 1, sizeof(char));
- strcpy(file, tmp);
- } else
- error(_("invalid 'file' argument"));
- width = ARG(asReal,args);
- height = ARG(asReal,args);
- ps = ARG(asReal,args);
- family = CHAR(STRING_ELT(CAR(args), 0)); args = CDR(args);
- antialias = ARG(asLogical,args);
- title = CHAR(STRING_ELT(CAR(args), 0)); args = CDR(args);
- bgs = CAR(args); args = CDR(args);
- bg = RGBpar(bgs, 0);
- canvass = CAR(args); args = CDR(args);
- canvas = RGBpar(canvass, 0) | 0xff000000; /* force opaque */
- tmps = CAR(args); args = CDR(args);
- if (!isNull(tmps)) {
- tmps = coerceVector(tmps, REALSXP);
- if (LENGTH(tmps) > 0) {
- dpi = mydpi;
- mydpi[0] = REAL(tmps)[0];
- if (LENGTH(tmps) > 1)
- mydpi[1] = REAL(tmps)[1];
- else
- mydpi[1] = mydpi[0];
- }
- }
- /* just in case someone passed NAs/NaNs */
- if (dpi && (ISNAN(dpi[0]) || ISNAN(dpi[1]))) dpi=0;
-
- if (ISNAN(width) || ISNAN(height) || width <= 0.0 || height <= 0.0)
- error(_("invalid quartz() device size"));
-
- if (type) {
- const quartz_module_t *m = quartz_modules;
- mtype = type;
- while (m->type) {
- if (!strcasecmp(type, m->type)) {
- module = m->qbe;
- if (m->subst) mtype = m->subst;
- break;
- }
- m++;
- }
-
- if (!strncasecmp(type, "bitmap:", 7)) {
- module = QBE_BITMAP;
- mtype = mtype + 7;
- }
- }
-
- quartzpos = 1;
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev = calloc(1, sizeof(DevDesc));
-
- if (!dev)
- error(_("unable to create device description"));
-
- QuartzParameters_t qpar = {
- sizeof(qpar),
- mtype, file, title,
- -1.0, -1.0, width, height, ps,
- family,
- antialias ? QPFLAG_ANTIALIAS: 0,
- -1, /* connection */
- bg, canvas,
- dpi
- };
-
- /* re-routed code has the first shot */
- if (ptr_QuartzBackend)
- qd = ptr_QuartzBackend(dev, &qfn, &qpar);
-
- if (qd == NULL) { /* try internal modules next */
- switch (module) {
- case QBE_COCOA:
- qd = QuartzCocoa_DeviceCreate(dev, &qfn, &qpar);
- break;
- case QBE_NATIVE:
- /* native is essentially cocoa with carbon fall-back */
- qd = QuartzCocoa_DeviceCreate(dev, &qfn, &qpar);
- if (qd) break;
- case QBE_CARBON:
- qd = QuartzCarbon_DeviceCreate(dev, &qfn, &qpar);
- break;
- case QBE_PDF:
- qpar.canvas = 0; /* so not used */
- qd = QuartzPDF_DeviceCreate(dev, &qfn, &qpar);
- break;
- case QBE_BITMAP:
- /* we need to set up the default file name here, where we
- know the original type name. */
- if (file == NULL) {
- static char deffile[30];
- snprintf(deffile, 30, "%s.%s", "Rplot%03d", type);
- qpar.file = deffile;
- }
- qpar.canvas = 0; /* so not used */
- qd = QuartzBitmap_DeviceCreate(dev, &qfn, &qpar);
- break;
- }
- }
-
- if (qd == NULL) {
- vmaxset(vmax);
- free(dev);
- error(_("unable to create quartz() device target, given type may not be supported"));
- }
- const char *devname = "quartz_off_screen";
- if(streql(type, "") || streql(type, "native") || streql(type, "cocoa")
- || streql(type, "carbon")) devname = "quartz";
- gsetVar(R_DeviceSymbol, mkString(devname), R_BaseEnv);
- pGEDevDesc dd = GEcreateDevDesc(dev);
- GEaddDevice(dd);
- GEinitDisplayList(dd);
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
-
-#include <sys/sysctl.h>
-
-static double cached_darwin_version = 0.0;
-
-/* Darwin version X.Y maps to OS X version 10.(X - 4).Y */
-static double darwin_version() {
- char ver[32];
- size_t len = sizeof(ver) - 1;
- int mib[2] = { CTL_KERN, KERN_OSRELEASE };
- if (cached_darwin_version > 0.0)
- return cached_darwin_version;
- sysctl(mib, 2, &ver, &len, 0, 0);
- return (cached_darwin_version = atof(ver));
-}
-
-#include <mach/mach.h>
-#include <servers/bootstrap.h>
-
-/* even as of Darwin 9 there is no entry for bootstrap_info in bootrap headers */
-extern kern_return_t bootstrap_info(mach_port_t , /* bootstrap port */
- name_array_t*, mach_msg_type_number_t*, /* service */
- name_array_t*, mach_msg_type_number_t*, /* server */
- bool_array_t*, mach_msg_type_number_t*); /* active */
-
-/* returns 1 if window server session service
- (com.apple.windowserver.session) is present in the boostrap
- namespace (pre-Lion) or when a current session is present, active
- and there is no SSH_CONNECTION (Lion and later).
- returns 0 if an error occurred or the service is not
- present. For all practical purposes this returns 1 only if run
- interactively via LS. Although ssh to a machine that has a running
- session for the same user will allow a WS connection, this function
- will still return 0 in that case.
- NOTE: on Mac OS X 10.5 we are currently NOT searching the parent
- namespaces. This is currently OK, because the session service will
- be registered in the session namespace which is the last in the
- chain. However, this could change in the future.
- */
-static int has_wss() {
- int res = 0;
-
- if (darwin_version() < 11.0) { /* before Lion we get reliable information from the bootstrap info */
- kern_return_t kr;
- mach_port_t self = mach_task_self();
- mach_port_t bport = MACH_PORT_NULL;
- kr = task_get_bootstrap_port(self, &bport);
- if (kr == KERN_SUCCESS) {
- kern_return_t kr;
- name_array_t serviceNames;
- mach_msg_type_number_t serviceNameCount;
- name_array_t serverNames;
- mach_msg_type_number_t serverNameCount;
- bool_array_t active;
- mach_msg_type_number_t activeCount;
-
- serviceNames = NULL;
- serverNames = NULL;
- active = NULL;
-
- kr = bootstrap_info(bport,
- &serviceNames, &serviceNameCount,
- &serverNames, &serverNameCount,
- &active, &activeCount);
- if (kr == KERN_SUCCESS) {
- unsigned int i = 0;
- while (i < serviceNameCount) {
- if (!strcmp(serviceNames[i], "com.apple.windowserver.session")) {
- res = 1;
- break;
- }
- i++;
- }
- }
- }
- if (bport != MACH_PORT_NULL)
- mach_port_deallocate(mach_task_self(), bport);
- } else {
- /* On Mac OS X 10.7 (Lion) and higher two things changed:
- a) there is no com.apple.windowserver.session anymore
- so the above will fail
- b) every process has now the full bootstrap info,
- so in fact even remote connections will be able to
- run on-screen tasks if the user is logged in
- So we need to add some heuristics to decide when the user
- actually wants Quartz ... */
- /* check user's session */
- CFDictionaryRef dict = CGSessionCopyCurrentDictionary();
- if (dict) { /* allright, let's see if the session is current */
- CFTypeRef obj = CFDictionaryGetValue(dict, CFSTR("kCGSSessionOnConsoleKey"));
- if (obj && CFGetTypeID(obj) == CFBooleanGetTypeID()) {
- /* even if this session is active, we don't use Quartz for SSH connections */
- if (CFBooleanGetValue(obj) && (!getenv("SSH_CONNECTION") || getenv("SSH_CONNECTION")[0] == 0))
- res = 1;
- }
- CFRelease(dict);
- }
- }
-
- return res;
-}
-
-SEXP makeQuartzDefault() {
- return ScalarLogical(has_wss());
-}
-
-#else
-/* --- no AQUA support = no Quartz --- */
-
-#include "grDevices.h"
-#include <R_ext/QuartzDevice.h>
-
-SEXP Quartz(SEXP args)
-{
- warning(_("Quartz device is not available on this platform"));
- return R_NilValue;
-}
-
-SEXP makeQuartzDefault() {
- return ScalarLogical(FALSE);
-}
-
-QuartzDesc_t
-Quartz_C(QuartzParameters_t *par, quartz_create_fn_t q_create, int *errorCode)
-{
- if (errorCode) errorCode[0] = -1;
- return NULL;
-}
-
-void *getQuartzAPI()
-{
- return NULL;
-}
-
-#endif
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devWindows._c b/com.oracle.truffle.r.native/library/grDevices/src/devWindows._c
deleted file mode 100644
index 6f7edd24d40779f048062d056f6bf6611e775381..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devWindows._c
+++ /dev/null
@@ -1,3853 +0,0 @@
-/*
- * R : A Computer Langage for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1998--2003 Guido Masarotto and Brian Ripley
- * Copyright (C) 2004 The R Foundation
- * Copyright (C) 2004-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/
- */
-
-/*--- Device Driver for Windows; this file started from
- * src/unix/X11/devX11.c
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#define R_USE_SIGNALS 1
-#include "Defn.h"
-#define R_USE_PROTOTYPES 1
-#include <R_ext/GraphicsEngine.h>
-
-#include "main_Fileio.h"
-#include <stdio.h>
-#include "opt.h"
-#include "graphapp/ga.h"
-#include "graphapp/stdimg.h"
-#include "console.h"
-#include "rui.h"
-#define WIN32_LEAN_AND_MEAN 1
-/* Mingw-w64 defines this to be 0x0502 */
-#ifndef _WIN32_WINNT
-# define _WIN32_WINNT 0x0500
-#endif
-#include <windows.h>
-#include "devWindows.h"
-#define DEVWINDOWS 1
-#include "grDevices.h"
-
-/* there are conflicts with Rmath.h */
-#define imax2 Rf_imax2
-#define imin2 Rf_imin2
-int imax2(int, int);
-int imin2(int, int);
-
-#ifdef ENABLE_NLS
-#define G_(String) libintl_dgettext("RGui", String)
-#define GN_(String) gettext_noop (String)
-#else /* not NLS */
-#define G_(String) (String)
-#define GN_(String) String
-#endif
-
-/* from extra.c */
-extern size_t Rf_utf8towcs(wchar_t *wc, const char *s, size_t n);
-
-static
-Rboolean GADeviceDriver(pDevDesc dd, const char *display, double width,
- double height, double pointsize,
- Rboolean recording, int resize, int bg, int canvas,
- double gamma, int xpos, int ypos, Rboolean buffered,
- SEXP psenv, Rboolean restoreConsole,
- const char *title, Rboolean clickToConfirm,
- Rboolean fillOddEven, const char *family, int quality);
-
-
-/* a colour used to represent the background on png if transparent
- NB: used as RGB and BGR
-*/
-
-#define PNG_TRANS 0xfdfefd
-
-/* these really are globals: per machine, not per window */
-static double user_xpinch = 0.0, user_ypinch = 0.0;
-
-static void GAsetunits(double xpinch, double ypinch)
-{
- user_xpinch = xpinch;
- user_ypinch = ypinch;
-}
-
-static rgb GArgb(int color, double gamma)
-{
- int r, g, b;
- if (gamma != 1) {
- r = (int) (255 * pow(R_RED(color) / 255.0, gamma));
- g = (int) (255 * pow(R_GREEN(color) / 255.0, gamma));
- b = (int) (255 * pow(R_BLUE(color) / 255.0, gamma));
- } else {
- r = R_RED(color);
- g = R_GREEN(color);
- b = R_BLUE(color);
- }
- return rgb(r, g, b);
-}
-
-
-
- /********************************************************/
- /* This device driver has been documented so that it be */
- /* used as a template for new drivers */
- /********************************************************/
-
-#define MM_PER_INCH 25.4 /* mm -> inch conversion */
-
-#define TRACEDEVGA(a)
-#define CLIP if (xd->clip.width>0) gsetcliprect(_d,xd->clip)
-
-static drawing _d;
-
-#define DRAW(a) {if(xd->kind != SCREEN) {_d=xd->gawin; CLIP; a;} else {_d=xd->bm; CLIP; a; if(!xd->buffered) {_d=xd->gawin; CLIP; a;} }}
-
-#define SHOW if(xd->kind==SCREEN) {drawbits(xd); GALastUpdate = GetTickCount();}
-#define SH if(xd->kind==SCREEN && xd->buffered && GA_xd) GA_Timer(xd)
-
-
-#define SF 20 /* scrollbar resolution */
-
- /********************************************************/
- /* Each driver can have its own device-specic graphical */
- /* parameters and resources. these should be wrapped */
- /* in a structure (gadesc in devWindows.h) */
- /* and attached to the overall device description via */
- /* the dd->deviceSpecific pointer */
- /* NOTE that there are generic graphical parameters */
- /* which must be set by the device driver, but are */
- /* common to all device types (see Graphics.h) */
- /* so go in the GPar structure rather than this device- */
- /* specific structure */
- /********************************************************/
-
-static rect getregion(gadesc *xd)
-{
- rect r = getrect(xd->bm);
- r.x += max(0, xd->xshift);
- r.y += max(0, xd->yshift);
- r.width = min(r.width, xd->showWidth);
- r.height = min(r.height, xd->showHeight);
- return r;
-}
-
-/* Update the screen 100ms after last plotting call or 500ms after
- last update (by default).
-
- This runs on (asynchronous) timers for each device.
- Macro SHOW does an immediate update, and records the update
- in GALastUpdate.
- SHOW is called for expose and mouse events, and newpage.
-
- Macro SH calls GA_Timer. If it is more than 500ms since the last
- update it does an update; otherwise it sets a timer running for
- 100ms. In either case cancels any existing timer.
- SH is called for the graphics primitives. (This could probably be
- replace by calling from Mode(0)).
-
- There are two conditions:
- (i) xd->buffered is true, which is a per-device condition.
- (ii) GA_xd is non-null. This is used to inhibit updates during shutdown
- of the device, and also (post 2.14.0) when the device is held.
-*/
-
-static UINT_PTR TimerNo = 0;
-static gadesc *GA_xd;
-static DWORD GALastUpdate = 0;
-
-static void drawbits(gadesc *xd)
-{
- if (xd)
- gbitblt(xd->gawin, xd->bm, pt(0,0), getrect(xd->bm));
-}
-
-static VOID CALLBACK
-GA_timer_proc(HWND hwnd, UINT message, UINT_PTR tid, DWORD time)
-{
- if ((message != WM_TIMER) || tid != TimerNo || !GA_xd) return;
- drawbits(GA_xd);
- GALastUpdate = time;
-}
-
-static void GA_Timer(gadesc *xd)
-{
- DWORD now = GetTickCount();
- if(TimerNo != 0) KillTimer(0, TimerNo);
- if(now > GALastUpdate + xd->timesince) {
- drawbits(xd);
- GALastUpdate = now;
- } else {
- GA_xd = xd;
- TimerNo = SetTimer((HWND)0, (UINT_PTR)0, (UINT) xd->timeafter,
- GA_timer_proc);
- }
-}
-
-static int GA_holdflush(pDevDesc dd, int level)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- if(!xd->buffered) return 0;
- int old = xd->holdlevel;
- xd->holdlevel += level;
- if(xd->holdlevel <= 0) xd->holdlevel = 0;
- if(xd->holdlevel == 0) {
- GA_xd = xd;
- gsetcursor(xd->gawin, ArrowCursor);
- drawbits(GA_xd);
- GALastUpdate = GetTickCount();
- }
- if (old == 0 && xd->holdlevel > 0) {
- if(TimerNo != 0) KillTimer(0, TimerNo);
- drawbits(xd);
- GA_xd = NULL;
- gsetcursor(xd->gawin, WatchCursor);
- }
- return xd->holdlevel;
-}
-
-
- /********************************************************/
- /* There are a number of actions that every device */
- /* driver is expected to perform (even if, in some */
- /* cases it does nothing - just so long as it doesn't */
- /* crash !). this is how the graphics engine interacts */
- /* with each device. Each action will be documented */
- /* individually. */
- /* hooks for these actions must be set up when the */
- /* device is first created */
- /********************************************************/
-
- /* Device Driver Actions */
-
-static void GA_Activate(pDevDesc dd);
-static void GA_Circle(double x, double y, double r,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Clip(double x0, double x1, double y0, double y1,
- pDevDesc dd);
-static void GA_Close(pDevDesc dd);
-static void GA_Deactivate(pDevDesc dd);
-static void GA_eventHelper(pDevDesc dd, int code);
-static Rboolean GA_Locator(double *x, double *y, pDevDesc dd);
-static void GA_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd);
-static void GA_Mode(int mode, pDevDesc dd);
-static void GA_NewPage(const pGEcontext gc,
- pDevDesc dd);
-static void GA_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd);
-static void GA_Resize(pDevDesc dd);
-static void GA_Raster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd);
-static SEXP GA_Cap(pDevDesc dd);
-static double GA_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd);
-static void GA_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd);
-static Rboolean GA_Open(pDevDesc, gadesc*, const char*, double, double,
- Rboolean, int, int, double, int, int, int);
-static Rboolean GA_NewFrameConfirm(pDevDesc);
-
-
- /********************************************************/
- /* end of list of required device driver actions */
- /********************************************************/
-
-#include "rbitmap.h"
-
- /* Support Routines */
-
-static double pixelHeight(drawing d);
-static double pixelWidth(drawing d);
-static void SetColor(int, double, gadesc*);
-static void SetFont(pGEcontext, double, gadesc*);
-//static int Load_Rbitmap_Dll();
-static void SaveAsPng(pDevDesc dd, const char *fn);
-static void SaveAsJpeg(pDevDesc dd, int quality, const char *fn);
-static void SaveAsBmp(pDevDesc dd, const char *fn);
-static void SaveAsTiff(pDevDesc dd, const char *fn);
-static void SaveAsBitmap(pDevDesc dd, int res);
-
-static void PrivateCopyDevice(pDevDesc dd, pDevDesc ndd, const char *name)
-{
- pGEDevDesc gdd;
- int saveDev = curDevice();
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- gsetcursor(xd->gawin, WatchCursor);
- gsetVar(R_DeviceSymbol, mkString(name), R_BaseEnv);
- ndd->displayListOn = FALSE;
- gdd = GEcreateDevDesc(ndd);
- GEaddDevice(gdd);
- GEcopyDisplayList(ndevNumber(dd));
- GEkillDevice(gdd);
- selectDevice(saveDev);
- gsetcursor(xd->gawin, ArrowCursor);
- show(xd->gawin);
-}
-
-static void SaveAsWin(pDevDesc dd, const char *display,
- Rboolean restoreConsole)
-{
- pDevDesc ndd = (pDevDesc) calloc(1, sizeof(DevDesc));
- if (!ndd) {
- R_ShowMessage(_("Not enough memory to copy graphics window"));
- return;
- }
- if(!R_CheckDeviceAvailableBool()) {
- free(ndd);
- R_ShowMessage(_("No device available to copy graphics window"));
- return;
- }
-
- pGEDevDesc gdd = desc2GEDesc(dd);
- if (GADeviceDriver(ndd, display,
- fromDeviceWidth(toDeviceWidth(1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- fromDeviceHeight(toDeviceHeight(-1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- ((gadesc*) dd->deviceSpecific)->basefontsize,
- 0, 1, White, White, 1, NA_INTEGER, NA_INTEGER, FALSE,
- R_GlobalEnv, restoreConsole, "", FALSE,
- ((gadesc*) dd->deviceSpecific)->fillOddEven, "",
- DEFAULT_QUALITY))
- PrivateCopyDevice(dd, ndd, display);
-}
-
-static void init_PS_PDF(void)
-{
- SEXP call, initS, grNS=R_FindNamespace(mkString("grDevices"));
-
- initS = findVarInFrame3(grNS, install("initPSandPDFfonts"), TRUE);
- if(initS == R_UnboundValue)
- error("missing initPSandPDFfonts() in grDevices namespace: this should not happen");
- PROTECT(call = lang1(initS));
- eval(call, R_GlobalEnv);
- UNPROTECT(1);
-}
-
-
-static void SaveAsPostscript(pDevDesc dd, const char *fn)
-{
- SEXP s;
- pDevDesc ndd = (pDevDesc) calloc(1, sizeof(DevDesc));
- pGEDevDesc gdd = desc2GEDesc(dd);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- char family[256], encoding[256], paper[256], bg[256], fg[256];
- const char **afmpaths = NULL;
-
- if (!ndd) {
- R_ShowMessage(_("Not enough memory to copy graphics window"));
- return;
- }
- if(!R_CheckDeviceAvailableBool()) {
- free(ndd);
- R_ShowMessage(_("No device available to copy graphics window"));
- return;
- }
-
- if(strchr(fn, '%')) error(_("'%%' is not allowed in file name"));
-
- /* need to initialize PS/PDF font database:
- also sets .PostScript.Options */
- init_PS_PDF();
- /* Set default values and pad with zeroes ... */
- strncpy(family, "Helvetica", 256);
- strcpy(encoding, "ISOLatin1.enc");
- strncpy(paper, "special", 256);
- strncpy(bg, "transparent", 256);
- strncpy(fg, "black", 256);
- /* and then try to get it from .PostScript.Options */
- s = findVar(install(".PostScript.Options"), xd->psenv);
- if ((s != R_UnboundValue) && (s != R_NilValue)) {
- SEXP names = getAttrib(s, R_NamesSymbol);
- int i, done;
- for (i = 0, done = 0; (done< 4) && (i < length(s)) ; i++) {
- if(!strcmp("family", CHAR(STRING_ELT(names, i)))) {
- strncpy(family, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- done++;
- }
- if(!strcmp("paper", CHAR(STRING_ELT(names, i)))) {
- strncpy(paper, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- done++;
- if(strcmp("paper", "default") == 0)
- strncpy(paper, "special", 255);
- }
- if(!strcmp("bg", CHAR(STRING_ELT(names, i)))) {
- strncpy(bg, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- done++;
- }
- if(!strcmp("fg", CHAR(STRING_ELT(names, i)))) {
- strncpy(fg, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- done++;
- }
- }
- }
- if (PSDeviceDriver(ndd, fn, paper, family, afmpaths, encoding,
- bg, fg,
- fromDeviceWidth(toDeviceWidth(1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- fromDeviceHeight(toDeviceHeight(-1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- (double)0, ((gadesc*) dd->deviceSpecific)->basefontsize,
- 0, 1, 0, "", "R Graphics Output", R_NilValue, "rgb",
- TRUE, xd->fillOddEven))
- /* horizontal=F, onefile=F, pagecentre=T, print.it=F */
- PrivateCopyDevice(dd, ndd, "postscript");
-}
-
-
-static void SaveAsPDF(pDevDesc dd, const char *fn)
-{
- SEXP s;
- pDevDesc ndd = (pDevDesc) calloc(1, sizeof(DevDesc));
- pGEDevDesc gdd = desc2GEDesc(dd);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- char family[256], encoding[256], bg[256], fg[256];
- const char **afmpaths = NULL;
- Rboolean useCompression = FALSE;
-
- if (!ndd) {
- R_ShowMessage(_("Not enough memory to copy graphics window"));
- return;
- }
- if(!R_CheckDeviceAvailableBool()) {
- free(ndd);
- R_ShowMessage(_("No device available to copy graphics window"));
- return;
- }
-
- if(strchr(fn, '%')) error(_("'%%' is not allowed in file name"));
-
- /* Set default values... */
- init_PS_PDF();
- s = findVar(install(".PDF.Options"), xd->psenv);
- strncpy(family, "Helvetica", 256);
- strcpy(encoding, "ISOLatin1.enc");
- strncpy(bg, "transparent", 256);
- strncpy(fg, "black", 256);
- /* and then try to get it from .PDF.Options */
- if ((s != R_UnboundValue) && (s != R_NilValue)) {
- SEXP names = getAttrib(s, R_NamesSymbol);
- for (int i = 0; i < length(s) ; i++) {
- if(!strcmp("family", CHAR(STRING_ELT(names, i))))
- strncpy(family, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)),255);
- if(!strcmp("bg", CHAR(STRING_ELT(names, i))))
- strncpy(bg, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- if(!strcmp("fg", CHAR(STRING_ELT(names, i))))
- strncpy(fg, CHAR(STRING_ELT(VECTOR_ELT(s, i), 0)), 255);
- if(!strcmp("compress", CHAR(STRING_ELT(names, i))))
- useCompression = LOGICAL(VECTOR_ELT(s, i))[0] != 0;
- }
- }
- if (PDFDeviceDriver(ndd, fn, "special", family, afmpaths, encoding,
- bg, fg,
- fromDeviceWidth(toDeviceWidth(1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- fromDeviceHeight(toDeviceHeight(-1.0, GE_NDC, gdd),
- GE_INCHES, gdd),
- ((gadesc*) dd->deviceSpecific)->basefontsize,
- 1, 0, "R Graphics Output", R_NilValue, 1, 4,
- "rgb", TRUE, TRUE, xd->fillOddEven, useCompression))
- PrivateCopyDevice(dd, ndd, "PDF");
-}
-
-
- /* Pixel Dimensions (Inches) */
-static double pixelWidth(drawing obj)
-{
- return ((double) 1) / devicepixelsx(obj);
-}
-
-static double pixelHeight(drawing obj)
-{
- return ((double) 1) / devicepixelsy(obj);
-}
-
- /* Font information array. */
- /* Point sizes: 6-24 */
- /* Faces: plain, bold, oblique, bold-oblique */
- /* Symbol may be added later */
-
-#define NFONT 19
-#define MAXFONT 32
-static int fontnum;
-static int fontinitdone = 0;/* in {0,1,2} */
-static char *fontname[MAXFONT];
-static int fontstyle[MAXFONT];
-
-static void RStandardFonts()
-{
- int i;
-
- for (i = 0; i < 4; i++) fontname[i] = "Arial";
- fontname[4] = "Symbol";
- fontstyle[0] = fontstyle[4] = Plain;
- fontstyle[1] = Bold;
- fontstyle[2] = Italic;
- fontstyle[3] = BoldItalic;
- fontnum = 5;
- fontinitdone = 2; /* =fontinit done & fontname must not be
- free-ed */
-}
-
-
-static void RFontInit()
-{
- int i, notdone;
- char *opt[2];
- char oops[256];
-
- snprintf(oops, 256, "%s/Rdevga", getenv("R_USER"));
- notdone = 1;
- fontnum = 0;
- fontinitdone = 1;
- if (!optopenfile(oops)) {
- snprintf(oops, 256, "%s/etc/Rdevga", getenv("R_HOME"));
- if (!optopenfile(oops)) {
- RStandardFonts();
- notdone = 0;
- }
- }
- while (notdone) {
- oops[0] = '\0';
- notdone = optread(opt, ':');
- if (notdone == 1)
- snprintf(oops, 256, "[%s] Error at line %d.", optfile(), optline());
- else if (notdone == 2) {
- fontname[fontnum] = strdup(opt[0]);
- if (!fontname[fontnum])
- strcpy(oops, "Insufficient memory. ");
- else {
- if (!strcmpi(opt[1], "plain"))
- fontstyle[fontnum] = Plain;
- else if (!strcmpi(opt[1], "bold"))
- fontstyle[fontnum] = Bold;
- else if (!strcmpi(opt[1], "italic"))
- fontstyle[fontnum] = Italic;
- else if (!strcmpi(opt[1], "bold&italic"))
- fontstyle[fontnum] = BoldItalic;
- else
- snprintf(oops, 256, "Unknown style at line %d. ", optline());
- fontnum += 1;
- }
- }
- if (oops[0]) {
- optclosefile();
- strcat(oops, optfile());
- strcat(oops, " will be ignored.");
- R_ShowMessage(oops);
- for (i = 0; i < fontnum; i++) free(fontname[i]);
- RStandardFonts();
- notdone = 0;
- }
- if (fontnum == MAXFONT) {
- optclosefile();
- notdone = 0;
- }
- }
-}
-
-/* Return a non-relocatable copy of a string */
-
-static char *SaveFontSpec(SEXP sxp, int offset)
-{
- char *s;
- if(!isString(sxp) || length(sxp) <= offset)
- error(_("invalid font specification"));
- s = R_alloc(strlen(CHAR(STRING_ELT(sxp, offset)))+1, sizeof(char));
- strcpy(s, CHAR(STRING_ELT(sxp, offset)));
- return s;
-}
-
-/*
- * Take the fontfamily from a gcontext (which is device-independent)
- * and convert it into a Windows-specific font description using
- * the Windows font database (see src/library/grDevices/R/windows/windows.R)
- *
- * IF gcontext fontfamily is empty ("")
- * OR IF can't find gcontext fontfamily in font database
- * THEN return NULL
- */
-static char* translateFontFamily(const char* family) {
- SEXP graphicsNS, windowsenv, fontdb, fontnames;
- int i, nfonts;
- char* result = NULL;
- PROTECT_INDEX xpi;
-
- PROTECT(graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices"))));
- PROTECT_WITH_INDEX(windowsenv = findVar(install(".WindowsEnv"),
- graphicsNS), &xpi);
- if(TYPEOF(windowsenv) == PROMSXP)
- REPROTECT(windowsenv = eval(windowsenv, graphicsNS), xpi);
- PROTECT(fontdb = findVar(install(".Windows.Fonts"), windowsenv));
- PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
- nfonts = LENGTH(fontdb);
- if (strlen(family) > 0) {
- int found = 0;
- for (i = 0; i < nfonts && !found; i++) {
- const char* fontFamily = CHAR(STRING_ELT(fontnames, i));
- if (strcmp(family, fontFamily) == 0) {
- found = 1;
- result = SaveFontSpec(VECTOR_ELT(fontdb, i), 0);
- }
- }
- if (!found)
- warning(_("font family not found in Windows font database"));
- }
- UNPROTECT(4);
- return result;
-}
-
-/* Set the font size and face */
-/* If the font of this size and at that the specified */
-/* rotation is not present it is loaded. */
-/* 0 = plain text, 1 = bold */
-/* 2 = oblique, 3 = bold-oblique */
-
-#define SMALLEST 1
-
-static void SetFont(pGEcontext gc, double rot, gadesc *xd)
-{
- int size, face = gc->fontface, usePoints;
- char* fontfamily;
- double fs = gc->cex * gc->ps;
- int quality = xd->fontquality;
-
- usePoints = xd->kind <= METAFILE;
- if (!usePoints && xd->res_dpi > 0) fs *= xd->res_dpi/72.0;
- size = fs + 0.5;
-
- if (face < 1 || face > fontnum) face = 1;
- if (size < SMALLEST) size = SMALLEST;
- if (size != xd->fontsize || face != xd->fontface ||
- rot != xd->fontangle || strcmp(gc->fontfamily, xd->fontfamily)) {
- if(xd->font) del(xd->font);
- doevent();
- /*
- * If specify family = "", get family from face via Rdevga
- *
- * If specify a family and a face in 1 to 4 then get
- * that family (mapped through WindowsFonts()) and face.
- *
- * If specify face > 4 then get font from face via Rdevga
- * (whether specifed family or not).
- */
- char * fm = gc->fontfamily;
- if (!fm[0]) fm = xd->basefontfamily;
- fontfamily = translateFontFamily(fm);
- if (fontfamily && face <= 4) {
- xd->font = gnewfont2(xd->gawin,
- fontfamily, fontstyle[face - 1],
- size, rot, usePoints, quality);
- } else {
- xd->font = gnewfont2(xd->gawin,
- fontname[face - 1], fontstyle[face - 1],
- size, rot, usePoints, quality);
- }
- if (xd->font) {
- strcpy(xd->fontfamily, gc->fontfamily);
- xd->fontface = face;
- xd->fontsize = size;
- xd->fontangle = rot;
- } else {
- /* Fallback: set Arial */
- if (face > 4) face = 1;
- xd->font = gnewfont2(xd->gawin,
- "Arial", fontstyle[face - 1],
- size, rot, usePoints, quality);
- if (!xd->font)
- error("unable to set or substitute a suitable font");
- xd->fontface = face;
- xd->fontsize = size;
- xd->fontangle = rot;
- strcpy(xd->fontfamily, "Arial");
- warning("unable to set font: using Arial");
- }
- }
-}
-
-
-static void SetColor(int color, double gamma, gadesc *xd)
-{
- if (color != xd->col) {
- xd->col = color;
- xd->fgcolor = GArgb(color, gamma);
- }
-}
-
-
-/*
- * Some Notes on Line Textures
- *
- * Line textures are stored as an array of 4-bit integers within
- * a single 32-bit word. These integers contain the lengths of
- * lines to be drawn with the pen alternately down and then up.
- * The device should try to arrange that these values are measured
- * in points if possible, although pixels is ok on most displays.
- *
- * If newlty contains a line texture description it is decoded
- * as follows:
- *
- * ndash = 0;
- * for(i=0 ; i<8 && newlty&15 ; i++) {
- * dashlist[ndash++] = newlty&15;
- * newlty = newlty>>4;
- * }
- * dashlist[0] = length of pen-down segment
- * dashlist[1] = length of pen-up segment
- * etc
- *
- * An integer containing a zero terminates the pattern. Hence
- * ndash in this code fragment gives the length of the texture
- * description. If a description contains an odd number of
- * elements it is replicated to create a pattern with an
- * even number of elements. (If this is a pain, do something
- * different its not crucial).
- *
- * 27/5/98 Paul - change to allow lty and lwd to interact:
- * the line texture is now scaled by the line width so that,
- * for example, a wide (lwd=2) dotted line (lty=2) has bigger
- * dots which are more widely spaced. Previously, such a line
- * would have "dots" which were wide, but not long, nor widely
- * spaced.
- * In this driver, done in graphapp/gdraw.c
- */
-
-static void SetLineStyle(const pGEcontext gc, pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- xd->lty = gc->lty;
- if(xd->lwdscale != 1.0)
- xd->lwd = xd->lwdscale * gc->lwd;
- else xd->lwd = gc->lwd;
- if(xd->lwd < 1) xd->lwd = 1;
- switch (gc->lend) {
- case GE_ROUND_CAP:
- xd->lend = PS_ENDCAP_ROUND;
- break;
- case GE_BUTT_CAP:
- xd->lend = PS_ENDCAP_FLAT;
- break;
- case GE_SQUARE_CAP:
- xd->lend = PS_ENDCAP_SQUARE;
- break;
- default:
- error(_("invalid line end"));
- }
- switch (gc->ljoin) {
- case GE_ROUND_JOIN:
- xd->ljoin = PS_JOIN_ROUND;
- break;
- case GE_MITRE_JOIN:
- xd->ljoin = PS_JOIN_MITER;
- break;
- case GE_BEVEL_JOIN:
- xd->ljoin = PS_JOIN_BEVEL;
- break;
- default:
- error(_("invalid line join"));
- }
-
- xd->lmitre = gc->lmitre;
-}
-
-/* Callback functions */
-
-
-static void HelpResize(window w, rect r)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (r.width) {
- if ((xd->windowWidth != r.width) ||
- ((xd->windowHeight != r.height))) {
- xd->windowWidth = r.width;
- xd->windowHeight = r.height;
- xd->resize = TRUE;
- }
- }
- }
-}
-
-static void HelpClose(window w)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- killDevice(ndevNumber(dd));
- }
-}
-
-static void HelpExpose(window w, rect r)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- pGEDevDesc gdd = desc2GEDesc(dd);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (xd->resize) {
- GA_Resize(dd);
- /* avoid trying to replay list if there has been no drawing */
- if(gdd->dirty) {
- xd->replaying = TRUE;
- GEplayDisplayList(gdd);
- xd->replaying = FALSE;
- }
- R_ProcessEvents();
- } else
- SHOW;
- }
-}
-
-static void HelpMouseClick(window w, int button, point pt)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (!xd->locator && !xd->confirmation && !dd->gettingEvent)
- return;
- if (button & LeftButton) {
- int useBeep = xd->locator &&
- asLogical(GetOption1(install("locatorBell")));
- if(useBeep) gabeep();
- xd->clicked = 1;
- xd->px = pt.x;
- xd->py = pt.y;
- } else
- xd->clicked = 2;
- if (dd->gettingEvent) {
- doMouseEvent(dd, meMouseDown, button, pt.x, pt.y);
- if (xd->buffered) SHOW;
- }
- }
-}
-
-static void HelpMouseMove(window w, int button, point pt)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (dd->gettingEvent) {
- doMouseEvent(dd, meMouseMove, button, pt.x, pt.y);
- if (xd->buffered) SHOW;
- }
- }
-}
-
-static void HelpMouseUp(window w, int button, point pt)
-{
- if (AllDevicesKilled) return;
- {
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (dd->gettingEvent) {
- doMouseEvent(dd, meMouseUp,button, pt.x, pt.y);
- if (xd->buffered) SHOW;
- }
- }
-}
-
-static void menustop(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- if (!xd->locator)
- return;
- xd->clicked = 2;
-}
-
-static void menunextplot(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- xd->clicked = 2;
-}
-
-static void menufilebitmap(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- char *fn;
- /* the following use a private hook to set the default extension */
- if (m == xd->mpng) {
- setuserfilter("Png files (*.png)\0*.png\0\0");
- fn = askfilesave(G_("Portable network graphics file"), "|.png");
- } else if (m == xd->mbmp) {
- setuserfilter("Windows bitmap files (*.bmp)\0*.bmp\0\0");
- fn = askfilesave(G_("Windows bitmap file"), "|.bmp");
- } else if (m == xd->mtiff) {
- setuserfilter("TIFF files (*.tiff,*.tif)\0*.tiff;*.tif\0\0");
- fn = askfilesave(G_("TIFF file"), "|.tif");
- } else {
- setuserfilter("Jpeg files (*.jpeg,*.jpg)\0*.jpeg;*.jpg\0\0");
- fn = askfilesave(G_("Jpeg file"), "|.jpg");
- }
- if (!fn) return;
- gsetcursor(xd->gawin, WatchCursor);
- show(xd->gawin);
- if (m==xd->mpng) SaveAsPng(dd, fn);
- else if (m==xd->mbmp) SaveAsBmp(dd, fn);
- else if (m==xd->mtiff) SaveAsTiff(dd, fn);
- else if (m==xd->mjpeg50) SaveAsJpeg(dd, 50, fn);
- else if (m==xd->mjpeg75) SaveAsJpeg(dd, 75, fn);
- else SaveAsJpeg(dd, 100, fn);
- gsetcursor(xd->gawin, ArrowCursor);
- show(xd->gawin);
-}
-
-
-static void menups(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- char *fn;
-
- setuserfilter("Encapsulated postscript files (*.eps)\0*.eps\0Postscript files (*.ps)\0*.ps\0All files (*.*)\0*.*\0\0");
- fn = askfilesave(G_("Postscript file"), "|.ps");
- if (!fn) return;
- SaveAsPostscript(dd, fn);
-}
-
-
-static void menupdf(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- char *fn;
-
- setuserfilter("PDF files (*.pdf)\0*.pdf\0All files (*.*)\0*.*\0\0");
- fn = askfilesave(G_("PDF file"), "|.pdf");
- if (!fn) return;
- SaveAsPDF(dd, fn);
-}
-
-
-static void menuwm(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- char display[550], *fn;
-
- setuserfilter("Enhanced metafiles (*.emf)\0*.emf\0All files (*.*)\0*.*\0\0");
- fn = askfilesave(G_("Enhanced metafiles"), "|.emf");
- if (!fn) return;
- if(strlen(fn) > 512) {
- askok(G_("file path selected is too long: only 512 bytes are allowed"));
- return;
- }
- snprintf(display, 550, "win.metafile:%s", fn);
- SaveAsWin(dd, display, TRUE);
-}
-
-
-static void menuclpwm(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- SaveAsWin(dd, "win.metafile", TRUE);
-}
-
-static void menuclpbm(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- show(xd->gawin);
- gsetcursor(xd->gawin, WatchCursor);
- copytoclipboard(xd->bm);
- gsetcursor(xd->gawin, ArrowCursor);
-}
-
-static void menustayontop(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- BringToTop(xd->gawin, 2);
-}
-
-static void menuprint(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- SaveAsWin(dd, "win.print:", TRUE);
-}
-
-static void menuclose(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- HelpClose(xd->gawin);
-}
-
-static void grpopupact(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (ismdi())
- disable(xd->grmenustayontop);
- else {
- if (isTopmost(xd->gawin))
- check(xd->grmenustayontop);
- else
- uncheck(xd->grmenustayontop);
- }
-}
-
-/* plot history */
-
-/* NB: this puts .SavedPlots in .GlobalEnv */
-#define GROWTH 4
-#define GETDL SEXP vDL=findVar(install(".SavedPlots"), R_GlobalEnv)
-#define SETDL defineVar(install(".SavedPlots"), vDL, R_GlobalEnv)
-/* altered in 1.4.0, as incompatible format */
-#define PLOTHISTORYMAGIC 31416
-#define pMAGIC (INTEGER(VECTOR_ELT(vDL, 0))[0])
-#define pNUMPLOTS (INTEGER(VECTOR_ELT(vDL, 1))[0])
-#define pMAXPLOTS (INTEGER(VECTOR_ELT(vDL, 2))[0])
-#define pCURRENTPOS (INTEGER(VECTOR_ELT(vDL, 3))[0])
-#define pHISTORY (VECTOR_ELT(vDL, 4))
-#define SET_pHISTORY(v) (SET_VECTOR_ELT(vDL, 4, v))
-#define pCURRENT (VECTOR_ELT(pHISTORY, pCURRENTPOS))
-#define pCURRENTdl (VECTOR_ELT(pCURRENT, 0))
-#define pCURRENTgp (INTEGER(VECTOR_ELT(pCURRENT, 1)))
-#define pCURRENTsnapshot (VECTOR_ELT(pCURRENT, 0))
-#define pCHECK if ((TYPEOF(vDL)!=VECSXP)||\
- (TYPEOF(VECTOR_ELT(vDL, 0))!=INTSXP) ||\
- (LENGTH(VECTOR_ELT(vDL, 0))!=1) ||\
- (pMAGIC != PLOTHISTORYMAGIC)) {\
- R_ShowMessage(_("plot history seems corrupted"));\
- return;}
-#define pMOVE(a) {pCURRENTPOS+=a;\
- if(pCURRENTPOS<0) pCURRENTPOS=0;\
- if(pCURRENTPOS>pNUMPLOTS-1) pCURRENTPOS=pNUMPLOTS-1;\
- Replay(dd,vDL);SETDL;}
-#define pEXIST ((vDL!=R_UnboundValue) && (vDL!=R_NilValue))
-#define pMUSTEXIST if(!pEXIST){R_ShowMessage(_("no plot history!"));return;}
-
-
-
-
-static SEXP NewPlotHistory(int n)
-{
- SEXP vDL, class;
- int i;
-
- PROTECT(vDL = allocVector(VECSXP, 5));
- for (i = 0; i < 4; i++)
- PROTECT(SET_VECTOR_ELT(vDL, i, allocVector(INTSXP, 1)));
- PROTECT(SET_pHISTORY (allocVector(VECSXP, n)));
- pMAGIC = PLOTHISTORYMAGIC;
- pNUMPLOTS = 0;
- pMAXPLOTS = n;
- pCURRENTPOS = -1;
- for (i = 0; i < n; i++)
- SET_VECTOR_ELT(pHISTORY, i, R_NilValue);
- PROTECT(class = mkString("SavedPlots"));
- classgets(vDL, class);
- SETDL;
- UNPROTECT(7);
- return vDL;
-}
-
-static SEXP GrowthPlotHistory(SEXP vDL)
-{
- SEXP vOLD;
- int i, oldNPlots, oldCurrent;
-
- PROTECT(vOLD = pHISTORY);
- oldNPlots = pNUMPLOTS;
- oldCurrent = pCURRENTPOS;
- PROTECT(vDL = NewPlotHistory(pMAXPLOTS + GROWTH));
- for (i = 0; i < oldNPlots; i++)
- SET_VECTOR_ELT(pHISTORY, i, VECTOR_ELT(vOLD, i));
- pNUMPLOTS = oldNPlots;
- pCURRENTPOS = oldCurrent;
- SETDL;
- UNPROTECT(2);
- return vDL;
-}
-
-static void AddtoPlotHistory(SEXP snapshot, int replace)
-{
- int where;
- SEXP class;
-
- GETDL;
- PROTECT(snapshot);
-/* if (dl == R_NilValue) {
- R_ShowMessage("Display list is void!");
- return;
- } */
- if (!pEXIST)
- vDL = NewPlotHistory(GROWTH);
- else if (!replace && (pNUMPLOTS == pMAXPLOTS))
- vDL = GrowthPlotHistory(vDL);
- PROTECT(vDL);
- pCHECK;
- if (replace)
- where = pCURRENTPOS;
- else
- where = pNUMPLOTS;
-
- PROTECT(class = mkString("recordedplot"));
- classgets(snapshot, class);
- SET_VECTOR_ELT(pHISTORY, where, snapshot);
- pCURRENTPOS = where;
- if (!replace) pNUMPLOTS += 1;
- SETDL;
- UNPROTECT(3);
-}
-
-
-static void Replay(pDevDesc dd, SEXP vDL)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- xd->replaying = TRUE;
- gsetcursor(xd->gawin, WatchCursor);
- GEplaySnapshot(pCURRENT, desc2GEDesc(dd));
- xd->replaying = FALSE;
- gsetcursor(xd->gawin, ArrowCursor);
-}
-
-static void menurec(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (xd->recording) {
- xd->recording = FALSE;
- uncheck(m);
- } else {
- xd->recording = TRUE;
- check(m);
- }
-}
-
-
-static void menuadd(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- AddtoPlotHistory(GEcreateSnapshot(desc2GEDesc(dd)), 0);
- xd->needsave = FALSE;
-}
-
-static void menureplace(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
-
- GETDL;
- pMUSTEXIST;
- pCHECK;
- if (pCURRENTPOS < 0) {
- R_ShowMessage(G_("No plot to replace!"));
- return;
- }
- AddtoPlotHistory(GEcreateSnapshot(desc2GEDesc(dd)), 1);
-}
-
-static void menunext(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- GETDL;
- if (xd->needsave) return;
- pMUSTEXIST;
- pCHECK;
- if (pCURRENTPOS != (pNUMPLOTS - 1)) pMOVE(1);
- PrintWarnings();
-}
-
-static void menuprev(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- GETDL;
- pMUSTEXIST;
- pCHECK;
- if (pNUMPLOTS) {
- if (xd->recording && xd->needsave) {
- pGEDevDesc gdd = desc2GEDesc(dd);
- if (gdd->displayList != R_NilValue) {
- AddtoPlotHistory(GEcreateSnapshot(gdd), 0);
- xd->needsave = FALSE;
- vDL = findVar(install(".SavedPlots"), R_GlobalEnv);
- /* may have changed vDL pointer */
- }
- }
- pMOVE((xd->needsave) ? 0 : -1);
- }
- PrintWarnings();
-}
-
-static void menugrclear(control m)
-{
- defineVar(install(".SavedPlots"), R_NilValue, R_GlobalEnv);
-}
-
-static void menugvar(control m)
-{
- SEXP vDL;
- char *v = askstring(G_("Variable name"), "");
- pDevDesc dd = (pDevDesc) getdata(m);
-
- if (!v)
- return;
- vDL = findVar(install(v), R_GlobalEnv);
- pMUSTEXIST;
- pCHECK;
- if (!pNUMPLOTS) {
- R_ShowMessage(G_("Variable doesn't contain any plots!"));
- return;
- }
- pCURRENTPOS = 0;
- Replay(dd, vDL);
- SETDL;
-}
-
-static void menusvar(control m)
-{
- char *v;
-
- GETDL;
- pMUSTEXIST;
- pCHECK;
- v = askstring(G_("Name of variable to save to"), "");
- if (!v)
- return;
- defineVar(install(v), vDL, R_GlobalEnv);
-}
-/* end of plot history */
-
-static void menuconsole(control m)
-{
- show(RConsole);
-}
-
-static void menuR(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- check(xd->mR);
- uncheck(xd->mfix);
- uncheck(xd->mfit);
- xd->resizing = 1;
- xd->resize = TRUE;
- HelpExpose(m, getrect(xd->gawin));
-}
-
-static void menufit(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- uncheck(xd->mR);
- check(xd->mfit);
- uncheck(xd->mfix);
- xd->resizing = 2;
- xd->resize = TRUE;
- HelpExpose(m, getrect(xd->gawin));
-}
-
-static void menufix(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- uncheck(xd->mR);
- uncheck(xd->mfit);
- check(xd->mfix);
- xd->resizing = 3;
- xd->resize = TRUE;
- HelpExpose(m, getrect(xd->gawin));
-}
-
-static R_KeyName getKeyName(int key)
-{
- if (F1 <= key && key <= F10) return knF1 + key - F1 ;
- else switch (key) {
- case LEFT: return knLEFT;
- case UP: return knUP;
- case RIGHT:return knRIGHT;
- case DOWN: return knDOWN;
- case PGUP: return knPGUP;
- case PGDN: return knPGDN;
- case END: return knEND;
- case HOME: return knHOME;
- case INS: return knINS;
- case DEL: return knDEL;
- default: return knUNKNOWN;
- }
-}
-
-static void CHelpKeyIn(control w, int key)
-{
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- R_KeyName keyname;
-
- if (dd->gettingEvent) {
- keyname = getKeyName(key);
- if (keyname > knUNKNOWN) {
- doKeybd(dd, keyname, NULL);
- if (xd->buffered) SHOW;
- }
- } else {
- if (xd->replaying) return;
- switch (key) {
- case INS:
- menuadd(xd->madd);
- break;
- case PGUP:
- menuprev(xd->mprev);
- break;
- case PGDN:
- menunext(xd->mnext);
- break;
- case ENTER:
- xd->enterkey = TRUE;
- break;
- }
- }
-}
-
-__declspec(dllimport) extern int UserBreak;
-
-static void NHelpKeyIn(control w, int key)
-{
- char keyname[7];
-
- pDevDesc dd = (pDevDesc) getdata(w);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (dd->gettingEvent) {
- if (0 < key && key < 32) {
- strcpy(keyname, "ctrl- ");
- keyname[5] = (char) (key + 'A' - 1);
- } else {
- keyname[0] = (char) key;
- keyname[1] = '\0';
- }
- doKeybd(dd, knUNKNOWN, keyname);
- if (xd->buffered) SHOW;
- } else {
- if (xd->replaying) return;
- switch (key) {
- case '\n': /* ENTER has been translated to newline */
- xd->enterkey = TRUE;
- return;
- case ESC:
- UserBreak = TRUE;
- return;
- }
- if (ggetkeystate() != CtrlKey) return;
- key = 'A' + key - 1;
- if (key == 'C') menuclpbm(xd->mclpbm);
- if (desc2GEDesc(dd)->displayList == R_NilValue) return;
- if (key == 'W') menuclpwm(xd->mclpwm);
- else if (key == 'P') menuprint(xd->mprint);
- }
-}
-
-static void mbarf(control m)
-{
- pDevDesc dd = (pDevDesc) getdata(m);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- GETDL;
- if (pEXIST && !xd->replaying) {
- enable(xd->mnext);
- enable(xd->mprev);
- if (pCURRENTPOS >= 0 && desc2GEDesc(dd)->displayList != R_NilValue)
- enable(xd->mreplace);
- else
- disable(xd->mreplace);
- enable(xd->msvar);
- enable(xd->mclear);
- } else {
- disable(xd->mnext);
- disable(xd->mprev);
- disable(xd->mreplace);
- disable(xd->msvar);
- disable(xd->mclear);
- }
- if (!xd->replaying)
- enable(xd->mgvar);
- else
- disable(xd->mgvar);
- if (!xd->replaying && desc2GEDesc(dd)->displayList != R_NilValue) {
- enable(xd->madd);
- enable(xd->mprint);
- enable(xd->mpng);
- enable(xd->mbmp);
- enable(xd->mtiff);
- enable(xd->mjpeg50);
- enable(xd->mjpeg75);
- enable(xd->mjpeg100);
- enable(xd->mwm);
- enable(xd->mps);
- enable(xd->mpdf);
- enable(xd->mclpwm);
- enable(xd->mclpbm);
- } else {
- disable(xd->madd);
- disable(xd->mprint);
- disable(xd->msubsave);
- disable(xd->mpng);
- disable(xd->mbmp);
- disable(xd->mtiff);
- disable(xd->mjpeg50);
- disable(xd->mjpeg75);
- disable(xd->mjpeg100);
- disable(xd->mwm);
- disable(xd->mps);
- disable(xd->mpdf);
- disable(xd->mclpwm);
- disable(xd->mclpbm);
- }
- draw(xd->mbar);
-}
-
-
- /********************************************************/
- /* device_Open is not usually called directly by the */
- /* graphics engine; it is usually only called from */
- /* the device-driver entry point. */
- /* this function should set up all of the device- */
- /* specific resources for a new device */
- /* this function is given a new structure for device- */
- /* specific information AND it must FREE the structure */
- /* if anything goes seriously wrong */
- /* NOTE that it is perfectly acceptable for this */
- /* function to set generic graphics parameters too */
- /* (i.e., override the generic parameter settings */
- /* which GInit sets up) all at the author's own risk */
- /* of course :) */
- /********************************************************/
-
-#define MCHECK(m) {if(!(m)) {del(xd->gawin); return 0;}}
-
-static void devga_sbf(control c, int pos)
-{
- pDevDesc dd = (pDevDesc) getdata(c);
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- if (pos < 0) {
- pos = -pos-1;
- pos = min(pos*SF, (xd->origWidth - xd->windowWidth + SF-1));
- xd->xshift = -pos;
- } else {
- pos = min(pos*SF, (xd->origHeight - xd->windowHeight + SF-1));
- xd->yshift = -pos;
- }
- xd->resize = 1;
- HelpExpose(c, getrect(xd->gawin));
-}
-
-
-static Rboolean
-setupScreenDevice(pDevDesc dd, gadesc *xd, double w, double h,
- Rboolean recording, int resize, int xpos, int ypos)
-{
- menu m;
- int iw, ih;
- int cw, ch;
- double dw, dw0, dh, d;
- char buf[100];
-
- xd->kind = SCREEN;
- if (R_FINITE(user_xpinch) && user_xpinch > 0.0)
- dw = dw0 = (int) (w * user_xpinch);
- else
- dw = dw0 = (int) (w / pixelWidth(NULL));
- if (R_FINITE(user_ypinch) && user_ypinch > 0.0)
- dh = (int) (h * user_ypinch);
- else
- dh = (int) (h / pixelHeight(NULL));
-
- if (ismdi() && !isiconic(RFrame)) {
- cw = RgetMDIwidth();
- ch = RgetMDIheight();
- } else {
- cw = devicewidth(NULL);
- ch = deviceheight(NULL);
- }
-
- if (resize != 3) {
- if ((dw / cw) > 0.85) {
- d = dh / dw;
- dw = 0.85 * cw;
- dh = d * dw;
- }
- if ((dh / ch) > 0.85) {
- d = dw / dh;
- dh = 0.85 * ch;
- dw = d * dh;
- }
- } else {
- dw = min(dw, 0.85*cw);
- dh = min(dh, 0.85*ch);
- }
- iw = dw + 0.5;
- ih = dh + 0.5;
- if (resize == 2) xd->rescale_factor = dw/dw0;
- {
- int grx, gry;
- grx = (xpos == NA_INTEGER) ? Rwin_graphicsx : xpos;
- gry = (ypos == NA_INTEGER) ? Rwin_graphicsy : ypos;
- if (grx < 0) grx = cw - iw + grx;
- if (gry < 0) gry = ch - ih + gry;
- if (!(xd->gawin = newwindow("R Graphics",
- rect(grx, gry, iw, ih),
- Document | StandardWindow | Menubar |
- VScrollbar | HScrollbar | CanvasSize)
- )) {
- warning("unable to open window");
- return FALSE;
- }
- }
- gchangescrollbar(xd->gawin, VWINSB, 0, ih/SF-1, ih/SF, 0);
- gchangescrollbar(xd->gawin, HWINSB, 0, iw/SF-1, iw/SF, 0);
-
- addto(xd->gawin);
- gsetcursor(xd->gawin, ArrowCursor);
- if (ismdi()) {
- int btsize = 24;
- rect r = rect(2, 2, btsize, btsize);
- control bt, tb;
-
- MCHECK(tb = newtoolbar(btsize + 4));
- gsetcursor(tb, ArrowCursor);
- addto(tb);
-
- MCHECK(bt = newtoolbutton(cam_image, r, menuclpwm));
- MCHECK(addtooltip(bt, G_("Copy to the clipboard as a metafile")));
- gsetcursor(bt, ArrowCursor);
- setdata(bt, (void *) dd);
- r.x += (btsize + 6);
-
- MCHECK(bt = newtoolbutton(print_image, r, menuprint));
- MCHECK(addtooltip(bt, G_("Print")));
- gsetcursor(bt, ArrowCursor);
- setdata(bt, (void *) dd);
- r.x += (btsize + 6);
-
- MCHECK(bt = newtoolbutton(console_image, r, menuconsole));
- MCHECK(addtooltip(bt, G_("Return focus to Console")));
- gsetcursor(bt, ArrowCursor);
- setdata(bt, (void *) dd);
- r.x += (btsize + 6);
-
- MCHECK(xd->stoploc = newtoolbutton(stop_image, r, menustop));
- MCHECK(addtooltip(xd->stoploc, G_("Stop locator")));
- gsetcursor(bt, ArrowCursor);
- setdata(xd->stoploc,(void *) dd);
- hide(xd->stoploc);
- } else
- xd->stoploc = NULL;
-
- /* First we prepare 'locator' menubar and popup */
- addto(xd->gawin);
- MCHECK(xd->mbarloc = newmenubar(NULL));
- MCHECK(newmenu(G_("Stop")));
- MCHECK(m = newmenuitem(G_("Stop locator"), 0, menustop));
- setdata(m, (void *) dd);
- MCHECK(xd->locpopup = newpopup(NULL));
- MCHECK(m = newmenuitem(G_("Stop"), 0, menustop));
- setdata(m, (void *) dd);
- MCHECK(newmenuitem(G_("Continue"), 0, NULL));
-
- /* Next the 'Click for next plot' menubar */
- MCHECK(xd->mbarconfirm = newmenubar(NULL));
- MCHECK(newmenu(G_("Next")));
- MCHECK(m = newmenuitem(G_("Next plot"), 0, menunextplot));
- setdata(m, (void *) dd);
-
- /* Normal menubar */
- MCHECK(xd->mbar = newmenubar(mbarf));
- MCHECK(m = newmenu(G_("File")));
- MCHECK(xd->msubsave = newsubmenu(m, G_("Save as")));
- MCHECK(xd->mwm = newmenuitem("Metafile...", 0, menuwm));
- MCHECK(xd->mps = newmenuitem("Postscript...", 0, menups));
- MCHECK(xd->mpdf = newmenuitem("PDF...", 0, menupdf));
- MCHECK(xd->mpng = newmenuitem("Png...", 0, menufilebitmap));
- MCHECK(xd->mbmp = newmenuitem("Bmp...", 0, menufilebitmap));
- MCHECK(xd->mtiff = newmenuitem("TIFF...", 0, menufilebitmap));
- MCHECK(newsubmenu(xd->msubsave, "Jpeg"));
- /* avoid gettext confusion with % */
- snprintf(buf, 100, G_("%s quality..."), "50%");
- MCHECK(xd->mjpeg50 = newmenuitem(buf, 0, menufilebitmap));
- snprintf(buf, 100, G_("%s quality..."), "75%");
- MCHECK(xd->mjpeg75 = newmenuitem(buf, 0, menufilebitmap));
- snprintf(buf, 100, G_("%s quality..."), "100%");
- MCHECK(xd->mjpeg100 = newmenuitem(buf, 0, menufilebitmap));
- MCHECK(newsubmenu(m, G_("Copy to the clipboard")));
- MCHECK(xd->mclpbm = newmenuitem(G_("as a Bitmap\tCTRL+C"), 0, menuclpbm));
- MCHECK(xd->mclpwm = newmenuitem(G_("as a Metafile\tCTRL+W"), 0, menuclpwm));
- addto(m);
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->mprint = newmenuitem(G_("Print...\tCTRL+P"), 0, menuprint));
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->mclose = newmenuitem(G_("close Device"), 0, menuclose));
- MCHECK(newmenu(G_("History")));
- MCHECK(xd->mrec = newmenuitem(G_("Recording"), 0, menurec));
- if(recording) check(xd->mrec);
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->madd = newmenuitem(G_("Add\tINS"), 0, menuadd));
- MCHECK(xd->mreplace = newmenuitem(G_("Replace"), 0, menureplace));
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->mprev = newmenuitem(G_("Previous\tPgUp"), 0, menuprev));
- MCHECK(xd->mnext = newmenuitem(G_("Next\tPgDown"), 0, menunext));
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->msvar = newmenuitem(G_("Save to variable..."), 0, menusvar));
- MCHECK(xd->mgvar = newmenuitem(G_("Get from variable..."), 0, menugvar));
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->mclear = newmenuitem(G_("Clear history"), 0, menugrclear));
- MCHECK(newmenu(G_("Resize")));
- MCHECK(xd->mR = newmenuitem(G_("R mode"), 0, menuR));
- if(resize == 1) check(xd->mR);
- MCHECK(xd->mfit = newmenuitem(G_("Fit to window"), 0, menufit));
- if(resize == 2) check(xd->mfit);
- MCHECK(xd->mfix = newmenuitem(G_("Fixed size"), 0, menufix));
- if(resize == 3) check(xd->mfix);
- newmdimenu();
-
- /* Normal popup */
- MCHECK(xd->grpopup = newpopup(grpopupact));
- setdata(xd->grpopup, (void *) dd);
- MCHECK(m = newmenuitem(G_("Copy as metafile"), 0, menuclpwm));
- setdata(m, (void *) dd);
- MCHECK(m = newmenuitem(G_("Copy as bitmap"), 0, menuclpbm));
- setdata(m, (void *) dd);
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(m = newmenuitem(G_("Save as metafile..."), 0, menuwm));
- setdata(m, (void *) dd);
- MCHECK(m = newmenuitem(G_("Save as postscript..."), 0, menups));
- setdata(m, (void *) dd);
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(xd->grmenustayontop = newmenuitem(G_("Stay on top"), 0, menustayontop));
- setdata(xd->grmenustayontop, (void *) dd);
- MCHECK(newmenuitem("-", 0, NULL));
- MCHECK(m = newmenuitem(G_("Print..."), 0, menuprint));
- setdata(m, (void *) dd);
- gchangepopup(xd->gawin, xd->grpopup);
-
- MCHECK(xd->bm = newbitmap(getwidth(xd->gawin), getheight(xd->gawin),
- getdepth(xd->gawin)));
- MCHECK(xd->bm2 = newbitmap(getwidth(xd->gawin), getheight(xd->gawin),
- getdepth(xd->gawin)));
- gfillrect(xd->gawin, xd->outcolor, getrect(xd->gawin));
- gfillrect(xd->bm, xd->outcolor, getrect(xd->bm));
- addto(xd->gawin);
- setdata(xd->mbar, (void *) dd);
- setdata(xd->mpng, (void *) dd);
- setdata(xd->mbmp, (void *) dd);
- setdata(xd->mtiff, (void *) dd);
- setdata(xd->mjpeg50, (void *) dd);
- setdata(xd->mjpeg75, (void *) dd);
- setdata(xd->mjpeg100, (void *) dd);
- setdata(xd->mps, (void *) dd);
- setdata(xd->mpdf, (void *) dd);
- setdata(xd->mwm, (void *) dd);
- setdata(xd->mclpwm, (void *) dd);
- setdata(xd->mclpbm, (void *) dd);
- setdata(xd->mprint, (void *) dd);
- setdata(xd->mclose, (void *) dd);
- setdata(xd->mrec, (void *) dd);
- setdata(xd->mprev, (void *) dd);
- setdata(xd->mnext, (void *) dd);
- setdata(xd->mgvar, (void *) dd);
- setdata(xd->madd, (void *) dd);
- setdata(xd->mreplace, (void *) dd);
- setdata(xd->mR, (void *) dd);
- setdata(xd->mfit, (void *) dd);
- setdata(xd->mfix, (void *) dd);
- if (ismdi() && !(RguiMDI & RW_TOOLBAR)) toolbar_hide();
- show(xd->gawin); /* twice, for a Windows bug */
- show(xd->gawin);
- BringToTop(xd->gawin, 0);
- sethit(xd->gawin, devga_sbf);
- setresize(xd->gawin, HelpResize);
- setredraw(xd->gawin, HelpExpose);
- setmousedown(xd->gawin, HelpMouseClick);
- setmousemove(xd->gawin, HelpMouseMove);
- setmousedrag(xd->gawin, HelpMouseMove);
- setmouseup(xd->gawin, HelpMouseUp);
- setkeydown(xd->gawin, NHelpKeyIn);
- setkeyaction(xd->gawin, CHelpKeyIn);
- setclose(xd->gawin, HelpClose);
- xd->recording = recording;
- xd->replaying = FALSE;
- xd->resizing = resize;
-
- dd->eventHelper = GA_eventHelper;
-
- dd->canGenMouseDown = TRUE;
- dd->canGenMouseMove = TRUE;
- dd->canGenMouseUp = TRUE;
- dd->canGenKeybd = TRUE;
- dd->gettingEvent = FALSE;
-
- GA_xd = xd;
- return TRUE;
-}
-
-static Rboolean GA_Open(pDevDesc dd, gadesc *xd, const char *dsp,
- double w, double h, Rboolean recording,
- int resize, int canvascolor, double gamma,
- int xpos, int ypos, int bg)
-{
- rect rr;
- char buf[600]; /* allow for pageno formats */
-
- if (!fontinitdone)
- RFontInit();
-
- /* Foreground and Background Colors */
- xd->bg = dd->startfill = bg;
- xd->col = dd->startcol = R_RGB(0, 0, 0);
-
- xd->fgcolor = Black;
- xd->bgcolor = xd->canvascolor = GArgb(canvascolor, gamma);
- xd->outcolor = myGetSysColor(COLOR_APPWORKSPACE);
- xd->rescale_factor = 1.0;
- xd->fast = 1; /* Use 'cosmetic pens' if available.
- Overridden for printers and metafiles.
- */
- xd->xshift = xd->yshift = 0;
- xd->npage = 0;
- xd->fp = NULL; /* not all devices (e.g. TIFF) use the file pointer, but SaveAsBitmap
- looks at it */
-
- if (!dsp[0]) {
- if (!setupScreenDevice(dd, xd, w, h, recording, resize, xpos, ypos))
- return FALSE;
- xd->have_alpha = TRUE;
- } else if (!strncmp(dsp, "win.print:", 10)) {
- xd->kind = PRINTER;
- xd->fast = 0; /* use scalable line widths */
- xd->gawin = newprinter(MM_PER_INCH * w, MM_PER_INCH * h, &dsp[10]);
- if (!xd->gawin) {
- warning("unable to open printer");
- return FALSE;
- }
- } else if (!strncmp(dsp, "png:", 4) || !strncmp(dsp,"bmp:", 4)) {
- xd->res_dpi = (xpos == NA_INTEGER) ? 0 : xpos;
- xd->bg = dd->startfill = canvascolor;
- xd->kind = (dsp[0]=='p') ? PNG : BMP;
- if(strlen(dsp+4) >= 512) error(_("filename too long in %s() call"),
- (dsp[0]=='p') ? "png" : "bmp");
- strcpy(xd->filename, R_ExpandFileName(dsp+4));
- if (!Load_Rbitmap_Dll()) {
- warning("unable to load Rbitmap.dll");
- return FALSE;
- }
-
- if (w < 20 && h < 20)
- warning(_("'width=%d, height=%d' are unlikely values in pixels"),
- (int)w, (int) h);
- /*
- Observe that given actual graphapp implementation 256 is
- irrelevant,i.e., depth of the bitmap is that of graphic card
- if required depth > 1
- */
- if ((xd->gawin = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- xd->bm = xd->gawin;
- if ((xd->bm2 = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- snprintf(buf, 600, xd->filename, 1);
- if ((xd->fp = R_fopen(buf, "wb")) == NULL) {
- del(xd->gawin);
- warning(_("unable to open file '%s' for writing"), buf);
- return FALSE;
- }
- xd->have_alpha = TRUE;
- } else if (!strncmp(dsp, "jpeg:", 5)) {
- char *p = strchr(&dsp[5], ':');
- xd->res_dpi = (xpos == NA_INTEGER) ? 0 : xpos;
- xd->bg = dd->startfill = canvascolor;
- xd->kind = JPEG;
- if (!p) return FALSE;
- if (!Load_Rbitmap_Dll()) {
- warning("unable to load Rbitmap.dll");
- return FALSE;
- }
- *p = '\0';
- xd->quality = atoi(&dsp[5]);
- *p = ':' ;
- if(strlen(p+1) >= 512) error(_("filename too long in jpeg() call"));
- strcpy(xd->filename, R_ExpandFileName(p+1));
- if (w < 20 && h < 20)
- warning(_("'width=%d, height=%d' are unlikely values in pixels"),
- (int)w, (int) h);
- if((xd->gawin = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- xd->bm = xd->gawin;
- if ((xd->bm2 = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- snprintf(buf, 600, xd->filename, 1);
- if ((xd->fp = R_fopen(buf, "wb")) == NULL) {
- del(xd->gawin);
- warning(_("unable to open file '%s' for writing"), buf);
- return FALSE;
- }
- xd->have_alpha = TRUE;
- } else if (!strncmp(dsp, "tiff:", 5)) {
- char *p = strchr(&dsp[5], ':');
- xd->res_dpi = (xpos == NA_INTEGER) ? 0 : xpos;
- xd->bg = dd->startfill = canvascolor;
- xd->kind = TIFF;
- if (!p) return FALSE;
- if (!Load_Rbitmap_Dll()) {
- warning("unable to load Rbitmap.dll");
- return FALSE;
- }
- *p = '\0';
- xd->quality = atoi(&dsp[5]);
- *p = ':' ;
- if(strlen(p+1) >= 512) error(_("filename too long in tiff() call"));
- strcpy(xd->filename, R_ExpandFileName(p+1));
- if (w < 20 && h < 20)
- warning(_("'width=%d, height=%d' are unlikely values in pixels"),
- (int) w, (int) h);
- if((xd->gawin = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- xd->bm = xd->gawin;
- if ((xd->bm2 = newbitmap(w, h, 256)) == NULL) {
- warning(_("unable to allocate bitmap"));
- return FALSE;
- }
- xd->have_alpha = TRUE;
- } else {
- /*
- * win.metafile[:] in memory (for the clipboard)
- * win.metafile:filename
- * anything else return FALSE
- */
- char *s = "win.metafile";
- int ls = strlen(s);
- int ld = strlen(dsp);
-
- if (ls > ld)
- return FALSE;
- if (strncmp(dsp, s, ls) || (dsp[ls] && (dsp[ls] != ':'))) {
- warning("invalid specification for file name in win.metafile()");
- return FALSE;
- }
- if(ld > ls && strlen(&dsp[ls + 1]) >= 512)
- error(_("filename too long in win.metafile() call"));
- strcpy(xd->filename, (ld > ls) ? &dsp[ls + 1] : "");
- snprintf(buf, 600, xd->filename, 1);
- xd->w = MM_PER_INCH * w;
- xd->h = MM_PER_INCH * h;
- xd->gawin = newmetafile(buf, MM_PER_INCH * w, MM_PER_INCH * h);
- xd->kind = METAFILE;
- xd->fast = 0; /* use scalable line widths */
- if (!xd->gawin) {
- if(ld > ls)
- warning(_("unable to open metafile '%s' for writing"), buf);
- else
- warning(_("unable to open clipboard to write metafile"));
- return FALSE;
- }
- }
-
- if (xd->kind <= METAFILE)
- xd->lwdscale = devicepixelsy(xd->gawin)/96.0; /* matches ps/pdf */
- else if (xd->res_dpi > 0)
- xd->lwdscale = xd->res_dpi/96.0;
- else
- xd->lwdscale = 72.0/96.0;
- if(xd->lwdscale < 1.0) xd->lwdscale = 1.0; /* at least one pixel */
- rr = getrect(xd->gawin);
- xd->origWidth = xd->showWidth = xd->windowWidth = rr.width;
- xd->origHeight = xd->showHeight = xd->windowHeight = rr.height;
- xd->clip = rr;
- setdata(xd->gawin, (void *) dd);
- xd->needsave = FALSE;
- return TRUE;
-}
-
- /********************************************************/
- /* device_StrWidth should return the width of the given */
- /* string in DEVICE units (GStrWidth is responsible for */
- /* converting from DEVICE to whatever units the user */
- /* asked for */
- /********************************************************/
-
-static double GA_StrWidth(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- SetFont(gc, 0.0, xd);
- return (double) gstrwidth1(xd->gawin, xd->font, str, CE_NATIVE);
-}
-
-static double GA_StrWidth_UTF8(const char *str,
- const pGEcontext gc,
- pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- double a;
-
- /* This should never be called for symbol fonts */
- SetFont(gc, 0.0, xd);
- if(gc->fontface != 5)
- a = (double) gstrwidth1(xd->gawin, xd->font, str, CE_UTF8);
- else
- a = (double) gstrwidth1(xd->gawin, xd->font, str, CE_SYMBOL);
- return a;
-}
-
- /********************************************************/
- /* device_MetricInfo should return height, depth, and */
- /* width information for the given character in DEVICE */
- /* units (GMetricInfo does the necessary conversions) */
- /* This is used for formatting mathematical expressions */
- /********************************************************/
-
- /* Character Metric Information */
- /* Passing c == 0 gets font information.
- In a mbcslocale for a non-symbol font
- we pass a Unicode point, otherwise an 8-bit char, and
- we don't care which for a 7-bit char.
- */
-
-static void GA_MetricInfo(int c,
- const pGEcontext gc,
- double* ascent, double* descent,
- double* width, pDevDesc dd)
-{
- int a, d, w;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- Rboolean Unicode = mbcslocale;
-
- if (c < 0) { Unicode = TRUE; c = -c; }
- SetFont(gc, 0.0, xd);
- if(Unicode && gc->fontface != 5 && c > 127)
- gwcharmetric(xd->gawin, xd->font, c, &a, &d, &w);
- else
- gcharmetric(xd->gawin, xd->font, c, &a, &d, &w);
- /* Some Windows systems report that space has height and depth,
- so we have a kludge. Note that 32 is space in symbol font too */
- if(c == 32) {
- *ascent = 0.0;
- *descent = 0.0;
- } else {
- *ascent = (double) a;
- *descent = (double) d;
- }
- *width = (double) w;
-}
-
- /********************************************************/
- /* device_Clip is given the left, right, bottom, and */
- /* top of a rectangle (in DEVICE coordinates). it */
- /* should have the side-effect that subsequent output */
- /* is clipped to the given rectangle */
- /********************************************************/
-
-static void GA_Clip(double x0, double x1, double y0, double y1, pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- rect r;
-
- r = rcanon(rpt(pt(x0, y0), pt(x1, y1)));
- r.width += 1;
- r.height += 1;
- xd->clip = r;
-}
-
- /********************************************************/
- /* device_Resize is called whenever the device is */
- /* resized. the function must update the GPar */
- /* parameters (left, right, bottom, and top) for the */
- /* new device size */
- /* this is not usually called directly by the graphics */
- /* engine because the detection of device resizes */
- /* (e.g., a window resize) are usually detected by */
- /* device-specific code (see R_ProcessEvents) */
- /********************************************************/
-
-static void GA_Size(double *left, double *right,
- double *bottom, double *top,
- pDevDesc dd)
-{
- *left = dd->left;
- *top = dd->top;
- /* There's a mysterious -0.0001 in the setting */
- *right = ceil(dd->right);
- *bottom = ceil(dd->bottom);
-}
-
-static void GA_Resize(pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (xd->resize) {
- int iw, ih, iw0 = dd->right - dd->left,
- ih0 = dd->bottom - dd->top;
- double fw, fh, rf, shift;
-
- iw = xd->windowWidth;
- ih = xd->windowHeight;
- if(xd->resizing == 1) {
- /* last mode might have been 3, so remove scrollbars */
- gchangescrollbar(xd->gawin, VWINSB, 0, ih/SF-1, ih/SF, 0);
- gchangescrollbar(xd->gawin, HWINSB, 0, iw/SF-1, iw/SF, 0);
- dd->left = 0.0;
- dd->top = 0.0;
- dd->right = iw;
- dd->bottom = ih;
- xd->showWidth = iw;
- xd->showHeight = ih;
- } else if (xd->resizing == 2) {
- /* last mode might have been 3, so remove scrollbars */
- gchangescrollbar(xd->gawin, VWINSB, 0, ih/SF-1, ih/SF, 0);
- gchangescrollbar(xd->gawin, HWINSB, 0, iw/SF-1, iw/SF, 0);
- fw = (iw + 0.5)/(iw0 + 0.5);
- fh = (ih + 0.5)/(ih0 + 0.5);
- rf = min(fw, fh);
- xd->rescale_factor *= rf;
- {
- SEXP scale;
- PROTECT(scale = ScalarReal(rf));
- GEhandleEvent(GE_ScalePS, dd, scale);
- UNPROTECT(1);
- }
- if (fw < fh) {
- dd->left = 0.0;
- xd->showWidth = dd->right = iw;
- xd->showHeight = ih0*fw;
- shift = (ih - xd->showHeight)/2.0;
- dd->top = shift;
- dd->bottom = ih0*fw + shift;
- xd->xshift = 0; xd->yshift = shift;
- } else {
- dd->top = 0.0;
- xd->showHeight = dd->bottom = ih;
- xd->showWidth = iw0*fh;
- shift = (iw - xd->showWidth)/2.0;
- dd->left = shift;
- dd->right = iw0*fh + shift;
- xd->xshift = shift; xd->yshift = 0;
- }
- xd->clip = getregion(xd);
- } else if (xd->resizing == 3) {
- if(iw0 < iw) shift = (iw - iw0)/2.0;
- else shift = min(0, xd->xshift);
- dd->left = shift;
- dd->right = iw0 + shift;
- xd->xshift = shift;
- gchangescrollbar(xd->gawin, HWINSB, max(-shift,0)/SF,
- xd->origWidth/SF - 1, xd->windowWidth/SF, 0);
- if(ih0 < ih) shift = (ih - ih0)/2.0;
- else shift = min(0, xd->yshift);
- dd->top = shift;
- dd->bottom = ih0 + shift;
- xd->yshift = shift;
- gchangescrollbar(xd->gawin, VWINSB, max(-shift,0)/SF,
- xd->origHeight/SF - 1, xd->windowHeight/SF, 0);
- xd->showWidth = xd->origWidth + min(0, xd->xshift);
- xd->showHeight = xd->origHeight + min(0, xd->yshift);
- }
- xd->resize = FALSE;
- if (xd->kind == SCREEN) {
- del(xd->bm);
- xd->bm = newbitmap(iw, ih, getdepth(xd->gawin));
- if (!xd->bm) {
- R_ShowMessage(_("Insufficient memory for resize. Killing device"));
- killDevice(ndevNumber(dd));
- return; /* since the device is killed */
- }
- if(xd->have_alpha) {
- del(xd->bm2);
- xd->bm2 = newbitmap(iw, ih, getdepth(xd->gawin));
- if (!xd->bm2) {
- R_ShowMessage(_("Insufficient memory for resize. Disabling alpha blending"));
- xd->have_alpha = FALSE;
- }
- }
-
- gfillrect(xd->gawin, xd->outcolor, getrect(xd->gawin));
- gfillrect(xd->bm, xd->outcolor, getrect(xd->bm));
- }
- }
-}
-
- /********************************************************/
- /* device_NewPage is called whenever a new plot requires*/
- /* a new page. a new page might mean just clearing the */
- /* device (as in this case) or moving to a new page */
- /* (e.g., postscript) */
- /********************************************************/
-
-static void GA_NewPage(const pGEcontext gc,
- pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- xd->npage++;
- if ((xd->kind == PRINTER) && xd->needsave)
- nextpage(xd->gawin);
- if ((xd->kind == METAFILE) && xd->needsave) {
- char buf[600];
- if (strlen(xd->filename) == 0)
- error(_("a clipboard metafile can store only one figure."));
- else {
- del(xd->gawin);
- snprintf(buf, 600, xd->filename, xd->npage);
- xd->gawin = newmetafile(buf, xd->w, xd->h);
- if(!xd->gawin)
- error(_("metafile '%s' could not be created"), buf);
- }
- }
- if ((xd->kind == PNG || xd->kind == JPEG || xd->kind == BMP)
- && xd->needsave) {
- char buf[600];
- SaveAsBitmap(dd, xd->res_dpi);
- snprintf(buf, 600, xd->filename, xd->npage);
- if ((xd->fp = R_fopen(buf, "wb")) == NULL)
- error(_("unable to open file '%s' for writing"), buf);
- }
- if (xd->kind == TIFF && xd->needsave) {
- SaveAsBitmap(dd, xd->res_dpi);
- }
- if (xd->kind == SCREEN) {
- if(xd->buffered && !xd->holdlevel) SHOW;
- if (xd->recording && xd->needsave)
- AddtoPlotHistory(desc2GEDesc(dd)->savedSnapshot, 0);
- if (xd->replaying)
- xd->needsave = FALSE;
- else
- xd->needsave = TRUE;
- }
- xd->bg = gc->fill;
- xd->warn_trans = FALSE;
- {
- unsigned int alpha = R_ALPHA(xd->bg);
- if(alpha == 0) xd->bgcolor = xd->canvascolor;
- else {
- xd->bgcolor = GArgb(xd->bg, gc->gamma);
- if(alpha < 255)
- xd->bgcolor = (alpha * xd->bgcolor +
- (255-alpha) * xd->canvascolor)/255;
- }
- }
- if (xd->kind != SCREEN) {
- xd->needsave = TRUE;
- xd->clip = getrect(xd->gawin);
- if(R_OPAQUE(xd->bg) || xd->kind == BMP || xd->kind == JPEG
- || xd->kind == TIFF) {
- DRAW(gfillrect(_d, xd->bgcolor, xd->clip));
- } else if(xd->kind == PNG) {
- DRAW(gfillrect(_d, PNG_TRANS, xd->clip));
- }
- if(xd->kind == PNG)
- xd->pngtrans = ggetpixel(xd->gawin, pt(0,0)) | 0xff000000;
- } else {
- xd->clip = getregion(xd);
- DRAW(gfillrect(_d, xd->bgcolor, xd->clip));
- }
- SH;
-}
-
-static void deleteGraphMenus(int devnum)
-{
- char prefix[15];
-
- snprintf(prefix, 15, "$Graph%i", devnum);
- windelmenus(prefix);
-}
-
- /********************************************************/
- /* device_Close is called when the device is killed */
- /* this function is responsible for destroying any */
- /* device-specific resources that were created in */
- /* device_Open and for FREEing the device-specific */
- /* parameters structure */
- /********************************************************/
-
-static void GA_Close(pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- SEXP vDL;
-
- if (dd->onExit) {
- dd->onExit(dd);
- UserBreak = TRUE;
- }
-
- if (xd->kind == SCREEN) {
- if(xd->recording) {
- AddtoPlotHistory(GEcreateSnapshot(desc2GEDesc(dd)), 0);
- /* May have changed vDL, so can't use GETDL above */
- vDL = findVar(install(".SavedPlots"), R_GlobalEnv);
- pCURRENTPOS++; /* so PgUp goes to the last saved plot
- when a windows() device is opened */
- }
- hide(xd->gawin);
-
- del(xd->bm);
- /* If this is the active device and buffered, shut updates off */
- if (xd == GA_xd) GA_xd = NULL;
- deleteGraphMenus(ndevNumber(dd) + 1);
-
- } else if ((xd->kind == PNG) || (xd->kind == JPEG)
- || (xd->kind == BMP) || (xd->kind == TIFF)) {
- if (xd->kind == TIFF) xd->npage++;
- SaveAsBitmap(dd, xd->res_dpi);
- }
- del(xd->font);
- if(xd->bm2) del(xd->bm2);
- del(xd->gawin);
-/*
- * this is needed since the GraphApp delayed clean-up
- * ,i.e, I want free all resources NOW
- */
- /* I think the concern is rather to run all pending events on the
- device (but also on the console and others) */
- doevent();
- free(xd);
-}
-
- /********************************************************/
- /* device_Activate is called when a device becomes the */
- /* active device. in this case it is used to change the*/
- /* title of a window to indicate the active status of */
- /* the device to the user. not all device types will */
- /* do anything */
- /********************************************************/
-
-static void GA_Activate(pDevDesc dd)
-{
- char t[150];
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (xd->replaying || (xd->kind!=SCREEN))
- return;
- if(strlen(xd->title)) {
- snprintf(t, 140, xd->title, ndevNumber(dd) + 1);
- t[139] = '\0';
- } else {
- snprintf(t, 150, "R Graphics: Device %d", ndevNumber(dd) + 1);
- }
- strcat(t, " (ACTIVE)");
- settext(xd->gawin, t);
- if (xd != GA_xd)
- drawbits(GA_xd);
- GA_xd = xd;
-}
-
- /********************************************************/
- /* device_Deactivate is called when a device becomes */
- /* inactive. in this case it is used to change the */
- /* title of a window to indicate the inactive status of */
- /* the device to the user. not all device types will */
- /* do anything */
- /********************************************************/
-
-static void GA_Deactivate(pDevDesc dd)
-{
- char t[150];
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (xd->replaying || (xd->kind != SCREEN))
- return;
- if(strlen(xd->title)) {
- snprintf(t, 140, xd->title, ndevNumber(dd) + 1);
- t[139] = '\0';
- } else {
- snprintf(t, 150, "R Graphics: Device %d", ndevNumber(dd) + 1);
- }
- strcat(t, " (inactive)");
- settext(xd->gawin, t);
-}
-
-#define WARN_SEMI_TRANS { \
- if(!xd->warn_trans) warning(_("semi-transparency is not supported on this device: reported only once per page")); \
- xd->warn_trans = TRUE; \
- }
-
-#define DRAW2(col) {if(xd->kind != SCREEN) gcopyalpha(xd->gawin,xd->bm2,r,R_ALPHA(col)); else {gcopyalpha(xd->bm,xd->bm2,r,R_ALPHA(col)); if(!xd->buffered) drawbits(xd);}}
-
-
-
- /********************************************************/
- /* device_Rect should have the side-effect that a */
- /* rectangle is drawn with the given locations for its */
- /* opposite corners. the border of the rectangle */
- /* should be in the given "fg" colour and the rectangle */
- /* should be filled with the given "bg" colour */
- /* if "fg" is NA_INTEGER then no border should be drawn */
- /* if "bg" is NA_INTEGER then the rectangle should not */
- /* be filled */
- /* the locations are in an arbitrary coordinate system */
- /* and this function is responsible for converting the */
- /* locations to DEVICE coordinates using GConvert */
- /********************************************************/
-
-static void GA_Rect(double x0, double y0, double x1, double y1,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int tmp;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- rect r, rr;
-
- /* These in-place conversions are ok */
- TRACEDEVGA("rect");
-
- if (x0 > x1) {
- tmp = x0;
- x0 = x1;
- x1 = tmp;
- }
- if (y0 > y1) {
- tmp = y0;
- y0 = y1;
- y1 = tmp;
- }
- /* zero width or height disappears, so handle that case specially in case it's just rounding */
- if ((int)x0 == (int)x1 && x1-x0 >= 0.5) {
- x1 = (int)x1;
- x0 = x1 - 1.0;
- }
- if ((int)y0 == (int)y1 && y1-y0 >= 0.5) {
- y1 = (int)y1;
- y0 = y1 - 1.0;
- }
- r = rect((int) x0, (int) y0, (int)x1 - (int)x0, (int)y1 - (int)y0);
-
- SetColor(gc->fill, gc->gamma, xd);
- if (R_OPAQUE(gc->fill)) {
- DRAW(gfillrect(_d, xd->fgcolor, r));
- } else if(R_ALPHA(gc->fill) > 0) {
- if(xd->have_alpha) {
- rect cp = xd->clip;
- /* We are only working with the screen device here, so
- we can assume that x->bm is the current state.
- Copying from the screen window does not work. */
- /* Clip to the device region */
- rr = r;
- if (r.x < 0) {r.x = 0; r.width = r.width + rr.x;}
- if (r.y < 0) {r.y = 0; r.height = r.height + rr.y;}
- if (r.x + r.width > cp.x + cp.width)
- r.width = cp.x + cp.width - r.x;
- if (r.y + r.height > cp.y + cp.height)
- r.height = cp.y + cp.height - r.y;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gfillrect(xd->bm2, xd->fgcolor, rr);
- DRAW2(gc->fill);
- r = rr;
- } else WARN_SEMI_TRANS;
- }
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- DRAW(gdrawrect(_d, xd->lwd, xd->lty, xd->fgcolor, r, 0, xd->lend,
- xd->ljoin, xd->lmitre));
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- int adj, tol = xd->lwd; /* only half needed */
- rect cp = xd->clip;
- rr = r;
- r.x -= tol; r.y -= tol; r.width += 2*tol; r.height += 2*tol;
- if (r.x < 0) {adj = r.x; r.x = 0; r.width = r.width + adj;}
- if (r.y < 0) {adj = r.y; r.y = 0; r.height = r.height + adj;}
- if (r.x + r.width > cp.x + cp.width)
- r.width = cp.x + cp.width - r.x;
- if (r.y + r.height > cp.y + cp.height)
- r.height = cp.y + cp.height - r.y;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gdrawrect(xd->bm2, xd->lwd, xd->lty, xd->fgcolor, rr, 0, xd->lend,
- xd->ljoin, xd->lmitre);
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- SH;
-}
-
- /********************************************************/
- /* device_Circle should have the side-effect that a */
- /* circle is drawn, centred at the given location, with */
- /* the given radius. the border of the circle should be*/
- /* drawn in the given "col", and the circle should be */
- /* filled with the given "border" colour. */
- /* if "col" is NA_INTEGER then no border should be drawn*/
- /* if "border" is NA_INTEGER then the circle should not */
- /* be filled */
- /* the location is in arbitrary coordinates and the */
- /* function is responsible for converting this to */
- /* DEVICE coordinates. the radius is given in DEVICE */
- /* coordinates */
- /********************************************************/
-
-static void GA_Circle(double x, double y, double radius,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int id, ix, iy;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- rect r, rr;
-
- TRACEDEVGA("circle");
- id = 2*radius + 0.5;
- if (id < 2) id = 2; /* diameter 1 is near-invisible */
-
- ix = (int) x;
- iy = (int) y;
- r = rr = rect(ix - id/2, iy - id/2, id, id);
-
- SetColor(gc->fill, gc->gamma, xd);
- if (R_OPAQUE(gc->fill)) {
- DRAW(gfillellipse(_d, xd->fgcolor, rr));
- } else if(R_ALPHA(gc->fill) > 0) {
- if (xd->have_alpha) {
- rect cp = xd->clip;
- /* Clip to the device region */
- if (r.x < 0) {r.x = 0; r.width = r.width + rr.x;}
- if (r.y < 0) {r.y = 0; r.height = r.height + rr.y;}
- if (r.x + r.width > cp.x + cp.width)
- r.width = cp.x + cp.width - r.x;
- if (r.y + r.height > cp.y + cp.height)
- r.height = cp.y + cp.height - r.y;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gfillellipse(xd->bm2, xd->fgcolor, rr);
- DRAW2(gc->fill);
- r = rr;
- } else WARN_SEMI_TRANS;
- }
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- DRAW(gdrawellipse(_d, xd->lwd, xd->fgcolor, rr, 0, xd->lend,
- xd->ljoin, xd->lmitre));
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- int adj, tol = xd->lwd; /* only half needed */
- rect cp = xd->clip;
- r.x -= tol; r.y -= tol; r.width += 2*tol; r.height += 2*tol;
- if (r.x < 0) {adj = r.x; r.x = 0; r.width = r.width + adj;}
- if (r.y < 0) {adj = r.y; r.y = 0; r.height = r.height + adj;}
- if (r.x + r.width > cp.x + cp.width)
- r.width = cp.x + cp.width - r.x;
- if (r.y + r.height > cp.y + cp.height)
- r.height = cp.y + cp.height - r.y;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gdrawellipse(xd->bm2, xd->lwd, xd->fgcolor, rr, 0, xd->lend,
- xd->ljoin, xd->lmitre);
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- SH;
-}
-
- /********************************************************/
- /* device_Line should have the side-effect that a single*/
- /* line is drawn (from x1,y1 to x2,y2) */
- /* x1, y1, x2, and y2 are in arbitrary coordinates and */
- /* the function is responsible for converting them to */
- /* DEVICE coordinates using GConvert */
- /********************************************************/
-
-static void GA_Line(double x1, double y1, double x2, double y2,
- const pGEcontext gc,
- pDevDesc dd)
-{
- int xx1, yy1, xx2, yy2;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- /* In-place conversion ok */
- TRACEDEVGA("line");
- xx1 = (int) x1;
- yy1 = (int) y1;
- xx2 = (int) x2;
- yy2 = (int) y2;
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- DRAW(gdrawline(_d, xd->lwd, xd->lty, xd->fgcolor,
- pt(xx1, yy1), pt(xx2, yy2), 0, xd->lend,
- xd->ljoin, xd->lmitre));
- SH;
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- rect r = xd->clip;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gdrawline(xd->bm2, xd->lwd, xd->lty, xd->fgcolor,
- pt(xx1, yy1), pt(xx2, yy2), 0, xd->lend,
- xd->ljoin, xd->lmitre);
- DRAW2(gc->col);
- SH;
- } else WARN_SEMI_TRANS;
- }
-}
-
- /********************************************************/
- /* device_Polyline should have the side-effect that a */
- /* series of line segments are drawn using the given x */
- /* and y values */
- /* the x and y values are in arbitrary coordinates and */
- /* the function is responsible for converting them to */
- /* DEVICE coordinates using GConvert */
- /********************************************************/
-
-static void GA_Polyline(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- const void *vmax = vmaxget();
- point *p = (point *) R_alloc(n, sizeof(point));
- double devx, devy;
- int i;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- TRACEDEVGA("pl");
- for (i = 0; i < n; i++) {
- devx = x[i];
- devy = y[i];
- p[i].x = (int) devx;
- p[i].y = (int) devy;
- }
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- DRAW(gdrawpolyline(_d, xd->lwd, xd->lty, xd->fgcolor, p, n, 0, 0,
- xd->lend, xd->ljoin, xd->lmitre));
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- rect r = xd->clip; /* lines can go well outside bbox of points */
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gdrawpolyline(xd->bm2, xd->lwd, xd->lty, xd->fgcolor, p, n, 0, 0,
- xd->lend, xd->ljoin, xd->lmitre);
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- vmaxset(vmax);
- SH;
-}
-
- /********************************************************/
- /* device_Polygon should have the side-effect that a */
- /* polygon is drawn using the given x and y values */
- /* the polygon border should be drawn in the "fg" */
- /* colour and filled with the "bg" colour */
- /* if "fg" is NA_INTEGER don't draw the border */
- /* if "bg" is NA_INTEGER don't fill the polygon */
- /* the x and y values are in arbitrary coordinates and */
- /* the function is responsible for converting them to */
- /* DEVICE coordinates using GConvert */
- /********************************************************/
-
-static void GA_Polygon(int n, double *x, double *y,
- const pGEcontext gc,
- pDevDesc dd)
-{
- const void *vmax = vmaxget();
- point *points;
- rect r;
- double devx, devy;
- int i, mx0 = 0, mx1 = 0, my0 = 0, my1 = 0;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- TRACEDEVGA("plg");
- points = (point *) R_alloc(n , sizeof(point));
- if (!points)
- return;
- for (i = 0; i < n; i++) {
- devx = x[i];
- devy = y[i];
- points[i].x = (int) (devx);
- points[i].y = (int) (devy);
- mx0 = imin2(mx0, points[i].x);
- mx1 = imax2(mx1, points[i].x);
- my0 = imin2(my0, points[i].y);
- my1 = imax2(my1, points[i].y);
- }
- r.x = mx0; r.width = mx1 - mx0;
- r.y = my0; r.height = my1 - my0;
-
- if (xd->doSetPolyFill && xd->fillOddEven == FALSE) {
- DRAW(gsetpolyfillmode(_d, 0));
- xd->doSetPolyFill = FALSE; /* Only set it once */
- }
-
- SetColor(gc->fill, gc->gamma, xd);
- if (R_OPAQUE(gc->fill)) {
- DRAW(gfillpolygon(_d, xd->fgcolor, points, n));
- } else if(R_ALPHA(gc->fill) > 0) {
- if(xd->have_alpha) {
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gfillpolygon(xd->bm2, xd->fgcolor, points, n);
- DRAW2(gc->fill);
- } else WARN_SEMI_TRANS;
- }
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- DRAW(gdrawpolygon(_d, xd->lwd, xd->lty, xd->fgcolor, points, n, 0,
- xd->lend, xd->ljoin, xd->lmitre));
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- r = xd->clip;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gdrawpolygon(xd->bm2, xd->lwd, xd->lty, xd->fgcolor, points, n, 0,
- xd->lend, xd->ljoin, xd->lmitre);
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- vmaxset(vmax);
- SH;
-}
-
-static void GA_Path(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- const pGEcontext gc,
- pDevDesc dd)
-{
- const void *vmax = vmaxget();
- point *points;
- point *pointIndex;
- rect r;
- double devx, devy;
- int i, mx0 = 0, mx1 = 0, my0 = 0, my1 = 0;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- int ntot = 0;
- for (i=0; i < npoly; i++) {
- ntot = ntot + nper[i];
- }
-
- TRACEDEVGA("path");
- points = (point *) R_alloc(ntot, sizeof(point));
- if (!points)
- return;
- for (i = 0; i < ntot; i++) {
- devx = x[i];
- devy = y[i];
- points[i].x = (int) (devx);
- points[i].y = (int) (devy);
- mx0 = imin2(mx0, points[i].x);
- mx1 = imax2(mx1, points[i].x);
- my0 = imin2(my0, points[i].y);
- my1 = imax2(my1, points[i].y);
- }
- r.x = mx0; r.width = mx1 - mx0;
- r.y = my0; r.height = my1 - my0;
-
- if (winding) {
- DRAW(gsetpolyfillmode(_d, 0));
- } else {
- DRAW(gsetpolyfillmode(_d, 1));
- }
-
- SetColor(gc->fill, gc->gamma, xd);
- if (R_OPAQUE(gc->fill)) {
- DRAW(gfillpolypolygon(_d, xd->fgcolor, points, npoly, nper));
- } else if(R_ALPHA(gc->fill) > 0) {
- if(xd->have_alpha) {
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- gfillpolypolygon(xd->bm2, xd->fgcolor, points, npoly, nper);
- DRAW2(gc->fill);
- } else WARN_SEMI_TRANS;
- }
-
- SetColor(gc->col, gc->gamma, xd);
- SetLineStyle(gc, dd);
- if (R_OPAQUE(gc->col)) {
- pointIndex = points;
- for (i = 0; i < npoly; i++) {
- DRAW(gdrawpolygon(_d, xd->lwd, xd->lty, xd->fgcolor,
- pointIndex, nper[i], 0,
- xd->lend, xd->ljoin, xd->lmitre));
- pointIndex = pointIndex + nper[i];
- }
- } else if(R_ALPHA(gc->col) > 0) {
- if(xd->have_alpha) {
- r = xd->clip;
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- pointIndex = points;
- for (i = 0; i < npoly; i++) {
- gdrawpolygon(xd->bm2, xd->lwd, xd->lty, xd->fgcolor,
- pointIndex, nper[i], 0,
- xd->lend, xd->ljoin, xd->lmitre);
- pointIndex = pointIndex + nper[i];
- }
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- vmaxset(vmax);
- SH;
-}
-
-static void doRaster(unsigned int *raster, int x, int y, int w, int h,
- double rot, pDevDesc dd)
-{
- const void *vmax = vmaxget();
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- rect dr = rect(x, y, w, h);
- image img;
- byte *imageData;
-
- TRACEDEVGA("raster");
-
- /* Create image object */
- img = newimage(w, h, 32);
-
- /* Set the image pixels from the raster.
- Windows uses 0xaarrggbb.
- AlphaBlend requires pre-multiplied alpha, that is it uses
- (src + (1-alpha)*dest) for each pixel colour.
- We could re-order the lines here (top to bottom) to avoid a copy
- in imagetobitmap.
- */
- imageData = (byte *) R_alloc(4*w*h, sizeof(byte));
- for (int i = 0; i < w*h; i++) {
- byte alpha = R_ALPHA(raster[i]);
- double fac = alpha/255.0;
- imageData[i*4 + 3] = alpha;
- imageData[i*4 + 2] = 0.49 + fac * R_RED(raster[i]);
- imageData[i*4 + 1] = 0.49 + fac * R_GREEN(raster[i]);
- imageData[i*4 + 0] = 0.49 + fac * R_BLUE(raster[i]);
- }
- setpixels(img, imageData);
- if(xd->kind != SCREEN) {
- gsetcliprect(xd->gawin, xd->clip);
- gcopyalpha2(xd->gawin, img, dr);
- } else {
- gsetcliprect(xd->bm, xd->clip);
- gcopyalpha2(xd->bm, img, dr);
- if(!xd->buffered)
- drawbits(xd);
- }
-
- /* Tidy up */
- delimage(img);
- SH;
- vmaxset(vmax);
-}
-
-static void flipRaster(unsigned int *rasterImage,
- int imageWidth, int imageHeight,
- int invertX, int invertY,
- unsigned int *flippedRaster) {
- int i, j;
- int rowInc, rowOff, colInc, colOff;
-
- if (invertX) {
- colInc = -1;
- colOff = imageWidth - 1;
- } else {
- colInc = 1;
- colOff = 0;
- }
- if (invertY) {
- rowInc = -1;
- rowOff = imageHeight - 1;
- } else {
- rowInc = 1;
- rowOff = 0;
- }
-
- for (i = 0; i < imageHeight ;i++) {
- for (j = 0; j < imageWidth; j++) {
- int row = (rowInc*i + rowOff);
- int col = (colInc*j + colOff);
- flippedRaster[i*imageWidth + j] =
- rasterImage[row*imageWidth + col];
- }
- }
-}
-
-static void GA_Raster(unsigned int *raster, int w, int h,
- double x, double y,
- double width, double height,
- double rot,
- Rboolean interpolate,
- const pGEcontext gc, pDevDesc dd)
-{
- const void *vmax = vmaxget();
- double angle = rot*M_PI/180;
- unsigned int *image = raster;
- int imageWidth = w, imageHeight = h;
- Rboolean invertX = FALSE;
- Rboolean invertY = TRUE;
-
- /* The alphablend code cannot handle negative width or height */
- if (height < 0) {
- height = -height;
- invertY = FALSE;
- }
- if (width < 0) {
- width = -width;
- invertX = TRUE;
- }
-
- if (interpolate) {
- int newW = (int) (width + .5), newH = (int) (height + .5);
- unsigned int *newRaster;
-
- newRaster = (unsigned int *) R_alloc(newW * newH,
- sizeof(unsigned int));
- R_GE_rasterInterpolate(image, w, h, newRaster, newW, newH);
- image = newRaster;
- imageWidth = newW;
- imageHeight = newH;
-
- } else {
- /* Even if not interpolating, have to explicitly scale here
- * before doing rotation, so that image to rotate
- * is the right size AND so that can adjust (x, y)
- * correctly
- */
- int newW = (int) (width + .5), newH = (int) (height + .5);
- unsigned int *newRaster;
-
- newRaster = (unsigned int *) R_alloc(newW * newH,
- sizeof(unsigned int));
- R_GE_rasterScale(image, w, h, newRaster, newW, newH);
- image = newRaster;
- imageWidth = newW;
- imageHeight = newH;
- }
-
- if (invertX) {
- /* convert (x, y) from bottom-left to top-left */
- x -= imageWidth*cos(angle);
- if (angle != 0) y -= imageWidth*sin(angle);
- }
- if (!invertY) {
- /* convert (x, y) from bottom-left to top-left */
- y -= imageHeight*cos(angle);
- if (angle != 0) x -= imageHeight*sin(angle);
- }
-
- if (angle != 0) {
- int newW, newH;
- double xoff, yoff;
- unsigned int *resizedRaster, *rotatedRaster;
-
- R_GE_rasterRotatedSize(imageWidth, imageHeight, angle, &newW, &newH);
- R_GE_rasterRotatedOffset(imageWidth, imageHeight, angle, 0,
- &xoff, &yoff);
-
- resizedRaster = (unsigned int *) R_alloc(newW * newH,
- sizeof(unsigned int));
- R_GE_rasterResizeForRotation(image, imageWidth, imageHeight,
- resizedRaster, newW, newH, gc);
-
- rotatedRaster = (unsigned int *) R_alloc(newW * newH,
- sizeof(unsigned int));
- R_GE_rasterRotate(resizedRaster, newW, newH, angle, rotatedRaster, gc,
- /* Threshold alpha to
- * transparent/opaque only
- */
- FALSE);
-
- /*
- * Adjust (x, y) for resized and rotated image
- */
- x -= (newW - imageWidth)/2 + xoff;
- y -= (newH - imageHeight)/2 - yoff;
-
- image = rotatedRaster;
- imageWidth = newW;
- imageHeight = newH;
- }
-
- if (invertX || invertY) {
- unsigned int *flippedRaster;
-
- flippedRaster = (unsigned int *) R_alloc(imageWidth * imageHeight,
- sizeof(unsigned int));
- flipRaster(image, imageWidth, imageHeight,
- invertX, invertY, flippedRaster);
- image = flippedRaster;
- }
-
- doRaster(image, (int) (x + .5), (int) (y + .5),
- imageWidth, imageHeight, rot, dd);
-
- vmaxset(vmax);
-}
-
-static SEXP GA_Cap(pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- SEXP dim, raster = R_NilValue;
- image img = NULL;
- byte *screenData;
-
- /* These in-place conversions are ok */
- TRACEDEVGA("cap");
-
- /* Only make sense for on-screen device */
- if(xd->kind == SCREEN) {
- img = bitmaptoimage(xd->gawin);
- if (imagedepth(img) == 8) img = convert8to32(img);
-
- if (img) {
- int width = imagewidth(img), height = imageheight(img),
- size = width*height;
- unsigned int *rint;
-
- screenData = getpixels(img);
-
- PROTECT(raster = allocVector(INTSXP, size));
-
- /* Copy each byte of screen to an R matrix.
- * The ARGB32 needs to be converted to R's ABGR32 */
- rint = (unsigned int *) INTEGER(raster);
- for (int i = 0; i < size; i++)
- rint[i] = R_RGBA(screenData[i*4 + 2],
- screenData[i*4 + 1],
- screenData[i*4 + 0],
- 255);
- PROTECT(dim = allocVector(INTSXP, 2));
- INTEGER(dim)[0] = height;
- INTEGER(dim)[1] = width;
- setAttrib(raster, R_DimSymbol, dim);
-
- UNPROTECT(2);
- }
-
- /* Tidy up */
- delimage(img);
- }
-
-
- return raster;
-}
-
- /********************************************************/
- /* device_Text should have the side-effect that the */
- /* given text is drawn at the given location */
- /* the text should be rotated according to rot (degrees)*/
- /* the location is in an arbitrary coordinate system */
- /* and this function is responsible for converting the */
- /* location to DEVICE coordinates using GConvert */
- /********************************************************/
-
-static void GA_Text0(double x, double y, const char *str, int enc,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- double pixs, xl, yl, rot1;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- pixs = - 1;
- xl = 0.0;
- yl = -pixs;
- rot1 = rot * DEG2RAD;
- x += -xl * cos(rot1) + yl * sin(rot1);
- y -= -xl * sin(rot1) - yl * cos(rot1);
-
- SetFont(gc, rot, xd);
- SetColor(gc->col, gc->gamma, xd);
- if (R_OPAQUE(gc->col)) {
- if(gc->fontface != 5) {
- /* As from 2.7.0 can use Unicode always */
- int n = strlen(str), cnt;
- R_CheckStack2(sizeof(wchar_t)*(n+1));
- wchar_t wc[n+1];/* only need terminator to debug */
- cnt = (enc == CE_UTF8) ?
- Rf_utf8towcs(wc, str, n+1): mbstowcs(wc, str, n);
- /* These macros need to be wrapped in braces */
- DRAW(gwdrawstr1(_d, xd->font, xd->fgcolor, pt(x, y),
- wc, cnt, hadj));
- } else {
- DRAW(gdrawstr1(_d, xd->font, xd->fgcolor, pt(x, y), str, hadj));
- }
- } else if(R_ALPHA(gc->col) > 0) {
- /* it is too hard to get a correct bounding box */
- if(xd->have_alpha) {
- rect r = xd->clip;
- r = getregion(xd);
- gsetcliprect(xd->bm, xd->clip);
- gcopy(xd->bm2, xd->bm, r);
- if(gc->fontface != 5) {
- int n = strlen(str), cnt;
- R_CheckStack2(sizeof(wchar_t)*(n+1));
- wchar_t wc[n+1];
- cnt = (enc == CE_UTF8) ?
- Rf_utf8towcs(wc, str, n+1): mbstowcs(wc, str, n);
- gwdrawstr1(xd->bm2, xd->font, xd->fgcolor, pt(x, y),
- wc, cnt, hadj);
- } else
- gdrawstr1(xd->bm2, xd->font, xd->fgcolor, pt(x, y), str, hadj);
- DRAW2(gc->col);
- } else WARN_SEMI_TRANS;
- }
- SH;
-}
-
-static void GA_Text(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- GA_Text0(x, y, str, CE_NATIVE, rot, hadj, gc, dd);
-}
-
-static void GA_Text_UTF8(double x, double y, const char *str,
- double rot, double hadj,
- const pGEcontext gc,
- pDevDesc dd)
-{
- GA_Text0(x, y, str, CE_UTF8, rot, hadj, gc, dd);
-}
-
-
- /********************************************************/
- /* device_Locator should return the location of the next*/
- /* mouse click (in DEVICE coordinates; GLocator is */
- /* responsible for any conversions) */
- /* not all devices will do anything (e.g., postscript) */
- /********************************************************/
-
-static void donelocator(void *data)
-{
- gadesc *xd;
- xd = (gadesc *)data;
- addto(xd->gawin);
- gchangemenubar(xd->mbar);
- if (xd->stoploc) {
- hide(xd->stoploc);
- show(xd->gawin);
- }
- gsetcursor(xd->gawin, ArrowCursor);
- gchangepopup(xd->gawin, xd->grpopup);
- addto(xd->gawin);
- setstatus(_("R Graphics"));
- xd->locator = FALSE;
-}
-
-static void GA_onExit(pDevDesc dd);
-
-static Rboolean GA_Locator(double *x, double *y, pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- RCNTXT cntxt;
-
- if (xd->kind != SCREEN)
- return FALSE;
- if (xd->holdlevel > 0)
- error(_("attempt to use the locator after dev.hold()"));
- xd->locator = TRUE;
- xd->clicked = 0;
- show(xd->gawin);
- addto(xd->gawin);
- gchangemenubar(xd->mbarloc);
- if (xd->stoploc) {
- show(xd->stoploc);
- show(xd->gawin);
- }
- gchangepopup(xd->gawin, xd->locpopup);
- gsetcursor(xd->gawin, CrossCursor);
- setstatus(G_("Locator is active"));
-
- /* set up a context which will clean up if there's an error */
- begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_NilValue, R_NilValue,
- R_NilValue, R_NilValue);
- cntxt.cend = &donelocator;
- cntxt.cenddata = xd;
- xd->cntxt = (void *) &cntxt;
-
- /* and an exit handler in case the window gets closed */
- dd->onExit = GA_onExit;
-
- while (!xd->clicked) {
- SH;
- R_WaitEvent();
- R_ProcessEvents();
- }
-
- dd->onExit = NULL;
- xd->cntxt = NULL;
-
- endcontext(&cntxt);
- donelocator((void *)xd);
-
- if (xd->clicked == 1) {
- *x = xd->px;
- *y = xd->py;
- return TRUE;
- } else
- return FALSE;
-}
-
- /********************************************************/
- /* device_Mode is called whenever the graphics engine */
- /* starts drawing (mode=1) or stops drawing (mode=0) */
- /* the device is not required to do anything */
- /********************************************************/
-
-/* Set Graphics mode - not needed for X11 */
-static void GA_Mode(int mode, pDevDesc dd)
-{
-}
-
-
- /********************************************************/
- /* the device-driver entry point is given a device */
- /* description structure that it must set up. this */
- /* involves several important jobs ... */
- /* (1) it must ALLOCATE a new device-specific parameters*/
- /* structure and FREE that structure if anything goes */
- /* wrong (i.e., it won't report a successful setup to */
- /* the graphics engine (the graphics engine is NOT */
- /* responsible for allocating or freeing device-specific*/
- /* resources or parameters) */
- /* (2) it must initialise the device-specific resources */
- /* and parameters (mostly done by calling device_Open) */
- /* (3) it must initialise the generic graphical */
- /* parameters that are not initialised by GInit (because*/
- /* only the device knows what values they should have) */
- /* see Graphics.h for the official list of these */
- /* (4) it may reset generic graphics parameters that */
- /* have already been initialised by GInit (although you */
- /* should know what you are doing if you do this) */
- /* (5) it must attach the device-specific parameters */
- /* structure to the device description structure */
- /* e.g., dd->deviceSpecific = (void *) xd; */
- /* (6) it must FREE the overall device description if */
- /* it wants to bail out to the top-level */
- /* the graphics engine is responsible for allocating */
- /* the device description and freeing it in most cases */
- /* but if the device driver freaks out it needs to do */
- /* the clean-up itself */
- /********************************************************/
-
-
-static
-Rboolean GADeviceDriver(pDevDesc dd, const char *display, double width,
- double height, double pointsize,
- Rboolean recording, int resize, int bg, int canvas,
- double gamma, int xpos, int ypos, Rboolean buffered,
- SEXP psenv, Rboolean restoreConsole,
- const char *title, Rboolean clickToConfirm,
- Rboolean fillOddEven, const char *family,
- int quality)
-{
- /* if need to bail out with some sort of "error" then */
- /* must free(dd) */
-
- int ps; /* This really is in (big) points */
- gadesc *xd;
- rect rr;
-
- /* allocate new device description */
- if (!(xd = (gadesc *) malloc(sizeof(gadesc)))) {
- warning("allocation failed in GADeviceDriver");
- return FALSE;
- }
-
- /* from here on, if need to bail out with "error", must also */
- /* free(xd) */
-
- ps = pointsize;
- if (ps < 1) ps = 12;
- /* Ensures a font is selected at first use */
- xd->font = NULL;
- xd->fontface = -1;
- xd->fontsize = -1;
- xd->fontangle = 0.0;
- xd->fontfamily[0] = '\0';
- xd->basefontsize = ps ;
- dd->startfont = 1;
- dd->startps = ps;
- dd->startlty = LTY_SOLID;
- dd->startgamma = gamma;
- xd->bm = NULL;
- xd->bm2 = NULL;
- xd->have_alpha = FALSE; /* selectively overridden in GA_Open */
- xd->warn_trans = FALSE;
- strncpy(xd->title, title, 101);
- xd->title[100] = '\0';
- strncpy(xd->basefontfamily, family, 101);
- xd->basefontfamily[100] = '\0';
- xd->fontquality = quality;
- xd->doSetPolyFill = TRUE; /* will only set it once */
- xd->fillOddEven = fillOddEven;
-
- /* Start the Device Driver and Hardcopy. */
-
- if (!GA_Open(dd, xd, display, width, height, recording, resize, canvas,
- gamma, xpos, ypos, bg)) {
- warning("opening device failed");
- free(xd);
- return FALSE;
- }
- dd->deviceSpecific = (void *) xd;
- /* Set up Data Structures */
-
- dd->close = GA_Close;
- dd->activate = GA_Activate;
- dd->deactivate = GA_Deactivate;
- dd->size = GA_Size;
- dd->newPage = GA_NewPage;
- dd->clip = GA_Clip;
- dd->strWidth = GA_StrWidth;
- dd->text = GA_Text;
- dd->rect = GA_Rect;
- dd->circle = GA_Circle;
- dd->line = GA_Line;
- dd->polyline = GA_Polyline;
- dd->polygon = GA_Polygon;
- dd->path = GA_Path;
- dd->raster = GA_Raster;
- dd->cap = GA_Cap;
- dd->locator = GA_Locator;
- dd->mode = GA_Mode;
- dd->metricInfo = GA_MetricInfo;
- dd->newFrameConfirm = clickToConfirm ? GA_NewFrameConfirm : NULL;
- dd->hasTextUTF8 = TRUE;
- dd->strWidthUTF8 = GA_StrWidth_UTF8;
- dd->textUTF8 = GA_Text_UTF8;
- dd->useRotatedTextInContour = TRUE;
- xd->cntxt = NULL;
- dd->holdflush = GA_holdflush;
- xd->holdlevel = 0;
-
- dd->haveRaster = 2; /* full support */
- dd->haveCapture = dd->haveLocator = (xd->kind == SCREEN) ? 2 : 1;
- dd->haveTransparency = 2;
- switch(xd->kind) {
- case SCREEN:
- dd->haveTransparentBg = 3;
- case PRINTER:
- case METAFILE:
- case PNG:
- dd->haveTransparentBg = 2;
- break;
- default: /* JPEG, BMP, TIFF */
- dd->haveTransparentBg = 1;
- break;
- }
- /* set graphics parameters that must be set by device driver */
- /* Window Dimensions in Pixels */
- rr = getrect(xd->gawin);
- dd->left = (xd->kind == PRINTER) ? rr.x : 0; /* left */
- dd->right = dd->left + rr.width - 0.0001; /* right */
- dd->top = (xd->kind == PRINTER) ? rr.y : 0; /* top */
- dd->bottom = dd->top + rr.height - 0.0001; /* bottom */
- dd->clipLeft = dd->left; dd->clipRight = dd->right;
- dd->clipBottom = dd->bottom; dd->clipTop = dd->top;
-
- if (resize == 3) { /* might have got a shrunken window */
- int iw = width/pixelWidth(NULL) + 0.5,
- ih = height/pixelHeight(NULL) + 0.5;
- xd->origWidth = dd->right = iw;
- xd->origHeight = dd->bottom = ih;
- }
-
- dd->startps = ps * xd->rescale_factor;
- if (xd->kind > METAFILE && xd->res_dpi > 0) ps *= xd->res_dpi/72.0;
-
- if (xd->kind <= METAFILE) {
- /* it is 12 *point*, not 12 pixel */
- double ps0 = ps * xd->rescale_factor;
- dd->cra[0] = 0.9 * ps0 * devicepixelsx(xd->gawin) / 72.0;
- dd->cra[1] = 1.2 * ps0 * devicepixelsy(xd->gawin) / 72.0;
- } else {
- dd->cra[0] = 0.9 * ps;
- dd->cra[1] = 1.2 * ps;
- }
-
- /* Character Addressing Offsets */
- /* These are used to plot a single plotting character */
- /* so that it is exactly over the plotting point */
-
- dd->xCharOffset = 0.50;
- dd->yCharOffset = 0.40;
- dd->yLineBias = 0.2;
-
- /* Inches per raster unit */
-
- if (xd->kind <= METAFILE) { /* non-screen devices set NA_real_ */
- if (R_FINITE(user_xpinch) && user_xpinch > 0.0)
- dd->ipr[0] = 1.0/user_xpinch;
- else
- dd->ipr[0] = pixelWidth(xd->gawin);
- if (R_FINITE(user_ypinch) && user_ypinch > 0.0)
- dd->ipr[1] = 1.0/user_ypinch;
- else
- dd->ipr[1] = pixelHeight(xd->gawin);
- } else if (xd->res_dpi > 0) {
- dd->ipr[0] = dd->ipr[1] = 1.0/xd->res_dpi;
- } else {
- dd->ipr[0] = dd->ipr[1] = 1.0/72.0;
- }
-
-
- /* Device capabilities */
- dd->canClip= TRUE;
- dd->canHAdj = 1; /* 0, 0.5, 1 */
- dd->canChangeGamma = FALSE;
-
- /* initialise device description (most of the work */
- /* has been done in GA_Open) */
-
- xd->resize = (resize == 3) || ismdi(); // MDI windows may be zoomed automatically
- xd->locator = FALSE;
- xd->buffered = buffered;
- xd->psenv = psenv;
- {
- SEXP timeouts = GetOption1(install("windowsTimeouts"));
- if(isInteger(timeouts)){
- xd->timeafter = INTEGER(timeouts)[0];
- xd->timesince = INTEGER(timeouts)[1];
- } else {
- warning(_("option 'windowsTimeouts' should be integer"));
- xd->timeafter = 100;
- xd->timesince = 500;
- }
- }
- dd->displayListOn = (xd->kind == SCREEN);
- if (RConsole && restoreConsole) show(RConsole);
- return TRUE;
-}
-
-SEXP savePlot(SEXP args)
-{
- SEXP filename, type;
- const char *fn, *tp; char display[550];
- int device;
- pDevDesc dd;
- Rboolean restoreConsole;
-
- args = CDR(args); /* skip entry point name */
- device = asInteger(CAR(args));
- if(device < 1 || device > NumDevices())
- error(_("invalid device number in 'savePlot'"));
- dd = GEgetDevice(device - 1)->dev;
- if(!dd) error(_("invalid device in 'savePlot'"));
- filename = CADR(args);
- if (!isString(filename) || LENGTH(filename) != 1)
- error(_("invalid filename argument in 'savePlot'"));
- /* in 2.8.0 this will always be passed as native, but be conserative */
- fn = translateChar(STRING_ELT(filename, 0));
- type = CADDR(args);
- if (!isString(type) || LENGTH(type) != 1)
- error(_("invalid type argument in 'savePlot'"));
- tp = CHAR(STRING_ELT(type, 0));
- restoreConsole = asLogical(CADDDR(args));
-
- if(!strcmp(tp, "png")) {
- SaveAsPng(dd, fn);
- } else if (!strcmp(tp,"bmp")) {
- SaveAsBmp(dd,fn);
- } else if (!strcmp(tp,"tiff")) {
- SaveAsTiff(dd,fn);
- } else if(!strcmp(tp, "jpeg") || !strcmp(tp,"jpg")) {
- /*Default quality suggested in libjpeg*/
- SaveAsJpeg(dd, 75, fn);
- } else if(!strcmp(tp, "tiff") || !strcmp(tp,"tif")) {
- SaveAsTiff(dd, fn);
- } else if (!strcmp(tp, "wmf") || !strcmp(tp, "emf")) {
- if(strlen(fn) > 512) {
- askok(G_("file path selected is too long: only 512 bytes are allowed"));
- return R_NilValue;
- }
- snprintf(display, 550, "win.metafile:%s", fn);
- SaveAsWin(dd, display, restoreConsole);
- } else if (!strcmp(tp, "ps") || !strcmp(tp, "eps")) {
- SaveAsPostscript(dd, fn);
- } else if (!strcmp(tp, "pdf")) {
- SaveAsPDF(dd, fn);
- } else
- error(_("unknown type in savePlot"));
- return R_NilValue;
-}
-
-
-static int png_rows = 0;
-
-static unsigned int privategetpixel2(void *d,int i, int j)
-{
- rgb c;
- c = ((rgb *)d)[i*png_rows + j];
- return c | 0xff000000;
-}
-
-/* This is the device version */
-/* Values of res > 0 are used to set the resolution in the file */
-static void SaveAsBitmap(pDevDesc dd, int res)
-{
- rect r, r2;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
- unsigned char *data;
-
- r = ggetcliprect(xd->gawin);
- gsetcliprect(xd->gawin, r2 = getrect(xd->gawin));
- if(xd->fp || xd->kind == TIFF) {
- getbitmapdata2(xd->gawin, &data);
- if(data) {
- png_rows = r2.width;
- if (xd->kind == PNG)
- R_SaveAsPng(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, xd->fp,
- R_OPAQUE(xd->bg) ? 0 : xd->pngtrans, res) ;
- else if (xd->kind == JPEG)
- R_SaveAsJpeg(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, xd->quality, xd->fp, res) ;
- else if (xd->kind == TIFF) {
- char buf[600];
- snprintf(buf, 600, xd->filename, xd->npage - 1);
- R_SaveAsTIFF(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, buf, res, xd->quality) ;
- } else
- R_SaveAsBmp(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, xd->fp, res);
- free(data);
- } else
- warning(_("processing of the plot ran out of memory"));
- if(xd->fp) fclose(xd->fp);
- }
- gsetcliprect(xd->gawin, r);
- xd->fp = NULL;
-}
-
-/* These are the menu item versions */
-static void SaveAsPng(pDevDesc dd, const char *fn)
-{
- FILE *fp;
- rect r, r2;
- unsigned char *data;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (!Load_Rbitmap_Dll()) return;
- if ((fp = R_fopen(fn, "wb")) == NULL) {
- char msg[MAX_PATH+32];
-
- strcpy(msg, "Impossible to open ");
- strncat(msg, fn, MAX_PATH);
- R_ShowMessage(msg);
- return;
- }
- r = ggetcliprect(xd->bm);
- gsetcliprect(xd->bm, r2 = getrect(xd->bm));
- getbitmapdata2(xd->bm, &data);
- if(data) {
- png_rows = r2.width;
- R_SaveAsPng(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, fp, 0, 0) ;
- free(data);
- } else
- warning(_("processing of the plot ran out of memory"));
- gsetcliprect(xd->bm, r);
- fclose(fp);
-}
-
-static void SaveAsJpeg(pDevDesc dd, int quality, const char *fn)
-{
- FILE *fp;
- rect r, r2;
- unsigned char *data;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (!Load_Rbitmap_Dll()) return;
- if ((fp = R_fopen(fn,"wb")) == NULL) {
- char msg[MAX_PATH+32];
- strcpy(msg, "Impossible to open ");
- strncat(msg, fn, MAX_PATH);
- R_ShowMessage(msg);
- return;
- }
- r = ggetcliprect(xd->bm);
- gsetcliprect(xd->bm, r2 = getrect(xd->bm));
- getbitmapdata2(xd->bm, &data);
- if(data) {
- png_rows = r2.width;
- R_SaveAsJpeg(data,xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, quality, fp, 0) ;
- free(data);
- } else
- warning(_("processing of the plot ran out of memory"));
- gsetcliprect(xd->bm, r);
- fclose(fp);
-}
-
-
-static void SaveAsBmp(pDevDesc dd, const char *fn)
-{
- FILE *fp;
- rect r, r2;
- unsigned char *data;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (!Load_Rbitmap_Dll()) return;
- if ((fp = R_fopen(fn, "wb")) == NULL) {
- char msg[MAX_PATH+32];
-
- strcpy(msg, _("Impossible to open "));
- strncat(msg, fn, MAX_PATH);
- R_ShowMessage(msg);
- return;
- }
- r = ggetcliprect(xd->bm);
- gsetcliprect(xd->bm, r2 = getrect(xd->bm));
-
- getbitmapdata2(xd->bm, &data);
- if(data) {
- png_rows = r2.width;
- R_SaveAsBmp(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, fp, 0) ;
- free(data);
- } else
- warning(_("processing of the plot ran out of memory"));
- gsetcliprect(xd->bm, r);
- fclose(fp);
-}
-
-static void SaveAsTiff(pDevDesc dd, const char *fn)
-{
- rect r, r2;
- unsigned char *data;
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- if (!Load_Rbitmap_Dll()) {
- R_ShowMessage(_("Impossible to load Rbitmap.dll"));
- return;
- }
- r = ggetcliprect(xd->bm);
- gsetcliprect(xd->bm, r2 = getrect(xd->bm));
-
- getbitmapdata2(xd->bm, &data);
- if(data) {
- png_rows = r2.width;
- R_SaveAsTIFF(data, xd->windowWidth, xd->windowHeight,
- privategetpixel2, 0, fn, 0, 1 /* no compression */) ;
- free(data);
- } else
- warning(_("processing of the plot ran out of memory"));
- gsetcliprect(xd->bm, r);
-}
-
-/* This is Guido's devga device, 'ga' for GraphApp. */
-
-#ifndef CLEARTYPE_QUALITY
-# define CLEARTYPE_QUALITY 5
-#endif
-
-SEXP devga(SEXP args)
-{
- pGEDevDesc gdd;
- const char *display, *title, *family;
- const void *vmax;
- double height, width, ps, xpinch, ypinch, gamma;
- int recording = 0, resize = 1, bg, canvas, xpos, ypos, buffered, quality;
- Rboolean restoreConsole, clickToConfirm, fillOddEven;
- SEXP sc, psenv;
-
- vmax = vmaxget();
- args = CDR(args); /* skip entry point name */
- display = CHAR(STRING_ELT(CAR(args), 0));
- args = CDR(args);
- width = asReal(CAR(args));
- args = CDR(args);
- height = asReal(CAR(args));
- args = CDR(args);
- if (width <= 0 || height <= 0)
- error(_("invalid 'width' or 'height'"));
- ps = asReal(CAR(args));
- args = CDR(args);
- recording = asLogical(CAR(args));
- if (recording == NA_LOGICAL)
- error(_("invalid value of '%s'"), "record");
- args = CDR(args);
- resize = asInteger(CAR(args));
- if (resize == NA_INTEGER)
- error(_("invalid value of '%s'"), "rescale");
- args = CDR(args);
- xpinch = asReal(CAR(args));
- args = CDR(args);
- ypinch = asReal(CAR(args));
- args = CDR(args);
- sc = CAR(args);
- if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
- error(_("invalid value of '%s'"), "canvas");
- canvas = RGBpar(sc, 0);
- args = CDR(args);
- gamma = asReal(CAR(args));
- args = CDR(args);
- xpos = asInteger(CAR(args)); /* used for res in png/jpeg/bmp */
- args = CDR(args);
- ypos = asInteger(CAR(args));
- args = CDR(args);
- buffered = asLogical(CAR(args));
- if (buffered == NA_LOGICAL)
- error(_("invalid value of '%s'"), "buffered");
- args = CDR(args);
- psenv = CAR(args);
- args = CDR(args);
- sc = CAR(args);
- if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
- error(_("invalid value of '%s'"), "bg");
- bg = RGBpar(sc, 0);
- args = CDR(args);
- restoreConsole = asLogical(CAR(args));
- args = CDR(args);
- sc = CAR(args);
- if (!isString(sc) || LENGTH(sc) != 1)
- error(_("invalid value of '%s'"), "title");
- title = CHAR(STRING_ELT(sc, 0));
- args = CDR(args);
- clickToConfirm = asLogical(CAR(args));
- args = CDR(args);
- fillOddEven = asLogical(CAR(args));
- if (fillOddEven == NA_LOGICAL)
- error(_("invalid value of '%s'"), "fillOddEven");
- args = CDR(args);
- sc = CAR(args);
- if (!isString(sc) || LENGTH(sc) != 1)
- error(_("invalid value of '%s'"), "family");
- family = CHAR(STRING_ELT(sc, 0));
- quality = DEFAULT_QUALITY;
- args = CDR(args);
- quality = asInteger(CAR(args));
-// printf("fontquality=%d\n", quality);
- switch (quality) {
- case 1: quality = DEFAULT_QUALITY; break;
- case 2: quality = NONANTIALIASED_QUALITY; break;
- case 3: quality = CLEARTYPE_QUALITY; break;
- case 4: quality = ANTIALIASED_QUALITY; break;
- default: quality = DEFAULT_QUALITY;
- }
-
- R_GE_checkVersionOrDie(R_GE_version);
- R_CheckDeviceAvailable();
- BEGIN_SUSPEND_INTERRUPTS {
- pDevDesc dev;
- char type[100];
- strcpy(type, "windows");
- if (display[0]) {
- strncpy(type, display, 100);
- // Package tkrplot assumes the exact form here
- if(strncmp(display, "win.metafile", 12)) {
- char *p = strchr(type, ':');
- if(p) *p = '\0';
- }
- }
- /* Allocate and initialize the device driver data */
- if (!(dev = (pDevDesc) calloc(1, sizeof(DevDesc)))) return 0;
- GAsetunits(xpinch, ypinch);
- if (!GADeviceDriver(dev, display, width, height, ps,
- (Rboolean)recording, resize, bg, canvas, gamma,
- xpos, ypos, (Rboolean)buffered, psenv,
- restoreConsole, title, clickToConfirm,
- fillOddEven, family, quality)) {
- free(dev);
- error(_("unable to start %s() device"), type);
- }
- gdd = GEcreateDevDesc(dev);
- GEaddDevice2(gdd, type);
- } END_SUSPEND_INTERRUPTS;
- vmaxset(vmax);
- return R_NilValue;
-}
-
-static void GA_onExit(pDevDesc dd)
-{
- gadesc *xd = (gadesc *) dd->deviceSpecific;
-
- dd->onExit = NULL;
- xd->confirmation = FALSE;
- dd->gettingEvent = FALSE;
-
- if (xd->cntxt) endcontext((RCNTXT *)xd->cntxt);
- if (xd->locator) donelocator((void *)xd);
-
- addto(xd->gawin);
- gchangemenubar(xd->mbar);
- gchangepopup(xd->gawin, xd->grpopup);
- addto(xd->gawin);
- setstatus(_("R Graphics"));
- GA_Activate(dd);
-}
-
-static Rboolean GA_NewFrameConfirm(pDevDesc dev)
-{
- char *msg;
- gadesc *xd = dev->deviceSpecific;
-
- if (!xd || xd->kind != SCREEN) return FALSE;
-
- msg = G_("Waiting to confirm page change...");
- xd->confirmation = TRUE;
- xd->clicked = 0;
- xd->enterkey = 0;
- show(xd->gawin);
- addto(xd->gawin);
- gchangemenubar(xd->mbarconfirm);
- gchangepopup(xd->gawin, NULL);
- setstatus(msg);
- R_WriteConsole(msg, strlen(msg));
- R_WriteConsole("\n", 1);
- R_FlushConsole();
- settext(xd->gawin, G_("Click or hit ENTER for next page"));
- BringToTop(xd->gawin, 0);
- dev->onExit = GA_onExit; /* install callback for cleanup */
- while (!xd->clicked && !xd->enterkey) {
- SH;
- R_WaitEvent();
- R_ProcessEvents(); /* May not return if user interrupts */
- }
- dev->onExit(dev);
-
- return TRUE;
-}
-
-static void GA_eventHelper(pDevDesc dd, int code)
-{
- gadesc *xd = dd->deviceSpecific;
-
- if (code == 1) {
- show(xd->gawin);
- addto(xd->gawin);
- gchangemenubar(xd->mbar);
- gchangepopup(xd->gawin, NULL);
- if (isEnvironment(dd->eventEnv)) {
- SEXP prompt = findVar(install("prompt"), dd->eventEnv);
- if (length(prompt) == 1) {
- setstatus(CHAR(asChar(prompt)));
- settext(xd->gawin, CHAR(asChar(prompt)));
- }
- }
- dd->onExit = GA_onExit; /* install callback for cleanup */
- } else if (code == 0)
- dd->onExit(dd);
-
- return;
-}
-
-
-static R_SaveAsBitmap R_devCairo;
-static int RcairoAlreadyLoaded = 0;
-static HINSTANCE hRcairoDll;
-
-static int Load_Rcairo_Dll()
-{
- if (!RcairoAlreadyLoaded) {
- char szFullPath[PATH_MAX];
- strcpy(szFullPath, R_HomeDir());
- strcat(szFullPath, "/library/grDevices/libs/");
- strcat(szFullPath, R_ARCH);
- strcat(szFullPath, "/winCairo.dll");
- if (((hRcairoDll = LoadLibrary(szFullPath)) != NULL) &&
- ((R_devCairo =
- (R_SaveAsBitmap)GetProcAddress(hRcairoDll, "in_Cairo"))
- != NULL)) {
- RcairoAlreadyLoaded = 1;
- } else {
- if (hRcairoDll != NULL) FreeLibrary(hRcairoDll);
- RcairoAlreadyLoaded = -1;
- char buf[1000];
- snprintf(buf, 1000, "Unable to load '%s'", szFullPath);
- R_ShowMessage(buf);
- }
- }
- return (RcairoAlreadyLoaded > 0);
-}
-
-/*
- cairo(filename, type, width, height, pointsize, bg, res, antialias, quality)
-*/
-SEXP devCairo(SEXP args)
-{
- if (!Load_Rcairo_Dll())
- error("unable to load winCairo.dll: was it built?");
- else (R_devCairo)(args);
- return R_NilValue;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devWindows.h b/com.oracle.truffle.r.native/library/grDevices/src/devWindows.h
deleted file mode 100644
index d6fc958ab52fdb576d4458f18cc5ce625c6f9976..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devWindows.h
+++ /dev/null
@@ -1,104 +0,0 @@
-/*
- * R : A Computer Langage for Statistical Data Analysis
- * Copyright (C) 1998--2003 Guido Masarotto and Brian Ripley
- * Copyright (C) 2004 The R Foundation
- *
- * 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 <R_ext/GraphicsEngine.h>
-#include <R_ext/Boolean.h>
-
-enum DeviceKinds {SCREEN=0, PRINTER, METAFILE, PNG, JPEG, BMP, TIFF};
-
-typedef struct {
- /* R Graphics Parameters */
- /* local device copy so that we can detect when parameter changes */
- int col; /* Color */
- int bg; /* Background */
- int fontface; /* Typeface */
- int fontsize, basefontsize; /* Size in points.
- fontsize has been adjusted
- for dpi diffs, basefontsize has not */
- double fontangle;
- char basefontfamily[500]; /* Initial font family */
-
- /* devga Driver Specific */
- /* parameters with copy per devga device */
-
- enum DeviceKinds kind;
- int windowWidth; /* Window width (pixels) */
- int windowHeight; /* Window height (pixels) */
- int showWidth; /* device width (pixels) */
- int showHeight; /* device height (pixels) */
- int origWidth, origHeight, xshift, yshift;
- Rboolean resize; /* Window resized */
- window gawin; /* Graphics window */
- /*FIXME: we should have union for this stuff and
- maybe change gawin to canvas*/
- /* SCREEN section*/
- popup locpopup, grpopup;
- button stoploc;
- menubar mbar, mbarloc, mbarconfirm;
- menu msubsave;
- menuitem mpng, mbmp, mjpeg50, mjpeg75, mjpeg100, mtiff;
- menuitem mps, mpdf, mwm, mclpbm, mclpwm, mprint, mclose;
- menuitem mrec, madd, mreplace, mprev, mnext, mclear, msvar, mgvar;
- menuitem mR, mfit, mfix, grmenustayontop, mnextplot;
- Rboolean recording, replaying, needsave;
- bitmap bm, bm2;
-
- /* PNG, JPEG, BMP, TIFF section */
- FILE *fp;
- char filename[512];
- int quality;
- int npage;
- int res_dpi; /* Values >0 recorded in the file */
-
- double w, h;
- rgb fgcolor; /* Foreground color */
- rgb bgcolor; /* Background color */
- rgb canvascolor; /* Canvas color */
- rgb outcolor; /* Outside canvas color */
- rect clip; /* The clipping rectangle */
- font font;
- char fontfamily[100];
- int fontquality;
-
- Rboolean locator;
- Rboolean confirmation;
-
- int clicked; /* {0,1,2} */
- int px, py, lty, lwd;
- int resizing; /* {1,2,3} */
- double rescale_factor;
- int fast; /* Use fast fixed-width lines? */
- unsigned int pngtrans; /* what PNG_TRANS get mapped to */
- Rboolean buffered;
- int timeafter, timesince;
- SEXP psenv;
- R_GE_lineend lend;
- R_GE_linejoin ljoin;
- float lmitre;
- Rboolean enterkey; /* Set true when enter key is hit */
- double lwdscale; /* scale factor for lwd */
- void *cntxt; /* context for unwinding on error */
- Rboolean have_alpha; /* support for AlphaBlend */
- Rboolean warn_trans; /* Warn on use of translucency if not supported */
- char title[101];
- Rboolean clickToConfirm; /* for NewFrameConfirm */
- Rboolean doSetPolyFill, fillOddEven; /* polygon fill mode */
- int holdlevel;
-} gadesc;
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/devices.c b/com.oracle.truffle.r.native/library/grDevices/src/devices.c
deleted file mode 100644
index 588757ae534314b6bf3c7d89c804b04da26df723..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/devices.c
+++ /dev/null
@@ -1,206 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--2013 The R Core Team
- * Copyright (C) 2002--2005 The R Foundation
- *
- * 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/
-
-
- * This is (a small part of) an extensive reworking by Paul Murrell
- * of an original quick hack by Ross Ihaka designed to give a
- * superset of the functionality in the AT&T Bell Laboratories GRZ
- * library.
- *
- */
-
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-#include "main_Graphics.h"
-#include "main_GraphicsBase.h"
-#include <R_ext/GraphicsEngine.h>
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#undef _
-#define _(String) dgettext ("grDevices", String)
-#else
-#define _(String) (String)
-#endif
-
-
-#define checkArity_length \
- args = CDR(args); \
- if(!LENGTH(CAR(args))) \
- error(_("argument must have positive length"))
-
-SEXP devcontrol(SEXP args)
-{
- int listFlag;
- pGEDevDesc gdd = GEcurrentDevice();
-
- args = CDR(args);
- listFlag = asLogical(CAR(args));
- if(listFlag == NA_LOGICAL) error(_("invalid argument"));
- GEinitDisplayList(gdd);
- gdd->displayListOn = listFlag ? TRUE: FALSE;
- return ScalarLogical(listFlag);
-}
-
-SEXP devdisplaylist(SEXP args)
-{
- pGEDevDesc gdd = GEcurrentDevice();
- return ScalarLogical(gdd->displayListOn);
-}
-
-SEXP devcopy(SEXP args)
-{
- checkArity_length;
- GEcopyDisplayList(INTEGER(CAR(args))[0] - 1);
- return R_NilValue;
-}
-
-SEXP devcur(SEXP args)
-{
- args = CDR(args);
- return ScalarInteger(curDevice() + 1);
-}
-
-SEXP devnext(SEXP args)
-{
- checkArity_length;
- return ScalarInteger( nextDevice(INTEGER(CAR(args))[0] - 1) + 1 );
-}
-
-SEXP devprev(SEXP args)
-{
- checkArity_length;
- return ScalarInteger( prevDevice(INTEGER(CAR(args))[0] - 1) + 1 );
-}
-
-SEXP devset(SEXP args)
-{
- checkArity_length;
- int devNum = INTEGER(CAR(args))[0] - 1;
- return ScalarInteger( selectDevice(devNum) + 1 );
-}
-
-SEXP devoff(SEXP args)
-{
- checkArity_length;
- killDevice(INTEGER(CAR(args))[0] - 1);
- return R_NilValue;
-}
-
-SEXP devsize(SEXP args)
-{
- SEXP ans;
- pDevDesc dd = GEcurrentDevice()->dev;
- double left, right, bottom, top;
-
- dd->size(&left, &right, &bottom, &top, dd);
- ans = allocVector(REALSXP, 2);
- REAL(ans)[0] = fabs(right - left);
- REAL(ans)[1] = fabs(bottom - top);
- return ans;
-}
-
-SEXP devholdflush(SEXP args)
-{
- pDevDesc dd = GEcurrentDevice()->dev;
-
- args = CDR(args);
- int level = asInteger(CAR(args));
- if(dd->holdflush && level != NA_INTEGER) level = (dd->holdflush(dd, level));
- else level = 0;
- return ScalarInteger(level);
-}
-
-SEXP devcap(SEXP args)
-{
- SEXP ans;
- int i = 0;
- pDevDesc dd = GEcurrentDevice()->dev;
-
- args = CDR(args);
-
- PROTECT(ans = allocVector(INTSXP, 9));
- INTEGER(ans)[i] = dd->haveTransparency;
- INTEGER(ans)[++i] = dd->haveTransparentBg;
- /* These will be NULL if the device does not define them */
- INTEGER(ans)[++i] = (dd->raster != NULL) ? dd->haveRaster : 1;
- INTEGER(ans)[++i] = (dd->cap != NULL) ? dd->haveCapture : 1;
- INTEGER(ans)[++i] = (dd->locator != NULL) ? dd->haveLocator : 1;
- INTEGER(ans)[++i] = (int)(dd->canGenMouseDown);
- INTEGER(ans)[++i] = (int)(dd->canGenMouseMove);
- INTEGER(ans)[++i] = (int)(dd->canGenMouseUp);
- INTEGER(ans)[++i] = (int)(dd->canGenKeybd);
- /* FIXME: there should be a way for a device to declare its own
- events, and return information on how to set them */
-
- UNPROTECT(1);
- return ans;
-}
-
-SEXP devcapture(SEXP args)
-{
- int i, col, row, nrow, ncol, size;
- Rboolean native;
- pGEDevDesc gdd = GEcurrentDevice();
- int *rint;
- SEXP raster, image, idim;
-
- args = CDR(args);
-
- native = asLogical(CAR(args));
- if (native != TRUE) native = FALSE;
-
- raster = GECap(gdd);
- if (isNull(raster)) /* NULL = unsupported */
- return raster;
-
- PROTECT(raster);
- if (native) {
- setAttrib(raster, R_ClassSymbol, mkString("nativeRaster"));
- UNPROTECT(1);
- return raster;
- }
-
- /* non-native, covert to color strings (this is based on grid.cap) */
- 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(3);
-
- return image;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/grDevices.h b/com.oracle.truffle.r.native/library/grDevices/src/grDevices.h
deleted file mode 100644
index ca7c213ef3448a590eac511186c74ec7ecc96be7..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/grDevices.h
+++ /dev/null
@@ -1,113 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2004-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/
- */
-
-#include <Rinternals.h>
-#include <R_ext/Boolean.h>
-#include <R_ext/GraphicsEngine.h> /* for DevDesc */
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#undef _
-#define _(String) dgettext ("grDevices", String)
-#else
-#define _(String) (String)
-#endif
-
-SEXP R_CreateAtVector(SEXP axp, SEXP usr, SEXP nint, SEXP is_log);
-SEXP R_GAxisPars(SEXP usr, SEXP is_log, SEXP nintLog);
-
-SEXP PicTeX(SEXP);
-
-SEXP PostScript(SEXP);
-SEXP XFig(SEXP);
-SEXP PDF(SEXP);
-SEXP Type1FontInUse(SEXP, SEXP);
-SEXP CIDFontInUse(SEXP, SEXP);
-
-#ifndef _WIN32
-SEXP Quartz(SEXP);
-SEXP makeQuartzDefault();
-
-SEXP X11(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP savePlot(SEXP call, SEXP op, SEXP args, SEXP rho);
-#endif
-
-SEXP devCairo(SEXP);
-
-Rboolean
-PSDeviceDriver(pDevDesc, const char*, const char*, const char*,
- const char **, const char*, const char*, const char*,
- double, double, Rboolean, double, Rboolean, Rboolean,
- Rboolean, const char*, const char*, SEXP, const char*, int,
- Rboolean);
-
-Rboolean
-PDFDeviceDriver(pDevDesc, const char *, const char *, const char *,
- const char **, const char *, const char *, const char *,
- double, double, double, int, int, const char*, SEXP,
- int, int, const char *, int, int, Rboolean, Rboolean);
-
-#ifdef _WIN32
-SEXP devga(SEXP);
-SEXP savePlot(SEXP);
-SEXP bringToTop(SEXP, SEXP);
-SEXP msgWindow(SEXP, SEXP);
-#endif
-
-SEXP devcap(SEXP args);
-SEXP devcapture(SEXP args);
-SEXP devcontrol(SEXP args);
-SEXP devcopy(SEXP args);
-SEXP devcur(SEXP args);
-SEXP devdisplaylist(SEXP args);
-SEXP devholdflush(SEXP args);
-SEXP devnext(SEXP args);
-SEXP devoff(SEXP args);
-SEXP devprev(SEXP args);
-SEXP devset(SEXP args);
-SEXP devsize(SEXP args);
-
-SEXP chull(SEXP x);
-
-SEXP contourLines(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP getSnapshot(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP playSnapshot(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP getGraphicsEventEnv(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP setGraphicsEventEnv(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP devAskNewPage(SEXP call, SEXP op, SEXP args, SEXP env);
-
-#ifndef DEVWINDOWS
-SEXP rgb(SEXP r, SEXP g, SEXP b, SEXP a, SEXP MCV, SEXP nam);
-SEXP hsv(SEXP h, SEXP s, SEXP v, SEXP a);
-SEXP hcl(SEXP h, SEXP c, SEXP l, SEXP a, SEXP sfixup);
-SEXP gray(SEXP lev, SEXP a);
-SEXP colors(void);
-SEXP col2rgb(SEXP colors, SEXP alpha);
-SEXP palette(SEXP value);
-SEXP palette2(SEXP value);
-SEXP RGB2hsv(SEXP rgb);
-#endif
-
-unsigned int inRGBpar3(SEXP, int, unsigned int);
-const char *incol2name(unsigned int col);
-unsigned int inR_GE_str2col(const char *s);
-void initPalette(void);
-
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/gzio.c b/com.oracle.truffle.r.native/library/grDevices/src/gzio.c
new file mode 100644
index 0000000000000000000000000000000000000000..d8573c6d2eb975da612f1c74a32be3b1bf397676
--- /dev/null
+++ b/com.oracle.truffle.r.native/library/grDevices/src/gzio.c
@@ -0,0 +1,19 @@
+/*
+ * This material is distributed under the GNU General Public License
+ * Version 2. You may review the terms of this license at
+ * http://www.gnu.org/licenses/gpl-2.0.html
+ *
+ * Copyright (c) 1995, 1996, 1997 Robert Gentleman and Ross Ihaka
+ * Copyright (c) 1995-2014, The R Core Team
+ * Copyright (c) 2002-2008, The R Foundation
+ * Copyright (c) 2015, Oracle and/or its affiliates
+ *
+ * All rights reserved.
+ */
+
+// This simply includes gzio.h (which actually contains code)
+
+#define f_tell ftell
+#define warning Rf_warning
+
+#include GNUR_GZIO_H
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/init.c b/com.oracle.truffle.r.native/library/grDevices/src/init.c
deleted file mode 100644
index ae8283662173f73336a8b2026369705ab694345a..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/init.c
+++ /dev/null
@@ -1,140 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2004-13 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/
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <R.h>
-#include <Rinternals.h>
-#include <R_ext/GraphicsEngine.h>
-
-#include "grDevices.h"
-#include <R_ext/Rdynload.h>
-
-#ifndef _WIN32
-/* This really belongs with the X11 module, but it is about devices */
-static SEXP cairoProps(SEXP in)
-{
- int which = asInteger(in);
- if(which == 1)
- return ScalarLogical(
-#ifdef HAVE_WORKING_CAIRO
- 1
-#else
- 0
-#endif
- );
- else if(which == 2)
- return ScalarLogical(
-#ifdef HAVE_PANGOCAIRO
- 1
-#else
- 0
-#endif
- );
- return R_NilValue;
-}
-#endif
-
-#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
-
-static const R_CallMethodDef CallEntries[] = {
- CALLDEF(Type1FontInUse, 2),
- CALLDEF(CIDFontInUse, 2),
- CALLDEF(R_CreateAtVector, 4),
- CALLDEF(R_GAxisPars, 3),
- CALLDEF(chull, 1),
- CALLDEF(gray, 2),
- CALLDEF(RGB2hsv, 1),
- CALLDEF(rgb, 6),
- CALLDEF(hsv, 4),
- CALLDEF(hcl, 5),
- CALLDEF(col2rgb, 2),
- CALLDEF(colors, 0),
- CALLDEF(palette, 1),
- CALLDEF(palette2, 1),
-
-#ifndef _WIN32
- CALLDEF(makeQuartzDefault, 0),
- CALLDEF(cairoProps, 1),
-#else
- CALLDEF(bringToTop, 2),
- CALLDEF(msgWindow, 2),
-#endif
- {NULL, NULL, 0}
-};
-
-#define EXTDEF(name, n) {#name, (DL_FUNC) &name, n}
-
-static const R_ExternalMethodDef ExtEntries[] = {
- EXTDEF(PicTeX, 6),
- EXTDEF(PostScript, 19),
- EXTDEF(XFig, 14),
- EXTDEF(PDF, 20),
- EXTDEF(devCairo, 10),
- EXTDEF(devcap, 0),
- EXTDEF(devcapture, 1),
- EXTDEF(devcontrol, 1),
- EXTDEF(devcopy, 1),
- EXTDEF(devcur, 0),
- EXTDEF(devdisplaylist, 0),
- EXTDEF(devholdflush, 1),
- EXTDEF(devnext, 1),
- EXTDEF(devoff, 1),
- EXTDEF(devprev, 1),
- EXTDEF(devset, 1),
- EXTDEF(devsize, 0),
- EXTDEF(contourLines, 4),
- EXTDEF(getSnapshot, 0),
- EXTDEF(playSnapshot, 1),
- EXTDEF(getGraphicsEvent, 1),
- EXTDEF(getGraphicsEventEnv, 1),
- EXTDEF(setGraphicsEventEnv, 2),
- EXTDEF(devAskNewPage, 1),
-
-#ifdef _WIN32
- EXTDEF(savePlot, 4),
- EXTDEF(devga, 21),
-#else
- EXTDEF(savePlot, 3),
- EXTDEF(Quartz, 11),
- EXTDEF(X11, 17),
-#endif
- {NULL, NULL, 0}
-};
-
-#ifdef HAVE_AQUA
-extern void setup_RdotApp(void);
-extern Rboolean useaqua;
-#endif
-
-void R_init_grDevices(DllInfo *dll)
-{
- initPalette();
- R_registerRoutines(dll, NULL, CallEntries, NULL, ExtEntries);
- R_useDynamicSymbols(dll, FALSE);
- R_forceSymbols(dll, TRUE);
-
-#ifdef HAVE_AQUA
-/* R.app will run event loop, so if we are running under that we don't
- need to run one here */
- if(useaqua) setup_RdotApp();
-#endif
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_Fileio.h b/com.oracle.truffle.r.native/library/grDevices/src/main_Fileio.h
deleted file mode 100644
index a94b17beec5e05aac349c66dd12dfa6ad932a409..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_Fileio.h
+++ /dev/null
@@ -1,28 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * 2007 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/
- */
-
-#ifndef RFILEIO_H_
-
-#define RFILEIO_H_
-
-int R_fgetc(FILE*);
-FILE * R_fopen(const char *filename, const char *mode);
-
-#endif
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_Graphics.h b/com.oracle.truffle.r.native/library/grDevices/src/main_Graphics.h
deleted file mode 100644
index f7c6940a47b91c03d8ce53ba2616f900a7e51559..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_Graphics.h
+++ /dev/null
@@ -1,309 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1998--2012 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/
- */
-
-#ifndef GRAPHICS_H_
-#define GRAPHICS_H_
-
-/* This is a private header */
-
-#include <R_ext/Boolean.h>
-
-#include <R_ext/GraphicsEngine.h>
-/* needed for R_GE_lineend/join, R_GE_gcontext */
-
-#define R_GRAPHICS 1
-#include "main_Rgraphics.h" /* RUnit */
-
-//typedef unsigned int rcolor;
-
-/* base.c, graphics.c, par.c */
-#define MAX_LAYOUT_ROWS 200
-#define MAX_LAYOUT_COLS 200
-#define MAX_LAYOUT_CELLS 10007 /* must be less than 65535,
- 3 copies, 3bytes each */
-
-typedef struct {
- double ax;
- double bx;
- double ay;
- double by;
-} GTrans;
-
-typedef struct {
- /* Plot State */
- /*
- When the device driver is started this is 0
- After the first call to plot.new/perps it is 1
- Every graphics operation except plot.new/persp
- should fail if state = 0
- This is checked at the highest internal function
- level (e.g., do_lines, do_axis, do_plot_xy, ...)
- */
-
- int state; /* plot state: 1 if GNewPlot has been called
- (by plot.new or persp) */
- Rboolean valid; /* valid layout ? Used in GCheckState & do_playDL */
-
- /* GRZ-like Graphics Parameters */
- /* ``The horror, the horror ... '' */
- /* Marlon Brando - Appocalypse Now */
-
- /* General Parameters -- set and interrogated directly */
-
- double adj; /* String adjustment */
- Rboolean ann; /* Should annotation take place */
- rcolor bg; /* **R ONLY** Background color */
- char bty; /* Box type */
- double cex; /* Character expansion */
- double lheight; /* Line height
- The height of a line of text is:
- ps * cex * lheight */
- rcolor col; /* Plotting Color */
- double crt; /* Character/string rotation */
- double din[2]; /* device size in inches */
- int err; /* Error repporting level */
- rcolor fg; /* **R ONLY** Foreground Color */
- char family[201]; /* **R ONLY** Font family
- Simple name which is mapped by device-specific
- font database to device-specific name.
- Only used if not "".
- Default is "".
- Ignored by some devices. */
- int font; /* Text font */
- double gamma; /* Device Gamma Correction */
- int lab[3]; /* Axis labelling */
- /* [0] = # ticks on x-axis */
- /* [1] = # ticks on y-axis */
- /* [2] = length of axis labels */
- int las; /* Label style (rotation) */
- int lty; /* Line texture */
- double lwd; /* Line width */
- R_GE_lineend lend; /* **R ONLY** Line end style */
- R_GE_linejoin ljoin;/* **R ONLY** Line join style */
- double lmitre; /* **R ONLY** Line mitre limit */
- double mgp[3]; /* Annotation location */
- /* [0] = location of axis title */
- /* [1] = location of axis label */
- /* [2] = location of axis line */
- double mkh; /* Mark size in inches */
- int pch; /* Plotting character */
- /* Note that ps is never changed, so always the same as dev->startps.
- However, the ps in the graphics context is changed */
- double ps; /* Text & symbol pointsize */
- int smo; /* Curve smoothness */
- double srt; /* String Rotation */
- double tck; /* Tick size as in S */
- double tcl; /* Tick size in "lines" */
- double xaxp[3]; /* X Axis annotation */
- /* [0] = coordinate of lower tick */
- /* [1] = coordinate of upper tick */
- /* [2] = num tick intervals */
- /* almost always used internally */
- char xaxs; /* X Axis style */
- char xaxt; /* X Axis type */
- Rboolean xlog; /* Log Axis for X */
- int xpd; /* Clip to plot region indicator */
- int oldxpd;
- double yaxp[3]; /* Y Axis annotation */
- char yaxs; /* Y Axis style */
- char yaxt; /* Y Axis type */
- Rboolean ylog; /* Log Axis for Y */
-
- /* Annotation Parameters */
-
- double cexbase; /* Base character size */
- double cexmain; /* Main title size */
- double cexlab; /* xlab and ylab size */
- double cexsub; /* Sub title size */
- double cexaxis; /* Axis label size */
-
- int fontmain; /* Main title font */
- int fontlab; /* Xlab and ylab font */
- int fontsub; /* Subtitle font */
- int fontaxis; /* Axis label fonts */
-
- rcolor colmain; /* Main title color */
- rcolor collab; /* Xlab and ylab color */
- rcolor colsub; /* Subtitle color */
- rcolor colaxis; /* Axis label color */
-
- /* Layout Parameters */
-
- Rboolean layout; /* has a layout been specified */
-
- int numrows;
- int numcols;
- int currentFigure;
- int lastFigure;
- double heights[MAX_LAYOUT_ROWS];
- double widths[MAX_LAYOUT_COLS];
- int cmHeights[MAX_LAYOUT_ROWS];
- int cmWidths[MAX_LAYOUT_COLS];
- unsigned short order[MAX_LAYOUT_CELLS];
- int rspct; /* 0 = none, 1 = full, 2 = see respect */
- unsigned char respect[MAX_LAYOUT_CELLS];
-
- int mfind; /* By row/col indicator */
-
- /* Layout parameters which can be set directly by the */
- /* user (e.g., par(fig=c(.5,1,0,1))) or otherwise are */
- /* calculated automatically */
- /* NOTE that *Units parameters are for internal use only */
-
- double fig[4]; /* (current) Figure size (proportion) */
- /* [0] = left, [1] = right */
- /* [2] = bottom, [3] = top */
- double fin[2]; /* (current) Figure size (inches) */
- /* [0] = width, [1] = height */
- GUnit fUnits; /* (current) figure size units */
- double plt[4]; /* (current) Plot size (proportions) */
- /* [0] = left, [1] = right */
- /* [2] = bottom, [3] = top */
- double pin[2]; /* (current) plot size (inches) */
- /* [0] = width, [1] = height */
- GUnit pUnits; /* (current) plot size units */
- Rboolean defaultFigure; /* calculate figure from layout ? */
- Rboolean defaultPlot; /* calculate plot from figure - margins ? */
-
- /* Layout parameters which are set directly by the user */
-
- double mar[4]; /* Plot margins in lines */
- double mai[4]; /* Plot margins in inches */
- /* [0] = bottom, [1] = left */
- /* [2] = top, [3] = right */
- GUnit mUnits; /* plot margin units */
- double mex; /* Margin expansion factor */
- double oma[4]; /* Outer margins in lines */
- double omi[4]; /* outer margins in inches */
- double omd[4]; /* outer margins in NDC */
- /* [0] = bottom, [1] = left */
- /* [2] = top, [3] = right */
- GUnit oUnits; /* outer margin units */
- char pty; /* Plot type */
-
- /* Layout parameters which can be set by the user, but */
- /* almost always get automatically calculated anyway */
-
- double usr[4]; /* Graphics window */
- /* [0] = xmin, [1] = xmax */
- /* [2] = ymin, [3] = ymax */
-
- /* The logged usr parameter; if xlog, use logusr[0:1] */
- /* if ylog, use logusr[2:3] */
-
- double logusr[4];
-
- /* Layout parameter: Internal flags */
-
- Rboolean new; /* Clean plot ? */
- int devmode; /* creating new image or adding to existing one */
-
- /* Coordinate System Mappings */
- /* These are only used internally (i.e., cannot be */
- /* set directly by the user) */
-
- /* The reliability of these parameters relies on */
- /* the fact that plot.new is the */
- /* first graphics operation called in the creation */
- /* of a graph (unless it is a call to persp) */
-
- /* udpated per plot.new */
-
- double xNDCPerChar; /* Nominal character width (NDC) */
- double yNDCPerChar; /* Nominal character height (NDC) */
- double xNDCPerLine; /* Nominal line width (NDC) */
- double yNDCPerLine; /* Nominal line height (NDC) */
- double xNDCPerInch; /* xNDC -> Inches */
- double yNDCPerInch; /* yNDC -> Inches */
-
- /* updated per plot.new and if inner2dev changes */
-
- GTrans fig2dev; /* Figure to device */
-
- /* udpated per DevNewPlot and if ndc2dev changes */
-
- GTrans inner2dev; /* Inner region to device */
-
- /* udpated per device resize */
-
- GTrans ndc2dev; /* NDC to raw device */
-
- /* updated per plot.new and per plot.window */
-
- GTrans win2fig; /* Window to figure mapping */
-
- /* NOTE: if user has not set fig and/or plt then */
- /* they need to be updated per plot.new too */
-
- double scale; /* An internal "zoom" factor to apply to ps and lwd */
- /* (for fit-to-window resizing in Windows) */
-} GPar;
-
-/* always remap private functions */
-#define copyGPar Rf_copyGPar
-#define FixupCol Rf_FixupCol
-#define FixupLty Rf_FixupLty
-#define FixupLwd Rf_FixupLwd
-#define FixupVFont Rf_FixupVFont
-#define GInit Rf_GInit
-#define labelformat Rf_labelformat
-#define ProcessInlinePars Rf_ProcessInlinePars
-#define recordGraphicOperation Rf_recordGraphicOperation
-
-/* NOTE: during replays, call == R_NilValue;
- ---- the following adds readability: */
-Rboolean GRecording(SEXP, pGEDevDesc);
-
-/* Default the settings for general graphical parameters
- * (i.e., defaults that do not depend on the device type: */
-void GInit(GPar*);
-
-void copyGPar(GPar *, GPar *);
-
- /* from graphics.c, used in par.c */
-double R_Log10(double);
-
-/* from par.c, called in plot.c, plot3d.c */
-void ProcessInlinePars(SEXP, pGEDevDesc);
-
-/* from device.c */
-void recordGraphicOperation(SEXP, SEXP, pGEDevDesc);
-
-/* some functions that plot.c needs to share with plot3d.c */
-SEXP FixupCol(SEXP, unsigned int);
-SEXP FixupLty(SEXP, int);
-SEXP FixupLwd(SEXP, double);
-SEXP FixupVFont(SEXP);
-SEXP labelformat(SEXP);
-
-/*
- * Function to generate an R_GE_gcontext from Rf_gpptr info
- *
- * from graphics.c, used in plot.c, plotmath.c
- */
-void gcontextFromGP(pGEcontext gc, pGEDevDesc dd);
-
-/* From base.c */
-#define gpptr Rf_gpptr
-#define dpptr Rf_dpptr
-GPar* Rf_gpptr(pGEDevDesc dd);
-GPar* Rf_dpptr(pGEDevDesc dd);
-
-#endif /* GRAPHICS_H_ */
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_GraphicsBase.h b/com.oracle.truffle.r.native/library/grDevices/src/main_GraphicsBase.h
deleted file mode 100644
index 6344ab777d44316ed3dbffe8a8d6967bec8a520d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_GraphicsBase.h
+++ /dev/null
@@ -1,44 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-8 The R Core Team.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation; either version 2.1 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 Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, a copy is available at
- * http://www.r-project.org/Licenses/
- */
-
-/* Definitions for the base graphics system.
- So should be private.
- */
-
-#ifndef R_GRAPHICSBASE_H_
-#define R_GRAPHICSBASE_H_
-
-typedef struct {
- GPar dp; /* current device default parameters:
- those which will be used at the next GNewPage */
- GPar gp; /* current device current parameters */
- GPar dpSaved; /* saved device default parameters:
- graphics state at the time that the currently
- displayed plot was started, so we can replay
- the display list.
- */
- Rboolean baseDevice; /* Has the device received base output? */
-} baseSystemState;
-
-void registerBase(void); /* used in devices.c */
-void unregisterBase(void); /* used in devices.c */
-
-void Rf_setBaseDevice(Rboolean val, pGEDevDesc dd); /* used in graphics.c */
-
-#endif /* R_GRAPHICSBASE_ */
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_Rgraphics.h b/com.oracle.truffle.r.native/library/grDevices/src/main_Rgraphics.h
deleted file mode 100644
index 0dcd6bb37f105ddd39fc60f5e070d11750f9879c..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_Rgraphics.h
+++ /dev/null
@@ -1,289 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1998--2008 R Core Team
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU Lesser General Public License as published by
- * the Free Software Foundation; either version 2.1 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 Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public License
- * along with this program; if not, a copy is available at
- * http://www.r-project.org/Licenses/
- */
-
-#ifndef RGRAPHICS_H_
-#define RGRAPHICS_H_
-
-/* This was a public header in R < 2.8.0, but no longer */
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
- /* possible coordinate systems (for specifying locations) */
-typedef enum {
- DEVICE = 0, /* native device coordinates (rasters) */
- NDC = 1, /* normalised device coordinates x=(0,1), y=(0,1) */
- INCHES = 13, /* inches x=(0,width), y=(0,height) */
- NIC = 6, /* normalised inner region coordinates (0,1) */
- OMA1 = 2, /* outer margin 1 (bottom) x=NIC, y=LINES */
- OMA2 = 3, /* outer margin 2 (left) */
- OMA3 = 4, /* outer margin 3 (top) */
- OMA4 = 5, /* outer margin 4 (right) */
- NFC = 7, /* normalised figure region coordinates (0,1) */
- NPC = 16, /* normalised plot region coordinates (0,1) */
- USER = 12, /* user/data/world coordinates;
- * x,=(xmin,xmax), y=(ymin,ymax) */
- MAR1 = 8, /* figure margin 1 (bottom) x=USER(x), y=LINES */
- MAR2 = 9, /* figure margin 2 (left) x=USER(y), y=LINES */
- MAR3 = 10, /* figure margin 3 (top) x=USER(x), y=LINES */
- MAR4 = 11, /* figure margin 4 (right) x=USER(y), y=LINES */
-
- /* possible, units (for specifying dimensions) */
- /* all of the above, plus ... */
-
- LINES = 14, /* multiples of a line in the margin (mex) */
- CHARS = 15 /* multiples of text height (cex) */
-} GUnit;
-
-
-#define currentFigureLocation Rf_currentFigureLocation
-#define GArrow Rf_GArrow
-#define GBox Rf_GBox
-#define GCheckState Rf_GCheckState
-#define GCircle Rf_GCircle
-#define GClip Rf_GClip
-#define GClipPolygon Rf_GClipPolygon
-#define GConvert Rf_GConvert
-#define GConvertX Rf_GConvertX
-#define GConvertXUnits Rf_GConvertXUnits
-#define GConvertY Rf_GConvertY
-#define GConvertYUnits Rf_GConvertYUnits
-#define GExpressionHeight Rf_GExpressionHeight
-#define GExpressionWidth Rf_GExpressionWidth
-#define GForceClip Rf_GForceClip
-#define GLine Rf_GLine
-#define GLocator Rf_GLocator
-#define GMapUnits Rf_GMapUnits
-#define GMapWin2Fig Rf_GMapWin2Fig
-#define GMathText Rf_GMathText
-#define GMetricInfo Rf_GMetricInfo
-#define GMMathText Rf_GMMathText
-#define GMode Rf_GMode
-#define GMtext Rf_GMtext
-#define GNewPlot Rf_GNewPlot
-#define GPath Rf_GPath
-#define GPolygon Rf_GPolygon
-#define GPolyline Rf_GPolyline
-#define GPretty Rf_GPretty
-#define GRect Rf_GRect
-#define GRaster Rf_GRaster
-#define GReset Rf_GReset
-#define GRestore Rf_GRestore
-#define GRestorePars Rf_GRestorePars
-#define GSavePars Rf_GSavePars
-#define GScale Rf_GScale
-#define GSetState Rf_GSetState
-#define GSetupAxis Rf_GSetupAxis
-#define GStrHeight Rf_GStrHeight
-#define GStrWidth Rf_GStrWidth
-#define GSymbol Rf_GSymbol
-#define GText Rf_GText
-#define GVStrHeight Rf_GVStrHeight
-#define GVStrWidth Rf_GVStrWidth
-#define GVText Rf_GVText
-
-#define xDevtoNDC Rf_xDevtoNDC
-#define xDevtoNFC Rf_xDevtoNFC
-#define xDevtoNPC Rf_xDevtoNPC
-#define xDevtoUsr Rf_xDevtoUsr
-#define xNPCtoUsr Rf_xNPCtoUsr
-#define yDevtoNDC Rf_yDevtoNDC
-#define yDevtoNFC Rf_yDevtoNFC
-#define yDevtoNPC Rf_yDevtoNPC
-#define yDevtoUsr Rf_yDevtoUsr
-#define yNPCtoUsr Rf_yNPCtoUsr
-
-
-/*-------------------------------------------------------------------
- *
- * GPAR FUNCTIONS are concerned with operations on the
- * entire set of graphics parameters for a device
- * (e.g., initialisation, saving, and restoring)
- *
- * From graphics.c, used in plot.c.
- */
-
-/* Reset the current graphical parameters from the default ones: */
-void GRestore(pGEDevDesc);
-/* Make a temporary copy of the current parameters */
-void GSavePars(pGEDevDesc);
-/* Restore the temporary copy saved by GSavePars */
-void GRestorePars(pGEDevDesc);
-
-
-/*-------------------------------------------------------------------
- *
- * DEVICE STATE FUNCTIONS are concerned with getting and setting
- * the current state of the device; is it ready to be drawn into?
- *
- * From graphics.c, used in plot.c.
- */
-
-/* has plot.new been called yet? */
-void GCheckState(pGEDevDesc);
-/* Set to 1 when plot.new succeeds
- * Set to 0 when don't want drawing to go ahead */
-void GSetState(int, pGEDevDesc);
-
-/*-------------------------------------------------------------------
- *
- * GRAPHICAL PRIMITIVES are the generic front-end for the functions
- * that every device driver must provide.
- *
- * NOTE that locations supplied to these functions may be in any
- * of the valid coordinate systems (each function takes a "coords"
- * parameter to indicate the coordinate system); the device-specific
- * version of the function is responsible for calling GConvert to get
- * the location into device coordinates.
- *
- * From graphics.c, used in plot.c.
- */
-
-
-/* Draw a circle, centred on (x,y) with radius r (in inches). */
-void GCircle(double, double, int, double, int, int, pGEDevDesc);
-/* Set clipping region (based on current setting of dd->gp.xpd).
- * Only clip if new clipping region is different from the current one */
-void GClip(pGEDevDesc);
-/* Polygon clipping: */
-int GClipPolygon(double *, double *, int, int, int,
- double *, double *, pGEDevDesc);
-/* Always clips */
-void GForceClip(pGEDevDesc);
-/* Draw a line from (x1,y1) to (x2,y2): */
-void GLine(double, double, double, double, int, pGEDevDesc);
-/* Return the location of the next mouse click: */
-Rboolean GLocator(double*, double*, int, pGEDevDesc);
-/* Return the height, depth, and width of the specified
- * character in the specified units: */
-void GMetricInfo(int, double*, double*, double*, GUnit, pGEDevDesc);
-/* Set device "mode" (drawing or not drawing) here for windows and mac drivers.
- */
-void GMode(int, pGEDevDesc);
-/* Draw a path using the specified lists of x and y values: */
-void GPath(double*, double*, int, int*, Rboolean, int, int, pGEDevDesc);
-/* Draw a polygon using the specified lists of x and y values: */
-void GPolygon(int, double*, double*, int, int, int, pGEDevDesc);
-/* Draw series of straight lines using the specified lists of x and y values: */
-void GPolyline(int, double*, double*, int, pGEDevDesc);
-/* Draw a rectangle given two opposite corners: */
-void GRect(double, double, double, double, int, int, int, pGEDevDesc);
-/* Draw a raster image given two opposite corners: */
-void GRaster(unsigned int*, int, int,
- double, double, double, double,
- double, Rboolean, pGEDevDesc);
-/* Return the height of the specified string in the specified units: */
-double GStrHeight(const char *, cetype_t, GUnit, pGEDevDesc);
-/* Return the width of the specified string in the specified units */
-double GStrWidth(const char *, cetype_t, GUnit, pGEDevDesc);
-/* Draw the specified text at location (x,y) with the specified
- * rotation and justification: */
-void GText(double, double, int, const char *, cetype_t, double, double, double,
- pGEDevDesc);
-
-/* From plotmath.c, used in plot.c */
-void GMathText(double, double, int, SEXP, double, double, double, pGEDevDesc);
-void GMMathText(SEXP, int, double, int, double, int, double, pGEDevDesc);
-
-
-/*-------------------------------------------------------------------
- *
- * GRAPHICAL UTILITIES are functions that produce graphical output
- * using the graphical primitives (i.e., they are generic - NOT
- * device-specific).
- *
- * From graphics.c, used in plot.c.
- */
-
-/* Draw a line from (x1,y1) to (x2,y2) with an arrow head
- * at either or both ends. */
-void GArrow(double, double, double, double, int, double, double, int, pGEDevDesc);
-/* Draw a box around specified region:
- * 1=plot region, 2=figure region, 3=inner region, 4=device. */
-void GBox(int, pGEDevDesc);
-/* Return a "nice" min, max and number of intervals for a given
- * range on a linear or _log_ scale, respectively: */
-void GPretty(double*, double*, int*); /* used in plot3d.c */
-/* Draw text in margins. */
-void GMtext(const char *, cetype_t, int, double, int, double, int, double, pGEDevDesc);
-/* Draw one of the predefined symbols (circle, square, diamond, ...) */
-void GSymbol(double, double, int, int, pGEDevDesc);
-
-/* From plotmath.c, used in plot.c */
-double GExpressionHeight(SEXP, GUnit, pGEDevDesc);
-double GExpressionWidth(SEXP, GUnit, pGEDevDesc);
-
-
-
-/*----------------------------------------------------------------------
- *
- * TRANSFORMATIONS are concerned with converting locations between
- * coordinate systems and dimensions between different units.
- *
- * From graphics.c, used in par.c, plot.c, plot3d.c
- */
-
-/* Convert an R unit (e.g., "user") into an internal unit (e.g., USER)> */
-GUnit GMapUnits(int);
-/* Convert a LOCATION from one coordinate system to another: */
-void GConvert(double*, double*, GUnit, GUnit, pGEDevDesc);
-double GConvertX(double, GUnit, GUnit, pGEDevDesc);
-double GConvertY(double, GUnit, GUnit, pGEDevDesc);
-/* Convert an x/y-dimension from one set of units to another: */
-double GConvertXUnits(double, GUnit, GUnit, pGEDevDesc);
-double GConvertYUnits(double, GUnit, GUnit, pGEDevDesc);
-
-/* Set up the different regions on a device (i.e., inner region,
- * figure region, plot region) and transformations for associated
- * coordinate systems (called whenever anything that affects the
- * coordinate transformations changes):
- */
-void GReset(pGEDevDesc);
-
-/* Set up the user coordinate transformations: */
-void GMapWin2Fig(pGEDevDesc);
-/* Set up the device for a new plot by Resetting graphics parameters
- * and Resetting the regions and coordinate Systems */
-pGEDevDesc GNewPlot(Rboolean);
-/* Set up the user coordinates based on the axis limits */
-void GScale(double, double, int, pGEDevDesc);
-/* Set up the axis limits based on the user coordinates */
-void GSetupAxis(int, pGEDevDesc);
-/* Return row and column of current figure in the layout matrix */
-void currentFigureLocation(int*, int*, pGEDevDesc);
-
-/* which of these conversions should be public? maybe all? [NO_REMAP] */
-double xDevtoNDC(double, pGEDevDesc);
-double yDevtoNDC(double, pGEDevDesc);
-double xDevtoNFC(double, pGEDevDesc);
-double yDevtoNFC(double, pGEDevDesc);
-double xDevtoNPC(double, pGEDevDesc);
-double yDevtoNPC(double, pGEDevDesc);
-double xDevtoUsr(double, pGEDevDesc);
-double yDevtoUsr(double, pGEDevDesc);
-double xNPCtoUsr(double, pGEDevDesc);
-double yNPCtoUsr(double, pGEDevDesc);
-
-#ifdef __cplusplus
-}
-#endif
-
-#endif /* RGRAPHICS_H_ */
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_contour-common.h b/com.oracle.truffle.r.native/library/grDevices/src/main_contour-common.h
deleted file mode 100644
index b885bfc2e45a7d4c9be465a3eac44f5bf450526d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_contour-common.h
+++ /dev/null
@@ -1,336 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--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/
- */
-
-
-/* Stuff for labels on contour plots
- Originally written by Nicholas Hildreth
- Adapted by Paul Murrell
-*/
-
-/* Included by src/main/plot3d.c and src/library/graphics/src/plot3d */
-
- /* C o n t o u r P l o t t i n g */
-
-typedef struct SEG {
- struct SEG *next;
- double x0;
- double y0;
- double x1;
- double y1;
-} SEG, *SEGP;
-
-
-static int ctr_intersect(double z0, double z1, double zc, double *f)
-{
-/* Old test was ((z0 - zc) * (z1 - zc) < 0.0), but rounding led to inconsistencies
- in PR#15454 */
- if ( (z0 < zc) != (z1 < zc) && z0 != zc && z1 != zc ) {
- *f = (zc - z0) / (z1 - z0);
- return 1;
- }
- return 0;
-}
-
-static SEGP ctr_newseg(double x0, double y0, double x1, double y1, SEGP prev)
-{
- SEGP seg = (SEGP)R_alloc(1, sizeof(SEG));
- seg->x0 = x0;
- seg->y0 = y0;
- seg->x1 = x1;
- seg->y1 = y1;
- seg->next = prev;
- return seg;
-}
-
-static void ctr_swapseg(SEGP seg)
-{
- double x, y;
- x = seg->x0;
- y = seg->y0;
- seg->x0 = seg->x1;
- seg->y0 = seg->y1;
- seg->x1 = x;
- seg->y1 = y;
-}
-
- /* ctr_segdir(): Determine the entry direction to the next cell */
- /* and update the cell indices */
-
-#define XMATCH(x0,x1) (fabs(x0-x1) == 0)
-#define YMATCH(y0,y1) (fabs(y0-y1) == 0)
-
-static int ctr_segdir(double xend, double yend, double *x, double *y,
- int *i, int *j, int nx, int ny)
-{
- if (YMATCH(yend, y[*j])) {
- if (*j == 0)
- return 0;
- *j = *j - 1;
- return 3;
- }
- if (XMATCH(xend, x[*i])) {
- if (*i == 0)
- return 0;
- *i = *i - 1;
- return 4;
- }
- if (YMATCH(yend, y[*j + 1])) {
- if (*j >= ny - 1)
- return 0;
- *j = *j + 1;
- return 1;
- }
- if (XMATCH(xend, x[*i + 1])) {
- if (*i >= nx - 1)
- return 0;
- *i = *i + 1;
- return 2;
- }
- return 0;
-}
-
-/* Search seglist for a segment with endpoint (xend, yend). */
-/* The cell entry direction is dir, and if tail=1/0 we are */
-/* building the tail/head of a contour. The matching segment */
-/* is pointed to by seg and the updated segment list (with */
-/* the matched segment stripped) is returned by the funtion. */
-
-static SEGP ctr_segupdate(double xend, double yend, int dir, Rboolean tail,
- SEGP seglist, SEGP* seg)
-{
- if (seglist == NULL) {
- *seg = NULL;
- return NULL;
- }
- switch (dir) {
- case 1:
- case 3:
- if (YMATCH(yend,seglist->y0)) {
- if (!tail)
- ctr_swapseg(seglist);
- *seg = seglist;
- return seglist->next;
- }
- if (YMATCH(yend,seglist->y1)) {
- if (tail)
- ctr_swapseg(seglist);
- *seg = seglist;
- return seglist->next;
- }
- break;
- case 2:
- case 4:
- if (XMATCH(xend,seglist->x0)) {
- if (!tail)
- ctr_swapseg(seglist);
- *seg = seglist;
- return seglist->next;
- }
- if (XMATCH(xend,seglist->x1)) {
- if (tail)
- ctr_swapseg(seglist);
- *seg = seglist;
- return seglist->next;
- }
- break;
- }
- seglist->next = ctr_segupdate(xend, yend, dir, tail, seglist->next, seg);
- return seglist;
-}
-
-
-
-/*
- * Generate a list of segments for a single level
- *
- * NB this R_allocs its return value, so callers need to manage R_alloc stack.
- */
-static SEGP* contourLines(double *x, int nx, double *y, int ny,
- double *z, double zc, double atom)
-{
- double f, xl, xh, yl, yh, zll, zhl, zlh, zhh, xx[4], yy[4];
- int i, j, k, l, m, nacode;
- SEGP seglist;
- SEGP *segmentDB;
- /* Initialize the segment data base */
- /* Note we must be careful about resetting */
- /* the top of the stack, otherwise we run out of */
- /* memory after a sequence of displaylist replays */
- /*
- * This reset is done out in GEcontourLines
- */
- segmentDB = (SEGP*)R_alloc(nx*ny, sizeof(SEGP));
- for (i = 0; i < nx; i++)
- for (j = 0; j < ny; j++)
- segmentDB[i + j * nx] = NULL;
- for (i = 0; i < nx - 1; i++) {
- xl = x[i];
- xh = x[i + 1];
- for (j = 0; j < ny - 1; j++) {
- yl = y[j];
- yh = y[j + 1];
- k = i + j * nx;
- zll = z[k];
- zhl = z[k + 1];
- zlh = z[k + nx];
- zhh = z[k + nx + 1];
-
- /* If the value at a corner is exactly equal to a contour level,
- * change that value by a tiny amount */
-
- if (zll == zc) zll += atom;
- if (zhl == zc) zhl += atom;
- if (zlh == zc) zlh += atom;
- if (zhh == zc) zhh += atom;
-#ifdef DEBUG_contour
- /* Haven't seen this happening (MM): */
- if (zll == zc) REprintf(" [%d,%d] ll: %g\n",i,j, zll);
- if (zhl == zc) REprintf(" [%d,%d] hl: %g\n",i,j, zhl);
- if (zlh == zc) REprintf(" [%d,%d] lh: %g\n",i,j, zlh);
- if (zhh == zc) REprintf(" [%d,%d] hh: %g\n",i,j, zhh);
-#endif
- /* Check for intersections with sides */
-
- nacode = 0;
- if (R_FINITE(zll)) nacode += 1;
- if (R_FINITE(zhl)) nacode += 2;
- if (R_FINITE(zlh)) nacode += 4;
- if (R_FINITE(zhh)) nacode += 8;
-
- k = 0;
- switch (nacode) {
- case 15:
- if (ctr_intersect(zll, zhl, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yl; k++;
- }
- if (ctr_intersect(zll, zlh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xl; k++;
- }
- if (ctr_intersect(zhl, zhh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xh; k++;
- }
- if (ctr_intersect(zlh, zhh, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yh; k++;
- }
- break;
- case 14:
- if (ctr_intersect(zhl, zhh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xh; k++;
- }
- if (ctr_intersect(zlh, zhh, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yh; k++;
- }
- if (ctr_intersect(zlh, zhl, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yh + f * (yl - yh);
- k++;
- }
- break;
- case 13:
- if (ctr_intersect(zll, zlh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xl; k++;
- }
- if (ctr_intersect(zlh, zhh, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yh; k++;
- }
- if (ctr_intersect(zll, zhh, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yl + f * (yh - yl);
- k++;
- }
- break;
- case 11:
- if (ctr_intersect(zhl, zhh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xh; k++;
- }
- if (ctr_intersect(zll, zhl, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yl; k++;
- }
- if (ctr_intersect(zll, zhh, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yl + f * (yh - yl);
- k++;
- }
- break;
- case 7:
- if (ctr_intersect(zll, zlh, zc, &f)) {
- yy[k] = yl + f * (yh - yl);
- xx[k] = xl; k++;
- }
- if (ctr_intersect(zll, zhl, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yl; k++;
- }
- if (ctr_intersect(zlh, zhl, zc, &f)) {
- xx[k] = xl + f * (xh - xl);
- yy[k] = yh + f * (yl - yh);
- k++;
- }
- break;
- }
-
- /* We now have k(=2,4) endpoints */
- /* Decide which to join */
-
- seglist = NULL;
-
- if (k > 0) {
- if (k == 2) {
- seglist = ctr_newseg(xx[0], yy[0], xx[1], yy[1], seglist);
- }
- else if (k == 4) {
- for (k = 3; k >= 1; k--) {
- m = k;
- xl = xx[k];
- for (l = 0; l < k; l++) {
- if (xx[l] > xl) {
- xl = xx[l];
- m = l;
- }
- }
- if (m != k) {
- xl = xx[k];
- yl = yy[k];
- xx[k] = xx[m];
- yy[k] = yy[m];
- xx[m] = xl;
- yy[m] = yl;
- }
- }
- seglist = ctr_newseg(xx[0], yy[0], xx[1], yy[1], seglist);
- seglist = ctr_newseg(xx[2], yy[2], xx[3], yy[3], seglist);
- }
- else error("k = %d, should be 2 or 4", k);
- }
- segmentDB[i + j * nx] = seglist;
- }
- }
- return segmentDB;
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/main_rlocale.h b/com.oracle.truffle.r.native/library/grDevices/src/main_rlocale.h
deleted file mode 100644
index fcb2284014cc45dca1f091e9983537b70d807dfa..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/main_rlocale.h
+++ /dev/null
@@ -1,120 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2005-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/
- */
-
-
-/* This file was contributed by Ei-ji Nakama.
- * See also the comments in src/main/rlocale.c.
-
- * It does 2 things:
- * (a) supplies wrapper/substitute wc[s]width functions for use in
- * character.c, errors.c, printutils.c, devPS.c, RGui console.
- * (b) Defines a replacment for iswctype to be used on Windows, OS X and AIX.
- * in gram.c
- */
-
-#ifndef R_LOCALE_H
-#define R_LOCALE_H
-
-#ifndef NO_C_HEADERS
-#include <wchar.h>
-#include <ctype.h>
-#include <wctype.h>
-#endif
-
-#ifdef __cplusplus
-extern "C" {
-#endif
-
-/*
- * Windows CJK
- * In Unicode, there is not a rule about character width.
- * A letter of breadth is used in a CJK (China, Japan, Korea,
- * Taiwan, Hong Kong, and Singapore) area, and there are a
- * letter and a standard (character width is not still prescribed)
- * of a cord in a country.
- * Letter width is a problem of a font, but it is a rule route
- * besides a alphanumeric character that use a breadth letter.
- * It is generally defined as a breadth letter for a font such
- * as Japanese.
- * - Win32
-
- * Attempted explanation by BDR
- * The display widths of characters are not prescribed in Unicode.
- * Double-width characters are used in the CJK area: their width can
- * be font-specific, with different fonts in use in different parts
- * of the CJK area. The tables supplied in many OSes and by Marcus
- * Kuhn are not do not take the exact locale into account. The
- * tables supplied in rlocale_data.h allow different widths for
- * different parts of the CJK area, and also where needed different
- * widths on Windows. (The Windows differences are in zh_CN, and
- * apply to European characters.)
- *
- */
-extern int Ri18n_wcwidth(wchar_t);
-extern int Ri18n_wcswidth (const wchar_t *, size_t);
-
-/* Mac OSX CJK and WindowXP(Japanese)
- * iswctypes of MacOSX calls isctypes. no i18n.
- * For example, iswprint of Windows does not accept a macron of
- * Japanese "a-ru" of R as a letter.
- * Therefore Japanese "Buraian.Ripuri-" of "Brian Ripley" is
- * shown of hex-string.:-)
- * We define alternatives to be used if
- * defined(Win32) || defined(__APPLE__) || defined(_AIX)
- */
-extern wctype_t Ri18n_wctype(const char *);
-extern int Ri18n_iswctype(wint_t, wctype_t);
-
-#ifndef IN_RLOCALE_C
-/* We want to avoid these redefinitions in rlocale.c itself */
-#undef iswupper
-#undef iswlower
-#undef iswalpha
-#undef iswdigit
-#undef iswxdigit
-#undef iswspace
-#undef iswprint
-#undef iswgraph
-#undef iswblank
-#undef iswcntrl
-#undef iswpunct
-#undef iswalnum
-#undef wctype
-#undef iswctype
-
-#define iswupper(__x) Ri18n_iswctype(__x, Ri18n_wctype("upper"))
-#define iswlower(__x) Ri18n_iswctype(__x, Ri18n_wctype("lower"))
-#define iswalpha(__x) Ri18n_iswctype(__x, Ri18n_wctype("alpha"))
-#define iswdigit(__x) Ri18n_iswctype(__x, Ri18n_wctype("digit"))
-#define iswxdigit(__x) Ri18n_iswctype(__x, Ri18n_wctype("xdigit"))
-#define iswspace(__x) Ri18n_iswctype(__x, Ri18n_wctype("space"))
-#define iswprint(__x) Ri18n_iswctype(__x, Ri18n_wctype("print"))
-#define iswgraph(__x) Ri18n_iswctype(__x, Ri18n_wctype("graph"))
-#define iswblank(__x) Ri18n_iswctype(__x, Ri18n_wctype("blank"))
-#define iswcntrl(__x) Ri18n_iswctype(__x, Ri18n_wctype("cntrl"))
-#define iswpunct(__x) Ri18n_iswctype(__x, Ri18n_wctype("punct"))
-#define iswalnum(__x) Ri18n_iswctype(__x, Ri18n_wctype("alnum"))
-#define wctype(__x) Ri18n_wctype(__x)
-#define iswctype(__x,__y) Ri18n_iswctype(__x,__y)
-#endif
-
-#ifdef __cplusplus
-}
-#endif
-#endif /* R_LOCALE_H */
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.c b/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.c
deleted file mode 100644
index 35b1e9b75af76ebfb51167decf73eb672047997b..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.c
+++ /dev/null
@@ -1,191 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2007-9 The R Foundation
- *
- * 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/
- *
- * Bitmap output Quartz device module
- *
- * Original author: Byron Ellis
- *
- * This file should be compiled only if AQUA is enabled
- */
-
-
-#include "qdBitmap.h"
-
-#include <R.h>
-#include <Rinternals.h>
-#include <R_ext/QuartzDevice.h>
-#define _(String) (String)
-
-typedef struct {
- CGContextRef bitmap; /* Bitmap drawing context */
- char *uti; /* Type of bitmap to produce */
- char *path; /* Path for file save during close (can be NULL) */
- int page; /* current page number increased by NewPage (0 right after init) */
- unsigned int length; /* Size of the bitmap */
- char data[1]; /* Actual bitmap bytes */
-} QuartzBitmapDevice;
-
-static QuartzFunctions_t *qf;
-
-CGContextRef QuartzBitmap_GetCGContext(QuartzDesc_t dev, void *userInfo)
-{
- return ((QuartzBitmapDevice*) userInfo)->bitmap;
-}
-
-void QuartzBitmap_Output(QuartzDesc_t dev, QuartzBitmapDevice *qbd)
-{
- if(qbd->path && qbd->uti) {
- /* On 10.4+ we can employ the CGImageDestination API to create a
- variety of different bitmap formats */
-#if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4
- char buf[PATH_MAX+1];
- snprintf(buf, PATH_MAX, qbd->path, qbd->page); buf[PATH_MAX] = '\0';
- CFStringRef pathString = CFStringCreateWithBytes(kCFAllocatorDefault, (UInt8*) buf, strlen(buf), kCFStringEncodingUTF8, FALSE);
- CFURLRef path;
- if(CFStringFind(pathString, CFSTR("://"), 0).location != kCFNotFound) {
- CFStringRef pathEscaped = CFURLCreateStringByAddingPercentEscapes(kCFAllocatorDefault, pathString, NULL, NULL, kCFStringEncodingUTF8);
- path = CFURLCreateWithString(kCFAllocatorDefault, pathEscaped, NULL);
- CFRelease(pathEscaped);
- } else {
- path = CFURLCreateFromFileSystemRepresentation(kCFAllocatorDefault, (const UInt8*) buf, strlen(buf), FALSE);
- }
- CFRelease(pathString);
-
- CFStringRef scheme = CFURLCopyScheme(path);
- CFStringRef type = CFStringCreateWithBytes(kCFAllocatorDefault, (UInt8*) qbd->uti, strlen(qbd->uti), kCFStringEncodingUTF8, FALSE);
- CGImageRef image = CGBitmapContextCreateImage(qbd->bitmap);
- if(CFStringCompare(scheme,CFSTR("file"), 0) == 0) { /* file output */
- CGImageDestinationRef dest = CGImageDestinationCreateWithURL(path, type, 1, NULL);
- if(dest) {
- CGImageDestinationAddImage(dest, image, NULL);
- CGImageDestinationFinalize(dest);
- CFRelease(dest);
- } else
- error(_("QuartzBitmap_Output - unable to open file '%s'"), buf);
- } else if(CFStringCompare(scheme, CFSTR("clipboard"), 0) == 0) { /* clipboard output */
- CFMutableDataRef data = CFDataCreateMutable(kCFAllocatorDefault, 0);
- CGImageDestinationRef dest = CGImageDestinationCreateWithData(data, type, 1, NULL);
- CGImageDestinationAddImage(dest, image, NULL);
- CGImageDestinationFinalize(dest);
- CFRelease(dest);
- PasteboardRef pb = NULL;
- if(PasteboardCreate(kPasteboardClipboard, &pb) == noErr) {
- PasteboardClear(pb);
- PasteboardSynchronize(pb);
- PasteboardPutItemFlavor(pb, (PasteboardItemID) 1, type, data, 0);
- }
- CFRelease(data);
- } else
- warning(_("not a supported scheme, no image data written"));
- CFRelease(scheme);
- CFRelease(type);
- CFRelease(path);
- CFRelease(image);
-#endif
- }
-}
-
-void QuartzBitmap_NewPage(QuartzDesc_t dev, void *userInfo, int flags)
-{
- QuartzBitmapDevice *qbd = (QuartzBitmapDevice*) userInfo;
-
- if (qbd->page) QuartzBitmap_Output(dev, qbd); /* save the image unless the first page is being created */
- qbd->page++;
-}
-
-void QuartzBitmap_Close(QuartzDesc_t dev, void *userInfo)
-{
- QuartzBitmapDevice *qbd = (QuartzBitmapDevice*) userInfo;
-
- /* FIXME: do this only if device is dirty? */
- if (qbd->page) QuartzBitmap_Output(dev, qbd);
-
- /* Free ourselves */
- if (qbd->bitmap) CFRelease(qbd->bitmap);
- if (qbd->uti) free(qbd->uti);
- if (qbd->path) free(qbd->path);
- free(qbd);
-}
-
-QuartzDesc_t QuartzBitmap_DeviceCreate(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par)
-{
- /* In the case of a zero length string we default to PNG presently. This
- should probably be an option somewhere. */
- double *dpi = par->dpi;
- double width = par->width, height = par->height;
- const char *type = par->type;
- double mydpi[2] = { 72.0, 72.0 }; /* fall-back to 72dpi if none was specified */
- QuartzDesc_t ret = NULL;
- if (!qf) qf = fn;
- if(!type || strlen(type) == 0) type = "public.png";
- if (!dpi) dpi=mydpi;
-
-#if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_4
- /* We'll gladly support any image destination type */
- CFArrayRef types = CGImageDestinationCopyTypeIdentifiers();
- CFStringRef mine = CFStringCreateWithBytes(kCFAllocatorDefault, (UInt8*) type, strlen(type), kCFStringEncodingUTF8, FALSE);
- if(CFArrayContainsValue(types,CFRangeMake(0, CFArrayGetCount(types)), mine)) {
- size_t w = (size_t) (dpi[0] * width);
- size_t h = (size_t) (dpi[1] * height);
- size_t rb= (w*8*4+7)/8; /* Bytes per row */
- size_t s = h*rb;
- /* QuartzDesc_t qd; */
- /* Allocate sufficient space */
- /* FIXME: check allocations */
- QuartzBitmapDevice *dev = malloc(sizeof(QuartzBitmapDevice)+s);
- dev->length = (unsigned int) s;
- dev->uti = type ? strdup(type) : NULL;
- dev->path = par->file ? strdup(par->file) : NULL;
- dev->page = 0;
- memset(dev->data, 0, s);
- dev->bitmap = CGBitmapContextCreate(dev->data, w, h, 8, rb,
- CGColorSpaceCreateWithName(kCGColorSpaceGenericRGB),
- kCGImageAlphaPremultipliedLast);
- /* bitmaps use flipped coordinates (top-left is the origin), so we need to pre-set CTM. */
- CGContextTranslateCTM(dev->bitmap, 0.0, height * dpi[1]);
- CGContextScaleCTM(dev->bitmap, 1.0, -1.0);
- QuartzBackend_t qdef = {
- sizeof(qdef), width, height, dpi[0]/72.0 , dpi[1]/72.0, par->pointsize,
- par->bg, par->canvas, par->flags | QDFLAG_RASTERIZED,
- dev,
- QuartzBitmap_GetCGContext,
- NULL, /* locate */
- QuartzBitmap_Close,
- QuartzBitmap_NewPage,
- NULL, /* state */
- NULL, /* par */
- NULL, /* sync */
- NULL, /* cap */
- };
-
-
- if (!(ret = qf->Create(dd, &qdef)))
- QuartzBitmap_Close(NULL, dev);
- else {
- /* since this device is non-resizable we set the size right away (as opposed to on-display) */
- qf->SetSize(ret, width, height);
- /* tell Quartz to prepare our new context */
- qf->ResetContext(ret);
- }
- }
- CFRelease(mine);
- CFRelease(types);
-#endif
- return ret;
-}
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.h b/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.h
deleted file mode 100644
index c81534f2f99e1a80538565f412c9733f6735c55d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.h
+++ /dev/null
@@ -1,27 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2007 The R Foundation
- *
- * 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/
- *
- * Quartz Quartz device module header file
- *
- */
-
-#include <R.h>
-#include <R_ext/QuartzDevice.h>
-
-QuartzDesc_t QuartzBitmap_DeviceCreate(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par);
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/qdCocoa.h b/com.oracle.truffle.r.native/library/grDevices/src/qdCocoa.h
deleted file mode 100644
index 57624ccb70323cb096b83873b0e5a94857dc0519..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/qdCocoa.h
+++ /dev/null
@@ -1,54 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2007 The R Foundation
- *
- * 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/
- *
- * Quartz Quartz device module header file
- *
- */
-
-#include <R.h>
-#include <R_ext/QuartzDevice.h>
-
-/* inofficial API that can be used by other applications */
-
-#define QCF_SET_PEPTR 1 /* set ProcessEvents function pointer */
-#define QCF_SET_FRONT 2 /* set application mode to front */
-
-void QuartzCocoa_SetupEventLoop(int flags, unsigned long latency);
-int QuartzCocoa_SetLatency(unsigned long latency);
-
-/* this is the designated creator, used by the Quartz dispatcher */
-QuartzDesc_t QuartzCocoa_DeviceCreate(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par);
-
-#ifdef __OBJC__
-
-#import <Cocoa/Cocoa.h>
-
-typedef struct sQuartzCocoaDevice QuartzCocoaDevice;
-
-@interface QuartzCocoaView : NSView
-{
- QuartzCocoaDevice *ci;
-}
-
-+ (QuartzCocoaView*) quartzWindowWithRect: (NSRect) rect andInfo: (void*) info;
-
-- (id) initWithFrame: (NSRect) fram andInfo: (void*) info;
-
-@end
-
-#endif
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.c b/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.c
deleted file mode 100644
index 6a13846154bfb72bd2c274eb834d1c878da2e05d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.c
+++ /dev/null
@@ -1,166 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2007-8 The R Foundation
- *
- * 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/
- *
- * PDF output Quartz device module
- *
- * This module creates PDF output using CoreGraphics. Currently
- * supported targets are file and CFMutableData. The latter is
- * passed as parv in parameters.
- *
- * This file should be compiled only if AQUA is enabled
- */
-
-
-#include "qdPDF.h"
-
-#include <R.h>
-#include <Rinternals.h>
-#include <R_ext/QuartzDevice.h>
-#define _(String) (String)
-
-typedef struct {
- CGContextRef context; /* drawing context */
- CFURLRef url; /* destication URL (on NULL is connection or data is used) */
- int connection; /* destination connection (currently unsupported) */
- int page; /* page number (0 before first NewPage call) */
- CGRect bbox; /* bounding box (in points) */
- CFMutableDataRef data; /* destination data (if writing to CFMutableData) */
-} QuartzPDFDevice;
-
-static QuartzFunctions_t *qf;
-
-CGContextRef QuartzPDF_GetCGContext(QuartzDesc_t dev,void *userInfo)
-{
- return ((QuartzPDFDevice*)userInfo)->context;
-}
-
-void QuartzPDF_NewPage(QuartzDesc_t dev, void *userInfo, int flags)
-{
- QuartzPDFDevice *qpd = (QuartzPDFDevice*) userInfo;
- if (qpd->context) { /* hopefully that's true */
- if (qpd->page) CGContextEndPage(qpd->context);
- CGContextBeginPage(qpd->context, &qpd->bbox);
- }
- qpd->page++;
-}
-
-void QuartzPDF_Close(QuartzDesc_t dev, void *userInfo)
-{
- QuartzPDFDevice *qpd = (QuartzPDFDevice*) userInfo;
-
- if (qpd->context) { /* hopefully that's true */
- if (qpd->page) CGContextEndPage(qpd->context);
- CGContextRelease(qpd->context);
- }
- /* Free ourselves */
- if (qpd->url) CFRelease(qpd->url);
- if (qpd->data) CFRelease(qpd->data);
- free(qpd);
-}
-
-QuartzDesc_t
-QuartzPDF_DeviceCreate(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par)
-{
- QuartzDesc_t ret = NULL;
- double *dpi = par->dpi;
- double mydpi[2] = { 72.0, 72.0 };
- double width = par->width, height = par->height;
- /* DPI is ignored, because PDF is resolution independent.
- More precisely 72dpi is used to guarantee that PDF and GE
- coordinates are the same */
- dpi = mydpi;
-
- if (!qf) qf = fn;
-
- QuartzPDFDevice *dev = calloc(1, sizeof(QuartzPDFDevice));
-
- if ((!par->file || ! *par->file)) par->file = "Rplots.pdf";
-
- if (par->parv) dev->data = (CFMutableDataRef) CFRetain((CFTypeRef) par->parv); /* parv if set is CFMutableDataRef to write to */
- else if (par->file && *par->file) {
- CFStringRef path = CFStringCreateWithBytes(kCFAllocatorDefault, (UInt8*) par->file, strlen(par->file), kCFStringEncodingUTF8, FALSE);
- if (!path || !(dev->url = CFURLCreateWithFileSystemPath (NULL, path, kCFURLPOSIXPathStyle, false))) {
- warning(_("cannot open file '%s'"), par->file);
- free(dev);
- return ret;
- }
- CFRelease(path);
- }
- dev->bbox = CGRectMake(0, 0, width * 72.0, height * 72.0);
- CFDictionaryRef ai = 0;
- { /* optional PDF auxiliary info: we add creator and title (if present) - we could support more ... */
- int numK = 1;
- CFStringRef keys[2], values[2];
- keys[0] = kCGPDFContextCreator;
- values[0] = CFSTR("Quartz R Device");
- if (par->title) {
- keys[numK] = kCGPDFContextTitle;
- values[numK] = CFStringCreateWithBytes(kCFAllocatorDefault, (UInt8*) par->title, strlen(par->title), kCFStringEncodingUTF8, FALSE);
- numK++;
- }
- ai = CFDictionaryCreate(0, (void*) keys, (void*) values, numK, &kCFTypeDictionaryKeyCallBacks, &kCFTypeDictionaryValueCallBacks);
- while (numK) CFRelease(values[--numK]);
- }
-
- if (dev->data) {
- CGDataConsumerRef consumer = CGDataConsumerCreateWithCFData(dev->data);
- if (consumer) {
- dev->context = CGPDFContextCreate(consumer, &dev->bbox, ai);
- CFRelease(consumer);
- }
- } else
- dev->context = CGPDFContextCreateWithURL(dev->url, &dev->bbox, ai);
-
- if (dev->context == NULL) {
- if (ai) CFRelease(ai);
- if (dev->url) CFRelease(dev->url);
- free(dev);
- return ret;
- }
- if (ai) CFRelease(ai);
- dev->page = 0;
-
- /* we need to flip the y coordinate */
- CGContextTranslateCTM(dev->context, 0.0, dev->bbox.size.height);
- CGContextScaleCTM(dev->context, 1.0, -1.0);
-
- QuartzBackend_t qdef = {
- sizeof(qdef), width, height,
- dpi[0]/72.0, dpi[1]/72.0, par->pointsize,
- par->bg, par->canvas, par->flags,
- dev,
- QuartzPDF_GetCGContext,
- NULL, /* locate */
- QuartzPDF_Close,
- QuartzPDF_NewPage,
- NULL, /* state */
- NULL, /* par */
- NULL, /* sync */
- NULL, /* cap */
- };
-
- if (!(ret = qf->Create(dd, &qdef)))
- QuartzPDF_Close(NULL,dev);
- else {
- qf->SetSize(ret, width, height);
- qf->ResetContext(ret);
- }
-
- return ret;
-}
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.h b/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.h
deleted file mode 100644
index 24aa7573b6ed148bab1901fb17db8b3dff6afdd2..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/qdPDF.h
+++ /dev/null
@@ -1,5 +0,0 @@
-#include <R.h>
-#include <R_ext/QuartzDevice.h>
-
-QuartzDesc_t QuartzPDF_DeviceCreate(void *dd, QuartzFunctions_t *fn, QuartzParameters_t *par);
-
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/rbitmap.h b/com.oracle.truffle.r.native/library/grDevices/src/rbitmap.h
deleted file mode 100644
index 5af8abea43c40570c8868b4f0cfe3f03abf67c6d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/rbitmap.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/*
- * R : A Computer Langage for Statistical Data Analysis
- * Copyright (C) 2000-11 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 WIN32_LEAN_AND_MEAN 1
-#include <windows.h>
-typedef int (*R_SaveAsBitmap)(/* variable set of args */);
-static R_SaveAsBitmap R_SaveAsPng, R_SaveAsJpeg, R_SaveAsBmp, R_SaveAsTIFF;
-
-static int RbitmapAlreadyLoaded = 0;
-static HINSTANCE hRbitmapDll;
-
-static int Load_Rbitmap_Dll()
-{
- if (!RbitmapAlreadyLoaded) {
- char szFullPath[PATH_MAX];
- strcpy(szFullPath, R_HomeDir());
- strcat(szFullPath, "\\library\\grDevices\\libs\\");
- strcat(szFullPath, R_ARCH);
- strcat(szFullPath, "\\Rbitmap.dll");
- if (((hRbitmapDll = LoadLibrary(szFullPath)) != NULL) &&
- ((R_SaveAsPng=
- (R_SaveAsBitmap)GetProcAddress(hRbitmapDll, "R_SaveAsPng"))
- != NULL) &&
- ((R_SaveAsBmp=
- (R_SaveAsBitmap)GetProcAddress(hRbitmapDll, "R_SaveAsBmp"))
- != NULL) &&
- ((R_SaveAsJpeg=
- (R_SaveAsBitmap)GetProcAddress(hRbitmapDll, "R_SaveAsJpeg"))
- != NULL) &&
- ((R_SaveAsTIFF=
- (R_SaveAsBitmap)GetProcAddress(hRbitmapDll, "R_SaveAsTIFF"))
- != NULL)
- ) {
- RbitmapAlreadyLoaded = 1;
- } else {
- if (hRbitmapDll != NULL) FreeLibrary(hRbitmapDll);
- RbitmapAlreadyLoaded= -1;
- char buf[1000];
- snprintf(buf, 1000, "Unable to load '%s'", szFullPath);
- R_ShowMessage(buf);
- }
- }
- return (RbitmapAlreadyLoaded > 0);
-}
diff --git a/com.oracle.truffle.r.native/library/grDevices/src/stubs.c b/com.oracle.truffle.r.native/library/grDevices/src/stubs.c
deleted file mode 100644
index 393fc8f69f7c713ee879af5848b98e2a296fee0d..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/grDevices/src/stubs.c
+++ /dev/null
@@ -1,107 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2012 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 <config.h>
-#include "Defn.h"
-//#include <Internal.h>
-#include "grDevices.h"
-
-#ifndef _WIN32
-SEXP do_X11(SEXP call, SEXP op, SEXP args, SEXP env);
-SEXP do_saveplot(SEXP call, SEXP op, SEXP args, SEXP env);
-
-SEXP X11(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_X11(call, op, CDR(args), env);
-}
-
-SEXP savePlot(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_saveplot(call, op, CDR(args), env);
-}
-#endif
-
-SEXP contourLines(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_contourLines(call, op, CDR(args), env);
-}
-
-SEXP getSnapshot(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_getSnapshot(call, op, CDR(args), env);
-}
-
-SEXP playSnapshot(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_playSnapshot(call, op, CDR(args), env);
-}
-
-SEXP getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_getGraphicsEvent(call, op, CDR(args), env);
-}
-
-SEXP getGraphicsEventEnv(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_getGraphicsEventEnv(call, op, CDR(args), env);
-}
-
-SEXP setGraphicsEventEnv(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- return do_setGraphicsEventEnv(call, op, CDR(args), env);
-}
-
-#ifdef _WIN32
-SEXP bringtotop(SEXP sdev, SEXP sstay);
-SEXP msgwindow(SEXP sdev, SEXP stype);
-
-
-SEXP bringToTop(SEXP sdev, SEXP sstay)
-{
- return bringtotop(sdev, sstay);
-}
-
-SEXP msgWindow(SEXP sdev, SEXP stype)
-{
- return msgwindow(sdev, stype);
-}
-
-#endif
-
-
-#include <R_ext/GraphicsEngine.h>
-
-SEXP devAskNewPage(SEXP call, SEXP op, SEXP args, SEXP env)
-{
- int ask;
- pGEDevDesc gdd = GEcurrentDevice();
- Rboolean oldask = gdd->ask;
-
- args = CDR(args);
- if (!isNull(CAR(args))) {
- ask = asLogical(CAR(args));
- if (ask == NA_LOGICAL) error(_("invalid '%s' argument"), "ask");
- gdd->ask = ask;
- R_Visible = FALSE;
- } else R_Visible = TRUE;
-
- return ScalarLogical(oldask);
-}
-
-
diff --git a/com.oracle.truffle.r.native/library/graphics/Makefile b/com.oracle.truffle.r.native/library/graphics/Makefile
index f128fcf8a4ea847d045bd6a86eda6d24ffe6ae27..8a38d40ecbdab87615ca30100da32dd802700e97 100644
--- a/com.oracle.truffle.r.native/library/graphics/Makefile
+++ b/com.oracle.truffle.r.native/library/graphics/Makefile
@@ -21,4 +21,24 @@
# questions.
#
+OBJ = lib
+
+GNUR_INCLUDES := -I$(TOPDIR)/fficall/src/include
+GRAPHICS_INCLUDES := -I$(GNUR_HOME)/src/library/graphics
+
+GNUR_C_SOURCES := base.c graphics.c init.c par.c plot.c plot3d.c stem.c
+
+GNUR_C_OBJECTS := $(addprefix $(OBJ)/, $(GNUR_C_SOURCES:.c=.o))
+
include ../lib.mk
+
+include $(TOPDIR)/fficall/src/include/gnurheaders.mk
+
+#CFLAGS := $(CFLAGS) -H
+
+# plot.c needs to include the GNUR internal Print.h
+$(OBJ)/plot.o: $(GNUR_SRC)/plot.c
+ $(CC) $(CFLAGS) $(GNUR_INCLUDES) $(INCLUDES) $(GNUR_HEADER_DEFS) $(GRAPHICS_INCLUDES) $(SUPPRESS_WARNINGS) -c $< -o $@
+
+$(OBJ)/%.o: $(GNUR_SRC)/%.c
+ $(CC) $(CFLAGS) $(INCLUDES) $(GNUR_INCLUDES) $(GNUR_HEADER_DEFS) $(GRAPHICS_INCLUDES) $(SUPPRESS_WARNINGS) -c $< -o $@
diff --git a/com.oracle.truffle.r.native/library/graphics/src/Defn.h b/com.oracle.truffle.r.native/library/graphics/src/Defn.h
deleted file mode 100644
index f69f7893a76cba0ecdc750927896bb170369af9b..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/Defn.h
+++ /dev/null
@@ -1,3 +0,0 @@
-// replacing the original Defn.h file
-
-#include "../../grDevices/src/Defn.h"
diff --git a/com.oracle.truffle.r.native/library/graphics/src/base.c b/com.oracle.truffle.r.native/library/graphics/src/base.c
deleted file mode 100644
index c48879ada157048fa45a0396cb31ea651e84d574..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/base.c
+++ /dev/null
@@ -1,353 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2001-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/
- */
-
-/* The beginning of code which represents an R base graphics system
- * separate from an R graphics engine (separate from R devices)
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-#include "../../grDevices/src/main_Graphics.h"
-#include "../../grDevices/src/main_GraphicsBase.h"
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#undef _
-#define _(String) dgettext ("graphics", String)
-#else
-#define _(String) (String)
-#endif
-
-/* From src/main/devices.c */
-extern int baseRegisterIndex;
-
-static R_INLINE GPar* dpSavedptr(pGEDevDesc dd) {
- if (baseRegisterIndex == -1)
- error(_("no base graphics system is registered"));
- baseSystemState *bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- return &(bss->dpSaved);
-}
-
-static void restoredpSaved(pGEDevDesc dd)
-{
- /* NOTE that not all params should be restored before playing */
- /* the display list (e.g., don't restore the device size) */
-
- /* This could probably now just do a memcpy */
- int i, j, nr, nc;
-
- dpptr(dd)->state = dpSavedptr(dd)->state;
- /* does not restore 'valid' */
- dpptr(dd)->adj = dpSavedptr(dd)->adj;
- dpptr(dd)->ann = dpSavedptr(dd)->ann;
- dpptr(dd)->bg = dpSavedptr(dd)->bg;
- dpptr(dd)->bty = dpSavedptr(dd)->bty;
- dpptr(dd)->cex = dpSavedptr(dd)->cex;
- gpptr(dd)->lheight = dpSavedptr(dd)->lheight;
- dpptr(dd)->col = dpSavedptr(dd)->col;
- dpptr(dd)->crt = dpSavedptr(dd)->crt;
- dpptr(dd)->err = dpSavedptr(dd)->err;
- dpptr(dd)->fg = dpSavedptr(dd)->fg;
- strncpy(dpptr(dd)->family, dpSavedptr(dd)->family, 201);
- dpptr(dd)->font = dpSavedptr(dd)->font;
- dpptr(dd)->gamma = dpSavedptr(dd)->gamma;
- dpptr(dd)->lab[0] = dpSavedptr(dd)->lab[0];
- dpptr(dd)->lab[1] = dpSavedptr(dd)->lab[1];
- dpptr(dd)->lab[2] = dpSavedptr(dd)->lab[2];
- dpptr(dd)->las = dpSavedptr(dd)->las;
- dpptr(dd)->lty = dpSavedptr(dd)->lty;
- dpptr(dd)->lwd = dpSavedptr(dd)->lwd;
- dpptr(dd)->lend = dpSavedptr(dd)->lend;
- dpptr(dd)->ljoin = dpSavedptr(dd)->ljoin;
- dpptr(dd)->lmitre = dpSavedptr(dd)->lmitre;
- dpptr(dd)->mgp[0] = dpSavedptr(dd)->mgp[0];
- dpptr(dd)->mgp[1] = dpSavedptr(dd)->mgp[1];
- dpptr(dd)->mgp[2] = dpSavedptr(dd)->mgp[2];
- dpptr(dd)->mkh = dpSavedptr(dd)->mkh;
- dpptr(dd)->pch = dpSavedptr(dd)->pch;
- dpptr(dd)->ps = dpSavedptr(dd)->ps; /*was commented out --why? Well, it never changes */
- dpptr(dd)->smo = dpSavedptr(dd)->smo;
- dpptr(dd)->srt = dpSavedptr(dd)->srt;
- dpptr(dd)->tck = dpSavedptr(dd)->tck;
- dpptr(dd)->tcl = dpSavedptr(dd)->tcl;
- dpptr(dd)->xaxp[0] = dpSavedptr(dd)->xaxp[0];
- dpptr(dd)->xaxp[1] = dpSavedptr(dd)->xaxp[1];
- dpptr(dd)->xaxp[2] = dpSavedptr(dd)->xaxp[2];
- dpptr(dd)->xaxs = dpSavedptr(dd)->xaxs;
- dpptr(dd)->xaxt = dpSavedptr(dd)->xaxt;
- dpptr(dd)->xpd = dpSavedptr(dd)->xpd;
- /* not oldxpd, which is a gpptr concept */
- dpptr(dd)->xlog = dpSavedptr(dd)->xlog;
- dpptr(dd)->yaxp[0] = dpSavedptr(dd)->yaxp[0];
- dpptr(dd)->yaxp[1] = dpSavedptr(dd)->yaxp[1];
- dpptr(dd)->yaxp[2] = dpSavedptr(dd)->yaxp[2];
- dpptr(dd)->yaxs = dpSavedptr(dd)->yaxs;
- dpptr(dd)->yaxt = dpSavedptr(dd)->yaxt;
- dpptr(dd)->ylog = dpSavedptr(dd)->ylog;
- dpptr(dd)->cexbase = dpSavedptr(dd)->cexbase;
- dpptr(dd)->cexmain = dpSavedptr(dd)->cexmain;
- dpptr(dd)->cexlab = dpSavedptr(dd)->cexlab;
- dpptr(dd)->cexsub = dpSavedptr(dd)->cexsub;
- dpptr(dd)->cexaxis = dpSavedptr(dd)->cexaxis;
- dpptr(dd)->fontmain = dpSavedptr(dd)->fontmain;
- dpptr(dd)->fontlab = dpSavedptr(dd)->fontlab;
- dpptr(dd)->fontsub = dpSavedptr(dd)->fontsub;
- dpptr(dd)->fontaxis = dpSavedptr(dd)->fontaxis;
- dpptr(dd)->colmain = dpSavedptr(dd)->colmain;
- dpptr(dd)->collab = dpSavedptr(dd)->collab;
- dpptr(dd)->colsub = dpSavedptr(dd)->colsub;
- dpptr(dd)->colaxis = dpSavedptr(dd)->colaxis;
-
- /* must restore layout parameters; the different graphics */
- /* regions and coordinate transformations will be recalculated */
- /* but they need all of the layout information restored for this */
- /* to happen correctly */
-
- dpptr(dd)->devmode = dpSavedptr(dd)->devmode;
- dpptr(dd)->fig[0] = dpSavedptr(dd)->fig[0];
- dpptr(dd)->fig[1] = dpSavedptr(dd)->fig[1];
- dpptr(dd)->fig[2] = dpSavedptr(dd)->fig[2];
- dpptr(dd)->fig[3] = dpSavedptr(dd)->fig[3];
- dpptr(dd)->fin[0] = dpSavedptr(dd)->fin[0];
- dpptr(dd)->fin[1] = dpSavedptr(dd)->fin[1];
- dpptr(dd)->fUnits = dpSavedptr(dd)->fUnits;
- dpptr(dd)->defaultFigure = dpSavedptr(dd)->defaultFigure;
- dpptr(dd)->mar[0] = dpSavedptr(dd)->mar[0];
- dpptr(dd)->mar[1] = dpSavedptr(dd)->mar[1];
- dpptr(dd)->mar[2] = dpSavedptr(dd)->mar[2];
- dpptr(dd)->mar[3] = dpSavedptr(dd)->mar[3];
- dpptr(dd)->mai[0] = dpSavedptr(dd)->mai[0];
- dpptr(dd)->mai[1] = dpSavedptr(dd)->mai[1];
- dpptr(dd)->mai[2] = dpSavedptr(dd)->mai[2];
- dpptr(dd)->mai[3] = dpSavedptr(dd)->mai[3];
- dpptr(dd)->mUnits = dpSavedptr(dd)->mUnits;
- dpptr(dd)->mex = dpSavedptr(dd)->mex;
- nr = dpptr(dd)->numrows = dpSavedptr(dd)->numrows;
- nc = dpptr(dd)->numcols = dpSavedptr(dd)->numcols;
- dpptr(dd)->currentFigure = dpSavedptr(dd)->currentFigure;
- dpptr(dd)->lastFigure = dpSavedptr(dd)->lastFigure;
- for (i = 0; i < nr && i < MAX_LAYOUT_ROWS; i++) {
- dpptr(dd)->heights[i] = dpSavedptr(dd)->heights[i];
- dpptr(dd)->cmHeights[i] = dpSavedptr(dd)->cmHeights[i];
- }
- for (j = 0; j < nc && j < MAX_LAYOUT_COLS; j++) {
- dpptr(dd)->widths[j] = dpSavedptr(dd)->widths[j];
- dpptr(dd)->cmWidths[j] = dpSavedptr(dd)->cmWidths[j];
- }
- for (i = 0; i < nr*nc && i < MAX_LAYOUT_CELLS; i++) {
- dpptr(dd)->order[i] = dpSavedptr(dd)->order[i];
- dpptr(dd)->respect[i] = dpSavedptr(dd)->respect[i];
- }
- dpptr(dd)->rspct = dpSavedptr(dd)->rspct;
- dpptr(dd)->layout = dpSavedptr(dd)->layout;
- dpptr(dd)->mfind = dpSavedptr(dd)->mfind;
- dpptr(dd)->new = dpSavedptr(dd)->new;
- dpptr(dd)->oma[0] = dpSavedptr(dd)->oma[0];
- dpptr(dd)->oma[1] = dpSavedptr(dd)->oma[1];
- dpptr(dd)->oma[2] = dpSavedptr(dd)->oma[2];
- dpptr(dd)->oma[3] = dpSavedptr(dd)->oma[3];
- dpptr(dd)->omi[0] = dpSavedptr(dd)->omi[0];
- dpptr(dd)->omi[1] = dpSavedptr(dd)->omi[1];
- dpptr(dd)->omi[2] = dpSavedptr(dd)->omi[2];
- dpptr(dd)->omi[3] = dpSavedptr(dd)->omi[3];
- dpptr(dd)->omd[0] = dpSavedptr(dd)->omd[0];
- dpptr(dd)->omd[1] = dpSavedptr(dd)->omd[1];
- dpptr(dd)->omd[2] = dpSavedptr(dd)->omd[2];
- dpptr(dd)->omd[3] = dpSavedptr(dd)->omd[3];
- dpptr(dd)->oUnits = dpSavedptr(dd)->oUnits;
- dpptr(dd)->plt[0] = dpSavedptr(dd)->plt[0];
- dpptr(dd)->plt[1] = dpSavedptr(dd)->plt[1];
- dpptr(dd)->plt[2] = dpSavedptr(dd)->plt[2];
- dpptr(dd)->plt[3] = dpSavedptr(dd)->plt[3];
- dpptr(dd)->pin[0] = dpSavedptr(dd)->pin[0];
- dpptr(dd)->pin[1] = dpSavedptr(dd)->pin[1];
- dpptr(dd)->pUnits = dpSavedptr(dd)->pUnits;
- dpptr(dd)->defaultPlot = dpSavedptr(dd)->defaultPlot;
- dpptr(dd)->pty = dpSavedptr(dd)->pty;
- dpptr(dd)->usr[0] = dpSavedptr(dd)->usr[0];
- dpptr(dd)->usr[1] = dpSavedptr(dd)->usr[1];
- dpptr(dd)->usr[2] = dpSavedptr(dd)->usr[2];
- dpptr(dd)->usr[3] = dpSavedptr(dd)->usr[3];
- dpptr(dd)->logusr[0] = dpSavedptr(dd)->logusr[0];
- dpptr(dd)->logusr[1] = dpSavedptr(dd)->logusr[1];
- dpptr(dd)->logusr[2] = dpSavedptr(dd)->logusr[2];
- dpptr(dd)->logusr[3] = dpSavedptr(dd)->logusr[3];
-}
-
-static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data)
-{
- GESystemDesc *sd;
- baseSystemState *bss, *bss2;
- SEXP result = R_NilValue;
-
- switch (task) {
- case GE_FinaliseState:
- /* called from unregisterOne */
- sd = dd->gesd[baseRegisterIndex];
- free(sd->systemSpecific);
- sd->systemSpecific = NULL;
- break;
- case GE_InitState:
- {
- /* called from registerOne */
- pDevDesc dev;
- GPar *ddp;
- sd = dd->gesd[baseRegisterIndex];
- dev = dd->dev;
- bss = sd->systemSpecific = malloc(sizeof(baseSystemState));
- /* Bail out if necessary */
- if (!bss) return result;
- /* Make sure initialized, or valgrind may complain. */
- memset(bss, 0, sizeof(baseSystemState));
- ddp = &(bss->dp);
- GInit(ddp);
- /* For some things, the device sets the starting value at least. */
- ddp->ps = dev->startps;
- ddp->col = ddp->fg = dev->startcol;
- ddp->bg = dev->startfill;
- ddp->font = dev->startfont;
- ddp->lty = dev->startlty;
- ddp->gamma = dev->startgamma;
- /* Initialise the gp settings too: formerly in addDevice. */
- copyGPar(ddp, &(bss->gp));
- GReset(dd);
- /*
- * The device has not yet received any base output
- */
- bss->baseDevice = FALSE;
- /* Indicate success */
- result = R_BlankString;
- break;
- }
- case GE_CopyState:
- {
- /* called from GEcopyDisplayList */
- pGEDevDesc curdd = GEcurrentDevice();
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific;
- copyGPar(&(bss->dpSaved), &(bss2->dpSaved));
- restoredpSaved(curdd);
- copyGPar(&(bss2->dp), &(bss2->gp));
- GReset(curdd);
- break;
- }
- case GE_SaveState:
- /* called from GEinitDisplayList */
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- copyGPar(&(bss->dp), &(bss->dpSaved));
- break;
- case GE_RestoreState:
- /* called from GEplayDisplayList */
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- restoredpSaved(dd);
- copyGPar(&(bss->dp), &(bss->gp));
- GReset(dd);
- break;
- case GE_SaveSnapshotState:
- /* called from GEcreateSnapshot */
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- /* Changed from INTSXP in 2.7.0: but saved graphics lists
- are protected by an R version number */
- PROTECT(result = allocVector(RAWSXP, sizeof(GPar)));
- copyGPar(&(bss->dpSaved), (GPar*) RAW(result));
- UNPROTECT(1);
- break;
- case GE_RestoreSnapshotState:
- /* called from GEplaySnapshot */
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- copyGPar((GPar*) RAW(data), &(bss->dpSaved));
- restoredpSaved(dd);
- copyGPar(&(bss->dp), &(bss->gp));
- GReset(dd);
- break;
- case GE_CheckPlot:
- /* called from GEcheckState:
- Check that the current plotting state is "valid"
- */
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- result = ScalarLogical(bss->baseDevice ?
- (bss->gp.state == 1) && bss->gp.valid :
- TRUE);
- break;
- case GE_ScalePS:
- {
- /* called from GEhandleEvent in devWindows.c */
- GPar *ddp, *ddpSaved;
- bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- ddp = &(bss->dp);
- ddpSaved = &(bss->dpSaved);
- if (isReal(data) && LENGTH(data) == 1) {
- double rf = REAL(data)[0];
- ddp->scale *= rf;
- /* Modify the saved settings so this effects display list too */
- ddpSaved->scale *= rf;
- } else
- error("event 'GE_ScalePS' requires a single numeric value");
- break;
- }
- }
- return result;
-}
-
-/* (un)Register the base graphics system with the graphics engine
- */
-void
-registerBase(void) {
- GEregisterSystem(baseCallback, &baseRegisterIndex);
-}
-
-void
-unregisterBase(void) {
- GEunregisterSystem(baseRegisterIndex);
- baseRegisterIndex = -1;
-}
-
-SEXP RunregisterBase(void)
-{
- unregisterBase();
- return R_NilValue;
-}
-
-/* FIXME: Make this a macro to avoid function call overhead?
- Inline it if you really think it matters.
- */
-GPar* gpptr(pGEDevDesc dd) {
- if (baseRegisterIndex == -1)
- error(_("the base graphics system is not registered"));
- baseSystemState *bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- return &(bss->gp);
-}
-
-GPar* dpptr(pGEDevDesc dd) {
- if (baseRegisterIndex == -1)
- error(_("the base graphics system is not registered"));
- baseSystemState *bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- return &(bss->dp);
-}
-
-/* called in GNewPlot to mark device as 'dirty' */
-void Rf_setBaseDevice(Rboolean val, pGEDevDesc dd) {
- if (baseRegisterIndex == -1)
- error(_("the base graphics system is not registered"));
- baseSystemState *bss = dd->gesd[baseRegisterIndex]->systemSpecific;
- bss->baseDevice = val;
-}
diff --git a/com.oracle.truffle.r.native/library/graphics/src/graphics.c b/com.oracle.truffle.r.native/library/graphics/src/graphics.c
deleted file mode 100644
index 6b1939e88864589ec2d333f7ab9bf62ff1c2e8e8..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/graphics.c
+++ /dev/null
@@ -1,3484 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--2014 The R Core Team
- * Copyright (C) 2002--2011 The R Foundation
- *
- * 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/
-
-
- * This is an extensive reworking by Paul Murrell of an original
- * quick hack by Ross Ihaka designed to give a superset of the
- * functionality in the AT&T Bell Laboratories GRZ library.
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <Rinternals.h>
-//#include <Defn.h>
-#include <float.h> /* for DBL_EPSILON etc */
-#include "../../grDevices/src/main_Graphics.h"
-// --> R_ext/GraphicsEngine.h + Rgraphics.h
-#include "../../grDevices/src/main_GraphicsBase.h" /* setBaseDevice */
-#include <Rmath.h> /* eg. fmax2() */
-
-#define _(String) (String)
-
-/*--->> Documentation now in ../include/Rgraphics.h "API" ----- */
-
-double R_Log10(double x)
-{
- return (R_FINITE(x) && x > 0.0) ? log10(x) : NA_REAL;
-}
-
-/*-------------------------------------------------------------------
- *
- * TRANSFORMATIONS
- *
- * There are five major regions on a device, for any
- * particular figure: the outer margins, which "stick"
- * to the edges of the device; the inner region, which
- * is defined as the total device less the outer margins;
- * the figure region, which defaults from the current
- * layout (mfrow, mfcol, layout) unless the user specifies
- * it directly (fig, fin); the figure margins, which
- * "stick" to the edges of the plot region; and thed
- * plot region, which is the figure region less the figure
- * margins by default unless the user specifies it directly
- * (plt, pin)
- *
- * COORDINATE SYSTEMS
- *
- * DEVICE = devices natural coordinate system
- * (e.g., pixels, 1/72", ...)
- * NDC = normalised device coordinates (0..1 on device)
- * INCHES = inches
- * OMA1..4 = outer margin coordinates
- * NIC = normalised inner region coordinates
- * (0..1 on inner region)
- * NFC = normalised figure coordinates
- * (0..1 on figure region)
- * MAR1..4 = figure margin coordinates
- * NPC = normalised plot coordinates
- * (0..1 on plot region)
- * USER = world or data coordinates
- *
- *
- * UNITS
- *
- * All of the above, except OMA1..4 and MAR1..4, plus ...
- *
- * LINES = line coordinates (lines of margin; based on mex)
- * CHARS = char coordinates (lines of text; based on cex)
- *
- * The function Convert(value, from, to) is provided
- * to transform between any pair of coordinate systems
- * (for transforming locations)
- *
- * The functions ConvertXUnits(value, from, to) and
- * ConvertYUnits(value, from, to) are provided to transform
- * between any pair of units (for transforming dimensions)
- *
- * IMPORTANT: if user coordinates are logged, then the
- * conversion to/from USER units will not work. in this
- * case it is necessary to use convert(x1) - convert(x2)
- * rather than convert(x1 - x2)
- *
- */
-
-
-/* In interpreted R, units are as follows:
- * 1 = "user"
- * 2 = "figure"
- * 3 = "inches"
- * the function GMapUnits provides a mapping
- * between interpreted units and internal units.
- */
-GUnit GMapUnits(int Runits)
-{
- switch (Runits) {
- case 1: return USER;
- case 2: return NFC;
- case 3: return INCHES;
- default: return 0;
- }
-}
-
- /* Conversions Between Units*/
-
-/* Used to be global (non-static) -- but are nowhere declared.
- * The public interface is through G[XY]ConvertUnits() */
-
-static double xNDCtoDevUnits(double x, pGEDevDesc dd)
-{
- return x*fabs(gpptr(dd)->ndc2dev.bx);
-}
-
-static double yNDCtoDevUnits(double y, pGEDevDesc dd)
-{
- return y*fabs(gpptr(dd)->ndc2dev.by);
-}
-
-static double xNICtoDevUnits(double x, pGEDevDesc dd)
-{
- return x*fabs(gpptr(dd)->inner2dev.bx);
-}
-
-static double yNICtoDevUnits(double y, pGEDevDesc dd)
-{
- return y*fabs(gpptr(dd)->inner2dev.by);
-}
-
-static double xNFCtoDevUnits(double x, pGEDevDesc dd)
-{
- return x*fabs(gpptr(dd)->fig2dev.bx);
-}
-
-static double yNFCtoDevUnits(double y, pGEDevDesc dd)
-{
- return y*fabs(gpptr(dd)->fig2dev.by);
-}
-
-static double xNPCtoDevUnits(double x, pGEDevDesc dd)
-{
- return xNFCtoDevUnits(x*(gpptr(dd)->plt[1] - gpptr(dd)->plt[0]), dd);
-}
-
-static double yNPCtoDevUnits(double y, pGEDevDesc dd)
-{
- return yNFCtoDevUnits(y*(gpptr(dd)->plt[3] - gpptr(dd)->plt[2]), dd);
-}
-
-static double xUsrtoDevUnits(double x, pGEDevDesc dd)
-{
- return xNFCtoDevUnits(x*gpptr(dd)->win2fig.bx, dd);
-}
-
-static double yUsrtoDevUnits(double y, pGEDevDesc dd)
-{
- return yNFCtoDevUnits(y*gpptr(dd)->win2fig.by, dd);
-}
-
-static double xInchtoDevUnits(double x, pGEDevDesc dd)
-{
- return xNDCtoDevUnits(x*gpptr(dd)->xNDCPerInch, dd);
-}
-
-static double yInchtoDevUnits(double y, pGEDevDesc dd)
-{
- return yNDCtoDevUnits(y*gpptr(dd)->yNDCPerInch, dd);
-}
-
-static double xLinetoDevUnits(double x, pGEDevDesc dd)
-{
- return xNDCtoDevUnits(x*gpptr(dd)->xNDCPerLine, dd);
-}
-
-static double yLinetoDevUnits(double y, pGEDevDesc dd)
-{
- return yNDCtoDevUnits(y*gpptr(dd)->yNDCPerLine, dd);
-}
-
-static double xChartoDevUnits(double x, pGEDevDesc dd)
-{
- return xNDCtoDevUnits(x*gpptr(dd)->cex*gpptr(dd)->xNDCPerChar, dd);
-}
-
-static double yChartoDevUnits(double y, pGEDevDesc dd)
-{
- return yNDCtoDevUnits(y*gpptr(dd)->cex*gpptr(dd)->yNDCPerChar, dd);
-}
-
-static double xDevtoNDCUnits(double x, pGEDevDesc dd)
-{
- return x/fabs(gpptr(dd)->ndc2dev.bx);
-}
-
-static double yDevtoNDCUnits(double y, pGEDevDesc dd)
-{
- return y/fabs(gpptr(dd)->ndc2dev.by);
-}
-
-static double xDevtoNICUnits(double x, pGEDevDesc dd)
-{
- return x/fabs(gpptr(dd)->inner2dev.bx);
-}
-
-static double yDevtoNICUnits(double y, pGEDevDesc dd)
-{
- return y/fabs(gpptr(dd)->inner2dev.by);
-}
-
-static double xDevtoNFCUnits(double x, pGEDevDesc dd)
-{
- return x/fabs(gpptr(dd)->fig2dev.bx);
-}
-
-static double yDevtoNFCUnits(double y, pGEDevDesc dd)
-{
- return y/fabs(gpptr(dd)->fig2dev.by);
-}
-
-static double xDevtoNPCUnits(double x, pGEDevDesc dd)
-{
- return xDevtoNFCUnits(x, dd)/(gpptr(dd)->plt[1] - gpptr(dd)->plt[0]);
-}
-
-static double yDevtoNPCUnits(double y, pGEDevDesc dd)
-{
- return yDevtoNFCUnits(y, dd)/(gpptr(dd)->plt[3] - gpptr(dd)->plt[2]);
-}
-
-static double xDevtoUsrUnits(double x, pGEDevDesc dd)
-{
- return xDevtoNFCUnits(x, dd)/gpptr(dd)->win2fig.bx;
-}
-
-static double yDevtoUsrUnits(double y, pGEDevDesc dd)
-{
- return yDevtoNFCUnits(y, dd)/gpptr(dd)->win2fig.by;
-}
-
-static double xDevtoInchUnits(double x, pGEDevDesc dd)
-{
- return xDevtoNDCUnits(x, dd)/gpptr(dd)->xNDCPerInch;
-}
-
-static double yDevtoInchUnits(double y, pGEDevDesc dd)
-{
- return yDevtoNDCUnits(y, dd)/gpptr(dd)->yNDCPerInch;
-}
-
-static double xDevtoLineUnits(double x, pGEDevDesc dd)
-{
- return xDevtoNDCUnits(x, dd)/gpptr(dd)->xNDCPerLine;
-}
-
-static double yDevtoLineUnits(double y, pGEDevDesc dd)
-{
- return yDevtoNDCUnits(y, dd)/gpptr(dd)->yNDCPerLine;
-}
-
-/* NOTE that use the _current_ gpptr(dd)->cex here */
-/* the conversion for lines doesn't have to worry about */
-/* this because gpptr(dd)->mex can only be set once per plot */
-
-static double xDevtoCharUnits(double x, pGEDevDesc dd)
-{
- return xDevtoNDCUnits(x, dd)/(gpptr(dd)->cex * gpptr(dd)->xNDCPerChar);
-}
-
-static double yDevtoCharUnits(double y, pGEDevDesc dd)
-{
- return yDevtoNDCUnits(y, dd)/(gpptr(dd)->cex * gpptr(dd)->yNDCPerChar);
-}
-
-static void BadUnitsError(const char *where)
-{
- error(_("bad units specified in '%s'"), where);
-}
-
-/* GConvertXUnits() and GConvertYUnits() convert
- a single value fromUnits toUnits : */
-
-double GConvertXUnits(double x, GUnit fromUnits, GUnit toUnits, pGEDevDesc dd)
-{
- double dev, final;
- switch (fromUnits) {
- case DEVICE: dev = x; break;
- case NDC: dev = xNDCtoDevUnits(x, dd); break;
- case NIC: dev = xNICtoDevUnits(x, dd); break;
- case NFC: dev = xNFCtoDevUnits(x, dd); break;
- case NPC: dev = xNPCtoDevUnits(x, dd); break;
- case USER: dev = xUsrtoDevUnits(x, dd); break;
- case INCHES: dev = xInchtoDevUnits(x, dd); break;
- case LINES: dev = xLinetoDevUnits(x, dd); break;
- case CHARS: dev = xChartoDevUnits(x, dd); break;
- default: dev = 0; BadUnitsError("GConvertXUnits");
-
- }
- switch (toUnits) {
- case DEVICE: final = dev; break;
- case NDC: final = xDevtoNDCUnits(dev, dd); break;
- case NIC: final = xDevtoNICUnits(dev, dd); break;
- case NFC: final = xDevtoNFCUnits(dev, dd); break;
- case NPC: final = xDevtoNPCUnits(dev, dd); break;
- case USER: final = xDevtoUsrUnits(dev, dd); break;
- case INCHES: final = xDevtoInchUnits(dev, dd); break;
- case LINES: final = xDevtoLineUnits(dev, dd); break;
- case CHARS: final = xDevtoCharUnits(dev, dd); break;
- default: final = 0; BadUnitsError("GConvertXUnits");
- }
- return final;
-}
-
-double GConvertYUnits(double y, GUnit fromUnits, GUnit toUnits, pGEDevDesc dd)
-{
- double dev, final;
- switch (fromUnits) {
- case DEVICE: dev = y; break;
- case NDC: dev = yNDCtoDevUnits(y, dd); break;
- case NIC: dev = yNICtoDevUnits(y, dd); break;
- case NFC: dev = yNFCtoDevUnits(y, dd); break;
- case NPC: dev = yNPCtoDevUnits(y, dd); break;
- case USER: dev = yUsrtoDevUnits(y, dd); break;
- case INCHES: dev = yInchtoDevUnits(y, dd); break;
- case LINES: dev = yLinetoDevUnits(y, dd); break;
- case CHARS: dev = yChartoDevUnits(y, dd); break;
- default: dev = 0; BadUnitsError("GConvertYUnits");
- }
- switch (toUnits) {
- case DEVICE: final = dev; break;
- case NDC: final = yDevtoNDCUnits(dev, dd); break;
- case NIC: final = yDevtoNICUnits(dev, dd); break;
- case NFC: final = yDevtoNFCUnits(dev, dd); break;
- case NPC: final = yDevtoNPCUnits(dev, dd); break;
- case USER: final = yDevtoUsrUnits(dev, dd); break;
- case INCHES: final = yDevtoInchUnits(dev, dd); break;
- case LINES: final = yDevtoLineUnits(dev, dd); break;
- case CHARS: final = yDevtoCharUnits(dev, dd); break;
- default: final = 0; BadUnitsError("GConvertYUnits");
- }
- return final;
-}
-
-/* Functions to convert locations from one coordinate system to another */
-
-/* OTHER coordinate systems to DEVICE */
-
-/* Used to be global (non-static) -- but are nowhere declared.
- * The public interface is GConvert(), GConvertX(), GConvertY() */
-static double xNDCtoDev(double x, pGEDevDesc dd)
-{
- return gpptr(dd)->ndc2dev.ax + x*gpptr(dd)->ndc2dev.bx;
-}
-
-static double yNDCtoDev(double y, pGEDevDesc dd)
-{
- return gpptr(dd)->ndc2dev.ay + y*gpptr(dd)->ndc2dev.by;
-}
-
-static double xInchtoDev(double x, pGEDevDesc dd)
-{
- return xNDCtoDev(x*gpptr(dd)->xNDCPerInch, dd);
-}
-
-static double yInchtoDev(double y, pGEDevDesc dd)
-{
- return yNDCtoDev(y*gpptr(dd)->yNDCPerInch, dd);
-}
-
-static double xLinetoDev(double x, pGEDevDesc dd)
-{
- return xNDCtoDev(x*gpptr(dd)->xNDCPerLine, dd);
-}
-
-static double yLinetoDev(double y, pGEDevDesc dd)
-{
- return yNDCtoDev(y*gpptr(dd)->yNDCPerLine, dd);
-}
-
-static double xNICtoDev(double x, pGEDevDesc dd)
-{
- return gpptr(dd)->inner2dev.ax + x*gpptr(dd)->inner2dev.bx;
-}
-
-static double yNICtoDev(double y, pGEDevDesc dd)
-{
- return gpptr(dd)->inner2dev.ay + y*gpptr(dd)->inner2dev.by;
-}
-/* NOTE that an x-coordinate in OMA2 or OMA4 converts to a */
-/* y-coordinate in Dev and a y-coordinate in OMA2 or OMA4 */
-/* converts to an x-coordinate in Dev */
-
-static double xOMA1toDev(double x, pGEDevDesc dd)
-{
- return xNICtoDev(x, dd);
-}
-
-static double yOMA1toDev(double y, pGEDevDesc dd)
-{
- return yLinetoDev((gpptr(dd)->oma[0] - y), dd);
-}
-
-static double xOMA2toyDev(double x, pGEDevDesc dd)
-{
- return yNICtoDev(x, dd);
-}
-
-static double yOMA2toxDev(double y, pGEDevDesc dd)
-{
- return xLinetoDev((gpptr(dd)->oma[1] - y), dd);
-}
-
-static double xOMA3toDev(double x, pGEDevDesc dd)
-{
- return xNICtoDev(x, dd);
-}
-
-static double yOMA3toDev(double y, pGEDevDesc dd)
-{
- double ndc = 1.0-yDevtoNDC(yLinetoDev((gpptr(dd)->oma[2] - y), dd), dd);
- return yNDCtoDev(ndc, dd);
-}
-
-static double xOMA4toyDev(double x, pGEDevDesc dd)
-{
- return yNICtoDev(x, dd);
-}
-
-static double yOMA4toxDev(double y, pGEDevDesc dd)
-{
- double ndc = 1.0-xDevtoNDC(xLinetoDev(gpptr(dd)->oma[3]-y, dd), dd);
- return xNDCtoDev(ndc, dd);
-}
-
-static double xNFCtoDev(double x, pGEDevDesc dd)
-{
- return gpptr(dd)->fig2dev.ax + x*gpptr(dd)->fig2dev.bx;
-}
-
-static double yNFCtoDev(double y, pGEDevDesc dd)
-{
- return gpptr(dd)->fig2dev.ay + y*gpptr(dd)->fig2dev.by;
-}
-
-static double xNPCtoDev(double x, pGEDevDesc dd)
-{
- return xNFCtoDev(gpptr(dd)->plt[0] +
- x*(gpptr(dd)->plt[1] - gpptr(dd)->plt[0]), dd);
-}
-
-static double yNPCtoDev(double y, pGEDevDesc dd)
-{
- return yNFCtoDev(gpptr(dd)->plt[2] +
- y*(gpptr(dd)->plt[3] - gpptr(dd)->plt[2]), dd);
-}
-
-static double xUsrtoDev(double x, pGEDevDesc dd)
-{
- if (gpptr(dd)->xlog)
- x = R_Log10(x);
- return xNFCtoDev(gpptr(dd)->win2fig.ax + x*gpptr(dd)->win2fig.bx, dd);
-}
-
-static double yUsrtoDev(double y, pGEDevDesc dd)
-{
- if (gpptr(dd)->ylog)
- y = R_Log10(y);
- return yNFCtoDev(gpptr(dd)->win2fig.ay + y*gpptr(dd)->win2fig.by, dd);
-}
-
-/* NOTE that an x-coordinate in MAR2 or MAR4 converts to a */
-/* y-coordinate in Dev and a y-coordinate in MAR2 or MAR4 */
-/* converts to an x-coordinate in Dev */
-
-static double xMAR1toDev(double x, pGEDevDesc dd)
-{
- return xUsrtoDev(x, dd);
-}
-
-static double yMAR1toDev(double y, pGEDevDesc dd)
-{
- double nfc = GConvertYUnits(y, LINES, NFC, dd);
- return yNFCtoDev(gpptr(dd)->plt[2] - nfc, dd);
-}
-
-static double xMAR2toyDev(double x, pGEDevDesc dd)
-{
- return yUsrtoDev(x, dd);
-}
-
-static double yMAR2toxDev(double y, pGEDevDesc dd)
-{
- double nfc = GConvertXUnits(y, LINES, NFC, dd);
- return xNFCtoDev(gpptr(dd)->plt[0] - nfc, dd);
-}
-
-static double xMAR3toDev(double x, pGEDevDesc dd)
-{
- return xUsrtoDev(x, dd);
-}
-
-static double yMAR3toDev(double y, pGEDevDesc dd)
-{
- double nfc = GConvertYUnits(y, LINES, NFC, dd);
- return yNFCtoDev(gpptr(dd)->plt[3] + nfc, dd);
-}
-
-static double xMAR4toyDev(double x, pGEDevDesc dd)
-{
- return yUsrtoDev(x, dd);
-}
-
-static double yMAR4toxDev(double y, pGEDevDesc dd)
-{
- double nfc = GConvertXUnits(y, LINES, NFC, dd);
- return xNFCtoDev(gpptr(dd)->plt[1] + nfc, dd);
-}
-
-/* DEVICE coordinates to OTHER */
-
-double xDevtoNDC(double x, pGEDevDesc dd)
-{
- return (x - gpptr(dd)->ndc2dev.ax)/gpptr(dd)->ndc2dev.bx;
-}
-
-double yDevtoNDC(double y, pGEDevDesc dd)
-{
- return (y - gpptr(dd)->ndc2dev.ay)/gpptr(dd)->ndc2dev.by;
-}
-
-static double xDevtoInch(double x, pGEDevDesc dd)
-{
- return xDevtoNDC(x, dd)/gpptr(dd)->xNDCPerInch;
-}
-
-static double yDevtoInch(double y, pGEDevDesc dd)
-{
- return yDevtoNDC(y, dd)/gpptr(dd)->yNDCPerInch;
-}
-
-static double xDevtoLine(double x, pGEDevDesc dd)
-{
- return xDevtoNDC(x, dd)/gpptr(dd)->xNDCPerLine;
-}
-
-static double yDevtoLine(double y, pGEDevDesc dd)
-{
- return yDevtoNDC(y, dd)/gpptr(dd)->yNDCPerLine;
-}
-
-static double xDevtoNIC(double x, pGEDevDesc dd)
-{
- return (x - gpptr(dd)->inner2dev.ax)/gpptr(dd)->inner2dev.bx;
-}
-
-static double yDevtoNIC(double y, pGEDevDesc dd)
-{
- return (y - gpptr(dd)->inner2dev.ay)/gpptr(dd)->inner2dev.by;
-}
-
-static double xDevtoOMA1(double x, pGEDevDesc dd)
-{
- return xDevtoNIC(x, dd);
-}
-
-static double yDevtoOMA1(double y, pGEDevDesc dd)
-{
- return gpptr(dd)->oma[0] - yDevtoLine(y, dd);
-}
-
-static double xDevtoyOMA2(double x, pGEDevDesc dd)
-{
- return gpptr(dd)->oma[1] - xDevtoLine(x, dd);
-}
-
-static double yDevtoxOMA2(double y, pGEDevDesc dd)
-{
- return yDevtoNIC(y, dd);
-}
-
-static double xDevtoOMA3(double x, pGEDevDesc dd)
-{
- return xDevtoNIC(x, dd);
-}
-
-static double yDevtoOMA3(double y, pGEDevDesc dd)
-{
- double line = (1.0 - yDevtoNDC(y, dd))/gpptr(dd)->yNDCPerLine;
- return gpptr(dd)->oma[2] - line;
-}
-
-static double xDevtoyOMA4(double x, pGEDevDesc dd)
-{
- double line = (1.0 - xDevtoNDC(x, dd))/gpptr(dd)->xNDCPerLine;
- return gpptr(dd)->oma[3] - line;
-}
-
-static double yDevtoxOMA4(double y, pGEDevDesc dd)
-{
- return yDevtoNIC(y, dd);
-}
-
-double xDevtoNFC(double x, pGEDevDesc dd)
-{
- return (x - gpptr(dd)->fig2dev.ax)/gpptr(dd)->fig2dev.bx;
-}
-
-double yDevtoNFC(double y, pGEDevDesc dd)
-{
- return (y - gpptr(dd)->fig2dev.ay)/gpptr(dd)->fig2dev.by;
-}
-
-double xDevtoNPC(double x, pGEDevDesc dd)
-{
- return (xDevtoNFC(x, dd) - gpptr(dd)->plt[0])/
- (gpptr(dd)->plt[1] - gpptr(dd)->plt[0]);
-}
-
-double yDevtoNPC(double y, pGEDevDesc dd)
-{
- return (yDevtoNFC(y, dd) - gpptr(dd)->plt[2])/
- (gpptr(dd)->plt[3] - gpptr(dd)->plt[2]);
-}
-
-/* a special case (NPC = normalised plot region coordinates) */
-
-double xNPCtoUsr(double x, pGEDevDesc dd)
-{
- if (gpptr(dd)->xlog)
- return Rexp10(gpptr(dd)->logusr[0] +
- x*(gpptr(dd)->logusr[1] - gpptr(dd)->logusr[0]));
- else
- return gpptr(dd)->usr[0] + x*(gpptr(dd)->usr[1] - gpptr(dd)->usr[0]);
-}
-
-double yNPCtoUsr(double y, pGEDevDesc dd)
-{
- if (gpptr(dd)->ylog)
- return Rexp10(gpptr(dd)->logusr[2] +
- y*(gpptr(dd)->logusr[3]-gpptr(dd)->logusr[2]));
- else
- return gpptr(dd)->usr[2] + y*(gpptr(dd)->usr[3] - gpptr(dd)->usr[2]);
-}
-
-double xDevtoUsr(double x, pGEDevDesc dd)
-{
- double nfc = xDevtoNFC(x, dd);
- if (gpptr(dd)->xlog)
- return Rexp10((nfc - gpptr(dd)->win2fig.ax)/gpptr(dd)->win2fig.bx);
- else
- return (nfc - gpptr(dd)->win2fig.ax)/gpptr(dd)->win2fig.bx;
-}
-
-double yDevtoUsr(double y, pGEDevDesc dd)
-{
- double nfc = yDevtoNFC(y, dd);
- if (gpptr(dd)->ylog)
- return Rexp10((nfc - gpptr(dd)->win2fig.ay)/gpptr(dd)->win2fig.by);
- else
- return (nfc - gpptr(dd)->win2fig.ay)/gpptr(dd)->win2fig.by;
-}
-
-static double xDevtoMAR1(double x, pGEDevDesc dd)
-{
- return xDevtoUsr(x, dd);
-}
-
-static double yDevtoMAR1(double y, pGEDevDesc dd)
-{
- return gpptr(dd)->oma[0] + gpptr(dd)->mar[0] - yDevtoLine(y, dd);
-}
-
-static double xDevtoyMAR2(double x, pGEDevDesc dd)
-{
- return gpptr(dd)->oma[1] + gpptr(dd)->mar[1] - xDevtoLine(x, dd);
-}
-
-static double yDevtoxMAR2(double y, pGEDevDesc dd)
-{
- return yDevtoUsr(y, dd);
-}
-
-static double xDevtoMAR3(double x, pGEDevDesc dd)
-{
- return xDevtoUsr(x, dd);
-}
-
-static double yDevtoMAR3(double y, pGEDevDesc dd)
-{
- double line = GConvertYUnits(1.0 - yDevtoNFC(y, dd), NFC, LINES, dd);
- return gpptr(dd)->mar[2] - line;
-}
-
-static double xDevtoyMAR4(double x, pGEDevDesc dd)
-{
- double line = GConvertXUnits(1.0 - xDevtoNFC(x, dd), NFC, LINES, dd);
- return gpptr(dd)->mar[3] - line;
-}
-
-static double yDevtoxMAR4(double y, pGEDevDesc dd)
-{
- return yDevtoUsr(y, dd);
-}
-
-/* the Convert function converts a LOCATION in the FROM coordinate */
-/* system to a LOCATION in the TO coordinate system */
-
-void GConvert(double *x, double *y, GUnit from, GUnit to, pGEDevDesc dd)
-{
- double devx, devy;
-
- switch (from) {
- case DEVICE:
- devx = *x;
- devy = *y;
- break;
- case NDC:
- devx = xNDCtoDev(*x, dd);
- devy = yNDCtoDev(*y, dd);
- break;
- case INCHES:
- devx = xInchtoDev(*x, dd);
- devy = yInchtoDev(*y, dd);
- break;
- case OMA1:
- devx = xOMA1toDev(*x, dd);
- devy = yOMA1toDev(*y, dd);
- break;
- case OMA2:
- devx = yOMA2toxDev(*y, dd);
- devy = xOMA2toyDev(*x, dd);
- break;
- case OMA3:
- devx = xOMA3toDev(*x, dd);
- devy = yOMA3toDev(*y, dd);
- break;
- case OMA4:
- devx = yOMA4toxDev(*y, dd);
- devy = xOMA4toyDev(*x, dd);
- break;
- case NIC:
- devx = xNICtoDev(*x, dd);
- devy = yNICtoDev(*y, dd);
- break;
- case NFC:
- devx = xNFCtoDev(*x, dd);
- devy = yNFCtoDev(*y, dd);
- break;
- case MAR1:
- devx = xMAR1toDev(*x, dd);
- devy = yMAR1toDev(*y, dd);
- break;
- case MAR2:
- devx = yMAR2toxDev(*y, dd);
- devy = xMAR2toyDev(*x, dd);
- break;
- case MAR3:
- devx = xMAR3toDev(*x, dd);
- devy = yMAR3toDev(*y, dd);
- break;
- case MAR4:
- devx = yMAR4toxDev(*y, dd);
- devy = xMAR4toyDev(*x, dd);
- break;
- case NPC:
- devx = xNPCtoDev(*x, dd);
- devy = yNPCtoDev(*y, dd);
- break;
- case USER:
- devx = xUsrtoDev(*x, dd);
- devy = yUsrtoDev(*y, dd);
- break;
- default:
- devx = 0; /* for -Wall */
- devy = 0;
- BadUnitsError("GConvert");
- }
-
- switch (to) {
- case DEVICE:
- *x = devx;
- *y = devy;
- break;
- case NDC:
- *x = xDevtoNDC(devx, dd);
- *y = yDevtoNDC(devy, dd);
- break;
- case INCHES:
- *x = xDevtoInch(devx, dd);
- *y = yDevtoInch(devy, dd);
- break;
- case LINES:
- *x = xDevtoLine(devx, dd);
- *y = yDevtoLine(devy, dd);
- break;
- case NIC:
- *x = xDevtoNIC(devx, dd);
- *y = yDevtoNIC(devy, dd);
- break;
- case OMA1:
- *x = xDevtoOMA1(devx, dd);
- *y = yDevtoOMA1(devy, dd);
- break;
- case OMA2:
- *x = yDevtoxOMA2(devy, dd);
- *y = xDevtoyOMA2(devx, dd);
- break;
- case OMA3:
- *x = xDevtoOMA3(devx, dd);
- *y = yDevtoOMA3(devy, dd);
- break;
- case OMA4:
- *x = yDevtoxOMA4(devy, dd);
- *y = xDevtoyOMA4(devx, dd);
- break;
- case NFC:
- *x = xDevtoNFC(devx, dd);
- *y = yDevtoNFC(devy, dd);
- break;
- case NPC:
- *x = xDevtoNPC(devx, dd);
- *y = yDevtoNPC(devy, dd);
- break;
- case USER:
- *x = xDevtoUsr(devx, dd);
- *y = yDevtoUsr(devy, dd);
- break;
- case MAR1:
- *x = xDevtoMAR1(devx, dd);
- *y = yDevtoMAR1(devy, dd);
- break;
- case MAR2:
- *x = yDevtoxMAR2(devy, dd);
- *y = xDevtoyMAR2(devx, dd);
- break;
- case MAR3:
- *x = xDevtoMAR3(devx, dd);
- *y = yDevtoMAR3(devy, dd);
- break;
- case MAR4:
- *x = yDevtoxMAR4(devy, dd);
- *y = xDevtoyMAR4(devx, dd);
- break;
- default:
- BadUnitsError("GConvert");
- }
-}
-
-double GConvertX(double x, GUnit from, GUnit to, pGEDevDesc dd)
-{
- double devx;
- switch (from) {
- case DEVICE:devx = x; break;
- case NDC: devx = xNDCtoDev(x, dd); break;
- case INCHES:devx = xInchtoDev(x, dd); break;
- case LINES: devx = xLinetoDev(x, dd); break;
- case OMA1: devx = xOMA1toDev(x, dd); break;
- /*case OMA2: x <--> y */
- case OMA3: devx = xOMA3toDev(x, dd); break;
- /*case OMA4: x <--> y */
- case NIC: devx = xNICtoDev(x, dd); break;
- case NFC: devx = xNFCtoDev(x, dd); break;
- case MAR1: devx = xMAR1toDev(x, dd); break;
- /*case MAR2: x <--> y */
- case MAR3: devx = xMAR3toDev(x, dd); break;
- /*case MAR4: x <--> y */
- case NPC: devx = xNPCtoDev(x, dd); break;
- case USER: devx = xUsrtoDev(x, dd); break;
- default: devx = 0;/* for -Wall */ BadUnitsError("GConvertX");
- }
-
- switch (to) {
- case DEVICE:x = devx; break;
- case NDC: x = xDevtoNDC(devx, dd); break;
- case INCHES:x = xDevtoInch(devx, dd); break;
- case LINES: x = xDevtoLine(devx, dd); break;
- case NIC: x = xDevtoNIC(devx, dd); break;
- case OMA1: x = xDevtoOMA1(devx, dd); break;
- /*case OMA2: x <--> y */
- case OMA3: x = xDevtoOMA3(devx, dd); break;
- /*case OMA4: x <--> y */
- case NFC: x = xDevtoNFC(devx, dd); break;
- case USER: x = xDevtoUsr(devx, dd); break;
- case MAR1: x = xDevtoMAR1(devx, dd); break;
- /*case MAR2: x <--> y */
- case MAR3: x = xDevtoMAR3(devx, dd); break;
- /*case MAR4: x <--> y */
- case NPC: x = xDevtoNPC(devx, dd); break;
- default: BadUnitsError("GConvertX");
- }
- return x;
-}
-
-double GConvertY(double y, GUnit from, GUnit to, pGEDevDesc dd)
-{
- double devy;
- switch (from) {
- case DEVICE:devy = y; break;
- case NDC: devy = yNDCtoDev(y, dd); break;
- case INCHES:devy = yInchtoDev(y, dd); break;
- case LINES: devy = yLinetoDev(y, dd); break;
- case OMA1: devy = yOMA1toDev(y, dd); break;
- /*case OMA2: x <--> y */
- case OMA3: devy = yOMA3toDev(y, dd); break;
- /*case OMA4: x <--> y */
- case NIC: devy = yNICtoDev(y, dd); break;
- case NFC: devy = yNFCtoDev(y, dd); break;
- case MAR1: devy = yMAR1toDev(y, dd); break;
- /*case MAR2: x <--> y */
- case MAR3: devy = yMAR3toDev(y, dd); break;
- /*case MAR4: x <--> y */
- case NPC: devy = yNPCtoDev(y, dd); break;
- case USER: devy = yUsrtoDev(y, dd); break;
- default: devy = 0;/* for -Wall */ BadUnitsError("GConvertY");
- }
-
- switch (to) {
- case DEVICE:y = devy; break;
- case NDC: y = yDevtoNDC(devy, dd); break;
- case INCHES:y = yDevtoInch(devy, dd); break;
- case LINES: y = yDevtoLine(devy, dd); break;
- case NIC: y = yDevtoNIC(devy, dd); break;
- case OMA1: y = yDevtoOMA1(devy, dd); break;
- /*case OMA2: x <--> y */
- case OMA3: y = yDevtoOMA3(devy, dd); break;
- /*case OMA4: x <--> y */
- case NFC: y = yDevtoNFC(devy, dd); break;
- case USER: y = yDevtoUsr(devy, dd); break;
- case MAR1: y = yDevtoMAR1(devy, dd); break;
- /*case MAR2: x <--> y */
- case MAR3: y = yDevtoMAR3(devy, dd); break;
- /*case MAR4: x <--> y */
- case NPC: y = yDevtoNPC(devy, dd); break;
- default: BadUnitsError("GConvertY");
- }
- return y;
-}
-
-/* Code for layouts */
-
-static double sum(double values[], int n, int cmValues[], int cmSum)
-{
- int i;
- double s = 0;
- for (i = 0; i < n; i++)
- if ((cmSum && cmValues[i]) || (!cmSum && !cmValues[i]))
- s = s + values[i];
- return s;
-}
-
-static double sumWidths(pGEDevDesc dd)
-{
- return sum(gpptr(dd)->widths, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 0);
-}
-
-static double sumCmWidths(pGEDevDesc dd)
-{
- return sum(gpptr(dd)->widths, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 1);
-}
-
-static double sumHeights(pGEDevDesc dd)
-{
- return sum(gpptr(dd)->heights, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 0);
-}
-
-static double sumCmHeights(pGEDevDesc dd)
-{
- return sum(gpptr(dd)->heights, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 1);
-}
-
-static int tallLayout(double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- return (cmHeight/sumHeights(dd)) > (cmWidth/sumWidths(dd));
-}
-
-static void figureExtent(int *minCol, int *maxCol, int *minRow, int *maxRow,
- int figureNum, pGEDevDesc dd)
-{
- int minc = -1;
- int maxc = -1;
- int minr = -1;
- int maxr = -1;
- int i, j;
- int nr = gpptr(dd)->numrows;
- for (i = 0; i < nr; i++)
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (gpptr(dd)->order[i + j*nr] == figureNum) {
- if ((minc == -1) || (j < minc))
- minc = j;
- if ((maxc == -1) || (j > maxc))
- maxc = j;
- if ((minr == -1) || (i < minr))
- minr = i;
- if ((maxr == -1) || (i > maxr))
- maxr = i;
- }
- *minCol = minc;
- *maxCol = maxc;
- *minRow = minr;
- *maxRow = maxr;
-}
-
-static double sumRegions(double regions[], int from, int to)
-{
- int i;
- double s = 0;
- for (i = from; i < to + 1; i++)
- s = s + regions[i];
- return s;
-}
-
-static void largestRegion(double *width, double *height,
- double layoutAspectRatio, double innerAspectRatio)
-{
- if (layoutAspectRatio < innerAspectRatio) {
- *width = 1.0;
- *height = layoutAspectRatio/innerAspectRatio;
- }
- else {
- *width = innerAspectRatio/layoutAspectRatio;
- *height = 1.0;
- }
-}
-
-static void layoutRegion(double *width, double *height,
- double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- largestRegion(width, height,
- sum(heights, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 0)/
- sum(widths, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 0),
- cmHeight/cmWidth);
-}
-
-
- /* allocate one dimension (width or height) for either */
- /* relative or cm units */
-
-static void allocDimension(double dimensions[], double sumDimensions, int n,
- int cmDimensions[], int cmDimension)
-{
- int i;
- for (i = 0; i < n; i++)
- if ((cmDimension && cmDimensions[i]) ||
- (!cmDimension && !cmDimensions[i]))
- dimensions[i] = dimensions[i]/sumDimensions;
-}
-
-static void allCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- allocDimension(widths, cmWidth, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 1);
- allocDimension(heights, cmHeight, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 1);
-}
-
-static void modifyDimension(double dimension[], double multiplier, double n,
- int cmDimensions[])
-{
- int i;
- for (i = 0; i < n; i++)
- if (!cmDimensions[i])
- dimension[i] = dimension[i] * multiplier;
-}
-
-static void modifyRegions(double widths[], double heights[],
- double colMultiplier, double rowMultiplier,
- pGEDevDesc dd)
-{
- modifyDimension(widths, colMultiplier, gpptr(dd)->numcols, gpptr(dd)->cmWidths);
- modifyDimension(heights, rowMultiplier, gpptr(dd)->numrows, gpptr(dd)->cmHeights);
-}
-
-static void regionsWithoutRespect(double widths[], double heights[], pGEDevDesc dd)
-{
- allocDimension(widths,
- sum(widths, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 0),
- gpptr(dd)->numcols, gpptr(dd)->cmWidths, 0);
- allocDimension(heights,
- sum(heights, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 0),
- gpptr(dd)->numrows, gpptr(dd)->cmHeights, 0);
-}
-
-static void regionsWithRespect(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- double cm, rm;
- layoutRegion(&cm, &rm, widths, heights, cmWidth, cmHeight, dd);
- regionsWithoutRespect(widths, heights, dd);
- modifyRegions(widths, heights, cm, rm, dd);
-}
-
-static void widthsRespectingHeights(double widths[],
- double cmWidth, double cmHeight,
- pGEDevDesc dd)
-{
- int i, j;
- int respectedCols[MAX_LAYOUT_COLS];
- double widthLeft;
- double disrespectedWidth = 0;
- int nr = gpptr(dd)->numrows;
- for (j = 0; j < gpptr(dd)->numcols; j++) {
- respectedCols[j] = 0;
- widths[j] = gpptr(dd)->widths[j];
- }
- for (i = 0; i < nr; i++)
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (gpptr(dd)->respect[i + j * nr] &&
- !gpptr(dd)->cmWidths[j]) respectedCols[j] = 1;
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (!respectedCols[j])
- disrespectedWidth += gpptr(dd)->widths[j];
- widthLeft = sumHeights(dd) * cmWidth/cmHeight -
- sumWidths(dd) + disrespectedWidth;
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (!respectedCols[j])
- widths[j] = widthLeft * widths[j]/disrespectedWidth;
-}
-
-static void regionsRespectingHeight(double widths[], double heights[],
- double cmWidth, double cmHeight,
- pGEDevDesc dd)
-{
- widthsRespectingHeights(widths, cmWidth, cmHeight, dd);
- regionsWithRespect(widths, heights, cmWidth, cmHeight, dd);
-}
-
-static void heightsRespectingWidths(double heights[],
- double cmWidth, double cmHeight,
- pGEDevDesc dd)
-{
- int i, j;
- int respectedRows[MAX_LAYOUT_ROWS];
- double heightLeft;
- double disrespectedHeight = 0;
- int nr = gpptr(dd)->numrows;
- for (i = 0; i < nr; i++) {
- respectedRows[i] = 0;
- heights[i] = gpptr(dd)->heights[i];
- }
- for (i = 0; i < nr; i++)
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (gpptr(dd)->respect[i + j*nr] &&
- !gpptr(dd)->cmHeights[i]) respectedRows[i] = 1;
- for (i = 0; i < gpptr(dd)->numrows; i++)
- if (!respectedRows[i])
- disrespectedHeight += gpptr(dd)->heights[i];
- heightLeft = sumWidths(dd) * cmHeight/cmWidth -
- sumHeights(dd) + disrespectedHeight;
- for (i = 0; i < gpptr(dd)->numrows; i++)
- if (!respectedRows[i])
- heights[i] = heightLeft * heights[i]/disrespectedHeight;
-}
-
-static void regionsRespectingWidth(double widths[], double heights[],
- double cmWidth, double cmHeight,
- pGEDevDesc dd)
-{
- heightsRespectingWidths(heights, cmWidth, cmHeight, dd);
- regionsWithRespect(widths, heights, cmWidth, cmHeight, dd);
-}
-
-static void noCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- switch (gpptr(dd)->rspct) {
- case 0:
- regionsWithoutRespect(widths, heights, dd);
- break;
- case 1:
- regionsWithRespect(widths, heights, cmWidth, cmHeight, dd);
- break;
- case 2:
- if (tallLayout(cmWidth, cmHeight, dd))
- regionsRespectingWidth(widths, heights, cmWidth, cmHeight, dd);
- else
- regionsRespectingHeight(widths, heights, cmWidth, cmHeight, dd);
- }
-}
-
-static void notAllCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- double newCmWidth, newCmHeight;
- newCmWidth = cmWidth - sumCmWidths(dd);
- newCmHeight = cmHeight - sumCmHeights(dd);
- noCmRegions(widths, heights, newCmWidth, newCmHeight, dd);
- allocDimension(widths, cmWidth, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 1);
- allocDimension(heights, cmHeight, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 1);
- modifyDimension(widths, newCmWidth/cmWidth, gpptr(dd)->numcols,
- gpptr(dd)->cmWidths);
- modifyDimension(heights, newCmHeight/cmHeight, gpptr(dd)->numrows,
- gpptr(dd)->cmHeights);
-}
-
-static void widthCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- allocDimension(widths, cmWidth, gpptr(dd)->numcols, gpptr(dd)->cmWidths, 1);
- allocDimension(heights, sumHeights(dd), gpptr(dd)->numrows,
- gpptr(dd)->cmHeights, 0);
- modifyDimension(heights, (cmHeight - sumCmHeights(dd))/cmHeight,
- gpptr(dd)->numrows, gpptr(dd)->cmHeights);
- allocDimension(heights, cmHeight, gpptr(dd)->numrows,
- gpptr(dd)->cmHeights, 1);
-}
-
-static void heightCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- allocDimension(heights, cmHeight, gpptr(dd)->numrows, gpptr(dd)->cmHeights, 1);
- allocDimension(widths, sumWidths(dd), gpptr(dd)->numcols,
- gpptr(dd)->cmWidths, 0);
- modifyDimension(widths, (cmWidth - sumCmWidths(dd))/cmWidth,
- gpptr(dd)->numcols, gpptr(dd)->cmWidths);
- allocDimension(widths, cmWidth, gpptr(dd)->numcols,
- gpptr(dd)->cmWidths, 1);
-}
-
-static Rboolean allCmWidths(pGEDevDesc dd)
-{
- int j;
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (!gpptr(dd)->cmWidths[j])
- return FALSE;
- return TRUE;
-}
-
-static Rboolean allCmHeights(pGEDevDesc dd)
-{
- int i;
- for (i = 0; i < gpptr(dd)->numrows; i++)
- if (!gpptr(dd)->cmHeights[i])
- return FALSE;
- return TRUE;
-}
-
-static Rboolean noCmWidths(pGEDevDesc dd)
-{
- int j;
- for (j = 0; j < gpptr(dd)->numcols; j++)
- if (gpptr(dd)->cmWidths[j])
- return FALSE;
- return TRUE;
-}
-
-static Rboolean noCmHeights(pGEDevDesc dd)
-{
- int i;
- for (i = 0; i < gpptr(dd)->numrows; i++)
- if (gpptr(dd)->cmHeights[i])
- return FALSE;
- return TRUE;
-}
-
-static void someCmRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- if (allCmWidths(dd))
- widthCmRegions(widths, heights, cmWidth, cmHeight, dd);
- else if (allCmHeights(dd))
- heightCmRegions(widths, heights, cmWidth, cmHeight, dd);
- else
- notAllCmRegions(widths, heights, cmWidth, cmHeight, dd);
-}
-
-static Rboolean allCm(pGEDevDesc dd)
-{
- return allCmWidths(dd) && allCmHeights(dd);
-}
-
-static Rboolean noCm(pGEDevDesc dd)
-{
- return noCmWidths(dd) && noCmHeights(dd);
-}
-
-static void layoutRegions(double widths[], double heights[],
- double cmWidth, double cmHeight, pGEDevDesc dd)
-{
- int i, j;
- for (j = 0; j < gpptr(dd)->numcols; j++)
- widths[j] = gpptr(dd)->widths[j];
- for (i = 0; i < gpptr(dd)->numrows; i++)
- heights[i] = gpptr(dd)->heights[i];
-
- if (allCm(dd))
- allCmRegions(widths, heights, cmWidth, cmHeight, dd);
- else if (noCm(dd))
- noCmRegions(widths, heights, cmWidth, cmHeight, dd);
- else
- someCmRegions(widths, heights, cmWidth, cmHeight, dd);
-}
-
-static void subRegion(double *left, double *right, double *bottom, double *top,
- int mincol, int maxcol,
- int minrow, int maxrow,
- double widths[], double heights[], pGEDevDesc dd)
-{
- double totalWidth = sumRegions(widths, 0, gpptr(dd)->numcols-1);
- double totalHeight = sumRegions(heights, 0, gpptr(dd)->numrows-1);
- *left = (0.5 - totalWidth/2) + sumRegions(widths, 0, mincol-1);
- *right = (0.5 - totalWidth/2) + sumRegions(widths, 0, maxcol);
- *bottom = (0.5 - totalHeight/2) + totalHeight
- - sumRegions(heights, 0, maxrow);
- *top = (0.5 - totalHeight/2) + totalHeight
- - sumRegions(heights, 0, minrow-1);
-}
-
-/* a fudge for backwards compatibility (of sorts) with par(mfg) */
-/* return the top-left-most row/col that the current figure */
-/* occupies in the current layout */
-
-void currentFigureLocation(int *row, int *col, pGEDevDesc dd)
-{
- int maxcol, maxrow;
- if (gpptr(dd)->layout)
- figureExtent(col, &maxcol, row, &maxrow, gpptr(dd)->currentFigure, dd);
- else if (gpptr(dd)->mfind) { /* mfcol */
- *row = (gpptr(dd)->currentFigure - 1)%gpptr(dd)->numrows;
- *col = (gpptr(dd)->currentFigure - 1)/gpptr(dd)->numrows;
- }
- else { /* mfrow */
- *row = (gpptr(dd)->currentFigure - 1)/gpptr(dd)->numcols;
- *col = (gpptr(dd)->currentFigure - 1)%gpptr(dd)->numcols;
- }
-}
-
-/* mapNDC2Dev -- transformation from NDC to Dev */
-/* Use this coordinate system for outer margin coordinates */
-/* This must be called if the device is resized */
-
-static void mapNDC2Dev(pGEDevDesc dd)
-{
- /* For new devices, have to check the device's idea of its size
- * in case there has been a resize.
- */
- double asp = dd->dev->ipr[1] / dd->dev->ipr[0];
-
- gpptr(dd)->ndc2dev.bx = dpptr(dd)->ndc2dev.bx =
- dd->dev->right - dd->dev->left;
- gpptr(dd)->ndc2dev.ax = dpptr(dd)->ndc2dev.ax = dd->dev->left;
- gpptr(dd)->ndc2dev.by = dpptr(dd)->ndc2dev.by =
- dd->dev->top - dd->dev->bottom;
- gpptr(dd)->ndc2dev.ay = dpptr(dd)->ndc2dev.ay = dd->dev->bottom;
- /* Units Conversion */
-
- gpptr(dd)->xNDCPerInch = dpptr(dd)->xNDCPerInch =
- 1.0/fabs(gpptr(dd)->ndc2dev.bx * dd->dev->ipr[0]);
- gpptr(dd)->yNDCPerInch = dpptr(dd)->yNDCPerInch =
- 1.0/fabs(gpptr(dd)->ndc2dev.by * dd->dev->ipr[1]);
- gpptr(dd)->xNDCPerChar = dpptr(dd)->xNDCPerChar =
- fabs(gpptr(dd)->cexbase * gpptr(dd)->scale *
- dd->dev->cra[1] * asp / gpptr(dd)->ndc2dev.bx);
- gpptr(dd)->yNDCPerChar = dpptr(dd)->yNDCPerChar =
- fabs(gpptr(dd)->cexbase * gpptr(dd)->scale *
- dd->dev->cra[1] / gpptr(dd)->ndc2dev.by);
- gpptr(dd)->xNDCPerLine = dpptr(dd)->xNDCPerLine =
- fabs(gpptr(dd)->mex * gpptr(dd)->cexbase * gpptr(dd)->scale *
- dd->dev->cra[1] * asp / gpptr(dd)->ndc2dev.bx);
- gpptr(dd)->yNDCPerLine = dpptr(dd)->yNDCPerLine =
- fabs(gpptr(dd)->mex * gpptr(dd)->cexbase * gpptr(dd)->scale *
- dd->dev->cra[1] / gpptr(dd)->ndc2dev.by);
-}
-
-static void updateOuterMargins(pGEDevDesc dd)
-{
- switch (gpptr(dd)->oUnits) {
- case LINES:
- gpptr(dd)->omi[0] = dpptr(dd)->omi[0] =
- GConvertYUnits(gpptr(dd)->oma[0], LINES, INCHES, dd);
- gpptr(dd)->omi[1] = dpptr(dd)->omi[1] =
- GConvertXUnits(gpptr(dd)->oma[1], LINES, INCHES, dd);
- gpptr(dd)->omi[2] = dpptr(dd)->omi[2] =
- GConvertYUnits(gpptr(dd)->oma[2], LINES, INCHES, dd);
- gpptr(dd)->omi[3] = dpptr(dd)->omi[3] =
- GConvertXUnits(gpptr(dd)->oma[3], LINES, INCHES, dd);
- gpptr(dd)->omd[0] = dpptr(dd)->omd[0] =
- GConvertXUnits(gpptr(dd)->oma[1], LINES, NDC, dd);
- gpptr(dd)->omd[1] = dpptr(dd)->omd[1] =
- 1 - GConvertXUnits(gpptr(dd)->oma[3], LINES, NDC, dd);
- gpptr(dd)->omd[2] = dpptr(dd)->omd[2] =
- GConvertYUnits(gpptr(dd)->oma[0], LINES, NDC, dd);
- gpptr(dd)->omd[3] = dpptr(dd)->omd[3] =
- 1 - GConvertYUnits(gpptr(dd)->oma[2], LINES, NDC, dd);
- break;
- case INCHES:
- gpptr(dd)->oma[0] = dpptr(dd)->oma[0] =
- GConvertYUnits(gpptr(dd)->omi[0], INCHES, LINES, dd);
- gpptr(dd)->oma[1] = dpptr(dd)->oma[1] =
- GConvertXUnits(gpptr(dd)->omi[1], INCHES, LINES, dd);
- gpptr(dd)->oma[2] = dpptr(dd)->oma[2] =
- GConvertYUnits(gpptr(dd)->omi[2], INCHES, LINES, dd);
- gpptr(dd)->oma[3] = dpptr(dd)->oma[3] =
- GConvertXUnits(gpptr(dd)->omi[3], INCHES, LINES, dd);
- gpptr(dd)->omd[0] = dpptr(dd)->omd[0] =
- GConvertXUnits(gpptr(dd)->omi[1], INCHES, NDC, dd);
- gpptr(dd)->omd[1] = dpptr(dd)->omd[1] =
- 1 - GConvertXUnits(gpptr(dd)->omi[3], INCHES, NDC, dd);
- gpptr(dd)->omd[2] = dpptr(dd)->omd[2] =
- GConvertYUnits(gpptr(dd)->omi[0], INCHES, NDC, dd);
- gpptr(dd)->omd[3] = dpptr(dd)->omd[3] =
- 1 - GConvertYUnits(gpptr(dd)->omi[2], INCHES, NDC, dd);
- break;
- case NDC:
- gpptr(dd)->oma[0] = dpptr(dd)->oma[0] =
- GConvertYUnits(gpptr(dd)->omd[2], NDC, LINES, dd);
- gpptr(dd)->oma[1] = dpptr(dd)->oma[1] =
- GConvertXUnits(gpptr(dd)->omd[0], NDC, LINES, dd);
- gpptr(dd)->oma[2] = dpptr(dd)->oma[2] =
- GConvertYUnits(1 - gpptr(dd)->omd[3], NDC, LINES, dd);
- gpptr(dd)->oma[3] = dpptr(dd)->oma[3] =
- GConvertXUnits(1 - gpptr(dd)->omd[1], NDC, LINES, dd);
- gpptr(dd)->omi[0] = dpptr(dd)->omi[0] =
- GConvertYUnits(gpptr(dd)->omd[2], NDC, INCHES, dd);
- gpptr(dd)->omi[1] = dpptr(dd)->omi[1] =
- GConvertXUnits(gpptr(dd)->omd[0], NDC, INCHES, dd);
- gpptr(dd)->omi[2] = dpptr(dd)->omi[2] =
- GConvertYUnits(1 - gpptr(dd)->omd[3], NDC, INCHES, dd);
- gpptr(dd)->omi[3] = dpptr(dd)->omi[3] =
- GConvertXUnits(1 - gpptr(dd)->omd[1], NDC, INCHES, dd);
- break;
- default: break; /*nothing (-Wall) */
- }
-}
-
-/* mapInner2Dev -- transformation from NIC to Dev */
-/* Use this coordinate system for setting up multiple figures */
-/* This is also used when specifying the figure region directly */
-/* Note that this is incompatible with S which uses then entire */
-/* device surface for such a plot */
-/* This must be called per DevNewPlot, if the NDCtoDev transformation */
-/* changes, and if oma changes */
-
-static void mapInner2Dev(pGEDevDesc dd)
-{
- double x0, x1, y0, y1;
- x0 = xLinetoDev(gpptr(dd)->oma[1], dd);
- y0 = yLinetoDev(gpptr(dd)->oma[0], dd);
- x1 = GConvertXUnits(gpptr(dd)->oma[3], LINES, NDC, dd);
- x1 = xNDCtoDev(1.0 - x1, dd);
- y1 = GConvertYUnits(gpptr(dd)->oma[2], LINES, NDC, dd);
- y1 = yNDCtoDev(1.0 - y1, dd);
- gpptr(dd)->inner2dev.bx = dpptr(dd)->inner2dev.bx = x1 - x0;
- gpptr(dd)->inner2dev.ax = dpptr(dd)->inner2dev.ax = x0;
- gpptr(dd)->inner2dev.by = dpptr(dd)->inner2dev.by = y1 - y0;
- gpptr(dd)->inner2dev.ay = dpptr(dd)->inner2dev.ay = y0;
-}
-
-/* mapFigureRegion -- calculate figure region in NIC */
-
-static void mapFigureRegion(pGEDevDesc dd)
-{
- int mincol, maxcol, minrow, maxrow;
- double x0, x1, y0, y1;
- double widths[MAX_LAYOUT_COLS], heights[MAX_LAYOUT_ROWS];
- if (gpptr(dd)->layout) {
- layoutRegions(widths, heights,
- GConvertXUnits(1.0, NIC, INCHES, dd)*2.54,
- GConvertYUnits(1.0, NIC, INCHES, dd)*2.54, dd);
- figureExtent(&mincol, &maxcol, &minrow, &maxrow,
- gpptr(dd)->currentFigure, dd);
- subRegion(&x0, &x1, &y0, &y1,
- mincol, maxcol, minrow, maxrow,
- widths, heights, dd);
- }
- else {
- int row, col;
- if (gpptr(dd)->mfind) {
- col = (gpptr(dd)->currentFigure-1) / gpptr(dd)->numrows + 1;
- row = gpptr(dd)->currentFigure - (col-1)*gpptr(dd)->numrows;
- }
- else {
- row = (gpptr(dd)->currentFigure-1) / gpptr(dd)->numcols + 1;
- col = gpptr(dd)->currentFigure - (row-1)*gpptr(dd)->numcols;
- }
- x0 = (double) (col-1) / gpptr(dd)->numcols;
- x1 = (double) col / gpptr(dd)->numcols;
- y0 = (double) (gpptr(dd)->numrows - row) / gpptr(dd)->numrows;
- y1 = (double) (gpptr(dd)->numrows - row + 1) / gpptr(dd)->numrows;
- }
- gpptr(dd)->fig[0] = dpptr(dd)->fig[0] = x0;
- gpptr(dd)->fig[1] = dpptr(dd)->fig[1] = x1;
- gpptr(dd)->fig[2] = dpptr(dd)->fig[2] = y0;
- gpptr(dd)->fig[3] = dpptr(dd)->fig[3] = y1;
- gpptr(dd)->fUnits = dpptr(dd)->fUnits = NIC;
-}
-
-static void updateFigureRegion(pGEDevDesc dd)
-{
- double nicWidth, nicHeight;
- switch (gpptr(dd)->fUnits) {
- case NIC:
- gpptr(dd)->fin[0] = dpptr(dd)->fin[0] =
- GConvertXUnits(gpptr(dd)->fig[1] - gpptr(dd)->fig[0], NIC, INCHES, dd);
- gpptr(dd)->fin[1] = dpptr(dd)->fin[1] =
- GConvertYUnits(gpptr(dd)->fig[3] - gpptr(dd)->fig[2], NIC, INCHES, dd);
- break;
- case INCHES:
- nicWidth = GConvertXUnits(gpptr(dd)->fin[0], INCHES, NIC, dd);
- nicHeight = GConvertYUnits(gpptr(dd)->fin[1], INCHES, NIC, dd);
- gpptr(dd)->fig[0] = dpptr(dd)->fig[0] = 0.5 - nicWidth/2;
- gpptr(dd)->fig[1] = dpptr(dd)->fig[1] = gpptr(dd)->fig[0] + nicWidth;
- gpptr(dd)->fig[2] = dpptr(dd)->fig[2] = 0.5 - nicHeight/2;
- gpptr(dd)->fig[3] = dpptr(dd)->fig[3] = gpptr(dd)->fig[2] + nicHeight;
- break;
- default: /*nothing*/ break;
- }
-}
-
-/* mapFig2Dev -- Transformation from NFC to Dev */
-/* This must be called per plot.new and if the NICtoDev transformation */
-/* changes */
-
-static void mapFig2Dev(pGEDevDesc dd)
-{
- double x0, x1, y0, y1;
- y0 = yNICtoDev(gpptr(dd)->fig[2], dd);
- y1 = yNICtoDev(gpptr(dd)->fig[3], dd);
- x0 = xNICtoDev(gpptr(dd)->fig[0], dd);
- x1 = xNICtoDev(gpptr(dd)->fig[1], dd);
- gpptr(dd)->fig2dev.bx = dpptr(dd)->fig2dev.bx = x1 - x0;
- gpptr(dd)->fig2dev.ax = dpptr(dd)->fig2dev.ax = x0;
- gpptr(dd)->fig2dev.by = dpptr(dd)->fig2dev.by = y1 - y0;
- gpptr(dd)->fig2dev.ay = dpptr(dd)->fig2dev.ay = y0;
-}
-
-static void updateFigureMargins(pGEDevDesc dd)
-{
- switch (gpptr(dd)->mUnits) {
- case LINES:
- gpptr(dd)->mai[0] = dpptr(dd)->mai[0] =
- GConvertYUnits(gpptr(dd)->mar[0], LINES, INCHES, dd);
- gpptr(dd)->mai[1] = dpptr(dd)->mai[1] =
- GConvertXUnits(gpptr(dd)->mar[1], LINES, INCHES, dd);
- gpptr(dd)->mai[2] = dpptr(dd)->mai[2] =
- GConvertYUnits(gpptr(dd)->mar[2], LINES, INCHES, dd);
- gpptr(dd)->mai[3] = dpptr(dd)->mai[3] =
- GConvertXUnits(gpptr(dd)->mar[3], LINES, INCHES, dd);
- break;
- case INCHES:
- gpptr(dd)->mar[0] = dpptr(dd)->mar[0] =
- GConvertYUnits(gpptr(dd)->mai[0], INCHES, LINES, dd);
- gpptr(dd)->mar[1] = dpptr(dd)->mar[1] =
- GConvertXUnits(gpptr(dd)->mai[1], INCHES, LINES, dd);
- gpptr(dd)->mar[2] = dpptr(dd)->mar[2] =
- GConvertYUnits(gpptr(dd)->mai[2], INCHES, LINES, dd);
- gpptr(dd)->mar[3] = dpptr(dd)->mar[3] =
- GConvertXUnits(gpptr(dd)->mai[3], INCHES, LINES, dd);
- break;
- default: /*nothing*/ break;
- }
-}
-
-/* mapPlotRegion -- plot region in NFC */
-
-static void mapPlotRegion(pGEDevDesc dd)
-{
- double x0, x1, y0, y1;
- x0 = GConvertXUnits(gpptr(dd)->mar[1], LINES, NFC, dd);
- y0 = GConvertYUnits(gpptr(dd)->mar[0], LINES, NFC, dd);
- x1 = 1.0 - GConvertXUnits(gpptr(dd)->mar[3], LINES, NFC, dd);
- y1 = 1.0 - GConvertYUnits(gpptr(dd)->mar[2], LINES, NFC, dd);
- if(gpptr(dd)->pty == 's') {
- /* maximal plot size in inches */
- double center, width, height;
- double inchWidth = GConvertXUnits(x1 - x0, NFC, INCHES, dd);
- double inchHeight = GConvertYUnits(y1 - y0, NFC, INCHES, dd);
- /* shrink the longer side */
- if (inchWidth > inchHeight) {
- width = 0.5*GConvertXUnits(inchHeight, INCHES, NFC, dd);
- center = 0.5*(x1 + x0);
- x0 = center-width;
- x1 = center+width;
- }
- else {
- height = 0.5*GConvertYUnits(inchWidth, INCHES, NFC, dd);
- center = 0.5*(y1 + y0);
- y0 = center-height;
- y1 = center+height;
- }
- }
- gpptr(dd)->plt[0] = dpptr(dd)->plt[0] = x0;
- gpptr(dd)->plt[1] = dpptr(dd)->plt[1] = x1;
- gpptr(dd)->plt[2] = dpptr(dd)->plt[2] = y0;
- gpptr(dd)->plt[3] = dpptr(dd)->plt[3] = y1;
- gpptr(dd)->pUnits = dpptr(dd)->pUnits = NFC;
-}
-
-static void updatePlotRegion(pGEDevDesc dd)
-{
- double nfcWidth, nfcHeight;
- switch (gpptr(dd)->pUnits) {
- case NFC:
- gpptr(dd)->pin[0] = dpptr(dd)->pin[0] =
- GConvertXUnits(gpptr(dd)->plt[1] - gpptr(dd)->plt[0], NFC, INCHES, dd);
- gpptr(dd)->pin[1] = dpptr(dd)->pin[1] =
- GConvertYUnits(gpptr(dd)->plt[3] - gpptr(dd)->plt[2], NFC, INCHES, dd);
- break;
- case INCHES:
- nfcWidth = GConvertXUnits(gpptr(dd)->pin[0], INCHES, NFC, dd);
- nfcHeight = GConvertYUnits(gpptr(dd)->pin[1], INCHES, NFC, dd);
- gpptr(dd)->plt[0] = dpptr(dd)->plt[0] = 0.5 - nfcWidth/2;
- gpptr(dd)->plt[1] = dpptr(dd)->plt[1] = gpptr(dd)->plt[0] + nfcWidth;
- gpptr(dd)->plt[2] = dpptr(dd)->plt[2] = 0.5 - nfcHeight/2;
- gpptr(dd)->plt[3] = dpptr(dd)->plt[3] = gpptr(dd)->plt[2] + nfcHeight;
- break;
- default: /*nothing*/ break;
- }
-}
-
-/* GMapWin2Fig -- transformation from Usr to NFC */
-
-void GMapWin2Fig(pGEDevDesc dd)
-{
- if (gpptr(dd)->xlog) {
- gpptr(dd)->win2fig.bx = dpptr(dd)->win2fig.bx =
- (gpptr(dd)->plt[1] - gpptr(dd)->plt[0])/
- (gpptr(dd)->logusr[1] - gpptr(dd)->logusr[0]);
- gpptr(dd)->win2fig.ax = dpptr(dd)->win2fig.ax =
- gpptr(dd)->plt[0] - gpptr(dd)->win2fig.bx * gpptr(dd)->logusr[0];
- }
- else {
- gpptr(dd)->win2fig.bx = dpptr(dd)->win2fig.bx =
- (gpptr(dd)->plt[1] - gpptr(dd)->plt[0])/
- (gpptr(dd)->usr[1] - gpptr(dd)->usr[0]);
- gpptr(dd)->win2fig.ax = dpptr(dd)->win2fig.ax =
- gpptr(dd)->plt[0] - gpptr(dd)->win2fig.bx * gpptr(dd)->usr[0];
- }
- if (gpptr(dd)->ylog) {
- gpptr(dd)->win2fig.by = dpptr(dd)->win2fig.by =
- (gpptr(dd)->plt[3] - gpptr(dd)->plt[2])/
- (gpptr(dd)->logusr[3] - gpptr(dd)->logusr[2]);
- gpptr(dd)->win2fig.ay = dpptr(dd)->win2fig.ay =
- gpptr(dd)->plt[2] - gpptr(dd)->win2fig.by * gpptr(dd)->logusr[2];
- }
- else {
- gpptr(dd)->win2fig.by = dpptr(dd)->win2fig.by =
- (gpptr(dd)->plt[3] - gpptr(dd)->plt[2])/
- (gpptr(dd)->usr[3] - gpptr(dd)->usr[2]);
- gpptr(dd)->win2fig.ay = dpptr(dd)->win2fig.ay =
- gpptr(dd)->plt[2] - gpptr(dd)->win2fig.by * gpptr(dd)->usr[2];
- }
-}
-
-/* mapping -- Set up mappings between coordinate systems */
-/* This is the user's interface to the mapping routines above */
-
-static
-void mapping(pGEDevDesc dd, int which)
-{
- switch(which) {
- case 0:
- mapNDC2Dev(dd);
- case 1:
- updateOuterMargins(dd);
- mapInner2Dev(dd);
- case 2:
- if (gpptr(dd)->defaultFigure)
- mapFigureRegion(dd);
- updateFigureRegion(dd);
- mapFig2Dev(dd);
- case 3:
- updateFigureMargins(dd);
- if (gpptr(dd)->defaultPlot)
- mapPlotRegion(dd);
- updatePlotRegion(dd);
- }
-}
-
-/* GReset -- Reset coordinate systems mappings and unit yardsticks */
-
-void GReset(pGEDevDesc dd)
-{
- /* Character extents are based on the raster size */
- gpptr(dd)->mkh = gpptr(dd)->scale * dd->dev->cra[0]
- * dd->dev->ipr[0];
-
- /* Recompute Mappings */
- mapping(dd, 0);
-}
-
-/* Is the figure region too big ? */
-
-/* Why is this FLT_EPSILON? */
-static Rboolean validFigureRegion(pGEDevDesc dd)
-{
- return ((gpptr(dd)->fig[0] > 0-FLT_EPSILON) &&
- (gpptr(dd)->fig[1] < 1+FLT_EPSILON) &&
- (gpptr(dd)->fig[2] > 0-FLT_EPSILON) &&
- (gpptr(dd)->fig[3] < 1+FLT_EPSILON));
-}
-
-/* Is the figure region too small ? */
-
-static Rboolean validOuterMargins(pGEDevDesc dd)
-{
- return ((gpptr(dd)->fig[0] < gpptr(dd)->fig[1]) &&
- (gpptr(dd)->fig[2] < gpptr(dd)->fig[3]));
-}
-
-/* Is the plot region too big ? */
-
-static Rboolean validPlotRegion(pGEDevDesc dd)
-{
- return ((gpptr(dd)->plt[0] > 0-FLT_EPSILON) &&
- (gpptr(dd)->plt[1] < 1+FLT_EPSILON) &&
- (gpptr(dd)->plt[2] > 0-FLT_EPSILON) &&
- (gpptr(dd)->plt[3] < 1+FLT_EPSILON));
-}
-
-/* Is the plot region too small ? */
-
-static Rboolean validFigureMargins(pGEDevDesc dd)
-{
- return ((gpptr(dd)->plt[0] < gpptr(dd)->plt[1]) &&
- (gpptr(dd)->plt[2] < gpptr(dd)->plt[3]));
-}
-
-static void invalidError(const char *message, pGEDevDesc dd)
-{
- dpptr(dd)->currentFigure -= 1;
- if (dpptr(dd)->currentFigure < 1)
- dpptr(dd)->currentFigure = dpptr(dd)->lastFigure;
- gpptr(dd)->currentFigure = dpptr(dd)->currentFigure;
- error(message);
-}
-
-Rboolean GRecording(SEXP call, pGEDevDesc dd)
-{
- return GErecording(call, dd);
-}
-
-/* GNewPlot -- Begin a new plot (advance to new frame if needed) */
-pGEDevDesc GNewPlot(Rboolean recording)
-{
- pGEDevDesc dd;
-
- /* Restore Default Parameters */
-
- dd = GEcurrentDevice();
- GRestore(dd);
-
- /* GNewPlot always starts a new plot UNLESS the user has set
- * gpptr(dd)->new to TRUE by par(new=TRUE)
- * If gpptr(dd)->new is FALSE, we leave it that way (further GNewPlot's
- * will move on to subsequent plots)
- * If gpptr(dd)->new is TRUE, any subsequent drawing will dirty the plot
- * and reset gpptr(dd)->new to FALSE
- */
-
- /* we can call par(mfg) before any plotting.
- That sets new = TRUE and also sets currentFigure <= lastFigure
- so treat separately. */
-
- /* The logic for when to start a new page is mimiced in the
- * read-only par("page") in par.c, SO if you make changes
- * to the logic here, you will need to change that as well
- */
- if (!gpptr(dd)->new) {
- R_GE_gcontext gc;
- gcontextFromGP(&gc, dd);
- dpptr(dd)->currentFigure += 1;
- gpptr(dd)->currentFigure = dpptr(dd)->currentFigure;
- if (gpptr(dd)->currentFigure > gpptr(dd)->lastFigure) {
- if (recording) {
- 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
- dd = GEcurrentDevice();
- }
- GEinitDisplayList(dd);
- }
- GENewPage(&gc, dd);
- dpptr(dd)->currentFigure = gpptr(dd)->currentFigure = 1;
- }
-
- GReset(dd);
- GForceClip(dd);
- } else if(!gpptr(dd)->state) { /* device is unused */
- R_GE_gcontext gc;
- gcontextFromGP(&gc, dd);
- if (recording) {
- 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
- dd = GEcurrentDevice();
- }
- GEinitDisplayList(dd);
- }
- GENewPage(&gc, dd);
- dpptr(dd)->currentFigure = gpptr(dd)->currentFigure = 1;
- GReset(dd);
- GForceClip(dd);
- }
-
- /* IF the division of the device into separate regions */
- /* has resulted in any invalid regions ... */
- /* IF this was a user command (i.e., we are recording) */
- /* send an error message to the command line */
- /* IF we are replaying then draw a message in the output */
-
-#define G_ERR_MSG(msg) \
- if (recording) \
- invalidError(msg, dd); \
- else { \
- int xpdsaved = gpptr(dd)->xpd; \
- gpptr(dd)->xpd = 2; \
- GText(0.5,0.5, NFC, msg, -1, 0.5,0.5, 0, dd); \
- gpptr(dd)->xpd = xpdsaved; \
- }
-
- dpptr(dd)->valid = gpptr(dd)->valid = FALSE;
- if (!validOuterMargins(dd)) {
- G_ERR_MSG(_("outer margins too large (figure region too small)"));
- } else if (!validFigureRegion(dd)) {
- G_ERR_MSG(_("figure region too large"));
- } else if (!validFigureMargins(dd)) {
- G_ERR_MSG(_("figure margins too large"));
- } else if (!validPlotRegion(dd)) {
- G_ERR_MSG(_("plot region too large"));
- } else {
- dpptr(dd)->valid = gpptr(dd)->valid = TRUE;
- /*
- * At this point, base output has been successfully
- * produced on the device, so mark the device "dirty"
- * with respect to base graphics.
- * This is used when checking whether the device is
- * "valid" with respect to base graphics
- */
- Rf_setBaseDevice(TRUE, dd);
- GEdirtyDevice(dd);
- }
-
- return dd;
-}
-#undef G_ERR_MSG
-
-#if 0
-/* in src/main/graphics.c */
-// (usr, log, n_inp) |--> (axp, n_out) :
-void GAxisPars(double *min, double *max, int *n, Rboolean log, int axis)
-{
-#define EPS_FAC_2 100
- Rboolean swap = *min > *max;
- double t_, min_o, max_o;
-
- if(swap) { /* Feature: in R, something like xlim = c(100,0) just works */
- t_ = *min; *min = *max; *max = t_;
- }
- /* save only for the extreme case (EPS_FAC_2): */
- min_o = *min; max_o = *max;
-
- if(log) {
- /* Avoid infinities */
- if(*max > 308) *max = 308;
- if(*min < -307) *min = -307;
- *min = Rexp10(*min);
- *max = Rexp10(*max);
- GLPretty(min, max, n);
- }
- else GEPretty(min, max, n);
-
- double tmp2 = EPS_FAC_2 * DBL_EPSILON;/* << prevent overflow in product below */
- if(fabs(*max - *min) < (t_ = fmax2(fabs(*max), fabs(*min)))* tmp2) {
- /* Treat this case somewhat similar to the (min ~= max) case above */
- /* Too much accuracy here just shows machine differences */
- warning(_("relative range of values (%4.0f * EPS) is small (axis %d)")
- /*"to compute accurately"*/,
- fabs(*max - *min) / (t_*DBL_EPSILON), axis);
-
- /* No pretty()ing anymore */
- *min = min_o;
- *max = max_o;
- double eps = .005 * fabs(*max - *min);/* .005: not to go to DBL_MIN/MAX */
- *min += eps;
- *max -= eps;
- if(log) {
- *min = Rexp10(*min);
- *max = Rexp10(*max);
- }
- *n = 1;
- }
- if(swap) {
- t_ = *min; *min = *max; *max = t_;
- }
-}
-#endif
-
-void GScale(double min, double max, int axis, pGEDevDesc dd)
-{
-/* GScale: used to default axis information
- * i.e., if user has NOT specified par(usr=...)
- * NB: can have min > max !
- */
-#define EPS_FAC_1 16
-
- Rboolean is_xaxis = (axis == 1 || axis == 3);
- int log, n, style;
- double temp, min_o = 0., max_o = 0., tmp2 = 0.;/*-Wall*/
-
- if(is_xaxis) {
- n = gpptr(dd)->lab[0];
- style = gpptr(dd)->xaxs;
- log = gpptr(dd)->xlog;
- }
- else {
- n = gpptr(dd)->lab[1];
- style = gpptr(dd)->yaxs;
- log = gpptr(dd)->ylog;
- }
-
- if (log) {
- /* keep original min, max - to use in extremis */
- min_o = min; max_o = max;
- min = log10(min);
- max = log10(max);
- }
- if(!R_FINITE(min) || !R_FINITE(max)) {
- warning(_("nonfinite axis limits [GScale(%g,%g,%d, .); log=%d]"),
- min, max, axis, log);
- if(!R_FINITE(min)) min = - .45 * DBL_MAX;
- if(!R_FINITE(max)) max = + .45 * DBL_MAX;
- /* max - min is now finite */
- }
- /* Version <= 1.2.0 had
- if (min == max) -- exact equality for real numbers */
- temp = fmax2(fabs(max), fabs(min));
- if(temp == 0) {/* min = max = 0 */
- min = -1;
- max = 1;
- }
- else if(fabs(max - min) < temp * EPS_FAC_1 * DBL_EPSILON) {
- temp *= (min == max) ? .4 : 1e-2;
- min -= temp;
- max += temp;
- }
-
- switch(style) {
- case 'r':
- temp = 0.04 * (max-min);
- min -= temp;
- max += temp;
- break;
- case 'i':
- break;
- case 's':/* FIXME --- implement 's' and 'e' axis styles ! */
- case 'e':
- default:
- error(_("axis style \"%c\" unimplemented"), style);
- }
-
- if (log) { /* 10^max may have gotten +Inf ; or 10^min has become 0 */
- if((temp = Rexp10(min)) == 0.) {/* or < 1.01*DBL_MIN */
- temp = fmin2(min_o, 1.01* DBL_MIN); /* allow smaller non 0 */
- min = log10(temp);
- }
- if(max >= 308.25) { /* overflows */
- tmp2 = fmax2(max_o, .99 * DBL_MAX);
- max = log10(tmp2);
- } else tmp2 = Rexp10(max);
- }
- if(is_xaxis) {
- if (log) {
- gpptr(dd)->usr[0] = dpptr(dd)->usr[0] = temp;
- gpptr(dd)->usr[1] = dpptr(dd)->usr[1] = tmp2;
- gpptr(dd)->logusr[0] = dpptr(dd)->logusr[0] = min;
- gpptr(dd)->logusr[1] = dpptr(dd)->logusr[1] = max;
- } else {
- gpptr(dd)->usr[0] = dpptr(dd)->usr[0] = min;
- gpptr(dd)->usr[1] = dpptr(dd)->usr[1] = max;
- }
- } else {
- if (log) {
- gpptr(dd)->usr[2] = dpptr(dd)->usr[2] = temp;
- gpptr(dd)->usr[3] = dpptr(dd)->usr[3] = tmp2;
- gpptr(dd)->logusr[2] = dpptr(dd)->logusr[2] = min;
- gpptr(dd)->logusr[3] = dpptr(dd)->logusr[3] = max;
- } else {
- gpptr(dd)->usr[2] = dpptr(dd)->usr[2] = min;
- gpptr(dd)->usr[3] = dpptr(dd)->usr[3] = max;
- }
- }
-
- /* This is not directly needed when [xy]axt = "n",
- * but may later be different in another call to axis(), e.g.:
- > plot(1, xaxt = "n"); axis(1)
- * In that case, do_axis() should do the following:
- */
-
- // Computation of [xy]axp[0:2] == (min,max,n) :
- GAxisPars(&min, &max, &n, log, axis);
-
-#define G_Store_AXP(is_X) \
- if(is_X) { \
- gpptr(dd)->xaxp[0] = dpptr(dd)->xaxp[0] = min; \
- gpptr(dd)->xaxp[1] = dpptr(dd)->xaxp[1] = max; \
- gpptr(dd)->xaxp[2] = dpptr(dd)->xaxp[2] = n; \
- } \
- else { \
- gpptr(dd)->yaxp[0] = dpptr(dd)->yaxp[0] = min; \
- gpptr(dd)->yaxp[1] = dpptr(dd)->yaxp[1] = max; \
- gpptr(dd)->yaxp[2] = dpptr(dd)->yaxp[2] = n; \
- }
-
- G_Store_AXP(is_xaxis);
-}
-#undef EPS_FAC_1
-#undef EPS_FAC_2
-
-void GSetupAxis(int axis, pGEDevDesc dd)
-{
-/* GSetupAxis -- Set up the default axis information
- * called when user specifies par(usr =...) */
-/* What should happen if ------------
- * xlog or ylog = TRUE ? */
- double min, max;
- int n;
- Rboolean is_xaxis = (axis == 1 || axis == 3);
-
- if(is_xaxis) {
- n = gpptr(dd)->lab[0];
- min = gpptr(dd)->usr[0];
- max = gpptr(dd)->usr[1];
- }
- else {
- n = gpptr(dd)->lab[1];
- min = gpptr(dd)->usr[2];
- max = gpptr(dd)->usr[3];
- }
-
- GPretty(&min, &max, &n);
-
- G_Store_AXP(is_xaxis);
-}
-#undef G_Store_AXP
-
-/*-------------------------------------------------------------------
- *
- * GPAR FUNCTIONS
- *
- */
-
-
-/* Set default graphics parameter values in a GPar.
- * This initialises the plot state, plus the graphical
- * parameters that are not the responsibility of the device initialisation.
-
- * Called from baseCallback.
- */
-
-void GInit(GPar *dp)
-{
- dp->state = 0;
- dp->valid = FALSE;
-
- dp->ann = TRUE;
- dp->err = 0;
- dp->bty = 'o';
-
- dp->mkh = .001;/* dummy value > 0 --- set in GReset : unused in R */
- dp->cex = 1.0;
- dp->lheight = 1.0;
- dp->cexbase = 1.0;
- dp->cexmain = 1.2;
- dp->cexlab = 1.0;
- dp->cexsub = 1.0;
- dp->cexaxis = 1.0;
-
- dp->col = R_RGB(0, 0, 0);
- dp->colmain = R_RGB(0, 0, 0);
- dp->collab = R_RGB(0, 0, 0);
- dp->colsub = R_RGB(0, 0, 0);
- dp->colaxis = R_RGB(0, 0, 0);
- dp->gamma = 1;
-
- dp->scale = 1.0;
- strcpy(dp->family, "");
- dp->font = 1;
- dp->fontmain = 2;
- dp->fontlab = 1;
- dp->fontsub = 1;
- dp->fontaxis = 1;
-
- dp->pch = 1;
- dp->lty = LTY_SOLID;
- dp->lend = GE_ROUND_CAP;
- dp->ljoin = GE_ROUND_JOIN;
- dp->lmitre = 10.0;
- dp->smo = 1;
-
- /* String Adjustment and rotation */
- dp->adj = 0.5;
- dp->crt = 0.0;
- dp->srt = 0.0;
-
- /* Positioning of margin text */
- dp->mgp[0] = 3;
- dp->mgp[1] = 1;
- dp->mgp[2] = 0;
-
- /* Axis annotation parameters */
- dp->lab[0] = 5;
- dp->lab[1] = 5;
- dp->lab[2] = 7;
- dp->las = 0;
- dp->tck = NA_REAL;
- dp->tcl = -0.5;
- dp->xaxp[0] = 0.0;
- dp->xaxp[1] = 1.0;
- dp->xaxp[2] = 5.0;
- dp->xaxs = 'r';
- dp->xaxt = 's';
- dp->xlog = FALSE;
- dp->xpd = 0;
- dp->oldxpd = -99;
- dp->yaxp[0] = 0.0;
- dp->yaxp[1] = 1.0;
- dp->yaxp[2] = 5.0;
- dp->yaxs = 'r';
- dp->yaxt = 's';
- dp->ylog = FALSE;
-
- /* Outer Margins */
- dp->mex = 1.0;
- dp->oma[0] = 0.0;
- dp->oma[1] = 0.0;
- dp->oma[2] = 0.0;
- dp->oma[3] = 0.0;
- dp->oUnits = LINES;
- dp->fig[0] = 0.0;
- dp->fig[1] = 1.0;
- dp->fig[2] = 0.0;
- dp->fig[3] = 1.0;
- dp->fUnits = NIC;
- dp->defaultFigure = TRUE; /* the figure region is calculated from */
- /* the layout by default */
- dp->pUnits = NFC;
- dp->defaultPlot = TRUE; /* the plot region is calculated as */
- /* figure-margin by default */
-
- /* Inner Margins */
- dp->mar[0] = 5.1;
- dp->mar[1] = 4.1;
- dp->mar[2] = 4.1;
- dp->mar[3] = 2.1;
- dp->mUnits = LINES;
-
- /* Multi-figure parameters */
- dp->layout = FALSE;
- dp->mfind = 0;
-
- dp->numrows = 1;
- dp->numcols = 1;
- dp->currentFigure = 1;
- dp->lastFigure = 1;
- dp->heights[0] = 1;
- dp->widths[0] = 1;
- dp->cmHeights[0] = 0;
- dp->cmWidths[0] = 0;
- dp->order[0] = 1;
- dp->rspct = 0;
- dp->respect[0] = 0;
-
- /* Misc plotting parameters */
- dp->new = FALSE;
- dp->devmode = -99;
- dp->pty = 'm';
- dp->lwd = 1;
-
- /* Data window */
- dp->usr[0] = 0.0;
- dp->usr[1] = 1.0;
- dp->usr[2] = 0.0;
- dp->usr[3] = 1.0;
-}
-
-/* Copy a GPar structure from source to dest. */
-void copyGPar(GPar *source, GPar *dest)
-{
- memcpy(dest, source, sizeof(GPar));
-}
-
-
-/* Restore the graphics parameters from the device copy. */
-void GRestore(pGEDevDesc dd)
-{
- if (NoDevices()) error(_("no graphics device is active"));
- copyGPar(dpptr(dd), gpptr(dd));
-}
-
-
-/* FIXME: reorganize this as a memcpy */
-
-/* Saving and restoring of "inline" graphical */
-/* parameters. These are the ones which can be */
-/* specified as a arguments to high-level */
-/* graphics functions. */
-
-static double adjsave; /* adj */
-static int annsave; /* ann */
-static char btysave; /* bty */
-static double cexsave; /* cex */
-static double lheightsave;
-static double cexbasesave; /* cexbase */
-static double cexmainsave; /* cex.main */
-static double cexlabsave; /* cex.lab */
-static double cexsubsave; /* cex.sub */
-static double cexaxissave; /* cex.axis */
-static int colsave; /* col */
-static int fgsave; /* fg */
-static int bgsave; /* bg */
-static int colmainsave; /* col.main */
-static int collabsave; /* col.lab */
-static int colsubsave; /* col.sub */
-static int colaxissave; /* col.axis */
-static double crtsave; /* character rotation */
-static char familysave[201];
-static int fontsave; /* font */
-static int fontmainsave; /* font.main */
-static int fontlabsave; /* font.lab */
-static int fontsubsave; /* font.sub */
-static int fontaxissave; /* font.axis */
-static int errsave; /* error mode */
-static int labsave[3]; /* axis labelling parameters */
-static int lassave; /* label style */
-static int ltysave; /* line type */
-static double lwdsave; /* line width */
-static R_GE_lineend lendsave;
-static R_GE_linejoin ljoinsave;
-static double lmitresave;
-static double mgpsave[3]; /* margin position for annotation */
-static double mkhsave; /* mark height */
-static int pchsave; /* plotting character */
-static double srtsave; /* string rotation */
-static double tcksave; /* tick mark length */
-static double tclsave; /* tick mark length in LINES */
-static double xaxpsave[3]; /* x axis parameters */
-static char xaxssave; /* x axis calculation style */
-static char xaxtsave; /* x axis type */
-static int xpdsave; /* clipping control */
-static double yaxpsave[3]; /* y axis parameters */
-static char yaxssave; /* y axis calculation style */
-static char yaxtsave; /* y axis type */
-
-
-/* Make a temporary copy of the inline parameter values. */
-void GSavePars(pGEDevDesc dd)
-{
- adjsave = gpptr(dd)->adj;
- annsave = gpptr(dd)->ann;
- btysave = gpptr(dd)->bty;
- cexsave = gpptr(dd)->cex;
- lheightsave = gpptr(dd)->lheight;
- cexbasesave = gpptr(dd)->cexbase;
- cexlabsave = gpptr(dd)->cexlab;
- cexmainsave = gpptr(dd)->cexmain;
- cexsubsave = gpptr(dd)->cexsub;
- cexaxissave = gpptr(dd)->cexaxis;
- colsave = gpptr(dd)->col;
- fgsave = gpptr(dd)->fg;
- bgsave = gpptr(dd)->bg;
- collabsave = gpptr(dd)->collab;
- colmainsave = gpptr(dd)->colmain;
- colsubsave = gpptr(dd)->colsub;
- colaxissave = gpptr(dd)->colaxis;
- crtsave = gpptr(dd)->crt;
- errsave = gpptr(dd)->err;
- strncpy(familysave, gpptr(dd)->family, 201);
- fontsave = gpptr(dd)->font;
- fontmainsave = gpptr(dd)->fontmain;
- fontlabsave = gpptr(dd)->fontlab;
- fontsubsave = gpptr(dd)->fontsub;
- fontaxissave = gpptr(dd)->fontaxis;
- labsave[0] = gpptr(dd)->lab[0];
- labsave[1] = gpptr(dd)->lab[1];
- labsave[2] = gpptr(dd)->lab[2];
- lassave = gpptr(dd)->las;
- ltysave = gpptr(dd)->lty;
- lwdsave = gpptr(dd)->lwd;
- lendsave = gpptr(dd)->lend;
- ljoinsave = gpptr(dd)->ljoin;
- lmitresave = gpptr(dd)->lmitre;
- mgpsave[0] = gpptr(dd)->mgp[0];
- mgpsave[1] = gpptr(dd)->mgp[1];
- mgpsave[2] = gpptr(dd)->mgp[2];
- mkhsave = gpptr(dd)->mkh;
- pchsave = gpptr(dd)->pch;
- srtsave = gpptr(dd)->srt;
- tcksave = gpptr(dd)->tck;
- tclsave = gpptr(dd)->tcl;
- xaxpsave[0] = gpptr(dd)->xaxp[0];
- xaxpsave[1] = gpptr(dd)->xaxp[1];
- xaxpsave[2] = gpptr(dd)->xaxp[2];
- xaxssave = gpptr(dd)->xaxs;
- xaxtsave = gpptr(dd)->xaxt;
- xpdsave = gpptr(dd)->xpd;
- yaxpsave[0] = gpptr(dd)->yaxp[0];
- yaxpsave[1] = gpptr(dd)->yaxp[1];
- yaxpsave[2] = gpptr(dd)->yaxp[2];
- yaxssave = gpptr(dd)->yaxs;
- yaxtsave = gpptr(dd)->yaxt;
-}
-
-
-/* Restore temporarily saved inline parameter values */
-void GRestorePars(pGEDevDesc dd)
-{
- gpptr(dd)->adj = adjsave;
- gpptr(dd)->ann = annsave;
- gpptr(dd)->bty = btysave;
- gpptr(dd)->cex = cexsave;
- gpptr(dd)->lheight = lheightsave;
- gpptr(dd)->cexbase = cexbasesave;
- gpptr(dd)->cexlab = cexlabsave;
- gpptr(dd)->cexmain = cexmainsave;
- gpptr(dd)->cexsub = cexsubsave;
- gpptr(dd)->cexaxis = cexaxissave;
- gpptr(dd)->col = colsave;
- gpptr(dd)->fg = fgsave;
- gpptr(dd)->bg = bgsave;
- gpptr(dd)->collab = collabsave;
- gpptr(dd)->colmain = colmainsave;
- gpptr(dd)->colsub = colsubsave;
- gpptr(dd)->colaxis = colaxissave;
- gpptr(dd)->crt = crtsave;
- gpptr(dd)->err = errsave;
- strncpy(gpptr(dd)->family, familysave, 201);
- gpptr(dd)->font = fontsave;
- gpptr(dd)->fontmain = fontmainsave;
- gpptr(dd)->fontlab = fontlabsave;
- gpptr(dd)->fontsub = fontsubsave;
- gpptr(dd)->fontaxis = fontaxissave;
- gpptr(dd)->lab[0] = labsave[0];
- gpptr(dd)->lab[1] = labsave[1];
- gpptr(dd)->lab[2] = labsave[2];
- gpptr(dd)->las = lassave;
- gpptr(dd)->lty = ltysave;
- gpptr(dd)->lwd = lwdsave;
- gpptr(dd)->lend = lendsave;
- gpptr(dd)->ljoin = ljoinsave;
- gpptr(dd)->lmitre = lmitresave;
- gpptr(dd)->mgp[0] = mgpsave[0];
- gpptr(dd)->mgp[1] = mgpsave[1];
- gpptr(dd)->mgp[2] = mgpsave[2];
- gpptr(dd)->mkh = mkhsave;
- gpptr(dd)->pch = pchsave;
- gpptr(dd)->srt = srtsave;
- gpptr(dd)->tck = tcksave;
- gpptr(dd)->tcl = tclsave;
- gpptr(dd)->xaxp[0] = xaxpsave[0];
- gpptr(dd)->xaxp[1] = xaxpsave[1];
- gpptr(dd)->xaxp[2] = xaxpsave[2];
- gpptr(dd)->xaxs = xaxssave;
- gpptr(dd)->xaxt = xaxtsave;
- gpptr(dd)->xpd = xpdsave;
- gpptr(dd)->yaxp[0] = yaxpsave[0];
- gpptr(dd)->yaxp[1] = yaxpsave[1];
- gpptr(dd)->yaxp[2] = yaxpsave[2];
- gpptr(dd)->yaxs = yaxssave;
- gpptr(dd)->yaxt = yaxtsave;
-}
-
-/*-------------------------------------------------------------------
- *
- * DEVICE STATE FUNCTIONS
- *
- */
-
-
-/* This records whether GNewPlot has been called. */
-void GSetState(int newstate, pGEDevDesc dd)
-{
- dpptr(dd)->state = gpptr(dd)->state = newstate;
-}
-
-
-
-/* Enquire whether GNewPlot has been called. */
-void GCheckState(pGEDevDesc dd)
-{
- if(gpptr(dd)->state == 0)
- error(_("plot.new has not been called yet"));
- if (!gpptr(dd)->valid)
- error(_("invalid graphics state"));
-}
-
-/*-------------------------------------------------------------------
- * GRAPHICAL PRIMITIVES
- *
- */
-
-/* CLIPPING paradigm:
-
- R uses both the clipping capabilities of the device (if present)
- and its own internal clipping algorithms.
- If the device has no clipping capabilities (canClip = FALSE) then R
- does all of the clipping internally.
- If the device has clipping capabilities, R still does some internal
- clipping (to the device extent). This is to avoid "silly" values
- being sent to the device (e.g., X11 and Ghostview will barf if you
- send a ridiculously large number to them). Call this silly-clipping.
-
- The problem with getting R to do some of the clipping is that it is
- not necessarily as good as the device at clipping (e.g., R's text
- clipping is very crude). This is the motivation for leaving as much
- of the clipping as possible to the device.
- R does different amounts of silly-clipping for different primitives.
- See the individual routines for more info.
-*/
-
-
-static void setClipRect(double *x1, double *y1, double *x2, double *y2,
- int coords, pGEDevDesc dd)
-{
- /*
- * xpd = 0 means clip to current plot region
- * xpd = 1 means clip to current figure region
- * xpd = 2 means clip to device region
- */
- *x1 = 0.0;
- *y1 = 0.0;
- *x2 = 1.0;
- *y2 = 1.0;
- switch (gpptr(dd)->xpd) {
- case 0:
- GConvert(x1, y1, NPC, coords, dd);
- GConvert(x2, y2, NPC, coords, dd);
- break;
- case 1:
- GConvert(x1, y1, NFC, coords, dd);
- GConvert(x2, y2, NFC, coords, dd);
- break;
- case 2:
- GConvert(x1, y1, NDC, coords, dd);
- GConvert(x2, y2, NDC, coords, dd);
- break;
- }
-}
-
-/* Update the device clipping region (depends on GP->xpd). */
-void GClip(pGEDevDesc dd)
-{
- if (gpptr(dd)->xpd != gpptr(dd)->oldxpd) {
- double x1, y1, x2, y2;
- setClipRect(&x1, &y1, &x2, &y2, DEVICE, dd);
- GESetClip(x1, y1, x2, y2, dd);
- gpptr(dd)->oldxpd = gpptr(dd)->xpd;
- }
-}
-
-
-/* Forced update of the device clipping region. */
-void GForceClip(pGEDevDesc dd)
-{
- double x1, y1, x2, y2;
- if (gpptr(dd)->state == 0) return;
- setClipRect(&x1, &y1, &x2, &y2, DEVICE, dd);
- GESetClip(x1, y1, x2, y2, dd);
-}
-
-/*
- * Function to generate an R_GE_gcontext from gpptr info
- *
- * In some cases, the settings made here will need to be overridden
- * (eps. the fill setting)
- */
-/* Used here and in do_xspline */
-void gcontextFromGP(pGEcontext gc, pGEDevDesc dd)
-{
- gc->col = gpptr(dd)->col;
- gc->fill = gpptr(dd)->bg; /* This may need manual adjusting */
- gc->gamma = gpptr(dd)->gamma;
- /*
- * Scale by "zoom" factor to allow for fit-to-window resizing in Windows
- */
- gc->lwd = gpptr(dd)->lwd * gpptr(dd)->scale;
- gc->lty = gpptr(dd)->lty;
- gc->lend = gpptr(dd)->lend;
- gc->ljoin = gpptr(dd)->ljoin;
- gc->lmitre = gpptr(dd)->lmitre;
- gc->cex = gpptr(dd)->cex;
- /*
- * Scale by "zoom" factor to allow for fit-to-window resizing in Windows
- */
- gc->ps = (double) gpptr(dd)->ps * gpptr(dd)->scale;
- gc->lineheight = gpptr(dd)->lheight;
- gc->fontface = gpptr(dd)->font;
- strncpy(gc->fontfamily, gpptr(dd)->family, 201);
-}
-
-/* Draw a line. */
-/* If the device canClip, R clips line to device extent and
- device does all other clipping. */
-void GLine(double x1, double y1, double x2, double y2, int coords, pGEDevDesc dd)
-{
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
- if (gpptr(dd)->lty == LTY_BLANK) return;
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- GConvert(&x1, &y1, coords, DEVICE, dd);
- GConvert(&x2, &y2, coords, DEVICE, dd);
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- if(R_FINITE(x1) && R_FINITE(y1) && R_FINITE(x2) && R_FINITE(y2))
- GELine(x1, y1, x2, y2, &gc, dd);
-}
-
-/* We need extra graphics device closure handling
- when inside a call to locator (it should raise
- an error and return). PR#15253
-
- This assume that locator is running on only one device at a time,
- which is currently safe.
-*/
-static void (*old_close)(pDevDesc) = NULL;
-
-static void locator_close(pDevDesc dd)
-{
- if(old_close) old_close(dd);
- dd->close = old_close;
- old_close = NULL;
- error(_("graphics device closed during call to locator or identify"));
-}
-
-
-/* Read the current "pen" position. */
-Rboolean GLocator(double *x, double *y, int coords, pGEDevDesc dd)
-{
- Rboolean ret;
- /* store original close handler (it will still be called on
- closure) and assign new handler that throws an error
- */
- old_close = (dd->dev)->close;
- dd->dev->close = &locator_close;
-
- if(dd->dev->locator && dd->dev->locator(x, y, dd->dev)) {
- GConvert(x, y, DEVICE, coords, dd);
- ret = TRUE;
- } else ret = FALSE;
- /* restore original close handler */
- dd->dev->close = old_close;
- old_close = NULL;
- return ret;
-
-}
-
-/* Access character font metric information. */
-void GMetricInfo(int c, double *ascent, double *descent, double *width,
- GUnit units, pGEDevDesc dd)
-{
- R_GE_gcontext gc;
- gcontextFromGP(&gc, dd);
- dd->dev->metricInfo(c & 0xFF, &gc, ascent, descent, width, dd->dev);
- if (units != DEVICE) {
- *ascent = GConvertYUnits(*ascent, DEVICE, units, dd);
- *descent = GConvertYUnits(*descent, DEVICE, units, dd);
- *width = GConvertXUnits(*width, DEVICE, units, dd);
- }
-}
-
-
-/* Check that everything is initialized :
- Interpretation :
- mode = 0, graphics off
- mode = 1, graphics on
- mode = 2, graphical input on (ignored by most drivers)
-*/
-void GMode(int mode, pGEDevDesc dd)
-{
- if (NoDevices())
- error(_("No graphics device is active"));
- if(mode != gpptr(dd)->devmode) GEMode(mode, dd); /* dd->dev->mode(mode, dd->dev); */
- gpptr(dd)->new = dpptr(dd)->new = FALSE;
- gpptr(dd)->devmode = dpptr(dd)->devmode = mode;
-}
-
-
-/*
-***********************************
-* START GClipPolygon code
-*
-* Everything up to END GClipPolygon code
-* is just here to support GClipPolygon
-* which only exists to satisfy the
-* Rgraphics.h API (which should be
-* superceded by the API provided by
-* GraphicsDevice.h and GraphicsEngine.h)
-***********************************
-*/
-/*
- * If device can't clip we should use something like Sutherland-Hodgman here
- *
- * NOTE: most of this code (up to GPolygon) is only now used by
- * GClipPolygon -- GPolygon runs the new GEPolygon in engine.c
- */
-typedef enum {
- Left = 0,
- Right = 1,
- Bottom = 2,
- Top = 3
-} Edge;
-
-/* Clipper State Variables */
-typedef struct {
- int first; /* true if we have seen the first point */
- double fx; /* x coord of the first point */
- double fy; /* y coord of the first point */
- double sx; /* x coord of the most recent point */
- double sy; /* y coord of the most recent point */
-}
-GClipState;
-
-/* The Clipping Rectangle */
-typedef struct {
- double xmin;
- double xmax;
- double ymin;
- double ymax;
-}
-GClipRect;
-
-static
-int inside (Edge b, double px, double py, GClipRect *clip)
-{
- switch (b) {
- case Left: if (px < clip->xmin) return 0; break;
- case Right: if (px > clip->xmax) return 0; break;
- case Bottom: if (py < clip->ymin) return 0; break;
- case Top: if (py > clip->ymax) return 0; break;
- }
- return 1;
-}
-
-static
-int cross (Edge b, double x1, double y1, double x2, double y2,
- GClipRect *clip)
-{
- if (inside (b, x1, y1, clip) == inside (b, x2, y2, clip))
- return 0;
- else return 1;
-}
-
-static
-void intersect (Edge b, double x1, double y1, double x2, double y2,
- double *ix, double *iy, GClipRect *clip)
-{
- double m = 0;
-
- if (x1 != x2) m = (y1 - y2) / (x1 - x2);
- switch (b) {
- case Left:
- *ix = clip->xmin;
- *iy = y2 + (clip->xmin - x2) * m;
- break;
- case Right:
- *ix = clip->xmax;
- *iy = y2 + (clip->xmax - x2) * m;
- break;
- case Bottom:
- *iy = clip->ymin;
- if (x1 != x2) *ix = x2 + (clip->ymin - y2) / m;
- else *ix = x2;
- break;
- case Top:
- *iy = clip->ymax;
- if (x1 != x2) *ix = x2 + (clip->ymax - y2) / m;
- else *ix = x2;
- break;
- }
-}
-
-static
-void clipPoint (Edge b, double x, double y,
- double *xout, double *yout, int *cnt, int store,
- GClipRect *clip, GClipState *cs)
-{
- double ix = 0.0, iy = 0.0 /* -Wall */;
-
- if (!cs[b].first) {
- /* No previous point exists for this edge. */
- /* Save this point. */
- cs[b].first = 1;
- cs[b].fx = x;
- cs[b].fy = y;
- }
- else
- /* A previous point exists. */
- /* If 'p' and previous point cross edge, find intersection. */
- /* Clip against next boundary, if any. */
- /* If no more edges, add intersection to output list. */
- if (cross (b, x, y, cs[b].sx, cs[b].sy, clip)) {
- intersect (b, x, y, cs[b].sx, cs[b].sy, &ix, &iy, clip);
- if (b < Top)
- clipPoint (b + 1, ix, iy, xout, yout, cnt, store,
- clip, cs);
- else {
- if (store) {
- xout[*cnt] = ix;
- yout[*cnt] = iy;
- }
- (*cnt)++;
- }
- }
-
- /* Save as most recent point for this edge */
- cs[b].sx = x;
- cs[b].sy = y;
-
- /* For all, if point is 'inside' */
- /* proceed to next clip edge, if any */
- if (inside (b, x, y, clip)) {
- if (b < Top)
- clipPoint (b + 1, x, y, xout, yout, cnt, store, clip, cs);
- else {
- if (store) {
- xout[*cnt] = x;
- yout[*cnt] = y;
- }
- (*cnt)++;
- }
- }
-}
-
-static
-void closeClip (double *xout, double *yout, int *cnt, int store,
- GClipRect *clip, GClipState *cs)
-{
- double ix = 0.0, iy = 0.0 /* -Wall */;
- Edge b;
-
- for (b = Left; b <= Top; b++) {
- if (cross (b, cs[b].sx, cs[b].sy, cs[b].fx, cs[b].fy, clip)) {
- intersect (b, cs[b].sx, cs[b].sy,
- cs[b].fx, cs[b].fy, &ix, &iy, clip);
- if (b < Top)
- clipPoint (b + 1, ix, iy, xout, yout, cnt, store, clip, cs);
- else {
- if (store) {
- xout[*cnt] = ix;
- yout[*cnt] = iy;
- }
- (*cnt)++;
- }
- }
- }
-}
-
-int GClipPolygon(double *x, double *y, int n, int coords, int store,
- double *xout, double *yout, pGEDevDesc dd)
-{
- int i, cnt = 0;
- GClipState cs[4];
- GClipRect clip;
- for (i = 0; i < 4; i++)
- cs[i].first = 0;
- /* Set up the cliprect here for R. */
- setClipRect(&clip.xmin, &clip.ymin, &clip.xmax, &clip.ymax, coords, dd);
- /* If necessary, swap the clip region extremes */
- if (clip.xmax < clip.xmin) {
- double swap = clip.xmax;
- clip.xmax = clip.xmin;
- clip.xmin = swap;
- }
- if (clip.ymax < clip.ymin) {
- double swap = clip.ymax;
- clip.ymax = clip.ymin;
- clip.ymin = swap;
- }
- for (i = 0; i < n; i++)
- clipPoint (Left, x[i], y[i], xout, yout, &cnt, store, &clip, cs);
- closeClip (xout, yout, &cnt, store, &clip, cs);
- return (cnt);
-}
-/*
-***********************************
-* END GClipPolygon code
-***********************************
-*/
-
-/*
- * This is just here to satisfy the Rgraphics.h API.
- * This allows new graphics API (GraphicsDevice.h, GraphicsEngine.h)
- * to be developed alongside.
- * Could be removed if Rgraphics.h ever gets REPLACED by new API
- * NOTE that base graphics code (in plot.c) still calls this.
- */
-/* GPolygon -- Draw a polygon
- * Filled with color bg and outlined with color fg
- * These may both be NA_INTEGER
- */
-void GPolygon(int n, double *x, double *y, int coords,
- int bg, int fg, pGEDevDesc dd)
-{
- int i;
- double *xx;
- double *yy;
- const void *vmaxsave = vmaxget();
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- if (gpptr(dd)->lty == LTY_BLANK)
- fg = R_TRANWHITE; /* transparent for the border */
-
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- xx = (double*) R_alloc(n, sizeof(double));
- yy = (double*) R_alloc(n, sizeof(double));
- if (!xx || !yy)
- error("unable to allocate memory (in GPolygon)");
- for (i=0; i<n; i++) {
- xx[i] = x[i];
- yy[i] = y[i];
- GConvert(&(xx[i]), &(yy[i]), coords, DEVICE, dd);
- }
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- gc.col = fg;
- gc.fill = bg;
- GEPolygon(n, xx, yy, &gc, dd);
- vmaxset(vmaxsave);
-}
-
-#include <stdio.h>
-
-/* Draw a series of line segments. */
-/* If the device canClip, R clips to the device extent and the device
- does all other clipping */
-void GPolyline(int n, double *x, double *y, int coords, pGEDevDesc dd)
-{
- int i;
- double *xx;
- double *yy;
- const void *vmaxsave = vmaxget();
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- xx = (double*) R_alloc(n, sizeof(double));
- yy = (double*) R_alloc(n, sizeof(double));
- if (!xx || !yy)
- error("unable to allocate memory (in GPolyline)");
- for (i=0; i<n; i++) {
- xx[i] = x[i];
- yy[i] = y[i];
- GConvert(&(xx[i]), &(yy[i]), coords, DEVICE, dd);
- }
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- GEPolyline(n, xx, yy, &gc, dd);
- vmaxset(vmaxsave);
-}
-
-
-/*
- * This is just here to satisfy the Rgraphics.h API.
- * This allows new graphics API (GraphicsDevice.h, GraphicsEngine.h)
- * to be developed alongside.
- * Could be removed if Rgraphics.h ever gets REPLACED by new API
- * NOTE that base graphics code (do_symbol in plot.c) still calls this.
- *
- * NB: this fiddles with radius = 0.
- */
-void GCircle(double x, double y, int coords,
- double radius, int bg, int fg, pGEDevDesc dd)
-{
- double ir;
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- ir = radius/dd->dev->ipr[0];
- ir = (ir > 0) ? ir : 1;
-
- if (gpptr(dd)->lty == LTY_BLANK)
- fg = R_TRANWHITE; /* transparent for the border */
-
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- GConvert(&x, &y, coords, DEVICE, dd);
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- gc.col = fg;
- gc.fill = bg;
- GECircle(x, y, ir, &gc, dd);
-}
-
-/* Draw a rectangle */
-/* Filled with color bg and outlined with color fg */
-/* These may both be NA_INTEGER */
-void GRect(double x0, double y0, double x1, double y1, int coords,
- int bg, int fg, pGEDevDesc dd)
-{
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- if (gpptr(dd)->lty == LTY_BLANK)
- fg = R_TRANWHITE; /* transparent for the border */
-
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- GConvert(&x0, &y0, coords, DEVICE, dd);
- GConvert(&x1, &y1, coords, DEVICE, dd);
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- gc.col = fg;
- gc.fill = bg;
- GERect(x0, y0, x1, y1, &gc, dd);
-}
-
-void GPath(double *x, double *y,
- int npoly, int *nper,
- Rboolean winding,
- int bg, int fg, pGEDevDesc dd)
-{
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- if (gpptr(dd)->lty == LTY_BLANK)
- fg = R_TRANWHITE; /* transparent for the border */
-
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- gc.col = fg;
- gc.fill = bg;
- GEPath(x, y, npoly, nper, winding, &gc, dd);
-}
-
-void GRaster(unsigned int* image, int w, int h,
- double x0, double y0, double x1, double y1,
- double angle, Rboolean interpolate,
- pGEDevDesc dd)
-{
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
-
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
-
- GERaster(image, w, h, x0, y0, x1, y1, angle, interpolate,
- &gc, dd);
-}
-
-/* Compute string width. */
-double GStrWidth(const char *str, cetype_t enc, GUnit units, pGEDevDesc dd)
-{
- double w;
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
- w = GEStrWidth(str, (gc.fontface == 5) ? CE_SYMBOL:enc, &gc, dd);
- if (units != DEVICE)
- w = GConvertXUnits(w, DEVICE, units, dd);
- return w;
-}
-
-
-/* Compute string height. */
-
-double GStrHeight(const char *str, cetype_t enc, GUnit units, pGEDevDesc dd)
-{
- double h;
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
- h = GEStrHeight(str, (gc.fontface == 5) ? CE_SYMBOL:enc, &gc, dd);
- if (units != DEVICE)
- h = GConvertYUnits(h, DEVICE, units, dd);
- return h;
-}
-
-/* Draw text in a plot. */
-/* If you want EXACT centering of text (e.g., like in GSymbol) */
-/* then pass NA_REAL for xc and yc */
-void GText(double x, double y, int coords, const char *str, cetype_t enc,
- double xc, double yc, double rot, pGEDevDesc dd)
-{
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- GConvert(&x, &y, coords, DEVICE, dd);
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- GEText(x, y, str, (gc.fontface == 5) ? CE_SYMBOL:enc, xc, yc, rot, &gc, dd);
-}
-
-/*-------------------------------------------------------------------
- *
- * GRAPHICAL UTILITIES
- *
- */
-
-
-/* GArrow -- Draw an arrow. */
-/* NOTE that the length parameter is in inches. */
-void GArrow(double xfrom, double yfrom, double xto, double yto, int coords,
- double length, double angle, int code, pGEDevDesc dd)
-{
-
- double xfromInch = xfrom;
- double yfromInch = yfrom;
- double xtoInch = xto;
- double ytoInch = yto;
- double rot, xc, yc;
- double x[3], y[3];
- double eps = 1.e-3;
-
- GLine(xfrom, yfrom, xto, yto, coords, dd);
-
- GConvert(&xfromInch, &yfromInch, coords, INCHES, dd);
- GConvert(&xtoInch, &ytoInch, coords, INCHES, dd);
- if((code & 3) == 0) return; /* no arrows specified */
- if(length == 0) return; /* zero-length arrow heads */
-
- if(hypot(xfromInch - xtoInch, yfromInch - ytoInch) < eps) {
- /* effectively 0-length arrow */
- warning(_("zero-length arrow is of indeterminate angle and so skipped"));
- return;
- }
- angle *= DEG2RAD;
- if(code & 1) {
- xc = xtoInch - xfromInch;
- yc = ytoInch - yfromInch;
- rot= atan2(yc, xc);
- x[0] = xfromInch + length * cos(rot+angle);
- y[0] = yfromInch + length * sin(rot+angle);
- x[1] = xfromInch;
- y[1] = yfromInch;
- x[2] = xfromInch + length * cos(rot-angle);
- y[2] = yfromInch + length * sin(rot-angle);
- GPolyline(3, x, y, INCHES, dd);
- }
- if(code & 2) {
- xc = xfromInch - xtoInch;
- yc = yfromInch - ytoInch;
- rot= atan2(yc, xc);
- x[0] = xtoInch + length * cos(rot+angle);
- y[0] = ytoInch + length * sin(rot+angle);
- x[1] = xtoInch;
- y[1] = ytoInch;
- x[2] = xtoInch + length * cos(rot-angle);
- y[2] = ytoInch + length * sin(rot-angle);
- GPolyline(3, x, y, INCHES, dd);
- }
-}
-
-
-/* Draw a box about one of several regions: box(which) */
-void GBox(int which, pGEDevDesc dd)
-{
- double x[7], y[7];
- if (which == 1) {/* plot */
- x[0] = gpptr(dd)->plt[0]; y[0] = gpptr(dd)->plt[2];/* <- , __ */
- x[1] = gpptr(dd)->plt[1]; y[1] = gpptr(dd)->plt[2];/* -> , __ */
- x[2] = gpptr(dd)->plt[1]; y[2] = gpptr(dd)->plt[3];/* -> , ^ */
- x[3] = gpptr(dd)->plt[0]; y[3] = gpptr(dd)->plt[3];/* <- , ^ */
- x[4] = x[0]; y[4] = y[0]; /* <- , __ */
- x[5] = x[1]; y[5] = y[1]; /* -> , __ */
- x[6] = x[2]; y[6] = y[2]; /* -> , __ */
- }
- else {/* "figure", "inner", or "outer" */
- x[0] = 0.; y[0] = 0.;
- x[1] = 1.; y[1] = 0.;
- x[2] = 1.; y[2] = 1.;
- x[3] = 0.; y[3] = 1.;
- }
- switch(which) {
- case 1: /* Plot */
- switch(gpptr(dd)->bty) {
- case 'o':
- case 'O':
- GPolygon(4, x, y, NFC,
- R_TRANWHITE, gpptr(dd)->col, dd);
- break;
- case 'l':
- case 'L':
- GPolyline(3, x+3, y+3, NFC, dd);
- break;
- case '7':
- GPolyline(3, x+1, y+1, NFC, dd);
- break;
- case 'c':
- case 'C':
- case '[':
- GPolyline(4, x+2, y+2, NFC, dd);
- break;
- case ']':/* new */
- GPolyline(4, x, y, NFC, dd);
- break;
- case 'u':
- case 'U':
- GPolyline(4, x+3, y+3, NFC, dd);
- break;
- case 'n':
- case 'N': /* nothing */
- break;
- default:
- warning(_("invalid par(\"bty\") = '%c'; no box() drawn"),
- gpptr(dd)->bty);
- }
- break;
- case 2: /* Figure */
- GPolygon(4, x, y, NFC,
- R_TRANWHITE, gpptr(dd)->col, dd);
- break;
- case 3: /* Inner Region */
- GPolygon(4, x, y, NIC,
- R_TRANWHITE, gpptr(dd)->col, dd);
- break;
- case 4: /* "outer": Device border */
- GPolygon(4, x, y, NDC,
- R_TRANWHITE, gpptr(dd)->col, dd);
- break;
- default:
- error(_("invalid argument to GBox"));
- }
-}
-
-#if 1
-/* in src/main/graphics.c */
-#define LPR_SMALL 2
-#define LPR_MEDIUM 3
-
-void GLPretty(double *ul, double *uh, int *n)
-{
-/* Generate pretty tick values -- LOGARITHMIC scale
- * __ ul < uh __
- * This only does a very simple setup.
- * The real work happens when the axis is drawn. */
- int p1, p2;
- double dl = *ul, dh = *uh;
- p1 = (int) ceil(log10(dl));
- p2 = (int) floor(log10(dh));
- if(p2 <= p1 && dh/dl > 10.0) {
- p1 = (int) ceil(log10(dl) - 0.5);
- p2 = (int) floor(log10(dh) + 0.5);
- }
-
- if (p2 <= p1) { /* floor(log10(uh)) <= ceil(log10(ul))
- * <==> log10(uh) - log10(ul) < 2
- * <==> uh / ul < 100 */
- /* Very small range : Use tickmarks from a LINEAR scale
- * Splus uses n = 9 here, but that is dumb */
- GPretty(ul, uh, n);
- *n = -*n;
- }
- else { /* extra tickmarks --> CreateAtVector() in ./plot.c */
- /* round to nice "1e<N>" */
- *ul = Rexp10((double)p1);
- *uh = Rexp10((double)p2);
- if (p2 - p1 <= LPR_SMALL)
- *n = 3; /* Small range : Use 1,2,5,10 times 10^k tickmarks */
- else if (p2 - p1 <= LPR_MEDIUM)
- *n = 2; /* Medium range : Use 1,5 times 10^k tickmarks */
- else
- *n = 1; /* Large range : Use 10^k tickmarks
- * But decimate, when there are too many*/
- }
-}
-
-void GPretty(double *lo, double *up, int *ndiv)
-{
- GEPretty(lo, up, ndiv);
-}
-#endif
-
-#define SMALL 0.25
-#define RADIUS 0.375
-#define SQRC 0.88622692545275801364 /* sqrt(pi / 4) */
-#define DMDC 1.25331413731550025119 /* sqrt(pi / 4) * sqrt(2) */
-#define TRC0 1.55512030155621416073 /* sqrt(4 * pi/(3 * sqrt(3))) */
-#define TRC1 1.34677368708859836060 /* TRC0 * sqrt(3) / 2 */
-#define TRC2 0.77756015077810708036 /* TRC0 / 2 */
-#define CMAG 1.0 /* Circle magnifier, now defunct */
-#define GSTR_0 dpptr(dd)->scale * dd->dev->cra[1] * 0.5 * dd->dev->ipr[1] * gpptr(dd)->cex
-/* NOTE: This cex is already multiplied with cexbase */
-
-/* Draw one of the R special symbols. */
-void GSymbol(double x, double y, int coords, int pch, pGEDevDesc dd)
-{
- double size = GConvertYUnits(GSTR_0, INCHES, DEVICE, dd);
- R_GE_gcontext gc; gcontextFromGP(&gc, dd);
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- GConvert(&x, &y, coords, DEVICE, dd);
- /*
- * Ensure that the base clipping region is set on the device
- */
- GClip(dd);
- /*
- * Force line type LTY_SOLID
- * i.e., current par(lty) is ignored when drawing symbols
- */
- gc.lty = LTY_SOLID;
- /*
- * special case for pch = "."
- */
- if(pch == 46) size = gpptr(dd)->cex;
- GESymbol(x, y, pch, size, &gc, dd);
-}
-
-
-/* Draw text in plot margins. */
-void GMtext(const char *str, cetype_t enc, int side, double line, int outer,
- double at, int las, double yadj, pGEDevDesc dd)
-{
-/* "las" gives the style of axis labels:
- 0 = always parallel to the axis [= default],
- 1 = always horizontal,
- 2 = always perpendicular to the axis.
- 3 = always vertical.
-*/
- double angle, xadj;
- int coords;
-
- /* Init to keep -Wall happy: */
- angle = 0.;
- coords = 0;
-
- xadj = gpptr(dd)->adj; /* ALL cases */
- if(outer) {
- switch(side) {
- case 1: coords = OMA1; break;
- case 2: coords = OMA2; break;
- case 3: coords = OMA3; break;
- case 4: coords = OMA4; break;
- }
- }
- else {
- switch(side) {
- case 1: coords = MAR1; break;
- case 2: coords = MAR2; break;
- case 3: coords = MAR3; break;
- case 4: coords = MAR4; break;
- }
- }
- /* Note: I changed gpptr(dd)->yLineBias to 0.3 here. */
- /* Purely visual tuning. RI */
- /* This has been replaced by a new argument padj (=yadj here) to axis()
- and mtext() and that can either be set manually or is determined in
- a somehow fuzzy manner with respect to current side and las settings.
- Uwe L.
- */
- /* Note from PR#14532:
- yLineBias is the proportion of line height that is white
- space. The manipulation of "line" below is pure visual tuning
- such that when we plot horizontal text on side 1 (or vertical
- text on side 4) with padj=0 (i.e. text written *above* the
- specified y-value), it is symmetric w.r.t text written on sides
- 1 and 2 with padj=0.
- */
- switch(side) {
- case 1:
- if(las == 2 || las == 3) {
- angle = 90;
- }
- else {
- line += (1/gpptr(dd)->mex)*(1 - dd->dev->yLineBias);
- angle = 0;
- }
- break;
- case 2:
- if(las == 1 || las == 2) {
- angle = 0;
- }
- else {
- line += (1/gpptr(dd)->mex)*dd->dev->yLineBias;
- angle = 90;
- }
- break;
- case 3:
- if(las == 2 || las == 3) {
- angle = 90;
- }
- else {
- line += (1/gpptr(dd)->mex)*dd->dev->yLineBias;
- angle = 0;
- }
- break;
- case 4:
- if(las == 1 || las == 2) {
- angle = 0;
- }
- else {
- line += (1/gpptr(dd)->mex)*(1 - dd->dev->yLineBias);
- angle = 90;
- }
- break;
- }
- GText(at, line, coords, str, enc, xadj, yadj, angle, dd);
-}/* GMtext */
-
-/* ------------------------------------------------------------
- code below here moved from plotmath.c, which said
-
- * This source code module:
- * Copyright (C) 1997, 1998 Paul Murrell and Ross Ihaka
- * Copyright (C) 1998-2008 The R Core Team
-
- */
-
-double GExpressionWidth(SEXP expr, GUnit units, pGEDevDesc dd)
-{
- R_GE_gcontext gc;
- double width;
- gcontextFromGP(&gc, dd);
- width = GEExpressionWidth(expr, &gc, dd);
- if (units == DEVICE)
- return width;
- else
- return GConvertXUnits(width, DEVICE, units, dd);
-}
-
-double GExpressionHeight(SEXP expr, GUnit units, pGEDevDesc dd)
-{
- R_GE_gcontext gc;
- double height;
- gcontextFromGP(&gc, dd);
- height = GEExpressionHeight(expr, &gc, dd);
- if (units == DEVICE)
- return height;
- else
- return GConvertYUnits(height, DEVICE, units, dd);
-}
-
-/* Comment is NOT true: used in plot.c for strwidth and strheight.
- *
- * This is just here to satisfy the Rgraphics.h API.
- * This allows new graphics API (GraphicsDevice.h, GraphicsEngine.h)
- * to be developed alongside.
- * Could be removed if Rgraphics.h ever gets REPLACED by new API
- * NOTE that base graphics code no longer calls this -- the base
- * graphics system directly calls the graphics engine for mathematical
- * annotation (GEMathText)
- */
-void GMathText(double x, double y, int coords, SEXP expr,
- double xc, double yc, double rot,
- pGEDevDesc dd)
-{
- R_GE_gcontext gc;
- gcontextFromGP(&gc, dd);
- GConvert(&x, &y, coords, DEVICE, dd);
- GClip(dd);
- GEMathText(x, y, expr, xc, yc, rot, &gc, dd);
-}
-
-void GMMathText(SEXP str, int side, double line, int outer,
- double at, int las, double yadj, pGEDevDesc dd)
-{
- int coords = 0;
- double xadj, angle = 0;
-
- /* IF font metric information is not available for device */
- /* then bail out */
- double ascent, descent, width;
- GMetricInfo('M', &ascent, &descent, &width, DEVICE, dd);
- if ((ascent == 0) && (descent == 0) && (width == 0))
- error(_("metric information not available for this device"));
-
- xadj = gpptr(dd)->adj;
-
- /* This is MOSTLY the same as the same section of GMtext
- * BUT it differs because it sets different values for yadj for
- * different situations.
- * Paul
- */
- /* changed to unify behaviour with changes in GMText. Uwe */
- if(outer) {
- switch(side) {
- case 1: coords = OMA1; break;
- case 2: coords = OMA2; break;
- case 3: coords = OMA3; break;
- case 4: coords = OMA4; break;
- }
- }
- else {
- switch(side) {
- case 1: coords = MAR1; break;
- case 2: coords = MAR2; break;
- case 3: coords = MAR3; break;
- case 4: coords = MAR4; break;
- }
- }
- switch(side) {
- case 1:
- if(las == 2 || las == 3) {
- angle = 90;
- }
- else {
- /* line = line + 1 - gpptr(dd)->yLineBias;
- angle = 0;
- yadj = NA_REAL; */
- line += (1/gpptr(dd)->mex)*(1 - dd->dev->yLineBias);
- angle = 0;
- }
- break;
- case 2:
- if(las == 1 || las == 2) {
- angle = 0;
- }
- else {
- /* line = line + gpptr(dd)->yLineBias;
- angle = 90;
- yadj = NA_REAL; */
- /* The following line is needed for symmetry with plain text
- but changes existing output */
- line += (1/gpptr(dd)->mex)*dd->dev->yLineBias;
- angle = 90;
- }
- break;
- case 3:
- if(las == 2 || las == 3) {
- angle = 90;
- }
- else {
- /* line = line + gpptr(dd)->yLineBias;
- angle = 0;
- yadj = NA_REAL; */
- /* The following line is needed for symmetry with plain text
- but changes existing output */
- line += (1/gpptr(dd)->mex)*dd->dev->yLineBias;
- angle = 0;
- }
- break;
- case 4:
- if(las == 1 || las == 2) {
- angle = 0;
- }
- else {
- /* line = line + 1 - gpptr(dd)->yLineBias;
- angle = 90;
- yadj = NA_REAL; */
- line += (1/gpptr(dd)->mex)*(1 - dd->dev->yLineBias);
- angle = 90;
- }
- break;
- }
- GMathText(at, line, coords, str, xadj, yadj, angle, dd);
-}/* GMMathText */
-
-/* -------------------- end of code from plotmath ------------- */
diff --git a/com.oracle.truffle.r.native/library/graphics/src/graphics.h b/com.oracle.truffle.r.native/library/graphics/src/graphics.h
deleted file mode 100644
index 44fd024d76b58d74d4bd8053c1e43fe14de7c62c..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/graphics.h
+++ /dev/null
@@ -1,73 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2012 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/
- */
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#undef _
-#define _(String) dgettext ("graphics", String)
-#else
-#define _(String) (String)
-#endif
-
-SEXP C_contour(SEXP);
-SEXP C_contourDef(void);
-SEXP C_filledcontour(SEXP);
-SEXP C_image(SEXP);
-SEXP C_persp(SEXP);
-
-SEXP C_abline(SEXP args);
-SEXP C_arrows(SEXP args);
-SEXP C_axis(SEXP args);
-SEXP C_box(SEXP args);
-SEXP C_clip(SEXP args);
-SEXP C_convertX(SEXP args);
-SEXP C_convertY(SEXP args);
-SEXP C_dend(SEXP args);
-SEXP C_dendwindow(SEXP args);
-SEXP C_erase(SEXP args);
-SEXP C_layout(SEXP args);
-SEXP C_mtext(SEXP args);
-SEXP C_path(SEXP args);
-SEXP C_plotXY(SEXP args);
-SEXP C_plot_window(SEXP args);
-SEXP C_polygon(SEXP args);
-SEXP C_raster(SEXP args);
-SEXP C_rect(SEXP args);
-SEXP C_segments(SEXP args);
-SEXP C_strHeight(SEXP args);
-SEXP C_strWidth (SEXP args);
-SEXP C_symbols(SEXP args);
-SEXP C_text(SEXP args);
-SEXP C_title(SEXP args);
-SEXP C_xspline(SEXP args);
-
-
-SEXP C_par(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP C_plot_new(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP C_locator(SEXP call, SEXP op, SEXP args, SEXP rho);
-SEXP C_identify(SEXP call, SEXP op, SEXP args, SEXP rho);
-
-void registerBase(void);
-void unregisterBase(void);
-SEXP RunregisterBase(void);
-
-SEXP C_StemLeaf(SEXP x, SEXP scale, SEXP swidth, SEXP atom);
-SEXP C_BinCount(SEXP x, SEXP breaks, SEXP right, SEXP lowest);
-
-Rboolean isNAcol(SEXP col, int index, int ncol);
diff --git a/com.oracle.truffle.r.native/library/graphics/src/init.c b/com.oracle.truffle.r.native/library/graphics/src/init.c
deleted file mode 100644
index dfc6468c2877fe9c02cde700075d2d8554a08040..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/init.c
+++ /dev/null
@@ -1,93 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 2012 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/
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <R.h>
-#include <Rinternals.h>
-
-#include "graphics.h"
-#include <R_ext/Rdynload.h>
-
-#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
-
-static const R_CallMethodDef CallEntries[] = {
- CALLDEF(C_contourDef, 0),
- CALLDEF(C_StemLeaf, 4),
- CALLDEF(C_BinCount, 4),
- CALLDEF(RunregisterBase, 0),
- {NULL, NULL, 0}
-};
-
-
-#define EXTDEF(name, n) {#name, (DL_FUNC) &name, n}
-
-static const R_ExternalMethodDef ExtEntries[] = {
- EXTDEF(C_contour, -1),
- EXTDEF(C_filledcontour, 5),
- EXTDEF(C_image, 4),
- EXTDEF(C_persp, -1),
-
- EXTDEF(C_abline, -1),
- EXTDEF(C_axis, -1),
- EXTDEF(C_arrows, -1),
- EXTDEF(C_box, -1),
- EXTDEF(C_clip, -1),
- EXTDEF(C_convertX, 3),
- EXTDEF(C_convertY, 3),
- EXTDEF(C_dend, -1),
- EXTDEF(C_dendwindow, -1),
- EXTDEF(C_erase, -1),
- EXTDEF(C_layout, -1),
- EXTDEF(C_mtext, -1),
- EXTDEF(C_par, -1),
- EXTDEF(C_path, -1),
- EXTDEF(C_plotXY, -1),
- EXTDEF(C_plot_window, -1),
- EXTDEF(C_polygon, -1),
- EXTDEF(C_raster, -1),
- EXTDEF(C_rect, -1),
- EXTDEF(C_segments, -1),
- EXTDEF(C_strHeight, -1),
- EXTDEF(C_strWidth, -1),
- EXTDEF(C_symbols, -1),
- EXTDEF(C_text, -1),
- EXTDEF(C_title, -1),
- EXTDEF(C_xspline, -1),
-
- EXTDEF(C_plot_new, 0),
- EXTDEF(C_locator, -1),
- EXTDEF(C_identify, -1),
- {NULL, NULL, 0}
-};
-
-
-void
-#ifdef HAVE_VISIBILITY_ATTRIBUTE
-__attribute__ ((visibility ("default")))
-#endif
-R_init_graphics(DllInfo *dll)
-{
- R_registerRoutines(dll, NULL, CallEntries, NULL, ExtEntries);
- R_useDynamicSymbols(dll, FALSE);
- R_forceSymbols(dll, TRUE);
- registerBase();
-}
diff --git a/com.oracle.truffle.r.native/library/graphics/src/par-common.h b/com.oracle.truffle.r.native/library/graphics/src/par-common.h
deleted file mode 100644
index fb4584cf053c4f1a7c7bc3c058202c8cd7ffbecb..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/par-common.h
+++ /dev/null
@@ -1,363 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1997-2012 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/
- */
-
-/* Graphical parameters which are treated identically by
- * par( <nam> = <value> ) and highlevel plotfun (..., <nam> = <value> ).
- *
- * This is #included both from Specify() and Specify2() into ./par.c
-*/
- if (streql(what, "adj")) {
- lengthCheck(what, value, 1); x = asReal(value);
- BoundsCheck(x, 0.0, 1.0, what);
- R_DEV__(adj) = x;
- }
- else if (streql(what, "ann")) {
- lengthCheck(what, value, 1); ix = asLogical(value);
- R_DEV__(ann) = (ix != 0);/* NA |-> TRUE */
- }
- else if (streql(what, "bg")) {
- /* in par() this means the plot region, inline it means filled points */
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-#else
- if (!isVector(value) || LENGTH(value) < 1) par_error(what);
-#endif
- R_DEV__(bg) = RGBpar3(value, 0, dpptr(dd)->bg);
-#ifdef FOR_PAR
- R_DEV__(new) = FALSE;
-#endif
- }
- else if (streql(what, "bty")) {
- lengthCheck(what, value, 1);
- if (!isString(value))
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- switch (cx) {
- case 'o': case 'O':
- case 'l': case 'L':
- case '7':
- case 'c': case 'C': case '[':
- case ']':
- case 'u': case 'U':
- case 'n':
- R_DEV__(bty) = cx;
- break;
- default:
- par_error(what);
- }
- }
-
- else if (streql(what, "cex")) {
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-/* else: cex can be a vector of length > 1, so pick off first value
- (as e.g. pch always did) */
-#endif
- x = asReal(value);
- posRealCheck(x, what);
-#ifdef FOR_PAR
- R_DEV__(cex) = 1.0;
- R_DEV__(cexbase) = x;
-#else
- R_DEV__(cex) = x; // not setting cexbase here
-#endif
- }
- else if (streql(what, "cex.main")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(cexmain) = x;
- }
- else if (streql(what, "cex.lab")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(cexlab) = x;
- }
- else if (streql(what, "cex.sub")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(cexsub) = x;
- }
- else if (streql(what, "cex.axis")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(cexaxis) = x;
- }
- else if (streql(what, "col")) {
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-#else
- if (!isVector(value) || LENGTH(value) < 1) par_error(what);
-#endif
- R_DEV__(col) = RGBpar3(value, 0, dpptr(dd)->bg);
- }
- else if (streql(what, "col.main")) {
- lengthCheck(what, value, 1);
- R_DEV__(colmain) = RGBpar3(value, 0, dpptr(dd)->bg);
- }
- else if (streql(what, "col.lab")) {
- lengthCheck(what, value, 1);
- R_DEV__(collab) = RGBpar3(value, 0, dpptr(dd)->bg);
- }
- else if (streql(what, "col.sub")) {
- lengthCheck(what, value, 1);
- R_DEV__(colsub) = RGBpar3(value, 0, dpptr(dd)->bg);
- }
- else if (streql(what, "col.axis")) {
- lengthCheck(what, value, 1);
- R_DEV__(colaxis) = RGBpar3(value, 0, dpptr(dd)->bg);
- }
- else if (streql(what, "crt")) {
- lengthCheck(what, value, 1); x = asReal(value);
- naRealCheck(x, what);
- R_DEV__(crt) = x;
- }
- else if (streql(what, "err")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- if (ix == 0 || ix == -1)
- R_DEV__(err) = ix;
- else par_error(what);
- }
- else if (streql(what, "family")) {
- const char *ss;
- value = coerceVector(value, STRSXP);
- lengthCheck(what, value, 1);
- const void *vmax = vmaxget();
- ss = translateChar(STRING_ELT(value, 0));
- if(strlen(ss) > 200)
- error(_("graphical parameter 'family' has a maximum length of 200 bytes"));
-#ifdef FOR_PAR
- strncpy(dpptr(dd)->family, ss, 201);
-#endif
- strncpy(gpptr(dd)->family, ss, 201);
- vmaxset(vmax);
- }
- else if (streql(what, "fg")) {
- lengthCheck(what, value, 1);
- ix = RGBpar3(value, 0, dpptr(dd)->bg);
-#ifdef FOR_PAR
- /* par(fg=) sets BOTH "fg" and "col" */
- R_DEV__(col) = ix;
-#endif
- R_DEV__(fg) = ix;
- }
- else if (streql(what, "font")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- posIntCheck(ix, what);
- R_DEV__(font) = ix;
- }
- else if (streql(what, "font.main")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- posIntCheck(ix, what);
- R_DEV__(fontmain) = ix;
- }
- else if (streql(what, "font.lab")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- posIntCheck(ix, what);
- R_DEV__(fontlab) = ix;
- }
- else if (streql(what, "font.sub")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- posIntCheck(ix, what);
- R_DEV__(fontsub) = ix;
- }
- else if (streql(what, "font.axis")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- posIntCheck(ix, what);
- R_DEV__(fontaxis) = ix;
- }
- else if (streql(what, "lab")) {
- value = coerceVector(value, INTSXP);
- lengthCheck(what, value, 3);
- posIntCheck (INTEGER(value)[0], what);
- posIntCheck (INTEGER(value)[1], what);
- nonnegIntCheck(INTEGER(value)[2], what);
- R_DEV__(lab[0]) = INTEGER(value)[0];
- R_DEV__(lab[1]) = INTEGER(value)[1];
- R_DEV__(lab[2]) = INTEGER(value)[2];
- }
- else if (streql(what, "las")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- if (0 <= ix && ix <= 3)
- R_DEV__(las) = ix;
- else par_error(what);
- }
- else if (streql(what, "lend")) {
- lengthCheck(what, value, 1);
- R_DEV__(lend) = GE_LENDpar(value, 0);
- }
- else if (streql(what, "ljoin")) {
- lengthCheck(what, value, 1);
- R_DEV__(ljoin) = GE_LJOINpar(value, 0);
- }
- else if (streql(what, "lmitre")) {
- lengthCheck(what, value, 1);
- x = asReal(value);
- posRealCheck(x, what);
- if (x < 1)
- par_error(what);
- R_DEV__(lmitre) = x;
- }
- else if (streql(what, "lty")) {
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-#else
- if (!isVector(value) || LENGTH(value) < 1) par_error(what);
-#endif
- R_DEV__(lty) = GE_LTYpar(value, 0);
- }
- else if (streql(what, "lwd")) {
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-#else
- if (!isVector(value) || LENGTH(value) < 1) par_error(what);
-#endif
- x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(lwd) = x;
- }
- else if (streql(what, "mgp")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 3);
- /* Since 1.6.x: Allow negative (S-compatibly): */
- naRealCheck(REAL(value)[0], what);
- naRealCheck(REAL(value)[1], what);
- naRealCheck(REAL(value)[2], what);
- if(REAL(value)[0] * REAL(value)[1] < 0 ||
- REAL(value)[0] * REAL(value)[2] < 0)
- warning("`mgp[1:3]' are of differing sign");
- R_DEV__(mgp[0]) = REAL(value)[0];
- R_DEV__(mgp[1]) = REAL(value)[1];
- R_DEV__(mgp[2]) = REAL(value)[2];
- }
- else if (streql(what, "mkh")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(mkh) = x;
- }
- else if (streql(what, "pch")) {
-#ifdef FOR_PAR
- lengthCheck(what, value, 1);
-#else
- if (!isVector(value) || LENGTH(value) < 1) par_error(what);
-#endif
- if (isString(value)) {
- ix = GEstring_to_pch(STRING_ELT(value, 0));
- } else if (isNumeric(value)) {
- ix = asInteger(value);
- } else par_error(what);
- if(ix == NA_INTEGER) par_error(what);
- R_DEV__(pch) = ix;
- }
- else if (streql(what, "smo")) {
- /* FIXME: not real */
- lengthCheck(what, value, 1); x = asReal(value);
- nonnegRealCheck(x, what);
- R_DEV__(smo) = (int) x;
- }
- else if (streql(what, "srt")) {
- lengthCheck(what, value, 1); x = asReal(value);
- naRealCheck(x, what);
- R_DEV__(srt) = x;
- }
-
- /* NOTE: tck and tcl must be treated in parallel; if one is NA,
- * the other must be non-NA. If tcl is NA, then setting tck to NA
- * will reset tck to its initial default value. See also graphics.c. */
- else if (streql(what, "tck")) {
- lengthCheck(what, value, 1); x = asReal(value);
- R_DEV__(tck) = x;
- if (R_FINITE(x))
- R_DEV__(tcl) = NA_REAL;
- else if(!R_FINITE(dpptr(dd)->tcl))
- R_DEV__(tcl) = -0.5;
- }
- else if (streql(what, "tcl")) {
- lengthCheck(what, value, 1); x = asReal(value);
- R_DEV__(tcl) = x;
- if (R_FINITE(x))
- R_DEV__(tck) = NA_REAL;
- else if (!R_FINITE(dpptr(dd)->tck))
- R_DEV__(tck) = -0.01; /* S Default -- was 0.02 till R 1.5.x */
- }
- else if (streql(what, "xaxp")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 3);
- naRealCheck(REAL(value)[0], what);
- naRealCheck(REAL(value)[1], what);
- if ((R_DEV__(xlog)))
- logAxpCheck((int) (REAL(value)[2]), what);
- else
- posIntCheck((int) (REAL(value)[2]), what);
- R_DEV__(xaxp[0]) = REAL(value)[0];
- R_DEV__(xaxp[1]) = REAL(value)[1];
- R_DEV__(xaxp[2]) = (int)(REAL(value)[2]);
- }
- else if (streql(what, "xaxs")) {
- if (!isString(value) || LENGTH(value) < 1)
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- if (cx == 's' || cx == 'e' || cx == 'i' || cx == 'r' || cx == 'd')
- R_DEV__(xaxs) = cx;
- else par_error(what);
- }
- else if (streql(what, "xaxt")) {
- if (!isString(value) || LENGTH(value) < 1)
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- if (cx == 's' || cx == 'l' || cx == 't' || cx == 'n')
- R_DEV__(xaxt) = cx;
- else par_error(what);
- }
- else if (streql(what, "xpd")) {
- lengthCheck(what, value, 1);
- ix = asInteger(value);
- if (ix == NA_INTEGER)
- R_DEV__(xpd) = 2;
- else
- R_DEV__(xpd) = (ix != 0);
- }
- else if (streql(what, "yaxp")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 3);
- naRealCheck(REAL(value)[0], what);
- naRealCheck(REAL(value)[1], what);
- if ((R_DEV__(ylog)))
- logAxpCheck((int) (REAL(value)[2]), what);
- else
- posIntCheck((int) (REAL(value)[2]), what);
- R_DEV__(yaxp[0]) = REAL(value)[0];
- R_DEV__(yaxp[1]) = REAL(value)[1];
- R_DEV__(yaxp[2]) = (int) (REAL(value)[2]);
- }
- else if (streql(what, "yaxs")) {
- if (!isString(value) || LENGTH(value) < 1)
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- if (cx == 's' || cx == 'e' || cx == 'i' || cx == 'r' || cx == 'd')
- R_DEV__(yaxs) = cx;
- else par_error(what);
- }
- else if (streql(what, "yaxt")) {
- if (!isString(value) || LENGTH(value) < 1)
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- if (cx == 's' || cx == 'l' || cx == 't' || cx == 'n')
- R_DEV__(yaxt) = cx;
- else par_error(what);
- }
diff --git a/com.oracle.truffle.r.native/library/graphics/src/par.c b/com.oracle.truffle.r.native/library/graphics/src/par.c
deleted file mode 100644
index 27d436d3e54c1ee6b5f081ed2d325c1f02df7c8e..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/par.c
+++ /dev/null
@@ -1,1268 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--2014 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/
- *
- *
- *
- * GRZ-like state information.
- *
- * This is a quick knock-off of the GRZ library to provide a basic
- * S-like graphics capability for R. Basically this bit of code
- * provides the functionality of the "par" function in S.
- *
- * "The horror, the horror ..."
- * Marlon Brando in Apocalypse Now.
- *
- * Main functions:
- * do_par(.) and
- * do_layout(.) implement R's par(.), layout()rely on
- *
- * Specify(.) [ par(what = value) ]
- * Specify2(.) [ <highlevelplot>(what = value) ]
- * Query(.) [ par(what) ]
- */
-
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-#include <Rmath.h>
-#include "../../grDevices/src/main_Graphics.h" /* "GPar" structure + COMMENTS */
-
-#include "graphics.h"
-
-typedef struct {
- char *name;
- int code; /* 0 normal, 1 not inline, 2 read-only
- -1 unknown, -2 obselete, -3 graphical args
- */
-} ParTab;
-
-static const ParTab
-ParTable [] = {
- { "adj", 0 },
- { "ann", 0 },
- { "ask", 1 },
- { "bg", 0 },
- { "bty", 0 },
- { "cex", 0 },
- { "cex.axis", 0 },
- { "cex.lab", 0 },
- { "cex.main", 0 },
- { "cex.sub", 0 },
- { "cin", 2 },
- { "col", 0 },
- { "col.axis", 0 },
- { "col.lab", 0 },
- { "col.main", 0 },
- { "col.sub", 0 },
- { "cra", 2 },
- { "crt", 0 },
- { "csi", 2 },
- { "csy", 0 },
- { "cxy", 2 },
- { "din", 2 },
- { "err", 0 },
- { "family", 0 },
- { "fg", 0 },
- { "fig", 1 },
- { "fin", 1 },
- { "font", 0 },
- { "font.axis", 0 },
- { "font.lab", 0 },
- { "font.main", 0 },
- { "font.sub", 0 },
- { "lab", 0 },
- { "las", 0 },
- { "lend", 0 },
- { "lheight", 1 },
- { "ljoin", 0 },
- { "lmitre", 0 },
- { "lty", 0 },
- { "lwd", 0 },
- { "mai", 1 },
- { "mar", 1 },
- { "mex", 1 },
- { "mfcol", 1 },
- { "mfg", 1 },
- { "mfrow", 1 },
- { "mgp", 0 },
- { "mkh", 0 },
- { "new", 1 },
- { "oma", 1 },
- { "omd", 1 },
- { "omi", 1 },
- { "page", 2 },
- { "pch", 0 },
- { "pin", 1 },
- { "plt", 1 },
- { "ps", 1 },
- { "pty", 1 },
- { "smo", 0 },
- { "srt", 0 },
- { "tck", 0 },
- { "tcl", 0 },
- { "usr", 1 },
- { "xaxp", 0 },
- { "xaxs", 0 },
- { "xaxt", 0 },
- { "xlog", 1 },
- { "xpd", 0 },
- { "yaxp", 0 },
- { "yaxs", 0 },
- { "yaxt", 0 },
- { "ylbias", 1 },
- { "ylog", 1 },
- /* Obsolete pars */
- { "gamma", -2},
- { "type", -2},
- { "tmag", -2},
- /* Non-pars that might get passed to Specify2 */
- { "asp", -3},
- { "main", -3},
- { "sub", -3},
- { "xlab", -3},
- { "ylab", -3},
- { "xlim", -3},
- { "ylim", -3},
- { NULL, -1}
-};
-
-
-static int ParCode(const char *what)
-{
- int i;
- for (i = 0; ParTable[i].name; i++)
- if (!strcmp(what, ParTable[i].name)) return ParTable[i].code;
- return -1;
-}
-
-
-static void par_error(const char *what)
-{
- error(_("invalid value specified for graphical parameter \"%s\""), what);
-}
-
-
-static void lengthCheck(const char *what, SEXP v, int n)
-{
- if (length(v) != n)
- error(_("graphical parameter \"%s\" has the wrong length"), what);
-}
-
-
-static void nonnegIntCheck(int x, const char *s)
-{
- if (x == NA_INTEGER || x < 0)
- par_error(s);
-}
-
-static void posIntCheck(int x, const char *s)
-{
- if (x == NA_INTEGER || x <= 0)
- par_error(s);
-}
-
-static void posRealCheck(double x, const char *s)
-{
- if (!R_FINITE(x) || x <= 0)
- par_error(s);
-}
-
-static void nonnegRealCheck(double x, const char *s)
-{
- if (!R_FINITE(x) || x < 0)
- par_error(s);
-}
-
-static void naRealCheck(double x, const char *s)
-{
- if (!R_FINITE(x))
- par_error(s);
-}
-
-static void logAxpCheck(int x, const char *s)
-{
- if (x == NA_INTEGER || x == 0 || x > 4)
- par_error(s);
-}
-
-
-static void BoundsCheck(double x, double a, double b, const char *s)
-{
-/* Check if a <= x <= b */
- if (!R_FINITE(x) || (R_FINITE(a) && x < a) || (R_FINITE(b) && x > b))
- par_error(s);
-}
-
-
-/* When any one of the layout parameters (which can only be set via */
-/* par(...)) is modified, must call GReset() to update the layout and */
-/* the transformations between coordinate systems */
-
-/* These will be defined differently for Specify() and Specify2() : */
-/* <FIXME> do not need separate macros for a = b = c and b = a = c */
-#define R_DEV__(_P_) dpptr(dd)->_P_ = gpptr(dd)->_P_
-#define R_DEV_2(_P_) gpptr(dd)->_P_ = dpptr(dd)->_P_
-/* In Emacs : -- only inside Specify() :
- * (query-replace-regexp
- "dpptr(dd)->\\([][A-Za-z0-9]+\\) = gpptr(dd)->\\(\\1\\)"
- "R_DEV__(\\1)" nil nil nil)
-
- (query-replace-regexp
- "gpptr(dd)->\\([][A-Za-z0-9]+\\) = dpptr(dd)->\\(\\1\\)"
- "R_DEV_2(\\1)" nil nil nil)
-*/
-
-static void Specify(const char *what, SEXP value, pGEDevDesc dd)
-{
-/* If you ADD a NEW par, then do NOT forget to update the code in
- * ../library/base/R/par.R
-
- * Parameters in Specify(),
- * which can*not* be specified in high-level functions,
- * i.e., by Specify2() [below]:
- * this list is in \details{.} of ../library/base/man/par.Rd
- * ------------------------
- * "ask",
- * "family", "fig", "fin",
- * "lheight",
- * "mai", "mar", "mex", "mfrow", "mfcol", "mfg",
- * "new",
- * "oma", "omd", "omi",
- * "pin", "plt", "ps", "pty"
- * "usr",
- * "xlog", "ylog"
- * "ylbias",
- */
- double x;
- int ix = 0;
- char cx = '\0';
-
- /* If we get here, Query has already checked that 'what' is valid */
-
- if (ParCode(what) == 2) {
- warning(_("graphical parameter \"%s\" cannot be set"), what);
- return;
- }
-#define FOR_PAR
-#include "par-common.h"
-#undef FOR_PAR
-/* ------------ */
- else if (streql(what, "bg")) {
- lengthCheck(what, value, 1);
- ix = RGBpar3(value, 0, dpptr(dd)->bg);
- /* naIntCheck(ix, what); */
- R_DEV__(bg) = ix;
- R_DEV__(new) = FALSE;
- }
-/*--- and these are "Specify() only" {i.e. par(nam = val)} : */
- else if (streql(what, "ask")) {
- lengthCheck(what, value, 1); ix = asLogical(value);
- dd->ask = (ix == 1);/* NA |-> FALSE */
- }
- else if (streql(what, "fig")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- if (0.0 <= REAL(value)[0] && REAL(value)[0] < REAL(value)[1] &&
- REAL(value)[1] <= 1.0 &&
- 0.0 <= REAL(value)[2] && REAL(value)[2] < REAL(value)[3] &&
- REAL(value)[3] <= 1.0) {
- R_DEV_2(defaultFigure) = 0;
- R_DEV_2(fUnits) = NIC;
- R_DEV_2(numrows) = 1;
- R_DEV_2(numcols) = 1;
- R_DEV_2(heights[0]) = 1;
- R_DEV_2(widths[0]) = 1;
- R_DEV_2(cmHeights[0]) = 0;
- R_DEV_2(cmWidths[0]) = 0;
- R_DEV_2(order[0]) = 1;
- R_DEV_2(currentFigure) = 1;
- R_DEV_2(lastFigure) = 1;
- R_DEV__(rspct) = 0;
-
- R_DEV_2(fig[0]) = REAL(value)[0];
- R_DEV_2(fig[1]) = REAL(value)[1];
- R_DEV_2(fig[2]) = REAL(value)[2];
- R_DEV_2(fig[3]) = REAL(value)[3];
- GReset(dd);
- }
- else par_error(what);
- }
- else if (streql(what, "fin")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 2);
- R_DEV_2(defaultFigure) = 0;
- R_DEV_2(fUnits) = INCHES;
- R_DEV_2(numrows) = 1;
- R_DEV_2(numcols) = 1;
- R_DEV_2(heights[0]) = 1;
- R_DEV_2(widths[0]) = 1;
- R_DEV_2(cmHeights[0]) = 0;
- R_DEV_2(cmWidths[0]) = 0;
- R_DEV_2(order[0]) = 1;
- R_DEV_2(currentFigure) = 1;
- R_DEV_2(lastFigure) = 1;
- R_DEV__(rspct) = 0;
- R_DEV_2(fin[0]) = REAL(value)[0];
- R_DEV_2(fin[1]) = REAL(value)[1];
- GReset(dd);
- }
- /* -- */
- else if (streql(what, "lheight")) {
- lengthCheck(what, value, 1);
- x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(lheight) = x;
- }
- else if (streql(what, "mai")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- nonnegRealCheck(REAL(value)[2], what);
- nonnegRealCheck(REAL(value)[3], what);
- R_DEV__(mai[0]) = REAL(value)[0];
- R_DEV__(mai[1]) = REAL(value)[1];
- R_DEV__(mai[2]) = REAL(value)[2];
- R_DEV__(mai[3]) = REAL(value)[3];
- R_DEV__(mUnits) = INCHES;
- R_DEV__(defaultPlot) = TRUE;
- GReset(dd);
- }
- else if (streql(what, "mar")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- nonnegRealCheck(REAL(value)[2], what);
- nonnegRealCheck(REAL(value)[3], what);
- R_DEV__(mar[0]) = REAL(value)[0];
- R_DEV__(mar[1]) = REAL(value)[1];
- R_DEV__(mar[2]) = REAL(value)[2];
- R_DEV__(mar[3]) = REAL(value)[3];
- R_DEV__(mUnits) = LINES;
- R_DEV__(defaultPlot) = TRUE;
- GReset(dd);
- }
- else if (streql(what, "mex")) {
- lengthCheck(what, value, 1); x = asReal(value);
- posRealCheck(x, what);
- R_DEV__(mex) = x;
- GReset(dd);
- }
- else if (streql(what, "mfrow")) {
- int nrow, ncol;
- value = coerceVector(value, INTSXP);
- lengthCheck(what, value, 2);
- posIntCheck(INTEGER(value)[0], what);
- posIntCheck(INTEGER(value)[1], what);
- nrow = INTEGER(value)[0];
- ncol = INTEGER(value)[1];
- R_DEV_2(numrows) = nrow;
- R_DEV_2(numcols) = ncol;
- R_DEV_2(currentFigure) = nrow*ncol;
- R_DEV_2(lastFigure) = nrow*ncol;
- R_DEV_2(defaultFigure) = TRUE;
- R_DEV_2(layout) = FALSE;
- if (nrow > 2 || ncol > 2) {
- R_DEV_2(cexbase) = 0.66;
- R_DEV_2(mex) = 1.0;
- }
- else if (nrow == 2 && ncol == 2) {
- R_DEV_2(cexbase) = 0.83;
- R_DEV_2(mex) = 1.0;
- }
- else {
- R_DEV_2(cexbase) = 1.0;
- R_DEV_2(mex) = 1.0;
- }
- R_DEV__(mfind) = 0;
- GReset(dd);
- }
- else if (streql(what, "mfcol")) {
- int nrow, ncol;
- value = coerceVector(value, INTSXP);
- lengthCheck(what, value, 2);
- posIntCheck(INTEGER(value)[0], what);
- posIntCheck(INTEGER(value)[1], what);
- nrow = INTEGER(value)[0];
- ncol = INTEGER(value)[1];
- R_DEV_2(numrows) = nrow;
- R_DEV_2(numcols) = ncol;
- R_DEV_2(currentFigure) = nrow*ncol;
- R_DEV_2(lastFigure) = nrow*ncol;
- R_DEV_2(defaultFigure) = TRUE;
- R_DEV_2(layout) = FALSE;
- if (nrow > 2 || ncol > 2) {
- R_DEV_2(cexbase) = 0.66;
- R_DEV_2(mex) = 1.0;
- }
- else if (nrow == 2 && ncol == 2) {
- R_DEV_2(cexbase) = 0.83;
- R_DEV_2(mex) = 1.0;
- }
- else {
- R_DEV__(cexbase) = 1.0;
- R_DEV__(mex) = 1.0;
- }
- R_DEV__(mfind) = 1;
- GReset(dd);
- }
- else if (streql(what, "mfg")) {
- int row, col, nrow, ncol, np;
- value = coerceVector(value, INTSXP);
- np = length(value);
- if(np != 2 && np != 4)
- error(_("parameter \"mfg\" has the wrong length"));
- posIntCheck(INTEGER(value)[0], what);
- posIntCheck(INTEGER(value)[1], what);
- row = INTEGER(value)[0];
- col = INTEGER(value)[1];
- nrow = dpptr(dd)->numrows;
- ncol = dpptr(dd)->numcols;
- if(row <= 0 || row > nrow)
- error(_("parameter \"i\" in \"mfg\" is out of range"));
- if(col <= 0 || col > ncol)
- error(_("parameter \"j\" in \"mfg\" is out of range"));
- if(np == 4) {
- posIntCheck(INTEGER(value)[2], what);
- posIntCheck(INTEGER(value)[3], what);
- if(nrow != INTEGER(value)[2])
- warning(_("value of 'nr' in \"mfg\" is wrong and will be ignored"));
- if(ncol != INTEGER(value)[3])
- warning(_("value of 'nc' in \"mfg\" is wrong and will be ignored"));
- }
- R_DEV_2(lastFigure) = nrow*ncol;
- /*R_DEV__(mfind) = 1;*/
- /* currentFigure is 1-based */
- if(gpptr(dd)->mfind)
- dpptr(dd)->currentFigure = (col-1)*nrow + row;
- else dpptr(dd)->currentFigure = (row-1)*ncol + col;
- /*
- if (dpptr(dd)->currentFigure == 0)
- dpptr(dd)->currentFigure = dpptr(dd)->lastFigure;
- */
- R_DEV_2(currentFigure);
- /* R_DEV_2(defaultFigure) = TRUE;
- R_DEV_2(layout) = FALSE; */
- R_DEV_2(new) = TRUE;
- GReset(dd);
- /* Force a device clip */
- if (dd->dev->canClip) GForceClip(dd);
- } /* mfg */
-
- else if (streql(what, "new")) {
- lengthCheck(what, value, 1);
- ix = asLogical(value);
- if(!gpptr(dd)->state) {
- /* no need to warn with new=FALSE and no plot */
- if(ix != 0) warning(_("calling par(new=TRUE) with no plot"));
- } else R_DEV__(new) = (ix != 0);
- }
- /* -- */
-
- else if (streql(what, "oma")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- nonnegRealCheck(REAL(value)[2], what);
- nonnegRealCheck(REAL(value)[3], what);
- R_DEV__(oma[0]) = REAL(value)[0];
- R_DEV__(oma[1]) = REAL(value)[1];
- R_DEV__(oma[2]) = REAL(value)[2];
- R_DEV__(oma[3]) = REAL(value)[3];
- R_DEV__(oUnits) = LINES;
- /* !!! Force eject of multiple figures !!! */
- R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
- GReset(dd);
- }
- else if (streql(what, "omd")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- BoundsCheck(REAL(value)[0], 0.0, 1.0, what);
- BoundsCheck(REAL(value)[1], 0.0, 1.0, what);
- BoundsCheck(REAL(value)[2], 0.0, 1.0, what);
- BoundsCheck(REAL(value)[3], 0.0, 1.0, what);
- R_DEV__(omd[0]) = REAL(value)[0];
- R_DEV__(omd[1]) = REAL(value)[1];
- R_DEV__(omd[2]) = REAL(value)[2];
- R_DEV__(omd[3]) = REAL(value)[3];
- R_DEV__(oUnits) = NDC;
- /* Force eject of multiple figures */
- R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
- GReset(dd);
- }
- else if (streql(what, "omi")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- nonnegRealCheck(REAL(value)[2], what);
- nonnegRealCheck(REAL(value)[3], what);
- R_DEV__(omi[0]) = REAL(value)[0];
- R_DEV__(omi[1]) = REAL(value)[1];
- R_DEV__(omi[2]) = REAL(value)[2];
- R_DEV__(omi[3]) = REAL(value)[3];
- R_DEV__(oUnits) = INCHES;
- /* Force eject of multiple figures */
- R_DEV__(currentFigure) = gpptr(dd)->lastFigure;
- GReset(dd);
- }
- /* -- */
-
- else if (streql(what, "pin")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 2);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- R_DEV__(pin[0]) = REAL(value)[0];
- R_DEV__(pin[1]) = REAL(value)[1];
- R_DEV__(pUnits) = INCHES;
- R_DEV__(defaultPlot) = FALSE;
- GReset(dd);
- }
- else if (streql(what, "plt")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- nonnegRealCheck(REAL(value)[0], what);
- nonnegRealCheck(REAL(value)[1], what);
- nonnegRealCheck(REAL(value)[2], what);
- nonnegRealCheck(REAL(value)[3], what);
- R_DEV__(plt[0]) = REAL(value)[0];
- R_DEV__(plt[1]) = REAL(value)[1];
- R_DEV__(plt[2]) = REAL(value)[2];
- R_DEV__(plt[3]) = REAL(value)[3];
- R_DEV__(pUnits) = NFC;
- R_DEV__(defaultPlot) = FALSE;
- GReset(dd);
- }
- else if (streql(what, "ps")) {
- lengthCheck(what, value, 1); ix = asInteger(value);
- nonnegIntCheck(ix, what);
- R_DEV__(ps) = ix;
- }
- else if (streql(what, "pty")) {
- if (!isString(value) || LENGTH(value) < 1)
- par_error(what);
- cx = CHAR(STRING_ELT(value, 0))[0];
- if (cx == 'm' || cx == 's') {
- R_DEV__(pty) = cx;
- R_DEV__(defaultPlot) = TRUE;
- }
- else par_error(what);
- }
- /* -- */
- else if (streql(what, "usr")) {
- value = coerceVector(value, REALSXP);
- lengthCheck(what, value, 4);
- naRealCheck(REAL(value)[0], what);
- naRealCheck(REAL(value)[1], what);
- naRealCheck(REAL(value)[2], what);
- naRealCheck(REAL(value)[3], what);
- if (REAL(value)[0] == REAL(value)[1] ||
- REAL(value)[2] == REAL(value)[3])
- par_error(what);
- if (gpptr(dd)->xlog) {
- R_DEV_2(logusr[0]) = REAL(value)[0];
- R_DEV_2(logusr[1]) = REAL(value)[1];
- R_DEV_2(usr[0]) = Rexp10(REAL(value)[0]);
- R_DEV_2(usr[1]) = Rexp10(REAL(value)[1]);
- }
- else {
- R_DEV_2(usr[0]) = REAL(value)[0];
- R_DEV_2(usr[1]) = REAL(value)[1];
- R_DEV_2(logusr[0]) = R_Log10(REAL(value)[0]);
- R_DEV_2(logusr[1]) = R_Log10(REAL(value)[1]);
- }
- if (gpptr(dd)->ylog) {
- R_DEV_2(logusr[2]) = REAL(value)[2];
- R_DEV_2(logusr[3]) = REAL(value)[3];
- R_DEV_2(usr[2]) = Rexp10(REAL(value)[2]);
- R_DEV_2(usr[3]) = Rexp10(REAL(value)[3]);
- }
- else {
- R_DEV_2(usr[2]) = REAL(value)[2];
- R_DEV_2(usr[3]) = REAL(value)[3];
- R_DEV_2(logusr[2]) = R_Log10(REAL(value)[2]);
- R_DEV_2(logusr[3]) = R_Log10(REAL(value)[3]);
- }
- /* Reset Mapping and Axis Parameters */
- GMapWin2Fig(dd);
- GSetupAxis(1, dd);
- GSetupAxis(2, dd);
- }/* usr */
-
- else if (streql(what, "xlog")) {
- lengthCheck(what, value, 1); ix = asLogical(value);
- if (ix == NA_LOGICAL)
- par_error(what);
- R_DEV__(xlog) = (ix != 0);
- }
- else if (streql(what, "ylog")) {
- lengthCheck(what, value, 1); ix = asLogical(value);
- if (ix == NA_LOGICAL)
- par_error(what);
- R_DEV__(ylog) = (ix != 0);
- }
- else if (streql(what, "ylbias")) {
- lengthCheck(what, value, 1);
- dd->dev->yLineBias = asReal(value);
- }
- /* We do not need these as Query will already have warned.
- else if (streql(what, "type")) {
- warning(_("graphical parameter \"%s\" is obsolete"), what);
- }
- else warning(_("unknown graphical parameter \"%s\""), what);
- */
-
- return;
-} /* Specify */
-
-
-/* Specify2 -- parameters as arguments from higher-level graphics functions
- * --------
- * Many things in PARALLEL to Specify(.)
- * for par()s not valid here, see comment there.
- */
-#undef R_DEV_2
-#undef R_DEV__
-/* Now defined differently in Specify2() : */
-#define R_DEV__(_P_) gpptr(dd)->_P_
-
-static void Specify2(const char *what, SEXP value, pGEDevDesc dd)
-{
- double x;
- int ix = 0, ptype = ParCode(what);
- char cx = '\0';
-
- if (ptype == 1 || ptype == -3) {
- /* 1: these are valid, but not settable inline
- 3: arguments, not pars
- */
- return;
- }
- if (ptype == -2) {
- warning(_("graphical parameter \"%s\" is obsolete"), what);
- return;
- }
- if (ptype < 0) {
- warning(_("\"%s\" is not a graphical parameter"), what);
- return;
- }
- if (ptype == 2) {
- warning(_("graphical parameter \"%s\" cannot be set"), what);
- return;
- }
-
-#include "par-common.h"
-} /* Specify2 */
-
-
-/* Do NOT forget to update ../library/base/R/par.R */
-/* if you ADD a NEW par !! */
-
-static SEXP Query(const char *what, pGEDevDesc dd)
-{
- SEXP value;
-
- if (streql(what, "adj")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->adj;
- }
- else if (streql(what, "ann")) {
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = (dpptr(dd)->ann != 0);
- }
- else if (streql(what, "ask")) {
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = dd->ask;
- }
- else if (streql(what, "bg")) {
- value = mkString(col2name(dpptr(dd)->bg));
- }
- else if (streql(what, "bty")) {
- char buf[2];
- buf[0] = dpptr(dd)->bty;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "cex")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->cexbase;
- }
- else if (streql(what, "cex.main")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->cexmain;
- }
- else if (streql(what, "cex.lab")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->cexlab;
- }
- else if (streql(what, "cex.sub")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->cexsub;
- }
- else if (streql(what, "cex.axis")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->cexaxis;
- }
- else if (streql(what, "cin")) {
- value = allocVector(REALSXP, 2);
- REAL(value)[0] = dpptr(dd)->scale * dd->dev->cra[0] * dd->dev->ipr[0];
- REAL(value)[1] = dpptr(dd)->scale * dd->dev->cra[1] * dd->dev->ipr[1];
- }
- else if (streql(what, "col")) {
- value = mkString(col2name(dpptr(dd)->col));
- }
- else if (streql(what, "col.main")) {
- value = mkString(col2name(dpptr(dd)->colmain));
- }
- else if (streql(what, "col.lab")) {
- value = mkString(col2name(dpptr(dd)->collab));
- }
- else if (streql(what, "col.sub")) {
- value = mkString(col2name(dpptr(dd)->colsub));
- }
- else if (streql(what, "col.axis")) {
- value = mkString(col2name(dpptr(dd)->colaxis));
- }
- else if (streql(what, "cra")) {
- value = allocVector(REALSXP, 2);
- REAL(value)[0] = dpptr(dd)->scale * dd->dev->cra[0];
- REAL(value)[1] = dpptr(dd)->scale * dd->dev->cra[1];
- }
- else if (streql(what, "crt")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->crt;
- }
- else if (streql(what, "csi")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = GConvertYUnits(1.0, CHARS, INCHES, dd);
- }
- else if (streql(what, "cxy")) {
- value = allocVector(REALSXP, 2);
- /* == par("cin") / par("pin") : */
- REAL(value)[0] = dpptr(dd)->scale * dd->dev->cra[0]
- * dd->dev->ipr[0] / dpptr(dd)->pin[0]
- * (dpptr(dd)->usr[1] - dpptr(dd)->usr[0]);
- REAL(value)[1] = dpptr(dd)->scale * dd->dev->cra[1]
- * dd->dev->ipr[1] / dpptr(dd)->pin[1]
- * (dpptr(dd)->usr[3] - dpptr(dd)->usr[2]);
- }
- else if (streql(what, "din")) {
- value = allocVector(REALSXP, 2);
- REAL(value)[0] = GConvertXUnits(1.0, NDC, INCHES, dd);
- REAL(value)[1] = GConvertYUnits(1.0, NDC, INCHES, dd);
- }
- else if (streql(what, "err")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->err;
- }
- else if (streql(what, "family")) {
- value = mkString(dpptr(dd)->family);
- }
- else if (streql(what, "fg")) {
- value = mkString(col2name(dpptr(dd)->fg));
- }
- else if (streql(what, "fig")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->fig[0];
- REAL(value)[1] = dpptr(dd)->fig[1];
- REAL(value)[2] = dpptr(dd)->fig[2];
- REAL(value)[3] = dpptr(dd)->fig[3];
- }
- else if (streql(what, "fin")) {
- value = allocVector(REALSXP, 2);
- REAL(value)[0] = dpptr(dd)->fin[0];
- REAL(value)[1] = dpptr(dd)->fin[1];
- }
- else if (streql(what, "font")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->font;
- }
- else if (streql(what, "font.main")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->fontmain;
- }
- else if (streql(what, "font.lab")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->fontlab;
- }
- else if (streql(what, "font.sub")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->fontsub;
- }
- else if (streql(what, "font.axis")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->fontaxis;
- }
- else if (streql(what, "lab")) {
- value = allocVector(INTSXP, 3);
- INTEGER(value)[0] = dpptr(dd)->lab[0];
- INTEGER(value)[1] = dpptr(dd)->lab[1];
- INTEGER(value)[2] = dpptr(dd)->lab[2];
- }
- else if (streql(what, "las")) {
- value = allocVector(INTSXP, 1);
- INTEGER(value)[0] = dpptr(dd)->las;
- }
- else if (streql(what, "lend")) {
- value = GE_LENDget(dpptr(dd)->lend);
- }
- else if (streql(what, "lheight")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->lheight;
- }
- else if (streql(what, "ljoin")) {
- value = GE_LJOINget(dpptr(dd)->ljoin);
- }
- else if (streql(what, "lmitre")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->lmitre;
- }
- else if (streql(what, "lty")) {
- value = GE_LTYget(dpptr(dd)->lty);
- }
- else if (streql(what, "lwd")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->lwd;
- }
- else if (streql(what, "mai")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->mai[0];
- REAL(value)[1] = dpptr(dd)->mai[1];
- REAL(value)[2] = dpptr(dd)->mai[2];
- REAL(value)[3] = dpptr(dd)->mai[3];
- }
- else if (streql(what, "mar")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->mar[0];
- REAL(value)[1] = dpptr(dd)->mar[1];
- REAL(value)[2] = dpptr(dd)->mar[2];
- REAL(value)[3] = dpptr(dd)->mar[3];
- }
- else if (streql(what, "mex")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->mex;
- }
- /* NOTE that if a complex layout has been specified */
- /* then this simple information may not be very useful. */
- else if (streql(what, "mfrow") || streql(what, "mfcol")) {
- value = allocVector(INTSXP, 2);
- INTEGER(value)[0] = dpptr(dd)->numrows;
- INTEGER(value)[1] = dpptr(dd)->numcols;
- }
- else if (streql(what, "mfg")) {
- int row, col;
- value = allocVector(INTSXP, 4);
- currentFigureLocation(&row, &col, dd);
- INTEGER(value)[0] = row+1;
- INTEGER(value)[1] = col+1;
- INTEGER(value)[2] = dpptr(dd)->numrows;
- INTEGER(value)[3] = dpptr(dd)->numcols;
- }
- else if (streql(what, "mgp")) {
- value = allocVector(REALSXP, 3);
- REAL(value)[0] = dpptr(dd)->mgp[0];
- REAL(value)[1] = dpptr(dd)->mgp[1];
- REAL(value)[2] = dpptr(dd)->mgp[2];
- }
- else if (streql(what, "mkh")) {
- /* Unused in R, but settable */
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->mkh;
- }
- else if (streql(what, "new")) {
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = dpptr(dd)->new;
- }
- else if (streql(what, "oma")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->oma[0];
- REAL(value)[1] = dpptr(dd)->oma[1];
- REAL(value)[2] = dpptr(dd)->oma[2];
- REAL(value)[3] = dpptr(dd)->oma[3];
- }
- else if (streql(what, "omd")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->omd[0];
- REAL(value)[1] = dpptr(dd)->omd[1];
- REAL(value)[2] = dpptr(dd)->omd[2];
- REAL(value)[3] = dpptr(dd)->omd[3];
- }
- else if (streql(what, "omi")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->omi[0];
- REAL(value)[1] = dpptr(dd)->omi[1];
- REAL(value)[2] = dpptr(dd)->omi[2];
- REAL(value)[3] = dpptr(dd)->omi[3];
- }
- else if (streql(what, "page")) {
- /* This calculation mimics the decision-making in GNewPlot()
- * in graphics.c SO it MUST be kept in synch with the logic there
- */
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = 0;
- if (dpptr(dd)->new) {
- if (!dpptr(dd)->state)
- LOGICAL(value)[0] = 1;
- } else {
- if (dpptr(dd)->currentFigure + 1 > dpptr(dd)->lastFigure)
- LOGICAL(value)[0] = 1;
- }
- }
- else if (streql(what, "pch")) {
- int val = dpptr(dd)->pch;
- /* we need to be careful that par("pch") is converted back
- to the same value */
- if (known_to_be_latin1 && val <= -32 && val >= -255) val = -val;
- if(val >= ' ' && val <= (mbcslocale ? 127 : 255)) {
- char buf[2];
- buf[0] = (char) val;
- buf[1] = '\0';
- value = mkString(buf);
- } else {
- /* Could return as UTF-8 string */
- value = ScalarInteger(val);
- }
- }
- else if (streql(what, "pin")) {
- value = allocVector(REALSXP, 2);
- REAL(value)[0] = dpptr(dd)->pin[0];
- REAL(value)[1] = dpptr(dd)->pin[1];
- }
- else if (streql(what, "plt")) {
- value = allocVector(REALSXP, 4);
- REAL(value)[0] = dpptr(dd)->plt[0];
- REAL(value)[1] = dpptr(dd)->plt[1];
- REAL(value)[2] = dpptr(dd)->plt[2];
- REAL(value)[3] = dpptr(dd)->plt[3];
- }
- else if (streql(what, "ps")) {
- value = allocVector(INTSXP, 1);
- /* was reporting unscaled prior to 2.7.0 */
- INTEGER(value)[0] = (int)(dpptr(dd)->ps * dpptr(dd)->scale);
- }
- else if (streql(what, "pty")) {
- char buf[2];
- buf[0] = dpptr(dd)->pty;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "smo")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->smo;
- }
- else if (streql(what, "srt")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->srt;
- }
- else if (streql(what, "tck")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->tck;
- }
- else if (streql(what, "tcl")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dpptr(dd)->tcl;
- }
- else if (streql(what, "usr")) {
- value = allocVector(REALSXP, 4);
- if (gpptr(dd)->xlog) {
- REAL(value)[0] = gpptr(dd)->logusr[0];
- REAL(value)[1] = gpptr(dd)->logusr[1];
- }
- else {
- REAL(value)[0] = dpptr(dd)->usr[0];
- REAL(value)[1] = dpptr(dd)->usr[1];
- }
- if (gpptr(dd)->ylog) {
- REAL(value)[2] = gpptr(dd)->logusr[2];
- REAL(value)[3] = gpptr(dd)->logusr[3];
- }
- else {
- REAL(value)[2] = dpptr(dd)->usr[2];
- REAL(value)[3] = dpptr(dd)->usr[3];
- }
- }
- else if (streql(what, "xaxp")) {
- value = allocVector(REALSXP, 3);
- REAL(value)[0] = dpptr(dd)->xaxp[0];
- REAL(value)[1] = dpptr(dd)->xaxp[1];
- REAL(value)[2] = dpptr(dd)->xaxp[2];
- }
- else if (streql(what, "xaxs")) {
- char buf[2];
- buf[0] = dpptr(dd)->xaxs;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "xaxt")) {
- char buf[2];
- buf[0] = dpptr(dd)->xaxt;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "xlog")) {
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = dpptr(dd)->xlog;
- }
- else if (streql(what, "xpd")) {
- value = allocVector(LGLSXP, 1);
- if (dpptr(dd)->xpd == 2)
- LOGICAL(value)[0] = NA_LOGICAL;
- else
- LOGICAL(value)[0] = dpptr(dd)->xpd;
- }
- else if (streql(what, "yaxp")) {
- value = allocVector(REALSXP, 3);
- REAL(value)[0] = dpptr(dd)->yaxp[0];
- REAL(value)[1] = dpptr(dd)->yaxp[1];
- REAL(value)[2] = dpptr(dd)->yaxp[2];
- }
- else if (streql(what, "yaxs")) {
- char buf[2];
- buf[0] = dpptr(dd)->yaxs;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "yaxt")) {
- char buf[2];
- buf[0] = dpptr(dd)->yaxt;
- buf[1] = '\0';
- value = mkString(buf);
- }
- else if (streql(what, "ylbias")) {
- value = allocVector(REALSXP, 1);
- REAL(value)[0] = dd->dev->yLineBias;
- }
- else if (streql(what, "ylog")) {
- value = allocVector(LGLSXP, 1);
- LOGICAL(value)[0] = dpptr(dd)->ylog;
- }
- else if (ParCode(what) == -2) {
- warning(_("graphical parameter \"%s\" is obsolete"), what);
- value = R_NilValue;
- }
- else {
- warning(_("\"%s\" is not a graphical parameter"), what);
- value = R_NilValue;
- }
- return value;
-}
-
-SEXP C_par(SEXP call, SEXP op, SEXP args, SEXP rho)
-{
- SEXP value;
- SEXP originalArgs = args;
- pGEDevDesc dd;
- int new_spec, nargs;
-
- args = CDR(args);
-
- dd = GEcurrentDevice();
- new_spec = 0;
- args = CAR(args);
- nargs = length(args);
- if (isNewList(args)) {
- SEXP oldnames, newnames, tag, val;
- int i;
- PROTECT(newnames = allocVector(STRSXP, nargs));
- PROTECT(value = allocVector(VECSXP, nargs));
- oldnames = getAttrib(args, R_NamesSymbol);
- for (i = 0 ; i < nargs ; i++) {
- if (oldnames != R_NilValue)
- tag = STRING_ELT(oldnames, i);
- else
- tag = R_NilValue;
- val = VECTOR_ELT(args, i);
- /* tags are all ASCII */
- if (tag != R_NilValue && CHAR(tag)[0]) {
- new_spec = 1;
- SET_VECTOR_ELT(value, i, Query(CHAR(tag), dd));
- SET_STRING_ELT(newnames, i, tag);
- Specify(CHAR(tag), val, dd);
- }
- else if (isString(val) && length(val) > 0) {
- tag = STRING_ELT(val, 0);
- if (tag != R_NilValue && CHAR(tag)[0]) {
- SET_VECTOR_ELT(value, i, Query(CHAR(tag), dd));
- SET_STRING_ELT(newnames, i, tag);
- }
- }
- else {
- SET_VECTOR_ELT(value, i, R_NilValue);
- SET_STRING_ELT(newnames, i, R_BlankString);
- }
- }
- setAttrib(value, R_NamesSymbol, newnames);
- }
- else {
- error(_("invalid argument passed to par()"));
- return R_NilValue/* -Wall */;
- }
- /* should really only do this if specifying new pars ? yes! [MM] */
-
- if (new_spec && GRecording(call, dd))
- GErecordGraphicOperation(op, originalArgs, dd);
-
- UNPROTECT(2);
- return value;
-}
-
-/*
- * Layout was written by Paul Murrell during 1997-1998 as a partial
- * implementation of ideas in his PhD thesis. The orginal was
- * written in common lisp provides rather more general capabilities.
- *
- * layout(
- * num.rows,
- * num.cols,
- * mat,
- * num.figures,
- * col.widths,
- * row.heights,
- * cm.widths,
- * cm.heights,
- * respect,
- * respect.mat
- * )
- */
-
-SEXP C_layout(SEXP args)
-{
- int i, j, nrow, ncol, ncmrow, ncmcol;
- pGEDevDesc dd;
-
- args = CDR(args);
-
- dd = GEcurrentDevice();
-
- /* num.rows: */
- nrow = dpptr(dd)->numrows = gpptr(dd)->numrows =
- INTEGER(CAR(args))[0];
- if (nrow > MAX_LAYOUT_ROWS)
- error(_("too many rows in layout, limit %d"), MAX_LAYOUT_ROWS);
- args = CDR(args);
- /* num.cols: */
- ncol = dpptr(dd)->numcols = gpptr(dd)->numcols =
- INTEGER(CAR(args))[0];
- if (ncol > MAX_LAYOUT_COLS)
- error(_("too many columns in layout, limit %d"), MAX_LAYOUT_COLS);
- if (nrow * ncol > MAX_LAYOUT_CELLS)
- error(_("too many cells in layout, limit %d"), MAX_LAYOUT_CELLS);
- args = CDR(args);
- /* mat[i,j] == order[i+j*nrow] : */
- for (i = 0; i < nrow * ncol; i++)
- dpptr(dd)->order[i] = gpptr(dd)->order[i] =
- (unsigned short) INTEGER(CAR(args))[i];
- args = CDR(args);
-
- /* num.figures: */
- dpptr(dd)->currentFigure = gpptr(dd)->currentFigure =
- dpptr(dd)->lastFigure = gpptr(dd)->lastFigure =
- INTEGER(CAR(args))[0];
- args = CDR(args);
- /* col.widths: */
- for (j = 0; j < ncol; j++)
- dpptr(dd)->widths[j] = gpptr(dd)->widths[j] =
- REAL(CAR(args))[j];
- args = CDR(args);
- /* row.heights: */
- for (i = 0; i < nrow; i++)
- dpptr(dd)->heights[i] = gpptr(dd)->heights[i] =
- REAL(CAR(args))[i];
- args = CDR(args);
- /* cm.widths: */
- ncmcol = length(CAR(args));
- for (j = 0; j < ncol; j++)
- dpptr(dd)->cmWidths[j] = gpptr(dd)->cmWidths[j] = 0;
- for (j = 0; j < ncmcol; j++) {
- dpptr(dd)->cmWidths[INTEGER(CAR(args))[j] - 1]
- = gpptr(dd)->cmWidths[INTEGER(CAR(args))[j] - 1]
- = 1;
- }
- args = CDR(args);
- /* cm.heights: */
- ncmrow = length(CAR(args));
- for (i = 0; i < nrow; i++)
- dpptr(dd)->cmHeights[i] = gpptr(dd)->cmHeights[i] = 0;
- for (i = 0; i < ncmrow; i++) {
- dpptr(dd)->cmHeights[INTEGER(CAR(args))[i] - 1]
- = gpptr(dd)->cmHeights[INTEGER(CAR(args))[i]-1]
- = 1;
- }
- args = CDR(args);
- /* respect = 0 (FALSE), 1 (TRUE), or 2 (matrix) : */
- dpptr(dd)->rspct = gpptr(dd)->rspct = INTEGER(CAR(args))[0];
- args = CDR(args);
- /* respect.mat */
- for (i = 0; i < nrow * ncol; i++)
- dpptr(dd)->respect[i] = gpptr(dd)->respect[i]
- = (unsigned char)INTEGER(CAR(args))[i];
-
- /*------------------------------------------------------*/
-
- if (nrow > 2 || ncol > 2) {
- gpptr(dd)->cexbase = dpptr(dd)->cexbase = 0.66;
- gpptr(dd)->mex = dpptr(dd)->mex = 1.0;
- }
- else if (nrow == 2 && ncol == 2) {
- gpptr(dd)->cexbase = dpptr(dd)->cexbase = 0.83;
- gpptr(dd)->mex = dpptr(dd)->mex = 1.0;
- }
- else {
- gpptr(dd)->cexbase = dpptr(dd)->cexbase = 1.0;
- gpptr(dd)->mex = dpptr(dd)->mex = 1.0;
- }
-
- dpptr(dd)->defaultFigure = gpptr(dd)->defaultFigure = TRUE;
- dpptr(dd)->layout = gpptr(dd)->layout = TRUE;
-
- GReset(dd);
-
- return R_NilValue;
-}
-
-
-/* ProcessInLinePars handles inline par specifications
- in graphics functions. */
-
-void ProcessInlinePars(SEXP s, pGEDevDesc dd)
-{
- if (isList(s)) {
- while (s != R_NilValue) {
- if (isList(CAR(s)))
- ProcessInlinePars(CAR(s), dd);
- else if (TAG(s) != R_NilValue)
- Specify2(CHAR(PRINTNAME(TAG(s))), CAR(s), dd);
- s = CDR(s);
- }
- }
-}
-
-
-
-/*= Local Variables: **/
-/*= mode: C **/
-/*= kept-old-versions: 12 **/
-/*= kept-new-versions: 30 **/
-/*= End: **/
diff --git a/com.oracle.truffle.r.native/library/graphics/src/plot.c b/com.oracle.truffle.r.native/library/graphics/src/plot.c
deleted file mode 100644
index 00582a30b79f246b7afe8a99d260323ac113d77c..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/plot.c
+++ /dev/null
@@ -1,4094 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997--2014 The R Core Team
- * Copyright (C) 2002--2009 The R Foundation
- *
- * 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/
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "Defn.h"
-#include <float.h> /* for DBL_MAX */
-#include "../../grDevices/src/main_Graphics.h"
-#include "../../../gnur/R-3.1.3/src/include/Print.h"
-#include <Rmath.h> // Rexp10, fmin2, fmax2, imax2
-
-#include "graphics.h"
-
-static R_INLINE void TypeCheck(SEXP s, SEXPTYPE type)
-{
- if (TYPEOF(s) != type)
- error("invalid type passed to graphics function");
-}
-
-
-/*
- * Is element i of a colour object NA (or NULL)?
- */
-Rboolean isNAcol(SEXP col, int index, int ncol)
-{
- Rboolean result = TRUE; /* -Wall */
-
- if (isNull(col))
- result = TRUE;
- else {
- if (isLogical(col))
- result = LOGICAL(col)[index % ncol] == NA_LOGICAL;
- else if (isString(col))
- result = strcmp(CHAR(STRING_ELT(col, index % ncol)), "NA") == 0;
- else if (isInteger(col))
- result = INTEGER(col)[index % ncol] == NA_INTEGER;
- else if (isReal(col))
- result = !R_FINITE(REAL(col)[index % ncol]);
- else
- error(_("invalid color specification"));
- }
- return result;
-}
-
-
-/* P A R A M E T E R U T I L I T I E S */
-
-/*
- * Extract specified par from list of inline pars
- */
-static SEXP getInlinePar(SEXP s, char *name)
-{
- SEXP result = R_NilValue;
- int found = 0;
- if (isList(s) && !found) {
- while (s != R_NilValue) {
- if (isList(CAR(s))) {
- result = getInlinePar(CAR(s), name);
- if (result)
- found = 1;
- } else
- if (TAG(s) != R_NilValue)
- if (!strcmp(CHAR(PRINTNAME(TAG(s))), name)) {
- result = CAR(s);
- found = 1;
- }
- s = CDR(s);
- }
- }
- return result;
-}
-
-/* dflt used to be used for < 0 values in R < 2.7.0,
- now just used for NULL */
-static SEXP FixupPch(SEXP pch, int dflt)
-{
- int i, n;
- SEXP ans = R_NilValue;/* -Wall*/
-
- n = length(pch);
- if (n == 0) return ans = ScalarInteger(dflt);
-
- PROTECT(ans = allocVector(INTSXP, n));
- if (isList(pch)) {
- for (i = 0; pch != R_NilValue; pch = CDR(pch))
- INTEGER(ans)[i++] = asInteger(CAR(pch));
- }
- else if (isInteger(pch)) {
- for (i = 0; i < n; i++)
- INTEGER(ans)[i] = INTEGER(pch)[i];
- }
- else if (isReal(pch)) {
- for (i = 0; i < n; i++)
- INTEGER(ans)[i] = R_FINITE(REAL(pch)[i]) ?
- (int) REAL(pch)[i] : NA_INTEGER;
- }
- else if (isString(pch)) {
- for (i = 0; i < n; i++) {
- /* New in 2.7.0: negative values indicate Unicode points. */
- INTEGER(ans)[i] = GEstring_to_pch(STRING_ELT(pch, i));
- }
- }
- else if (isLogical(pch)) {/* NA, but not TRUE/FALSE */
- for (i = 0; i < n; i++)
- if(LOGICAL(pch)[i] == NA_LOGICAL) INTEGER(ans)[i] = NA_INTEGER;
- else error(_("only NA allowed in logical plotting symbol"));
- }
- else error(_("invalid plotting symbol"));
- UNPROTECT(1);
- return ans;
-}
-
-SEXP FixupLty(SEXP lty, int dflt)
-{
- int i, n;
- SEXP ans;
- n = length(lty);
- if (n == 0) {
- ans = ScalarInteger(dflt);
- }
- else {
- ans = allocVector(INTSXP, n);
- for (i = 0; i < n; i++)
- INTEGER(ans)[i] = GE_LTYpar(lty, i);
- }
- return ans;
-}
-
-SEXP FixupLwd(SEXP lwd, double dflt)
-{
- int i, n;
- double w;
- SEXP ans = NULL;
-
- n = length(lwd);
- if (n == 0)
- ans = ScalarReal(dflt);
- else {
- PROTECT(lwd = coerceVector(lwd, REALSXP));
- n = length(lwd);
- ans = allocVector(REALSXP, n);
- for (i = 0; i < n; i++) {
- w = REAL(lwd)[i];
- if (w < 0) w = NA_REAL;
- REAL(ans)[i] = w;
-
- }
- UNPROTECT(1);
- }
- return ans;
-}
-
-static SEXP FixupFont(SEXP font, int dflt)
-{
- int i, k, n;
- SEXP ans = R_NilValue;/* -Wall*/
- n = length(font);
- if (n == 0) {
- ans = ScalarInteger(dflt);
- }
- else if (isLogical(font)) {
- ans = allocVector(INTSXP, n);
- for (i = 0; i < n; i++) {
- k = LOGICAL(font)[i];
-#ifndef Win32
- if (k < 1 || k > 5) k = NA_INTEGER;
-#else
- if (k < 1 || k > 32) k = NA_INTEGER;
-#endif
- INTEGER(ans)[i] = k;
- }
- }
- else if (isInteger(font)) {
- ans = allocVector(INTSXP, n);
- for (i = 0; i < n; i++) {
- k = INTEGER(font)[i];
-#ifndef Win32
- if (k < 1 || k > 5) k = NA_INTEGER;
-#else
- if (k < 1 || k > 32) k = NA_INTEGER;
-#endif
- INTEGER(ans)[i] = k;
- }
- }
- else if (isReal(font)) {
- ans = allocVector(INTSXP, n);
- for (i = 0; i < n; i++) {
- k = (int) REAL(font)[i];
-#ifndef Win32
- if (k < 1 || k > 5) k = NA_INTEGER;
-#else
- if (k < 1 || k > 32) k = NA_INTEGER;
-#endif
- INTEGER(ans)[i] = k;
- }
- }
- else error(_("invalid font specification"));
- return ans;
-}
-
-SEXP FixupCol(SEXP col, unsigned int dflt)
-{
- int i, n;
- SEXP ans;
- unsigned int bg = dpptr(GEcurrentDevice())->bg; /* col = 0 */
-
- n = length(col);
- if (n == 0) {
- PROTECT(ans = ScalarInteger(dflt));
- } else {
- ans = PROTECT(allocVector(INTSXP, n));
- if (isList(col))
- for (i = 0; i < n; i++) {
- INTEGER(ans)[i] = RGBpar3(CAR(col), 0, bg);
- col = CDR(col);
- }
- else
- for (i = 0; i < n; i++)
- INTEGER(ans)[i] = RGBpar3(col, i, bg);
- }
- UNPROTECT(1);
- return ans;
-}
-
-static SEXP FixupCex(SEXP cex, double dflt)
-{
- SEXP ans;
- int i, n;
- n = length(cex);
- if (n == 0) {
- ans = allocVector(REALSXP, 1);
- if (R_FINITE(dflt) && dflt > 0)
- REAL(ans)[0] = dflt;
- else
- REAL(ans)[0] = NA_REAL;
- }
- else {
- double c;
- ans = allocVector(REALSXP, n);
- if (isReal(cex))
- for (i = 0; i < n; i++) {
- c = REAL(cex)[i];
- if (R_FINITE(c) && c > 0)
- REAL(ans)[i] = c;
- else
- REAL(ans)[i] = NA_REAL;
- }
- else if (isInteger(cex) || isLogical(cex))
- for (i = 0; i < n; i++) {
- c = INTEGER(cex)[i];
- if (c == NA_INTEGER || c <= 0)
- c = NA_REAL;
- REAL(ans)[i] = c;
- }
- else
- error(_("invalid '%s' value"), "cex");
- }
- return ans;
-}
-
-SEXP FixupVFont(SEXP vfont) {
- SEXP ans = R_NilValue;
- if (!isNull(vfont)) {
- SEXP vf;
- int typeface, fontindex;
- int minindex, maxindex=0;/* -Wall*/
- int i;
- PROTECT(vf = coerceVector(vfont, INTSXP));
- if (length(vf) != 2)
- error(_("invalid '%s' value"), "vfont");
- typeface = INTEGER(vf)[0];
- if (typeface < 1 || typeface > 8)
- error(_("invalid 'vfont' value [typeface %d]"), typeface);
- /* For each of the typefaces {1..8}, there are several fontindices
- available; how many depends on the typeface.
- The possible combinations are "given" in ./g_fontdb.c
- and also listed in help(Hershey).
- */
- minindex = 1;
- switch (typeface) {
- case 1: /* serif */
- maxindex = 7; break;
- case 2: /* sans serif */
- case 7: /* serif symbol */
- maxindex = 4; break;
- case 3: /* script */
- maxindex = 3; break;
- case 4: /* gothic english */
- case 5: /* gothic german */
- case 6: /* gothic italian */
- maxindex = 1; break;
- case 8: /* sans serif symbol */
- maxindex = 2;
- }
- fontindex = INTEGER(vf)[1];
- if (fontindex < minindex || fontindex > maxindex)
- error(_("invalid 'vfont' value [typeface = %d, fontindex = %d]"),
- typeface, fontindex);
- ans = allocVector(INTSXP, 2);
- for (i = 0; i < 2; i++) INTEGER(ans)[i] = INTEGER(vf)[i];
- UNPROTECT(1);
- }
- return ans;
-}
-
-
-/* GetTextArg() : extract and possibly set text arguments
- * ("label", col=, cex=, font=)
- *
- * Main purpose: Treat things like title(main = list("This Title", font= 4))
- *
- * Called from Title() [only, currently]
- */
-static void
-GetTextArg(SEXP spec, SEXP *ptxt, rcolor *pcol, double *pcex, int *pfont)
-{
- int i, n, font, colspecd;
- rcolor col;
- double cex;
- SEXP txt, nms;
- PROTECT_INDEX pi;
-
- txt = R_NilValue;
- cex = NA_REAL;
- col = R_TRANWHITE;
- colspecd = 0;
- font = NA_INTEGER;
- /* It doesn't look as if this protection is needed */
- PROTECT_WITH_INDEX(txt, &pi);
-
- switch (TYPEOF(spec)) {
- case LANGSXP:
- case SYMSXP:
- REPROTECT(txt = coerceVector(spec, EXPRSXP), pi);
- break;
- case VECSXP:
- if (length(spec) == 0) {
- *ptxt = R_NilValue;
- }
- else {
- nms = getAttrib(spec, R_NamesSymbol);
- if (nms == R_NilValue){ /* PR#1939 */
- txt = VECTOR_ELT(spec, 0);
- if (TYPEOF(txt) == LANGSXP || TYPEOF(txt) == SYMSXP )
- REPROTECT(txt = coerceVector(txt, EXPRSXP), pi);
- else if (!isExpression(txt))
- REPROTECT(txt = coerceVector(txt, STRSXP), pi);
- } else {
- n = length(nms);
- for (i = 0; i < n; i++) {
- if (!strcmp(CHAR(STRING_ELT(nms, i)), "cex")) {
- cex = asReal(VECTOR_ELT(spec, i));
- }
- else if (!strcmp(CHAR(STRING_ELT(nms, i)), "col")) {
- SEXP colsxp = VECTOR_ELT(spec, i);
- if (!isNAcol(colsxp, 0, LENGTH(colsxp))) {
- col = asInteger(FixupCol(colsxp, R_TRANWHITE));
- colspecd = 1;
- }
- }
- else if (!strcmp(CHAR(STRING_ELT(nms, i)), "font")) {
- font = asInteger(FixupFont(VECTOR_ELT(spec, i), NA_INTEGER));
- }
- else if (!strcmp(CHAR(STRING_ELT(nms, i)), "")) {
- txt = VECTOR_ELT(spec, i);
- if (TYPEOF(txt) == LANGSXP || TYPEOF(txt) == SYMSXP)
- REPROTECT(txt = coerceVector(txt, EXPRSXP), pi);
- else if (!isExpression(txt))
- REPROTECT(txt = coerceVector(txt, STRSXP), pi);
- }
- else error(_("invalid graphics parameter"));
- }
- }
- }
- break;
- case STRSXP:
- case EXPRSXP:
- txt = spec;
- break;
- default:
- REPROTECT(txt = coerceVector(spec, STRSXP), pi);
- break;
- }
- UNPROTECT(1);
- if (txt != R_NilValue) {
- *ptxt = txt;
- if (R_FINITE(cex)) *pcex = cex;
- if (colspecd) *pcol = col;
- if (font != NA_INTEGER) *pfont = font;
- }
-}/* GetTextArg */
-
-
- /* GRAPHICS FUNCTION ENTRY POINTS */
-
-SEXP C_plot_new(SEXP call, SEXP op, SEXP args, SEXP rho)
-{
- /* plot.new() - create a new plot "frame" */
-
- pGEDevDesc dd;
-
- dd = GEcurrentDevice();
- /*
- * If user is prompted before new page, user has opportunity
- * to kill current device. GNewPlot returns (potentially new)
- * current device.
- */
- dd = GNewPlot(GRecording(call, dd));
-
- dpptr(dd)->xlog = gpptr(dd)->xlog = FALSE;
- dpptr(dd)->ylog = gpptr(dd)->ylog = FALSE;
-
- GScale(0.0, 1.0, 1, dd);
- GScale(0.0, 1.0, 2, dd);
- GMapWin2Fig(dd);
- GSetState(1, dd);
-
- if (GRecording(call, dd))
- GErecordGraphicOperation(op, args, dd);
- return R_NilValue;
-}
-
-
-/*
- * SYNOPSIS
- *
- * plot.window(xlim, ylim, log="", asp=NA)
- *
- * DESCRIPTION
- *
- * This function sets up the world coordinates for a graphics
- * window. Note that if asp is a finite positive value then
- * the window is set up so that one data unit in the y direction
- * is equal in length to one data unit in the x direction divided
- * by asp.
- *
- * The special case asp == 1 produces plots where distances
- * between points are represented accurately on screen.
- *
- * NOTE
- *
- * The use of asp can have weird effects when axis is an
- * interpreted function. It has to be internal so that the
- * full computation is captured in the display list.
- */
-
-SEXP C_plot_window(SEXP args)
-{
- SEXP xlim, ylim, logarg;
- double asp, xmin, xmax, ymin, ymax;
- Rboolean logscale;
- const char *p;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- if (length(args) < 3)
- error(_("at least 3 arguments required"));
-
- xlim = CAR(args);
- if (!isNumeric(xlim) || LENGTH(xlim) != 2)
- error(_("invalid '%s' value"), "xlim");
- args = CDR(args);
-
- ylim = CAR(args);
- if (!isNumeric(ylim) || LENGTH(ylim) != 2)
- error(_("invalid '%s' value"), "ylim");
- args = CDR(args);
-
- logscale = FALSE;
- logarg = CAR(args);
- if (!isString(logarg))
- error(_("\"log=\" specification must be character"));
- p = CHAR(STRING_ELT(logarg, 0));
- while (*p) {
- switch (*p) {
- case 'x':
- dpptr(dd)->xlog = gpptr(dd)->xlog = logscale = TRUE;
- break;
- case 'y':
- dpptr(dd)->ylog = gpptr(dd)->ylog = logscale = TRUE;
- break;
- default:
- error(_("invalid \"log=%s\" specification"), p);
- }
- p++;
- }
- args = CDR(args);
-
- asp = (logscale) ? NA_REAL : asReal(CAR(args));;
- args = CDR(args);
-
- /* This reads [xy]axs and lab, used in GScale */
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- if (isInteger(xlim)) {
- if (INTEGER(xlim)[0] == NA_INTEGER || INTEGER(xlim)[1] == NA_INTEGER)
- error(_("NAs not allowed in 'xlim'"));
- xmin = INTEGER(xlim)[0];
- xmax = INTEGER(xlim)[1];
- }
- else {
- if (!R_FINITE(REAL(xlim)[0]) || !R_FINITE(REAL(xlim)[1]))
- error(_("need finite 'xlim' values"));
- xmin = REAL(xlim)[0];
- xmax = REAL(xlim)[1];
- }
- if (isInteger(ylim)) {
- if (INTEGER(ylim)[0] == NA_INTEGER || INTEGER(ylim)[1] == NA_INTEGER)
- error(_("NAs not allowed in 'ylim'"));
- ymin = INTEGER(ylim)[0];
- ymax = INTEGER(ylim)[1];
- }
- else {
- if (!R_FINITE(REAL(ylim)[0]) || !R_FINITE(REAL(ylim)[1]))
- error(_("need finite 'ylim' values"));
- ymin = REAL(ylim)[0];
- ymax = REAL(ylim)[1];
- }
- if ((dpptr(dd)->xlog && (xmin < 0 || xmax < 0)) ||
- (dpptr(dd)->ylog && (ymin < 0 || ymax < 0)))
- error(_("Logarithmic axis must have positive limits"));
-
- if (R_FINITE(asp) && asp > 0) {
- double pin1, pin2, scale, xdelta, ydelta, xscale, yscale, xadd, yadd;
- pin1 = GConvertXUnits(1.0, NPC, INCHES, dd);
- pin2 = GConvertYUnits(1.0, NPC, INCHES, dd);
- xdelta = fabs(xmax - xmin) / asp;
- ydelta = fabs(ymax - ymin);
- if(xdelta == 0.0 && ydelta == 0.0) {
- /* We really do mean zero: small non-zero values work.
- Mimic the behaviour of GScale for the x axis. */
- xadd = yadd = ((xmin == 0.0) ? 1 : 0.4) * asp;
- xadd *= asp;
- } else {
- xscale = pin1 / xdelta;
- yscale = pin2 / ydelta;
- scale = (xscale < yscale) ? xscale : yscale;
- xadd = .5 * (pin1 / scale - xdelta) * asp;
- yadd = .5 * (pin2 / scale - ydelta);
- }
- if(xmax < xmin) xadd *= -1;
- if(ymax < ymin) yadd *= -1;
- GScale(xmin - xadd, xmax + xadd, 1, dd);
- GScale(ymin - yadd, ymax + yadd, 2, dd);
- }
- else { /* asp <= 0 or not finite -- includes logscale ! */
- GScale(xmin, xmax, 1, dd);
- GScale(ymin, ymax, 2, dd);
- }
- /* GScale set the [xy]axp parameters */
- GMapWin2Fig(dd);
- GRestorePars(dd);
- /* This has now clobbered the Rf_ggptr settings for coord system */
- return R_NilValue;
-}
-
-static void GetAxisLimits(double left, double right, Rboolean logflag, double *low, double *high)
-{
-/* Called from Axis() such as
- * GetAxisLimits(gpptr(dd)->usr[0], gpptr(dd)->usr[1], &low, &high)
- *
- * Computes *low < left, right < *high (even if left=right)
- */
- double eps;
- if (logflag) {
- left = log(left);
- right = log(right);
- }
- if (left > right) {/* swap */
- eps = left; left = right; right = eps;
- }
- eps = right - left;
- if (eps == 0.)
- eps = 0.5 * FLT_EPSILON;
- else
- eps *= FLT_EPSILON;
- *low = left - eps;
- *high = right + eps;
-
- if (logflag) {
- *low = exp(*low);
- *high = exp(*high);
- }
-}
-
-
-/* axis(side, at, labels, ...) */
-
-SEXP labelformat(SEXP labels)
-{
- /* format(labels): i.e. from numbers to strings */
- SEXP ans = R_NilValue;/* -Wall*/
- int i, n, w, d, e, wi, di, ei;
- const char *strp;
- n = length(labels);
- R_print.digits = 7;/* maximally 7 digits -- ``burnt in'';
- S-PLUS <= 5.x has about 6
- (but really uses single precision..) */
- switch(TYPEOF(labels)) {
- case LGLSXP:
- PROTECT(ans = allocVector(STRSXP, n));
- for (i = 0; i < n; i++) {
- strp = EncodeLogical(LOGICAL(labels)[i], 0);
- SET_STRING_ELT(ans, i, mkChar(strp));
- }
- UNPROTECT(1);
- break;
- case INTSXP:
- PROTECT(ans = allocVector(STRSXP, n));
- for (i = 0; i < n; i++) {
- strp = EncodeInteger(INTEGER(labels)[i], 0);
- SET_STRING_ELT(ans, i, mkChar(strp));
- }
- UNPROTECT(1);
- break;
- case REALSXP:
- formatReal(REAL(labels), n, &w, &d, &e, 0);
- PROTECT(ans = allocVector(STRSXP, n));
- for (i = 0; i < n; i++) {
- strp = EncodeReal(REAL(labels)[i], 0, d, e, OutDec);
- SET_STRING_ELT(ans, i, mkChar(strp));
- }
- UNPROTECT(1);
- break;
- case CPLXSXP:
- formatComplex(COMPLEX(labels), n, &w, &d, &e, &wi, &di, &ei, 0);
- PROTECT(ans = allocVector(STRSXP, n));
- for (i = 0; i < n; i++) {
- strp = EncodeComplex(COMPLEX(labels)[i], 0, d, e, 0, di, ei,
- OutDec);
- SET_STRING_ELT(ans, i, mkChar(strp));
- }
- UNPROTECT(1);
- break;
- case STRSXP:
- PROTECT(ans = allocVector(STRSXP, n));
- for (i = 0; i < n; i++) {
- SET_STRING_ELT(ans, i, STRING_ELT(labels, i));
- }
- UNPROTECT(1);
- break;
- default:
- error(_("invalid type for axis labels"));
- }
- return ans;
-}
-
-
-static double ComputePAdjValue(double padj, int side, int las)
-{
- if (!R_FINITE(padj)) {
- switch(las) {
- case 0:/* parallel to axis */
- padj = 0.0; break;
- case 1:/* horizontal */
- switch(side) {
- case 1:
- case 3: padj = 0.0; break;
- case 2:
- case 4: padj = 0.5; break;
- }
- break;
- case 2:/* perpendicular to axis */
- padj = 0.5; break;
- case 3:/* vertical */
- switch(side) {
- case 1:
- case 3: padj = 0.5; break;
- case 2:
- case 4: padj = 0.0; break;
- }
- break;
- }
- }
- return padj;
-}
-
-static void getxlimits(double *x, pGEDevDesc dd) {
- /*
- * xpd = 0 means clip to current plot region
- * xpd = 1 means clip to current figure region
- * xpd = 2 means clip to device region
- */
- switch (gpptr(dd)->xpd) {
- case 0:
- x[0] = gpptr(dd)->usr[0];
- x[1] = gpptr(dd)->usr[1];
- break;
- case 1:
- x[0] = GConvertX(0, NFC, USER, dd);
- x[1] = GConvertX(1, NFC, USER, dd);
- break;
- case 2:
- x[0] = GConvertX(0, NDC, USER, dd);
- x[1] = GConvertX(1, NDC, USER, dd);
- break;
- }
-}
-
-static void getylimits(double *y, pGEDevDesc dd) {
- switch (gpptr(dd)->xpd) {
- case 0:
- y[0] = gpptr(dd)->usr[2];
- y[1] = gpptr(dd)->usr[3];
- break;
- case 1:
- y[0] = GConvertY(0, NFC, USER, dd);
- y[1] = GConvertY(1, NFC, USER, dd);
- break;
- case 2:
- y[0] = GConvertY(0, NDC, USER, dd);
- y[1] = GConvertY(1, NDC, USER, dd);
- break;
- }
-}
-
-SEXP C_axis(SEXP args)
-{
- /* axis(side, at, labels, tick, line, pos,
- outer, font, lty, lwd, lwd.ticks, col, col.ticks,
- hadj, padj, ...)
- */
-
- SEXP at, lab, padj, label;
- int font, lty, npadj;
- rcolor col, colticks;
- int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
- int istart, iend, incr;
- Rboolean dolabels, doticks, logflag = FALSE;
- Rboolean create_at;
- double x, y, temp, tnew, tlast;
- double axp[3], usr[2], limits[2];
- double gap, labw, low, high, line, pos, lwd, lwdticks, hadj;
- double axis_base, axis_tick, axis_lab, axis_low, axis_high;
-
- pGEDevDesc dd = GEcurrentDevice();
-
- /* Arity Check */
- /* This is a builtin function, so it should always have */
- /* the correct arity, but it doesn't hurt to be defensive. */
-
- args = CDR(args);
- if (length(args) < 15)
- error(_("too few arguments"));
- GCheckState(dd);
-
- PrintDefaults(); /* prepare for labelformat */
-
- /* Required argument: "side" */
- /* Which side of the plot the axis is to appear on. */
- /* side = 1 | 2 | 3 | 4. */
-
- side = asInteger(CAR(args));
- if (side < 1 || side > 4)
- error(_("invalid axis number %d"), side);
- args = CDR(args);
-
- /* Required argument: "at" */
- /* This gives the tick-label locations. */
- /* Note that these are coerced to the correct type below. */
-
- at = CAR(args); args = CDR(args);
-
- /* Required argument: "labels" */
- /* Labels can be a logical, indicating whether or not */
- /* to label the axis; or it can be a vector of character */
- /* strings or expressions which give the labels explicitly. */
- /* The expressions are used to set mathematical labelling. */
-
- dolabels = TRUE;
- lab = CAR(args);
- if (isLogical(lab) && length(lab) > 0) {
- i = asLogical(lab);
- if (i == 0 || i == NA_LOGICAL)
- dolabels = FALSE;
- PROTECT(lab = R_NilValue);
- } else if (TYPEOF(lab) == LANGSXP || TYPEOF(lab) == SYMSXP) {
- PROTECT(lab = coerceVector(lab, EXPRSXP));
- } else if (isExpression(lab)) {
- PROTECT(lab);
- } else {
- PROTECT(lab = coerceVector(lab, STRSXP));
- }
- args = CDR(args);
-
- /* Required argument: "tick" */
- /* This indicates whether or not ticks and the axis line */
- /* should be plotted: TRUE => show, FALSE => don't show. */
-
- doticks = asLogical(CAR(args));
- doticks = (doticks == NA_LOGICAL) ? TRUE : (Rboolean) doticks;
- args = CDR(args);
-
- /* Optional argument: "line" */
-
- /* Specifies an offset outward from the plot for the axis.
- * The values in the par value "mgp" are interpreted
- * relative to this value. */
- line = asReal(CAR(args));
- /* defer processing until after in-line pars */
- args = CDR(args);
-
- /* Optional argument: "pos" */
- /* Specifies a user coordinate at which the axis should be drawn. */
- /* This overrides the value of "line". Again the "mgp" par values */
- /* are interpreted relative to this value. */
-
- pos = asReal(CAR(args));
- /* defer processing until after in-line pars */
- args = CDR(args);
-
- /* Optional argument: "outer" */
- /* Should the axis be drawn in the outer margin. */
- /* This only affects the computation of axis_base. */
-
- outer = asLogical(CAR(args));
- if (outer == NA_LOGICAL || outer == 0)
- outer = NPC;
- else
- outer = NIC;
- args = CDR(args);
-
- /* Optional argument: "font" */
- font = asInteger(FixupFont(CAR(args), NA_INTEGER));
- args = CDR(args);
-
- /* Optional argument: "lty" */
- lty = asInteger(FixupLty(CAR(args), 0));
- args = CDR(args);
-
- /* Optional argument: "lwd" */
- lwd = asReal(FixupLwd(CAR(args), 1));
- args = CDR(args);
- lwdticks = asReal(FixupLwd(CAR(args), 1));
- args = CDR(args);
-
- /* Optional argument: "col" */
- col = asInteger(FixupCol(CAR(args), gpptr(dd)->fg));
- args = CDR(args);
- colticks = asInteger(FixupCol(CAR(args), col));
- args = CDR(args);
-
- /* Optional argument: "hadj" */
- if (length(CAR(args)) != 1)
- error(_("'hadj' must be of length one"));
- hadj = asReal(CAR(args));
- args = CDR(args);
-
- /* Optional argument: "padj" */
- PROTECT(padj = coerceVector(CAR(args), REALSXP));
- npadj = length(padj);
- if (npadj <= 0) error(_("zero-length '%s' specified"), "padj");
-
- /* Now we process all the remaining inline par values:
- we need to do it now as x/yaxp are retrieved next.
- That will set gpptr, so we update that first - do_plotwindow
- clobbered the gpptr settings. */
- GSavePars(dd);
- gpptr(dd)->xaxp[0] = dpptr(dd)->xaxp[0];
- gpptr(dd)->xaxp[1] = dpptr(dd)->xaxp[1];
- gpptr(dd)->xaxp[2] = dpptr(dd)->xaxp[2];
- gpptr(dd)->yaxp[0] = dpptr(dd)->yaxp[0];
- gpptr(dd)->yaxp[1] = dpptr(dd)->yaxp[1];
- gpptr(dd)->yaxp[2] = dpptr(dd)->yaxp[2];
- ProcessInlinePars(args, dd);
-
- /* Retrieve relevant "par" values. */
-
- switch(side) {
- case 1:
- case 3:
- axp[0] = gpptr(dd)->xaxp[0];
- axp[1] = gpptr(dd)->xaxp[1];
- axp[2] = gpptr(dd)->xaxp[2];
- usr[0] = dpptr(dd)->usr[0];
- usr[1] = dpptr(dd)->usr[1];
- logflag = dpptr(dd)->xlog;
- nint = dpptr(dd)->lab[0];
- break;
- case 2:
- case 4:
- axp[0] = gpptr(dd)->yaxp[0];
- axp[1] = gpptr(dd)->yaxp[1];
- axp[2] = gpptr(dd)->yaxp[2];
- usr[0] = dpptr(dd)->usr[2];
- usr[1] = dpptr(dd)->usr[3];
- logflag = dpptr(dd)->ylog;
- nint = dpptr(dd)->lab[1];
- break;
- }
-
- /* Deferred processing */
- if (!R_FINITE(line)) {
- /* Except that here mgp values are not relative to themselves */
- line = gpptr(dd)->mgp[2];
- lineoff = (int) line;
- }
- if (!R_FINITE(pos)) pos = NA_REAL; else lineoff = 0;
-
- /* Determine the tickmark positions. Note that these may fall */
- /* outside the plot window. We will clip them in the code below. */
-
- create_at = isNull(at);
- if (create_at) {
- PROTECT(at = CreateAtVector(axp, usr, nint, logflag));
- }
- else {
- if (isReal(at)) PROTECT(at = duplicate(at));
- else PROTECT(at = coerceVector(at, REALSXP));
- }
- n = length(at);
-
- /* Check/setup the tick labels. This can mean using user-specified */
- /* labels, or encoding the "at" positions as strings. */
-
- if (dolabels) {
- if (length(lab) == 0)
- lab = labelformat(at);
- else {
- if (create_at)
- error(_("'labels' is supplied and not 'at'"));
- if (!isExpression(lab)) lab = labelformat(lab);
- }
- if (length(at) != length(lab))
- error(_("'at' and 'labels' lengths differ, %d != %d"),
- length(at), length(lab));
- }
- PROTECT(lab);
-
- /* Check there are no NA, Inf or -Inf values for tick positions. */
- /* The code here is long-winded. Couldn't we just inline things */
- /* below. Hmmm - we need the min and max of the finite values ... */
-
- ind = (int *) R_alloc(n, sizeof(int));
- for(i = 0; i < n; i++) ind[i] = i;
- rsort_with_index(REAL(at), ind, n);
- ntmp = 0;
- for(i = 0; i < n; i++) {
- if(R_FINITE(REAL(at)[i])) ntmp = i+1;
- }
- if (n > 0 && ntmp == 0)
- error(_("no locations are finite"));
- n = ntmp;
-
- /* Ok, all systems are "GO". Let's get to it. */
-
- /* At this point we know the value of "xaxt" and "yaxt",
- * so we test to see whether the relevant one is "n".
- * If it is, we just bail out at this point. */
-
- if ((n == 0) ||
- ((side == 1 || side == 3) && gpptr(dd)->xaxt == 'n') ||
- ((side == 2 || side == 4) && gpptr(dd)->yaxt == 'n')) {
- GRestorePars(dd);
- UNPROTECT(4);
- return R_NilValue;
- }
-
-
- gpptr(dd)->lty = lty;
- gpptr(dd)->lwd = lwd;
- gpptr(dd)->adj = R_FINITE(hadj) ? hadj : 0.5;
- gpptr(dd)->font = (font == NA_INTEGER)? gpptr(dd)->fontaxis : font;
- gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cexaxis;
-
- /* Draw the axis */
- GMode(1, dd);
- switch (side) {
- case 1: /*--- x-axis -- horizontal --- */
- case 3:
- /* First set the clipping limits */
- getxlimits(limits, dd);
- /* Now override par("xpd") and force clipping to device region. */
- gpptr(dd)->xpd = 2;
- GetAxisLimits(limits[0], limits[1], logflag, &low, &high);
- axis_low = GConvertX(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
- axis_high = GConvertX(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
- if (side == 1) {
- if (R_FINITE(pos))
- axis_base = GConvertY(pos, USER, NFC, dd);
- else
- axis_base = GConvertY(0.0, outer, NFC, dd)
- - GConvertYUnits(line, LINES, NFC, dd);
- if (R_FINITE(gpptr(dd)->tck)) {
- double len, xu, yu;
- if(gpptr(dd)->tck > 0.5)
- len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
- else {
- xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- xu = (fabs(xu) < fabs(yu)) ? xu : yu;
- len = GConvertYUnits(xu, INCHES, NFC, dd);
- }
- axis_tick = axis_base + len;
-
- } else
- axis_tick = axis_base +
- GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
- }
- else {
- if (R_FINITE(pos))
- axis_base = GConvertY(pos, USER, NFC, dd);
- else
- axis_base = GConvertY(1.0, outer, NFC, dd)
- + GConvertYUnits(line, LINES, NFC, dd);
- if (R_FINITE(gpptr(dd)->tck)) {
- double len, xu, yu;
- if(gpptr(dd)->tck > 0.5)
- len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
- else {
- xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- xu = (fabs(xu) < fabs(yu)) ? xu : yu;
- len = GConvertYUnits(xu, INCHES, NFC, dd);
- }
- axis_tick = axis_base - len;
- } else
- axis_tick = axis_base -
- GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
- }
- if (doticks) {
- gpptr(dd)->col = col;
- if (lwd > 0.0)
- GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
- gpptr(dd)->col = colticks;
- gpptr(dd)->lwd = lwdticks;
- if (lwdticks > 0) {
- for (i = 0; i < n; i++) {
- x = REAL(at)[i];
- if (low <= x && x <= high) {
- x = GConvertX(x, USER, NFC, dd);
- GLine(x, axis_base, x, axis_tick, NFC, dd);
- }
- }
- }
- }
- /* Tickmark labels. */
- gpptr(dd)->col = gpptr(dd)->colaxis;
- gap = GStrWidth("m", -1, NFC, dd); /* FIXUP x/y distance */
- tlast = -1.0;
- if (!R_FINITE(hadj)) {
- if (gpptr(dd)->las == 2 || gpptr(dd)->las == 3) {
- gpptr(dd)->adj = (side == 1) ? 1 : 0;
- }
- else gpptr(dd)->adj = 0.5;
- }
- if (side == 1) {
- axis_lab = - axis_base
- + GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- + GConvertY(0.0, NPC, NFC, dd);
- }
- else { /* side == 3 */
- axis_lab = axis_base
- + GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- - GConvertY(1.0, NPC, NFC, dd);
- }
- axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);
-
- /* The order of processing is important here. */
- /* We must ensure that the labels are drawn left-to-right. */
- /* The logic here is getting way too convoluted. */
- /* This needs a serious rewrite. */
-
- if (gpptr(dd)->usr[0] > gpptr(dd)->usr[1]) {
- istart = n - 1;
- iend = -1;
- incr = -1;
- }
- else {
- istart = 0;
- iend = n;
- incr = 1;
- }
- for (i = istart; i != iend; i += incr) {
- double padjval = REAL(padj)[i % npadj];
- padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
- x = REAL(at)[i];
- if (!R_FINITE(x)) continue;
- temp = GConvertX(x, USER, NFC, dd);
- if (dolabels) {
- /* Clip tick labels to user coordinates. */
- if (x > low && x < high) {
- if (isExpression(lab)) {
- GMMathText(VECTOR_ELT(lab, ind[i]), side,
- axis_lab, 0, x, gpptr(dd)->las,
- padjval, dd);
- }
- else {
- label = STRING_ELT(lab, ind[i]);
- if(label != NA_STRING) {
- const char *ss = CHAR(label);
- labw = GStrWidth(ss, 0, NFC, dd);
- tnew = temp - 0.5 * labw;
- /* Check room for perpendicular labels. */
- if (gpptr(dd)->las == 2 ||
- gpptr(dd)->las == 3 ||
- tnew - tlast >= gap) {
- GMtext(ss, getCharCE(label),
- side, axis_lab, 0, x,
- gpptr(dd)->las, padjval, dd);
- tlast = temp + 0.5 *labw;
- }
- }
- }
- }
- }
- }
- break;
-
- case 2: /*--- y-axis -- vertical --- */
- case 4:
- /* First set the clipping limits */
- getylimits(limits, dd);
- /* Now override par("xpd") and force clipping to device region. */
- gpptr(dd)->xpd = 2;
- GetAxisLimits(limits[0], limits[1], logflag, &low, &high);
- axis_low = GConvertY(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
- axis_high = GConvertY(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
- if (side == 2) {
- if (R_FINITE(pos))
- axis_base = GConvertX(pos, USER, NFC, dd);
- else
- axis_base = GConvertX(0.0, outer, NFC, dd)
- - GConvertXUnits(line, LINES, NFC, dd);
- if (R_FINITE(gpptr(dd)->tck)) {
- double len, xu, yu;
- if(gpptr(dd)->tck > 0.5)
- len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
- else {
- xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- xu = (fabs(xu) < fabs(yu)) ? xu : yu;
- len = GConvertXUnits(xu, INCHES, NFC, dd);
- }
- axis_tick = axis_base + len;
- } else
- axis_tick = axis_base +
- GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
- }
- else {
- if (R_FINITE(pos))
- axis_base = GConvertX(pos, USER, NFC, dd);
- else
- axis_base = GConvertX(1.0, outer, NFC, dd)
- + GConvertXUnits(line, LINES, NFC, dd);
- if (R_FINITE(gpptr(dd)->tck)) {
- double len, xu, yu;
- if(gpptr(dd)->tck > 0.5)
- len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
- else {
- xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
- xu = (fabs(xu) < fabs(yu)) ? xu : yu;
- len = GConvertXUnits(xu, INCHES, NFC, dd);
- }
- axis_tick = axis_base - len;
- } else
- axis_tick = axis_base -
- GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
- }
- if (doticks) {
- gpptr(dd)->col = col;
- if (lwd > 0.0)
- GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
- gpptr(dd)->col = colticks;
- gpptr(dd)->lwd = lwdticks;
- if (lwdticks > 0) {
- for (i = 0; i < n; i++) {
- y = REAL(at)[i];
- if (low <= y && y <= high) {
- y = GConvertY(y, USER, NFC, dd);
- GLine(axis_base, y, axis_tick, y, NFC, dd);
- }
- }
- }
- }
- /* Tickmark labels. */
- gpptr(dd)->col = gpptr(dd)->colaxis;
- gap = GStrWidth("m", CE_ANY, INCHES, dd);
- gap = GConvertYUnits(gap, INCHES, NFC, dd);
- tlast = -1.0;
- if (!R_FINITE(hadj)) {
- if (gpptr(dd)->las == 1 || gpptr(dd)->las == 2) {
- gpptr(dd)->adj = (side == 2) ? 1 : 0;
- }
- else gpptr(dd)->adj = 0.5;
- }
- if (side == 2) {
- axis_lab = - axis_base
- + GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- + GConvertX(0.0, NPC, NFC, dd);
- }
- else { /* side == 4 */
- axis_lab = axis_base
- + GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- - GConvertX(1.0, NPC, NFC, dd);
- }
- axis_lab = GConvertXUnits(axis_lab, NFC, LINES, dd);
-
- /* The order of processing is important here. */
- /* We must ensure that the labels are drawn left-to-right. */
- /* The logic here is getting way too convoluted. */
- /* This needs a serious rewrite. */
-
- if (gpptr(dd)->usr[2] > gpptr(dd)->usr[3]) {
- istart = n - 1;
- iend = -1;
- incr = -1;
- }
- else {
- istart = 0;
- iend = n;
- incr = 1;
- }
- for (i = istart; i != iend; i += incr) {
- double padjval = REAL(padj)[i % npadj];
- padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
- y = REAL(at)[i];
- if (!R_FINITE(y)) continue;
- temp = GConvertY(y, USER, NFC, dd);
- if (dolabels) {
- /* Clip tick labels to user coordinates. */
- if (y > low && y < high) {
- if (isExpression(lab)) {
- GMMathText(VECTOR_ELT(lab, ind[i]), side,
- axis_lab, 0, y, gpptr(dd)->las,
- padjval, dd);
- }
- else {
- label = STRING_ELT(lab, ind[i]);
- if(label != NA_STRING) {
- const char *ss = CHAR(label);
- labw = GStrWidth(ss, getCharCE(label), INCHES, dd);
- labw = GConvertYUnits(labw, INCHES, NFC, dd);
- tnew = temp - 0.5 * labw;
- /* Check room for perpendicular labels. */
- if (gpptr(dd)->las == 1 ||
- gpptr(dd)->las == 2 ||
- tnew - tlast >= gap) {
- GMtext(ss, getCharCE(label),
- side, axis_lab, 0, y,
- gpptr(dd)->las, padjval, dd);
- tlast = temp + 0.5 *labw;
- }
- }
- }
- }
- }
- }
- break;
- } /* end switch(side, ..) */
- GMode(0, dd);
- GRestorePars(dd);
- UNPROTECT(4); /* lab, at, lab, padj again */
- return at;
-} /* Axis */
-
-
-SEXP C_plotXY(SEXP args)
-{
-/* plot.xy(xy, type, pch, lty, col, bg, cex, lwd, ...)
-
- * plot points or lines of various types
- */
- SEXP sxy, sx, sy, pch, cex, col, bg, lty, lwd;
- double *x, *y, xold, yold, xx, yy, thiscex, thislwd;
- int i, n, npch, ncex, ncol, nbg, nlwd, type=0, start=0, thispch;
- rcolor thiscol, thisbg;
- const void *vmax = NULL /* -Wall */;
-
- pGEDevDesc dd = GEcurrentDevice();
-
- /* Basic Checks */
- GCheckState(dd);
- args = CDR(args);
- if (length(args) < 7)
- error(_("too few arguments"));
-
- /* Required Arguments */
-#define PLOT_XY_DEALING(subname) \
- sx = R_NilValue; /* -Wall */ \
- sy = R_NilValue; /* -Wall */ \
- sxy = CAR(args); \
- if (isNewList(sxy) && length(sxy) >= 2) { \
- TypeCheck(sx = VECTOR_ELT(sxy, 0), REALSXP); \
- TypeCheck(sy = VECTOR_ELT(sxy, 1), REALSXP); \
- } \
- else if (isList(sxy) && length(sxy) >= 2) { \
- TypeCheck(sx = CAR(sxy), REALSXP); \
- TypeCheck(sy = CADR(sxy), REALSXP); \
- } \
- else \
- error(_("invalid plotting structure")); \
- if (LENGTH(sx) != LENGTH(sy)) \
- error(_("'x' and 'y' lengths differ in %s()"), subname);\
- n = LENGTH(sx); \
- args = CDR(args)
-
- PLOT_XY_DEALING("plot.xy");
-
- if (isNull(CAR(args))) type = 'p';
- else {
- if (isString(CAR(args)) && LENGTH(CAR(args)) == 1 &&
- LENGTH(pch = STRING_ELT(CAR(args), 0)) >= 1) {
- if(LENGTH(pch) > 1)
- warning(_("plot type '%s' will be truncated to first character"),
- CHAR(pch));
- type = CHAR(pch)[0];
- }
- else error(_("invalid plot type"));
- }
- args = CDR(args);
-
- PROTECT(pch = FixupPch(CAR(args), gpptr(dd)->pch));
- npch = length(pch);
- args = CDR(args);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
- args = CDR(args);
-
- /* Default col was NA_INTEGER (0x80000000) which was interpreted
- as zero (black) or "don't draw" depending on line/rect/circle
- situation. Now we set the default to zero and don't plot at all
- if col==NA.
-
- FIXME: bg needs similar change, but that requires changes to
- the specific drivers. */
-
- PROTECT(col = FixupCol(CAR(args), 0)); args = CDR(args);
- ncol = LENGTH(col);
-
- PROTECT(bg = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- nbg = LENGTH(bg);
-
- PROTECT(cex = FixupCex(CAR(args), 1.0)); args = CDR(args);
- ncex = LENGTH(cex);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd)); args = CDR(args);
- nlwd = LENGTH(lwd);
-
- /* Miscellaneous Graphical Parameters */
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- x = REAL(sx);
- y = REAL(sy);
-
- if (INTEGER(lty)[0] != NA_INTEGER)
- gpptr(dd)->lty = INTEGER(lty)[0];
- if (R_FINITE( (thislwd = REAL(lwd)[0]) ))
- gpptr(dd)->lwd = thislwd; /* but do recycle for "p" etc */
-
- GMode(1, dd);
-
- /* Line drawing :*/
- switch(type) {
- case 'l':
- case 'o':
- /* lines and overplotted lines and points */
- gpptr(dd)->col = INTEGER(col)[0];
- xold = NA_REAL;
- yold = NA_REAL;
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- /* do the conversion now to check for non-finite */
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if ((R_FINITE(xx) && R_FINITE(yy)) &&
- !(R_FINITE(xold) && R_FINITE(yold)))
- start = i;
- else if ((R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx) && R_FINITE(yy))) {
- if (i-start > 1)
- GPolyline(i-start, x+start, y+start, USER, dd);
- }
- else if ((R_FINITE(xold) && R_FINITE(yold)) && (i == n-1))
- GPolyline(n-start, x+start, y+start, USER, dd);
- xold = xx;
- yold = yy;
- }
- break;
-
- case 'b':
- case 'c': /* broken lines (with points in between if 'b') */
- {
- double d, f;
- d = GConvertYUnits(0.5, CHARS, INCHES, dd);
- gpptr(dd)->col = INTEGER(col)[0];
- xold = NA_REAL;
- yold = NA_REAL;
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, INCHES, dd);
- if (R_FINITE(xold) && R_FINITE(yold) &&
- R_FINITE(xx) && R_FINITE(yy)) {
- // might divide by zero
- if (d < 0.5 * hypot(xx-xold, yy-yold)) {
- f = d/hypot(xx-xold, yy-yold);
- GLine(xold + f * (xx - xold),
- yold + f * (yy - yold),
- xx + f * (xold - xx),
- yy + f * (yold - yy),
- INCHES, dd);
- }
- }
- xold = xx;
- yold = yy;
- }
- }
- break;
-
- case 's': /* step function I */
- {
- double *xtemp, *ytemp;
- int n0 = 0;
- if(n <= 1000) {
- R_CheckStack2(4*n*sizeof(double));
- xtemp = (double *) alloca(2*n*sizeof(double));
- ytemp = (double *) alloca(2*n*sizeof(double));
- } else {
- vmax = vmaxget();
- xtemp = (double *) R_alloc(2*n, sizeof(double));
- ytemp = (double *) R_alloc(2*n, sizeof(double));
- }
- gpptr(dd)->col = INTEGER(col)[0];
- xold = NA_REAL;
- yold = NA_REAL;
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if ((R_FINITE(xx) && R_FINITE(yy)) &&
- (R_FINITE(xold) && R_FINITE(yold))) {
- if(n0 == 0) { xtemp[n0] = xold; ytemp[n0++] = yold; }
- xtemp[n0] = xx; ytemp[n0++] = yold;/* <-only diff 's' <-> 'S' */
- xtemp[n0] = xx; ytemp[n0++] = yy;
- } else if( (R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx) && R_FINITE(yy)) && n0 > 0) {
- GPolyline(n0, xtemp, ytemp, DEVICE, dd);
- n0 = 0;
- }
- xold = xx;
- yold = yy;
- }
- if(n0 > 0) GPolyline(n0, xtemp, ytemp, DEVICE, dd);
- if(n > 1000) vmaxset(vmax);
- }
- break;
-
- case 'S': /* step function II */
- {
- double *xtemp, *ytemp;
- int n0 = 0;
- if(n < 1000) {
- R_CheckStack2(4*n*sizeof(double));
- xtemp = (double *) alloca(2*n*sizeof(double));
- ytemp = (double *) alloca(2*n*sizeof(double));
- } else {
- vmax = vmaxget();
- xtemp = (double *) R_alloc(2*n, sizeof(double));
- ytemp = (double *) R_alloc(2*n, sizeof(double));
- }
- gpptr(dd)->col = INTEGER(col)[0];
- xold = NA_REAL;
- yold = NA_REAL;
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if ((R_FINITE(xx) && R_FINITE(yy)) &&
- (R_FINITE(xold) && R_FINITE(yold))) {
- if(n0 == 0) {xtemp[n0] = xold; ytemp[n0++] = yold;}
- xtemp[n0] = xold; ytemp[n0++] = yy;
- xtemp[n0] = xx; ytemp[n0++] = yy;
- } else if( (R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx) && R_FINITE(yy)) && n0 > 0) {
- GPolyline(n0, xtemp, ytemp, DEVICE, dd);
- n0 = 0;
- }
- xold = xx;
- yold = yy;
- }
- if(n0 > 0) GPolyline(n0, xtemp, ytemp, DEVICE, dd);
- if(n > 1000) vmaxset(vmax);
- }
- break;
-
- case 'h': /* h[istogram] (bar plot) */
- if (gpptr(dd)->ylog)
- yold = gpptr(dd)->usr[2];/* DBL_MIN fails.. why ???? */
- else
- yold = 0.0;
- yold = GConvertY(yold, USER, DEVICE, dd);
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if (R_FINITE(xx) && R_FINITE(yy)
- && !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol])) {
- gpptr(dd)->col = thiscol;
- GLine(xx, yold, xx, yy, DEVICE, dd);
- }
- }
- break;
-
- case 'p':
- case 'n': /* nothing here */
- break;
-
- default:/* OTHERWISE */
- error(_("invalid plot type '%c'"), type);
-
- } /* End {switch(type)} - for lines */
-
- /* Points : */
- if (type == 'p' || type == 'b' || type == 'o') {
- for (i = 0; i < n; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if (R_FINITE(xx) && R_FINITE(yy)) {
- if (R_FINITE( (thiscex = REAL(cex)[i % ncex]) ) &&
- (thispch = INTEGER(pch)[i % npch]) != NA_INTEGER) {
- /* FIXME: should this skip 0-sized symbols? */
- thiscol = INTEGER(col)[i % ncol];
- thisbg = INTEGER(bg)[i % nbg];
- if (!(R_TRANSPARENT(thiscol) &&
- R_TRANSPARENT(thisbg))) {
- gpptr(dd)->cex = thiscex * gpptr(dd)->cexbase;
- gpptr(dd)->col = thiscol;
- if(nlwd > 1 &&
- R_FINITE((thislwd = REAL(lwd)[i % nlwd])))
- gpptr(dd)->lwd = thislwd;
- gpptr(dd)->bg = thisbg;
- GSymbol(xx, yy, DEVICE, thispch, dd);
- }
- }
- }
- }
- }
- GMode(0, dd);
- GRestorePars(dd);
- UNPROTECT(6);
- return R_NilValue;
-} /* PlotXY */
-
-/* Checks for ... , x0, y0, x1, y1 ... */
-
-static void xypoints(SEXP args, int *n)
-{
- int k=0,/* -Wall */ kmin;
-
- if (!isNumeric(CAR(args)))
- error(_("invalid first argument"));
- SETCAR(args, coerceVector(CAR(args), REALSXP));
- k = LENGTH(CAR(args));
- *n = k; kmin = k;
- args = CDR(args);
-
- if (!isNumeric(CAR(args)))
- error(_("invalid second argument"));
- k = LENGTH(CAR(args));
- SETCAR(args, coerceVector(CAR(args), REALSXP));
- if (k > *n) *n = k;
- if (k < kmin) kmin = k;
- args = CDR(args);
-
- if (!isNumeric(CAR(args)))
- error(_("invalid third argument"));
- SETCAR(args, coerceVector(CAR(args), REALSXP));
- k = LENGTH(CAR(args));
- if (k > *n) *n = k;
- if (k < kmin) kmin = k;
- args = CDR(args);
-
- if (!isNumeric(CAR(args)))
- error(_("invalid fourth argument"));
- SETCAR(args, coerceVector(CAR(args), REALSXP));
- k = LENGTH(CAR(args));
- if (k > *n) *n = k;
- if (k < kmin) kmin = k;
- args = CDR(args);
-
- if (*n > 0 && kmin == 0)
- error(_("cannot mix zero-length and non-zero-length coordinates"));
-}
-
-
-SEXP C_segments(SEXP args)
-{
- /* segments(x0, y0, x1, y1, col, lty, lwd, ...) */
- SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
- double *x0, *x1, *y0, *y1;
- double xx[2], yy[2];
- int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- if (length(args) < 4) error(_("too few arguments"));
- GCheckState(dd);
-
- xypoints(args, &n);
- if(n == 0) return R_NilValue;
-
- sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
- sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
- sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
- sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
- ncol = LENGTH(col); args = CDR(args);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
- nlty = length(lty); args = CDR(args);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
- nlwd = length(lwd); args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- x0 = REAL(sx0);
- y0 = REAL(sy0);
- x1 = REAL(sx1);
- y1 = REAL(sy1);
-
- GMode(1, dd);
- for (i = 0; i < n; i++) {
- xx[0] = x0[i % nx0];
- yy[0] = y0[i % ny0];
- xx[1] = x1[i % nx1];
- yy[1] = y1[i % ny1];
- GConvert(xx, yy, USER, DEVICE, dd);
- GConvert(xx+1, yy+1, USER, DEVICE, dd);
- if (R_FINITE(xx[0]) && R_FINITE(yy[0]) &&
- R_FINITE(xx[1]) && R_FINITE(yy[1]))
- {
- int thiscol = INTEGER(col)[i % ncol];
- if(!R_TRANSPARENT(thiscol)) {
- gpptr(dd)->col = thiscol;
- gpptr(dd)->lty = INTEGER(lty)[i % nlty];
- gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
- GLine(xx[0], yy[0], xx[1], yy[1], DEVICE, dd);
- }
- }
- }
- GMode(0, dd);
- GRestorePars(dd);
-
- UNPROTECT(3);
- return R_NilValue;
-}
-
-
-SEXP C_rect(SEXP args)
-{
- /* rect(xl, yb, xr, yt, col, border, lty, ...) */
- SEXP sxl, sxr, syb, syt, col, lty, lwd, border;
- double *xl, *xr, *yb, *yt, x0, y0, x1, y1;
- int i, n, nxl, nxr, nyb, nyt, ncol, nlty, nlwd, nborder;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- if (length(args) < 4) error(_("too few arguments"));
- GCheckState(dd);
-
- xypoints(args, &n);
- if(n == 0) return R_NilValue;
-
- sxl = CAR(args); nxl = length(sxl); args = CDR(args);/* x_left */
- syb = CAR(args); nyb = length(syb); args = CDR(args);/* y_bottom */
- sxr = CAR(args); nxr = length(sxr); args = CDR(args);/* x_right */
- syt = CAR(args); nyt = length(syt); args = CDR(args);/* y_top */
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
- ncol = LENGTH(col);
- args = CDR(args);
-
- PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg));
- nborder = LENGTH(border);
- args = CDR(args);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
- nlty = length(lty);
- args = CDR(args);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
- nlwd = length(lwd);
- args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- xl = REAL(sxl);
- xr = REAL(sxr);
- yb = REAL(syb);
- yt = REAL(syt);
-
- GMode(1, dd);
- for (i = 0; i < n; i++) {
- if (nlty && INTEGER(lty)[i % nlty] != NA_INTEGER)
- gpptr(dd)->lty = INTEGER(lty)[i % nlty];
- else
- gpptr(dd)->lty = dpptr(dd)->lty;
- if (nlwd && REAL(lwd)[i % nlwd] != NA_REAL)
- gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
- else
- gpptr(dd)->lwd = dpptr(dd)->lwd;
- x0 = xl[i % nxl];
- y0 = yb[i % nyb];
- x1 = xr[i % nxr];
- y1 = yt[i % nyt];
- GConvert(&x0, &y0, USER, DEVICE, dd);
- GConvert(&x1, &y1, USER, DEVICE, dd);
- if (R_FINITE(x0) && R_FINITE(y0) && R_FINITE(x1) && R_FINITE(y1))
- GRect(x0, y0, x1, y1, DEVICE, INTEGER(col)[i % ncol],
- INTEGER(border)[i % nborder], dd);
- }
- GMode(0, dd);
-
- GRestorePars(dd);
- UNPROTECT(4);
- return R_NilValue;
-}
-
-SEXP C_path(SEXP args)
-{
- /* path(x, y, col, border, lty, ...) */
- SEXP sx, sy, nper, rule, col, border, lty;
- int i, nx, npoly;
- double *xx, *yy;
- const void *vmax = NULL /* -Wall */;
-
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 2) error(_("too few arguments"));
- /* (x,y) is checked in R via xy.coords() ; no need here : */
- sx = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- sy = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- nx = LENGTH(sx);
-
- PROTECT(nper = CAR(args)); args = CDR(args);
- npoly = LENGTH(nper);
-
- PROTECT(rule = CAR(args)); args = CDR(args);
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg)); args = CDR(args);
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty)); args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- GMode(1, dd);
-
- vmax = vmaxget();
-
- /*
- * Work in device coordinates because that is what the
- * graphics engine needs.
- */
- xx = (double*) R_alloc(nx, sizeof(double));
- yy = (double*) R_alloc(nx, sizeof(double));
- if (!xx || !yy)
- error("unable to allocate memory (in GPath)");
- for (i=0; i<nx; i++) {
- xx[i] = REAL(sx)[i];
- yy[i] = REAL(sy)[i];
- GConvert(&(xx[i]), &(yy[i]), USER, DEVICE, dd);
- if (!(R_FINITE(xx[i]) && R_FINITE(yy[i])))
- error("invalid 'x' or 'y' (in 'GPath')");
- }
-
- if (INTEGER(lty)[0] == NA_INTEGER)
- gpptr(dd)->lty = dpptr(dd)->lty;
- else
- gpptr(dd)->lty = INTEGER(lty)[0];
-
- GPath(xx, yy, npoly, INTEGER(nper), INTEGER(rule)[0] == 1,
- INTEGER(col)[0], INTEGER(border)[0], dd);
-
- GMode(0, dd);
-
- GRestorePars(dd);
- UNPROTECT(5);
-
- vmaxset(vmax);
- return R_NilValue;
-}
-
-SEXP C_raster(SEXP args)
-{
- /* raster(image, xl, yb, xr, yt, angle, interpolate, ...) */
- const void *vmax;
- unsigned int *image;
- SEXP raster, dim, sxl, sxr, syb, syt, angle, interpolate;
- double *xl, *xr, *yb, *yt, x0, y0, x1, y1;
- int i, n, nxl, nxr, nyb, nyt;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- if (length(args) < 7) error(_("too few arguments"));
- GCheckState(dd);
-
- raster = CAR(args); args = CDR(args);
- n = LENGTH(raster);
- if (n <= 0) error(_("Empty raster"));
- dim = getAttrib(raster, R_DimSymbol);
-
- 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);
- }
-
- xypoints(args, &n);
- if(n == 0) return R_NilValue;
-
- sxl = CAR(args); nxl = length(sxl); args = CDR(args);/* x_left */
- syb = CAR(args); nyb = length(syb); args = CDR(args);/* y_bottom */
- sxr = CAR(args); nxr = length(sxr); args = CDR(args);/* x_right */
- syt = CAR(args); nyt = length(syt); args = CDR(args);/* y_top */
-
- angle = CAR(args); args = CDR(args);
- interpolate = CAR(args); args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- xl = REAL(sxl);
- xr = REAL(sxr);
- yb = REAL(syb);
- yt = REAL(syt);
-
- GMode(1, dd);
- for (i = 0; i < n; i++) {
- x0 = xl[i % nxl];
- y0 = yb[i % nyb];
- x1 = xr[i % nxr];
- y1 = yt[i % nyt];
- GConvert(&x0, &y0, USER, DEVICE, dd);
- GConvert(&x1, &y1, USER, DEVICE, dd);
- if (R_FINITE(x0) && R_FINITE(y0) && R_FINITE(x1) && R_FINITE(y1))
- GRaster(image, INTEGER(dim)[1], INTEGER(dim)[0],
- x0, y0, x1 - x0, y1 - y0,
- REAL(angle)[i % LENGTH(angle)],
- LOGICAL(interpolate)[i % LENGTH(interpolate)], dd);
- }
- GMode(0, dd);
-
- GRestorePars(dd);
-
- vmaxset(vmax);
- return R_NilValue;
-}
-
-
-SEXP C_arrows(SEXP args)
-{
- /* arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, ...) */
- SEXP sx0, sx1, sy0, sy1, col, lty, lwd;
- double *x0, *x1, *y0, *y1;
- double xx0, yy0, xx1, yy1;
- double hlength, angle;
- int code;
- int nx0, nx1, ny0, ny1, i, n, ncol, nlty, nlwd;
- rcolor thiscol;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- if (length(args) < 4) error(_("too few arguments"));
- GCheckState(dd);
-
- xypoints(args, &n);
- if(n == 0) return R_NilValue;
-
- sx0 = CAR(args); nx0 = length(sx0); args = CDR(args);
- sy0 = CAR(args); ny0 = length(sy0); args = CDR(args);
- sx1 = CAR(args); nx1 = length(sx1); args = CDR(args);
- sy1 = CAR(args); ny1 = length(sy1); args = CDR(args);
-
- hlength = asReal(CAR(args));
- if (!R_FINITE(hlength) || hlength < 0)
- error(_("invalid arrow head length"));
- args = CDR(args);
-
- angle = asReal(CAR(args));
- if (!R_FINITE(angle))
- error(_("invalid arrow head angle"));
- args = CDR(args);
-
- code = asInteger(CAR(args));
- if (code == NA_INTEGER || code < 0 || code > 3)
- error(_("invalid arrow head specification"));
- args = CDR(args);
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
- ncol = LENGTH(col);
- args = CDR(args);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
- nlty = length(lty);
- args = CDR(args);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
- nlwd = length(lwd);
- args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- x0 = REAL(sx0);
- y0 = REAL(sy0);
- x1 = REAL(sx1);
- y1 = REAL(sy1);
-
- GMode(1, dd);
- for (i = 0; i < n; i++) {
- xx0 = x0[i % nx0];
- yy0 = y0[i % ny0];
- xx1 = x1[i % nx1];
- yy1 = y1[i % ny1];
- GConvert(&xx0, &yy0, USER, DEVICE, dd);
- GConvert(&xx1, &yy1, USER, DEVICE, dd);
- if (R_FINITE(xx0) && R_FINITE(yy0) && R_FINITE(xx1) && R_FINITE(yy1)
- && !R_TRANSPARENT(thiscol = INTEGER(col)[i % ncol])) {
- gpptr(dd)->col = thiscol;
- gpptr(dd)->lty = INTEGER(lty)[i % nlty];
- gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
- GArrow(xx0, yy0, xx1, yy1, DEVICE,
- hlength, angle, code, dd);
- }
- }
- GMode(0, dd);
- GRestorePars(dd);
-
- UNPROTECT(3);
- return R_NilValue;
-}
-
-
-static void drawPolygon(int n, double *x, double *y,
- int lty, int fill, int border, pGEDevDesc dd)
-{
- if (lty == NA_INTEGER)
- gpptr(dd)->lty = dpptr(dd)->lty;
- else
- gpptr(dd)->lty = lty;
- GPolygon(n, x, y, USER, fill, border, dd);
-}
-
-SEXP C_polygon(SEXP args)
-{
- /* polygon(x, y, col, border, lty, ...) */
- SEXP sx, sy, col, border, lty;
- int nx;
- int ncol, nborder, nlty, i, start=0;
- int num = 0;
- double *x, *y, xx, yy, xold, yold;
-
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 2) error(_("too few arguments"));
- /* (x,y) is checked in R via xy.coords() ; no need here : */
- sx = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- sy = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- nx = LENGTH(sx);
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- ncol = LENGTH(col);
-
- PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg)); args = CDR(args);
- nborder = LENGTH(border);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty)); args = CDR(args);
- nlty = length(lty);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- GMode(1, dd);
-
- x = REAL(sx);
- y = REAL(sy);
- xold = NA_REAL;
- yold = NA_REAL;
- for (i = 0; i < nx; i++) {
- xx = x[i];
- yy = y[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if ((R_FINITE(xx) && R_FINITE(yy)) &&
- !(R_FINITE(xold) && R_FINITE(yold)))
- start = i; /* first point of current segment */
- else if ((R_FINITE(xold) && R_FINITE(yold)) &&
- !(R_FINITE(xx) && R_FINITE(yy))) {
- if (i-start > 1) {
- drawPolygon(i-start, x+start, y+start,
- INTEGER(lty)[num%nlty],
- INTEGER(col)[num%ncol],
- INTEGER(border)[num%nborder], dd);
- num++;
- }
- }
- else if ((R_FINITE(xold) && R_FINITE(yold)) && (i == nx-1)) { /* last */
- drawPolygon(nx-start, x+start, y+start,
- INTEGER(lty)[num%nlty],
- INTEGER(col)[num%ncol],
- INTEGER(border)[num%nborder], dd);
- num++;
- }
- xold = xx;
- yold = yy;
- }
-
- GMode(0, dd);
-
- GRestorePars(dd);
- UNPROTECT(3);
- return R_NilValue;
-}
-
-SEXP C_text(SEXP args)
-{
-/* text(xy, labels, adj, pos, offset,
- * vfont, cex, col, font, ...)
- */
- SEXP sx, sy, sxy, txt, adj, pos, cex, col, rawcol, font, vfont;
- int i, n, npos, ncex, ncol, nfont, ntxt;
- double adjx = 0, adjy = 0, offset = 0.5;
- double *x, *y;
- double xx, yy;
- Rboolean vectorFonts = FALSE;
- SEXP string;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 3) error(_("too few arguments"));
-
- PLOT_XY_DEALING("text");
-
- /* labels */
- txt = CAR(args);
- if (isSymbol(txt) || isLanguage(txt))
- txt = coerceVector(txt, EXPRSXP);
- else if (!isExpression(txt))
- txt = coerceVector(txt, STRSXP);
- PROTECT(txt);
- if (length(txt) <= 0)
- error(_("zero-length '%s' specified"), "labels");
- args = CDR(args);
-
- PROTECT(adj = CAR(args));
- if (isNull(adj) || (isNumeric(adj) && length(adj) == 0)) {
- adjx = gpptr(dd)->adj;
- adjy = NA_REAL;
- }
- else if (isReal(adj)) {
- if (LENGTH(adj) == 1) {
- adjx = REAL(adj)[0];
- adjy = NA_REAL;
- }
- else {
- adjx = REAL(adj)[0];
- adjy = REAL(adj)[1];
- }
- }
- else if (isInteger(adj)) {
- if (LENGTH(adj) == 1) {
- adjx = INTEGER(adj)[0];
- adjy = NA_REAL;
- }
- else {
- adjx = INTEGER(adj)[0];
- adjy = INTEGER(adj)[1];
- }
- }
- else error(_("invalid '%s' value"), "adj");
- args = CDR(args);
-
- PROTECT(pos = coerceVector(CAR(args), INTSXP));
- npos = length(pos);
- for (i = 0; i < npos; i++)
- if (INTEGER(pos)[i] < 1 || INTEGER(pos)[i] > 4)
- error(_("invalid '%s' value"), "pos");
- args = CDR(args);
-
- offset = GConvertXUnits(asReal(CAR(args)), CHARS, INCHES, dd);
- args = CDR(args);
-
- PROTECT(vfont = FixupVFont(CAR(args)));
- args = CDR(args);
-
- PROTECT(cex = FixupCex(CAR(args), 1.0));
- ncex = LENGTH(cex);
- args = CDR(args);
-
- rawcol = CAR(args);
- PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
- ncol = LENGTH(col);
- args = CDR(args);
-
- PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
- nfont = LENGTH(font);
- args = CDR(args);
-
- x = REAL(sx);
- y = REAL(sy);
- /* n = LENGTH(sx) = LENGTH(sy) */
- ntxt = LENGTH(txt);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- /* Done here so 'vfont' trumps inline 'family' */
- if (!isNull(vfont) && !isExpression(txt)) {
- strncpy(gpptr(dd)->family, "Her ", 201);
- gpptr(dd)->family[3] = (char) INTEGER(vfont)[0];
- vectorFonts = TRUE;
- }
-
- GMode(1, dd);
- if (n == 0 && ntxt > 0)
- error(_("no coordinates were supplied"));
- for (i = 0; i < imax2(n,ntxt); i++) {
- xx = x[i % n];
- yy = y[i % n];
- GConvert(&xx, &yy, USER, INCHES, dd);
- if (R_FINITE(xx) && R_FINITE(yy)) {
- if (ncol && !isNAcol(rawcol, i, ncol))
- gpptr(dd)->col = INTEGER(col)[i % ncol];
- else
- gpptr(dd)->col = dpptr(dd)->col;
- if (ncex && R_FINITE(REAL(cex)[i % ncex]))
- gpptr(dd)->cex = gpptr(dd)->cexbase * REAL(cex)[i % ncex];
- else
- gpptr(dd)->cex = gpptr(dd)->cexbase;
-
- if (vectorFonts) gpptr(dd)->font = INTEGER(vfont)[1];
- else if (nfont && INTEGER(font)[i % nfont] != NA_INTEGER)
- gpptr(dd)->font = INTEGER(font)[i % nfont];
- else
- gpptr(dd)->font = dpptr(dd)->font;
-
- if (npos > 0) {
- switch(INTEGER(pos)[i % npos]) {
- case 1:
- yy = yy - offset;
- adjx = 0.5;
- adjy = 1 - (0.5 - dd->dev->yCharOffset);
- break;
- case 2:
- xx = xx - offset;
- adjx = 1;
- adjy = dd->dev->yCharOffset;
- break;
- case 3:
- yy = yy + offset;
- adjx = 0.5;
- adjy = 0;
- break;
- case 4:
- xx = xx + offset;
- adjx = 0;
- adjy = dd->dev->yCharOffset;
- break;
- }
- }
- if (isExpression(txt)) {
- GMathText(xx, yy, INCHES, VECTOR_ELT(txt, i % ntxt),
- adjx, adjy, gpptr(dd)->srt, dd);
- } else {
- string = STRING_ELT(txt, i % ntxt);
- if(string != NA_STRING)
- GText(xx, yy, INCHES, CHAR(string), getCharCE(string),
- adjx, adjy, gpptr(dd)->srt, dd);
- }
- }
- }
- GMode(0, dd);
-
- GRestorePars(dd);
- UNPROTECT(7);
- return R_NilValue;
-}
-
-static double ComputeAdjValue(double adj, int side, int las)
-{
- if (!R_FINITE(adj)) {
- switch(las) {
- case 0:/* parallel to axis */
- adj = 0.5; break;
- case 1:/* horizontal */
- switch(side) {
- case 1:
- case 3: adj = 0.5; break;
- case 2: adj = 1.0; break;
- case 4: adj = 0.0; break;
- }
- break;
- case 2:/* perpendicular to axis */
- switch(side) {
- case 1:
- case 2: adj = 1.0; break;
- case 3:
- case 4: adj = 0.0; break;
- }
- break;
- case 3:/* vertical */
- switch(side) {
- case 1: adj = 1.0; break;
- case 3: adj = 0.0; break;
- case 2:
- case 4: adj = 0.5; break;
- }
- break;
- }
- }
- return adj;
-}
-
-static double ComputeAtValueFromAdj(double adj, int side, int outer,
- pGEDevDesc dd)
-{
- double at = 0; /* -Wall */
- switch(side % 2) {
- case 0:
- at = outer ? adj : yNPCtoUsr(adj, dd);
- break;
- case 1:
- at = outer ? adj : xNPCtoUsr(adj, dd);
- break;
- }
- return at;
-}
-
-static double ComputeAtValue(double at, double adj,
- int side, int las, int outer,
- pGEDevDesc dd)
-{
- if (!R_FINITE(at)) {
- /* If the text is parallel to the axis, use "adj" for "at"
- * Otherwise, centre the text
- */
- switch(las) {
- case 0:/* parallel to axis */
- at = ComputeAtValueFromAdj(adj, side, outer, dd);
- break;
- case 1:/* horizontal */
- switch(side) {
- case 1:
- case 3:
- at = ComputeAtValueFromAdj(adj, side, outer, dd);
- break;
- case 2:
- case 4:
- at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
- break;
- }
- break;
- case 2:/* perpendicular to axis */
- switch(side) {
- case 1:
- case 3:
- at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
- break;
- case 2:
- case 4:
- at = outer ? 0.5 : yNPCtoUsr(0.5, dd);
- break;
- }
- break;
- case 3:/* vertical */
- switch(side) {
- case 1:
- case 3:
- at = outer ? 0.5 : xNPCtoUsr(0.5, dd);
- break;
- case 2:
- case 4:
- at = ComputeAtValueFromAdj(adj, side, outer, dd);
- break;
- }
- break;
- }
- }
- return at;
-}
-
-/* mtext(text,
- side = 3,
- line = 0,
- outer = TRUE,
- at = NA,
- adj = NA,
- padj = NA,
- cex = NA,
- col = NA,
- font = NA,
- ...) */
-
-SEXP C_mtext(SEXP args)
-{
- SEXP text, side, line, outer, at, adj, padj, cex, col, font, string;
- SEXP rawcol;
- int ntext, nside, nline, nouter, nat, nadj, npadj, ncex, ncol, nfont;
- Rboolean dirtyplot = FALSE, gpnewsave = FALSE, dpnewsave = FALSE;
- int i, n, fontsave, colsave;
- double cexsave;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 9)
- error(_("too few arguments"));
-
- /* Arg1 : text= */
- text = CAR(args);
- if (isSymbol(text) || isLanguage(text))
- text = coerceVector(text, EXPRSXP);
- else if (!isExpression(text))
- text = coerceVector(text, STRSXP);
- PROTECT(text);
- n = ntext = length(text);
- if (ntext <= 0)
- error(_("zero-length '%s' specified"), "text");
- args = CDR(args);
-
- /* Arg2 : side= */
- PROTECT(side = coerceVector(CAR(args), INTSXP));
- nside = length(side);
- if (nside <= 0) error(_("zero-length '%s' specified"), "side");
- if (n < nside) n = nside;
- args = CDR(args);
-
- /* Arg3 : line= */
- PROTECT(line = coerceVector(CAR(args), REALSXP));
- nline = length(line);
- if (nline <= 0) error(_("zero-length '%s' specified"), "line");
- if (n < nline) n = nline;
- args = CDR(args);
-
- /* Arg4 : outer= */
- /* outer == NA => outer <- 0 */
- PROTECT(outer = coerceVector(CAR(args), INTSXP));
- nouter = length(outer);
- if (nouter <= 0) error(_("zero-length '%s' specified"), "outer");
- if (n < nouter) n = nouter;
- args = CDR(args);
-
- /* Arg5 : at= */
- PROTECT(at = coerceVector(CAR(args), REALSXP));
- nat = length(at);
- if (nat <= 0) error(_("zero-length '%s' specified"), "at");
- if (n < nat) n = nat;
- args = CDR(args);
-
- /* Arg6 : adj= */
- PROTECT(adj = coerceVector(CAR(args), REALSXP));
- nadj = length(adj);
- if (nadj <= 0) error(_("zero-length '%s' specified"), "adj");
- if (n < nadj) n = nadj;
- args = CDR(args);
-
- /* Arg7 : padj= */
- PROTECT(padj = coerceVector(CAR(args), REALSXP));
- npadj = length(padj);
- if (npadj <= 0) error(_("zero-length '%s' specified"), "padj");
- if (n < npadj) n = npadj;
- args = CDR(args);
-
- /* Arg8 : cex */
- PROTECT(cex = FixupCex(CAR(args), 1.0));
- ncex = length(cex);
- if (ncex <= 0) error(_("zero-length '%s' specified"), "cex");
- if (n < ncex) n = ncex;
- args = CDR(args);
-
- /* Arg9 : col */
- rawcol = CAR(args);
- PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
- ncol = length(col);
- if (ncol <= 0) error(_("zero-length '%s' specified"), "col");
- if (n < ncol) n = ncol;
- args = CDR(args);
-
- /* Arg10 : font */
- PROTECT(font = FixupFont(CAR(args), NA_INTEGER));
- nfont = length(font);
- if (nfont <= 0) error(_("zero-length '%s' specified"), "font");
- if (n < nfont) n = nfont;
- args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- /* If we only scribble in the outer margins, */
- /* we don't want to mark the plot as dirty. */
-
- dirtyplot = FALSE;
- gpnewsave = gpptr(dd)->new;
- dpnewsave = dpptr(dd)->new;
- cexsave = gpptr(dd)->cex;
- fontsave = gpptr(dd)->font;
- colsave = gpptr(dd)->col;
-
- /* override par("xpd") and force clipping to figure region
- NOTE: don't override to _reduce_ clipping region */
- if (gpptr(dd)->xpd < 1)
- gpptr(dd)->xpd = 1;
-
- if (outer) {
- gpnewsave = gpptr(dd)->new;
- dpnewsave = dpptr(dd)->new;
- /* override par("xpd") and force clipping to device region */
- gpptr(dd)->xpd = 2;
- }
- GMode(1, dd);
-
- for (i = 0; i < n; i++) {
- double atval = REAL(at)[i % nat];
- double adjval = REAL(adj)[i % nadj];
- double padjval = REAL(padj)[i % npadj];
- double cexval = REAL(cex)[i % ncex];
- double lineval = REAL(line)[i % nline];
- int outerval = INTEGER(outer)[i % nouter];
- int sideval = INTEGER(side)[i % nside];
- int fontval = INTEGER(font)[i % nfont];
- int colval = INTEGER(col)[i % ncol];
-
- if (outerval == NA_INTEGER) outerval = 0;
- /* Note : we ignore any shrinking produced */
- /* by mfrow / mfcol specs here. I.e. don't */
- /* gpptr(dd)->cexbase. */
- if (R_FINITE(cexval)) gpptr(dd)->cex = cexval;
- else cexval = cexsave;
- gpptr(dd)->font = (fontval == NA_INTEGER) ? fontsave : fontval;
- if (isNAcol(rawcol, i, ncol))
- gpptr(dd)->col = colsave;
- else
- gpptr(dd)->col = colval;
- gpptr(dd)->adj = ComputeAdjValue(adjval, sideval, gpptr(dd)->las);
- padjval = ComputePAdjValue(padjval, sideval, gpptr(dd)->las);
- atval = ComputeAtValue(atval, gpptr(dd)->adj, sideval, gpptr(dd)->las,
- outerval, dd);
-
- if (isExpression(text))
- GMMathText(VECTOR_ELT(text, i % ntext),
- sideval, lineval, outerval, atval, gpptr(dd)->las,
- padjval, dd);
- else {
- string = STRING_ELT(text, i % ntext);
- if(string != NA_STRING)
- GMtext(CHAR(string), getCharCE(string), sideval, lineval,
- outerval, atval, gpptr(dd)->las, padjval, dd);
- }
-
- if (outerval == 0) dirtyplot = TRUE;
- }
- GMode(0, dd);
-
- GRestorePars(dd);
- if (!dirtyplot) {
- gpptr(dd)->new = gpnewsave;
- dpptr(dd)->new = dpnewsave;
- }
- UNPROTECT(10);
- return R_NilValue;
-} /* Mtext */
-
-
-SEXP C_title(SEXP args)
-{
-/* Annotation for plots :
-
- title(main, sub, xlab, ylab,
- line, outer,
- ...) */
-
- SEXP Main, xlab, ylab, sub, string;
- double adj, adjy, cex, offset, line, hpos, vpos;
- int i, n, font, outer, where;
- rcolor col;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 6) error(_("too few arguments"));
-
- Main = sub = xlab = ylab = R_NilValue;
-
- if (CAR(args) != R_NilValue && length(CAR(args)) > 0)
- Main = CAR(args);
- args = CDR(args);
-
- if (CAR(args) != R_NilValue && length(CAR(args)) > 0)
- sub = CAR(args);
- args = CDR(args);
-
- if (CAR(args) != R_NilValue && length(CAR(args)) > 0)
- xlab = CAR(args);
- args = CDR(args);
-
- if (CAR(args) != R_NilValue && length(CAR(args)) > 0)
- ylab = CAR(args);
- args = CDR(args);
-
- line = asReal(CAR(args));
- args = CDR(args);
-
- outer = asLogical(CAR(args));
- if (outer == NA_LOGICAL) outer = 0;
- args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- /* override par("xpd") and force clipping to figure region
- NOTE: don't override to _reduce_ clipping region */
- if (gpptr(dd)->xpd < 1)
- gpptr(dd)->xpd = 1;
- if (outer)
- gpptr(dd)->xpd = 2;
- adj = gpptr(dd)->adj;
-
- GMode(1, dd);
- if (Main != R_NilValue) {
- cex = gpptr(dd)->cexmain;
- col = gpptr(dd)->colmain;
- font = gpptr(dd)->fontmain;
- /* GetTextArg may coerce, so protect the result */
- GetTextArg(Main, &Main, &col, &cex, &font);
- PROTECT(Main);
- gpptr(dd)->col = col;
- gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
- gpptr(dd)->font = font;
- if (outer) {
- if (R_FINITE(line)) {
- vpos = line;
- adjy = 0;
- }
- else {
- vpos = 0.5 * gpptr(dd)->oma[2];
- adjy = 0.5;
- }
- hpos = adj;
- where = OMA3;
- }
- else {
- if (R_FINITE(line)) {
- vpos = line;
- adjy = 0;
- }
- else {
- vpos = 0.5 * gpptr(dd)->mar[2];
- adjy = 0.5;
- }
- hpos = GConvertX(adj, NPC, USER, dd);
- where = MAR3;
- }
- if (isExpression(Main)) {
- GMathText(hpos, vpos, where, VECTOR_ELT(Main, 0),
- adj, 0.5, 0.0, dd);
- }
- else {
- n = length(Main);
- offset = 0.5 * (n - 1) + vpos;
- for (i = 0; i < n; i++) {
- string = STRING_ELT(Main, i);
- if(string != NA_STRING)
- GText(hpos, offset - i, where, CHAR(string), getCharCE(string),
- adj, adjy, 0.0, dd);
- }
- }
- UNPROTECT(1);
- }
- if (sub != R_NilValue) {
- cex = gpptr(dd)->cexsub;
- col = gpptr(dd)->colsub;
- font = gpptr(dd)->fontsub;
- /* GetTextArg may coerce, so protect the result */
- GetTextArg(sub, &sub, &col, &cex, &font);
- PROTECT(sub);
- gpptr(dd)->col = col;
- gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
- gpptr(dd)->font = font;
- if (R_FINITE(line))
- vpos = line;
- else
- vpos = gpptr(dd)->mgp[0] + 1;
- if (outer) {
- hpos = adj;
- where = 1;
- }
- else {
- hpos = GConvertX(adj, NPC, USER, dd);
- where = 0;
- }
- if (isExpression(sub))
- GMMathText(VECTOR_ELT(sub, 0), 1, vpos, where,
- hpos, 0, 0.0, dd);
- else {
- n = length(sub);
- for (i = 0; i < n; i++) {
- string = STRING_ELT(sub, i);
- if(string != NA_STRING)
- GMtext(CHAR(string), getCharCE(string), 1, vpos, where,
- hpos, 0, 0.0, dd);
- }
- }
- UNPROTECT(1);
- }
- if (xlab != R_NilValue) {
- cex = gpptr(dd)->cexlab;
- col = gpptr(dd)->collab;
- font = gpptr(dd)->fontlab;
- /* GetTextArg may coerce, so protect the result */
- GetTextArg(xlab, &xlab, &col, &cex, &font);
- PROTECT(xlab);
- gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
- gpptr(dd)->col = col;
- gpptr(dd)->font = font;
- if (R_FINITE(line))
- vpos = line;
- else
- vpos = gpptr(dd)->mgp[0];
- if (outer) {
- hpos = adj;
- where = 1;
- }
- else {
- hpos = GConvertX(adj, NPC, USER, dd);
- where = 0;
- }
- if (isExpression(xlab))
- GMMathText(VECTOR_ELT(xlab, 0), 1, vpos, where,
- hpos, 0, 0.0, dd);
- else {
- n = length(xlab);
- for (i = 0; i < n; i++) {
- string = STRING_ELT(xlab, i);
- if(string != NA_STRING)
- GMtext(CHAR(string), getCharCE(string), 1, vpos + i,
- where, hpos, 0, 0.0, dd);
- }
- }
- UNPROTECT(1);
- }
- if (ylab != R_NilValue) {
- cex = gpptr(dd)->cexlab;
- col = gpptr(dd)->collab;
- font = gpptr(dd)->fontlab;
- /* GetTextArg may coerce, so protect the result */
- GetTextArg(ylab, &ylab, &col, &cex, &font);
- PROTECT(ylab);
- gpptr(dd)->cex = gpptr(dd)->cexbase * cex;
- gpptr(dd)->col = col;
- gpptr(dd)->font = font;
- if (R_FINITE(line))
- vpos = line;
- else
- vpos = gpptr(dd)->mgp[0];
- if (outer) {
- hpos = adj;
- where = 1;
- }
- else {
- hpos = GConvertY(adj, NPC, USER, dd);
- where = 0;
- }
- if (isExpression(ylab))
- GMMathText(VECTOR_ELT(ylab, 0), 2, vpos, where,
- hpos, 0, 0.0, dd);
- else {
- n = length(ylab);
- for (i = 0; i < n; i++) {
- string = STRING_ELT(ylab, i);
- if(string != NA_STRING)
- GMtext(CHAR(string), getCharCE(string), 2, vpos - i,
- where, hpos, 0, 0.0, dd);
- }
- }
- UNPROTECT(1);
- }
- GMode(0, dd);
- GRestorePars(dd);
- return R_NilValue;
-} /* Title */
-
-
-/* abline(a, b, h, v, col, lty, lwd, ...)
- draw lines in intercept/slope form. */
-
-SEXP C_abline(SEXP args)
-{
- SEXP a, b, h, v, untf, col, lty, lwd;
- int i, ncol, nlines, nlty, nlwd, lstart, lstop;
- double aa, bb, x[2], y[2]={0.,0.} /* -Wall */;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 5) error(_("too few arguments"));
-
- if ((a = CAR(args)) != R_NilValue)
- SETCAR(args, a = coerceVector(a, REALSXP));
- args = CDR(args);
-
- if ((b = CAR(args)) != R_NilValue)
- SETCAR(args, b = coerceVector(b, REALSXP));
- args = CDR(args);
-
- if ((h = CAR(args)) != R_NilValue)
- SETCAR(args, h = coerceVector(h, REALSXP));
- args = CDR(args);
-
- if ((v = CAR(args)) != R_NilValue)
- SETCAR(args, v = coerceVector(v, REALSXP));
- args = CDR(args);
-
- if ((untf = CAR(args)) != R_NilValue)
- SETCAR(args, untf = coerceVector(untf, LGLSXP));
- args = CDR(args);
-
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- ncol = LENGTH(col);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty)); args = CDR(args);
- nlty = length(lty);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd)); args = CDR(args);
- nlwd = length(lwd);
-
- GSavePars(dd);
-
- ProcessInlinePars(args, dd);
-
- nlines = 0;
-
- if (a != R_NilValue) { /* case where a ans b are supplied */
- if (b == R_NilValue) {
- if (LENGTH(a) != 2)
- error(_("invalid a=, b= specification"));
- aa = REAL(a)[0];
- bb = REAL(a)[1];
- }
- else {
- aa = asReal(a);
- bb = asReal(b);
- }
- if (!R_FINITE(aa) || !R_FINITE(bb))
- error(_("'a' and 'b' must be finite"));
- gpptr(dd)->col = INTEGER(col)[0];
- gpptr(dd)->lwd = REAL(lwd)[0];
- if (nlty && INTEGER(lty)[0] != NA_INTEGER)
- gpptr(dd)->lty = INTEGER(lty)[0];
- else
- gpptr(dd)->lty = dpptr(dd)->lty;
- GMode(1, dd);
-
- /* FIXME?
- * Seems like the logic here is just draw from xmin to xmax
- * and you're guaranteed to draw at least from ymin to ymax
- * This MAY cause a problem at some stage when the line being
- * drawn is VERY steep -- and the problem is worse now that
- * abline will potentially draw to the extents of the device
- * (when xpd = NA). NOTE that R's internal clipping protects the
- * device drivers from stupidly large numbers, BUT there is
- * still a risk that we could produce a number which is too
- * big for the computer's brain.
- * Paul.
- *
- * The problem is worse -- you could get NaN, which at least the
- * X11 device coerces to -2^31 <TSL>
- */
- getxlimits(x, dd);/* -> (x[0], x[1]) */
- if (R_FINITE(gpptr(dd)->lwd)) {
- Rboolean xlog = gpptr(dd)->xlog, ylog = gpptr(dd)->ylog;
- if (LOGICAL(untf)[0] && (xlog || ylog)) {
-#define NS 100
- /* Plot curve, linear on original scales */
- double xx[NS+1], yy[NS+1];
- if(xlog) {
- /* x_i should be equidistant in log-scale, i.e., equi-ratio */
- double x_f = x[1] / DBL_MAX;
- xx[0] = x[0] = fmax2(x[0], 1.01 *x_f); /* > 0 */
- x_f = pow(x[1]/x[0], 1./NS);
- for (i = 1; i < NS; i++)
- xx[i] = xx[i-1] * x_f;
- } else {
- double xstep = (x[1] - x[0])/NS;
- for (i = 0; i < NS; i++)
- xx[i] = x[0] + i*xstep;
- }
- xx[NS] = x[1];
- for (i = 0; i <= NS; i++)
- yy[i] = aa + xx[i] * bb;
-
- /* now get rid of -ve values */
- lstart = 0;lstop = NS;
- if (xlog) {
- for(; xx[lstart] <= 0 && lstart < NS+1; lstart++);
- for(; xx[lstop] <= 0 && lstop > 0; lstop--);
- }
- if (ylog) {
- for(; yy[lstart] <= 0 && lstart < NS+1; lstart++);
- for(; yy[lstop] <= 0 && lstop > 0; lstop--);
- }
-
- GPolyline(lstop-lstart+1, xx+lstart, yy+lstart, USER, dd);
-#undef NS
- } else { /* non-log plots, possibly with log scales */
-
- y[0] = aa + (xlog ? log10(x[0]) : x[0]) * bb;
- y[1] = aa + (xlog ? log10(x[1]) : x[1]) * bb;
- if (ylog) {
- y[0] = Rexp10(y[0]);
- y[1] = Rexp10(y[1]);
- }
-
- GLine(x[0], y[0], x[1], y[1], USER, dd);
- }
- }
- GMode(0, dd);
- nlines++;
- }
- if (h != R_NilValue) { /* horizontal liee */
- GMode(1, dd);
- for (i = 0; i < LENGTH(h); i++) {
- gpptr(dd)->col = INTEGER(col)[nlines % ncol];
- if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
- gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
- else
- gpptr(dd)->lty = dpptr(dd)->lty;
- gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
- aa = REAL(h)[i];
- if (R_FINITE(aa) && R_FINITE(gpptr(dd)->lwd)) {
- getxlimits(x, dd);
- y[0] = aa;
- y[1] = aa;
- GLine(x[0], y[0], x[1], y[1], USER, dd);
- }
- nlines++;
- }
- GMode(0, dd);
- }
- if (v != R_NilValue) { /* vertical line */
- GMode(1, dd);
- for (i = 0; i < LENGTH(v); i++) {
- gpptr(dd)->col = INTEGER(col)[nlines % ncol];
- if (nlty && INTEGER(lty)[nlines % nlty] != NA_INTEGER)
- gpptr(dd)->lty = INTEGER(lty)[nlines % nlty];
- else
- gpptr(dd)->lty = dpptr(dd)->lty;
- gpptr(dd)->lwd = REAL(lwd)[nlines % nlwd];
- aa = REAL(v)[i];
- if (R_FINITE(aa) && R_FINITE(gpptr(dd)->lwd)) {
- getylimits(y, dd);
- x[0] = aa;
- x[1] = aa;
- GLine(x[0], y[0], x[1], y[1], USER, dd);
- }
- nlines++;
- }
- GMode(0, dd);
- }
- UNPROTECT(3);
- GRestorePars(dd);
- return R_NilValue;
-} /* Abline */
-
-
-SEXP C_box(SEXP args)
-{
-/* box(which="plot", lty="solid", ...)
- --- which is coded, 1 = plot, 2 = figure, 3 = inner, 4 = outer.
-*/
- int which, col;
- SEXP colsxp, fgsxp;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
- GSavePars(dd);
- args = CDR(args);
- which = asInteger(CAR(args)); args = CDR(args);
- if (which < 1 || which > 4)
- error(_("invalid '%s' argument"), "which");
- /*
- * If specified non-NA col then use that, else ...
- *
- * if specified non-NA fg then use that, else ...
- *
- * else use par("col")
- */
- col= gpptr(dd)->col;
- ProcessInlinePars(args, dd);
- colsxp = getInlinePar(args, "col");
- if (isNAcol(colsxp, 0, 1)) {
- fgsxp = getInlinePar(args, "fg");
- if (isNAcol(fgsxp, 0, 1))
- gpptr(dd)->col = col;
- else
- gpptr(dd)->col = gpptr(dd)->fg;
- }
- /* override par("xpd") and force clipping to device region */
- gpptr(dd)->xpd = 2;
- GMode(1, dd);
- GBox(which, dd);
- GMode(0, dd);
- GRestorePars(dd);
- return R_NilValue;
-}
-
-static void drawPointsLines(double xp, double yp, double xold, double yold,
- char type, int first, pGEDevDesc dd)
-{
- if (type == 'p' || type == 'o')
- GSymbol(xp, yp, DEVICE, gpptr(dd)->pch, dd);
- if ((type == 'l' || type == 'o') && !first)
- GLine(xold, yold, xp, yp, DEVICE, dd);
-}
-
-SEXP C_locator(SEXP call, SEXP op, SEXP args, SEXP rho)
-{
- SEXP x, y, nobs, ans, saveans, stype = R_NilValue;
- int i, n;
- char type = 'p';
- double xp, yp, xold=0, yold=0;
- pGEDevDesc dd = GEcurrentDevice();
- SEXP name = CAR(args);
-
- args = CDR(args);
- /* If replaying, just draw the points and lines that were recorded */
- if (call == R_NilValue) {
- x = CAR(args); args = CDR(args);
- y = CAR(args); args = CDR(args);
- nobs = CAR(args); args = CDR(args);
- n = INTEGER(nobs)[0];
- stype = CAR(args); args = CDR(args);
- type = CHAR(STRING_ELT(stype, 0))[0];
- if (type != 'n') {
- GMode(1, dd);
- for (i = 0; i < n; i++) {
- xp = REAL(x)[i];
- yp = REAL(y)[i];
- GConvert(&xp, &yp, USER, DEVICE, dd);
- drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
- xold = xp;
- yold = yp;
- }
- GMode(0, dd);
- }
- return R_NilValue;
- } else {
- GCheckState(dd);
-
- n = asInteger(CAR(args));
- if (n <= 0 || n == NA_INTEGER)
- error(_("invalid number of points in %s"), "locator()");
- args = CDR(args);
- if (isString(CAR(args)) && LENGTH(CAR(args)) == 1)
- stype = CAR(args);
- else
- error(_("invalid plot type"));
- type = CHAR(STRING_ELT(stype, 0))[0];
- PROTECT(x = allocVector(REALSXP, n));
- PROTECT(y = allocVector(REALSXP, n));
- PROTECT(nobs=allocVector(INTSXP,1));
-
- GMode(2, dd);
- for (i = 0; i < n; i++) {
- if (!GLocator(&(REAL(x)[i]), &(REAL(y)[i]), USER, dd)) break;
- if (type != 'n') {
- GMode(1, dd);
- xp = REAL(x)[i];
- yp = REAL(y)[i];
- GConvert(&xp, &yp, USER, DEVICE, dd);
- drawPointsLines(xp, yp, xold, yold, type, i==0, dd);
- GMode(0, dd);
- GMode(2, dd);
- xold = xp; yold = yp;
- }
- }
- GMode(0, dd);
- INTEGER(nobs)[0] = i;
- for (; i < n; i++) {
- REAL(x)[i] = NA_REAL;
- REAL(y)[i] = NA_REAL;
- }
- PROTECT(ans = allocList(3));
- SETCAR(ans, x);
- SETCADR(ans, y);
- SETCADDR(ans, nobs);
- if (GRecording(call, dd)) {
- PROTECT(saveans = allocList(5));
- SETCAR(saveans, name);
- SETCADR(saveans, x);
- SETCADDR(saveans, y);
- SETCADDDR(saveans, nobs);
- SETCAD4R(saveans, CAR(args));
- /* Record the points and lines that were drawn in the display list */
- GErecordGraphicOperation(op, saveans, dd);
- UNPROTECT(1);
- }
- UNPROTECT(4);
- return ans;
- }
-}
-
-static void drawLabel(double xi, double yi, int pos, double offset,
- const char *l, cetype_t enc, pGEDevDesc dd)
-{
- switch (pos) {
- case 4:
- xi = xi+offset;
- GText(xi, yi, INCHES, l, enc, 0.0,
- dd->dev->yCharOffset, 0.0, dd);
- break;
- case 2:
- xi = xi-offset;
- GText(xi, yi, INCHES, l, enc, 1.0,
- dd->dev->yCharOffset, 0.0, dd);
- break;
- case 3:
- yi = yi+offset;
- GText(xi, yi, INCHES, l, enc, 0.5,
- 0.0, 0.0, dd);
- break;
- case 1:
- yi = yi-offset;
- GText(xi, yi, INCHES, l, enc, 0.5,
- 1-(0.5-dd->dev->yCharOffset),
- 0.0, dd);
- break;
- case 0:
- GText(xi, yi, INCHES, l, enc, 0.0, 0.0, 0.0, dd);
- break;
- }
-}
-
-SEXP C_identify(SEXP call, SEXP op, SEXP args, SEXP rho)
-{
- SEXP ans, x, y, l, ind, pos, Offset, draw, saveans;
- double xi, yi, xp, yp, d, dmin, offset, tol;
- int atpen, i, imin, k, n, nl, npts, plot, posi, warn;
- pGEDevDesc dd = GEcurrentDevice();
- SEXP name = CAR(args);
-
- args = CDR(args);
- /* If we are replaying the display list, then just redraw the
- labels beside the identified points */
- if (call == R_NilValue) {
- ind = CAR(args); args = CDR(args);
- pos = CAR(args); args = CDR(args);
- x = CAR(args); args = CDR(args);
- y = CAR(args); args = CDR(args);
- Offset = CAR(args); args = CDR(args);
- l = CAR(args); args = CDR(args);
- draw = CAR(args);
- n = LENGTH(x);
- nl = LENGTH(l);
- /*
- * Most of the appropriate settings have been set up in
- * R code by par(...)
- * Hence no GSavePars() or ProcessInlinePars() here
- * (also because this function is unusual in that it does
- * different things when run by a user compared to when
- * run from the display list)
- * BUT par(cex) only sets cexbase, so here we set cex from cexbase
- */
- gpptr(dd)->cex = gpptr(dd)->cexbase;
- offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
- for (i = 0; i < n; i++) {
- plot = LOGICAL(ind)[i];
- if (LOGICAL(draw)[0] && plot) {
- xi = REAL(x)[i];
- yi = REAL(y)[i];
- GConvert(&xi, &yi, USER, INCHES, dd);
- posi = INTEGER(pos)[i];
- drawLabel(xi, yi, posi, offset,
- CHAR(STRING_ELT(l, i % nl)),
- getCharCE(STRING_ELT(l, i % nl)), dd);
- }
- }
- return R_NilValue;
- }
- else {
- GCheckState(dd);
-
- x = CAR(args); args = CDR(args);
- y = CAR(args); args = CDR(args);
- l = CAR(args); args = CDR(args);
- npts = asInteger(CAR(args)); args = CDR(args);
- plot = asLogical(CAR(args)); args = CDR(args);
- Offset = CAR(args); args = CDR(args);
- tol = asReal(CAR(args)); args = CDR(args);
- atpen = asLogical(CAR(args));
- if (npts <= 0 || npts == NA_INTEGER)
- error(_("invalid number of points in %s"), "identify()");
- if (!isReal(x) || !isReal(y) || !isString(l) || !isReal(Offset))
- error(_("incorrect argument type"));
- if (tol <= 0 || ISNAN(tol))
- error(_("invalid '%s' value"), "tolerance");
- if (plot == NA_LOGICAL)
- error(_("invalid '%s' value"), "plot");
- if (atpen == NA_LOGICAL)
- error(_("invalid '%s' value"), "atpen");
- nl = LENGTH(l);
- if (nl <= 0)
- error(_("zero-length '%s' specified"), "labels");
- n = LENGTH(x);
- if (n != LENGTH(y))
- error(_("different argument lengths"));
- if (nl > n)
- warning(_("more 'labels' than points"));
-
- /*
- * Most of the appropriate settings have been set up in
- * R code by par(...)
- * Hence no GSavePars() or ProcessInlinePars() here
- * (also because this function is unusual in that it does
- * different things when run by a user compared to when
- * run from the display list)
- * BUT par(cex) only sets cexbase, so here we set cex from cexbase
- */
- gpptr(dd)->cex = gpptr(dd)->cexbase;
- offset = GConvertXUnits(asReal(Offset), CHARS, INCHES, dd);
- PROTECT(ind = allocVector(LGLSXP, n));
- PROTECT(pos = allocVector(INTSXP, n));
- for (i = 0; i < n; i++) LOGICAL(ind)[i] = 0;
-
- k = 0;
- GMode(2, dd);
- PROTECT(x = duplicate(x));
- PROTECT(y = duplicate(y));
- while (k < npts) {
- if (!GLocator(&xp, &yp, INCHES, dd)) break;
- /*
- * Repeat cex setting from cexbase within loop
- * so that if window is redrawn
- * (e.g., conver/uncover window)
- * during identifying (i.e., between clicks)
- * we reset cex properly.
- */
- gpptr(dd)->cex = gpptr(dd)->cexbase;
- dmin = DBL_MAX;
- imin = -1;
- for (i = 0; i < n; i++) {
- xi = REAL(x)[i];
- yi = REAL(y)[i];
- GConvert(&xi, &yi, USER, INCHES, dd);
- if (!R_FINITE(xi) || !R_FINITE(yi)) continue;
- d = hypot(xp-xi, yp-yi);
- if (d < dmin) {
- imin = i;
- dmin = d;
- }
- }
- /* can't use warning because we want to print immediately */
- /* might want to handle warn=2? */
- warn = asInteger(GetOption1(install("warn")));
- if (dmin > tol) {
- if(warn >= 0) {
- REprintf(_("warning: no point within %.2f inches\n"), tol);
- R_FlushConsole();
- }
- }
- else if (LOGICAL(ind)[imin]) {
- if(warn >= 0 ) {
- REprintf(_("warning: nearest point already identified\n"));
- R_FlushConsole();
- }
- }
- else {
- k++;
- LOGICAL(ind)[imin] = 1;
-
- if (atpen) {
- xi = xp;
- yi = yp;
- INTEGER(pos)[imin] = 0;
- /* now record where to replot if necessary */
- GConvert(&xp, &yp, INCHES, USER, dd);
- REAL(x)[imin] = xp; REAL(y)[imin] = yp;
- } else {
- xi = REAL(x)[imin];
- yi = REAL(y)[imin];
- GConvert(&xi, &yi, USER, INCHES, dd);
- if (fabs(xp-xi) >= fabs(yp-yi)) {
- if (xp >= xi)
- INTEGER(pos)[imin] = 4;
- else
- INTEGER(pos)[imin] = 2;
- } else {
- if (yp >= yi)
- INTEGER(pos)[imin] = 3;
- else
- INTEGER(pos)[imin] = 1;
- }
- }
- if (plot) {
- drawLabel(xi, yi, INTEGER(pos)[imin], offset,
- CHAR(STRING_ELT(l, imin % nl)),
- getCharCE(STRING_ELT(l, imin % nl)), dd);
- GMode(0, dd);
- GMode(2, dd);
- }
- }
- }
- GMode(0, dd);
- PROTECT(ans = allocList(2));
- SETCAR(ans, ind);
- SETCADR(ans, pos);
- if (GRecording(call, dd)) {
- /* If we are recording, save enough information to be able to
- redraw the text labels beside identified points */
- PROTECT(saveans = allocList(8));
- SETCAR(saveans, name);
- SETCADR(saveans, ind);
- SETCADDR(saveans, pos);
- SETCADDDR(saveans, x);
- SETCAD4R(saveans, y);
- SETCAR(nthcdr(saveans,5), Offset);
- SETCAR(nthcdr(saveans,6), l);
- SETCAR(nthcdr(saveans,7), ScalarLogical(plot));
-
- GErecordGraphicOperation(op, saveans, dd);
- UNPROTECT(1);
- }
- UNPROTECT(5);
-
- return ans;
- }
-}
-
-/* strheight(str, units, cex, font, vfont, ...) || strwidth() */
-#define DO_STR_DIM(KIND) \
-{ \
- SEXP ans, str, ch, font, vfont; \
- int i, n, units; \
- double cex, cexsave; \
- pGEDevDesc dd = GEcurrentDevice(); \
- args = CDR(args); \
- if (length(args) < 5) error(_("too few arguments")); \
- \
- str = CAR(args); \
- if (isSymbol(str) || isLanguage(str)) \
- str = coerceVector(str, EXPRSXP); \
- else if (!isExpression(str)) \
- str = coerceVector(str, STRSXP); \
- PROTECT(str); \
- args = CDR(args); \
- \
- if ((units = asInteger(CAR(args))) == NA_INTEGER || units < 0) \
- error(_("invalid units")); \
- if(units == 1) GCheckState(dd); \
- args = CDR(args); \
- \
- if (isNull(CAR(args))) \
- cex = gpptr(dd)->cex; \
- else if (!R_FINITE((cex = asReal(CAR(args)))) || cex <= 0.0) \
- error(_("invalid '%s' value"), "cex"); \
- args = CDR(args); \
- PROTECT(font = FixupFont(CAR(args), NA_INTEGER)); args = CDR(args); \
- PROTECT(vfont = FixupVFont(CAR(args))); args = CDR(args); \
- GSavePars(dd); \
- ProcessInlinePars(args, dd); \
- \
- /* 'vfont' trumps inline 'family' */ \
- if (!isNull(vfont) && !isExpression(str)) { \
- strncpy(gpptr(dd)->family, "Her ", 201); \
- gpptr(dd)->family[3] = (char)INTEGER(vfont)[0]; \
- gpptr(dd)->font = INTEGER(vfont)[1]; \
- } else gpptr(dd)->font = INTEGER(font)[0]; \
- \
- n = LENGTH(str); \
- PROTECT(ans = allocVector(REALSXP, n)); \
- cexsave = gpptr(dd)->cex; \
- gpptr(dd)->cex = cex * gpptr(dd)->cexbase; \
- for (i = 0; i < n; i++) \
- if (isExpression(str)) \
- REAL(ans)[i] = GExpression ## KIND(VECTOR_ELT(str, i), \
- GMapUnits(units), dd); \
- else { \
- ch = STRING_ELT(str, i); \
- REAL(ans)[i] = (ch == NA_STRING) ? 0.0 : \
- GStr ## KIND(CHAR(ch), getCharCE(ch), GMapUnits(units), dd); \
- } \
- gpptr(dd)->cex = cexsave; \
- GRestorePars(dd); \
- UNPROTECT(4); \
- return ans; \
-}
-
-SEXP C_strHeight(SEXP args)
-DO_STR_DIM(Height)
-
-SEXP C_strWidth (SEXP args)
-DO_STR_DIM(Width)
-
-#undef DO_STR_DIM
-
-
-static int *dnd_lptr;
-static int *dnd_rptr;
-static double *dnd_hght;
-static double *dnd_xpos;
-static double dnd_hang;
-static double dnd_offset;
-
-static void drawdend(int node, double *x, double *y, SEXP dnd_llabels,
- pGEDevDesc dd)
-{
-/* Recursive function for 'hclust' dendrogram drawing:
- * Do left + Do right + Do myself
- * "do" : 1) label leafs (if there are) and __
- * 2) find coordinates to draw the | |
- * 3) return (*x,*y) of "my anchor"
- */
- double xl, xr, yl, yr;
- double xx[4], yy[4];
- int k;
-
- *y = dnd_hght[node-1];
- /* left part */
- k = dnd_lptr[node-1];
- if (k > 0) drawdend(k, &xl, &yl, dnd_llabels, dd);
- else {
- xl = dnd_xpos[-k-1];
- yl = (dnd_hang >= 0) ? *y - dnd_hang : 0;
- if(STRING_ELT(dnd_llabels, -k-1) != NA_STRING)
- GText(xl, yl-dnd_offset, USER,
- CHAR(STRING_ELT(dnd_llabels, -k-1)),
- getCharCE(STRING_ELT(dnd_llabels, -k-1)),
- 1.0, 0.3, 90.0, dd);
- }
- /* right part */
- k = dnd_rptr[node-1];
- if (k > 0) drawdend(k, &xr, &yr, dnd_llabels, dd);
- else {
- xr = dnd_xpos[-k-1];
- yr = (dnd_hang >= 0) ? *y - dnd_hang : 0;
- if(STRING_ELT(dnd_llabels, -k-1) != NA_STRING)
- GText(xr, yr-dnd_offset, USER,
- CHAR(STRING_ELT(dnd_llabels, -k-1)),
- getCharCE(STRING_ELT(dnd_llabels, -k-1)),
- 1.0, 0.3, 90.0, dd);
- }
- xx[0] = xl; yy[0] = yl;
- xx[1] = xl; yy[1] = *y;
- xx[2] = xr; yy[2] = *y;
- xx[3] = xr; yy[3] = yr;
- GPolyline(4, xx, yy, USER, dd);
- *x = 0.5 * (xl + xr);
-}
-
-
-SEXP C_dend(SEXP args)
-{
- double x, y;
- int n;
-
- SEXP dnd_llabels, xpos;
- pGEDevDesc dd;
-
- dd = GEcurrentDevice();
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 6)
- error(_("too few arguments"));
-
- /* n */
- n = asInteger(CAR(args));
- if (n == NA_INTEGER || n < 2)
- goto badargs;
- args = CDR(args);
-
- /* merge */
- if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2*n)
- goto badargs;
- dnd_lptr = &(INTEGER(CAR(args))[0]);
- dnd_rptr = &(INTEGER(CAR(args))[n]);
- args = CDR(args);
-
- /* height */
- if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
- goto badargs;
- dnd_hght = REAL(CAR(args));
- args = CDR(args);
-
- /* ord = order(x$order) */
- if (length(CAR(args)) != n+1)
- goto badargs;
- PROTECT(xpos = coerceVector(CAR(args), REALSXP));
- dnd_xpos = REAL(xpos);
- args = CDR(args);
-
- /* hang */
- dnd_hang = asReal(CAR(args));
- if (!R_FINITE(dnd_hang))
- goto badargs;
- dnd_hang = dnd_hang * (dnd_hght[n-1] - dnd_hght[0]);
- args = CDR(args);
-
- /* labels */
- if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n+1)
- goto badargs;
- dnd_llabels = CAR(args);
- args = CDR(args);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
- gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cex;
- dnd_offset = GConvertYUnits(GStrWidth("m", CE_ANY, INCHES, dd), INCHES,
- USER, dd);
-
- /* override par("xpd") and force clipping to figure region
- NOTE: don't override to _reduce_ clipping region */
- if (gpptr(dd)->xpd < 1)
- gpptr(dd)->xpd = 1;
-
- GMode(1, dd);
- drawdend(n, &x, &y, dnd_llabels, dd);
- GMode(0, dd);
- GRestorePars(dd);
- UNPROTECT(1);
- return R_NilValue;
-
- badargs:
- error(_("invalid dendrogram input"));
- return R_NilValue;/* never used; to keep -Wall happy */
-}
-
-SEXP C_dendwindow(SEXP args)
-{
- int i, imax, n;
- double pin, *ll, tmp, yval, *y, ymin, ymax, yrange, m;
- SEXP merge, height, llabels, str;
- const void *vmax;
- pGEDevDesc dd;
-
- dd = GEcurrentDevice();
- GCheckState(dd);
- args = CDR(args);
- if (length(args) < 5)
- error(_("too few arguments"));
- n = asInteger(CAR(args));
- if (n == NA_INTEGER || n < 2)
- goto badargs;
- args = CDR(args);
- if (TYPEOF(CAR(args)) != INTSXP || length(CAR(args)) != 2 * n)
- goto badargs;
- merge = CAR(args);
-
- args = CDR(args);
- if (TYPEOF(CAR(args)) != REALSXP || length(CAR(args)) != n)
- goto badargs;
- height = CAR(args);
-
- args = CDR(args);
- dnd_hang = asReal(CAR(args));
- if (!R_FINITE(dnd_hang))
- goto badargs;
-
- args = CDR(args);
- if (TYPEOF(CAR(args)) != STRSXP || length(CAR(args)) != n + 1)
- goto badargs;
- llabels = CAR(args);
-
- args = CDR(args);
- GSavePars(dd);
- ProcessInlinePars(args, dd);
- gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cex;
- dnd_offset = GStrWidth("m", CE_ANY, INCHES, dd);
- vmax = vmaxget();
- /* n is the number of merges, so the points are labelled 1 ... n+1 */
- y = (double*)R_alloc(n+1, sizeof(double));
- ll = (double*)R_alloc(n+1, sizeof(double));
- dnd_lptr = &(INTEGER(merge)[0]);
- dnd_rptr = &(INTEGER(merge)[n]);
- ymax = ymin = REAL(height)[0];
- for (i = 1; i < n; i++) {
- m = REAL(height)[i];
- if (m > ymax)
- ymax = m;
- else if (m < ymin)
- ymin = m;
- }
- pin = gpptr(dd)->pin[1];
- for (i = 0; i <= n; i++) {
- str = STRING_ELT(llabels, i);
- ll[i] = (str == NA_STRING) ? 0.0 :
- GStrWidth(CHAR(str), getCharCE(str), INCHES, dd) + dnd_offset;
- }
-
- imax = -1; yval = -DBL_MAX;
- if (dnd_hang >= 0) {
- ymin = ymax - (1 + dnd_hang) * (ymax - ymin);
- yrange = ymax - ymin;
- /* determine leaf heights */
- for (i = 0; i < n; i++) {
- if (dnd_lptr[i] < 0)
- y[-dnd_lptr[i] - 1] = REAL(height)[i];
- if (dnd_rptr[i] < 0)
- y[-dnd_rptr[i] - 1] = REAL(height)[i];
- }
- /* determine the most extreme label depth */
- /* assuming that we are using the full plot */
- /* window for the tree itself */
- for (i = 0; i <= n; i++) {
- tmp = ((ymax - y[i]) / yrange) * pin + ll[i];
- if (tmp > yval) {
- yval = tmp;
- imax = i;
- }
- }
- }
- else {
- yrange = ymax;
- for (i = 0; i <= n; i++) {
- tmp = pin + ll[i];
- if (tmp > yval) {
- yval = tmp;
- imax = i;
- }
- }
- }
- /* now determine how much to scale */
- ymin = ymax - (pin/(pin - ll[imax])) * yrange;
- GScale(1.0, n+1.0, 1 /* x */, dd);
- GScale(ymin, ymax, 2 /* y */, dd);
- GMapWin2Fig(dd);
- GRestorePars(dd);
- vmaxset(vmax);
- return R_NilValue;
- badargs:
- error(_("invalid dendrogram input"));
- return R_NilValue;/* never used; to keep -Wall happy */
-}
-
-
-SEXP C_erase(SEXP args)
-{
- SEXP col;
- pGEDevDesc dd = GEcurrentDevice();
- args = CDR(args);
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE));
- GSavePars(dd);
- GMode(1, dd);
- GRect(0.0, 0.0, 1.0, 1.0, NDC, INTEGER(col)[0], R_TRANWHITE, dd);
- GMode(0, dd);
- GRestorePars(dd);
- UNPROTECT(1);
- return R_NilValue;
-}
-
-/* symbols(..) in ../library/base/R/symbols.R : */
-
-/* utility just computing range() */
-static Rboolean SymbolRange(double *x, int n, double *xmax, double *xmin)
-{
- int i;
- *xmax = -DBL_MAX;
- *xmin = DBL_MAX;
- for(i = 0; i < n; i++)
- if (R_FINITE(x[i])) {
- if (*xmax < x[i]) *xmax = x[i];
- if (*xmin > x[i]) *xmin = x[i];
- }
- return(*xmax >= *xmin && *xmin >= 0);
-}
-
-static void CheckSymbolPar(SEXP p, int *nr, int *nc)
-{
- SEXP dim = getAttrib(p, R_DimSymbol);
- switch(length(dim)) {
- case 0:
- *nr = LENGTH(p);
- *nc = 1;
- break;
- case 1:
- *nr = INTEGER(dim)[0];
- *nc = 1;
- break;
- case 2:
- *nr = INTEGER(dim)[0];
- *nc = INTEGER(dim)[1];
- break;
- default:
- *nr = 0;
- *nc = 0;
- }
- if (*nr == 0 || *nc == 0)
- error(_("invalid symbol parameter vector"));
-}
-
-/* Internal symbols(x, y, type, data, inches, bg, fg, ...) */
-SEXP C_symbols(SEXP args)
-{
- SEXP x, y, p, fg, bg;
- int i, j, nr, nc, nbg, nfg, type;
- double pmax, pmin, inches, rx, ry;
- double xx, yy, p0, p1, p2, p3, p4;
- double *pp, *xp, *yp;
- const void *vmax;
-
- pGEDevDesc dd = GEcurrentDevice();
- GCheckState(dd);
- args = CDR(args);
-
- if (length(args) < 7)
- error(_("too few arguments"));
-
- PROTECT(x = coerceVector(CAR(args), REALSXP)); args = CDR(args);
- PROTECT(y = coerceVector(CAR(args), REALSXP)); args = CDR(args);
- if (!isNumeric(x) || !isNumeric(y) || length(x) <= 0 || LENGTH(x) <= 0)
- error(_("invalid symbol coordinates"));
-
- type = asInteger(CAR(args)); args = CDR(args);
-
- /* data: */
- p = PROTECT(coerceVector(CAR(args), REALSXP)); args = CDR(args);
- CheckSymbolPar(p, &nr, &nc);
- if (LENGTH(x) != nr || LENGTH(y) != nr)
- error(_("x/y/parameter length mismatch"));
-
- inches = asReal(CAR(args)); args = CDR(args);
- if (!R_FINITE(inches) || inches < 0)
- inches = 0;
-
- PROTECT(bg = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- nbg = LENGTH(bg);
-
- PROTECT(fg = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- nfg = LENGTH(fg);
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
-
- GMode(1, dd);
- switch (type) {
- case 1: /* circles */
- if (nc != 1)
- error(_("invalid circles data"));
- if (!SymbolRange(REAL(p), nr, &pmax, &pmin))
- error(_("invalid symbol parameter"));
- for (i = 0; i < nr; i++) {
- if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
- R_FINITE(REAL(p)[i])) {
- rx = REAL(p)[i];
- /* For GCircle the radius is always in INCHES */
- if (inches > 0)
- rx *= inches / pmax;
- else
- rx = GConvertXUnits(rx, USER, INCHES, dd);
- /* GCircle sets radius zero to one pixel, but does
- not change very small non-zero radii */
- GCircle(REAL(x)[i], REAL(y)[i], USER, rx,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
- }
- }
- break;
- case 2: /* squares */
- if(nc != 1)
- error(_("invalid squares data"));
- if(!SymbolRange(REAL(p), nr, &pmax, &pmin))
- error(_("invalid symbol parameter"));
- for (i = 0; i < nr; i++) {
- if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
- R_FINITE(REAL(p)[i])) {
- p0 = REAL(p)[i];
- xx = REAL(x)[i];
- yy = REAL(y)[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- if (inches > 0) {
- p0 *= inches / pmax;
- rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
- }
- else {
- rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
- }
- /* FIXME: should this skip 0-sized symbols? */
- GRect(xx - rx, yy - rx, xx + rx, yy + rx, DEVICE,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
- }
- }
- break;
- case 3: /* rectangles */
- if (nc != 2)
- error(_("invalid rectangles data (need 2 columns)"));
- if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
- error(_("invalid symbol parameter"));
- for (i = 0; i < nr; i++) {
- if (R_FINITE(REAL(x)[i]) && R_FINITE(REAL(y)[i]) &&
- R_FINITE(REAL(p)[i]) && R_FINITE(REAL(p)[i+nr])) {
- xx = REAL(x)[i];
- yy = REAL(y)[i];
- GConvert(&xx, &yy, USER, DEVICE, dd);
- p0 = REAL(p)[i];
- p1 = REAL(p)[i+nr];
- if (inches > 0) {
- p0 *= inches / pmax;
- p1 *= inches / pmax;
- rx = GConvertXUnits(0.5 * p0, INCHES, DEVICE, dd);
- ry = GConvertYUnits(0.5 * p1, INCHES, DEVICE, dd);
- }
- else {
- rx = GConvertXUnits(0.5 * p0, USER, DEVICE, dd);
- ry = GConvertYUnits(0.5 * p1, USER, DEVICE, dd);
- }
- /* FIXME: should this skip 0-sized symbols? */
- GRect(xx - rx, yy - ry, xx + rx, yy + ry, DEVICE,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
-
- }
- }
- break;
- case 4: /* stars */
- if (nc < 3)
- error(_("invalid stars data"));
- if (!SymbolRange(REAL(p), nc * nr, &pmax, &pmin))
- error(_("invalid symbol parameter"));
- vmax = vmaxget();
- pp = (double*)R_alloc(nc, sizeof(double));
- xp = (double*)R_alloc(nc, sizeof(double));
- yp = (double*)R_alloc(nc, sizeof(double));
- p1 = 2.0 * M_PI / nc;
- for (i = 0; i < nr; i++) {
- xx = REAL(x)[i];
- yy = REAL(y)[i];
- if (R_FINITE(xx) && R_FINITE(yy)) {
- GConvert(&xx, &yy, USER, NDC, dd);
- if (inches > 0) {
- for(j = 0; j < nc; j++) {
- p0 = REAL(p)[i + j * nr];
- if (!R_FINITE(p0)) p0 = 0;
- pp[j] = (p0 / pmax) * inches;
- }
- }
- else {
- for(j = 0; j < nc; j++) {
- p0 = REAL(p)[i + j * nr];
- if (!R_FINITE(p0)) p0 = 0;
- pp[j] = GConvertXUnits(p0, USER, INCHES, dd);
- }
- }
- /* FIXME: should this skip 0-sized symbols? */
- for(j = 0; j < nc; j++) {
- xp[j] = GConvertXUnits(pp[j] * cos(j * p1),
- INCHES, NDC, dd) + xx;
- yp[j] = GConvertYUnits(pp[j] * sin(j * p1),
- INCHES, NDC, dd) + yy;
- }
- GPolygon(nc, xp, yp, NDC,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
- }
- }
- vmaxset(vmax);
- break;
- case 5: /* thermometers */
- if (nc != 3 && nc != 4)
- error(_("invalid thermometers data (need 3 or 4 columns)"));
- SymbolRange(REAL(p)+2*nr/* <-- pointer arith*/, nr, &pmax, &pmin);
- if (pmax < pmin)
- error(_("invalid 'thermometers[, %s]'"),
- (nc == 4)? "3:4" : "3");
- if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
- warning(_("'thermometers[, %s]' not in [0,1] -- may look funny"),
- (nc == 4)? "3:4" : "3");
- if (!SymbolRange(REAL(p), 2 * nr, &pmax, &pmin))
- error(_("invalid 'thermometers[, 1:2]'"));
- for (i = 0; i < nr; i++) {
- xx = REAL(x)[i];
- yy = REAL(y)[i];
- if (R_FINITE(xx) && R_FINITE(yy)) {
- p0 = REAL(p)[i];
- p1 = REAL(p)[i + nr];
- p2 = REAL(p)[i + 2 * nr];
- p3 = (nc == 4)? REAL(p)[i + 3 * nr] : 0.;
- if (R_FINITE(p0) && R_FINITE(p1) &&
- R_FINITE(p2) && R_FINITE(p3)) {
- if (p2 < 0) p2 = 0; else if (p2 > 1) p2 = 1;
- if (p3 < 0) p3 = 0; else if (p3 > 1) p3 = 1;
- GConvert(&xx, &yy, USER, NDC, dd);
- if (inches > 0) {
- p0 *= inches / pmax;
- p1 *= inches / pmax;
- rx = GConvertXUnits(0.5 * p0, INCHES, NDC, dd);
- ry = GConvertYUnits(0.5 * p1, INCHES, NDC, dd);
- }
- else {
- rx = GConvertXUnits(0.5 * p0, USER, NDC, dd);
- ry = GConvertYUnits(0.5 * p1, USER, NDC, dd);
- }
- GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
- GRect(xx - rx, yy - (1 - 2 * p2) * ry,
- xx + rx, yy - (1 - 2 * p3) * ry,
- NDC,
- INTEGER(fg)[i % nfg], INTEGER(fg)[i % nfg], dd);
- GLine(xx - rx, yy, xx - 1.5 * rx, yy, NDC, dd);
- GLine(xx + rx, yy, xx + 1.5 * rx, yy, NDC, dd);
-
- }
- }
- }
- break;
- case 6: /* boxplots (wid, hei, loWhsk, upWhsk, medProp) */
- if (nc != 5)
- error(_("invalid 'boxplots' data (need 5 columns)"));
- pmax = -DBL_MAX;
- pmin = DBL_MAX;
- for(i = 0; i < nr; i++) {
- p4 = REAL(p)[i + 4 * nr]; /* median proport. in [0,1] */
- if (pmax < p4) pmax = p4;
- if (pmin > p4) pmin = p4;
- }
- if (pmin < 0. || pmax > 1.) /* S-PLUS has an error here */
- warning(_("'boxplots[, 5]' outside [0,1] -- may look funny"));
- if (!SymbolRange(REAL(p), 4 * nr, &pmax, &pmin))
- error(_("invalid 'boxplots[, 1:4]'"));
- for (i = 0; i < nr; i++) {
- xx = REAL(x)[i];
- yy = REAL(y)[i];
- if (R_FINITE(xx) && R_FINITE(yy)) {
- p0 = REAL(p)[i]; /* width */
- p1 = REAL(p)[i + nr]; /* height */
- p2 = REAL(p)[i + 2 * nr];/* lower whisker */
- p3 = REAL(p)[i + 3 * nr];/* upper whisker */
- p4 = REAL(p)[i + 4 * nr];/* median proport. in [0,1] */
- if (R_FINITE(p0) && R_FINITE(p1) &&
- R_FINITE(p2) && R_FINITE(p3) && R_FINITE(p4)) {
- GConvert(&xx, &yy, USER, NDC, dd);
- if (inches > 0) {
- p0 *= inches / pmax;
- p1 *= inches / pmax;
- p2 *= inches / pmax;
- p3 *= inches / pmax;
- p0 = GConvertXUnits(p0, INCHES, NDC, dd);
- p1 = GConvertYUnits(p1, INCHES, NDC, dd);
- p2 = GConvertYUnits(p2, INCHES, NDC, dd);
- p3 = GConvertYUnits(p3, INCHES, NDC, dd);
- }
- else {
- p0 = GConvertXUnits(p0, USER, NDC, dd);
- p1 = GConvertYUnits(p1, USER, NDC, dd);
- p2 = GConvertYUnits(p2, USER, NDC, dd);
- p3 = GConvertYUnits(p3, USER, NDC, dd);
- }
- rx = 0.5 * p0;
- ry = 0.5 * p1;
- p4 = (1 - p4) * (yy - ry) + p4 * (yy + ry);
- /* Box */
- GRect(xx - rx, yy - ry, xx + rx, yy + ry, NDC,
- INTEGER(bg)[i % nbg], INTEGER(fg)[i % nfg], dd);
- /* Median */
- GLine(xx - rx, p4, xx + rx, p4, NDC, dd);
- /* Lower Whisker */
- GLine(xx, yy - ry, xx, yy - ry - p2, NDC, dd);
- /* Upper Whisker */
- GLine(xx, yy + ry, xx, yy + ry + p3, NDC, dd);
- }
- }
- }
- break;
- default:
- error(_("invalid symbol type"));
- }
- GMode(0, dd);
- GRestorePars(dd);
- UNPROTECT(5);
- return R_NilValue;
-}
-
-SEXP C_xspline(SEXP args)
-{
- SEXP sx, sy, ss, col, border, res, ans = R_NilValue;
- int i, nx;
- int ncol, nborder;
- double *x, *y;
- Rboolean open, repEnds, draw;
- double *xx;
- double *yy;
- const void *vmaxsave;
- R_GE_gcontext gc;
-
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
- args = CDR(args);
-
- if (length(args) < 6) error(_("too few arguments"));
- /* (x,y) is checked in R via xy.coords() ; no need here : */
- sx = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- sy = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- nx = LENGTH(sx);
- ss = SETCAR(args, coerceVector(CAR(args), REALSXP)); args = CDR(args);
- open = asLogical(CAR(args)); args = CDR(args);
- repEnds = asLogical(CAR(args)); args = CDR(args);
- draw = asLogical(CAR(args)); args = CDR(args);
-
- PROTECT(col = FixupCol(CAR(args), R_TRANWHITE)); args = CDR(args);
- ncol = LENGTH(col);
- if(ncol < 1)
- error(_("incorrect length for '%s' argument"), "col");
- if(ncol > 1)
- warning(_("incorrect length for '%s' argument"), "col");
-
- PROTECT(border = FixupCol(CAR(args), gpptr(dd)->fg)); args = CDR(args);
- nborder = LENGTH(border);
- if(nborder < 1)
- error(_("incorrect length for '%s' argument"), "border");
- if(nborder > 1)
- warning(_("incorrect length for '%s' argument"), "border");
-
- GSavePars(dd);
- ProcessInlinePars(args, dd);
- /* Paul 2008-12-05
- * Convert GP to gcontext AFTER ProcessInlinePars
- */
- gcontextFromGP(&gc, dd);
-
- GMode(1, dd);
-
- x = REAL(sx);
- y = REAL(sy);
- vmaxsave = vmaxget();
- xx = (double *) R_alloc(nx, sizeof(double));
- yy = (double *) R_alloc(nx, sizeof(double));
- if (!xx || !yy)
- error("unable to allocate memory (in xspline)");
- for (i = 0; i < nx; i++) {
- xx[i] = x[i];
- yy[i] = y[i];
- GConvert(&(xx[i]), &(yy[i]), USER, DEVICE, dd);
- }
- GClip(dd);
- gc.col = INTEGER(border)[0];
- gc.fill = INTEGER(col)[0];
- res = GEXspline(nx, xx, yy, REAL(ss), open, repEnds, draw, &gc, dd);
- vmaxset(vmaxsave);
- UNPROTECT(2);
-
- if(!draw) {
- SEXP nm, tmpx, tmpy;
- double *xx, *yy, *x0, *y0;
- PROTECT(ans = res);
- PROTECT(nm = allocVector(STRSXP, 2));
- SET_STRING_ELT(nm, 0, mkChar("x"));
- SET_STRING_ELT(nm, 1, mkChar("y"));
- setAttrib(ans, R_NamesSymbol, nm);
- nx = LENGTH(VECTOR_ELT(ans, 0));
- x0 = REAL(VECTOR_ELT(ans, 0));
- y0 = REAL(VECTOR_ELT(ans, 1));
- PROTECT(tmpx = allocVector(REALSXP, nx));
- PROTECT(tmpy = allocVector(REALSXP, nx));
- xx = REAL(tmpx);
- yy = REAL(tmpy);
- for (i = 0; i < nx; i++) {
- xx[i] = x0[i];
- yy[i] = y0[i];
- GConvert(&(xx[i]), &(yy[i]), DEVICE, USER, dd);
- }
- SET_VECTOR_ELT(ans, 0, tmpx);
- SET_VECTOR_ELT(ans, 1, tmpy);
- UNPROTECT(4);
- }
-
- GMode(0, dd);
- GRestorePars(dd);
- return ans;
-}
-
-/* clip(x1, x2, y1, y2) */
-SEXP C_clip(SEXP args)
-{
- SEXP ans = R_NilValue;
- double x1, x2, y1, y2;
- pGEDevDesc dd = GEcurrentDevice();
-
- args = CDR(args);
- x1 = asReal(CAR(args));
- if(!R_FINITE(x1)) error("invalid '%s' argument", "x1");
- args = CDR(args);
- x2 = asReal(CAR(args));
- if(!R_FINITE(x2)) error("invalid '%s' argument", "x2");
- args = CDR(args);
- y1 = asReal(CAR(args));
- if(!R_FINITE(y1)) error("invalid '%s' argument", "y1");
- args = CDR(args);
- y2 = asReal(CAR(args));
- if(!R_FINITE(y2)) error("invalid '%s' argument", "y2");
-
- GConvert(&x1, &y1, USER, DEVICE, dd);
- GConvert(&x2, &y2, USER, DEVICE, dd);
- GESetClip(x1, y1, x2, y2, dd);
- /* avoid GClip resetting this */
- gpptr(dd)->oldxpd = gpptr(dd)->xpd;
- return ans;
-}
-
-/* convert[XY](x, from to) */
-SEXP C_convertX(SEXP args)
-{
- SEXP ans = R_NilValue, x;
- int from, to, i, n;
- double *rx;
- pGEDevDesc gdd = GEcurrentDevice();
-
- args = CDR(args);
- x = CAR(args);
- if (TYPEOF(x) != REALSXP) error(_("invalid '%s' argument"), "x");
- n = LENGTH(x);
- from = asInteger(CADR(args));
- if (from == NA_INTEGER || from <= 0 || from > 17 )
- error(_("invalid '%s' argument"), "from");
- to = asInteger(CADDR(args));
- if (to == NA_INTEGER || to <= 0 || to > 17 )
- error(_("invalid '%s' argument"), "to");
- from--; to--;
-
- PROTECT(ans = duplicate(x));
- rx = REAL(ans);
- for (i = 0; i < n; i++) rx[i] = GConvertX(rx[i], from, to, gdd);
- UNPROTECT(1);
-
- return ans;
-}
-
-SEXP C_convertY(SEXP args)
-{
- SEXP ans = R_NilValue, x;
- int from, to, i, n;
- double *rx;
- pGEDevDesc gdd = GEcurrentDevice();
-
- args = CDR(args);
- x = CAR(args);
- if (TYPEOF(x) != REALSXP) error(_("invalid '%s' argument"), "x");
- n = LENGTH(x);
- from = asInteger(CADR(args));
- if (from == NA_INTEGER || from <= 0 || from > 17 )
- error(_("invalid '%s' argument"), "from");
- to = asInteger(CADDR(args));
- if (to == NA_INTEGER || to <= 0 || to > 17 )
- error(_("invalid '%s' argument"), "to");
- from--; to--;
-
- PROTECT(ans = duplicate(x));
- rx = REAL(ans);
- for (i = 0; i < n; i++) rx[i] = GConvertY(rx[i], from, to, gdd);
- UNPROTECT(1);
-
- return ans;
-}
diff --git a/com.oracle.truffle.r.native/library/graphics/src/plot3d.c b/com.oracle.truffle.r.native/library/graphics/src/plot3d.c
deleted file mode 100644
index 1271cfb61af413d81f4bc701c083f552cab9bf6e..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/plot3d.c
+++ /dev/null
@@ -1,2031 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1998--2014 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/
- */
-
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include "Defn.h"
-#include <float.h> /* for DBL_MAX */
-#include <Rmath.h>
-#include "../../grDevices/src/main_Graphics.h"
-#include "../../../gnur/R-3.1.3/src/include/Print.h"
-#include <R_ext/Boolean.h>
-
-#include "graphics.h"
-
-static void TypeCheck(SEXP s, SEXPTYPE type)
-{
- if (TYPEOF(s) != type)
- error("invalid type passed to graphics function");
-}
-
-
- /* F i l l e d C o n t o u r P l o t s */
-
- /* R o s s I h a k a, M a r c h 1 9 9 9 */
-
-static void
-FindCutPoints(double low, double high,
- double x1, double y1, double z1,
- double x2, double y2, double z2,
- double *x, double *y, double *z,
- int *npt)
-{
- double c;
-
- if (z1 > z2 ) {
- if (z2 > high || z1 < low) return;
- if (z1 < high) {
- x[*npt] = x1;
- y[*npt] = y1;
- z[*npt] = z1;
- ++*npt;
- } else if (z1 == R_PosInf) {
- x[*npt] = x2;
- y[*npt] = y1;
- z[*npt] = z2;
- ++*npt;
- } else { /* z1 >= high, z2 in range */
- c = (z1 - high) / (z1 - z2);
- x[*npt] = x1 + c * (x2 - x1);
- y[*npt] = y1;
- z[*npt] = z1 + c * (z2 - z1);
- ++*npt;
- }
- if (z2 == R_NegInf) {
- x[*npt] = x1;
- y[*npt] = y1;
- z[*npt] = z1;
- ++*npt;
- } else if (z2 <= low) { /* and z1 in range */
- c = (z2 -low) / (z2 - z1);
- x[*npt] = x2 - c * (x2 - x1);
- y[*npt] = y1;
- z[*npt] = z2 - c * (z2 - z1);
- ++*npt;
- }
- } else if (z1 < z2) {
- if (z2 < low || z1 > high) return;
- if (z1 > low) {
- x[*npt] = x1;
- y[*npt] = y1;
- z[*npt] = z1;
- ++*npt;
- } else if (z1 == R_NegInf) {
- x[*npt] = x2;
- y[*npt] = y1;
- z[*npt] = z2;;
- ++*npt;
- } else { /* and z2 in range */
- c = (z1 - low) / (z1 - z2);
- x[*npt] = x1 + c * (x2 - x1);
- y[*npt] = y1;
- z[*npt] = z1 + c * (z2 - z1);
- ++*npt;
- }
- if (z2 < high) {
-#ifdef OMIT
- /* Don't repeat corner vertices */
- x[*npt] = x2;
- y[*npt] = y2;
- z[*npt] = z2;
- ++*npt;
-#endif
- } else if (z2 == R_PosInf) {
- x[*npt] = x1;
- y[*npt] = y1;
- z[*npt] = z1;
- ++*npt;
- } else { /* z2 high, z1 in range */
- c = (z2 - high) / (z2 - z1);
- x[*npt] = x2 - c * (x2 - x1);
- y[*npt] = y1;
- z[*npt] = z2 - c * (z2 - z1);
- ++*npt;
- }
- } else {
- if(low <= z1 && z1 <= high) {
- x[*npt] = x1;
- y[*npt] = y1;
- z[*npt] = z1;
- ++*npt;
-#ifdef OMIT
- /* Don't repeat corner vertices */
- x[*npt] = x2;
- y[*npt] = y2;
- z[*npt] = z2;
- ++*npt;
-#endif
- }
- }
-}
-
-/* FIXME - This could pretty easily be adapted to handle NA */
-/* values on the grid. Just search the diagonals for cutpoints */
-/* instead of the cell sides. Use the same switch idea as in */
-/* contour above. There are 5 cases to handle. */
-
-static void
-FindPolygonVertices(double low, double high,
- double x1, double x2, double y1, double y2,
- double z11, double z21, double z12, double z22,
- double *x, double *y, double *z, int *npt)
-{
- *npt = 0;
- FindCutPoints(low, high, x1, y1, z11, x2, y1, z21, x, y, z, npt);
- FindCutPoints(low, high, y1, x2, z21, y2, x2, z22, y, x, z, npt);
- FindCutPoints(low, high, x2, y2, z22, x1, y2, z12, x, y, z, npt);
- FindCutPoints(low, high, y2, x1, z12, y1, x1, z11, y, x, z, npt);
-}
-
-/* filledcontour(x, y, z, levels, col) */
-SEXP C_filledcontour(SEXP args)
-{
- SEXP sx, sy, sz, sc, scol;
- double *x, *y, *z, *c;
- rcolor *col;
- int i, j, k, npt, nx, ny, nc, ncol, colsave, xpdsave;
- double px[8], py[8], pz[8];
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- PrintDefaults(); /* prepare for labelformat */
-
- args = CDR(args);
- sx = PROTECT(coerceVector(CAR(args), REALSXP));
- nx = LENGTH(sx);
- args = CDR(args);
-
- sy = PROTECT(coerceVector(CAR(args), REALSXP));
- ny = LENGTH(sy);
- args = CDR(args);
- if (nx < 2 || ny < 2) error(_("insufficient 'x' or 'y' values"));
-
- // do it this way as coerceVector can lose dims, e.g. for a list matrix
- sz = CAR(args);
- if (nrows(sz) != nx || ncols(sz) != ny) error(_("dimension mismatch"));
- sz = PROTECT(coerceVector(sz, REALSXP));
- args = CDR(args);
-
- sc = PROTECT(coerceVector(CAR(args), REALSXP)); /* levels */
- nc = length(sc);
- args = CDR(args);
-
- if (nc < 1) error(_("no contour values"));
-
- PROTECT(scol = FixupCol(CAR(args), R_TRANWHITE));
- ncol = length(scol);
-
- /* Shorthand Pointers */
-
- x = REAL(sx);
- y = REAL(sy);
- z = REAL(sz);
- c = REAL(sc);
- col = (rcolor *) INTEGER(scol);
-
- /* Check of grid coordinates */
- /* We want them to all be finite */
- /* and in strictly ascending order */
-
- if (nx < 1 || ny < 1) goto badxy;
- if (!R_FINITE(x[0])) goto badxy;
- if (!R_FINITE(y[0])) goto badxy;
- for (i = 1; i < nx; i++)
- if (!R_FINITE(x[i]) || x[i] <= x[i - 1]) goto badxy;
- for (j = 1; j < ny; j++)
- if (!R_FINITE(y[j]) || y[j] <= y[j - 1]) goto badxy;
-
- /* Check of the contour levels */
-
- if (!R_FINITE(c[0])) goto badlev;
- for (k = 1; k < nc; k++)
- if (!R_FINITE(c[k]) || c[k] <= c[k - 1]) goto badlev;
-
- colsave = gpptr(dd)->col;
- xpdsave = gpptr(dd)->xpd;
- /* override par("xpd") and force clipping to plot region */
- gpptr(dd)->xpd = 0;
-
- GMode(1, dd);
-
- for (i = 1; i < nx; i++) {
- for (j = 1; j < ny; j++) {
- for (k = 1; k < nc ; k++) {
- FindPolygonVertices(c[k - 1], c[k],
- x[i - 1], x[i],
- y[j - 1], y[j],
- z[i - 1 + (j - 1) * nx],
- z[i + (j - 1) * nx],
- z[i - 1 + j * nx],
- z[i + j * nx],
- px, py, pz, &npt);
- if (npt > 2)
- GPolygon(npt, px, py, USER, col[(k-1) % ncol],
- R_TRANWHITE, dd);
- }
- }
- }
- GMode(0, dd);
- gpptr(dd)->col = colsave;
- gpptr(dd)->xpd = xpdsave;
- UNPROTECT(5);
- return R_NilValue;
-
- badxy:
- error(_("invalid x / y values or limits"));
- badlev:
- error(_("invalid contour levels: must be strictly increasing"));
- return R_NilValue; /* never used; to keep -Wall happy */
-}
-
-
-
- /* I m a g e R e n d e r i n g */
-
-
-/* image(x, y, z, col, breaks) */
-SEXP C_image(SEXP args)
-{
- SEXP sx, sy, sz, sc;
- double *x, *y;
- int *z, tmp;
- unsigned *c;
- int i, j, nx, ny, nc, xpdsave;
- rcolor colsave;
- pGEDevDesc dd = GEcurrentDevice();
-
- GCheckState(dd);
-
- args = CDR(args);
-
- sx = PROTECT(coerceVector(CAR(args), REALSXP));
- nx = LENGTH(sx);
- args = CDR(args);
-
- sy = PROTECT(coerceVector(CAR(args), REALSXP));
- ny = LENGTH(sy);
- args = CDR(args);
-
- sz = PROTECT(coerceVector(CAR(args), INTSXP));
- args = CDR(args);
-
- PROTECT(sc = FixupCol(CAR(args), R_TRANWHITE));
- nc = LENGTH(sc);
-
- /* Shorthand Pointers */
-
- x = REAL(sx);
- y = REAL(sy);
- z = INTEGER(sz);
- c = (unsigned*)INTEGER(sc);
-
- /* Check of grid coordinates now done in C code */
-
- colsave = gpptr(dd)->col;
- xpdsave = gpptr(dd)->xpd;
- /* override par("xpd") and force clipping to plot region */
- gpptr(dd)->xpd = 0;
-
- GMode(1, dd);
-
- for (i = 0; i < nx - 1 ; i++) {
- for (j = 0; j < ny - 1; j++) {
- tmp = z[i + j * (nx - 1)];
- if (tmp >= 0 && tmp < nc && tmp != NA_INTEGER)
- GRect(x[i], y[j], x[i+1], y[j+1], USER, c[tmp],
- R_TRANWHITE, dd);
- }
- }
- GMode(0, dd);
- gpptr(dd)->col = colsave;
- gpptr(dd)->xpd = xpdsave;
- UNPROTECT(4);
- return R_NilValue;
-}
-
- /* P e r s p e c t i v e S u r f a c e P l o t s */
-
-/* Conversion of degrees to radians */
-
-#define DegToRad(x) (DEG2RAD * x)
-
-/* Definitions of data structures for vectors and */
-/* transformations in homogeneous 3d coordinates */
-
-typedef double Vector3d[4];
-typedef double Trans3d[4][4];
-
-/* The viewing transformation matrix. */
-
-static Trans3d VT;
-
-static void TransVector (Vector3d u, Trans3d T, Vector3d v)
-{
- double sum;
- int i, j;
-
- for (i = 0; i < 4; i++) {
- sum = 0;
- for (j = 0; j < 4; j++)
- sum = sum + u[j] * T[j][i];
- v[i] = sum;
- }
-}
-
-static void Accumulate (Trans3d T)
-{
- Trans3d U;
- double sum;
- int i, j, k;
-
- for (i = 0; i < 4; i++) {
- for (j = 0; j < 4; j++) {
- sum = 0;
- for (k = 0; k < 4; k++)
- sum = sum + VT[i][k] * T[k][j];
- U[i][j] = sum;
- }
- }
- for (i = 0; i < 4; i++)
- for (j = 0; j < 4; j++)
- VT[i][j] = U[i][j];
-}
-
-static void SetToIdentity (Trans3d T)
-{
- int i, j;
- for (i = 0; i < 4; i++) {
- for (j = 0; j < 4; j++)
- T[i][j] = 0;
- T[i][i] = 1;
- }
-}
-
-static void Translate (double x, double y, double z)
-{
- Trans3d T;
- SetToIdentity(T);
- T[3][0] = x;
- T[3][1] = y;
- T[3][2] = z;
- Accumulate(T);
-}
-
-static void Scale (double x, double y, double z)
-{
- Trans3d T;
- SetToIdentity(T);
- T[0][0] = x;
- T[1][1] = y;
- T[2][2] = z;
- Accumulate(T);
-}
-
-static void XRotate (double angle)
-{
- double c, s;
- Trans3d T;
- SetToIdentity(T);
- c = cos(DegToRad(angle));
- s = sin(DegToRad(angle));
- T[1][1] = c;
- T[2][1] = -s;
- T[2][2] = c;
- T[1][2] = s;
- Accumulate(T);
-}
-
-static void YRotate (double angle)
-{
- double c, s;
- Trans3d T;
- SetToIdentity(T);
- c = cos(DegToRad(angle));
- s = sin(DegToRad(angle));
- T[0][0] = c;
- T[2][0] = s;
- T[2][2] = c;
- T[0][2] = -s;
- Accumulate(T);
-}
-
-static void ZRotate (double angle)
-{
- double c, s;
- Trans3d T;
- SetToIdentity(T);
- c = cos(DegToRad(angle));
- s = sin(DegToRad(angle));
- T[0][0] = c;
- T[1][0] = -s;
- T[1][1] = c;
- T[0][1] = s;
- Accumulate(T);
-}
-
-static void Perspective (double d)
-{
- Trans3d T;
-
- SetToIdentity(T);
- T[2][3] = -1 / d;
- Accumulate(T);
-}
-
-
-/* Set up the light source */
-static double Light[4];
-static double Shade;
-static Rboolean DoLighting;
-
-static void SetUpLight(double theta, double phi)
-{
- double u[4];
- u[0] = 0; u[1] = -1; u[2] = 0; u[3] = 1;
- SetToIdentity(VT); /* Initialization */
- XRotate(-phi); /* colatitude rotation */
- ZRotate(theta); /* azimuthal rotation */
- TransVector(u, VT, Light); /* transform */
-}
-
-static double FacetShade(double *u, double *v)
-{
- double nx, ny, nz, sum;
- nx = u[1] * v[2] - u[2] * v[1];
- ny = u[2] * v[0] - u[0] * v[2];
- nz = u[0] * v[1] - u[1] * v[0];
- sum = sqrt(nx * nx + ny * ny + nz * nz);
- if (sum == 0) sum = 1;
- nx /= sum;
- ny /= sum;
- nz /= sum;
- sum = 0.5 * (nx * Light[0] + ny * Light[1] + nz * Light[2] + 1);
- return pow(sum, Shade);
-}
-
-
-/* For each facet, determine the farthest point from the eye. */
-/* Sorting the facets so that these depths are decreasing */
-/* yields an occlusion compatible ordering. */
-/* Note that we ignore z values when doing this. */
-
-static void DepthOrder(double *z, double *x, double *y, int nx, int ny,
- double *depth, int *indx)
-{
- int i, ii, j, jj, nx1, ny1;
- Vector3d u, v;
- double d;
- nx1 = nx - 1;
- ny1 = ny - 1;
- for (i = 0; i < nx1 * ny1; i++)
- indx[i] = i;
- for (i = 0; i < nx1; i++)
- for (j = 0; j < ny1; j++) {
- d = -DBL_MAX;
- for (ii = 0; ii <= 1; ii++)
- for (jj = 0; jj <= 1; jj++) {
- u[0] = x[i + ii];
- u[1] = y[j + jj];
- /* Originally I had the following line here: */
- /* u[2] = z[i+ii+(j+jj)*nx]; */
- /* But this leads to artifacts. */
- /* It has been replaced by the following line: */
- u[2] = 0;
- u[3] = 1;
- if (R_FINITE(u[0]) && R_FINITE(u[1]) && R_FINITE(u[2])) {
- TransVector(u, VT, v);
- if (v[3] > d) d = v[3];
- }
- }
- depth[i+j*nx1] = -d;
-
- }
- /* Determine the depth ordering of the facets to ensure
- that they are drawn in an occlusion compatible order. */
- rsort_with_index(depth, indx, nx1 * ny1);
-}
-
-
-static void DrawFacets(double *z, double *x, double *y, int nx, int ny,
- int *indx, double xs, double ys, double zs,
- int *col, int ncol, int border)
-{
- double xx[4], yy[4], shade = 0;
- Vector3d u, v;
- int i, j, k, n, nx1, ny1, icol, nv;
- unsigned int newcol, r, g, b;
- pGEDevDesc dd;
- dd = GEcurrentDevice();
- nx1 = nx - 1;
- ny1 = ny - 1;
- n = nx1 * ny1;
- for (k = 0; k < n; k++) {
- nv = 0;
- i = indx[k] % nx1;
- j = indx[k] / nx1;
- icol = (i + j * nx1) % ncol;
- if (DoLighting) {
- /* Note we must scale here */
- u[0] = xs * (x[i+1] - x[i]);
- u[1] = ys * (y[j] - y[j+1]);
- u[2] = zs * (z[(i+1)+j*nx] - z[i+(j+1)*nx]);
- v[0] = xs * (x[i+1] - x[i]);
- v[1] = ys * (y[j+1] - y[j]);
- v[2] = zs * (z[(i+1)+(j+1)*nx] - z[i+j*nx]);
- shade = FacetShade(u, v);
- }
- u[0] = x[i]; u[1] = y[j];
- u[2] = z[i + j * nx]; u[3] = 1;
- if (R_FINITE(u[0]) && R_FINITE(u[1]) && R_FINITE(u[2])) {
- TransVector(u, VT, v);
- xx[nv] = v[0] / v[3];
- yy[nv] = v[1] / v[3];
- nv++;
- }
-
- u[0] = x[i + 1]; u[1] = y[j];
- u[2] = z[i + 1 + j * nx]; u[3] = 1;
- if (R_FINITE(u[0]) && R_FINITE(u[1]) && R_FINITE(u[2])) {
- TransVector(u, VT, v);
- xx[nv] = v[0] / v[3];
- yy[nv] = v[1] / v[3];
- nv++;
- }
-
- u[0] = x[i + 1]; u[1] = y[j + 1];
- u[2] = z[i + 1 + (j + 1) * nx]; u[3] = 1;
- if (R_FINITE(u[0]) && R_FINITE(u[1]) && R_FINITE(u[2])) {
- TransVector(u, VT, v);
- xx[nv] = v[0] / v[3];
- yy[nv] = v[1] / v[3];
- nv++;
- }
-
- u[0] = x[i]; u[1] = y[j + 1];
- u[2] = z[i + (j + 1) * nx]; u[3] = 1;
- if (R_FINITE(u[0]) && R_FINITE(u[1]) && R_FINITE(u[2])) {
- TransVector(u, VT, v);
- xx[nv] = v[0] / v[3];
- yy[nv] = v[1] / v[3];
- nv++;
- }
-
- if (nv > 2) {
- newcol = col[icol];
- if (DoLighting) {
- // shade can degenerate to NaN
- if(R_FINITE(shade)) {
- r = (int)(shade * R_RED(newcol));
- g = (int)(shade * R_GREEN(newcol));
- b = (int)(shade * R_BLUE(newcol));
- newcol = R_RGB(r, g, b);
- GPolygon(nv, xx, yy, USER, newcol, border, dd);
- }
- } else
- GPolygon(nv, xx, yy, USER, newcol, border, dd);
- }
- }
-}
-
-
-static void PerspWindow(double *xlim, double *ylim, double *zlim, pGEDevDesc dd)
-{
- double pin1, pin2, scale, xdelta, ydelta, xscale, yscale, xadd, yadd;
- double xmax, xmin, ymax, ymin, xx, yy;
- Vector3d u, v;
- int i, j, k;
-
- xmax = xmin = ymax = ymin = 0;
- u[3] = 1;
- for (i = 0; i < 2; i++) {
- u[0] = xlim[i];
- for (j = 0; j < 2; j++) {
- u[1] = ylim[j];
- for (k = 0; k < 2; k++) {
- u[2] = zlim[k];
- TransVector(u, VT, v);
- xx = v[0] / v[3];
- yy = v[1] / v[3];
- if (xx > xmax) xmax = xx;
- if (xx < xmin) xmin = xx;
- if (yy > ymax) ymax = yy;
- if (yy < ymin) ymin = yy;
- }
- }
- }
- pin1 = GConvertXUnits(1.0, NPC, INCHES, dd);
- pin2 = GConvertYUnits(1.0, NPC, INCHES, dd);
- xdelta = fabs(xmax - xmin);
- ydelta = fabs(ymax - ymin);
- xscale = pin1 / xdelta;
- yscale = pin2 / ydelta;
- scale = (xscale < yscale) ? xscale : yscale;
- xadd = .5 * (pin1 / scale - xdelta);
- yadd = .5 * (pin2 / scale - ydelta);
- GScale(xmin - xadd, xmax + xadd, 1, dd);
- GScale(ymin - yadd, ymax + yadd, 2, dd);
- GMapWin2Fig(dd);
-}
-
-static int LimitCheck(double *lim, double *c, double *s)
-{
- if (!R_FINITE(lim[0]) || !R_FINITE(lim[1]) || lim[0] >= lim[1])
- return 0;
- *s = 0.5 * fabs(lim[1] - lim[0]);
- *c = 0.5 * (lim[1] + lim[0]);
- return 1;
-}
-
-/* PerspBox: The following code carries out a visibility test
- on the surfaces of the xlim/ylim/zlim box around the plot.
- If front = 0, only the faces with their inside toward the
- eyepoint are drawn. If front = 1, only the faces with
- their outside toward the eye are drawn. This lets us carry
- out hidden line removal by drawing any faces which will be
- obscured before the surface, and those which will not be
- obscured after the surface.
-
- Unfortunately as PR#202 showed, this is simplistic as the surface
- can go outside the box.
-*/
-
-/* The vertices of the box */
-static short int Vertex[8][3] = {
- {0, 0, 0},
- {0, 0, 1},
- {0, 1, 0},
- {0, 1, 1},
- {1, 0, 0},
- {1, 0, 1},
- {1, 1, 0},
- {1, 1, 1},
-};
-
-/* The vertices visited when tracing a face */
-static short int Face[6][4] = {
- {0, 1, 5, 4},
- {2, 6, 7, 3},
- {0, 2, 3, 1},
- {4, 5, 7, 6},
- {0, 4, 6, 2},
- {1, 3, 7, 5},
-};
-
-/* The edges drawn when tracing a face */
-static short int Edge[6][4] = {
- { 0, 1, 2, 3},
- { 4, 5, 6, 7},
- { 8, 7, 9, 0},
- { 2,10, 5,11},
- { 3,11, 4, 8},
- { 9, 6,10, 1},
-};
-
-
-static void PerspBox(int front, double *x, double *y, double *z,
- char *EdgeDone, pGEDevDesc dd)
-{
- Vector3d u0, v0, u1, v1, u2, v2, u3, v3;
- double d[3], e[3];
- int f, i, p0, p1, p2, p3, nearby;
- int ltysave = gpptr(dd)->lty;
-
- gpptr(dd)->lty = front ? LTY_DOTTED : LTY_SOLID;
-
- for (f = 0; f < 6; f++) {
- p0 = Face[f][0];
- p1 = Face[f][1];
- p2 = Face[f][2];
- p3 = Face[f][3];
-
- u0[0] = x[Vertex[p0][0]];
- u0[1] = y[Vertex[p0][1]];
- u0[2] = z[Vertex[p0][2]];
- u0[3] = 1;
- u1[0] = x[Vertex[p1][0]];
- u1[1] = y[Vertex[p1][1]];
- u1[2] = z[Vertex[p1][2]];
- u1[3] = 1;
- u2[0] = x[Vertex[p2][0]];
- u2[1] = y[Vertex[p2][1]];
- u2[2] = z[Vertex[p2][2]];
- u2[3] = 1;
- u3[0] = x[Vertex[p3][0]];
- u3[1] = y[Vertex[p3][1]];
- u3[2] = z[Vertex[p3][2]];
- u3[3] = 1;
-
- TransVector(u0, VT, v0);
- TransVector(u1, VT, v1);
- TransVector(u2, VT, v2);
- TransVector(u3, VT, v3);
-
- /* Visibility test. */
- /* Determine whether the surface normal is toward the eye. */
- /* Note that we only draw lines once. */
-
- for (i = 0; i < 3; i++) {
- d[i] = v1[i]/v1[3] - v0[i]/v0[3];
- e[i] = v2[i]/v2[3] - v1[i]/v1[3];
- }
- nearby = (d[0]*e[1] - d[1]*e[0]) < 0;
-
- if ((front && nearby) || (!front && !nearby)) {
- if (!EdgeDone[Edge[f][0]]++)
- GLine(v0[0]/v0[3], v0[1]/v0[3],
- v1[0]/v1[3], v1[1]/v1[3], USER, dd);
- if (!EdgeDone[Edge[f][1]]++)
- GLine(v1[0]/v1[3], v1[1]/v1[3],
- v2[0]/v2[3], v2[1]/v2[3], USER, dd);
- if (!EdgeDone[Edge[f][2]]++)
- GLine(v2[0]/v2[3], v2[1]/v2[3],
- v3[0]/v3[3], v3[1]/v3[3], USER, dd);
- if (!EdgeDone[Edge[f][3]]++)
- GLine(v3[0]/v3[3], v3[1]/v3[3],
- v0[0]/v0[3], v0[1]/v0[3], USER, dd);
- }
- }
- gpptr(dd)->lty = ltysave;
-}
-
-/* PerspAxes:
- */
-
-/* Starting vertex for possible axes */
-static short int AxisStart[8] = { 0, 0, 2, 4, 0, 4, 2, 6 };
-
-/* Tick vector for possible axes */
-static short int TickVector[8][3] = {
- {0, -1, -1},
- {-1, 0, -1},
- {0, 1, -1},
- {1, 0, -1},
- {-1, -1, 0},
- {1, -1, 0},
- {-1, 1, 0},
- {1, 1, 0}};
-
-static int lowest(double y1, double y2, double y3, double y4) {
- return ((y1 <= y2) && (y1 <= y3) && (y1 <= y4));
-}
-
-static double labelAngle(double x1, double y1, double x2, double y2) {
- double dx, dy;
- double angle;
- dx = fabs(x2 - x1);
- if (x2 > x1)
- dy = y2 - y1;
- else
- dy = y1 - y2;
- if (dx == 0) {
- if (dy > 0)
- angle = 90.;
- else
- angle = 270.;
- } else {
-#ifdef HAVE_ATAN2PI
- angle = 180. * atan2(dy, dx);
-#else
- angle = (180. / M_PI) * atan2(dy, dx);
-#endif
- }
- return angle;
-}
-
-static void PerspAxis(double *x, double *y, double *z,
- int axis, int axisType, int nTicks, int tickType,
- const char *label, cetype_t enc, pGEDevDesc dd)
-{
- Vector3d u1={0.,0.,0.,0.}, u2={0.,0.,0.,0.}, u3={0.,0.,0.,0.}, v1, v2, v3;
- double tickLength = .03; /* proportion of axis length */
- double min, max, d_frac;
- double *range = NULL; /* -Wall */
- double axp[3];
- int nint, i;
- SEXP at, lab;
- double cexsave = gpptr(dd)->cex;
- int fontsave = gpptr(dd)->font;
-
-
- switch (axisType) {
- case 0:
- min = x[0]; max = x[1]; range = x; break;
- case 1:
- min = y[0]; max = y[1]; range = y; break;
- case 2:
- min = z[0]; max = z[1]; range = z; break;
- }
- d_frac = 0.1*(max - min);
- nint = nTicks - 1; if(!nint) nint++;
- i = nint;
- GPretty(&min, &max, &nint);
- /* GPretty() rarely gives values too much outside range ..
- 2D axis() clip these, we play cheaper */
- while((min < range[0] - d_frac || range[1] + d_frac < max) && i < 20) {
- nint = ++i;
- min = range[0];
- max = range[1];
- GPretty(&min, &max, &nint);
- }
- axp[0] = min;
- axp[1] = max;
- axp[2] = nint;
- /* Do the following calculations for both ticktypes */
- switch (axisType) {
- case 0:
- u1[0] = min;
- u1[1] = y[Vertex[AxisStart[axis]][1]];
- u1[2] = z[Vertex[AxisStart[axis]][2]];
- break;
- case 1:
- u1[0] = x[Vertex[AxisStart[axis]][0]];
- u1[1] = min;
- u1[2] = z[Vertex[AxisStart[axis]][2]];
- break;
- case 2:
- u1[0] = x[Vertex[AxisStart[axis]][0]];
- u1[1] = y[Vertex[AxisStart[axis]][1]];
- u1[2] = min;
- break;
- }
- u1[0] = u1[0] + tickLength*(x[1]-x[0])*TickVector[axis][0];
- u1[1] = u1[1] + tickLength*(y[1]-y[0])*TickVector[axis][1];
- u1[2] = u1[2] + tickLength*(z[1]-z[0])*TickVector[axis][2];
- u1[3] = 1;
- switch (axisType) {
- case 0:
- u2[0] = max;
- u2[1] = u1[1];
- u2[2] = u1[2];
- break;
- case 1:
- u2[0] = u1[0];
- u2[1] = max;
- u2[2] = u1[2];
- break;
- case 2:
- u2[0] = u1[0];
- u2[1] = u1[1];
- u2[2] = max;
- break;
- }
- u2[3] = 1;
- /* The axis label has to be further out for "detailed" ticks
- in order to leave room for the tick labels */
- switch (tickType) {
- case 1: /* "simple": just an arrow parallel to axis, indicating direction
- of increase */
- u3[0] = u1[0] + tickLength*(x[1]-x[0])*TickVector[axis][0];
- u3[1] = u1[1] + tickLength*(y[1]-y[0])*TickVector[axis][1];
- u3[2] = u1[2] + tickLength*(z[1]-z[0])*TickVector[axis][2];
- break;
- case 2:
- u3[0] = u1[0] + 2.5*tickLength*(x[1]-x[0])*TickVector[axis][0];
- u3[1] = u1[1] + 2.5*tickLength*(y[1]-y[0])*TickVector[axis][1];
- u3[2] = u1[2] + 2.5*tickLength*(z[1]-z[0])*TickVector[axis][2];
- break;
- }
- switch (axisType) {
- case 0:
- u3[0] = (min + max)/2;
- break;
- case 1:
- u3[1] = (min + max)/2;
- break;
- case 2:
- u3[2] = (min + max)/2;
- break;
- }
- u3[3] = 1;
- TransVector(u1, VT, v1);
- TransVector(u2, VT, v2);
- TransVector(u3, VT, v3);
- /* Draw axis label */
- /* change in 2.5.0 to use cex.lab and font.lab */
- gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cexlab;
- gpptr(dd)->font = gpptr(dd)->fontlab;
- GText(v3[0]/v3[3], v3[1]/v3[3], USER, label, enc, .5, .5,
- labelAngle(v1[0]/v1[3], v1[1]/v1[3], v2[0]/v2[3], v2[1]/v2[3]),
- dd);
- /* Draw axis ticks */
- /* change in 2.5.0 to use cex.axis and font.axis */
- gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cexaxis;
- gpptr(dd)->font = gpptr(dd)->fontaxis;
- switch (tickType) {
- case 1: /* "simple": just an arrow parallel to axis, indicating direction
- of increase */
- /* arrow head is 0.25 inches long, with angle 30 degrees,
- and drawn at v2 end of line */
- GArrow(v1[0]/v1[3], v1[1]/v1[3],
- v2[0]/v2[3], v2[1]/v2[3], USER,
- 0.1, 10, 2, dd);
- break;
- case 2: /* "detailed": normal ticks as per 2D plots */
- PROTECT(at = CreateAtVector(axp, range, 7, FALSE));
- PROTECT(lab = labelformat(at));
- for (i=0; i<length(at); i++) {
- switch (axisType) {
- case 0:
- u1[0] = REAL(at)[i];
- u1[1] = y[Vertex[AxisStart[axis]][1]];
- u1[2] = z[Vertex[AxisStart[axis]][2]];
- break;
- case 1:
- u1[0] = x[Vertex[AxisStart[axis]][0]];
- u1[1] = REAL(at)[i];
- u1[2] = z[Vertex[AxisStart[axis]][2]];
- break;
- case 2:
- u1[0] = x[Vertex[AxisStart[axis]][0]];
- u1[1] = y[Vertex[AxisStart[axis]][1]];
- u1[2] = REAL(at)[i];
- break;
- }
- u1[3] = 1;
- u2[0] = u1[0] + tickLength*(x[1]-x[0])*TickVector[axis][0];
- u2[1] = u1[1] + tickLength*(y[1]-y[0])*TickVector[axis][1];
- u2[2] = u1[2] + tickLength*(z[1]-z[0])*TickVector[axis][2];
- u2[3] = 1;
- u3[0] = u2[0] + tickLength*(x[1]-x[0])*TickVector[axis][0];
- u3[1] = u2[1] + tickLength*(y[1]-y[0])*TickVector[axis][1];
- u3[2] = u2[2] + tickLength*(z[1]-z[0])*TickVector[axis][2];
- u3[3] = 1;
- TransVector(u1, VT, v1);
- TransVector(u2, VT, v2);
- TransVector(u3, VT, v3);
- /* Draw tick line */
- GLine(v1[0]/v1[3], v1[1]/v1[3],
- v2[0]/v2[3], v2[1]/v2[3], USER, dd);
- /* Draw tick label */
- GText(v3[0]/v3[3], v3[1]/v3[3], USER,
- CHAR(STRING_ELT(lab, i)),
- getCharCE(STRING_ELT(lab, i)),
- .5, .5, 0, dd);
- }
- UNPROTECT(2);
- break;
- }
- gpptr(dd)->cex = cexsave;
- gpptr(dd)->font = fontsave;
-}
-
-/* Determine the transformed (x, y) coordinates (in USER space)
- * for the four corners of the x-y plane of the persp plot
- * These will be used to determine which sides of the persp
- * plot to label with axes
- * The strategy is to determine which corner has the lowest y-value
- * to decide which of the x- and y-axes to label AND which corner
- * has the lowest x-value to decide which of the z-axes to label
- */
-static void PerspAxes(double *x, double *y, double *z,
- const char *xlab, cetype_t xenc,
- const char *ylab, cetype_t yenc,
- const char *zlab, cetype_t zenc,
- int nTicks, int tickType, pGEDevDesc dd)
-{
- int xAxis=0, yAxis=0, zAxis=0; /* -Wall */
- int xpdsave;
- Vector3d u0, u1, u2, u3;
- Vector3d v0, v1, v2, v3;
- u0[0] = x[0];
- u0[1] = y[0];
- u0[2] = z[0];
- u0[3] = 1;
- u1[0] = x[1];
- u1[1] = y[0];
- u1[2] = z[0];
- u1[3] = 1;
- u2[0] = x[0];
- u2[1] = y[1];
- u2[2] = z[0];
- u2[3] = 1;
- u3[0] = x[1];
- u3[1] = y[1];
- u3[2] = z[0];
- u3[3] = 1;
- TransVector(u0, VT, v0);
- TransVector(u1, VT, v1);
- TransVector(u2, VT, v2);
- TransVector(u3, VT, v3);
-
- /* to fit in the axis labels */
- xpdsave = gpptr(dd)->xpd;
- gpptr(dd)->xpd = 1;
-
- /* Figure out which X and Y axis to draw */
- if (lowest(v0[1]/v0[3], v1[1]/v1[3], v2[1]/v2[3], v3[1]/v3[3])) {
- xAxis = 0;
- yAxis = 1;
- } else if (lowest(v1[1]/v1[3], v0[1]/v0[3], v2[1]/v2[3], v3[1]/v3[3])) {
- xAxis = 0;
- yAxis = 3;
- } else if (lowest(v2[1]/v2[3], v1[1]/v1[3], v0[1]/v0[3], v3[1]/v3[3])) {
- xAxis = 2;
- yAxis = 1;
- } else if (lowest(v3[1]/v3[3], v1[1]/v1[3], v2[1]/v2[3], v0[1]/v0[3])) {
- xAxis = 2;
- yAxis = 3;
- } else
- warning(_("Axis orientation not calculated"));
- PerspAxis(x, y, z, xAxis, 0, nTicks, tickType, xlab, xenc, dd);
- PerspAxis(x, y, z, yAxis, 1, nTicks, tickType, ylab, yenc, dd);
- /* Figure out which Z axis to draw */
- if (lowest(v0[0]/v0[3], v1[0]/v1[3], v2[0]/v2[3], v3[0]/v3[3])) {
- zAxis = 4;
- } else if (lowest(v1[0]/v1[3], v0[0]/v0[3], v2[0]/v2[3], v3[0]/v3[3])) {
- zAxis = 5;
- } else if (lowest(v2[0]/v2[3], v1[0]/v1[3], v0[0]/v0[3], v3[0]/v3[3])) {
- zAxis = 6;
- } else if (lowest(v3[0]/v3[3], v1[0]/v1[3], v2[0]/v2[3], v0[0]/v0[3])) {
- zAxis = 7;
- } else
- warning(_("Axis orientation not calculated"));
- PerspAxis(x, y, z, zAxis, 2, nTicks, tickType, zlab, zenc, dd);
-
- gpptr(dd)->xpd = xpdsave;
-}
-
-SEXP C_persp(SEXP args)
-{
- SEXP x, y, z, xlim, ylim, zlim;
- SEXP depth, indx;
- SEXP col, border, xlab, ylab, zlab;
- double theta, phi, r, d;
- double ltheta, lphi;
- double expand, xc = 0.0, yc = 0.0, zc = 0.0, xs = 0.0, ys = 0.0, zs = 0.0;
- int i, j, scale, ncol, dobox, doaxes, nTicks, tickType;
- char EdgeDone[12]; /* Which edges have been drawn previously */
- pGEDevDesc dd;
-
- args = CDR(args);
- if (length(args) < 24) /* 24 plus any inline par()s */
- error(_("too few parameters"));
-
- PROTECT(x = coerceVector(CAR(args), REALSXP));
- if (length(x) < 2) error(_("invalid '%s' argument"), "x");
- args = CDR(args);
-
- PROTECT(y = coerceVector(CAR(args), REALSXP));
- if (length(y) < 2) error(_("invalid '%s' argument"), "y");
- args = CDR(args);
-
- PROTECT(z = coerceVector(CAR(args), REALSXP));
- if (!isMatrix(z) || nrows(z) != length(x) || ncols(z) != length(y))
- error(_("invalid '%s' argument"), "z");
- args = CDR(args);
-
- PROTECT(xlim = coerceVector(CAR(args), REALSXP));
- if (length(xlim) != 2) error(_("invalid '%s' argument"), "xlim");
- args = CDR(args);
-
- PROTECT(ylim = coerceVector(CAR(args), REALSXP));
- if (length(ylim) != 2) error(_("invalid '%s' argument"), "ylim");
- args = CDR(args);
-
- PROTECT(zlim = coerceVector(CAR(args), REALSXP));
- if (length(zlim) != 2) error(_("invalid '%s' argument"), "zlim");
- args = CDR(args);
-
- /* Checks on x/y/z Limits */
-
- if (!LimitCheck(REAL(xlim), &xc, &xs))
- error(_("invalid 'x' limits"));
- if (!LimitCheck(REAL(ylim), &yc, &ys))
- error(_("invalid 'y' limits"));
- if (!LimitCheck(REAL(zlim), &zc, &zs))
- error(_("invalid 'z' limits"));
-
- theta = asReal(CAR(args)); args = CDR(args);
- phi = asReal(CAR(args)); args = CDR(args);
- r = asReal(CAR(args)); args = CDR(args);
- d = asReal(CAR(args)); args = CDR(args);
- scale = asLogical(CAR(args)); args = CDR(args);
- expand = asReal(CAR(args)); args = CDR(args);
- col = CAR(args); args = CDR(args);
- border = CAR(args); args = CDR(args);
- ltheta = asReal(CAR(args)); args = CDR(args);
- lphi = asReal(CAR(args)); args = CDR(args);
- Shade = asReal(CAR(args)); args = CDR(args);
- dobox = asLogical(CAR(args)); args = CDR(args);
- doaxes = asLogical(CAR(args)); args = CDR(args);
- nTicks = asInteger(CAR(args)); args = CDR(args);
- tickType = asInteger(CAR(args)); args = CDR(args);
- xlab = CAR(args); args = CDR(args);
- ylab = CAR(args); args = CDR(args);
- zlab = CAR(args); args = CDR(args);
- if (!isString(xlab) || length(xlab) < 1)
- error(_("'xlab' must be a character vector of length 1"));
- if (!isString(ylab) || length(ylab) < 1)
- error(_("'ylab' must be a character vector of length 1"));
- if (!isString(zlab) || length(zlab) < 1)
- error(_("'zlab' must be a character vector of length 1"));
-
- if (R_FINITE(Shade) && Shade <= 0) Shade = 1;
- if (R_FINITE(ltheta) && R_FINITE(lphi) && R_FINITE(Shade))
- DoLighting = TRUE;
- else
- DoLighting = FALSE;
-
- if (!scale) {
- double s;
- s = xs;
- if (s < ys) s = ys;
- if (s < zs) s = zs;
- xs = s; ys = s; zs = s;
- }
-
- /* Parameter Checks */
-
- if (!R_FINITE(theta) || !R_FINITE(phi) || !R_FINITE(r) || !R_FINITE(d) ||
- d < 0 || r < 0)
- error(_("invalid viewing parameters"));
- if (!R_FINITE(expand) || expand < 0)
- error(_("invalid '%s' value"), "expand");
- if (scale == NA_LOGICAL)
- scale = 0;
- if ((nTicks == NA_INTEGER) || (nTicks < 0))
- error(_("invalid '%s' value"), "nticks");
- if ((tickType == NA_INTEGER) || (tickType < 1) || (tickType > 2))
- error(_("invalid '%s' value"), "ticktype");
-
- dd = GEcurrentDevice();
-
-#if 0
- GNewPlot(GRecording(call, dd));
-#endif
-
- PROTECT(col = FixupCol(col, gpptr(dd)->bg));
- ncol = LENGTH(col);
- if (ncol < 1) error(_("invalid '%s' specification"), "col");
- if(!R_OPAQUE(INTEGER(col)[0])) DoLighting = FALSE;
- PROTECT(border = FixupCol(border, gpptr(dd)->fg));
- if (length(border) < 1)
- error(_("invalid '%s' specification"), "border");
-
- GSetState(1, dd);
- GSavePars(dd);
- ProcessInlinePars(args, dd);
- if (length(border) > 1)
- gpptr(dd)->fg = INTEGER(border)[0];
- gpptr(dd)->xlog = gpptr(dd)->ylog = FALSE;
-
- /* Set up the light vector (if any) */
- if (DoLighting)
- SetUpLight(ltheta, lphi);
-
- /* Mark box edges as undrawn */
- for (i = 0; i< 12; i++)
- EdgeDone[i] = 0;
-
- /* Specify the viewing transformation. */
-
- SetToIdentity(VT); /* Initialization */
- Translate(-xc, -yc, -zc); /* center at the origin */
- Scale(1/xs, 1/ys, expand/zs); /* scale extents to [-1,1] */
- XRotate(-90.0); /* rotate x-y plane to horizontal */
- YRotate(-theta); /* azimuthal rotation */
- XRotate(phi); /* elevation rotation */
- Translate(0.0, 0.0, -r - d); /* translate the eyepoint to the origin */
- Perspective(d); /* perspective */
-
- /* Specify the plotting window. */
- /* Here we map the vertices of the cube */
- /* [xmin,xmax]*[ymin,ymax]*[zmin,zmax] */
- /* to the screen and then chose a window */
- /* which is symmetric about (0,0). */
-
- PerspWindow(REAL(xlim), REAL(ylim), REAL(zlim), dd);
-
- /* Compute facet order:
- We order the facets by depth and then draw them back to front.
- This is the "painters" algorithm. */
-
- PROTECT(depth = allocVector(REALSXP, (nrows(z) - 1)*(ncols(z) - 1)));
- PROTECT(indx = allocVector(INTSXP, (nrows(z) - 1)*(ncols(z) - 1)));
- DepthOrder(REAL(z), REAL(x), REAL(y), nrows(z), ncols(z),
- REAL(depth), INTEGER(indx));
-
- GMode(1, dd);
-
- if (dobox) {
- /* Draw (solid) faces which face away from the viewer */
- PerspBox(0, REAL(xlim), REAL(ylim), REAL(zlim), EdgeDone, dd);
- if (doaxes) {
- SEXP xl = STRING_ELT(xlab, 0), yl = STRING_ELT(ylab, 0),
- zl = STRING_ELT(zlab, 0);
- PerspAxes(REAL(xlim), REAL(ylim), REAL(zlim),
- (xl == NA_STRING) ? "" : CHAR(xl), getCharCE(xl),
- (yl == NA_STRING) ? "" : CHAR(yl), getCharCE(yl),
- (zl == NA_STRING) ? "" : CHAR(zl), getCharCE(zl),
- nTicks, tickType, dd);
- }
- }
-
- DrawFacets(REAL(z), REAL(x), REAL(y), nrows(z), ncols(z), INTEGER(indx),
- 1/xs, 1/ys, expand/zs,
- INTEGER(col), ncol, INTEGER(border)[0]);
-
- /* Draw (dotted) not-already-plotted edges of faces which face
- towards from the viewer */
- if (dobox)
- PerspBox(1, REAL(xlim), REAL(ylim), REAL(zlim), EdgeDone, dd);
- GMode(0, dd);
-
- GRestorePars(dd);
- UNPROTECT(10);
-
- PROTECT(x = allocVector(REALSXP, 16));
- PROTECT(y = allocVector(INTSXP, 2));
- for (i = 0; i < 4; i++)
- for (j = 0; j < 4; j++)
- REAL(x)[i + j * 4] = VT[i][j];
- INTEGER(y)[0] = 4;
- INTEGER(y)[1] = 4;
- setAttrib(x, R_DimSymbol, y);
- UNPROTECT(2);
- return x;
-}
-
-/* in src/main */
-#include "../../grDevices/src/main_contour-common.h"
-
-static
-void FindCorners(double width, double height, SEXP label,
- double x0, double y0, double x1, double y1,
- pGEDevDesc dd) {
- double delta = height / width;
- double dx = GConvertXUnits(x1 - x0, USER, INCHES, dd) * delta;
- double dy = GConvertYUnits(y1 - y0, USER, INCHES, dd) * delta;
- dx = GConvertYUnits(dx, INCHES, USER, dd);
- dy = GConvertXUnits(dy, INCHES, USER, dd);
-
- REAL(label)[0] = x0 + dy;
- REAL(label)[4] = y0 - dx;
- REAL(label)[1] = x0 - dy;
- REAL(label)[5] = y0 + dx;
- REAL(label)[3] = x1 + dy;
- REAL(label)[7] = y1 - dx;
- REAL(label)[2] = x1 - dy;
- REAL(label)[6] = y1 + dx;
-}
-static
-int TestLabelIntersection(SEXP label1, SEXP label2) {
-
- int i, j, l1, l2;
- double Ax, Bx, Ay, By, ax, ay, bx, by;
- double dom;
- double result1, result2;
-
- for (i = 0; i < 4; i++) {
- Ax = REAL(label1)[i];
- Ay = REAL(label1)[i+4];
- Bx = REAL(label1)[(i+1)%4];
- By = REAL(label1)[(i+1)%4+4];
- for (j = 0; j < 4; j++) {
- ax = REAL(label2)[j];
- ay = REAL(label2)[j+4];
- bx = REAL(label2)[(j+1)%4];
- by = REAL(label2)[(j+1)%4+4];
-
- dom = Bx*by - Bx*ay - Ax*by + Ax*ay - bx*By + bx*Ay + ax*By - ax*Ay;
- if (dom == 0.0) {
- result1 = -1;
- result2 = -1;
- }
- else {
- result1 = (bx*Ay - ax*Ay - ay*bx - Ax*by + Ax*ay + by*ax) / dom;
-
- if (bx - ax == 0.0) {
- if (by - ay == 0.0)
- result2 = -1;
- else
- result2 = (Ay + (By - Ay) * result1 - ay) / (by - ay);
- }
- else
- result2 = (Ax + (Bx - Ax) * result1 - ax) / (bx - ax);
-
- }
- l1 = (result1 >= 0.0) && (result1 <= 1.0);
- l2 = (result2 >= 0.0) && (result2 <= 1.0);
- if (l1 && l2) return 1;
- }
- }
-
- return 0;
-}
-
-/*** Checks whether a label window is inside view region ***/
-static int LabelInsideWindow(SEXP label, pGEDevDesc dd) {
- int i = 0;
- double x, y;
-
- while (i < 4) {
- x = REAL(label)[i];
- y = REAL(label)[i+4];
- GConvert(&x, &y, USER, NDC, dd);
- /* x = GConvertXUnits(REAL(label)[i], USER, NDC, dd);
- y = GConvertYUnits(REAL(label)[i+4], USER, NDC, dd); */
-
- if ((x < 0) || (x > 1) ||
- (y < 0) || (y > 1))
- return 1;
- i += 1;
- }
- return 0;
-}
-
-static
-int findGapUp(double *xxx, double *yyy, int ns, double labelDistance,
- pGEDevDesc dd) {
- double dX, dY;
- double dXC, dYC;
- double distanceSum = 0;
- int n = 0;
- int jjj = 1;
- while ((jjj < ns) && (distanceSum < labelDistance)) {
- /* Find a gap big enough for the label
- use several segments if necessary
- */
- dX = xxx[jjj] - xxx[jjj - n - 1]; /* jjj - n - 1 == 0 */
- dY = yyy[jjj] - yyy[jjj - n - 1];
- dXC = GConvertXUnits(dX, USER, INCHES, dd);
- dYC = GConvertYUnits(dY, USER, INCHES, dd);
- distanceSum = hypot(dXC, dYC);
- jjj++;
- n++;
- }
- if (distanceSum < labelDistance)
- return 0;
- else
- return n;
-}
-
-static
-int findGapDown(double *xxx, double *yyy, int ns, double labelDistance,
- pGEDevDesc dd) {
- double dX, dY;
- double dXC, dYC;
- double distanceSum = 0;
- int n = 0;
- int jjj = ns - 2;
- while ((jjj > -1) && (distanceSum < labelDistance)) {
- /* Find a gap big enough for the label
- use several segments if necessary
- */
- dX = xxx[jjj] - xxx[jjj + n + 1]; /*jjj + n + 1 == ns -1 */
- dY = yyy[jjj] - yyy[jjj + n + 1];
- dXC = GConvertXUnits(dX, USER, INCHES, dd);
- dYC = GConvertYUnits(dY, USER, INCHES, dd);
- distanceSum = hypot(dXC, dYC);
- jjj--;
- n++;
- }
- if (distanceSum < labelDistance)
- return 0;
- else
- return n;
-}
-
-/* labelList, label1, and label2 are all SEXPs rather than being allocated
- using R_alloc because they need to persist across calls to contour().
- In do_contour() there is a vmaxget() ... vmaxset() around each call to
- contour() to release all of the memory used in the drawing of the
- contour _lines_ at each contour level. We need to keep track of the
- contour _labels_ for _all_ contour levels, hence we have to use a
- different memory allocation mechanism.
-*/
-
-static
-double distFromEdge(double *xxx, double *yyy, int iii, pGEDevDesc dd) {
- return fmin2(fmin2(xxx[iii]-gpptr(dd)->usr[0], gpptr(dd)->usr[1]-xxx[iii]),
- fmin2(yyy[iii]-gpptr(dd)->usr[2], gpptr(dd)->usr[3]-yyy[iii]));
-}
-
-static SEXP labelList;
-static SEGP *ctr_SegDB;
-
-static
-Rboolean useStart(double *xxx, double *yyy, int ns, pGEDevDesc dd) {
- if (distFromEdge(xxx, yyy, 0, dd) < distFromEdge(xxx, yyy, ns-1, dd))
- return TRUE;
- else
- return FALSE;
-}
-
-
-static void contour(SEXP x, int nx, SEXP y, int ny, SEXP z,
- double zc,
- SEXP labels, int cnum,
- Rboolean drawLabels, int method,
- double atom, pGEDevDesc dd)
-{
-/* draw a contour for one given contour level 'zc' */
-
- const void *vmax;
-
- double xend, yend;
- int i, ii, j, jj, ns, dir;
- SEGP seglist, seg, s, start, end;
- double *xxx, *yyy;
-
- double variance, dX, dY, deltaX, deltaY;
- double dXC, dYC;
- int range=0, indx=0, n; /* -Wall */
- double lowestVariance;
- double squareSum;
- int iii, jjj;
- double distanceSum, labelDistance, avgGradient;
- char buffer[255];
- int result;
- double ux, uy, vx, vy;
- double xStart, yStart;
- double dx, dy, dxy;
- double labelHeight;
- SEXP label1 = PROTECT(allocVector(REALSXP, 8));
- SEXP label2;
- SEXP lab;
- Rboolean gotLabel = FALSE;
- Rboolean ddl;/* Don't draw label -- currently unused, i.e. always FALSE*/
-
-#ifdef DEBUG_contour
- Rprintf("contour(lev = %g):\n", zc);
-#endif
-
- vmax = vmaxget();
- /* This R-allocs ctr_SegDB */
- ctr_SegDB = contourLines(REAL(x), nx, REAL(y), ny, REAL(z), zc, atom);
-
- /* The segment database is now assembled. */
- /* Begin following contours. */
- /* 1. Grab a segment */
- /* 2. Follow its tail */
- /* 3. Follow its head */
- /* 4. Draw the contour */
-
- for (i = 0; i < nx - 1; i++)
- for (j = 0; j < ny - 1; j++) {
- while ((seglist = ctr_SegDB[i + j * nx])) {
- ii = i; jj = j;
- start = end = seglist;
- ctr_SegDB[i + j * nx] = seglist->next;
- xend = seglist->x1;
- yend = seglist->y1;
- while ((dir = ctr_segdir(xend, yend, REAL(x), REAL(y),
- &ii, &jj, nx, ny))) {
- ctr_SegDB[ii + jj * nx]
- = ctr_segupdate(xend, yend, dir, TRUE,/* = tail */
- ctr_SegDB[ii + jj * nx], &seg);
- if (!seg) break;
- end->next = seg;
- end = seg;
- xend = end->x1;
- yend = end->y1;
- }
- end->next = NULL; /* <<< new for 1.2.3 */
- ii = i; jj = j;
- xend = seglist->x0;
- yend = seglist->y0;
- while ((dir = ctr_segdir(xend, yend, REAL(x), REAL(y),
- &ii, &jj, nx, ny))) {
- ctr_SegDB[ii + jj * nx]
- = ctr_segupdate(xend, yend, dir, FALSE,/* ie. head */
- ctr_SegDB[ii+jj*nx], &seg);
- if (!seg) break;
- seg->next = start;
- start = seg;
- xend = start->x0;
- yend = start->y0;
- }
-
- /* ns := #{segments of polyline} -- need to allocate */
- s = start;
- ns = 0;
- /* max_contour_segments: prevent inf.loop (shouldn't be needed) */
- while (s && ns < max_contour_segments) {
- ns++;
- s = s->next;
- }
- if(ns == max_contour_segments)
- warning(_("contour(): circular/long seglist -- set %s > %d?"),
- "options(\"max.contour.segments\")", max_contour_segments);
-
- /* contour midpoint : use for labelling sometime (not yet!)
- int ns2;
- if (ns > 3) ns2 = ns/2; else ns2 = -1;
- */
-
- vmax = vmaxget();
- xxx = (double *) R_alloc(ns + 1, sizeof(double));
- yyy = (double *) R_alloc(ns + 1, sizeof(double));
- /* now have the space, go through again: */
- s = start;
- ns = 0;
- xxx[ns] = s->x0;
- yyy[ns++] = s->y0;
- while (s->next && ns < max_contour_segments) {
- s = s->next;
- xxx[ns] = s->x0;
- yyy[ns++] = s->y0;
- }
- xxx[ns] = s->x1;
- yyy[ns++] = s->y1;
-#ifdef DEBUG_contour
- Rprintf(" [%2d,%2d]: (x,y)[1:%d] = ", i,j, ns);
- if(ns >= 5)
- Rprintf(" (%g,%g), (%g,%g), ..., (%g,%g)\n",
- xxx[0],yyy[0], xxx[1],yyy[1], xxx[ns-1],yyy[ns-1]);
- else
- for(iii = 0; iii < ns; iii++)
- Rprintf(" (%g,%g)%s", xxx[iii],yyy[iii],
- (iii < ns-1) ? "," : "\n");
-#endif
-
- if (drawLabels) {
- /* If user supplied labels, use i'th one of them
- Otherwise stringify the z-value of the contour */
- cetype_t enc = CE_NATIVE;
- buffer[0] = ' ';
- if (!isNull(labels)) {
- int numl = length(labels);
- strcpy(&buffer[1], CHAR(STRING_ELT(labels, cnum % numl)));
- enc = getCharCE(STRING_ELT(labels, cnum % numl));
- }
- else {
- PROTECT(lab = allocVector(REALSXP, 1));
- REAL(lab)[0] = zc;
- lab = labelformat(lab);
- strcpy(&buffer[1], CHAR(STRING_ELT(lab, 0))); /* ASCII */
- UNPROTECT(1);
- }
- buffer[strlen(buffer)+1] = '\0';
- buffer[strlen(buffer)] = ' ';
-
- labelDistance = GStrWidth(buffer, enc, INCHES, dd);
- labelHeight = GStrHeight(buffer, enc, INCHES, dd);
-
- if (labelDistance > 0) {
- /* Try to find somewhere to draw the label */
- switch (method) {
- case 0: /* draw label at one end of contour
- overwriting contour line
- */
- if (useStart(xxx, yyy, ns, dd) )
- indx = 0;
- else
- indx = ns - 1;
- break;
- case 1: /* draw label at one end of contour
- embedded in contour
- no overlapping labels
- */
- indx = 0;
- range = 0;
- gotLabel = FALSE;
- if (useStart(xxx, yyy, ns, dd)) {
- iii = 0;
- n = findGapUp(xxx, yyy, ns, labelDistance, dd);
- }
- else {
- n = findGapDown(xxx, yyy, ns, labelDistance, dd);
- iii = ns - n - 1;
- }
- if (n > 0) {
- /** Find 4 corners of label extents **/
- FindCorners(labelDistance, labelHeight, label1,
- xxx[iii], yyy[iii],
- xxx[iii+n], yyy[iii+n], dd);
-
- /** Test corners for intersection with previous labels **/
- label2 = labelList;
- result = 0;
- while ((result == 0) && (label2 != R_NilValue)) {
- result = TestLabelIntersection(label1, CAR(label2));
- label2 = CDR(label2);
- }
- if (result == 0) {
- result = LabelInsideWindow(label1, dd);
- if (result == 0) {
- indx = iii;
- range = n;
- gotLabel = TRUE;
- }
- }
- }
- break;
- case 2: /* draw label on flattest portion of contour
- embedded in contour line
- no overlapping labels
- */
- /* Look for flatest sequence of contour gradients */
- lowestVariance = 9999999; /* A large number */
- indx = 0;
- range = 0;
- gotLabel = FALSE;
- for (iii = 0; iii < ns; iii++) {
- distanceSum = 0;
- avgGradient = 0;
- squareSum = 0;
- n = 0;
- jjj = (iii + 1);
- while ((jjj < ns-1) &&
- (distanceSum < labelDistance)) {
-
- /* Find a gap big enough for the label
- use several segments if necessary
- */
- dX = xxx[jjj] - xxx[jjj - n - 1];
- dY = yyy[jjj] - yyy[jjj - n - 1];
- dXC = GConvertXUnits(dX, USER, INCHES, dd);
- dYC = GConvertYUnits(dY, USER, INCHES, dd);
- distanceSum = hypot(dXC, dYC);
-
- /* Calculate the variance of the gradients
- of the segments that will make way for the
- label
- */
- deltaX = xxx[jjj] - xxx[jjj - 1];
- deltaY = yyy[jjj] - yyy[jjj - 1];
- if (deltaX == 0) {deltaX = 1;}
- avgGradient += (deltaY/deltaX);
- squareSum += avgGradient * avgGradient;
- jjj = (jjj + 1);
- n += 1;
- }
- if (distanceSum < labelDistance)
- break;
-
- /** Find 4 corners of label extents **/
- FindCorners(labelDistance, labelHeight, label1,
- xxx[iii], yyy[iii],
- xxx[iii+n], yyy[iii+n], dd);
-
- /** Test corners for intersection with previous labels **/
- label2 = labelList;
- result = 0;
- while ((result == 0) && (label2 != R_NilValue)) {
- result = TestLabelIntersection(label1, CAR(label2));
- label2 = CDR(label2);
- }
- if (result == 0)
- result = LabelInsideWindow(label1, dd);
- if (result == 0) {
- variance = (squareSum - (avgGradient * avgGradient) / n) / n;
- avgGradient /= n;
- if (variance < lowestVariance) {
- lowestVariance = variance;
- indx = iii;
- range = n;
- }
- }
- if (lowestVariance < 9999999)
- gotLabel = TRUE;
- }
- } /* switch (method) */
-
- if (method == 0) {
- GPolyline(ns, xxx, yyy, USER, dd);
- GText(xxx[indx], yyy[indx], USER, buffer,
- CE_NATIVE/*FIX*/,
- .5, .5, 0, dd);
- }
- else {
- if (indx > 0)
- GPolyline(indx+1, xxx, yyy, USER, dd);
- if (ns-1-indx-range > 0)
- GPolyline(ns-indx-range, xxx+indx+range, yyy+indx+range,
- USER, dd);
- if (gotLabel) {
- /* find which plot edge we are closest to */
- int closest; /* 0 = indx, 1 = indx+range */
- double dx1, dx2, dy1, dy2, dmin;
- dx1 = fmin2((xxx[indx] - gpptr(dd)->usr[0]),
- (gpptr(dd)->usr[1] - xxx[indx]));
- dx2 = fmin2((gpptr(dd)->usr[1] - xxx[indx+range]),
- (xxx[indx+range] - gpptr(dd)->usr[0]));
- if (dx1 < dx2) {
- closest = 0;
- dmin = dx1;
- } else {
- closest = 1;
- dmin = dx2;
- }
- dy1 = fmin2((yyy[indx] - gpptr(dd)->usr[2]),
- (gpptr(dd)->usr[3] - yyy[indx]));
- if (closest && (dy1 < dmin)) {
- closest = 0;
- dmin = dy1;
- } else if (dy1 < dmin)
- dmin = dy1;
- dy2 = fmin2((gpptr(dd)->usr[3] - yyy[indx+range]),
- (yyy[indx+range] - gpptr(dd)->usr[2]));
- if (!closest && (dy2 < dmin))
- closest = 1;
-
- dx = GConvertXUnits(xxx[indx+range] - xxx[indx],
- USER, INCHES, dd);
- dy = GConvertYUnits(yyy[indx+range] - yyy[indx],
- USER, INCHES, dd);
- dxy = hypot(dx, dy);
-
- /* save the current label for checking overlap */
- label2 = allocVector(REALSXP, 8);
-
- FindCorners(labelDistance, labelHeight, label2,
- xxx[indx], yyy[indx],
- xxx[indx+range], yyy[indx+range], dd);
- UNPROTECT_PTR(labelList);
- labelList = PROTECT(CONS(label2, labelList));
-
- ddl = FALSE;
- /* draw an extra bit of segment if the label
- doesn't fill the gap */
- if (closest) {
- xStart = xxx[indx+range] -
- (xxx[indx+range] - xxx[indx]) *
- labelDistance / dxy;
- yStart = yyy[indx+range] -
- (yyy[indx+range] - yyy[indx]) *
- labelDistance / dxy;
- if (labelDistance / dxy < 1)
- GLine(xxx[indx], yyy[indx],
- xStart, yStart,
- USER, dd);
- } else {
- xStart = xxx[indx] +
- (xxx[indx+range] - xxx[indx]) *
- labelDistance / dxy;
- yStart = yyy[indx] +
- (yyy[indx+range] - yyy[indx]) *
- labelDistance / dxy;
- if (labelDistance / dxy < 1)
- GLine(xStart, yStart,
- xxx[indx+range], yyy[indx+range],
- USER, dd);
- }
-
- /*** Draw contour labels ***/
- if (xxx[indx] < xxx[indx+range]) {
- if (closest) {
- ux = xStart;
- uy = yStart;
- vx = xxx[indx+range];
- vy = yyy[indx+range];
- } else {
- ux = xxx[indx];
- uy = yyy[indx];
- vx = xStart;
- vy = yStart;
- }
- }
- else {
- if (closest) {
- ux = xxx[indx+range];
- uy = yyy[indx+range];
- vx = xStart;
- vy = yStart;
- } else {
- ux = xStart;
- uy = yStart;
- vx = xxx[indx];
- vy = yyy[indx];
- }
- }
-
- if (!ddl) {
- /* convert to INCHES for calculation of
- angle to draw text
- */
- GConvert(&ux, &uy, USER, INCHES, dd);
- GConvert(&vx, &vy, USER, INCHES, dd);
- /* 0, .5 => left, centre justified */
- GText (ux, uy, INCHES, buffer,
- CE_NATIVE/*FIX*/,0, .5,
- (180 / 3.14) * atan2(vy - uy, vx - ux),
- dd);
- }
- } /* if (gotLabel) */
- } /* if (method == 0) else ... */
- } /* if (labelDistance > 0) */
-
- } /* if (drawLabels) */
- else {
- GPolyline(ns, xxx, yyy, USER, dd);
- }
-
- vmaxset(vmax);
- } /* while */
- } /* for(i .. ) for(j ..) */
- vmaxset(vmax); /* now we are done with ctr_SegDB */
- UNPROTECT_PTR(label1); /* pwwwargh! This is messy, but last thing
- protected is likely labelList, and that needs
- to be preserved across calls */
-}
-
-
-SEXP C_contourDef(void)
-{
- return ScalarLogical(GEcurrentDevice()->dev->useRotatedTextInContour);
-}
-
-/* contour(x, y, z, levels, labels, labcex, drawlabels,
- * method, vfont, col = col, lty = lty, lwd = lwd)
- */
-SEXP C_contour(SEXP args)
-{
- SEXP c, x, y, z, vfont, col, rawcol, lty, lwd, labels;
- int i, j, nx, ny, nc, ncol, nlty, nlwd;
- int ltysave, fontsave = 1 /* -Wall */;
- rcolor colsave;
- double cexsave, lwdsave;
- double atom, zmin, zmax;
- const void *vmax, *vmax0;
- char familysave[201];
- int method;
- Rboolean drawLabels;
- double labcex;
- pGEDevDesc dd = GEcurrentDevice();
- SEXP result = R_NilValue;
-
- GCheckState(dd);
-
- args = CDR(args);
- if (length(args) < 12) error(_("too few arguments"));
- PrintDefaults(); /* prepare for labelformat */
-
- x = PROTECT(coerceVector(CAR(args), REALSXP));
- nx = LENGTH(x);
- args = CDR(args);
-
- y = PROTECT(coerceVector(CAR(args), REALSXP));
- ny = LENGTH(y);
- args = CDR(args);
-
- z = PROTECT(coerceVector(CAR(args), REALSXP));
- args = CDR(args);
-
- /* levels */
- c = PROTECT(coerceVector(CAR(args), REALSXP));
- nc = LENGTH(c);
- args = CDR(args);
-
- labels = CAR(args);
- if (!isNull(labels)) TypeCheck(labels, STRSXP);
- args = CDR(args);
-
- labcex = asReal(CAR(args));
- args = CDR(args);
-
- drawLabels = (Rboolean)asLogical(CAR(args));
- args = CDR(args);
-
- method = asInteger(CAR(args)); args = CDR(args);
- if (method < 1 || method > 3)
- error(_("invalid '%s' value"), "method");
-
- PROTECT(vfont = FixupVFont(CAR(args)));
- if (!isNull(vfont)) {
- strncpy(familysave, gpptr(dd)->family, 201);
- strncpy(gpptr(dd)->family, "Her ", 201);
- gpptr(dd)->family[3] = (char) INTEGER(vfont)[0];
- fontsave = gpptr(dd)->font;
- gpptr(dd)->font = INTEGER(vfont)[1];
- }
- args = CDR(args);
-
- rawcol = CAR(args);
- PROTECT(col = FixupCol(rawcol, R_TRANWHITE));
- ncol = length(col);
- args = CDR(args);
-
- PROTECT(lty = FixupLty(CAR(args), gpptr(dd)->lty));
- nlty = length(lty);
- args = CDR(args);
-
- PROTECT(lwd = FixupLwd(CAR(args), gpptr(dd)->lwd));
- nlwd = length(lwd);
- args = CDR(args);
-
- if (nx < 2 || ny < 2)
- error(_("insufficient 'x' or 'y' values"));
-
- if (nrows(z) != nx || ncols(z) != ny)
- error(_("dimension mismatch"));
-
- if (nc < 1)
- error(_("no contour values"));
-
- for (i = 0; i < nx; i++) {
- if (!R_FINITE(REAL(x)[i]))
- error(_("missing 'x' values"));
- if (i > 0 && REAL(x)[i] < REAL(x)[i - 1])
- error(_("increasing 'x' values expected"));
- }
-
- for (i = 0; i < ny; i++) {
- if (!R_FINITE(REAL(y)[i]))
- error(_("missing 'y' values"));
- if (i > 0 && REAL(y)[i] < REAL(y)[i - 1])
- error(_("increasing 'y' values expected"));
- }
-
- for (i = 0; i < nc; i++)
- if (!R_FINITE(REAL(c)[i]))
- error(_("invalid NA contour values"));
-
- zmin = DBL_MAX;
- zmax = DBL_MIN;
- for (i = 0; i < nx * ny; i++)
- if (R_FINITE(REAL(z)[i])) {
- if (zmax < REAL(z)[i]) zmax = REAL(z)[i];
- if (zmin > REAL(z)[i]) zmin = REAL(z)[i];
- }
-
- if (zmin >= zmax) {
- if (zmin == zmax)
- warning(_("all z values are equal"));
- else
- warning(_("all z values are NA"));
- UNPROTECT(8);
- return R_NilValue;
- }
-
- /* change to 1e-3, reconsidered because of PR#897
- * but 1e-7, and even 2*DBL_EPSILON do not prevent inf.loop in contour().
- * maybe something like 16 * DBL_EPSILON * (..).
- * see also max_contour_segments above */
- atom = 1e-3 * (zmax - zmin);
-
- /* Initialize the segment data base */
-
- /* Note we must be careful about resetting */
- /* the top of the stack, otherwise we run out of */
- /* memory after a sequence of displaylist replays */
-
- vmax0 = vmaxget();
- ctr_SegDB = (SEGP*)R_alloc(nx*ny, sizeof(SEGP));
-
- for (i = 0; i < nx; i++)
- for (j = 0; j < ny; j++)
- ctr_SegDB[i + j * nx] = NULL;
-
- /* Draw the contours -- note the heap release */
-
- ltysave = gpptr(dd)->lty;
- colsave = gpptr(dd)->col;
- lwdsave = gpptr(dd)->lwd;
- cexsave = gpptr(dd)->cex;
- labelList = PROTECT(R_NilValue);
-
-
- /* draw contour for levels[i] */
- GMode(1, dd);
- for (i = 0; i < nc; i++) {
- vmax = vmaxget();
- gpptr(dd)->lty = INTEGER(lty)[i % nlty];
- if (gpptr(dd)->lty == NA_INTEGER)
- gpptr(dd)->lty = ltysave;
- if (isNAcol(rawcol, i, ncol))
- gpptr(dd)->col = colsave;
- else
- gpptr(dd)->col = INTEGER(col)[i % ncol];
- gpptr(dd)->lwd = REAL(lwd)[i % nlwd];
- if (!R_FINITE(gpptr(dd)->lwd))
- gpptr(dd)->lwd = lwdsave;
- gpptr(dd)->cex = labcex;
- contour(x, nx, y, ny, z, REAL(c)[i], labels, i,
- drawLabels, method - 1, atom, dd);
- vmaxset(vmax);
- }
- GMode(0, dd);
- vmaxset(vmax0);
- gpptr(dd)->lty = ltysave;
- gpptr(dd)->col = colsave;
- gpptr(dd)->lwd = lwdsave;
- gpptr(dd)->cex = cexsave;
- if(!isNull(vfont)) {
- strncpy(gpptr(dd)->family, familysave, 201);
- gpptr(dd)->font = fontsave;
- }
- UNPROTECT(9); /* x y z c vfont col lty lwd labellist */
- return result;
-}
diff --git a/com.oracle.truffle.r.native/library/graphics/src/stem.c b/com.oracle.truffle.r.native/library/graphics/src/stem.c
deleted file mode 100644
index 62b081b67fd227bc022c8992a2cddf4607a9227b..0000000000000000000000000000000000000000
--- a/com.oracle.truffle.r.native/library/graphics/src/stem.c
+++ /dev/null
@@ -1,214 +0,0 @@
-/*
- * R : A Computer Language for Statistical Data Analysis
- * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
- * Copyright (C) 1997-2014 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/
- */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <Rinternals.h>
-#include <math.h>
-#include <limits.h> /* INT_MAX */
-#include <stdlib.h> /* abs */
-#include <Rmath.h> /* for imin2 and imax2 */
-#include <R_ext/Print.h> /* for Rprintf */
-#include <R_ext/Utils.h> /* for R_rsort */
-#include <R_ext/Error.h>
-#include <R_ext/Arith.h> /* for R_FINITE */
-
-#ifdef ENABLE_NLS
-#include <libintl.h>
-#define _(String) dgettext ("graphics", String)
-#else
-#define _(String) (String)
-#endif
-
-static void stem_print(int close, int dist, int ndigits)
-{
- if((close/10 == 0) && (dist < 0))
- Rprintf(" %*s | ", ndigits, "-0");
- else
- Rprintf(" %*d | ", ndigits, close/10);
-}
-
-static Rboolean
-stem_leaf(double *x, int n, double scale, int width, double atom)
-{
- double r, c, x1, x2;
- double mu, lo, hi;
- int mm, k, i, j, xi;
- int ldigits, hdigits, ndigits, pdigits;
-
- R_rsort(x,n);
-
- if(n <= 1)
- return FALSE;
-
- Rprintf("\n");
- if(x[n-1] > x[0]) {
- r = atom + (x[n-1] - x[0])/scale;
- // this needs to be exact: exp10 in glibc is not accurate
- c = R_pow_di(10.0, (int)(1.0 - floor(log10(r))));
- mm = imin2(2, imax2(0, (int)(r*c/25)));
- k = 3*mm + 2 - 150/(n + 50);
- if ((k-1)*(k-2)*(k-5) == 0)
- c *= 10.;
- /* need to ensure that x[i]*c does not integer overflow */
- x1 = fabs(x[0]); x2 = fabs(x[n-1]);
- if(x2 > x1) x1 = x2;
- while(x1*c > INT_MAX) c /= 10;
- if (k*(k-4)*(k-8) == 0) mu = 5;
- if ((k-1)*(k-5)*(k-6) == 0) mu = 20;
- } else {
- r = atom + fabs(x[0])/scale;
- c = R_pow_di(10.0, (int)(1.0 - floor(log10(r))));
- k = 2; // not important what
- }
-
- mu = 10;
- if (k*(k-4)*(k-8) == 0) mu = 5;
- if ((k-1)*(k-5)*(k-6) == 0) mu = 20;
-
-
- /* Find the print width of the stem. */
-
- lo = floor(x[0]*c/mu)*mu;
- hi = floor(x[n-1]*c/mu)*mu;
- ldigits = (lo < 0) ? (int) floor(log10(-(double)lo)) + 1 : 0;
- hdigits = (hi > 0) ? (int) floor(log10((double)hi)): 0;
- ndigits = (ldigits < hdigits) ? hdigits : ldigits;
-
- /* Starting cell */
-
- if(lo < 0 && floor(x[0]*c) == lo) lo = lo - mu;
- hi = lo + mu;
- if(floor(x[0]*c+0.5) > hi) {
- lo = hi;
- hi = lo + mu;
- }
-
- /* Print out the info about the decimal place */
-
- pdigits = 1 - (int) floor(log10(c) + 0.5);
-
- Rprintf(" The decimal point is ");
- if(pdigits == 0)
- Rprintf("at the |\n\n");
- else
- Rprintf("%d digit(s) to the %s of the |\n\n",abs(pdigits),
- (pdigits > 0) ? "right" : "left");
- i = 0;
- do {
- if(lo < 0)
- stem_print((int)hi, (int)lo, ndigits);
- else
- stem_print((int)lo, (int)hi, ndigits);
- j = 0;
- do {
- if(x[i] < 0)xi = (int) (x[i]*c - .5);
- else xi = (int) (x[i]*c + .5);
-
- if( (hi == 0 && x[i] >= 0)||
- (lo < 0 && xi > hi) ||
- (lo >= 0 && xi >= hi) )
- break;
-
- j++;
- if(j <= width-12)
- Rprintf("%1d", abs(xi) % 10);
- i++;
- } while(i < n);
- if(j > width)
- Rprintf("+%d", j - width);
- Rprintf("\n");
- if(i >= n)
- break;
- hi += mu;
- lo += mu;
- } while(1);
- Rprintf("\n");
- return TRUE;
-}
-
-/* The R wrapper has removed NAs from x */
-SEXP C_StemLeaf(SEXP x, SEXP scale, SEXP swidth, SEXP atom)
-{
- if(TYPEOF(x) != REALSXP || TYPEOF(scale) != REALSXP) error("invalid input");
-#ifdef LONG_VECTOR_SUPPORT
- if (IS_LONG_VEC(x))
- error(_("long vector '%s' is not supported"), "x");
-#endif
- int width = asInteger(swidth), n = LENGTH(x);
- if (n == NA_INTEGER) error(_("invalid '%s' argument"), "x");
- if (width == NA_INTEGER) error(_("invalid '%s' argument"), "width");
- double sc = asReal(scale), sa = asReal(atom);
- if (!R_FINITE(sc)) error(_("invalid '%s' argument"), "scale");
- if (!R_FINITE(sa)) error(_("invalid '%s' argument"), "atom");
- stem_leaf(REAL(x), n, sc, width, sa);
- return R_NilValue;
-}
-
-/* Formerly a version in src/appl/binning.c */
-#include <string.h> // for memset
-
-static void
-C_bincount(double *x, R_xlen_t n, double *breaks, R_xlen_t nb, int *count,
- int right, int include_border)
-{
- R_xlen_t i, lo, hi, nb1 = nb - 1, new;
-
- // for(i = 0; i < nb1; i++) count[i] = 0;
- memset(count, 0, nb1 * sizeof(int));
-
- for(i = 0 ; i < n ; i++)
- if(R_FINITE(x[i])) { // left in as a precaution
- lo = 0;
- hi = nb1;
- if(breaks[lo] <= x[i] &&
- (x[i] < breaks[hi] || (x[i] == breaks[hi] && include_border))) {
- while(hi-lo >= 2) {
- new = (hi+lo)/2;
- if(x[i] > breaks[new] || (!right && x[i] == breaks[new]))
- lo = new;
- else
- hi = new;
- }
-#ifdef LONG_VECTOR_SUPPORT
- if(count[lo] >= INT_MAX)
- error("count for a bin exceeds INT_MAX");
-#endif
- count[lo]++;
- }
- }
-}
-
-/* The R wrapper removed non-finite values */
-SEXP C_BinCount(SEXP x, SEXP breaks, SEXP right, SEXP lowest)
-{
- x = PROTECT(coerceVector(x, REALSXP));
- breaks = PROTECT(coerceVector(breaks, REALSXP));
- R_xlen_t n = XLENGTH(x), nB = XLENGTH(breaks);
- int sr = asLogical(right), sl = asLogical(lowest);
- if (sr == NA_INTEGER) error(_("invalid '%s' argument"), "right");
- if (sl == NA_INTEGER) error(_("invalid '%s' argument"), "include.lowest");
- SEXP counts = PROTECT(allocVector(INTSXP, nB - 1));
- C_bincount(REAL(x), n, REAL(breaks), nB, INTEGER(counts), sr, sl);
- UNPROTECT(3);
- return counts;
-}
diff --git a/com.oracle.truffle.r.native/library/lib.mk b/com.oracle.truffle.r.native/library/lib.mk
index 8de59dce0295f84495c1e14118d53a5a1c951620..b387d908b61167e4df73aa0e9ecb39ff844cec59 100644
--- a/com.oracle.truffle.r.native/library/lib.mk
+++ b/com.oracle.truffle.r.native/library/lib.mk
@@ -73,10 +73,12 @@ INCLUDES := $(JNI_INCLUDES) $(FFI_INCLUDES)
PKGDIR := $(FASTR_LIBRARY_DIR)/$(PKG)
-ifneq ($(C_SOURCES),)
-all: $(LIB_PKG_PRE) libcommon $(LIB_PKG) $(LIB_PKG_POST)
+SUPPRESS_WARNINGS := -Wno-int-conversion -Wno-implicit-function-declaration
+
+ifeq ($(NO_LIBRARY),)
+all: $(LIB_PKG_PRE) libcommon $(LIB_PKG) $(LIB_PKG_POST)
else
-all: $(LIB_PKG_PRE) libcommon $(LIB_PKG_POST)
+all: $(LIB_PKG_PRE) libcommon $(LIB_PKG_POST)
endif
libcommon: $(PKGDIR)
diff --git a/mx.fastr/copyrights/overrides b/mx.fastr/copyrights/overrides
index d792b6c9ab2f06ae25b830f6f3905fc2fa2617c8..e6b716c3288682d0915553a3fd7ef421280c57cb 100644
--- a/mx.fastr/copyrights/overrides
+++ b/mx.fastr/copyrights/overrides
@@ -46,57 +46,23 @@ com.oracle.truffle.r.native/fficall/src/common/print_fastr.c,gnu_r_gentleman_iha
com.oracle.truffle.r.native/fficall/src/common/printutils_fastr.c,gnu_r_gentleman_ihaka.copyright
com.oracle.truffle.r.native/fficall/src/common/sys_fastr.c,gnu_r.copyright
com.oracle.truffle.r.native/fficall/src/common/util_fastr.c,gnu_r.copyright
-com.oracle.truffle.r.native/fficall/src/common/Defn.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/Graphics.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/GraphicsBase.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/Internal.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/Print.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/Rgraphics.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/nmath.h,gnu_r.copyright
-com.oracle.truffle.r.native/fficall/src/common/rlocale.h,gnu_r_gentleman_ihaka.copyright
-com.oracle.truffle.r.native/fficall/src/common/variable_defs.h,gnu_r.copyright
+com.oracle.truffle.r.native/fficall/src/include/Defn.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/Graphics.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/GraphicsBase.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/Internal.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/Print.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/Rgraphics.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/Fileio.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/contour-common.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/include/nmath.h,gnu_r.copyright
+com.oracle.truffle.r.native/fficall/src/include/rlocale.h,gnu_r_gentleman_ihaka.copyright
+com.oracle.truffle.r.native/fficall/src/variable_defs/variable_defs.h,gnu_r.copyright
com.oracle.truffle.r.native/fficall/src/jni/unimplemented.c,gnu_r.copyright
com.oracle.truffle.r.native/fficall/src/jni/Memory.c,gnu_r.copyright
com.oracle.truffle.r.native/fficall/src/jni/Rdynload_fastr.c,gnu_r.copyright
com.oracle.truffle.r.native/include/src/libintl.h,no.copyright
com.oracle.truffle.r.native/library/base/src/registration.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/graphics.h,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/init.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devQuartz.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/grDevices.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/init.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/axis_scales.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoBM.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/cairo/cairoFns.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/chull.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/colors.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devCairo.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devPS.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devPicTeX.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devWindows.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/devices.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_Fileio.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_Graphics.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_GraphicsBase.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_Rgraphics.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_contour-common.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/main_rlocale.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/qdBitmap.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/qdCocoa.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/qdPDF.c,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/qdPDF.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/rbitmap.h,no.copyright
-com.oracle.truffle.r.native/library/grDevices/src/stubs.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/Defn.h,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/base.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/graphics.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/par-common.h,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/par.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/plot.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/plot3d.c,no.copyright
-com.oracle.truffle.r.native/library/graphics/src/stem.c,no.copyright
+com.oracle.truffle.r.native/library/grDevices/src/gzio.c,gnu_r_gentleman_ihaka.copyright
com.oracle.truffle.r.native/library/grid/src/gpar.c,no.copyright
com.oracle.truffle.r.native/library/grid/src/grid.c,no.copyright
com.oracle.truffle.r.native/library/grid/src/grid.h,no.copyright