Permalink
Fetching contributors…
Cannot retrieve contributors at this time
1075 lines (913 sloc) 28 KB
%% therion source code
%%
%% therion.mp
%%
%% This file defines low-level MetaPost macros and variables required
%% for generation of map symbols
%%
%% $Date: 2003/07/01 09:06:44 $
%% $RCSfile: therion.mp,v $
%% $Revision: 1.3 $
%%
%% Copyright (C) 2000-2003 Martin Budaj
%%
%% Some macros are adapted from MPATTERN package of P. Bolek
%%
%% Some macros are used from MetaFun package of H. Hagen
%%
%% --------------------------------------------------------------------
%% This program is free software; you can redistribute it and/or modify
%% it under the terms of the GNU General Public License as published by
%% the Free Software Foundation; either version 2 of the License, or
%% any later version.
%%
%% This program is distributed in the hope that it will be useful,
%% but WITHOUT ANY WARRANTY; without even the implied warranty of
%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
%% GNU General Public License for more details.
%%
%% You should have received a copy of the GNU General Public License
%% along with this program; if not, write to the Free Software
%% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
%% --------------------------------------------------------------------
% This file defines low level macros used for map signatures in Therion.
% Before loading this file set `Scale' variable to numeric value
% representing denominator of the scale ratio. Internal variable
% `prologues' is set to 1 by this file. This module loads also
% symbol libraries.
tracingstats:=1;
prologues:=0;
% Set the random seed to a fixed value so therion reproducibly produces the
% same output for a given input.
randomseed:=42;
if known Background: background:=Background fi;
%TrueScale:=Scale;
% @VARIABLE
% symbol_scale --
%
% <I>internal numeric</I>; in map symbol definitions used for scaling
% in <A HREF="#T">T</A> transformation; recommended
% values are 1 or 2.
%newinternal symbol_scale;
%symbol_scale := 1;
% @VARIABLE
% fill_only --
%
% <I>boolean</I>, used in <A HREF="#thdraw">thdraw</A> and
% <A HREF="#thpattfill">thpattfill</A> commands. When set to false, it has
% no effect, when it is true, it suppresses all drawing
% commands with exception of <I>thpermanentfill</I>, so that only filled
% areas are drawn
boolean fill_only, horiz_labels, transparency;
fill_only := false;
horiz_labels:=true;
transparency:=false;
string ATTR__id, ATTR__survey, ATTR__scrap, NorthDir;
boolean ATTR__scrap_centerline;
picture ATTR__text;
numeric ATTR__height;
boolean ATTR__elevation;
ATTR__scrap_centerline := false;
ATTR__height:=0;
ATTR__elevation:=false;
boolean ATTR__shotflag_splay;
ATTR__shotflag_splay:=false;
boolean ATTR__shotflag_duplicate;
ATTR__shotflag_duplicate:=false;
boolean ATTR__shotflag_approx;
ATTR__shotflag_approx:=false;
boolean ATTR__stationflag_splay;
ATTR__stationflag_splay:=false;
color label_fill_color, label_fill_color_tmp;
label_fill_color := (1.0, 1.0, 1.0);
def push_label_fill_color(expr r,g,b) =
label_fill_color_tmp := label_fill_color;
label_fill_color := (r,g,b);
enddef;
def pop_label_fill_color =
label_fill_color := label_fill_color_tmp;
enddef;
def process_filledlabel(expr cent, rot) =
begingroup;
interim bboxmargin:=2.0bp;
q:=((bbox lab) smoothed 2) rotatedaround (cent, rot);
fill q withcolor label_fill_color;
draw lab rotatedaround (cent, rot);
write_circ_bbox(q); % without corners smoothing it was enough to use
% write_bbox(q);
endgroup;
enddef;
numeric area_border_errors;
area_border_errors = 0;
% @VARIABLE
% last_write --
%
% <I>numeric</I>; charcode of last figure which contained
% <A HREF="#write_bbox">write_bbox</A> macro; this value is used by
% <A HREF="#close_file">close_file</A> macro. Initially set to -1.
numeric last_write;
last_write = -1;
% @VARIABLE
% strut_string --
%
% <I>string</I> containing combination of the "highest" and "lowest" character
% in used font; it's used by <A HREF="">free_text</A> macro.
%string strut_string;
%strut_string = "(È";
% @VARIABLE
% file_name --
%
% <I>string</I>, name of file, where <I>write_bbox</I> macro writes
% text clipping path
% @VARIABLE
% s ch --
%
% <I>string</I>, temporary string/char variables
string s, ch, file_name, bg_name, clip_name, lang, diff_pos, diff_neg,
current_scrap, current_src;
% @VARIABLE
% u v w --
%
% <I>internal numeric variables</I> used as basic length units for drawing;
% they are set by <A HREF="#initialize">initialize</A> macro.
% <UL> <LI><I>u</I> -- normal unit decreasing with increasing scale
% <LI><I>v</I> -- like <I>u</I>, but can increase drammaticaly
% when some limit is encountered (to get effects like logarithmic
% scale)
% <LI><I>w</I> -- nearly constant at all scales
% </UL>
% @VARIABLE
% legend_scale --
%
% <I>numeric</I>, length of the longer side of signatures' legend box
newinternal legend_scale, u,v,w;
% @VARIABLE
% lab Lab --
%
% <I>picture</I>, in which are saved typeset labels
picture lab, Lab;
% @VARIABLE
% T --
%
% <I>transformation</I>, defines transformation function for transforming
% every argument of <A HREF="#thdraw>thdraw</A> and <A HREF="#thfill>thfill</A>
% macros
transform T;
% @VARIABLE
% p,q --
%
% <I>path</I>, for saving temporary paths
path p,q;
% @MACRO
% initialize --
%
% initializes basic length units <A HREF="#u">(u,v,w)</A> and pens used
% in map symbols according to scale. Five circular pens are defined:
% <UL><LI>PenA -- thick; for outlines
% <LI>PenB, PenC -- thinner; for pits, symbols etc.
% <LI>PenD -- thinnest; for fine details
% <LI>PenX -- extra thick; not recommended for use
% </UL>
def fonts_setup (expr t,s,m,l,h) =
write "\def\updown#1#2{\vbox{" &
"\offinterlineskip" &
"\setbox100=\hbox{#1}" &
"\setbox101=\hbox{#2}" &
"\ifnum\wd100>\wd101\hsize=\wd100\else\hsize=\wd101\fi" &
"\centerline{\box100}\vskip4pt" &
"\centerline{\box101}}}" &
"\def\thlabel{\thnormalsize}" &
"\def\thremark{\thsmallsize\si}" &
"\def\thcomment{\thsmallsize}" &
"\def\thentrance{\thsmallsize}" &
"\def\thaltitude{\thsmallsize}" &
"\def\thstationname{\thsmallsize}" &
"\def\thdate{\thsmallsize}" &
"\def\thheight{\thsmallsize}" &
"\def\thheightpos{+\ignorespaces}" &
"\def\thheightneg{-\ignorespaces}" &
"\def\thframed{\thsmallsize}" &
"\def\thwallaltitude{\thtinysize}"
to "mptexpre.tex";
write "\def\thtinysize{\size[" & decimal max(optical_zoom*t,0) & "]}" &
"\def\thsmallsize{\size[" & decimal max(optical_zoom*s,0) & "]}" &
"\def\thnormalsize{\size[" & decimal max(optical_zoom*m,0) & "]}" &
"\def\thlargesize{\size[" & decimal max(optical_zoom*l,0) & "]}" &
"\def\thhugesize{\size[" & decimal max(optical_zoom*h,0) & "]}"
to "mptexpre.tex";
write EOF to "mptexpre.tex";
enddef;
def initialize (expr sc) =
if unknown BaseScale: BaseScale = sc; fi;
optical_zoom := BaseScale/sc;
if BaseScale <= 1: % 1:100
u:=14bp; v:=14bp; w:=12bp;
fonts_setup(8,10,12,16,24);
elseif BaseScale <= 2: % 1:200
u:=12bp; v:=12bp; w:=12bp;
fonts_setup(7,8,10,14,20);
elseif BaseScale <= 5: % 1:500
u:=10bp; v:=10bp; w:=12bp;
fonts_setup(6,7,8,10,14);
else:
u:=7bp; v:=14bp; w:=10bp;
fonts_setup(5,6,7,8,10);
fi;
u := optical_zoom * u;
v := optical_zoom * v;
w := optical_zoom * w;
defaultscale := 0.8 * optical_zoom;
def PenA = pencircle scaled (u/10) enddef;
def PenB = pencircle scaled (0.7*u/10) enddef;
def PenC = pencircle scaled (0.5*u/10) enddef;
def PenD = pencircle scaled (0.35*u/10) enddef;
def PenX = pencircle scaled (1.2*u/10) enddef;
legend_scale := 3.14*u;
enddef;
% macro is expanded, we have to know all dimensions and pens before reading
% mpattern macros
initialize(Scale);
vardef thTEX primary s =
write "verbatimtex \input th_enc.tex etex" to "mptextmp.mp";
write "btex \mainfont "&s&" etex" to "mptextmp.mp";
write EOF to "mptextmp.mp";
scantokens "input mptextmp"
enddef;
% @MACRO
% inscale --
%
% zooms objects to scale specified in legend_scale variable (used in legend
% typesetting)
def inscale =
xscaled legend_scale yscaled (0.618*legend_scale)
enddef;
% @MACRO
% draw_legend_box --
%
% draws a legend bounding box and resets drawoptions() options
def draw_legend_box =
clip currentpicture to unitsquare inscale;
drawoptions();
pickup PenB;
draw unitsquare inscale;
enddef;
def clean_legend_box =
unfill unitsquare inscale;
enddef;
def legend_point (expr name) =
% if substring (2,9) of name = "station":
% scantokens(name)((0.5,0.5) inscale);
% else:
scantokens(name)((0.5,0.5) inscale,0,1,(0,0));
% fi;
draw_legend_box;
enddef;
def legend_line (expr name) =
scantokens(name)((((-0.3,.5)..(.3,.7)..(.5,.3)..{dir 80}(1.3,.9)) inscale)
randomized 3mm);
draw_legend_box;
enddef;
% legend_label
% legend_area
% legend_random
% @MACRO
% roundone --
%
% rounds <I>numeric value</I> to one decimal point
vardef roundone(expr n) =
% round(10*n)/10
n
enddef;
% @MACRO
% process_label --
%
% draws a label saved in <I>lab</I> picture variable and calls
% <A HREF="#write_bbox">write_bbox</A> macro.
def process_label (expr cent, rot) =
begingroup;
interim bboxmargin:=0.8bp;
q:=((bbox lab) smoothed 2) rotatedaround (cent, rot);
draw lab rotatedaround (cent, rot);
write_circ_bbox(q); % without corners smoothing it was enough to use
% write_bbox(q);
endgroup;
enddef;
% @MACRO
% process_uplabel --
%
% draws a label into semicircular box and writes clipping path to a file
def process_uplabel =
begingroup;
interim bboxmargin := 0.8 bp;
q:=bbox lab;
endgroup;
alef:=.8-.02*(xpart lrcorner q - xpart llcorner q);
% show alef;
q:=alef[llcorner q,ulcorner q]{up} .. {down}alef[lrcorner q, urcorner q] --
lrcorner q -- llcorner q -- cycle;
draw lab;
draw q;
q:=reverse q;
write_circ_bbox(q);
enddef;
% @MACRO
% process_downlabel --
%
% draws a label into down oriented semicircular box and writes
% clipping path to a file
def process_downlabel =
begingroup;
interim bboxmargin := 0.8 bp;
q:=bbox lab;
endgroup;
alef:=1-(.8-.02*(xpart lrcorner q - xpart llcorner q));
q:=alef[llcorner q,ulcorner q]{down} ..
{up}alef[lrcorner q, urcorner q] --
urcorner q -- ulcorner q -- cycle;
draw lab;
draw q;
write_circ_bbox(q);
enddef;
% @MACRO
% process_updownlabel --
%
% draws a label split into down and up oriented semicircular boxes and
% writes clipping path to a file
def process_updownlabel =
begingroup;
interim bboxmargin := 0.8 bp;
p:=bbox lab;
endgroup;
leftside:=xpart llcorner p;
rightside:=xpart lrcorner p;
draw (xpart llcorner p,.5[ypart llcorner p,ypart ulcorner p]) --
(xpart lrcorner p,.5[ypart llcorner p,ypart ulcorner p]);
alef:=1.05-.02*(xpart lrcorner p - xpart llcorner p);
% alef:=.8-.02*(rightside-leftside);
p:=alef[(leftside, ypart llcorner p),(leftside, ypart ulcorner p)]{up} ..
{down}alef[(rightside, ypart lrcorner p), (rightside, ypart urcorner p)]
-- alef[(rightside, ypart urcorner p), (rightside, ypart lrcorner p)]{down}
.. {up}alef[(leftside, ypart ulcorner p),(leftside, ypart llcorner p)]
-- cycle;
% p:=alef[llcorner p,ulcorner p]{up} .. {down}alef[lrcorner p, urcorner p] --
% aleff[llcorner p,ulcorner p]{down} ..
% {up}aleff[lrcorner p, urcorner p] -- cycle;
draw lab;
draw p;
p:=reverse p;
write_circ_bbox(p);
enddef;
def process_updownlabel_OLD =
p:=bbox lab;
q:=bbox Lab;
leftside:=min(xpart llcorner p, xpart ulcorner q);
rightside:=max(xpart lrcorner p, xpart urcorner q);
draw .5[(leftside, ypart llcorner p),(leftside, ypart ulcorner q)] --
.5[(rightside,ypart lrcorner p),(rightside,ypart urcorner q)];
alef:=.8-.02*(rightside-leftside);
q:=alef[(leftside, ypart llcorner p),(leftside, ypart ulcorner p)]{up} ..
{down}alef[(rightside, ypart lrcorner p), (rightside, ypart urcorner p)]
-- alef[(rightside, ypart urcorner q), (rightside, ypart lrcorner q)]{down}
.. {up}alef[(leftside, ypart ulcorner q),(leftside, ypart llcorner q)]
-- cycle;
draw lab;
draw Lab;
draw q;
q:=reverse q;
write_circ_bbox(q);
enddef;
% @MACRO
% process_boxedlabel --
%
% draws a label into circular box and writes
% clipping path to a file
def process_boxedlabel =
begingroup;
interim bboxmargin:=1.0bp;
q:=bbox lab;
draw lab;
draw q;
write_bbox(q);
endgroup;
enddef;
% @MACRO
% process_circledlabel --
%
% draws a label into circular box and writes
% clipping path to a file
def process_circledlabel =
begingroup;
interim bboxmargin := 0.4 bp;
q:=bbox lab;
endgroup;
q:=point 0 of q .. point 1 of q .. point 2 of q .. point 3 of q .. cycle;
draw lab;
draw q;
write_circ_bbox(q);
enddef;
% @MACRO
% write_bbox --
%
% Arguments:
% <I>path</I> variable -- rectangular bounding box of a label;
% assumptions: path is cyclic, counterclockwise oriented, with four points,
% composed from linear segments;
% see general <A HREF="#write_circ_bbox">write_circ_bbox</A> macro
% Results:
% one file per figure which uses labels with a clipping path in pseudo-pdf
% format
def write_bbox (expr q) =
file_name := jobname & "." & decimal(charcode) & "bbox";
for i:=4 downto 0:
s := decimal(roundone(xpart point i of q)) & " "
& decimal(roundone(ypart point i of q))
& if i=4: " m " else: " l" fi;
write s to file_name;
endfor;
last_write := charcode;
enddef;
% @MACRO
% write_circ_bbox --
%
% Arguments:
% <I>path</I> variable, only assumption is that <I>path</I> is cyclic
% and counterclockwise oriented.
% Results:
% one file per figure which uses labels with a clipping path in pseudo-pdf
% format
def write_circ_bbox expr q =
file_name := jobname & "." & decimal(charcode) & "bbox";
tmp:=length q;
s := decimal(roundone(xpart point tmp of q)) & " "
& decimal(roundone(ypart point tmp of q)) & " m";
write s to file_name;
for i:=tmp downto 1:
s := decimal(roundone(xpart precontrol i of q)) & " "
& decimal(roundone(ypart precontrol i of q)) & " "
& decimal(roundone(xpart postcontrol i-1 of q)) & " "
& decimal(roundone(ypart postcontrol i-1 of q)) & " "
& decimal(roundone(xpart point i-1 of q)) & " "
& decimal(roundone(ypart point i-1 of q)) & " c";
write s to file_name;
endfor;
last_write := charcode;
enddef;
% @MACRO
% close_file --
%
% closes file with a clipping path; it's invoked by <I>endchar</I> macro
def close_file =
if last_write=charcode:
write EOF to jobname & "." & decimal(charcode) & "bbox";
fi;
enddef;
% endchar should run close_file macro
extra_endfig := "close_file;";
% @MACRO
% thdraw --
%
% like plain MetaPost's <I>draw</I>, but draws a <I>path</I> transformed
% (rotated, scaled, shifted) to scrap's coordinates according T variable.
% (If <I>fill_only=false</I>)
def thdrawoptions(text t) =
def _thop_ = t enddef
enddef;
thdrawoptions();
def thdraw expr p =
if not fill_only:
addto currentpicture
if picture p:
also (p transformed T)
else:
doublepath (p transformed T) withpen currentpen
fi
_thop_ _op_
else:
addto currentpicture also nullpicture
fi
enddef;
% @MACRO
% thfill --
%
% fills a <I>path</I> transformed
% (rotated, scaled, shifted) to scrap's coordinates according T variable.
% Filled areas are clipped (like most
% other lines and points) with a clipping path around text labels.
def thfill expr c =
addto currentpicture contour (c transformed T) _thop_ _op_
enddef;
def thfilldraw expr c =
if not fill_only:
addto currentpicture contour (c transformed T) withpen currentpen _thop_ _op_
else:
addto currentpicture contour (c transformed T) _thop_ _op_
fi
enddef;
def thunfill expr c =
thfill c withcolor background
enddef;
def thundraw expr p =
thdraw p withcolor background
enddef;
def thunfilldraw expr c =
thfilldraw c withcolor background
enddef;
def thclean expr c =
if transparency:
thfill c withtransparentcolor tr_bg
else:
thunfill c
fi;
enddef;
def thPatternFill (expr Path, Pattern) =
T:=identity;
thclean Path;
thfill Path withpattern Pattern;
enddef;
%def thLegendPatternFill (expr Path, Pattern) =
% T:=identity;
% thfill Path withpattern Pattern;
%enddef;
% for drawarrow:
def _finarr text t =
thdraw _apth t;
thfilldraw arrowhead _apth t
enddef;
% @MACRO
% thpermanentfill --
%
% Fills specified area with a solid color; this area is not affected by
% text clipping path
%def thpermanentfill expr c =
% addto currentpicture contour (c transformed T) _thop_ _op_
%enddef;
let thpermanentfill = thfill;
primarydef p aligned al=
p shifted (xpart al * xpart U, ypart al * ypart U)
enddef;
% macros for drawing scraps in upper and lower levels; filled lower scraps
% require special treatment (MetaPost doesn't support non-continuous paths).
% We can't use one file for both, while PDF XObject has to be explicitly
% filled or stroked. Second macro writes also pseudo-pdf code of a clipping
% path for given scrap
boolean drawnext;
drawnext:=true;
def draw_upscrap (expr isout)(text t) =
path q;
for i=t:
if (numeric i):
if (i=1): drawnext:=true; else: drawnext:=false; fi;
else:
if drawnext: draw i withpen PenD; fi;
if not known q: q:=i; else: q:=q -- i; fi;
fi;
endfor;
if not cycle q: q:=q -- cycle; fi;
if turningnumber q = 0:
thwarning("scrap outline intersects itself");
fi;
if isout=1:
if turningnumber q > 0: q := reverse q; fi;
else:
if turningnumber q < 0: q := reverse q; fi;
fi;
addto bgfill contour q;
enddef;
% following macro writes noncontinuous PostScript path directly to EPS file
% (filled background and clipping path)
picture bgfill;
bgfill:=nullpicture;
def draw_downscrap =
bg_name := jobname & "." & decimal(charcode) & "bg";
clip_name := jobname & "." & decimal(charcode) & "clip";
write "%!PS" to bg_name;
write "%%BoundingBox: " &
decimal floor xpart llcorner bgfill & " " &
decimal floor ypart llcorner bgfill & " " &
decimal ceiling xpart urcorner bgfill & " " &
decimal ceiling ypart urcorner bgfill
to bg_name;
write "%%Page: 1 1" to bg_name;
write "newpath" to bg_name;
for qq within bgfill:
q := pathpart qq;
tmp:=length q;
s := decimal(roundone(xpart point tmp of q)) & " "
& decimal(roundone(ypart point tmp of q)) & " m";
write s & "oveto" to bg_name;
write s to clip_name;
for i:=tmp downto 1:
s := decimal(roundone(xpart precontrol i of q)) & " "
& decimal(roundone(ypart precontrol i of q)) & " "
& decimal(roundone(xpart postcontrol i-1 of q)) & " "
& decimal(roundone(ypart postcontrol i-1 of q)) & " "
& decimal(roundone(xpart point i-1 of q)) & " "
& decimal(roundone(ypart point i-1 of q)) & " c";
write s & "urveto" to bg_name;
write s to clip_name;
endfor;
endfor;
write "closepath fill" to bg_name;
write "showpage" to bg_name;
write "%%EOF" to bg_name;
write EOF to bg_name;
write EOF to clip_name;
bgfill:=nullpicture;
enddef;
vardef buildcycle(text ll) =
save ta_, tb_, k_, i_, pp_; path pp_[];
k_=0;
for q=ll: pp_[incr k_]=q; endfor
i_=k_;
for i=1 upto k_:
(ta_[i], length pp_[i_]-tb_[i_]) =
pp_[i] intersectiontimes reverse pp_[i_];
if ta_[i]<0:
message("[Error: area borders "& area_border[i] &" and "&
area_border[i_] &" don't intersect in scrap " & current_scrap &
" (file " & current_src & ")]");
area_border_errors := area_border_errors + 1;
fi
i_ := i;
endfor
for i=1 upto k_: subpath (ta_[i],tb_[i]) of pp_[i] .. endfor
cycle
enddef;
vardef unitvector primary z =
if (z<>(0,0)):
z/abs z
else:
hide(thwarning("strange path"))
(0,epsilon)
fi
enddef;
def thwarning (expr m) =
message("[Warning: " & m & " in scrap " & current_scrap & "]");
enddef;
def check_area_borders =
if area_border_errors > 0:
fi;
enddef;
%%%%%%%%%%%% Map symbols management %%%%%%%%%%%%%%%%%%%
def mapsymbol (expr name, set, warning) =
string s, stype, lname, ID;
stype = substring (0,1) of name;
lname = name & "_" & set;
ID := "ID_" & lname;
if (known scantokens ID):
if stype = "a":
s = "def " & name & " = scantokens(" & ditto & lname & ditto & ") enddef;";
else:
s = "let " & name & " = " & lname & ";";
fi;
scantokens s;
elseif warning:
message("[Warning: undefined symbol `" & lname & "']");
fi;
enddef;
%def hidesymbol (expr name) =
% string s, stype;
% stype = substring (0,1) of name;
% if stype = "a":
% s = "def " & name & " = scantokens(" & ditto & "a_empty" & ditto & ") enddef;";
% else:
% s = "vardef " & name & "@# (text t) = enddef;";
% fi;
% scantokens s;
% write name to "missed.dat";
%enddef;
def initsymbol (expr name) =
s := "ID_" & name & " = 1";
scantokens s;
enddef;
%%%
% comment out groups in order to use 'save ATTR_*' appropriately
def beginfig(expr c) =
% begingroup
charcode:=c;
clearxy; clearit; clearpen;
pickup defaultpen;
drawoptions();
scantokens extra_beginfig;
save smartll, smartur;
pair smartll[], smartur[];
smart_count := 0;
enddef;
def endfig =
scantokens extra_endfig;
shipit;
% endgroup
enddef;
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% P. Bolek's MPATTERN package adapted and simplified for Therion
% (with the same user interface except of patterncolor)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
string Pname_, PXYsteps_;
string Pmatrix_;
numeric Pnum_; Pnum_=0;
def PmakeBB_=
PBBox_ := "[" & decimal Plft_ & " " & decimal Plow_ & " "
& decimal Prt_ & " " & decimal Pup_ & "]";
enddef;
def Psteps_=
PXYsteps_ := decimal
if unknown PXStep_: (Prt_-Plft_) else: PXStep_ fi
& ":" & decimal
if unknown PYStep_: (Pup_-Plow_) else: PYStep_ fi;
enddef;
vardef Pfindbounds_=
Plow_ = ypart (llcorner currentpicture);
Plft_ = xpart (llcorner currentpicture);
Pup_ = ypart (urcorner currentpicture);
Prt_ = xpart (urcorner currentpicture);
PmakeBB_;
enddef;
def PmakePattern_(expr name)=
write decimal (Pnum_*epsilon) & ":"
& jobname & "." & decimal charcode & ":"
& PBBox_ & ":"
& PXYsteps_ & ":"
& Pmatrix_
to "patterns.dat"
enddef;
% User interface macros
vardef patternbbox(expr a)(text b)=
save Pi_, Pz_;
numeric Pi_, Pz_[];
if pair a:
Plft_:=min(xpart(a),xpart(b)); Plow_:=min(ypart(a),ypart(b));
Prt_:=max(xpart(a),xpart(b)); Pup_:=max(ypart(a),ypart(b));
else:
Pi_=1;
for t=b:
Pz_[Pi_]=t;
Pi_:=Pi_+1;
endfor;
Plft_:=min(a,Pz_2); Plow_:=min(Pz_1,Pz_3);
Prt_:=max(a,Pz_2); Pup_:=max(Pz_1,Pz_3);
fi;
PmakeBB_;
enddef;
def beginpattern(suffix name)=
numeric PXStep_, PYStep_;
numeric Plow_, Plft_, Pup_, Prt_;
string PBBox_;
Pmatrix_:="[1 0 0 1 0 0]";
Pname_:=str name;
Pnum_:=Pnum_+1;
beginfig(Pnum_+4000);
enddef;
def endpattern=
if unknown PBBox_:
Pfindbounds_;
fi;
endfig;
Psteps_;
PmakePattern_(Pname_);
scantokens(Pname_ & "=Pnum_;");
enddef;
picture pattpict;
color patterncolor_;
patterncolor_ := black;
primarydef p withpattern s=
if known s:
hide(pattpict := image(draw (0,0)--(10,10));
for i within pattpict:
patterncolor_ := (redpart i, greenpart i, bluepart i);
endfor;)
p withcolor (epsilon, 10*epsilon, s*epsilon)
if known mpversion:
if scantokens(mpversion)>=1.000:
withprescript(decimal redpart patterncolor_ & " " &
decimal greenpart patterncolor_ & " " &
decimal bluepart patterncolor_ & " THsetpatterncolor")
fi;
fi;
else:
p withcolor (1,0,0);
message("Warning: undefined pattern ignored");
fi;
enddef;
def patterntransform expr t=
Pmatrix_ := "[" & decimal xxpart t
& " " & decimal yxpart t
& " " & decimal xypart t
& " " & decimal yypart t
& " " & decimal xpart t
& " " & decimal ypart t & "]";
enddef;
def patternxstep expr t=
PXStep_ = t;
enddef;
def patternystep expr t=
PYStep_ = t;
enddef;
def patternstep text t=
if pair t:
PXStep_ = xpart t;
PYStep_ = ypart t;
else:
(PXStep_,PYStep_)=t;
fi;
enddef;
def patterncolor expr t=
message("Warning: patterncolor not supported in Therion");
enddef;
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% end of pattern macros
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% transparent rgb colors
numeric RGBnum; RGBnum=0;
string RGBname;
def def_transparent_rgb (suffix name)(expr r, g, b) =
RGBnum := RGBnum+1;
RGBname := str name;
write decimal (RGBnum*epsilon) & ":"
& decimal r & " "
& decimal g & " "
& decimal b
to "rgbcolors.dat";
scantokens(RGBname & ":=RGBnum;");
enddef;
primarydef p withtransparentcolor s=
p withcolor (epsilon, 12*epsilon, s*epsilon);
enddef;
def_transparent_rgb(tr_white, 1, 1, 1);
def_transparent_rgb(tr_blue, 0, 0, 1);
def_transparent_rgb(tr_black, 0, 0, 0);
def_transparent_rgb(tr_bg,
redpart background, greenpart background, bluepart background);
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% some useful macros from H. Hagen's MetaFun package
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
vardef paired (expr d) =
if pair d : d else : (d,d) fi
enddef ;
primarydef p randomshifted s =
begingroup ; save ss ; pair ss ; ss := paired(s) ;
p shifted (-.5xpart ss + uniformdeviate xpart ss,
-.5ypart ss + uniformdeviate ypart ss)
endgroup
enddef ;
primarydef p randomized s =
(if path p :
for i=0 upto length(p)-1 :
((point i of p) randomshifted s) .. controls
((postcontrol i of p) randomshifted s) and
((precontrol (i+1) of p) randomshifted s) ..
endfor
if cycle p :
cycle
else :
((point length(p) of p) randomshifted s)
fi
elseif pair p :
p randomshifted s
elseif color p :
if color s :
(uniformdeviate redpart s * redpart p,
uniformdeviate greenpart s * greenpart p,
uniformdeviate bluepart s * bluepart p)
elseif pair s :
((xpart s + uniformdeviate (ypart s - xpart s)) * p)
else :
(uniformdeviate s * p)
fi
else :
p + uniformdeviate s
fi)
enddef ;
primarydef p llmoved d =
((llcorner p) shifted (-xpart paired(d),-ypart paired(d)))
enddef ;
primarydef p lrmoved d =
((lrcorner p) shifted (+xpart paired(d),-ypart paired(d)))
enddef ;
primarydef p urmoved d =
((urcorner p) shifted (+xpart paired(d),+ypart paired(d)))
enddef ;
primarydef p ulmoved d =
((ulcorner p) shifted (-xpart paired(d),+ypart paired(d)))
enddef ;
primarydef p smoothed d =
(p llmoved (-xpart paired(d),0) -- p lrmoved (-xpart paired(d),0) {right} ..
p lrmoved (0,-ypart paired(d)) -- p urmoved (0,-ypart paired(d)) {up} ..
p urmoved (-xpart paired(d),0) -- p ulmoved (-xpart paired(d),0) {left} ..
p ulmoved (0,-ypart paired(d)) -- p llmoved (0,-ypart paired(d)) {down} .. cycle)
enddef ;
vardef punked primary p =
(point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor
if cycle p : -- cycle else : -- point length(p) of p fi)
enddef ;
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% end of MetaFun macros
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% we input map symbol definitions
input thPoint;
input thLine;
input thArea;
input thText;
input thSpecial;
input uAUT;
input thTrans;
nonstopmode;