/* Hello, Emacs, this is -*-C-*-
* $Id: tkcanvas.trm,v 1.36 2016/06/13 21:22:45 sfeam Exp $
*
*/
/* GNUPLOT - tkcanvas.trm */
/*[
* Copyright 1990 - 1993, 1998, 2004, 2014
*
* Permission to use, copy, and distribute this software and its
* documentation for any purpose with or without fee is hereby granted,
* provided that the above copyright notice appear in all copies and
* that both that copyright notice and this permission notice appear
* in supporting documentation.
*
* Permission to modify the software is granted, but not the right to
* distribute the complete modified source code. Modifications are to
* be distributed as patches to the released version. Permission to
* distribute binaries produced by compiling modified sources is granted,
* provided you
* 1. distribute the corresponding source modifications from the
* released version in the form of a patch file along with the binaries,
* 2. add special version identification to distinguish your version
* in addition to the base release version number,
* 3. provide your name and address as the primary contact for the
* support of your modified version, and
* 4. retain our contact information in regard to use of the base
* software.
* Permission to distribute the released version of the source code along
* with corresponding source modifications in the form of a patch file is
* granted with same provisions 2 through 4 for binary distributions.
*
* This software is provided "as is" without express or implied warranty
* to the extent permitted by applicable law.
]*/
/*
* This file is included by ../term.c.
*
* This terminal driver supports:
* Tk canvas widgets under several scripting languages
* (currently Tcl, Perl/Tk, Perl/Tkx, Python, Ruby, Rexx)
*
* AUTHORS and HISTORY:
* original dxy.trm by Martin Yii, eln557h@monu3.OZ
* Further modified Jan 1990 by Russell Lang, rjl@monu1.cc.monash.oz
*
* port to the Tk/Tcl canvas widget
* D. Jeff Dionne, July 1995 jeff@ryeham.ee.ryerson.ca
* Alex Woo, woo@playfair.stanford.edu
*
* adapted to the new terminal layout by Alex Woo (Sept. 1996)
*
* extended interactive Tk/Tcl capabilities
* Thomas Sefzick, March 1999, t.sefzick@fz-juelich.de
*
* added the perltk.trm code written by Slaven Rezic <eserte@cs.tu-berlin.de>.
* 'linewidth' and 'justify text' added, ends of plotted lines are now rounded.
* Thomas Sefzick, May 1999, t.sefzick@fz-juelich.de
*
* scale plot to fit into the actual size of the canvas as reported by
* the window manager (the canvas itself doesn't report its real size).
* Matt Willis, October 1999, mattbwillis@my-deja.com
*
* cleaned up and generalized in order to accomodate an increasing
* number of scripting languages; added support for Python and Ruby.
* based on a patch dated October 2002.
* Joachim Wuttke, November 2014, jwuttke@users.sourceforge.net
*
* Add support for Perl/Tkx and Rexx.
* Add support for rgb and palette color, filled boxes and polygons,
* rotated text, (custom) dashed lines, background colour, closed paths,
* rounded or butt line ends, Tk-arrows, optimized drawing of lines,
* boxed text and bold and italic text. Add 'size' option to give the
* code a hint of proper tic and font sizes. Add 'standalone' option to
* create self-contained scripts. Add support for enhanced text and
* external images for Tcl only.
* Bastian Maerkisch, December 2014, bmaerkisch@web.de
*
* BUGS or MISSING FEATURES:
* - enhanced text only for Tcl
* - option to change function name (multiple plots)
* - layer actions by adding tags to items
* - hypertext and image are missing
* - transparency is not possible
* - text encoding setting is ignored, we always use the system's default
* - The "interactive" mode has several issues:
* - The optimised line drawing, which merges adjacent segments into one
* path, renders the 'interactive mode' pretty useless.
* - It is not (yet) implemented at all for Python/Tkinter and Rexx/Tk.
* - Ruby/Tkinter: no support for user_gnuplot_coordinates().
* - gnuplot_xy:
* the definition (with 12 input and 4 output coordinates) is clumsy,
* and the implementation is unelegant.
* - we don't take advantage of object orientation; our Ruby code looks
* like an almost literal translation from Tcl (because that's what it is).
* - no support for Lua/Tk
*/
#include "driver.h"
#ifdef TERM_REGISTER
register_term(tkcanvas)
#endif
#ifdef TERM_PROTO
TERM_PUBLIC void TK_options __PROTO((void));
TERM_PUBLIC void TK_init __PROTO((void));
TERM_PUBLIC void TK_graphics __PROTO((void));
TERM_PUBLIC void TK_text __PROTO((void));
TERM_PUBLIC void TK_linetype __PROTO((int linetype));
TERM_PUBLIC void TK_move __PROTO((unsigned int x, unsigned int y));
TERM_PUBLIC void TK_vector __PROTO((unsigned int x, unsigned int y));
TERM_PUBLIC int TK_text_angle(int ang);
TERM_PUBLIC void TK_put_text(unsigned int x, unsigned int y, const char *str);
TERM_PUBLIC void TK_reset(void);
TERM_PUBLIC int TK_justify_text(enum JUSTIFY);
TERM_PUBLIC void TK_point(unsigned int, unsigned int, int);
TERM_PUBLIC void TK_arrow(unsigned int, unsigned int, unsigned int, unsigned int, int);
TERM_PUBLIC int TK_set_font(const char *font);
TERM_PUBLIC void TK_enhanced_open(char * fontname, double fontsize,
double base, TBOOLEAN widthflag, TBOOLEAN showflag, int overprint);
TERM_PUBLIC void TK_enhanced_flush(void);
TERM_PUBLIC void TK_linewidth(double linewidth);
TERM_PUBLIC int TK_make_palette(t_sm_palette *palette);
TERM_PUBLIC void TK_color(t_colorspec *colorspec);
TERM_PUBLIC void TK_fillbox(int style, unsigned int x, unsigned int y, unsigned int w, unsigned int h);
TERM_PUBLIC void TK_filled_polygon(int points, gpiPoint *corners);
#ifdef WRITE_PNG_IMAGE
TERM_PUBLIC void TK_image(unsigned m, unsigned n, coordval *image, gpiPoint *corner, t_imagecolor color_mode);
#endif
TERM_PUBLIC void TK_dashtype(int dt, t_dashtype *custom_dash_pattern);
#ifdef EAM_BOXED_TEXT
TERM_PUBLIC void TK_boxed_text(unsigned int x, unsigned int y, int option);
#endif
/* nominal canvas size */
#define TK_XMAX 1000
#define TK_YMAX 1000
/* char size and tic sizes in pixels */
#define TK_VCHAR 14 /* height of characters */
#define TK_HCHAR 6 /* width of characters including spacing */
#define TK_VTIC 8
#define TK_HTIC 8
#endif /* TERM_PROTO */
#ifndef TERM_PROTO_ONLY
#ifdef TERM_BODY
/* FIXME HBB 20000725: This needs to be fixed. As is, this driver causes
* the terminal layer to depend on several other core modules. This is a
* design bug. "term" is supposed as 'frontier' layer: it should not be
* dependent on any other code inside gnuplot */
#include "axis.h" /* axis_array */
#include "gadgets.h" /* is_3d_plot, plot_bounds */
/* text, font */
static int tk_angle = 0;
static char tk_anchor[7] = "w";
static enum JUSTIFY tk_justify;
static TBOOLEAN tk_next_text_use_font = FALSE;
static TBOOLEAN tk_boxed = FALSE;
/* enhanced text */
static TBOOLEAN tk_enhanced_opened_string = FALSE;
static TBOOLEAN tk_enhanced_show = FALSE;
static int tk_enhanced_base = 0;
static int tk_enhanced_overprint = 0;
static TBOOLEAN tk_enhanced_widthflag = FALSE;
/* vectors, polygons, paths */
static TBOOLEAN tk_rounded = FALSE;
static double tk_linewidth = 1.0;
static int tk_lastx = 0;
static int tk_lasty = 0;
static TBOOLEAN tk_in_path = FALSE;
static int * tk_path_x = NULL;
static int * tk_path_y = NULL;
static int tk_maxpath = 0;
static int tk_polygon_points = 0;
static char tk_dashpattern[3*DASHPATTERN_LENGTH];
static const char * tk_dashtypes[] = {
"", "1 1", "", "3 1", "2 2", "3 1 1 1", "3 1 1 1 1 1"
};
/* color */
static const char * tk_colors[] = {
"black", "gray", "red", "green", "blue", "magenta", "cyan", "brown"
};
static char tk_color[20] = "black";
static char tk_background[20] = "";
static char * tk_background_opt = NULL;
/* other options */
static TBOOLEAN tk_interactive = FALSE;
static TBOOLEAN tk_standalone = FALSE;
static int tk_width = 800;
static int tk_height = 600;
/* images */
static int tk_image_counter = 0;
/* prototypes of local functions */
static void TK_put_noenhanced_text(unsigned int x, unsigned int y, const char *str);
static void TK_put_enhanced_text(unsigned int x, unsigned int y, const char *str);
static void TK_rectangle(int x1, int y1, int x2, int y2, char * color, char * stipple);
static void TK_add_path_point(int x, int y); /* add a new point to current path or line */
static void TK_flush_line(); /* finish a poly-line */
enum TK_id {
/* languages first (order is important as it is used as index!) */
TK_LANG_TCL=0, TK_LANG_PERL, TK_LANG_PYTHON, TK_LANG_RUBY, TK_LANG_REXX,
TK_LANG_PERLTKX, TK_LANG_MAX,
/* other options */
TK_INTERACTIVE, TK_STANDALONE, TK_INPUT,
TK_NOROTTEXT, TK_ROTTEXT, TK_BACKGROUND, TK_NOBACKGROUND,
TK_ROUNDED, TK_BUTT, TK_SIZE, TK_ENHANCED, TK_NOENHANCED,
TK_PIXELS, TK_EXTERNALIMAGES, TK_INLINEIMAGES,
TK_OTHER
};
static int tk_script_language = TK_LANG_TCL;
static char *tk_script_languages[TK_LANG_MAX] = {
"tcl", "perl", "python", "ruby", "rexx", "perltkx"
};
static struct gen_table TK_opts[] =
{
{ "t$cl", TK_LANG_TCL },
{ "pe$rltk", TK_LANG_PERL },
{ "perltkx", TK_LANG_PERLTKX },
{ "tkx", TK_LANG_PERLTKX },
{ "py$thontkinter", TK_LANG_PYTHON },
{ "ru$bytkinter", TK_LANG_RUBY },
{ "re$xxtk", TK_LANG_REXX },
{ "int$eractive", TK_INTERACTIVE },
{ "inp$ut", TK_INPUT },
{ "stand$alone", TK_STANDALONE },
{ "nor$ottext", TK_NOROTTEXT },
{ "rot$text", TK_ROTTEXT },
{ "backg$round", TK_BACKGROUND },
{ "noback$ground", TK_NOBACKGROUND },
{ "round$ed", TK_ROUNDED },
{ "butt", TK_BUTT },
{ "size", TK_SIZE },
{ "enh$anced", TK_ENHANCED },
{ "noenh$anced", TK_NOENHANCED },
{ "pix$els", TK_PIXELS },
{ "inl$ineimages", TK_INLINEIMAGES },
{ "ext$ernalimages", TK_EXTERNALIMAGES },
{ NULL, TK_OTHER }
};
TERM_PUBLIC void
TK_options()
{
int cmd;
tk_interactive = FALSE;
while (!END_OF_COMMAND) {
switch (cmd = lookup_table(&TK_opts[0], c_token)) {
case TK_LANG_TCL:
case TK_LANG_PERL:
case TK_LANG_PERLTKX:
case TK_LANG_RUBY:
case TK_LANG_PYTHON:
case TK_LANG_REXX:
tk_script_language = cmd;
c_token++;
break;
case TK_INTERACTIVE:
tk_interactive = TRUE;
c_token++;
break;
case TK_INPUT:
tk_standalone = FALSE;
c_token++;
break;
case TK_STANDALONE:
tk_standalone = TRUE;
c_token++;
break;
case TK_NOROTTEXT:
term->text_angle = null_text_angle;
c_token++;
break;
case TK_ROTTEXT:
term->text_angle = TK_text_angle;
c_token++;
break;
case TK_BACKGROUND: {
long rgb;
int red, green, blue;
c_token++;
rgb = parse_color_name();
free(tk_background_opt);
tk_background_opt = NULL;
m_capture(&tk_background_opt, c_token-1, c_token);
red = (rgb >> 16) & 0xff;
green = (rgb >> 8) & 0xff;
blue = (rgb ) & 0xff;
snprintf(tk_background, sizeof(tk_background), "#%02x%02x%02x", red, green, blue);
break;
}
case TK_NOBACKGROUND:
tk_background[0] = NUL;
free(tk_background_opt);
tk_background_opt = NULL;
c_token++;
break;
case TK_ROUNDED:
tk_rounded = TRUE;
c_token++;
break;
case TK_BUTT:
tk_rounded = FALSE;
c_token++;
break;
case TK_SIZE: {
c_token++;
if (END_OF_COMMAND)
int_error(c_token, "size requires 'width,heigth'");
tk_width = real_expression();
if (!equals(c_token++, ","))
int_error(c_token, "size requires 'width,heigth'");
tk_height = real_expression();
if (tk_width < 1 || tk_height < 1)
int_error(c_token, "size is out of range");
break;
}
case TK_ENHANCED:
c_token++;
term->flags |= TERM_ENHANCED_TEXT;
break;
case TK_NOENHANCED:
c_token++;
term->flags &= ~TERM_ENHANCED_TEXT;
break;
case TK_PIXELS:
c_token++;
term->image = NULL;
break;
case TK_INLINEIMAGES:
case TK_EXTERNALIMAGES:
c_token++;
#ifdef WRITE_PNG_IMAGE
term->image = TK_image;
#endif
break;
case TK_OTHER:
default:
c_token++;
int_error(c_token, "unknown option");
break;
}
}
/* calculate the proper tic sizes and character size */
term->h_char = TK_HCHAR * TK_XMAX / (double) tk_width + 0.5;
term->h_tic = TK_HTIC * TK_XMAX / (double) tk_width + 0.5;
term->v_char = TK_VCHAR * TK_YMAX / (double) tk_height + 0.5;
term->v_tic = TK_VTIC * TK_YMAX / (double) tk_height + 0.5;
/* FIXME: image support only available for Tcl */
if ((term->image != NULL) && (tk_script_language != TK_LANG_TCL))
term->image = NULL;
/* FIXME: enhanced text only available for Tcl */
if ((term->flags & TERM_ENHANCED_TEXT) && (tk_script_language != TK_LANG_TCL))
term->flags &= ~TERM_ENHANCED_TEXT;
sprintf(term_options, "%s%s %s %s%s %s %s %s size %d,%d",
tk_script_languages[tk_script_language],
tk_interactive ? " interactive" : "",
tk_standalone ? "standalone" : "input",
(tk_background[0] == NUL) ? "nobackground " : "background ",
(tk_background[0] == NUL) ? "" : tk_background_opt,
tk_rounded ? "rounded" : "butt",
term->text_angle == null_text_angle ? "norottext" : "rottext",
term->image == NULL ? "pixels" : "externalimages",
tk_width, tk_height);
}
TERM_PUBLIC void
TK_init()
{
tk_image_counter = 0;
}
static char *tk_standalone_init[TK_LANG_MAX] = {
/* Tcl */
"canvas .c -width %d -height %d\n"
"pack .c\n"
"gnuplot .c\n\n",
/* Perl */
"use Tk;\n"
"my $top = MainWindow->new;\n"
"my $c = $top->Canvas(-width => %d, -height => %d)->pack;\n"
"gnuplot($c);\n"
"MainLoop;\n",
/* Python */
"from tkinter import *\n"
"from tkinter import font\n"
"root = Tk()\n"
"c = Canvas(root, width=%d, height=%d)\n"
"c.pack()\n"
"gnuplot(c)\n"
"root.mainloop()\n",
/* Ruby */
"require 'tk'\n"
"root = TkRoot.new { title 'Ruby/Tk' }\n"
"c = TkCanvas.new(root, 'width'=>%d, 'height'=>%d) { pack { } }\n"
"gnuplot(c)\n"
"Tk.mainloop\n",
/* Rexx */
"/**/\n"
"call RxFuncAdd 'TkLoadFuncs', 'rexxtk', 'TkLoadFuncs'\n"
"call TkLoadFuncs\n"
"cv = TkCanvas('.c', '-width', %d, '-height', %d)\n"
"call TkPack cv\n"
"call gnuplot cv\n"
"do forever\n"
" interpret 'call' TkWait()\n"
"end\n"
"return 0\n\n"
"exit:\nquit:\n"
"call TkDropFuncs\n"
"exit 0\n",
/* Perl/Tkx */
"use Tkx;\n"
"my $top = Tkx::widget->new(\".\");\n"
"my $c = $top->new_tk__canvas(-width => %d, -height => %d);\n"
"$c->g_pack;\n"
"gnuplot($c);\n"
"Tkx::MainLoop();\n"
};
static char *tk_init_gnuplot[TK_LANG_MAX] = {
/* Tcl */
"proc %s cv {\n"
" $cv delete all\n"
" set cmx [expr\\\n"
" [winfo width $cv]-2*[$cv cget -border]"
"-2*[$cv cget -highlightthickness]]\n"
" if {$cmx <= 1} {set cmx [$cv cget -width]}\n"
" set cmy [expr\\\n"
" [winfo height $cv]-2*[$cv cget -border]"
"-2*[$cv cget -highlightthickness]]\n"
" if {$cmy <= 1} {set cmy [$cv cget -height]}\n",
/* Perl */
"sub %s {\n"
" my($cv) = @_;\n"
" $cv->delete('all');\n"
" my $cmx = $cv->width - 2 * $cv->cget(-border)\n"
" - 2 * $cv->cget(-highlightthickness);\n"
" if ($cmx <= 1) {\n"
" $cmx = ($cv->cget(-width));\n"
" }\n"
" my $cmy = $cv->height - 2 * $cv->cget(-border)\n"
" - 2 * $cv->cget(-highlightthickness);\n"
" if ($cmy <= 1) {\n"
" $cmy = ($cv->cget(-height));\n"
" }\n",
/* Python */
"def %s (cv):\n"
"\tcv.delete('all')\n"
"\tcmdelta = 2*(int(cv.cget('border'))+"
"int(cv.cget('highlightthickness')))\n"
"\tcmx = int(cv.cget('width'))-cmdelta\n"
"\tif (cmx<=1):\n\t\tcmx = int(cv.cget('width'))\n"
"\tcmy = int(cv.cget('height'))-cmdelta\n"
"\tif (cmy<=1):\n\t\tcmy = int(cv.cget('height'))\n"
"",
/* Ruby (below, we NEED the blank in "- 2" !)*/
"def %s(cv)\n"
" cv.delete('all')\n"
" cmx = cv.width - 2*cv.cget('border') - 2*cv.cget('highlightthickness')\n"
" cmx = cvcget.width if (cmx <= 1)\n"
" cmy = cv.height - 2*cv.cget('border') - 2*cv.cget('highlightthickness')\n"
" cmy = cvcget.height if (cmy <= 1)\n"
"",
/* Rexx */
"/**/\n"
"call %s arg(1)\n"
"return 0\n\n"
"%s: procedure\n"
" cv = arg(1)\n"
" call TkCanvasDelete cv,'all'\n"
" cmx = TkCget(cv,'-width') - 2*TkCget(cv,'-border') - 2*TkCget(cv,'-highlightthickness')\n"
" if cmx <= 1 then; cmx = TkCget(cv,'-width')\n"
" cmy = TkCget(cv,'-height') - 2*TkCget(cv,'-border') - 2*TkCget(cv,'-highlightthickness')\n"
" if cmy <= 1 then; cmy = TkCget(cv,'-height')\n"
"\n",
/* Perl/Tkx */
"sub %s {\n"
" my($cv) = @_;\n"
" $cv->delete('all');\n"
" my $cmx = $cv->get_width - 2 * $cv->cget(-border)\n"
" - 2 * $cv->cget(-highlightthickness);\n"
" if ($cmx <= 1) {\n"
" $cmx = ($cv->cget(-width));\n"
" }\n"
" my $cmy = $cv->get_height - 2 * $cv->cget(-border)\n"
" - 2 * $cv->cget(-highlightthickness);\n"
" if ($cmy <= 1) {\n"
" $cmy = ($cv->cget(-height));\n"
" }\n"
};
static char *tk_set_background[TK_LANG_MAX] = {
/* Tcl */
" $cv configure -bg %s\n",
/* Perl */
" $cv->configure(-bg => q{%s});\n",
/* Python */
"\tcv.configure(bg='%s')\n",
/* Ruby */
" cv.configure('bg'=>'%s')\n",
/* Rexx */
" call TkConfigure cv, '-bg', '%s'\n",
/* Perl/Tkx */
" $cv->configure(-bg => q{%s});\n"
};
TERM_PUBLIC void
TK_graphics()
{
/*
* Here we start the definition of the `gnuplot` procedure.
* The resulting script code takes the actual width and height
* of the defined canvas and scales the plot to fit.
* You can tune the output for a particular size of the canvas by
* using the `size` option.
*/
char * tk_function = "gnuplot";
/* Reset to start of output file. If the user mistakenly tries to */
/* plot again into the same file, it will overwrite the original */
/* rather than corrupting it. */
fseek(gpoutfile, 0L, SEEK_SET);
fflush(gpoutfile);
if (ftruncate(fileno(gpoutfile), (off_t)0) != 0)
int_error(NO_CARET,"Error re-writing output file: %s", strerror(errno));
if (!tk_standalone &&
((tk_script_language == TK_LANG_PERL) || (tk_script_language == TK_LANG_PERLTKX)))
tk_function = "";
if (tk_standalone && (tk_script_language == TK_LANG_REXX))
fprintf(gpoutfile, tk_standalone_init[tk_script_language], tk_width, tk_height);
fprintf(gpoutfile, tk_init_gnuplot[tk_script_language], tk_function, tk_function);
tk_angle = tk_lastx = tk_lasty = 0;
safe_strncpy(tk_color, tk_colors[0], sizeof(tk_color));
/* set background */
if (tk_background[0] != NUL) {
//TK_rectangle(0, 0, TK_XMAX, TK_YMAX, tk_background, "");
fprintf(gpoutfile, tk_set_background[tk_script_language], tk_background);
}
}
TERM_PUBLIC void
TK_reset()
{
free(tk_path_x);
free(tk_path_y);
tk_path_x = tk_path_y = NULL;
tk_polygon_points = tk_maxpath = 0;
}
TERM_PUBLIC void
TK_linetype(int linetype)
{
t_colorspec colorspec;
colorspec.type = TC_LT;
colorspec.lt = linetype;
TK_color(&colorspec);
TK_dashtype(DASHTYPE_SOLID, NULL);
}
TERM_PUBLIC int
TK_make_palette(t_sm_palette *palette)
{
return 0; /* we can do RGB colors */
}
TERM_PUBLIC void
TK_color(t_colorspec *colorspec)
{
char tmp_color[20];
safe_strncpy(tmp_color, tk_color, sizeof(tmp_color));
switch (colorspec->type) {
case TC_LT: {
int linetype = colorspec->lt;
char * color = NULL;
if (linetype == LT_BACKGROUND)
color = (tk_background[0] != NUL) ? tk_background : "white";
if (linetype == LT_NODRAW)
color = "";
if (color == NULL) {
if (linetype < LT_BLACK)
linetype = LT_BLACK;
color = (char *) tk_colors[(linetype + 2) % 8];
}
safe_strncpy(tmp_color, color, sizeof(tmp_color));
break;
}
case TC_FRAC: {
rgb255_color rgb255;
/* Immediately translate palette index to RGB colour */
rgb255maxcolors_from_gray(colorspec->value, &rgb255);
snprintf(tmp_color, sizeof(tmp_color), "#%02x%02x%02x", rgb255.r, rgb255.g, rgb255.b);
break;
}
case TC_RGB: {
int red, green, blue;
red = (colorspec->lt >> 16) & 0xff;
green = (colorspec->lt >> 8) & 0xff;
blue = (colorspec->lt) & 0xff;
snprintf(tmp_color, sizeof(tk_color), "#%02x%02x%02x", red, green, blue);
break;
}
}
if (strcmp(tk_color, tmp_color) != 0) {
TK_flush_line();
safe_strncpy(tk_color, tmp_color, sizeof(tk_color));
}
}
TERM_PUBLIC void
TK_linewidth(double linewidth)
{
if (fabs(tk_linewidth - linewidth) > FLT_EPSILON)
TK_flush_line();
tk_linewidth = linewidth;
}
TERM_PUBLIC void
TK_dashtype(int dt, t_dashtype *custom_dash_pattern)
{
int i;
char tmp_dashpattern[3*DASHPATTERN_LENGTH];
TBOOLEAN preserve = FALSE;
if (dt >= 0) {
// {PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT};
dt %= 5;
dt += 2;
strcpy(tmp_dashpattern, tk_dashtypes[dt]);
} else if (dt == DASHTYPE_SOLID) {
tmp_dashpattern[0] = NUL;
} else if (dt == DASHTYPE_AXIS) {
strcpy(tmp_dashpattern, tk_dashtypes[1]);
} else if (dt == DASHTYPE_CUSTOM) {
if (custom_dash_pattern->dstring[0] != NUL) {
/* Tk and gnuplot support the very same dash pattern syntax. */
strncpy(tmp_dashpattern, custom_dash_pattern->dstring, sizeof(tmp_dashpattern)-1);
preserve = TRUE; /* do not change pattern */
} else {
tmp_dashpattern[0] = NUL;
for (i = 0; (i < DASHPATTERN_LENGTH/2) && (fabs(custom_dash_pattern->pattern[2*i]) > FLT_EPSILON); i++) {
char buf[32];
snprintf(buf, sizeof(buf), "%d %d ",
(int) (custom_dash_pattern->pattern[2*i] * tk_linewidth),
(int) (custom_dash_pattern->pattern[2*i + 1] * tk_linewidth));
strncat(tmp_dashpattern, buf, sizeof(tmp_dashpattern) - strlen(tmp_dashpattern)-1);
}
tmp_dashpattern[strlen(tmp_dashpattern) - 1] = NUL;
}
}
if ((tk_script_language == TK_LANG_PYTHON) && !preserve) {
for (i = 0; tmp_dashpattern[i] != NUL; i++)
if (tmp_dashpattern[i] == ' ')
tmp_dashpattern[i] = ',';
}
if (strcmp(tk_dashpattern, tmp_dashpattern) != 0) {
TK_flush_line();
safe_strncpy(tk_dashpattern, tmp_dashpattern, sizeof(tk_dashpattern));
}
}
TERM_PUBLIC void
TK_move(unsigned int x, unsigned int y)
{
/* terminate current path if we move to a disconnected position */
if (tk_polygon_points > 0) {
if ((tk_path_x[tk_polygon_points - 1] != x) ||
(tk_path_y[tk_polygon_points - 1] != TK_YMAX - y))
TK_flush_line();
else
return;
}
TK_add_path_point(x, TK_YMAX - y);
tk_lastx = x;
tk_lasty = TK_YMAX - y;
}
/* FIXME HBB 20000725: should use AXIS_UNDO_LOG() macro... */
#define TK_REAL_VALUE(value,axis) \
(axis_array[axis].log) \
? pow(axis_array[axis].base, axis_array[axis].min \
+ value*(axis_array[axis].max-axis_array[axis].min)) \
: axis_array[axis].min \
+ value*(axis_array[axis].max-axis_array[axis].min)
#define TK_X_VALUE(value) \
(double)(value-plot_bounds.xleft)/(double)(plot_bounds.xright-plot_bounds.xleft)
#define TK_Y_VALUE(value) \
(double)((TK_YMAX-value)-plot_bounds.ybot)/(double)(plot_bounds.ytop-plot_bounds.ybot)
static char *tk_bind_init[TK_LANG_MAX] = {
/* Tcl */
" $cv bind [\n ",
/* Perl */
" $cv->bind(\n ",
/* Python */
"",
/* Ruby */
"",
/* Rexx */
"",
/* Perl/Tkx */
" $cv->bind(\n "
};
static char *tk_line_segment_start[TK_LANG_MAX] = {
/* Tcl */
" $cv create line\\\n",
/* Perl */
" $cv->createLine(\n",
/* Python */
"\tcv.create_line(\\\n",
/* Ruby */
" cl=TkcLine.new(cv,\\\n",
/* Rexx */
" obj = TkCanvasLine(cv, ,\n",
/* Perl/Tkx */
" $cv->create_line(\n"
};
static char *tk_poly_point[TK_LANG_MAX] = {
/* Tcl */
" [expr $cmx*%d/1000] [expr $cmy*%d/1000]\\\n",
/* Perl */
" $cmx*%d/1000, $cmy*%d/1000,\n",
/* Python */
"\t\tcmx*%d/1000, cmy*%d/1000,\\\n",
/* Ruby */
" cmx*%d/1000, cmy*%d/1000,\\\n",
/* Rexx */
"\tcmx*%d/1000, cmy*%d/1000, ,\n",
/* Perl/Tkx */
" $cmx*%d/1000, $cmy*%d/1000,\n"
};
static char *tk_line_segment_opt[TK_LANG_MAX] = {
/* Tcl */
" -fill {%s} -width %.1f -capstyle %s -joinstyle %s",
/* Perl */
" -fill => q{%s}, -width => %.1f, -capstyle => q{%s}, -joinstyle => q{%s}",
/* Python */
"\t\tfill='%s', width=%.1f, capstyle='%s', joinstyle='%s'",
/* Ruby */
" 'fill'=>'%s', 'width'=>%.1f, 'capstyle'=>'%s', 'joinstyle'=>'%s'",
/* Rexx */
"\t'-fill', '%s', '-width', '%.1f', '-capstyle', '%s', '-joinstyle', '%s'",
/* Perl/Tkx */
" -fill => q{%s}, -width => %.1f, -capstyle => q{%s}, -joinstyle => q{%s}",
};
static char *tk_line_segment_dash[TK_LANG_MAX] = {
/* Tcl */
" -dash {%s}",
/* Perl */
", -dash => q{%s}",
/* Python */
", dash=(%s)",
/* Ruby */
", 'dash'=>'%s'",
/* Rexx */
", '-dash', '%s'",
/* Perl/Tkx */
", -dash => q{%s}"
};
static char *tk_line_segment_end[TK_LANG_MAX] = {
/* Tcl */
"\n",
/* Perl */
")",
/* Python */
")\n",
/* Ruby */
")\n",
/* Rexx */
")\n",
/* Perl/Tkx */
")"
};
static char *tk_bind_main[TK_LANG_MAX] = {
/* Tcl */
" ] <Button> \"gnuplot_xy %%W %f %f %f %f\\\n"
" %f %f %f %f",
/* Perl */
",\n '<Button>' => "
"[\\&gnuplot_xy, %f, %f, %f, %f,\n"
" %f, %f, %f, %f",
/* Python */
/* FIXME: how can one bind an event to a line segment in Python/TkCanvas ? */
"",
/* Ruby */
" cl.bind('Button', proc{ gnuplot_xy(%f, %f, %f, %f,\\\n"
" %f, %f, %f, %f",
/* FIXME: Rexx interactive binding untested */
" call TkCanvasBind cv, obj, 'Button', ,\n"
" 'gnuplot_xy %f, %f, %f, %f,' ,\n"
" '%f, %f, %f, %f' ,\n"
" ",
/* Perl/Tkx */
",\n '<Button>' => "
"[\\&gnuplot_xy, %f, %f, %f, %f,\n"
" %f, %f, %f, %f"
};
static char *tk_bind_f[TK_LANG_MAX] = {
/* Tcl */
" %f",
/* Perl */
", %f",
/* Python */
"",
/* Ruby */
", %f",
/* Rexx */
" || ', %f'",
/* Perl/Tkx */
", %f",
};
static char *tk_bind_nil[TK_LANG_MAX] = {
/* Tcl */
" {}",
/* Perl */
", \"\"",
/* Python */
"",
/* Ruby */
", ''",
/* Rexx */
" || ', \'\''",
/* Perl/Tkx */
", \"\""
};
static char *tk_bind_end[TK_LANG_MAX] = {
/* Tcl */
"\"\n",
/* Perl */
"]);\n",
/* Python */
"",
/* Ruby */
") })\n",
/* Rexx */
"\n",
/* Perl/Tkx */
"]);\n"
};
static char *tk_nobind[TK_LANG_MAX] = {
/* Tcl */
"",
/* Perl */
";\n",
/* Python */
"",
/* Ruby */
"",
/* Rexx */
"",
/* Perl/Tkx */
";\n"
};
TERM_PUBLIC void
TK_vector(unsigned int x, unsigned int y)
{
if ((x != tk_lastx) || (TK_YMAX - y != tk_lasty)) {
/* vector without preceeding move as e.g. in "with line lc variable" */
if (tk_polygon_points == 0)
TK_add_path_point(tk_lastx, tk_lasty);
TK_add_path_point(x, TK_YMAX - y);
}
tk_lastx = x;
tk_lasty = TK_YMAX - y;
return;
}
static void
TK_flush_line(void)
{
int x, y, i;
if (tk_in_path)
tk_in_path = FALSE;
if (tk_polygon_points < 2) {
tk_polygon_points = 0;
return;
}
/*
* this is the 1st part of the wrapper around the 'create line' command
* used to bind some actions to a line segment:
* bind {
* normal create line command
* } gnuplot_xy(some coordinates)
*/
/* prepare the binding mechanism */
if (tk_interactive && !is_3d_plot)
fputs(tk_bind_init[tk_script_language], gpoutfile);
/* draw a line segment */
fputs(tk_line_segment_start[tk_script_language], gpoutfile);
for (i = 0; i < tk_polygon_points; i++)
fprintf(gpoutfile, tk_poly_point[tk_script_language], tk_path_x[i], tk_path_y[i]);
fprintf(gpoutfile, tk_line_segment_opt[tk_script_language], tk_color, tk_linewidth,
tk_rounded ? "round" : "butt", tk_rounded ? "round" : "miter");
if (tk_dashpattern[0] != NUL)
fprintf(gpoutfile, tk_line_segment_dash[tk_script_language], tk_dashpattern);
fputs(tk_line_segment_end[tk_script_language], gpoutfile);
/* finish the binding mechanism
* (which calls 'gnuplot_xy' for the line segment pointed to by
* the mouse cursor when a mouse button is pressed)
*/
x = tk_path_x[tk_polygon_points -1];
y = tk_path_y[tk_polygon_points -1];
if (tk_interactive && !is_3d_plot) {
fprintf(gpoutfile, tk_bind_main[tk_script_language],
TK_REAL_VALUE(TK_X_VALUE(tk_lastx), FIRST_X_AXIS),
TK_REAL_VALUE(TK_Y_VALUE(tk_lasty), FIRST_Y_AXIS),
TK_REAL_VALUE(TK_X_VALUE(tk_lastx), SECOND_X_AXIS),
TK_REAL_VALUE(TK_Y_VALUE(tk_lasty), SECOND_Y_AXIS),
TK_REAL_VALUE(TK_X_VALUE(x), FIRST_X_AXIS),
TK_REAL_VALUE(TK_Y_VALUE(y), FIRST_Y_AXIS),
TK_REAL_VALUE(TK_X_VALUE(x), SECOND_X_AXIS),
TK_REAL_VALUE(TK_Y_VALUE(y), SECOND_Y_AXIS));
if (axis_array[FIRST_X_AXIS].log)
fprintf(gpoutfile, tk_bind_f[tk_script_language],
TK_REAL_VALUE(TK_X_VALUE(0.5 * (x + tk_lastx)),
FIRST_X_AXIS));
else
fputs(tk_bind_nil[tk_script_language], gpoutfile);
if (axis_array[FIRST_Y_AXIS].log)
fprintf(gpoutfile, tk_bind_f[tk_script_language],
TK_REAL_VALUE(TK_Y_VALUE(0.5 * (y + tk_lasty)),
FIRST_Y_AXIS));
else
fputs(tk_bind_nil[tk_script_language], gpoutfile);
if (axis_array[SECOND_X_AXIS].log)
fprintf(gpoutfile, tk_bind_f[tk_script_language],
TK_REAL_VALUE(TK_X_VALUE(0.5 * (x + tk_lastx)),
SECOND_X_AXIS));
else
fputs(tk_bind_nil[tk_script_language], gpoutfile);
if (axis_array[SECOND_Y_AXIS].log)
fprintf(gpoutfile, tk_bind_f[tk_script_language],
TK_REAL_VALUE(TK_Y_VALUE(0.5 * (y + tk_lasty)),
SECOND_Y_AXIS));
else
fputs(tk_bind_nil[tk_script_language], gpoutfile);
fputs(tk_bind_end[tk_script_language], gpoutfile);
} else {
fputs(tk_nobind[tk_script_language], gpoutfile);
}
tk_polygon_points = 0;
tk_in_path = FALSE;
}
#undef TK_REAL_VALUE
#undef TK_X_VALUE
#undef TK_Y_VALUE
TERM_PUBLIC int
TK_text_angle(int ang)
{
tk_angle = ang;
return TRUE;
}
static char *tk_create_text_begin[TK_LANG_MAX] = {
/* Tcl */
" $cv create text "
"[expr $cmx * %d /1000] [expr $cmy * %d /1000]\\\n"
" -text {%s} -fill %s\\\n"
" -anchor %s",
/* Perl */
" $cv->createText($cmx * %d / 1000, $cmy * %d / 1000,\n"
" -text => q{%s}, -fill => q{%s}, -anchor => '%s'",
/* Python */
"\tcv.create_text(cmx*%d/1000, cmy*%d/1000,\\\n"
"\t\ttext='%s', fill='%s', anchor='%s'",
/* Ruby */
" ct=TkcText.new(cv, cmx*%d/1000, cmy*%d/1000,\\\n"
" 'text'=>'%s', 'fill'=>'%s', 'anchor'=>'%s'",
/* Rexx */
" call TkCanvasText cv, cmx*%d/1000, cmy*%d/1000, ,\n"
"\t'-text', '%s', '-fill', '%s', '-anchor', '%s'",
/* Perl/Tkx */
" $cv->create_text($cmx * %d / 1000, $cmy * %d / 1000,\n"
" -text => q{%s}, -fill => q{%s}, -anchor => '%s'"
};
static char *tk_create_text_font[TK_LANG_MAX] = {
/* Tcl */
" -font $font",
/* Perl */
",\n -font => $font",
/* Python */
", font=gfont",
/* Ruby */
", 'font'=>font",
/* Rexx */
", '-font', font",
/* Perl/Tkx */
",\n (defined $font ? (-font => $font) : ())"
};
static char *tk_create_text_angle[TK_LANG_MAX] = {
/* Tcl */
" -angle %d",
/* Perl */
", -angle => %d",
/* Python */
", angle=%d",
/* Ruby */
", 'angle'=>%d",
/* Rexx */
", '-angle', %d",
/* Perl/Tkx */
", -angle => %d"
};
static char *tk_tag[TK_LANG_MAX] = {
/* Tcl */
" -tags %s",
/* Perl */
", -tags => q{%s}",
/* Python */
", tags='%s'",
/* Ruby */
", 'tags'=>'%s'",
/* Rexx */
", '-tags', '%s'",
/* Perl/Tkx */
", -tags => q{%s}"
};
static char *tk_create_text_end[TK_LANG_MAX] = {
/* Tcl */
"\n",
/* Perl */
");\n",
/* Python */
")\n",
/* Ruby */
")\n",
/* Rexx */
"\n",
/* Perl/Tkx */
");\n"
};
static void
TK_put_noenhanced_text(unsigned int x, unsigned int y, const char *str)
{
char *quoted_str = (char *) str;
int i, newsize = 0;
TK_flush_line();
if (tk_script_language == TK_LANG_TCL) {
/* Have to escape several characters: []{}"$; */
for (i = 0; str[i] != '\0'; i++) {
if ((str[i] == '[') || (str[i] == ']') ||
(str[i] == '{') || (str[i] == '}') ||
(str[i] == '$') || (str[i] == ';'))
newsize++;
newsize++;
}
quoted_str = (char *) gp_alloc(newsize + 1, "TK_put_text: quoted string");
for (i = 0, newsize = 0; str[i] != '\0'; i++) {
if ((str[i] == '[') || (str[i] == ']') ||
(str[i] == '{') || (str[i] == '}') ||
(str[i] == '$') || (str[i] == ';'))
quoted_str[newsize++] = '\\';
quoted_str[newsize++] = str[i];
}
quoted_str[newsize] = '\0';
}
if ((tk_script_language == TK_LANG_REXX) ||
(tk_script_language == TK_LANG_RUBY) ||
(tk_script_language == TK_LANG_PYTHON)) {
/* Have to quote-protect "'" characters */
for (i = 0; str[i] != '\0'; i++) {
if (str[i] == '\'')
newsize ++;
newsize++;
}
quoted_str = (char *) gp_alloc(newsize + 1, "TK_put_text: quoted string");
for (i = 0, newsize = 0; str[i] != '\0'; i++) {
if (str[i] == '\'')
quoted_str[newsize++] = (tk_script_language == TK_LANG_REXX) ? '\'' : '\\';
quoted_str[newsize++] = str[i];
}
quoted_str[newsize] = '\0';
}
y = TK_YMAX - y;
fprintf(gpoutfile, tk_create_text_begin[tk_script_language],
x, y, quoted_str, tk_color, tk_anchor);
if (tk_next_text_use_font) {
fputs(tk_create_text_font[tk_script_language], gpoutfile);
tk_next_text_use_font = FALSE;
}
if (tk_angle != 0)
fprintf(gpoutfile, tk_create_text_angle[tk_script_language], tk_angle);
if (tk_boxed)
fprintf(gpoutfile, tk_tag[tk_script_language], "boxedtext");
fputs(tk_create_text_end[tk_script_language], gpoutfile);
if (quoted_str != str)
free(quoted_str);
}
static char *tk_undef_font[TK_LANG_MAX] = {
/* Tcl */
" catch {unset font}\n",
/* Perl */
" undef $font;\n",
/* Python */
"",
/* Ruby */
"",
/* Rexx */
" drop font\n",
/* Perl/Tkx */
" undef $font;\n"
};
static char *tk_set_font[TK_LANG_MAX] = {
/* Tcl */
" set font [font create -family {%s}",
/* Perl */
" $font = $cv->fontCreate(-family => q{%s}",
/* Python */
"\tgfont = font.Font(family='%s'",
/* Ruby */
" font = TkFont.new :family => '%s'",
/* Rexx */
" font = TkFontCreate( , '-family', '%s'",
/* Perl/Tkx */
" $font = Tkx::font_create(-family => q{%s}"
};
static char *tk_set_fsize[TK_LANG_MAX] = {
/* Tcl */
" -size %d",
/* Perl */
", -size => %d",
/* Python */
", size=%d",
/* Ruby */
", :size => %d",
/* Rexx */
", '-size', '%d'",
/* Perl/Tkx */
", -size => %d"
};
static char *tk_set_fbold[TK_LANG_MAX] = {
/* Tcl */
" -weight bold",
/* Perl */
", -weight => q{bold}",
/* Python */
", weight='bold'",
/* Ruby */
", :weight => 'bold'",
/* Rexx */
", '-weight', 'bold'",
/* Perl/Tkx */
", -weight => q{bold}"
};
static char *tk_set_fitalic[TK_LANG_MAX] = {
/* Tcl */
" -slant italic",
/* Perl */
", -slant => q{italic}",
/* Python */
", slant='italic'",
/* Ruby */
", :slant => 'italic'",
/* Rexx */
", '-slant', 'italic'",
/* Perl/Tkx */
", -slant => q{italic}"
};
static char *tk_font_end[TK_LANG_MAX] = {
/* Tcl */
"]\n",
/* Perl */
");\n",
/* Python */
")\n",
/* Ruby */
"\n",
/* Rexx */
")\n",
/* Perl/Tkx */
");\n"
};
TERM_PUBLIC int
TK_set_font(const char *font)
{
if (!font || *font == NUL) {
tk_next_text_use_font = FALSE;
fputs(tk_undef_font[tk_script_language], gpoutfile);
} else {
char *name;
int size = 0;
size_t sep1 = strcspn(font, ",");
size_t sep2 = strcspn(font, ":");
size_t sep = GPMIN(sep1, sep2);
TBOOLEAN isbold, isitalic;
/* extract font name */
name = (char *) gp_alloc(sep + 1, "TK_set_font");
if (!name)
return FALSE;
strncpy(name, font, sep);
name[sep] = NUL;
/* bold, italic */
isbold = (strstr(font, ":Bold") != NULL);
isitalic = (strstr(font, ":Italic") != NULL);
/* font size */
if (sep1 < strlen(font))
sscanf(&(font[sep1 + 1]), "%d", &size);
fprintf(gpoutfile, tk_set_font[tk_script_language], name);
if (size > 0)
fprintf(gpoutfile, tk_set_fsize[tk_script_language], size);
if (isbold)
fputs(tk_set_fbold[tk_script_language], gpoutfile);
if (isitalic)
fputs(tk_set_fitalic[tk_script_language], gpoutfile);
fputs(tk_font_end[tk_script_language], gpoutfile);
tk_next_text_use_font = TRUE;
free(name);
}
return TRUE;
}
TERM_PUBLIC void
TK_enhanced_open(char *fontname, double fontsize, double base,
TBOOLEAN widthflag, TBOOLEAN showflag, int overprint)
{
if (overprint == 3) { /* save current position */
fprintf(gpoutfile, "set xenh_save $xenh; set yenh_save $yenh;\n");
return;
} else if (overprint == 4) { /* restore saved position */
fprintf(gpoutfile, "set xenh $xenh_save; set yenh $yenh_save;\n");
return;
}
if (!tk_enhanced_opened_string) {
TBOOLEAN isbold, isitalic;
char * family, * sep;
tk_enhanced_opened_string = TRUE;
/* Start new text fragment */
enhanced_cur_text = &enhanced_text[0];
/* Scale fractional font height to vertical units of display */
tk_enhanced_base = base * TK_HCHAR;
/* Keep track of whether we are supposed to show this string */
tk_enhanced_show = showflag;
/* 0/1/2 no overprint / 1st pass / 2nd pass */
tk_enhanced_overprint = overprint;
/* widthflag FALSE means do not update text position after printing */
tk_enhanced_widthflag = widthflag;
/* set new font */
family = gp_strdup(fontname);
sep = strchr(family, ':');
if (sep != NULL) *sep = NUL;
isbold = (strstr(fontname, ":Bold") != NULL);
isitalic = (strstr(fontname, ":Italic") != NULL);
fprintf(gpoutfile, tk_set_font[tk_script_language], family);
if (fontsize > 0)
fprintf(gpoutfile, tk_set_fsize[tk_script_language], (int) (fontsize));
if (isbold)
fputs(tk_set_fbold[tk_script_language], gpoutfile);
if (isitalic)
fputs(tk_set_fitalic[tk_script_language], gpoutfile);
fputs(tk_font_end[tk_script_language], gpoutfile);
tk_next_text_use_font = TRUE;
free(family);
}
}
static char *tk_enhanced_text_begin[TK_LANG_MAX] = {
/* Tcl */
" set et [$cv create text $%s $%s\\\n"
" -text {%s} -fill %s\\\n"
" -anchor %s",
/* Perl */
" $cv->createText($cmx * %d / 1000, $cmy * %d / 1000,\n"
" -text => q{%s}, -fill => q{%s}, -anchor => '%s'",
/* Python */
"\tcv.create_text(cmx*%d/1000, cmy*%d/1000,\\\n"
"\t\ttext='%s', fill='%s', anchor='%s'",
/* Ruby */
" ct=TkcText.new(cv, cmx*%d/1000, cmy*%d/1000,\\\n"
" 'text'=>'%s', 'fill'=>'%s', 'anchor'=>'%s'",
/* Rexx */
" call TkCanvasText cv, cmx*%d/1000, cmy*%d/1000, ,\n"
"\t'-text', '%s', '-fill', '%s', '-anchor', '%s'",
/* Perl/Tkx */
" $cv->create_text($cmx * %d / 1000, $cmy * %d / 1000,\n"
" -text => q{%s}, -fill => q{%s}, -anchor => '%s'"
};
static char *tk_enhanced_text_end[TK_LANG_MAX] = {
/* Tcl */
"]\n",
/* Perl */
");\n",
/* Python */
")\n",
/* Ruby */
")\n",
/* Rexx */
"\n",
/* Perl/Tkx */
");\n"
};
TERM_PUBLIC void
TK_enhanced_flush()
{
char *str = enhanced_text; /* The fragment to print */
if (!tk_enhanced_opened_string)
return;
*enhanced_cur_text = NUL;
/* print the string fragment in any case */
/* NB: base expresses offset from current y pos */
fprintf(gpoutfile, "set yenh [expr int($yenhb + %d)]\n", (int) (-tk_enhanced_base/5 * cos(tk_angle * DEG2RAD)));
fprintf(gpoutfile, "set xenh [expr int($xenhb + %d)]\n", (int) (-tk_enhanced_base/5 * sin(tk_angle * DEG2RAD)));
fprintf(gpoutfile, tk_enhanced_text_begin[tk_script_language],
"xenh", "yenh", str, tk_color, tk_anchor);
if (tk_next_text_use_font) {
fputs(tk_create_text_font[tk_script_language], gpoutfile);
tk_next_text_use_font = FALSE;
}
if (!tk_boxed)
fprintf(gpoutfile, tk_tag[tk_script_language], "enhancedtext");
else
fprintf(gpoutfile, tk_tag[tk_script_language], "boxedtext");
fputs(tk_enhanced_text_end[tk_script_language], gpoutfile);
if (!tk_enhanced_widthflag)
/* don't update position */
;
else if (tk_enhanced_overprint == 1) {
/* First pass of overprint, leave position in center of fragment */
//fprintf(gpoutfile, "incr xenh [expr ([lindex [$cv bbox $et] 2] - [lindex [$cv bbox $et] 0]) / 2]\n");
fprintf(gpoutfile, "set width [expr ([lindex [$cv bbox $et] 2] - [lindex [$cv bbox $et] 0])]\n");
fprintf(gpoutfile, "incr xenhb [expr int($width * %f)]\n", + cos(tk_angle * DEG2RAD) / 2);
fprintf(gpoutfile, "incr yenhb [expr int($width * %f)]\n", - sin(tk_angle * DEG2RAD) / 2);
} else {
/* Normal case is to update position to end of fragment */
//fprintf(gpoutfile, "set xenh [lindex [$cv bbox $et] 2]\n");
fprintf(gpoutfile, "set width [expr ([lindex [$cv bbox $et] 2] - [lindex [$cv bbox $et] 0])]\n");
fprintf(gpoutfile, "incr xenhb [expr int($width * %f)]\n", + cos(tk_angle * DEG2RAD));
fprintf(gpoutfile, "incr yenhb [expr int($width * %f)]\n", - sin(tk_angle * DEG2RAD));
}
if (tk_angle != 0)
fprintf(gpoutfile, "$cv itemconfigure $et -angle %d\n", tk_angle);
if (!tk_enhanced_show)
fprintf(gpoutfile, "$cv delete $et\n");
tk_enhanced_opened_string = FALSE;
}
static void
TK_put_enhanced_text(unsigned int x, unsigned int y, const char *str)
{
/* Set up global variables needed by enhanced_recursion() */
enhanced_fontscale = 1.0;
strncpy(enhanced_escape_format, "%c", sizeof(enhanced_escape_format));
tk_enhanced_opened_string = FALSE;
tk_lastx = x;
tk_lasty = TK_YMAX - y;
fprintf(gpoutfile, "set xenh0 [expr $cmx * %d /1000]; set yenh0 [expr $cmy * %d /1000];\n", x, TK_YMAX - y);
fprintf(gpoutfile, "set xenh $xenh0; set yenh $yenh0;\n");
fprintf(gpoutfile, "set xenhb $xenh0; set yenhb $yenh0;\n");
strcpy(tk_anchor, "w");
/* Set the recursion going. We say to keep going until a
* closing brace, but we don't really expect to find one.
* If the return value is not the nul-terminator of the
* string, that can only mean that we did find an unmatched
* closing brace in the string. We increment past it (else
* we get stuck in an infinite loop) and try again.
*/
while (*(str = enhanced_recursion((char *)str, TRUE,
"" /* font */, 10 /* size */,
0.0, TRUE, TRUE, 0))) {
(term->enhanced_flush)();
/* I think we can only get here if *str == '}' */
enh_err_check(str);
if (!*++str)
break; /* end of string */
/* else carry on and process the rest of the string */
}
if (tk_justify == RIGHT)
fprintf(gpoutfile, "$cv move enhancedtext [expr ($xenh0 - $xenhb)] [expr ($yenh0 - $yenhb)]\n");
else if (tk_justify == CENTRE)
fprintf(gpoutfile, "$cv move enhancedtext [expr ($xenh0 - $xenhb)/2] [expr ($yenh0 - $yenhb)/2]\n");
fprintf(gpoutfile, "$cv dtag enhancedtext\n");
}
TERM_PUBLIC void
TK_put_text(unsigned int x, unsigned int y, const char *str)
{
if ((str == NULL) || !strlen(str)) return;
/* If no enhanced text processing is needed, we can use the plain */
/* vanilla put_text() routine instead of the fancy recursive one. */
/* FIXME: enhanced text only implemented for Tcl */
if (!(term->flags & TERM_ENHANCED_TEXT) || ignore_enhanced_text || !strpbrk(str, "{}^_@&~") ||
(tk_script_language != TK_LANG_TCL))
TK_put_noenhanced_text(x, y, str);
else
TK_put_enhanced_text(x, y, str);
}
TERM_PUBLIC int
TK_justify_text(enum JUSTIFY anchor)
{
int return_value;
switch (anchor) {
case RIGHT:
strcpy(tk_anchor, "e");
return_value = TRUE;
break;
case CENTRE:
strcpy(tk_anchor, "center");
return_value = TRUE;
break;
case LEFT:
strcpy(tk_anchor, "w");
return_value = TRUE;
break;
default:
strcpy(tk_anchor, "w");
return_value = FALSE;
}
tk_justify = anchor;
return return_value;
}
TERM_PUBLIC void
TK_point(unsigned int x, unsigned int y, int point)
{
TK_flush_line();
if (point >= 0) {
do_point(x, y, point);
} else {
/* Emulate dots by a line of length 1 */
TK_dashtype(DASHTYPE_SOLID, NULL);
TK_move(x, y);
TK_vector(x, y+1);
TK_flush_line();
}
}
static char *tk_line_arrow[TK_LANG_MAX] = {
/* Tcl */
" -arrow %s",
/* Perl */
", -arrow => q{%s}",
/* Python */
", arrow='%s'",
/* Ruby */
", 'arrow'=>'%s'",
/* Rexx */
", '-arrow', '%s'",
/* Perl/Tkx */
", -arrow => q{%s}"
};
static char *tk_line_arrowshape[TK_LANG_MAX] = {
/* Tcl */
" -arrowshape {%d %d %d}",
/* Perl */
", -arrowshape => [%d, %d, %d]",
/* Python */
", arrowshape=(%d, %d, %d)",
/* Ruby */
", 'arrowshape'=>[%d, %d, %d]",
/* Rexx */
", '-arrowshape', '%d %d %d'",
/* Perl/Tkx */
", -arrowshape => [%d, %d, %d]"
};
TERM_PUBLIC
void TK_arrow(unsigned int usx, unsigned int usy, unsigned int uex, unsigned int uey, int head)
{
/* NOHEAD = 0, END_HEAD = 1, BACKHEAD = 2, BOTH_HEADS = 3 */
const char * arrow[BOTH_HEADS + 1] = { "none", "last", "first", "both" };
/* NOTE: we really need integer arguments. Why are the arguments unsigned in the first place? */
int sx = (int) usx;
int sy = (int) usy;
int ex = (int) uex;
int ey = (int) uey;
TK_flush_line();
if (curr_arrow_headfilled >= AS_FILLED) { /* AS_FILLED, AS_NOBORDER */
assert(abs(head) <= BOTH_HEADS);
fputs(tk_line_segment_start[tk_script_language], gpoutfile);
fprintf(gpoutfile, tk_poly_point[tk_script_language], sx, TK_YMAX - sy);
fprintf(gpoutfile, tk_poly_point[tk_script_language], ex, TK_YMAX - ey);
fprintf(gpoutfile, tk_line_segment_opt[tk_script_language], tk_color, tk_linewidth,
tk_rounded ? "round" : "butt", tk_rounded ? "round" : "miter");
if (curr_arrow_headlength > 0) {
/* This should exactly mimic the behaviour of do_arrow() */
int width = sin(curr_arrow_headangle * DEG2RAD) * curr_arrow_headlength;
int tiplen = cos(curr_arrow_headangle * DEG2RAD) * curr_arrow_headlength;
int backlen = width / tan(curr_arrow_headbackangle * DEG2RAD);
int length = tiplen - backlen;
/* impose lower limit on thickness of tips */
if (4 * length < tiplen) length = tiplen / 4;
if (length <= 1) length = 2;
if (tiplen < 1) tiplen = 1;
fprintf(gpoutfile, tk_line_arrow[tk_script_language], arrow[abs(head)]);
fprintf(gpoutfile, tk_line_arrowshape[tk_script_language], length, tiplen, width);
} else if (head != NOHEAD) {
double dx = sx - ex;
double dy = sy - ey;
double len_arrow = sqrt(dx * dx + dy * dy);
double len_tic = ((double) (term->h_tic + term->v_tic)) / 2.0;
double head_coeff = GPMAX(len_tic * HEAD_SHORT_LIMIT, GPMIN(HEAD_COEFF * len_arrow, len_tic * HEAD_LONG_LIMIT));
int length = (int) (COS15 * head_coeff);
int width = (int) (SIN15 * head_coeff);
fprintf(gpoutfile, tk_line_arrow[tk_script_language], arrow[abs(head)]);
fprintf(gpoutfile, tk_line_arrowshape[tk_script_language], length, length, width);
}
if (tk_dashpattern[0] != NUL)
fprintf(gpoutfile, tk_line_segment_dash[tk_script_language], tk_dashpattern);
fputs(tk_line_segment_end[tk_script_language], gpoutfile);
fputs(tk_nobind[tk_script_language], gpoutfile);
} else { /* AS_NOFILL, AS_EMPTY */
/* fall back to internal routine since we cannot do non-filled arrows */
do_arrow(sx, sy, ex, ey, head);
}
}
static char *tk_endblock[TK_LANG_MAX] = {
/* Tcl */
"}\n",
/* Perl */
"};\n",
/* Python */
"",
/* Ruby */
"end\n",
/* Rexx */
"return 0\n\n",
/* Perl/Tkx */
"};\n"
};
static char *tk_info_procs[TK_LANG_MAX] = {
/* Tcl */
"proc gnuplot_plotarea {} {\n"
" return {%d %d %d %d}\n"
"}\n"
"proc gnuplot_axisranges {} {\n"
" return {%f %f %f %f\n"
" %f %f %f %f}\n"
"}\n",
/* Perl */
"sub gnuplot_plotarea {\n"
" return (%d, %d, %d, %d);\n"
"};\n"
"sub gnuplot_axisranges {\n"
" return (%f, %f, %f, %f,\n"
" %f, %f, %f, %f);\n"
"};\n",
/* Python */
"def gnuplot_plotarea():\n"
"\treturn (%d, %d, %d, %d)\n"
"def gnuplot_axisranges():\n"
"\treturn (%f, %f, %f, %f,\\\n"
"\t %f, %f, %f, %f)\n",
/* Ruby */
"def gnuplot_plotarea()\n"
" return [%d, %d, %d, %d]\n"
"end\n"
"def gnuplot_axisranges()\n"
" return [%f, %f, %f, %f,\\\n"
" %f, %f, %f, %f]\n"
"end\n",
/* Rexx */
"gnuplot_plotarea: procedure\n"
"return '%d %d %d %d'\n"
"\n"
"gnuplot_axisranges: procedure\n"
"return '%f %f %f %f ' || ,\n"
" '%f %f %f %f'\n"
"\n",
/* Perl/Tkx */
"sub gnuplot_plotarea {\n"
" return (%d, %d, %d, %d);\n"
"};\n"
"sub gnuplot_axisranges {\n"
" return (%f, %f, %f, %f,\n"
" %f, %f, %f, %f);\n"
"};\n"
};
static char *tk_gnuplot_xy[] = {
/* Tcl */
"proc gnuplot_xy {win x1s y1s x2s y2s x1e y1e x2e y2e x1m y1m x2m y2m} {\n"
" if {([llength [info commands user_gnuplot_coordinates]])} {\n"
" set id [$win find withtag current]\n"
" user_gnuplot_coordinates $win $id \\\n"
" $x1s $y1s $x2s $y2s $x1e $y1e $x2e $y2e $x1m $y1m $x2m $y2m\n"
" } else {\n"
" if {[string length $x1m]>0} {puts -nonewline \" $x1m\"\n"
" } else {puts -nonewline \" [expr 0.5*($x1s+$x1e)]\"}\n"
" if {[string length $y1m]>0} {puts -nonewline \" $y1m\"\n"
" } else {puts -nonewline \" [expr 0.5*($y1s+$y1e)]\"}\n"
" if {[string length $x2m]>0} {puts -nonewline \" $x2m\"\n"
" } else {puts -nonewline \" [expr 0.5*($x2s+$x2e)]\"}\n"
" if {[string length $y2m]>0} {puts \" $y2m\"\n"
" } else {puts \" [expr 0.5*($y2s+$y2e)]\"}\n"
" }\n"
"}\n",
/* Perl */
"sub gnuplot_xy {\n"
" my ($win, $x1s, $y1s, $x2s, $y2s, $x1e, $y1e, $x2e, $y2e,\n"
" $x1m, $y1m, $x2m, $y2m) = @_;\n"
" if (defined &user_gnuplot_coordinates) {\n"
" my $id = $win->find('withtag', 'current');\n"
" user_gnuplot_coordinates $win, $id, $x1s, $y1s, $x2s, $y2s,\n"
" $x1e, $y1e, $x2e, $y2e, $x1m, $y1m, $x2m, $y2m\n"
" } else {\n"
" print \" \", (length($x1m)>0 ? \"$x1m\": 0.5*($x1s+$x1e));\n"
" print \" \", (length($y1m)>0 ? \"$y1m\": 0.5*($y1s+$y1e));\n"
" print \" \", (length($x2m)>0 ? \"$x2m\": 0.5*($x2s+$x2e));\n"
" print \" \", (length($y2m)>0 ? \"$y2m\": 0.5*($y2s+$y2e));\n"
" print \"\\n\"\n"
" }\n"
"};\n",
/* Python */
/* FIXME: how can one bind an event to a line segment in Python/TkCanvas ? */
"",
/* Ruby */
"def gnuplot_xy(x1s, y1s, x2s, y2s, x1e, y1e, x2e, y2e,\n"
" x1m, y1m, x2m, y2m)\n"
// " if (defined &user_gnuplot_coordinates)\n"
// " id = win->find('withtag', 'current')\n"
// " user_gnuplot_coordinates (win, id, x1s, y1s, x2s, y2s,\\\n"
// " x1e, y1e, x2e, y2e, x1m, y1m, x2m, y2m)\n"
// " else\n"
" print \" \", x1m!='' ? x1m : 0.5*(x1s+x1e)\n"
" print \" \", y1m!='' ? y1m : 0.5*(y1s+y1e)\n"
" print \" \", x2m!='' ? x2m : 0.5*(x2s+x2e)\n"
" print \" \", y2m!='' ? y2m : 0.5*(y2s+y2e)\n"
" print \"\\n\""
// " end\n"
"end\n",
/* Rexx */
/* FIXME: Rexx gnuplot_xy is untested */
"gnuplot_xy: procedure\n"
" x1s=arg(1); y1s=arg(2); x2s=arg(3); y2s=arg(4);\n"
" x1e=arg(5); y1e=arg(6); x2e=arg(7); y2e=arg(8);\n"
" x1m=arg(9); y1m=arg(10); x2m=arg(11); y2m=arg(12);\n"
"\n"
" outstr = ''\n"
" if (x1m\\='') then outstr = outstr x1m\n"
" else outstr = outstr (0.5*(x1s+x1e))\n"
" if (y1m\\='') then outstr = outstr y1m\n"
" else outstr = outstr (0.5*(y1s+y1e))\n"
" if (x2m\\='') then outstr = outstr x2m\n"
" else outstr = outstr (0.5*(x2s+x2e))\n"
" if (y2m\\='') then outstr = outstr y2m\n"
" else outstr = outstr (0.5*(y2s+y2e))\n"
"\n"
" call lineout ,outstr\n"
"return\n\n,"
/* Perl/Tkx */
"sub gnuplot_xy {\n"
" my ($win, $x1s, $y1s, $x2s, $y2s, $x1e, $y1e, $x2e, $y2e,\n"
" $x1m, $y1m, $x2m, $y2m) = @_;\n"
" if (defined &user_gnuplot_coordinates) {\n"
" my $id = $win->find('withtag', 'current');\n"
" user_gnuplot_coordinates $win, $id, $x1s, $y1s, $x2s, $y2s,\n"
" $x1e, $y1e, $x2e, $y2e, $x1m, $y1m, $x2m, $y2m\n"
" } else {\n"
" print \" \", (length($x1m)>0 ? \"$x1m\": 0.5*($x1s+$x1e));\n"
" print \" \", (length($y1m)>0 ? \"$y1m\": 0.5*($y1s+$y1e));\n"
" print \" \", (length($x2m)>0 ? \"$x2m\": 0.5*($x2s+$x2e));\n"
" print \" \", (length($y2m)>0 ? \"$y2m\": 0.5*($y2s+$y2e));\n"
" print \"\\n\"\n"
" }\n"
"};\n"
};
TERM_PUBLIC void
TK_text()
{
/*
* when switching back to text mode some procedures are generated which
* return important information about plotarea size and axis ranges:
* 'gnuplot_plotarea'
* returns the plotarea size in tkcanvas units
* 'gnuplot_axisranges'
* returns the min. and max. values of the axis
* (these are essentially needed to set the size of the canvas
* when the axis scaling is important.
* 'gnuplot_xy'
* contains actions bound to line segments the mouse is pointing
* to (see the above 'TK_vector' code):
* if the user has defined a procedure named 'user_gnuplot_coordinates'
* then 'gnuplot_xy' calls this procedure, otherwise is writes the
* coordinates of the line segment the mouse cursor is pointing to
* to standard output.
*/
TK_flush_line();
fputs(tk_endblock[tk_script_language], gpoutfile);
if (!is_3d_plot)
fprintf(gpoutfile, tk_info_procs[tk_script_language],
plot_bounds.xleft, plot_bounds.xright, TK_YMAX - plot_bounds.ytop, TK_YMAX - plot_bounds.ybot,
axis_array[FIRST_X_AXIS].min, axis_array[FIRST_X_AXIS].max,
axis_array[FIRST_Y_AXIS].min, axis_array[FIRST_Y_AXIS].max,
axis_array[SECOND_X_AXIS].min, axis_array[SECOND_X_AXIS].max,
axis_array[SECOND_Y_AXIS].min, axis_array[SECOND_Y_AXIS].max);
if (tk_interactive)
fputs(tk_gnuplot_xy[tk_script_language], gpoutfile);
if (tk_standalone && (tk_script_language != TK_LANG_REXX))
fprintf(gpoutfile, tk_standalone_init[tk_script_language], tk_width, tk_height);
fflush(gpoutfile);
}
static char *tk_rectangle[TK_LANG_MAX] = {
/* Tcl */
" $cv create rectangle\\\n"
" [expr $cmx*%d/1000] [expr $cmy*%d/1000]\\\n"
" [expr $cmx*%d/1000] [expr $cmy*%d/1000]\\\n"
" -fill %s -outline {} -stipple {%s}\n",
/* Perl */
" $cv->createRectangle("
"$cmx*%d/1000, $cmy*%d/1000, $cmx*%d/1000, $cmy*%d/1000,\n"
" -fill => q{%s}, -outline => q{}, -stipple => q{%s});\n",
/* Python */
"\tcv.create_rectangle(cmx*%d/1000, cmy*%d/1000, cmx*%d/1000, cmy*%d/1000,\\\n"
"\t\tfill='%s', outline='', stipple='%s')\n",
/* Ruby */
" cr=TkcRectangle.new("
"cv, cmx*%d/1000, cmy*%d/1000, cmx*%d/1000, cmy*%d/1000,\\\n"
" 'fill'=>'%s', 'outline'=>'', 'stipple'=>'%s')\n",
/* Rexx */
" obj = TkCanvasRectangle("
"cv, cmx*%d/1000, cmy*%d/1000, cmx*%d/1000, cmy*%d/1000, ,\n"
"\t'-fill', '%s', '-outline', '', '-stipple', '%s')\n",
/* Perl/Tkx */
" $cv->create_rectangle("
"$cmx*%d/1000, $cmy*%d/1000, $cmx*%d/1000, $cmy*%d/1000,\n"
" -fill => q{%s}, -outline => q{}, -stipple => q{%s});\n"
};
static void
TK_rectangle(int x1, int y1, int x2, int y2, char * color, char * stipple)
{
if (color == NULL) color = "";
if (stipple == NULL) stipple = "";
fprintf(gpoutfile, tk_rectangle[tk_script_language],
x1, y1, x2, y2, color, stipple);
}
TERM_PUBLIC void
TK_fillbox(int style, unsigned int x, unsigned int y, unsigned int w, unsigned int h)
{
char * stipple = "";
char * color = tk_color;
TK_flush_line();
switch (style & 0x0f) {
case FS_SOLID:
case FS_TRANSPARENT_SOLID: {
int density = style >> 4;
if (density < 20)
stipple = "gray12";
else if (density < 38)
stipple = "gray25";
else if (density < 53)
stipple = "gray50";
else if (density < 88)
stipple = "gray75";
else
stipple = "";
break;
}
case FS_PATTERN:
case FS_TRANSPARENT_PATTERN: {
const char * patterns[] = {"gray50", "gray25", "gray12", "gray75", ""};
int pattern = style >> 4;
stipple = (char *) patterns[pattern % 5];
break;
}
case FS_EMPTY:
color = (tk_background[0] != NUL) ? tk_background : "white";
break;
case FS_DEFAULT:
default:
break;
}
TK_rectangle(x, TK_YMAX - y, x + w, TK_YMAX - y - h, color, stipple);
}
static char *tk_poly_begin[TK_LANG_MAX] = {
/* Tcl */
" $cv create polygon\\\n",
/* Perl */
" $cv->createPolygon(\n",
/* Python */
"\tcv.create_polygon(\\\n",
/* Ruby */
" cp=TkcPolygon.new(cv,\\\n",
/* Rexx */
" obj = TkCanvasPolygon(cv, ,\n",
/* Perl/Tkx */
" $cv->create_polygon(\n"
};
static char *tk_poly_end[TK_LANG_MAX] = {
/* Tcl */
" -fill %s -outline {}\n",
/* Perl */
" -fill => q{%s}, -outline => q{});\n",
/* Python */
"\t\tfill='%s', outline='')\n",
/* Ruby */
" 'fill'=>'%s', 'outline'=>'')\n",
/* Rexx */
"\t'-fill', '%s', '-outline', '')\n",
/* Perl/Tkx */
" -fill => q{%s});\n",
};
TERM_PUBLIC void
TK_filled_polygon(int points, gpiPoint *corners)
{
int i;
TK_flush_line();
/* avoid duplicate last point */
if ((points > 2) && (corners[0].x == corners[points-1].x) && (corners[0].y == corners[points-1].y))
points--;
fputs(tk_poly_begin[tk_script_language], gpoutfile);
for (i = 0; i < points; i++)
fprintf(gpoutfile, tk_poly_point[tk_script_language], corners[i].x, TK_YMAX - corners[i].y);
fprintf(gpoutfile, tk_poly_end[tk_script_language], tk_color);
}
TERM_PUBLIC void
TK_path(int p)
{
if (p == 0) { /* start new path */
TK_flush_line();
tk_in_path = TRUE;
tk_polygon_points = 0;
FPRINTF((stderr, "tkcanvas: newpath\n"));
} else if (p == 1) { /* close path */
int i;
FPRINTF((stderr, "tkcanvas: closepath: %i points\n", tk_polygon_points));
if (tk_polygon_points > 1) {
fputs(tk_line_segment_start[tk_script_language], gpoutfile);
for (i = 0; i < tk_polygon_points; i++)
fprintf(gpoutfile, tk_poly_point[tk_script_language], tk_path_x[i], tk_path_y[i]);
fprintf(gpoutfile, tk_line_segment_opt[tk_script_language], tk_color, tk_linewidth,
tk_rounded ? "round" : "butt", tk_rounded ? "round" : "miter");
if (tk_dashpattern[0] != NUL)
fprintf(gpoutfile, tk_line_segment_dash[tk_script_language], tk_dashpattern);
fputs(tk_line_segment_end[tk_script_language], gpoutfile);
fputs(tk_nobind[tk_script_language], gpoutfile);
}
tk_in_path = FALSE;
tk_polygon_points = 0;
}
}
static void
TK_add_path_point(int x, int y)
{
if (tk_polygon_points >= tk_maxpath) {
tk_maxpath += 10;
tk_path_x = (int *) gp_realloc(tk_path_x, tk_maxpath * sizeof(int), "path_x");
tk_path_y = (int *) gp_realloc(tk_path_y, tk_maxpath * sizeof(int), "path_y");
}
tk_path_x[tk_polygon_points] = x;
tk_path_y[tk_polygon_points] = y;
tk_polygon_points++;
FPRINTF((stderr, "tkcanvas: new polygon point: %i %i\n", x, y));
}
#ifdef WRITE_PNG_IMAGE
TERM_PUBLIC void
TK_image(unsigned m, unsigned n, coordval * image, gpiPoint * corner, t_imagecolor color_mode)
{
int width = ABS(corner[0].x - corner[1].x);
int height = ABS(corner[0].y - corner[1].y);
char * basename = "gp";
char * fname;
TK_flush_line();
/* Write the image to a png file */
fname = (char *) gp_alloc(strlen(basename) + 16, "TK_image");
sprintf(fname, "%s_image_%02d.png", basename, ++tk_image_counter);
write_png_image(m, n, image, color_mode, fname);
/* FIXME: Only Tcl support, needs external `rescale` command. */
fprintf(gpoutfile, "set image%d [image create photo -file {%s}]\n", tk_image_counter, fname);
fprintf(gpoutfile, "set image%dr [resize $image%d [expr $cmx*%d/1000] [expr $cmy*%d/1000]]\n", tk_image_counter, tk_image_counter, width, height);
fprintf(gpoutfile, "$cv create image [expr $cmx*%d/1000] [expr $cmy*%d/1000] -anchor nw -image $image%dr\n", corner[0].x, TK_YMAX - corner[0].y, tk_image_counter);
}
#endif
static char *tk_box[TK_LANG_MAX] = {
/* Tcl */
" $cv raise boxedtext [$cv create rectangle [$cv bbox boxedtext] -fill {%s} -outline {%s}]\n",
/* Perl */
" $cv->raise(q{boxedtext}, $cv->createRectangle($cv->bbox(q{boxedtext}),\n"
" -fill => q{%s}, -outline => q{%s}));\n",
/* Python */
"\tcv.tag_raise('boxedtext', cv.create_rectangle(cv.bbox('boxedtext'),\\\n"
"\t\tfill='%s', outline='%s'))\n",
/* Ruby */
" cr=cv.raise('boxedtext', TkcRectangle.new(cv, cv.bbox('boxedtext'),\\\n"
" 'fill'=>'%s', 'outline'=>'%s'))\n",
/* Rexx */
"", /* TkCanvasRaise is not available */
/*
" obj = TkCanvasRaise(cv, 'boxedtext', TkCanvasRectangle(TkBbox(cv, 'boxedtext'), ,\n"
"\t'-fill', '%s', '-outline', '%s'))\n",
*/
/* Perl/Tkx */
" $cv->raise(q{boxedtext}, $cv->create_rectangle($cv->bbox(q{boxedtext}),\n"
" -fill => q{%s}, -outline => q{%s}));\n"
};
static char *tk_box_finish[TK_LANG_MAX] = {
/* Tcl */
" $cv dtag boxedtext\n",
/* Perl */
" $cv->dtag(q{boxedtext});\n",
/* Python */
"\tcv.dtag('boxedtext')\n",
/* Ruby */
" cr=cv.dtag('boxedtext')\n",
/* Rexx */
" obj = TkCanvasDTag(cv, 'boxedtext')\n",
/* Perl/Tkx */
" $cv->dtag(q{boxedtext});\n"
};
#ifdef EAM_BOXED_TEXT
TERM_PUBLIC void
TK_boxed_text(unsigned int x, unsigned int y, int option)
{
switch (option) {
case TEXTBOX_INIT:
tk_boxed = TRUE;
break;
case TEXTBOX_BACKGROUNDFILL:
fprintf(gpoutfile, tk_box[tk_script_language], tk_color, "");
break;
case TEXTBOX_GREY:
fprintf(gpoutfile, tk_box[tk_script_language], "grey75", "");
break;
case TEXTBOX_OUTLINE:
fprintf(gpoutfile, tk_box[tk_script_language], "", "black");
/* fall through, this also ends text box mode */
case TEXTBOX_FINISH:
fputs(tk_box_finish[tk_script_language], gpoutfile);
tk_boxed = FALSE;
break;
case TEXTBOX_MARGINS:
/* FIXME: cannot resize margins */
break;
}
}
#endif
#endif /* TERM_BODY */
#ifdef TERM_TABLE
TERM_TABLE_START(tkcanvas)
"tkcanvas", "Tk canvas widget",
TK_XMAX, TK_YMAX, TK_VCHAR, TK_HCHAR, TK_VTIC, TK_HTIC,
TK_options, TK_init, TK_reset,
TK_text, null_scale, TK_graphics, TK_move, TK_vector,
TK_linetype, TK_put_text, null_text_angle,
TK_justify_text, TK_point, TK_arrow, TK_set_font,
NULL /* set_pointsize */,
TERM_CAN_MULTIPLOT | TERM_ENHANCED_TEXT,
/* FIXME: Options not yet implemented */
/* TERM_CAN_DASH | TERM_LINEWIDTH | TERM_FONTSCALE, */
NULL /* suspend */, NULL /* resume */,
TK_fillbox, TK_linewidth,
#ifdef USE_MOUSE
NULL, NULL, NULL, NULL, NULL,
#endif
TK_make_palette, NULL, TK_color,
TK_filled_polygon, NULL /* image */,
TK_enhanced_open, TK_enhanced_flush, do_enh_writec,
NULL /* layer */, TK_path,
0.0,
NULL /* hypertext */,
#ifdef EAM_BOXED_TEXT
TK_boxed_text,
#endif
NULL, TK_dashtype
TERM_TABLE_END(tkcanvas)
#undef LAST_TERM
#define LAST_TERM tkcanvas
#endif /* TERM_TABLE */
#endif /* TERM_PROTO_ONLY */
#ifdef TERM_HELP
START_HELP(tkcanvas)
"1 tkcanvas",
"?commands set terminal tkcanvas",
"?set terminal tkcanvas",
"?set term tkcanvas",
"?terminal tkcanvas",
"?term tkcanvas",
"?tkcanvas",
" This terminal driver generates Tk canvas widget commands in one of the",
" following scripting languages: Tcl (default), Perl, Python, Ruby, or REXX.",
"",
" Syntax:",
" set terminal tkcanvas {tcl | perl | perltkx | python | ruby | rexx}",
" {standalone | input}",
" {interactive}",
" {rounded | butt}",
" {nobackground | background <rgb color>}",
" {{no}rottext}",
" {size <width>,<height>}",
" {{no}enhanced}",
" {externalimages | pixels}",
"",
" Execute the following sequence of Tcl/Tk commands to display the result:",
"",
" package require Tk",
" # the following two lines are only required to support external images",
" package require img::png",
" source resize.tcl",
" source plot.tcl",
" canvas .c -width 800 -height 600",
" pack .c",
" gnuplot .c",
"",
" Or, for Perl/Tk use a program like this:",
"",
" use Tk;",
" my $top = MainWindow->new;",
" my $c = $top->Canvas(-width => 800, -height => 600)->pack;",
" my $gnuplot = do \"plot.pl\";",
" $gnuplot->($c);",
" MainLoop;",
"",
" Or, for Perl/Tkx use a program like this:",
"",
" use Tkx;",
" my $top = Tkx::widget->new(\".\");",
" my $c = $top->new_tk__canvas(-width => 800, -height => 600);",
" $c->g_pack;",
" my $gnuplot = do \"plot.pl\";",
" $gnuplot->($c);",
" Tkx::MainLoop();",
"",
" Or, for Python/Tkinter use a program like this:",
"",
" from tkinter import *",
" from tkinter import font",
" root = Tk()",
" c = Canvas(root, width=800, height=600)",
" c.pack()",
" exec(open('plot.py').read())",
" gnuplot(c)",
" root.mainloop()",
"",
" Or, for Ruby/Tk use a program like this:",
"",
" require 'tk'",
" root = TkRoot.new { title 'Ruby/Tk' }",
" c = TkCanvas.new(root, 'width'=>800, 'height'=>600) { pack { } }",
" load('plot.rb')",
" gnuplot(c)",
" Tk.mainloop",
"",
" Or, for Rexx/Tk use a program like this:",
"",
" /**/",
" call RxFuncAdd 'TkLoadFuncs', 'rexxtk', 'TkLoadFuncs'",
" call TkLoadFuncs",
" cv = TkCanvas('.c', '-width', 800, '-height', 600)",
" call TkPack cv",
" call 'plot.rex' cv",
" do forever",
" cmd = TkWait()",
" if cmd = 'AWinClose' then leave",
" interpret 'call' cmd",
" end",
"",
" The code generated by `gnuplot` (in the above examples, this code is",
" written to \"plot.<ext>\") contains the following procedures:",
"",
" gnuplot(canvas)",
" takes the name of a canvas as its argument.",
" When called, it clears the canvas, finds the size of the canvas and",
" draws the plot in it, scaled to fit.",
"",
" gnuplot_plotarea()",
" returns a list containing the borders of the plotting area",
" (xleft, xright, ytop, ybot) in canvas screen coordinates."
" It works only for 2-dimensional plotting (`plot`).",
"",
" gnuplot_axisranges()",
" returns the ranges of the two axes in plot coordinates",
" (x1min, x1max, y1min, y1max, x2min, x2max, y2min, y2max).",
" It works only for 2-dimensional plotting (`plot`).",
"",
" You can create self-contained, minimal scripts using the `standalone`",
" option. The default is `input` which creates scripts which have to be",
" source'd (or loaded or called or whatever the adequate term is for the",
" language selected).",
"",
" If the `interactive` option is specified, mouse clicking on a line segment",
" will print the coordinates of its midpoint to stdout.",
" The user can supersede this behavior by supplying a procedure",
" user_gnuplot_coordinates which takes the following arguments:",
" win id x1s y1s x2s y2s x1e y1e x2e y2e x1m y1m x2m y2m,",
" i.e. the name of the canvas and the id of the line segment followed by the",
" coordinates of its start and end point in the two possible axis ranges; the",
" coordinates of the midpoint are only filled for logarithmic axes.",
"",
" By default the canvas is `transparent`, but an explicit background color",
" can be set with the `background` option.",
"",
" `rounded` sets line caps and line joins to be rounded;",
" `butt` is the default: butt caps and mitered joins.",
"",
" Text at arbitrary angles can be activated with the `rottext` option,",
" which requires Tcl/Tk 8.6 or later. The default is `norottext`.",
"",
" The `size` option tries to optimize the tic and font sizes for the given",
" canvas size. By default an output size of 800 x 600 pixels is assumed.",
"",
" `enhanced` selects `enhanced text` processing (default), but is currently",
" only available for Tcl.",
"",
" The `pixels` (default) option selects the failsafe pixel-by-pixel image",
" handler, see also `image pixels`.",
" The `externalimages` option saves images as external png images, which",
" are later loaded and scaled by the tkcanvas code. This option is only",
" available for Tcl and display may be slow in some situations since the",
" Tk image handler does not provide arbitrary scaling. Scripts need to source",
" the provided rescale.tcl.",
"",
" Interactive mode is not yet implemented for Python/Tk and Rexx/Tk.",
" Interactive mode for Ruby/Tk does not yet support user_gnuplot_coordinates."
END_HELP(tkcanvas)
#endif