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/metafont/mfpic/grafbase.mf | 376 ++++++++++++++++++++------- 1 file changed, 276 insertions(+), 100 deletions(-) (limited to 'Master/texmf-dist/metafont') diff --git a/Master/texmf-dist/metafont/mfpic/grafbase.mf b/Master/texmf-dist/metafont/mfpic/grafbase.mf index 470e3e7f346..2532e17cc3c 100644 --- a/Master/texmf-dist/metafont/mfpic/grafbase.mf +++ b/Master/texmf-dist/metafont/mfpic/grafbase.mf @@ -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,17 +67,14 @@ elseif base_name <> "plain": input plain; fi boolean METAPOST; - -if known color Geamparalele din Babadag: - METAPOST := true; -else: - METAPOST := false; -fi +METAPOST := known color Geamparalele din Babadag; +numeric metapostversion; if METAPOST: GBerrmsg ("wrong compiler.") "This file is for Metafont. For Metapost use grafbase.mp."; fi +metapostversion := 0; if not boolean debug: boolean debug; debug := false; fi @@ -174,6 +174,8 @@ enddef; boolean showbbox; showbbox := false; let color = numeric; color black, white; +let rgbcolor = numeric; +let cmykcolor = numeric; black := 0; white := 1; def withcolor text t = enddef; def _wc_ = withcolor enddef; @@ -185,54 +187,77 @@ 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) = - gray (sqrt((2r*r + 4g*g + b*b)/7)) +vardef knowncolor expr clr = (known clr) and (iscolor clr) enddef; + +vardef grayscalegray (expr g) = snapto g enddef; +vardef gray (expr g) = grayscalegray (g) enddef; +vardef cmyk (expr c, m, y, k) = rgb (1-c-k, 1-m-k, 1-y-k) enddef; +vardef makegray primary clr = + if knowncolor clr: clr else: black fi enddef; +def makergb = makegray enddef; +def makecmyk = makegray enddef; +vardef iscolor expr clr = color clr enddef; -vardef rgb (expr r, g, b) = - makeclr (snapto r, snapto g, snapto b) +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) = + togray (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 @@ -420,8 +445,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; @@ -447,6 +474,64 @@ def setsplit (suffix s) expr ss = setnumeric (s) emax (1, ceiling ss); enddef; +def setrgbcolor = setcolor enddef; +def setcmykcolor = setcolor enddef; +def setcolor = setvariable (color) enddef; +def gsetcolor = gsetvariable (color) enddef; + +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); + +def setoutputtemplate text garbage = enddef; + +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: @@ -552,7 +637,6 @@ numeric label_sep, labelpath_sep ; label_sep := 0; labelpath_sep := 0; def verbatimtex text t = enddef; - vardef newgblabel (expr hf, vf, BL, r) (text s) (text pts) = enddef; @@ -703,6 +787,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; @@ -714,12 +799,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: @@ -787,6 +866,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; @@ -798,8 +891,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: @@ -1221,7 +1316,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 @@ -1510,7 +1605,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: @@ -1778,6 +1872,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; @@ -2080,12 +2175,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: @@ -2190,7 +2300,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] ].. @@ -2205,8 +2315,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]; @@ -2215,6 +2324,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 @@ -2262,6 +2410,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} @@ -2290,6 +2439,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[]; @@ -2434,9 +2584,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) @@ -2466,30 +2619,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; @@ -2539,6 +2699,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 @@ -2613,8 +2821,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) = @@ -2741,6 +2951,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: @@ -2899,6 +3110,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): @@ -3014,6 +3227,7 @@ vardef randomlines (expr maxshift) expr f = fi fi enddef; + vardef parasegment (expr d, segs, f) = if d = 0: f else: @@ -3149,7 +3363,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: @@ -3253,6 +3467,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)); @@ -3270,11 +3485,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, @@ -3282,43 +3495,6 @@ def defaultsymbols = enddef; defaultsymbols; -def setdatacolors (text lst) = - save __type; color __type[]; - __type := 0; - for _itm = lst: - if (known _itm) and (color _itm): - __type[__type] := _itm; - 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]; - endfor - else: - SetdataWarn "colors"; - fi -enddef; -def getcolor expr n = 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; color colortype[]; -def defaultcolors = - setdatacolors(black, red, dBlue, dOrange, dGreen, - dMagenta, dCyan, dYellow); -enddef; -defaultcolors; - def computepie (suffix dat) (expr sign, ang, cent, rad) (text data) = begingroup save _tot, _max, _toobig; -- cgit v1.2.3