% -*-mode:slang;mode:fold-*- % Copyright (C) 2007 John E. Davis % This file is part of the S-Lang grace Module % The S-Lang grace Module 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. % The S-Lang grace Module 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 library; if not, write to the Free Software % Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, % USA. import ("grace"); require ("structfuns"); private variable FLTFMT = "%e"; private variable Debug = 0; % These come from the grace 5.1.21 source code private variable MAX_PATTERNS = 32; private variable MAX_LINESTYLES = 32; private variable MAX_LINEWIDTH = 20.0; private variable MAX_SYM = 12; private variable MAX_COLORS = 256; %{{{ Utility Functions private define quote_object (x) { if (typeof (x) != String_Type) return x; (x, ) = strreplace (x, "\n", "\\n", strlen (x)); return sprintf ("\"%s\"", str_quote_string (x, "\"", '\\')); } private define bool_to_onoff (x) { if (x == NULL) return NULL; if (x) return "on"; else return "off"; } private define validate_linestyle (v) { if (v == NULL) return v; return abs(v) mod MAX_LINESTYLES; } private define validate_linewidth (v) { if (v == NULL) return v; v = abs(v); if (v >= MAX_LINEWIDTH) v = 1.0; return v; } private define validate_symbol (v) { if (v == NULL) return v; return abs(v) mod MAX_SYM; } private define validate_pattern (v) { if (v == NULL) return v; return abs(v) mod MAX_PATTERNS; } %}}} private define grace_cmd () %{{{ { variable args = __pop_list (_NARGS-1); variable fp = (); foreach (args) { variable arg = (); if (arg == NULL) return; } if (-1 == fprintf (fp, __push_list(args))) throw IOError, "write to grace failed"; if (Debug) { if (-1 == fprintf (stdout, __push_list(args))) throw IOError, "write to grace failed"; } } %}}} private define g_redraw (g) { grace_cmd (g.fp, "redraw\n"); () = fflush (g.fp); } private define redraw (g) { if (g.no_redraw) return; g_redraw (g); } %{{{ Color Map routines private variable Color_Map = Assoc_Type[Int_Type, -1]; Color_Map["white"] = 0; Color_Map["black"] = 1; Color_Map["red"] = 2; Color_Map["green"] = 3; Color_Map["blue"] = 4; Color_Map["yellow"] = 5; Color_Map["brown"] = 6; Color_Map["grey"] = 7; Color_Map["violet"] = 8; Color_Map["cyan"] = 9; Color_Map["magenta"] = 10; Color_Map["orange"] = 11; Color_Map["indigo"] = 12; Color_Map["maroon"] = 13; Color_Map["turquoise"] = 14; Color_Map["green4"] = 15; private variable Max_Color = 15; private define g_get_colors () { variable c = assoc_get_keys (Color_Map); variable n = assoc_get_values (Color_Map); return c[array_sort(n)]; } private define g_new_color () { variable g, id, name, rgb; if (_NARGS != 3) usage (".new_color(name,rgb [;id=int])"); (g, name, rgb) = (); name = strlow (name); id = Color_Map[name]; if (id == -1) id = Max_Color+1; id = qualifier ("id", id); if (id == NULL) id = Max_Color+1; if ((id < 0) || (id >= MAX_COLORS)) throw InvalidParmError, "Colormap id out of range"; if (typeof (rgb) != Array_Type) rgb = [(rgb&0xFF0000) shr 16, (rgb&0xFF00) shr 8, (rgb&0xFF)]; rgb = abs(rgb) mod 256; grace_cmd (g.fp, "map color %d to (%d, %d, %d), %s\n", id, rgb[0], rgb[1], rgb[2], quote_object (name)); Color_Map[name] = id; if (id > Max_Color) Max_Color = id; } private define lookup_color (c) { if (c == NULL) return NULL; if (typeof (c) == String_Type) { variable id = Color_Map[c]; if (id == -1) { vmessage ("Warning: color %s is not defined", c); return 1; } return id; } c = typecast (c, Int_Type); if ((c < 0) || (c > Max_Color)) c = 1; return c; } %}}} %{{{ Titles and Axis Labels private define handle_title_qualifiers (g, title_type) { variable color = qualifier ("color", NULL); variable size = qualifier ("size", NULL); variable font = qualifier ("font", NULL); variable fp = g.fp; if (color != NULL) grace_cmd (fp, "%s color %S\n", title_type, quote_object(color)); if (size != NULL) grace_cmd (fp, "%s size ${FLTFMT}\n"$, title_type, size); if (font != NULL) grace_cmd (fp, "%s font %d\n", title_type, font); } private define g_title () { variable args = __pop_args (_NARGS-1); variable g = (); variable title = sprintf (__push_args (args)); grace_cmd (g.fp, "with g%d\ntitle \"%s\"\n", g.curr.id, title); handle_title_qualifiers (g, "title" ;;__qualifiers ()); redraw (g); } private define g_subtitle () { variable args = __pop_args (_NARGS-1); variable g = (); variable title = sprintf (__push_args (args)); grace_cmd (g.fp, "with g%d\nsubtitle \"%s\"\n", g.curr.id, title); handle_title_qualifiers (g, "subtitle" ;;__qualifiers ()); redraw (g); } private define handle_label_qualifiers (g, axis) { variable color = qualifier ("color", NULL); variable size = qualifier ("size", NULL); variable font = qualifier ("font", NULL); variable fp = g.fp; if (color != NULL) grace_cmd (fp, "%s label color %S\n", axis, quote_object(color)); if (size != NULL) grace_cmd (fp, "%s label char size ${FLTFMT}\n"$, axis, size); if (font != NULL) grace_cmd (fp, "%s label font %d\n", axis, font); } private define g_xlabel () { variable args = __pop_args (_NARGS-1); variable g = (); variable title = sprintf (__push_args (args)); grace_cmd (g.fp, "with g%d\nxaxis label \"%s\"\n", g.curr.id, title); handle_label_qualifiers (g, "xaxis" ;;__qualifiers ()); redraw (g); } private define g_ylabel () { variable args = __pop_args (_NARGS-1); variable g = (); variable title = sprintf (__push_args (args)); grace_cmd (g.fp, "with g%d\nyaxis label \"%s\"\n", g.curr.id, title); handle_label_qualifiers (g, "yaxis" ;;__qualifiers ()); redraw (g); } %}}} private define g_label () { if (_NARGS != 4) { usage (".label(string, x, y)"); } variable g, x, y, str; (g, str, x, y) = (); variable loctype = "world"; if (qualifier_exists ("viewport")) loctype = "view"; variable gr = g.curr; variable fp = g.fp; grace_cmd (fp, "with string\n"); grace_cmd (fp, "string on\n"); grace_cmd (fp, "string loctype %s\n", loctype); grace_cmd (fp, "string g%d\n", gr.id); grace_cmd (fp, "string ${FLTFMT}, ${FLTFMT}\n"$, x, y); grace_cmd (fp, "string color %S\n", lookup_color (qualifier("color", 1))); grace_cmd (fp, "string rot %d\n", qualifier("rot", 0)); grace_cmd (fp, "string font %d\n", qualifier("font", 0)); grace_cmd (fp, "string just %d\n", qualifier("just", 0)); grace_cmd (fp, "string char size %g\n", qualifier("size", 1)); grace_cmd (fp, "string def %s\n", quote_object (str)); list_append (gr.string_ids, g.next_string_id); g.next_string_id++; redraw (g); } %{{{ World coordinate routines private define output_one_world (fp, obj, wp, d) { variable w = @wp; if (w == NULL) { w = d; if (w == NULL) return; } grace_cmd (fp, "world %s ${FLTFMT}\n"$, obj, w); @wp = w; } private define compute_major_minor_tics (islog, xmin, xmax) { if (islog) { return 10, 1; } if ((xmin == NULL) || (xmax == NULL)) return 1, 0.5; variable delta = xmax - xmin; if (delta == 0.0) { return 1, 0.5; } variable multiplier = 10.0^(nint(log10 (delta))-1); variable max_tics = 6; variable major = 1.0; variable intervals = [1.0, 2.0, 5.0]; foreach (intervals*multiplier) { major = (); if (delta <= major*max_tics) break; } return major, major/5.0; } private define expand_world_limits (xmin, xmax, islog) { if ((xmin == NULL) || (xmax == NULL)) return (xmin, xmax); variable f = 0.05; if (islog) { xmax = log10 (xmax); xmin = log10 (xmin); } variable dx = f*(xmax - xmin); xmin -= dx; xmax += dx; if (islog) { xmin = 10^xmin; xmax = 10^xmax; } return xmin, xmax; } private define output_world (g) { variable gr = g.curr; variable id = gr.id; variable fp = g.fp; grace_cmd (fp, "with g%d\n", id); variable xmin = gr.world_xmin; variable xmax = gr.world_xmax; variable ymin = gr.world_ymin; variable ymax = gr.world_ymax; variable dxmin = gr.data_xmin; variable dxmax = gr.data_xmax; variable dymin = gr.data_ymin; variable dymax = gr.data_ymax; variable logx = gr.logx; variable logy = gr.logy; (dxmin, dxmax) = expand_world_limits (dxmin, dxmax, logx); (dymin, dymax) = expand_world_limits (dymin, dymax, logy); if ((xmin != NULL) || (dxmin != dxmax)) { output_one_world (fp, "xmin", &xmin, dxmin); output_one_world (fp, "xmax", &xmax, dxmax); } if ((ymin != NULL) || (dymin != dymax)) { output_one_world (fp, "ymin", &ymin, dymin); output_one_world (fp, "ymax", &ymax, dymax); } variable major, minor; (major, minor) = compute_major_minor_tics (logx, xmin, xmax); grace_cmd (fp, "xaxis tick major ${FLTFMT}\n"$, major); grace_cmd (fp, "xaxis tick minor ${FLTFMT}\n"$, minor); (major, minor) = compute_major_minor_tics (logy, ymin, ymax); grace_cmd (fp, "yaxis tick major ${FLTFMT}\n"$, major); grace_cmd (fp, "yaxis tick minor ${FLTFMT}\n"$, minor); } private define gr_set_autoscale (gr) { gr.world_xmin = NULL, gr.world_xmax = NULL; gr.world_ymin = NULL, gr.world_ymax = NULL; } private define g_world () { variable g, gr, xmin, ymin, xmax, ymax; switch (_NARGS) { case 1: g = (); gr = g.curr; gr_set_autoscale (gr); } { case 5: (g, xmin, xmax, ymin, ymax) = (); gr = g.curr; if (xmin != NULL) gr.world_xmin = xmin; if (xmax != NULL) gr.world_xmax = xmax; if (ymin != NULL) gr.world_ymin = ymin; if (ymax != NULL) gr.world_ymax = ymax; } { _pop_n (_NARGS); usage (".world ( [ xmin, ymin, xmax, ymax ] )"); } if (gr.num_sets) { output_world (g); redraw (g); } } private define g_xrange (g, xmin, xmax) { g.world (xmin, xmax, NULL, NULL); } private define g_yrange (g, ymin, ymax) { g.world (NULL, NULL, ymin, ymax); } %}}} private define g_clear () %{{{ { variable g = (); variable gr = g.curr; variable fp = g.fp; _for (0, gr.num_sets-1, 1) { variable set_id = (); grace_cmd (fp, "kill g%d.s%d\n", gr.id, set_id); } if (gr.num_sets) output_world (g); gr.num_sets = 0; gr.data_xmin = NULL; gr.data_xmax = NULL; gr.data_ymin = NULL; gr.data_ymax = NULL; while (length (gr.string_ids)) { grace_cmd (fp, "with string %d\nstring off\n", list_pop (gr.string_ids)); } redraw (g); } %}}} private define new_graph (id, fp) %{{{ { variable graph = struct { id = id, % graph_id num_sets = 0, % number of data sets for graph fp = fp, logx = 0, logy = 0, world_xmin = NULL, world_xmax = NULL, world_ymin = NULL, world_ymax = NULL, data_xmin = NULL, data_xmax = NULL, data_ymin = NULL, data_ymax = NULL, graph_type = "XY", string_ids = {}, }; return graph; } %}}} %{{{ Focus Method private define find_graph_by_row_col (g, row, col) { return g.graphs[g.ncols * row + col]; } private define find_graph_by_name (g, name) { return g.graphs[0]; } private define focus_internal (g, gr) { g.curr = gr; grace_cmd (g.fp, "focus g%d\nwith g%d\n", gr.id, gr.id); } private define g_focus () { variable row, col, g, gr; switch (_NARGS) { case 3: (g, row, col) = (); gr = find_graph_by_row_col (g, row-1, col-1); } { case 2: row = 0; (g, col) = (); if (typeof (col) == String_Type) gr = find_graph_by_name (g, col); else gr = find_graph_by_row_col (g, 0, col-1); } { case 1: g = (); gr = find_graph_by_row_col (g, (g.curr.id + 1) mod length(g.graphs)); } { usage ("focus (g, [row,col] | n | name) %% row,col = 1,2,.."); } focus_internal (g, gr); redraw (g); } %}}} %{{{ Save Method private variable Device_Map = Assoc_Type[String_Type,""]; Device_Map["ps"] = "PostScript"; % case is important Device_Map["eps"] = "EPS"; Device_Map["png"] = "PNG"; Device_Map["jpg"] = "JPEG"; Device_Map["jpeg"] = "JPEG"; Device_Map["agr"] = "AGR"; private define g_save () { if (_NARGS != 2) usage (".save (filename [;dev=device])"); variable g, file; (g, file) = (); variable ext = strlow (path_extname (file)); if (ext == "") { ext = ".agr"; } ext = ext[[1:]]; variable dev = qualifier ("dev"); % as an extension if (dev == NULL) dev = Device_Map[ext]; else { dev = Device_Map[dev]; } if (dev == "") throw NotImplementedError, "Print device is unknown to this interface"; variable fp = g.fp; % On debian, xmgrace will crash when overwriting a file-- so remove % it first. ()=remove(file); if (dev == "AGR") grace_cmd (fp, "saveall \"%s\"\n", file); else { grace_cmd (fp, "print to %s\n", quote_object(file)); grace_cmd (fp, "hardcopy device \"%s\"\n", dev); grace_cmd (fp, "print\n"); } () = fflush (g.fp); } %}}} private define g_close (g) %{{{ { _grace_close (g.fd); % Set anything that might contain an fp to NULL to ensure that % destructors are run on it now. g.curr = NULL; g.graphs = NULL; g.fd = NULL; g.fp = NULL; } %}}} %{{{ Log/Linear Methods private define output_graph_scale (g, logx, logy) { variable id = g.curr.id; if (logx) logx = "LOGARITHMIC"; else logx = "NORMAL"; if (logy) logy = "LOGARITHMIC"; else logy = "NORMAL"; grace_cmd (g.fp, "with g%d\n", id); grace_cmd (g.fp, "XAXES SCALE %s\n", logx); grace_cmd (g.fp, "YAXES SCALE %s\n", logy); redraw (g); } private define set_graph_scale (g, logx, logy) { variable gr = g.curr; if (logx != NULL) gr.logx = logx; if (logy != NULL) gr.logy = logy; output_graph_scale (g, gr.logx, gr.logy); } private define g_logx (g) { set_graph_scale (g, 1, NULL); } private define g_logy (g) { set_graph_scale (g, NULL, 1); } private define g_linx (g) { set_graph_scale (g, 1, NULL); } private define g_liny (g) { set_graph_scale (g, NULL, 1); } %}}} %{{{ Tick Methods private define output_tick_info (axis, nargs) { variable g, enable_major = NULL, enable_minor = NULL; switch (nargs) { case 1: g = (); } { case 2: (g, enable_major) = (); } { case 3: (g, enable_major, enable_minor) = (); } { _pop_n(nargs); usage (".%stick ([enable_major [,enable_minor]] [;qualifiers]\n" + "qualifiers:\n" + " offsetx=val, offsety=val, dir=val, size=val, color=val\n", " majorstyle=linestyle, majorwidth=width, majorsize=val, majorcolor=val, majorcolor=val\n", " minorstyle=linestyle, minorwidth=width, minorsize=val, minorcolor=val, minorcolor=val\n", " majorgrid=0|1, minorgrid=0|1\n" , axis); } variable fp = g.fp; grace_cmd (fp, "%saxis tick major %s\n", axis, bool_to_onoff(enable_major)); grace_cmd (fp, "%saxis tick minor %s\n", axis, bool_to_onoff(enable_minor)); grace_cmd (fp, "%saxis tick offsetx %g\n", axis, qualifier("offsetx")); grace_cmd (fp, "%saxis tick offsety %g\n", axis, qualifier("offsety")); variable dir = qualifier ("dir"); if (dir != NULL) { if (dir == 0) dir = "both"; else if (dir < 0) dir = "out"; else dir = "in"; grace_cmd (fp, "%s axis tick %s\n", dir); } grace_cmd (fp, "%saxis tick size %g\n", axis, qualifier("size")); grace_cmd (fp, "%saxis tick color %S\n", axis, lookup_color(qualifier("color"))); foreach (["major", "minor"]) { variable m = (); grace_cmd (fp, "%saxis tick %s linestyle %g\n", axis, m, qualifier("${m}style"$)); grace_cmd (fp, "%saxis tick %s linewidth %g\n", axis, m, qualifier("${m}width"$)); grace_cmd (fp, "%saxis tick %s size %g\n", axis, m, qualifier("${m}size"$)); grace_cmd (fp, "%saxis tick %S color %S\n", axis, m, lookup_color(qualifier("${m}color"$))); grace_cmd (fp, "%saxis tick %s grid %s\n", axis, m, bool_to_onoff (qualifier("${m}grid"$))); } redraw (g); } private define g_xtick () { output_tick_info ("x", _NARGS;;__qualifiers); } private define g_ytick () { output_tick_info ("y", _NARGS;; __qualifiers); } private define g_xtick () { output_tick_info ("x", _NARGS;;__qualifiers); } private define g_tick () { variable args = __pop_args (_NARGS); g_xtick (__push_args (args) ;; __qualifiers); g_ytick (__push_args (args) ;; __qualifiers); } %}}} %{{{ Plot/Oplot Methods private define get_data_limits (x, dmin, dmax) { if (dmin == NULL) dmin = min (x); else dmin = _min (min(x), dmin); if (dmax == NULL) dmax = max (x); else dmax = _max (max(x), dmax); return dmin, dmax; } private variable Plot_Set_Type_Map = Array_Type [6+1]; Plot_Set_Type_Map[2] = ["xy", "bar"]; Plot_Set_Type_Map[3] = ["xydy", "xydx", "bardy", "xyz", "xyr", "xysize", "xycolor"]; Plot_Set_Type_Map[4] = ["xydxdy", "xydxdx", "xydydy", "bardydy", "xycolpat", "xyvmap"]; Plot_Set_Type_Map[5] = ["xyhilo"]; Plot_Set_Type_Map[6] = ["xydxdxdydy", "xyboxplot"]; private variable GRAPH_TYPE_XY = 0x0001; private variable GRAPH_TYPE_CHART = 0x0002; private variable GRAPH_TYPE_FIXED = 0x0004; private variable GRAPH_TYPE_POLAR = 0x0008; private variable GRAPH_TYPE_PIE = 0x0010; private variable Graph_Types = Assoc_Type[Int_Type]; Graph_Types["XY"] = GRAPH_TYPE_XY; Graph_Types["CHART"] = GRAPH_TYPE_CHART; Graph_Types["FIXED"] = GRAPH_TYPE_FIXED; Graph_Types["POLAR"] = GRAPH_TYPE_POLAR; Graph_Types["PIE"] = GRAPH_TYPE_PIE; private variable Compatible_Graphs_Map = Assoc_Type[Int_Type, 0]; Compatible_Graphs_Map["xy"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED|GRAPH_TYPE_POLAR|GRAPH_TYPE_PIE; Compatible_Graphs_Map["xydx"] = GRAPH_TYPE_XY|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xydxdx"] = GRAPH_TYPE_XY|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xydxdy"] = GRAPH_TYPE_XY|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xydxdxdydy"] = GRAPH_TYPE_XY|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xydy"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xydydy"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["bar"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED; Compatible_Graphs_Map["bardy"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART; Compatible_Graphs_Map["bardydy"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART; Compatible_Graphs_Map["xyhilo"] = GRAPH_TYPE_XY; Compatible_Graphs_Map["xyz"] = GRAPH_TYPE_XY|GRAPH_TYPE_FIXED|GRAPH_TYPE_POLAR; Compatible_Graphs_Map["xyr"] = GRAPH_TYPE_FIXED; Compatible_Graphs_Map["xysize"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED|GRAPH_TYPE_POLAR; Compatible_Graphs_Map["xycolor"] = GRAPH_TYPE_XY|GRAPH_TYPE_CHART|GRAPH_TYPE_FIXED|GRAPH_TYPE_POLAR|GRAPH_TYPE_PIE; Compatible_Graphs_Map["xycolpat"] = GRAPH_TYPE_PIE; Compatible_Graphs_Map["xyvmap"] = GRAPH_TYPE_XY|GRAPH_TYPE_PIE; Compatible_Graphs_Map["xyboxplot"] = GRAPH_TYPE_XY; private define check_arrays_and_type (xs, nxs, graphtype, type) { if (type != NULL) type = strlow (type); variable i; variable len = length (xs[0]); _for i (0, nxs-1, 1) { if ((xs[i] == NULL) || (length (xs[i]) != len)) throw TypeMismatchError, "Expecting an array of length $len"$; } variable ok_types = Plot_Set_Type_Map[nxs]; if (type == NULL) type = ok_types[0]; if (NULL == wherefirst (type == ok_types)) throw TypeMismatchError, "Type $type is not compatible with number of arrays"$; variable ok_graphs = Compatible_Graphs_Map[type]; ifnot (ok_graphs & Graph_Types[graphtype]) throw TypeMismatchError, "Type $type is not compatible with graphtype=$graphtype"$; return type; } % Unfortunately grace does not seem to be able to handle NaNs and Infs private define filter_NaNs (xs, nxs) { variable i, is_bad = 0; _for i (0, nxs-1, 1) is_bad += isnan (xs[i]) or isinf(xs[i]); ifnot (any (is_bad)) return; variable j = wherenot (__tmp(is_bad)); _for i (0, nxs-1, 1) xs[i] = xs[i][j]; } private define filter_for_log (xs, nxs, logx, logy) { variable ispos = NULL; if (logx) ispos = (xs[0]>0); if (logy) { if (ispos != NULL) ispos = ispos and (xs[1]>0); else ispos = (xs[1] > 0); } if (ispos == NULL) return; ispos = where(ispos); _for (0, nxs-1, 1) { variable i = (); xs[i] = xs[i][ispos]; } } %{{{ Functions that write to the grace pipe private define send_xs (fp, graphid, setid, xs, nxs) { variable fmt = sprintf ("g%d.s%d point %${FLTFMT}, %${FLTFMT}\n"$, graphid, setid); variable x = xs[0], y = xs[1]; variable n = length (x); variable i; _for i (0, n-1, 1) { if (-1 == fprintf (fp, fmt, x[i], y[i])) throw IOError, "write to grace failed"; } _for (2, nxs-1, 1) { variable j = (); y = xs[j]; fmt = sprintf ("g%d.s%d.y%d[%%d] = %${FLTFMT}\n"$, graphid, setid, j-1); _for i (0, n-1, 1) { if (-1 == fprintf (fp, fmt, i, y[i])) throw IOError, "write to grace failed"; } } () = fflush (fp); } %}}} private define g_plot_internal (name, is_oplot, nargs) { if ((nargs < 2) || (nargs > 7)) { _pop_n(nargs); usage ("Some usage forms:\n" + " .$name (y)\n"$ + " .$name (x, y)\n"$ + " .$name (x, y, dy)\n"$ + " .$name (x, y, dx, dy)\n"$ + "Common qualifiers:\n" + " color=int, line=int, width=flt, sym=int, symcolor=int\n" + " errbar_size=flt errbar_color=int type=str\n"); } if (nargs == 2) { variable x = (); [1:length(x)], x; nargs++; } variable num_arrays = nargs-1; variable i = num_arrays; variable g, xs = Array_Type[6]; while (i) { i--; xs[i] = (); } g = (); variable fp = g.fp; variable gr = g.curr; variable gr_id = gr.id; variable graph_type = gr.graph_type; if (is_oplot == 0) { graph_type = qualifier ("graphtype"); if (graph_type == NULL) graph_type = "XY"; graph_type = strup (graph_type); if (0 == Graph_Types[graph_type]) { vmessage ("graphtype %s is unknown. Assuming XY", graph_type); graph_type = "XY"; } } variable type = check_arrays_and_type (xs, nargs-1, graph_type, qualifier("type")); g.no_redraw++; ifnot (is_oplot) { g.clear (); if (length (g.graphs) == 1) { grace_cmd (fp, "clear string\n"); g.next_string_id = 0; } } variable setid = gr.num_sets; variable q; variable linecolor = lookup_color(qualifier ("color", 1+(setid mod Max_Color))); variable linestyle = validate_linestyle (qualifier ("line",1)); variable linewidth = validate_linewidth (qualifier ("width", 1)); variable line_type = qualifier ("linetype", 1); variable dropline = qualifier_exists ("dropline"); variable sym = qualifier ("sym", 0); variable symcolor = lookup_color(qualifier ("symcolor", linecolor)); variable symfillcolor = qualifier ("symfillcolor", symcolor); variable errbar_linewidth = validate_linewidth (qualifier ("errbar_linewidth", linewidth)); variable errbar_linestyle = validate_linestyle(qualifier ("errbar_linestyle", 1)); if (sym < 0) { sym = -sym; linestyle = 0; } sym = validate_symbol (sym); variable logx = qualifier("logx", gr.logx); logx = (logx == NULL); variable logy = qualifier("logy", gr.logy); logy = (logy == NULL); variable grid = qualifier ("grid", 0); if (grid == NULL) grid = 1; grace_cmd (fp, "with g%d\n", gr.id); ifnot (is_oplot) { grace_cmd (fp, "g0 type %s\n", graph_type); gr.graph_type = graph_type; } variable obj = sprintf ("s%d", setid); grace_cmd (fp, "%s on\n", obj); grace_cmd (fp, "%s type %s\n", obj, type); grace_cmd (fp, "%s line type %d\n", obj, line_type); grace_cmd (fp, "%s dropline %s\n", obj, bool_to_onoff(dropline)); grace_cmd (fp, "%s linestyle %d\n", obj, linestyle); grace_cmd (fp, "%s color %S\n", obj, linecolor); grace_cmd (fp, "%s linewidth ${FLTFMT}\n"$, obj, linewidth); grace_cmd (fp, "%s fill %d\n", obj, qualifier ("fill", 0)); grace_cmd (fp, "%s fill color %S\n", obj, lookup_color(qualifier ("fillcolor", linecolor))); grace_cmd (fp, "%s fill pattern %d\n", obj, qualifier("fillpat")); grace_cmd (fp, "%s symbol %d\n", obj, sym); grace_cmd (fp, "%s symbol color %S\n", obj, symcolor); grace_cmd (fp, "%s symbol size ${FLTFMT}\n"$, obj, qualifier ("symsize", 1)); grace_cmd (fp, "%s symbol fill %d\n", obj, qualifier ("symfill", 0)); grace_cmd (fp, "%s symbol fill color %S\n", obj, symfillcolor); grace_cmd (fp, "%s errorbar on\n", obj); grace_cmd (fp, "%s errorbar place %s\n", obj, qualifier ("errbar_place", "both")); grace_cmd (fp, "%s errorbar color %S\n", obj, lookup_color (qualifier ("errbar_color", symcolor))); grace_cmd (fp, "%s errorbar pattern %d\n", obj, validate_pattern(qualifier ("errbar_pattern", 1))); grace_cmd (fp, "%s errorbar size %g\n", obj, qualifier ("errbar_size", 0.5)); grace_cmd (fp, "%s errorbar linewidth %g\n", obj, errbar_linewidth); grace_cmd (fp, "%s errorbar linestyle %d\n", obj, errbar_linestyle); grace_cmd (fp, "%s errorbar riser linewidth %g\n", obj, validate_linewidth(qualifier ("errbar_riser_linewidth", errbar_linewidth))); grace_cmd (fp, "%s errorbar riser linestyle %d\n", obj, qualifier ("errbar_riser_linestyle", errbar_linestyle)); % grace_cmd (fp, "%s errorbar riser clip off\n", obj); grace_cmd (fp, "%s errorbar riser clip length %g\n", obj, qualifier ("errbar_riser_clip_length")); grace_cmd (fp, "%s baseline type %d\n", obj, qualifier ("baseline_type", 0)); grace_cmd (fp, "%s baseline off\n", obj); if (setid == 0) { g_xtick (g; majorgrid=grid&1, minorgrid=grid&2); g_ytick (g; majorgrid=grid&1, minorgrid=grid&2); set_graph_scale (g, logx, logy); } filter_NaNs (xs, num_arrays); filter_for_log (xs, num_arrays, gr.logx, gr.logy); (gr.data_xmin, gr.data_xmax) = get_data_limits (xs[0], gr.data_xmin, gr.data_xmax); (gr.data_ymin, gr.data_ymax) = get_data_limits (xs[1], gr.data_ymin, gr.data_ymax); output_world (g); send_xs (fp, gr_id, setid, xs, num_arrays); g.no_redraw--; redraw (g); gr.num_sets += 1; } private define g_plot () { return g_plot_internal ("plot", 0, _NARGS;;__qualifiers()); } private define g_oplot () { return g_plot_internal ("oplot", 1, _NARGS;;__qualifiers()); } %}}} private define hplot_internal (name, is_ohplot, nargs) { variable g, xlo, h, dh_args; switch (nargs) { case 3: (g, xlo, h) = (); dh_args = NULL; } { case 4 or case 5: dh_args = __pop_args (nargs-3); (g, xlo, h) = (); } { usage (".$name (x, y [,dy1 [,dy2]] [; .oplot qualifiers])"$); } variable len = length(h); variable len2 = 2*len; variable x = Double_Type[len2]; variable y = Double_Type[len2]; variable xhi; if (len != length(h)) { if (len+1 != length(xlo)) throw TypeMismatchError, "Invalid number of bins for histogram plot"; xhi = xlo[[1:]]; xlo = xlo[[:-2]]; } else { variable last_x = xlo[-2] + (xlo[-1] - xlo[-2]); xhi = shift (xlo, 1); xhi[-1] = last_x; } x[[0::2]] = xlo; x[[1::2]] = xhi; y[[0::2]] = h; y[[1::2]] = h; y[where (isnan (y))] = 0.0; variable fun = &g_plot; if (is_ohplot) fun = &g_oplot; variable draw_errbar_first = 1; variable q; loop (2) { if (draw_errbar_first) { if (dh_args != NULL) { q = __qualifiers; if (q == NULL) q = struct {line}; else q = struct_combine (__qualifiers, "line", "fill"); q.line = 0; q.fill=0; (@fun) (g, 0.5*(xlo+xhi), h, __push_args(dh_args) ;; q); fun = &g_oplot; } draw_errbar_first = 0; continue; } q = __qualifiers; if (q != NULL) { q = struct_combine (__qualifiers, "sym"); q.sym = 0; } (@fun) (g, x, y ;;q); fun = &g_oplot; draw_errbar_first = 1; } } private define g_hplot () { return hplot_internal ("hplot", 0, _NARGS;;__qualifiers()); } private define g_ohplot () { return hplot_internal ("ohplot", 1, _NARGS;;__qualifiers()); } private define g_legend () %{{{ { if (_NARGS != 4) { _pop_n (_NARGS); usage (".legend (xpos, ypos, list-of-strings)"); } variable g, labels, x, y; (g, x, y, labels) = (); variable fp = g.fp, gr = g.curr; grace_cmd (fp, "with g%d\n", gr.id); grace_cmd (fp, "legend on\n"); _for (0, length (labels)-1, 1) { variable i = (); grace_cmd (fp, "s%d legend \"%S\"\n", i, labels[i]); } grace_cmd (fp, "legend loctype %S\n", qualifier ("loctype", "world")); grace_cmd (fp, "legend ${FLTFMT}, ${FLTFMT}\n"$, x, y); grace_cmd (fp, "legend font %S\n", quote_object (qualifier("font",1))); grace_cmd (fp, "legend char size %g\n", qualifier("size", 1)); grace_cmd (fp, "legend color %S\n", lookup_color (qualifier("color", 1))); grace_cmd (fp, "legend vgap %d\n", qualifier ("vgap", 1)); grace_cmd (fp, "legend hgap %d\n", qualifier ("hgap", 1)); grace_cmd (fp, "legend length %d\n", qualifier ("length", 4)); grace_cmd (fp, "legend box %s\n", bool_to_onoff(qualifier("box",1))); grace_cmd (fp, "legend box color %S\n", lookup_color(qualifier("box_color", 1))); grace_cmd (fp, "legend box pattern %d\n", qualifier("box_pattern", 1)); grace_cmd (fp, "legend box linewidth %g\n", qualifier("box_linewidth")); grace_cmd (fp, "legend box linestyle %d\n", qualifier("box_line", 1)); grace_cmd (fp, "legend box fill color %S\n", lookup_color(qualifier("box_fillcolor", 1))); grace_cmd (fp, "legend box fill pattern %d\n", qualifier("box_fillpattern", 0)); redraw (g); } %}}} private define g_multi () %{{{ { if (_NARGS != 3) { _pop_n (_NARGS); usage ("Usage: .multi(nrow, ncols ; offset=val, hgap=val, vgap=val, sizes=array)"); } variable g, nrows, ncols; (g, nrows, ncols) = (); variable offset = qualifier ("offset", 0.15); variable hgap = qualifier ("hgap", 0.3); variable vgap = qualifier ("vgap", 0.3); variable sizes = qualifier ("sizes"); variable fp = g.fp; variable graphs = g.graphs; variable num = length (graphs); variable new_num = nrows * ncols; g.no_redraw++; while (num > new_num) { num--; focus_internal (g, graphs[num]); g.kill (); } while (num < new_num) { list_append (graphs, new_graph (num, fp)); num++; } grace_cmd (fp, "ARRANGE(%d,%d,${FLTFMT},${FLTFMT},${FLTFMT})\n"$, nrows, ncols, offset, hgap, vgap); variable ticklabels = "on"; num = new_num; if ((vgap == 0.0) && (nrows > 1)) { loop (ncols) { num--; focus_internal (g, graphs[num]); grace_cmd (fp, "xaxis ticklabel on\n", ticklabels); } ticklabels = "off"; } while (num > 0) { num--; focus_internal (g, graphs[num]); grace_cmd (fp, "xaxis ticklabel %s\n", ticklabels); } if ((sizes != NULL) && (nrows == 2) && (length(sizes) == nrows)) { % Adjust the viewport sizes sizes *= nrows/sum(sizes); variable row = 0; num = 0; loop (ncols) { %vy2-vy1' = sizes*(vy2-vy1) focus_internal (g, graphs[num]); grace_cmd (fp, "view ymin VY2-(VY2-VY1)*%g\n", sizes[row]); num++; } row++; loop(ncols) { % vy2'-vy1 = sizes*(vy2-vy1) focus_internal (g, graphs[num]); grace_cmd (fp, "view ymax VY1+(VY2-VY1)*%g\n", sizes[row]); num++; } } g.no_redraw--; redraw (g); g.nrows = nrows; g.ncols = ncols; } %}}} private define g_kill (g) %{{{ { variable gr = g.curr, graphs = g.graphs, i; i = 0; _for i (0, length (graphs)-1, 1) { if (gr != graphs[i]) continue; list_delete (graphs, i); break; } g_clear (g); grace_cmd (g.fp, "kill g%d\n", gr.id); variable nrows = length(graphs); g.ncols = 1; g.nrows = nrows; if (nrows == 0) g.graphs = {new_graph(0, g.fp)}; g.focus (i mod length(g.graphs)); redraw (g); } %}}} private define g_viewport () { if (_NARGS != 5) usage (".viewport(xmin,xmax,ymin,ymax)"); variable g, xmin, xmax, ymin, ymax; (g, xmin, xmax, ymin, ymax) = (); if (xmin > xmax) (xmin,xmax) = (xmax,xmin); if (ymin > ymax) (ymin,ymax) = (ymax,ymin); if ((xmin == xmax) || (ymin == ymax)) { message ("The viewport size must be non-zero"); return; } variable fp = g.fp; grace_cmd (fp, "with g%d\n", g.curr.id); grace_cmd (fp, "view xmin %g\n", xmin); grace_cmd (fp, "view xmax %g\n", xmax); grace_cmd (fp, "view ymin %g\n", ymin); grace_cmd (fp, "view ymax %g\n", ymax); redraw (g); } private define g_pagesize () { if (_NARGS != 3) usage (".pagesize ( dx,dy | \"letter\"|\"a4\" [;qualifiers])" + "Qualifiers: landscape, portrait, units=cm|in"); variable g, dx = 792, dy = 612, orient = NULL; if (qualifier_exists ("landscape")) orient = "landscape"; if (qualifier_exists ("portrait")) orient = "portrait"; variable units = qualifier ("units"); switch (_NARGS) { case 3: (g, dx, dy) = (); } { case 2: variable paper = strlow (()); if (paper == "a4") (dx,dy) = (842,595); else (dx,dy) = (792,612); units = NULL; } { usage (".pagesize ( dx,dy | \"letter\" | \"a4\")"); } if (((orient == "landscape") && (dx < dy)) || ((orient == "portrait") && (dx > dy))) (dx, dy) = (dy, dx); if (units != NULL) { units = strlow(units); variable factor = 72; if (units == "cm") factor = 72/2.54; (dx, dy) = (nint (dx*factor), nint(dy*factor)); } if ((dx <= 0) || (dy <= 0)) { vmessage ("Invalid page size specification"); return; } grace_cmd (g.fp, "page size %d %d\n", dx, dy); if ((g.nrows == 1) && (g.ncols == 1)) g_multi (g,1,1); redraw (g); } define grace_new () { variable fd; variable default_args = ["xmgrace", "-nosafe"]; if (NULL == getenv ("DISPLAY")) default_args = ["gracebat", "-nosafe"]; if (_NARGS) { variable args = __pop_args (_NARGS); default_args = [__push_args (args)]; } fd = _grace_open (default_args); if (fd == NULL) throw RunTimeError, "Unable to open a grace subprocess"; variable fp = fdopen (fd, "w"); variable g = struct { fd = fd, fp = fp, curr = NULL, graphs = { new_graph (0, fp) }, % methods plot = &g_plot, oplot = &g_oplot, hplot = &g_hplot, ohplot = &g_ohplot, xrange = &g_xrange, yrange = &g_yrange, world = &g_world, ylabel = &g_ylabel, xlabel = &g_xlabel, title = &g_title, subtitle = &g_subtitle, redraw = &g_redraw, clear = &g_clear, focus = &g_focus, save = &g_save, close = &g_close, multi = &g_multi, kill = &g_kill, logx = &g_logx, logy = &g_logy, linx = &g_linx, liny = &g_liny, legend = &g_legend, xtick = &g_xtick, ytick = &g_ytick, tick = &g_tick, label = &g_label, viewport = &g_viewport, pagesize = &g_pagesize, new_color = &g_new_color, get_colors = &g_get_colors, nrows = 1, ncols = 1, next_string_id = 0, no_redraw = 0, }; g.curr = g.graphs [0]; % Add some Xfig colors g_new_color (g, "blue4", 0x000090); g_new_color (g, "blue3", 0x0000b0); g_new_color (g, "blue2", 0x0000d0); g_new_color (g, "ltblue", 0x87ceff); %g_new_color (g, "green4", 0x009000); g_new_color (g, "green3", 0x00b000); g_new_color (g, "green2", 0x00d000); g_new_color (g, "cyan4", 0x009090); g_new_color (g, "cyan3", 0x00b0b0); g_new_color (g, "cyan2", 0x00d0d0); g_new_color (g, "red4", 0x900000); g_new_color (g, "red3", 0xb00000); g_new_color (g, "red2", 0xd00000); g_new_color (g, "magenta4", 0x900090); g_new_color (g, "magenta3", 0xb000b0); g_new_color (g, "magenta2", 0xd000d0); g_new_color (g, "brown4", 0x803000); g_new_color (g, "brown3", 0xa04000); g_new_color (g, "brown2", 0xc06000); g_new_color (g, "pink4", 0xff8080); g_new_color (g, "pink3", 0xffa0a0); g_new_color (g, "pink2", 0xffc0c0); g_new_color (g, "pink", 0xffe0e0); return g; }