summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/metapost
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2009-10-03 14:58:41 +0000
committerKarl Berry <karl@freefriends.org>2009-10-03 14:58:41 +0000
commit556ccc6a2633ddbc27a22319d2e16e8a5d7483d1 (patch)
tree6f0b1301fabae1e14d1c00703e774efd67543d16 /Master/texmf-dist/metapost
parent4d18074405a67946d5505fd5e0836e115d220541 (diff)
mfpic 1.00 (30sep09)
git-svn-id: svn://tug.org/texlive/trunk@15602 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/metapost')
-rw-r--r--Master/texmf-dist/metapost/mfpic/dvipsnam.mp32
-rw-r--r--Master/texmf-dist/metapost/mfpic/grafbase.mp490
2 files changed, 424 insertions, 98 deletions
diff --git a/Master/texmf-dist/metapost/mfpic/dvipsnam.mp b/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
index 1bc8d9f64c9..0529714a4d1 100644
--- a/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
+++ b/Master/texmf-dist/metapost/mfpic/dvipsnam.mp
@@ -8,34 +8,34 @@
%%
%% -------------------------------------------------------------------
%%
-%% Copyright 2002--2006, Daniel H. Luecking
+%% Copyright 2002--2009, Daniel H. Luecking
%%
%% Mfpic may be distributed and/or modified under the conditions of the
-%% LaTeX Project Public License, either version 1.3b of this license or (at
+%% LaTeX Project Public License, either version 1.3c of this license or (at
%% your option) any later version. The latest version of this license is in
%% <http://www.latex-project.org/lppl.txt>
-%% and version 1.3b or later is part of all distributions of LaTeX version
-%% 2005/12/01 or later.
+%% and version 1.3c or later is part of all distributions of LaTeX version
+%% 2008/12/01 or later.
%%
%% Mfpic has maintenance status "author-maintained". The Current Maintainer
%% is Daniel H. Luecking. There are several Base Interpreters associated
%% with mfpic: plain TeX, LaTeX, plain Metafont and plain MetaPost.
%%
+%%% File: grafbase.dtx
+%%% A part of mfpic 1.00 2009/09/22
+%%%
if unknown grafbaseversion:
- vardef snapto expr t =
- if unknown t: 0
- elseif not (numeric t): 0
- elseif t < 0: 0
- elseif t > 1: 1
- else: t
- fi
- enddef;
- vardef cmyk (expr c, m, y, k) =
- (snapto 1-c-k, snapto 1-m-k, snapto1-y-k)
- enddef;
+ if unknown mpversion:
+ let cmykcolor=color;
+ vardef cmyk (expr c, m, y, k) =
+ (max(1-c-k,0), max(1-m-k,0), max(1-y-k,0))
+ enddef;
+ else:
+ vardef cmyk (expr c, m, y, k) = (c, m, y, k) enddef;
+ fi
fi
-color Apricot, Aquamarine, Bittersweet, Black, Blue, BlueGreen,
+cmykcolor Apricot, Aquamarine, Bittersweet, Black, Blue, BlueGreen,
BlueViolet, BrickRed, Brown, BurntOrange, CadetBlue, CarnationPink,
Cerulean, CornflowerBlue, Cyan, Dandelion, DarkOrchid, Emerald,
ForestGreen, Fuchsia, Goldenrod, Gray, Green, GreenYellow, JungleGreen,
diff --git a/Master/texmf-dist/metapost/mfpic/grafbase.mp b/Master/texmf-dist/metapost/mfpic/grafbase.mp
index 225150795f1..b231060dd5c 100644
--- a/Master/texmf-dist/metapost/mfpic/grafbase.mp
+++ b/Master/texmf-dist/metapost/mfpic/grafbase.mp
@@ -8,19 +8,22 @@
%%
%% -------------------------------------------------------------------
%%
-%% Copyright 2002--2006, Daniel H. Luecking
+%% Copyright 2002--2009, Daniel H. Luecking
%%
%% Mfpic may be distributed and/or modified under the conditions of the
-%% LaTeX Project Public License, either version 1.3b of this license or (at
+%% LaTeX Project Public License, either version 1.3c of this license or (at
%% your option) any later version. The latest version of this license is in
%% <http://www.latex-project.org/lppl.txt>
-%% and version 1.3b or later is part of all distributions of LaTeX version
-%% 2005/12/01 or later.
+%% and version 1.3c or later is part of all distributions of LaTeX version
+%% 2008/12/01 or later.
%%
%% Mfpic has maintenance status "author-maintained". The Current Maintainer
%% is Daniel H. Luecking. There are several Base Interpreters associated
%% with mfpic: plain TeX, LaTeX, plain Metafont and plain MetaPost.
%%
+%%% File: grafbase.dtx
+%%% A part of mfpic 1.00 2009/09/22
+%%%
if (known grafbaseversion) or (known grafbase):
message "Grafbase (" & jobname & "): You have loaded grafbase more "
& "than once! Please make sure that it is loaded only once.";
@@ -29,7 +32,7 @@ fi
boolean grafbase; grafbase := true;
string fileversion, filedate;
-fileversion := "0.9"; filedate := "2006/05/26";
+fileversion := "1.00"; filedate := "2009/09/22";
message " Loading grafbase macros, version " & fileversion & " " &
filedate & ".";
@@ -56,7 +59,7 @@ def checkversions (expr g)=
fi
enddef;
-checkversions (90);
+checkversions (100);
if unknown base_name : input plain;
elseif not string base_name: input plain;
@@ -64,18 +67,37 @@ elseif base_name <> "plain": input plain;
fi
boolean METAPOST;
+METAPOST := known color Geamparalele din Babadag;
+numeric metapostversion;
-if known color Geamparalele din Babadag:
- METAPOST := true;
-else:
- METAPOST := false;
-fi
if not METAPOST:
GBerrmsg ("wrong compiler.")
"This file is for Metapost. For Metafont use grafbase.mf.";
fi
+numeric metapostversion;
+boolean has_cmyk;
+boolean has_filenametemplate; % e.g., filenametemplate "%j.%n;
+boolean has_outputtemplate; % e.g., outputtemplate := "%j.%n;
+if unknown mpversion:
+ % prior to introduction of cmykcolor and output filename templates.
+ % Latest such version was 0.641.
+ metapostversion := 0.641;
+ has_cmyk := false;
+ has_filenametemplate := false;
+ has_outputtemplate := false;
+else:
+ metapostversion := scantokens (mpversion);
+ has_cmyk := true;
+ has_filenametemplate := true;
+ if metapostversion < 1.200:
+ has_outputtemplate := false;
+ else:
+ has_outputtemplate := true;
+ fi
+fi
+
if not boolean debug: boolean debug; debug := false; fi
def GBdebug =
@@ -143,6 +165,7 @@ enddef;
boolean showbbox; showbbox := false;
+if not has_cmyk: let rgbcolor = color; let cmykcolor = color; fi
def _wc_ = withcolor enddef;
color currentcolor, drawcolor, fillcolor, hatchcolor,
@@ -152,54 +175,123 @@ currentcolor := fillcolor := drawcolor := hatchcolor :=
background := white;
vardef snapto expr t =
- if unknown t: 0
- elseif not (numeric t): 0
- elseif t < 0: 0
- elseif t > 1: 1
- else: t
+ if numeric t:
+ if unknown t: 0
+ elseif t < 0: 0
+ elseif t > 1: 1
+ else: t
+ fi
+ else:
+ GBerrmsg ("Improper expression type.")
+ "The argument to `snapto' must be a numeric.";
fi
+
enddef;
-vardef gray (expr g) = (snapto g)*white enddef;
+vardef rgbgray (expr g) = (snapto g) * white enddef;
+vardef cmykgray (expr g) = cmyk(0,0,0,1 - snapto g) enddef;
-vardef makeclr (expr r, g, b) =
- (r, g, b)
-enddef;
+if has_cmyk :
+ vardef grayscalegray (expr g) = snapto g enddef;
+ vardef gray (expr g) = grayscalegray (g) enddef;
+ vardef cmyk (expr c, m, y, k) =
+ (snapto c, snapto m, snapto y, snapto k)
+ enddef;
-vardef rgb (expr r, g, b) =
- makeclr (snapto r, snapto g, snapto b)
+ def colorchoice (expr clr) (text D)(text N)(text R)(text C) =
+ if unknown clr: D
+ elseif numeric clr: N
+ elseif rgbcolor clr: R
+ elseif cmykcolor clr: C
+ else: D
+ fi
+ enddef;
+
+ vardef makecmyk primary clr =
+ colorchoice (clr)(cmykblack)(cmykgray(clr))
+ (rgbtocmyk(redpart clr,greenpart clr,bluepart clr))
+ (clr)
+ enddef;
+ vardef makergb primary clr =
+ colorchoice (clr)(rgbblack)(rgbgray(clr))(clr)
+ (cmyktorgb(cyanpart clr, magentapart clr, yellowpart clr, blackpart clr))
+ enddef;
+ vardef makegray primary clr =
+ colorchoice (clr)(grayscaleblack)(grayscalegray(clr))
+ (rgbtogray (redpart clr, greenpart clr, bluepart clr))
+ (cmyktogray(cyanpart clr, magentapart clr, yellowpart clr,
+ blackpart clr))
+ enddef;
+ vardef iscolor expr clr =
+ (rgbcolor clr) or (cmykcolor clr) or (numeric clr) or (boolean clr)
+ enddef;
+else:
+ vardef gray (expr g) = rgbgray(g) enddef;
+ vardef grayscalegray (expr g) = rgbgray(g) enddef;
+ vardef cmyk (expr c, m, y, k) = rgb (1-c-k, 1-m-k, 1-y-k) enddef;
+ def colorchoice (expr clr) (text D)(text N)(text R) =
+ if unknown clr: D
+ elseif numeric clr: N
+ elseif rgbcolor clr: R
+ else: D
+ fi
+ enddef;
+ vardef makergb primary clr =
+ colorchoice (clr)(rgbblack)(rgbgray(clr))(clr)
+ enddef;
+ vardef makegray primary clr =
+ colorchoice (clr)(rgbblack)(rgbgray(clr))
+ (rgbtogray (redpart clr, greenpart clr, bluepart clr))
+ enddef;
+ def makecmyk = makergb enddef;
+ vardef iscolor expr clr = color clr enddef;
+fi
+
+vardef knowncolor expr clr = (known clr) and (iscolor clr) enddef;
+
+vardef forceclr (expr c) =
+ if unknown c :
+ if numeric c: grayscaleblack
+ elseif rgbcolor c: rgbblack
+ elseif cmykcolor c: cmykblack
+ else: black
+ fi
+ elseif numeric c: gray (c)
+ elseif iscolor c: c
+ else: black
+ fi
enddef;
+vardef named (suffix c) = forceclr (c) enddef;
-vardef cmyk (expr c, m, y, k) =
- rgb (1-c-k, 1-m-k, 1-y-k)
+vardef togray (expr r, g, b) =
+ gray (sqrt((2r*r + 4g*g + b*b)/7))
enddef;
-vardef RGB (expr R, G, B) =
- rgb (R/255, G/255, B/255)
+vardef rgbtogray (expr r, g, b) =
+ togray(snapto r, snapto g, snapto b)
+enddef;
+vardef cmyktogray (expr c, m, y, k) =
+ rgbtogray (1-c-k,1-m-k,1-y-k)
enddef;
-vardef named (suffix c) =
- if unknown c: black else: forceclr (c) fi
+vardef cmyktorgb (expr c,m,y,k) =
+ rgb(1-c-k,1-m-k,1-y-k)
enddef;
-vardef forceclr (expr c) =
- if numeric c: gray (c)
- elseif color c: c
- else: black
- fi
+vardef rgbtocmyk (expr r,g,b) =
+ cmyk(1-r,1-g,1-b,0)
enddef;
-color red, green, blue, cyan, magenta, yellow;
-red := rgb (1, 0, 0);
-green := rgb (0, 1, 0);
-blue := rgb (0, 0, 1);
-cyan := rgb (0, 1, 1);
-magenta := rgb (1, 0, 1);
-yellow := rgb (1, 1, 0);
+vardef rgb (expr r, g, b) =
+ (snapto r, snapto g, snapto b)
+enddef;
+vardef RGB (expr R, G, B) =
+ rgb (R/255, G/255, B/255)
+enddef;
def list (suffix v) (text lst) =
v := 0; for _itm = lst: v[incr v] := _itm; endfor
if v = 0:
- GBerrmsg ("no list to process!")
+ GBerrmsg ("No list to process!")
"An attempt was made to produce an array from a "
& "list of expressions having no valid entries.";
fi
@@ -379,8 +471,10 @@ def setnumeric (suffix name) = save name; name := enddef;
def setboolean = setvariable (boolean) enddef;
def setpair = setvariable (pair) enddef;
def setpath = setvariable (path) enddef;
-def setcolor = setvariable (color) enddef;
def setpicture = setvariable (picture) enddef;
+def setstring = setvariable (string) enddef;
+def settransform = setvariable (transform) enddef;
+def setpen = setvariable (pen) enddef;
def settension (suffix tn) expr tens =
setnumeric (tn) if tens > 0: tens else: default_tension fi;
enddef;
@@ -406,6 +500,92 @@ def setsplit (suffix s) expr ss =
setnumeric (s) emax (1, ceiling ss);
enddef;
+if has_cmyk:
+ def setrgbcolor = setvariable (rgbcolor) enddef;
+ def setcmykcolor = setvariable (cmykcolor) enddef;
+ def setcolor (suffix name) expr val =
+ if boolean val : setboolean
+ elseif numeric val : setnumeric
+ elseif rgbcolor val : setrgbcolor
+ elseif cmykcolor val : setcmykcolor
+ % this should give a suitable error message:
+ else: setvariable (color)
+ fi (name) val;
+ enddef;
+ def gsetcolor (suffix name) expr val =
+ if boolean val : boolean name;
+ elseif numeric val : numeric name;
+ elseif rgbcolor val : rgbcolor name;
+ elseif cmykcolor val : cmykcolor name;
+ else: color name;
+ fi name := val;
+ enddef;
+else:
+ def setrgbcolor = setcolor enddef;
+ def setcmykcolor = setcolor enddef;
+ def setcolor = setvariable (color) enddef;
+ def gsetcolor = gsetvariable (color) enddef;
+fi
+
+setcolor(rgbblack) rgb(0,0,0);
+setcolor(red) rgb(1,0,0);
+setcolor(green) rgb(0,1,0);
+setcolor(blue) rgb(0,0,1);
+setcolor(rgbwhite) rgb(1,1,1);
+setcolor(cmykwhite) cmyk(0,0,0,0);
+setcolor(cyan) cmyk(1,0,0,0); % Maybe these should
+setcolor(magenta) cmyk(0,1,0,0); % be rbg for backward
+setcolor(yellow) cmyk(0,0,1,0); % compatibility?
+setcolor(cmykblack) cmyk(0,0,0,1);
+setcolor(grayscaleblack) gray(0);
+setcolor(grayscalewhite) gray(1);
+
+if has_outputtemplate:
+ def setoutputtemplate = outputtemplate := enddef;
+elseif has_filenametemplate:
+ def setoutputtemplate = filenametemplate enddef;
+else:
+ def setoutputtemplate text garbage = enddef;
+fi
+
+def romannumeral = _romannumeral (true) enddef;
+vardef _romannumeral (expr prefix, X) =
+ save Y, _tmp, U; string U;
+
+ Y.m := X div 1000; % thousands digit
+ _tmp := X - 1000Y.m; % hundreds digits and lower
+ Y.c := _tmp div 100; % hundreds
+ _tmp := _tmp - 100Y.c; % tens and units
+ Y.x := _tmp div 10; % tens
+ Y.i := _tmp - 10Y.x; % units
+
+ strrepeat("m", Y.m) &
+ romandigit(prefix, "c", "d", "m", Y.c) &
+ romandigit(prefix, "x", "l", "c", Y.x) &
+ romandigit(prefix, "i", "v", "x", Y.i)
+enddef;
+
+vardef romandigit (expr prefix, bot, mid, top, n) =
+ if n > 9 : top & strrepeat(bot, n-10) % shouldn't happen
+ elseif n > 8 :
+ if prefix: bot & top % "ix"
+ else: mid & bot & bot & bot & bot % "viiii"
+ fi
+ elseif n > 4 : mid & strrepeat (bot, n-5) % "v"--"viii"
+ elseif n > 3 :
+ if prefix: bot & mid % "iv"
+ else: bot & bot & bot & bot % "iiii"
+ fi
+ else: strrepeat (bot, n) % ""--"iii" for 0--3
+ fi
+enddef;
+
+vardef strrepeat (expr st, rep) =
+ setstring (_sr) "";
+ for i = 1 upto rep: _sr := _sr & st; endfor
+ _sr
+enddef;
+
transform ztr, vtr;
def setztr =
if debug:
@@ -530,7 +710,6 @@ label_adjust := origin;
numeric label_sep, labelpath_sep ;
label_sep := 0; labelpath_sep := 0;
-
vardef newgblabel (expr hf, vf, BL, r) (expr s) (text pts) =
save _lab, _ll, _ur; picture _lab; pair _ll, _ur;
_lab := makepicture (s);
@@ -702,6 +881,7 @@ vardef csc primary X = cscd (X*radian) enddef;
vardef degrees (expr t) = t*radian enddef;
vardef radians (expr t) = t/radian enddef;
+
vardef invcos primary X = (acos X)/radian enddef;
vardef invsin primary X = (asin X)/radian enddef;
vardef invtan primary X = (atan X)/radian enddef;
@@ -713,12 +893,6 @@ vardef logbase (expr B) primary X = (mlog X)/(mlog B) enddef;
def logtwo = logbase( 2) enddef;
def logten = logbase(10) enddef;
-vardef Arg primary Z = (angle Z)/radian enddef;
-vardef Log primary Z = (ln (abs Z), Arg Z) enddef;
-vardef cis primary T = dir (T*radian) enddef;
-vardef zexp primary Z = (exp (xpart Z)) * cis (ypart Z) enddef;
-vardef sgn primary Z = if not (Z = origin): unitvector fi Z enddef;
-
vardef cosh primary X =
setnumeric (temp) 2 exp (-abs(X));
if temp < reallysmall:
@@ -786,6 +960,20 @@ vardef atanh primary y =
fi
enddef;
+vardef Arg primary Z = (angle Z)/radian enddef;
+vardef Log primary Z = (ln (abs Z), Arg Z) enddef;
+vardef cis primary T = dir (T*radian) enddef;
+vardef zexp primary Z = (exp (xpart Z)) * cis (ypart Z) enddef;
+vardef sgn primary Z = if not (Z = origin): unitvector fi Z enddef;
+vardef conj primary Z = (xpart Z, -ypart Z) enddef;
+
+vardef Moebius (expr A) primary Z =
+ save _D; pair _D;
+ _D := (1, 0) + (Z zscaled (conj A));
+ (Z + A)/(abs _D) rotated (- angle _D)
+enddef;
+vardef pshdist (expr Z,W) = abs(Moebius(-W)(Z)) enddef;
+
vardef polar primary p = (xpart p) * dir (ypart p) enddef;
def id (expr x) = x enddef;
@@ -797,8 +985,10 @@ primarydef x**y =
fi
enddef;
let ^ = **;
+
transform T_stack[];
numeric T_stack; T_stack := 0;
+
def T_push (expr T) = T_stack[incr T_stack] := T; enddef;
def T_pop (suffix $) =
if T_stack > 0:
@@ -1118,7 +1308,7 @@ enddef;
def store (suffix fs) expr f =
hide (
if (not path f) and (not pair f):
- GBerrmsg ("improper expression type.")
+ GBerrmsg ("Improper expression type.")
"The second argument to `store' must be a path or pair.";
fi
if not path fs: path fs; fi
@@ -1371,7 +1561,6 @@ vardef gendashed (suffix pat) expr f =
picture _v; _v := nullpicture;
_d0 := 0; _t0 := 0;
dashit (_dpat.start) (_v);
-
if _n > 0:
save _m; _m := ceiling sqrt(_n);
for _j = 0 step _m until _n - 1:
@@ -1643,6 +1832,7 @@ vardef axis@# (expr len) = headpath (len, 0, 0) axisline@# enddef;
vardef borderrect =
rect((xneg+laxis,yneg+baxis),(xpos-raxis,ypos-taxis))
enddef;
+
numeric inside, outside, centered, onleft, onright, ontop, onbottom;
inside := -2;
outside := -1;
@@ -1945,12 +2135,27 @@ enddef;
vardef turtle (text t) =
setnumeric (_tu) 0;
- pair _tu[]; _tu0 := origin;
- for _a = t: _tu[incr _tu] := _tu[_tu - 1] + _a; endfor
+ setpair (_tmp) origin;
+ pair _tu[];
+ for _a = t:
+ _tmp := _tmp + _a;
+ _tu[incr _tu] := _tmp;
+ endfor
if _tu = 0: NoPoints("turtle", _tu); fi
mkpoly (false, _tu)
enddef;
+vardef brownianpath (expr start, num, sc) =
+ setnumeric (_brp) 1;
+ setpair (_tmp) start;
+ pair _brp[]; _brp1 := _tmp;
+ for _idx := 1 upto num:
+ _tmp := _tmp + sc/(sqrt 2)*(normaldeviate,normaldeviate);
+ _brp[incr _brp] := _tmp;
+ endfor
+ mkpoly (false, _brp)
+enddef;
+
vardef mksmooth (expr tens, cyclic) (suffix pts) =
if pts = 1: onepointpath (cyclic, pts1)
else:
@@ -2055,7 +2260,7 @@ enddef;
vardef mkqbezier (expr cyclic) (suffix pts) =
pts1
- if pts=1: {0,0}
+ if pts=1: {0,0}
else:
for _i = 2 step 2 until pts - 1:
..controls 1/3[pts[_i], pts[_i-1] ] and 1/3[pts[_i], pts[_i+1] ]..
@@ -2070,8 +2275,7 @@ enddef;
vardef qbezier (expr cyclic) (text t) =
setpairs (_qbz) (t);
- if _qbz=0: NoPoints ("qbezier", _qbz); fi
- if _qbz=1: onepointpath (cyclic, _qbz1)
+ if _qbz=0: NoPoints ("qbezier", _qbz);
else:
if (cyclic and odd _qbz) or (not cyclic and even _qbz):
_qbz[incr _qbz] := _qbz[_qbz-1];
@@ -2080,6 +2284,45 @@ vardef qbezier (expr cyclic) (text t) =
fi
enddef;
+vardef mkcbezier (expr cyclic) (suffix pts) =
+ pts1
+ if pts=1: {0,0}
+ else:
+ for _i = 1 step 3 until pts - 3:
+ ..controls pts[_i+1] and pts[_i+2] .. pts[_i+3]
+ endfor
+ if cyclic:
+ ..controls pts[pts - 1] and pts[pts]..cycle
+ fi
+ fi
+enddef;
+
+vardef cbezier (expr cyclic) (text t) =
+ setpairs (_cbz) (t);
+ if _cbz=0: NoPoints ("qbezier", _cbz);
+ else:
+ % Need 0 mod 3 for cyclic, otherwise 1 mod 3
+ setnumeric (_mdt) _cbz mod 3;
+ if cyclic:
+ if _mdt <> 0: _cbz[incr _cbz] := _cbz[_cbz-1]; fi
+ if _mdt = 1 : _cbz[incr _cbz] := _cbz1; fi
+ else: % need 1 more, duplicate next to last
+ if _mdt = 0:
+ _cbz := _cbz + 1;
+ _cbz[_cbz] := _cbz[_cbz-1];
+ _cbz[_cbz-1] := _cbz[_cbz-2];
+ fi
+ if _mdt = 2: % need 2 more, duplicate last 2.
+ _cbz := _cbz + 2; % add 2 slots
+ _cbz[_cbz] := _cbz[_cbz-2]; % fill them
+ _cbz[_cbz-1] := _cbz[_cbz-2]; % with last node
+ _cbz[_cbz-2] := _cbz[_cbz-3]; % orig last slot = orig previous.
+ fi
+ fi
+ mkcbezier (cyclic) (_cbz)
+ fi
+enddef;
+
vardef fcncontrol (expr ftens, X, Y, Z) =
Y if (xpart(Z-Y) <> 0) and (xpart(Y-X) <> 0):
+ xpart(Z-Y)/3/xpart(Z-X)*(Z - X)/ftens fi
@@ -2127,6 +2370,7 @@ vardef qspline (expr cyclic) (text t) =
fi
mkqbs (_qs) if cyclic: & cycle fi
enddef;
+
vardef mkcbs (suffix b) =
(b[1]+4b[2]+b[3])/6
if b < 4: {0,0}
@@ -2155,6 +2399,7 @@ vardef cspline (expr cyclic) (text t) =
fi
mkcbs (_cs) if cyclic: & cycle fi
enddef;
+
def init_spline_eqns (suffix pts) =
save _spl_pre, _spl_post;
pair _spl_pre[], _spl_post[];
@@ -2299,9 +2544,12 @@ vardef arcpps (expr begpt, endpt, sweep) =
enddef;
vardef arcpp (expr small, begpt, endpt, rad) =
- save full, ang; full := signof (rad) 360;
- if 2*abs(rad) > abs(begpt - endpt):
- ang := if not small: full - fi 2*asin (abs(begpt-endpt)/(2rad));
+ save full, diam, chord, ang;
+ full := signof (rad) 360;
+ diam := 2rad;
+ chord := abs(endpt-begpt);
+ if chord < abs(diam):
+ ang := if not small: full - fi 2*asin (chord/diam);
else: ang := signof (rad) 180;
fi
arcpps (begpt, endpt, ang)
@@ -2331,30 +2579,37 @@ vardef ellipse (expr center, radx, rady, angle) =
fullcircle xscaled (2*radx) yscaled (2*rady) rotated angle
shifted center
enddef;
+
vardef circle (expr center, rad) =
fullcircle scaled (2*rad) shifted center
enddef;
+
vardef circlecp (expr center, point) =
mkarc (center, point, point, 360) & cycle
enddef;
+
vardef circleppp (expr one, two, three) =
arcpps (one, two, 2*cornerangle (three, one, two))
& arcpps (two, three, 2*cornerangle (one, two, three))
& arcpps (three, one, 2*cornerangle (two, three, one))
& cycle
enddef;
+
vardef circlepps (expr one, two, sweep) =
save ang, full;
full := signof (sweep) 360;
ang := sweep mod full;
arcpps (one, two, ang) & arcpps (two, one, full - ang) & cycle
enddef;
+
vardef circlepp (expr small, one, two, rad) =
arcpp (small, one, two, rad) & arcpp (not small, two, one, rad) & cycle
enddef;
+
def circleppr (expr one, two, rad, small) =
circleppr (one, two, rad, small)
enddef;
+
vardef pathcenter expr p =
save a, cntr, n; pair cntr, a[];
n := length p;
@@ -2404,6 +2659,54 @@ vardef ninepointcircle expr t =
circleppp (medianpt 0 of t, medianpt 1 of t, medianpt 2 of t)
enddef;
+vardef pshcircle (expr disk, ctr, rad) =
+ if disk:
+ if rad >= 1 :
+ if rad > 1:
+ GBerrmsg ("Impossible pseudohyperbolic circle.")
+ "The radius of a pseudohyperbolic circle can be at most 1.";
+ fi
+ circle ((0,0),1)
+ elseif abs(ctr) >= 1 :
+ if abs(ctr) > 1:
+ GBerrmsg ("Impossible pseudohyperbolic circle.")
+ "The center of a pseudohyperbolic circle must be in"
+ & "the unit disk.";
+ fi
+ onepointpath (true,ctr)
+ else:
+ % compute Euclidean center and radius (and a denominator used twice
+ % in calculations).
+ save _r, _dnm;
+ _r := abs(ctr);
+ _dnm := 1 - _r*_r*rad*rad;
+ circle ( (1 - rad*rad)/_dnm*ctr, rad*(1 - _r*_r)/_dnm)
+ fi
+ else:
+ if rad >= 1 :
+ GBerrmsg ("Impossible pseudohyperbolic circle.")
+ "The radius of a pseudohyperbolic circle must be less than 1.";
+ onepointpath (true,ctr)
+ elseif ypart ctr <= 0:
+ if ypart ctr < 0:
+ GBerrmsg ("Impossible pseudohyperbolic circle.")
+ "The center of a pseudohyperbolic circle must be in"
+ & "the upper half-plane.";
+ fi
+ onepointpath (true,ctr)
+ else:
+ % compute Euclidean center and radius (and a denominator used twice
+ % in calculations).
+ % Euclidean center at xpart ctr + (1 + R^2)/(1 - R^2)*ypart ctr
+ % Euclidean radius 4R/(1 - R^2)*ypart ctr
+ save _y, _dnm;
+ _y := ypart ctr;
+ _dnm := 1 - rad*rad;
+ circle ( (xpart ctr, (1 + rad*rad)/_dnm * _y), 2rad/_dnm*_y)
+ fi
+ fi
+enddef;
+
vardef barycenter expr t =
save m; m := length t if not cycle t: + 1 fi;
pnt0(t)/m for k = 1 upto m - 1: + pnt[k](t)/m endfor
@@ -2478,8 +2781,10 @@ def plrregion (expr sm) = tplrregion (sm, default_tension) enddef;
vardef tplrregion (expr sm, tn, tlo, thi, st) (text _ft) =
(0,0)--tplrfcn (sm, tn, tlo, thi, st ) (_ft)--cycle
enddef;
+
numeric tolerancefactor;
tolerancefactor := .02;
+
vardef mklevelset (expr sm, tens, X, Y, t, a, b, c, d) =
save _inside_;
vardef _inside_ (expr U, V) =
@@ -2606,6 +2911,7 @@ vardef qbclosed expr f =
enddef;
vardef makesector expr p = (pathcenter p)--p--cycle enddef;
+
vardef arccomplement expr p =
if cycle p: onepointpath (false, pnt0(p))
else:
@@ -2763,6 +3069,8 @@ vardef colorGheadpath
f
enddef;
+path cut_path; cut_path := (.5,0)--(.5,.71)--(-.5,.71)--(-.5,0)--cycle;
+
def tailpath (suffix sh) = colortailpath (sh) (headcolor) enddef;
vardef colortailpath (suffix sh) (expr clr, sc, rot, pos) expr f =
if (sc <> 0) and (known sh) and (path sh):
@@ -2878,6 +3186,7 @@ vardef randomlines (expr maxshift) expr f =
fi
fi
enddef;
+
vardef parasegment (expr d, segs, f) =
if d = 0: f
else:
@@ -3013,7 +3322,7 @@ def setdatasymbols (text lst) =
__type[__type] := _itm;
next __type;
else:
- GBwarn "Improper path in setdatasymbols().";
+ GBwarn "Improper symbol in setdatasymbols().";
fi
endfor
if __type > 1:
@@ -3117,6 +3426,7 @@ forsuffixes S =
SolidDiamond, SolidStar :
S.tip := point 0 of S;
endfor
+
vardef gcd (expr n, m) =
save a, b, r;
a := emax (abs(m), abs(n));
@@ -3134,11 +3444,9 @@ vardef gcd (expr n, m) =
enddef;
vardef lcm (expr n, m) =
- n*m/gcd(n, m)
+ n/gcd(n, m)*m
enddef;
-path cut_path; cut_path := (.5,0)--(.5,.71)--(-.5,.71)--(-.5,0)--cycle;
-
numeric pointtype; path pointtype[];
def defaultsymbols =
setdatasymbols( Circle, Cross, SolidDiamond, Square, Plus,
@@ -3147,39 +3455,57 @@ enddef;
defaultsymbols;
def setdatacolors (text lst) =
- save __type; color __type[];
- __type := 0;
+ setnumeric (__type) 0;
+ % First, just count and store the known colors in the list
for _itm = lst:
- if (known _itm) and (color _itm):
- __type[__type] := _itm;
+ if knowncolor _itm :
+ if __type = 0 : def _datacolors = _itm enddef;
+ else:
+ expandafter def
+ expandafter _datacolors
+ expandafter = _datacolors, _itm enddef;
+ fi
next __type;
else: GBwarn "Improper color in setdatacolors().";
fi
endfor
if __type > 1:
- save colortype; colortype := __type;
- color colortype[];
- for _j = 0 upto colortype - 1:
- colortype[_j] := __type[_j];
+ save colortype, _tmpstr;
+ colortype := 0;
+ % colortype[] is an array of strings:
+ string colortype[], _tmpstr;
+ for _itm = _datacolors: %
+ % Each string is the name of some color variable
+ _tmpstr := "colortype_"&romannumeral(colortype);
+ setcolor (scantokens(_tmpstr)) _itm;
+ colortype[colortype] := _tmpstr;
+ next colortype;
endfor
else:
SetdataWarn "colors";
fi
enddef;
-def getcolor expr n = colortype[n mod colortype] enddef;
+def getcolor expr n = (scantokens (colortype[n mod colortype])) enddef;
-color dBlue, dOrange, dGreen, dMagenta, dCyan, dYellow;
-dBlue := 0.80blue + .2white;
-dOrange := 0.66yellow + .34red;
-dGreen := 0.80green;
-dMagenta := 0.85magenta;
-dCyan := 0.85cyan;
-dYellow := 0.85yellow;
+numeric colortype; string colortype[];
-numeric colortype; color colortype[];
+setcolor (dRed) (1, 0, 0);
+setcolor (dBlue) (.2,.2,1);
+setcolor (dOrange) (1,.34,0);
+setcolor (dGreen) (0,.80,0);
+setcolor (dBlack) cmykblack;
+if has_cmyk :
+ setcolor (dCyan) cyan;
+ setcolor (dMagenta) magenta;
+ setcolor (dYellow) yellow;
+else: % rgb colors seem to be lighter than the cmyk equivalents.
+ setcolor (dCyan) cmyk(.85,0,0,.15);
+ setcolor (dMagenta) cmyk(0,.85,0,.15);
+ setcolor (dYellow) cmyk(0,0,.85,.15);
+fi
def defaultcolors =
- setdatacolors(black, red, dBlue, dOrange, dGreen,
- dMagenta, dCyan, dYellow);
+ setdatacolors(dBlack, dRed, dBlue, dOrange,
+ dGreen, dMagenta, dCyan, dYellow);
enddef;
defaultcolors;