From 556ccc6a2633ddbc27a22319d2e16e8a5d7483d1 Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Sat, 3 Oct 2009 14:58:41 +0000 Subject: mfpic 1.00 (30sep09) git-svn-id: svn://tug.org/texlive/trunk@15602 c570f23f-e606-0410-a88d-b1316a301751 --- Master/texmf-dist/metapost/mfpic/dvipsnam.mp | 32 +- Master/texmf-dist/metapost/mfpic/grafbase.mp | 490 ++++++++++++++++++++++----- 2 files changed, 424 insertions(+), 98 deletions(-) (limited to 'Master/texmf-dist/metapost') 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 %% -%% 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 %% -%% 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; -- cgit v1.2.3