From 4cfc854a468fdfb00073bfad6067174da6b80b0d Mon Sep 17 00:00:00 2001 From: Hans Hagen Date: Mon, 12 Sep 2011 22:49:00 +0200 Subject: beta 2011.09.12 22:49 --- metapost/context/base/metafun.mpii | 2 +- metapost/context/base/metafun.mpiv | 2 +- metapost/context/base/mp-base.mp | 558 ------------------------ metapost/context/base/mp-base.mpii | 558 ++++++++++++++++++++++++ metapost/context/base/mp-base.mpiv | 860 +++++++++++++++++++++++++++++++++++++ 5 files changed, 1420 insertions(+), 560 deletions(-) delete mode 100644 metapost/context/base/mp-base.mp create mode 100644 metapost/context/base/mp-base.mpii create mode 100644 metapost/context/base/mp-base.mpiv (limited to 'metapost') diff --git a/metapost/context/base/metafun.mpii b/metapost/context/base/metafun.mpii index 4d8dc2537..705900a18 100644 --- a/metapost/context/base/metafun.mpii +++ b/metapost/context/base/metafun.mpii @@ -28,7 +28,7 @@ %D end even may use a patched version, we prefer to use a %D copy. -input mp-base.mp ; +input mp-base.mpii ; input mp-tool.mp ; input mp-spec.mpii ; input mp-core.mpii ; diff --git a/metapost/context/base/metafun.mpiv b/metapost/context/base/metafun.mpiv index 59ca2c4bd..89a7c3935 100644 --- a/metapost/context/base/metafun.mpiv +++ b/metapost/context/base/metafun.mpiv @@ -16,7 +16,7 @@ %D end even may use a patched version, we prefer to use a %D copy. -input mp-base.mp ; +input mp-base.mpiv ; input mp-tool.mp ; input mp-core.mpiv ; input mp-page.mp ; diff --git a/metapost/context/base/mp-base.mp b/metapost/context/base/mp-base.mp deleted file mode 100644 index 93cb5e90c..000000000 --- a/metapost/context/base/mp-base.mp +++ /dev/null @@ -1,558 +0,0 @@ -% This is (currently) a copy of the plain.mp file. We use a copy -% because (1) we want to make sure that there are no unresolved -% dependencies, and (2) we may patch this file eventually. - -% This file gives the macros for plain MetaPost -% It contains all the features of plain METAFONT except those specific to -% font-making. (See The METAFONTbook by D.E. Knuth). -% There are also a number of macros for labeling figures, etc. -string base_name, base_version; base_name="plain"; base_version="0.63"; - -message "Preloading the plain mem file, version "&base_version; - -delimiters (); % this makes parentheses behave like parentheses -def upto = step 1 until enddef; % syntactic sugar -def downto = step -1 until enddef; -def exitunless expr c = exitif not c enddef; -let relax = \; % ignore the word `relax', as in TeX -let \\ = \; % double relaxation is like single -def ]] = ] ] enddef; % right brackets should be loners -def -- = {curl 1}..{curl 1} enddef; -def --- = .. tension infinity .. enddef; -def ... = .. tension atleast 1 .. enddef; - -def gobble primary g = enddef; -primarydef g gobbled gg = enddef; -def hide(text t) = exitif numeric begingroup t;endgroup; enddef; -def ??? = hide(interim showstopping:=1; showdependencies) enddef; -def stop expr s = message s; gobble readstring enddef; - -warningcheck:=1; -tracinglostchars:=1; - -def interact = % sets up to make "show" commands stop - hide(showstopping:=1; tracingonline:=1) enddef; - -def loggingall = % puts tracing info into the log - tracingcommands:=3; tracingtitles:=1; tracingequations:=1; - tracingcapsules:=1; tracingspecs:=2; tracingchoices:=1; tracinglostchars:=1; - tracingstats:=1; tracingoutput:=1; tracingmacros:=1; tracingrestores:=1; - enddef; - -def tracingall = % turns on every form of tracing - tracingonline:=1; showstopping:=1; loggingall enddef; - -def tracingnone = % turns off every form of tracing - tracingcommands:=0; tracingtitles:=0; tracingequations:=0; - tracingcapsules:=0; tracingspecs:=0; tracingchoices:=0; tracinglostchars:=0; - tracingstats:=0; tracingoutput:=0; tracingmacros:=0; tracingrestores:=0; - enddef; - - - -%% dash patterns - -vardef dashpattern(text t) = - save on, off, w; - let on=_on_; - let off=_off_; - w = 0; - nullpicture t -enddef; - -tertiarydef p _on_ d = - begingroup save pic; - picture pic; pic=p; - addto pic doublepath (w,w)..(w+d,w); - w := w+d; - pic shifted (0,d) - endgroup -enddef; - -tertiarydef p _off_ d = - begingroup w:=w+d; - p shifted (0,d) - endgroup -enddef; - - - -%% basic constants and mathematical macros - -% numeric constants -newinternal eps,epsilon,infinity,_; -eps := .00049; % this is a pretty small positive number -epsilon := 1/256/256; % but this is the smallest -infinity := 4095.99998; % and this is the largest -_ := -1; % internal constant to make macros unreadable but shorter - -newinternal mitered, rounded, beveled, butt, squared; -mitered:=0; rounded:=1; beveled:=2; % linejoin types -butt:=0; rounded:=1; squared:=2; % linecap types - - -% pair constants -pair right,left,up,down,origin; -origin=(0,0); up=-down=(0,1); right=-left=(1,0); - -% path constants -path quartercircle,halfcircle,fullcircle,unitsquare; -fullcircle = makepath pencircle; -halfcircle = subpath (0,4) of fullcircle; -quartercircle = subpath (0,2) of fullcircle; -unitsquare=(0,0)--(1,0)--(1,1)--(0,1)--cycle; - -% transform constants -transform identity; -for z=origin,right,up: z transformed identity = z; endfor - -% color constants -color black, white, red, green, blue, background; -black = (0,0,0); -white = (1,1,1); -red = (1,0,0); -green = (0,1,0); -blue = (0,0,1); -background = white; % The user can reset this - -% picture constants -picture blankpicture,evenly,withdots; -blankpicture=nullpicture; % `display blankpicture...' -evenly=dashpattern(on 3 off 3); % `dashed evenly' -withdots=dashpattern(off 2.5 on 0 off 2.5); % `dashed withdots' - -% string constants -string ditto, EOF; -ditto = char 34; % ASCII double-quote mark -EOF = char 0; % end-of-file for readfrom and write..to - -% pen constants -pen pensquare,penrazor,penspeck; -pensquare = makepen(unitsquare shifted -(.5,.5)); -penrazor = makepen((-.5,0)--(.5,0)--cycle); -penspeck=pensquare scaled eps; - -% nullary operators -vardef whatever = save ?; ? enddef; - -% unary operators -let abs = length; - -vardef round primary u = - if numeric u: floor(u+.5) - elseif pair u: (round xpart u, round ypart u) - else: u fi enddef; - -vardef ceiling primary x = -floor(-x) enddef; - -vardef byte primary s = - if string s: ASCII fi s enddef; - -vardef dir primary d = right rotated d enddef; - -vardef unitvector primary z = z/abs z enddef; - -vardef inverse primary T = - transform T_; T_ transformed T = identity; T_ enddef; - -vardef counterclockwise primary c = - if turningnumber c <= 0: reverse fi c enddef; - -vardef tensepath expr r = - for k=0 upto length r - 1: point k of r --- endfor - if cycle r: cycle else: point infinity of r fi enddef; - -vardef center primary p = .5[llcorner p, urcorner p] enddef; - - - -% binary operators - -primarydef x mod y = (x-y*floor(x/y)) enddef; -primarydef x div y = floor(x/y) enddef; -primarydef w dotprod z = (xpart w * xpart z + ypart w * ypart z) enddef; - -primarydef x**y = if y=2: x*x else: takepower y of x fi enddef; -def takepower expr y of x = - if x>0: mexp(y*mlog x) - elseif (x=0) and (y>0): 0 - else: 1 - if y=floor y: - if y>=0: for n=1 upto y: *x endfor - else: for n=_ downto y: /x endfor - fi - else: hide(errmessage "Undefined power: " & decimal x&"**"&decimal y) - fi fi enddef; - -vardef direction expr t of p = - postcontrol t of p - precontrol t of p enddef; - -vardef directionpoint expr z of p = - a_:=directiontime z of p; - if a_<0: errmessage("The direction doesn't occur"); fi - point a_ of p enddef; - -secondarydef p intersectionpoint q = - begingroup save x_,y_; (x_,y_)=p intersectiontimes q; - if x_<0: errmessage("The paths don't intersect"); origin - else: .5[point x_ of p, point y_ of q] fi endgroup -enddef; - -tertiarydef p softjoin q = - begingroup c_:=fullcircle scaled 2join_radius shifted point 0 of q; - a_:=ypart(c_ intersectiontimes p); b_:=ypart(c_ intersectiontimes q); - if a_<0:point 0 of p{direction 0 of p} else: subpath(0,a_) of p fi - ... if b_<0:{direction infinity of q}point infinity of q - else: subpath(b_,infinity) of q fi endgroup enddef; -newinternal join_radius,a_,b_; path c_; - - -path cuttings; % what got cut off - -tertiarydef a cutbefore b = % tries to cut as little as possible - begingroup save t; - (t, whatever) = a intersectiontimes b; - if t<0: - cuttings:=point 0 of a; - a - else: cuttings:= subpath (0,t) of a; - subpath (t,length a) of a - fi - endgroup -enddef; - -tertiarydef a cutafter b = - reverse (reverse a cutbefore b) - hide(cuttings:=reverse cuttings) -enddef; - - - -% special operators -vardef incr suffix $ = $:=$+1; $ enddef; -vardef decr suffix $ = $:=$-1; $ enddef; - -def reflectedabout(expr w,z) = % reflects about the line w..z - transformed - begingroup transform T_; - w transformed T_ = w; z transformed T_ = z; - xxpart T_ = -yypart T_; xypart T_ = yxpart T_; % T_ is a reflection - T_ endgroup enddef; - -def rotatedaround(expr z, d) = % rotates d degrees around z - shifted -z rotated d shifted z enddef; -let rotatedabout = rotatedaround; % for roundabout people - -vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings - save u_; setu_ u; for uu = t: if uuu_: u_:=uu; fi endfor - u_ enddef; - -def setu_ primary u = - if pair u: pair u_ elseif string u: string u_ fi; - u_=u enddef; - -def flex(text t) = % t is a list of pairs - hide(n_:=0; for z=t: z_[incr n_]:=z; endfor - dz_:=z_[n_]-z_1) - z_1 for k=2 upto n_-1: ...z_[k]{dz_} endfor ...z_[n_] enddef; -newinternal n_; pair z_[],dz_; - -def superellipse(expr r,t,l,b,s)= - r{up}...(s[xpart t,xpart r],s[ypart r,ypart t]){t-r}... - t{left}...(s[xpart t,xpart l],s[ypart l,ypart t]){l-t}... - l{down}...(s[xpart b,xpart l],s[ypart l,ypart b]){b-l}... - b{right}...(s[xpart b,xpart r],s[ypart r,ypart b]){r-b}...cycle enddef; - -vardef interpath(expr a,p,q) = - for t=0 upto length p-1: a[point t of p, point t of q] - ..controls a[postcontrol t of p, postcontrol t of q] - and a[precontrol t+1 of p, precontrol t+1 of q] .. endfor - if cycle p: cycle - else: a[point infinity of p, point infinity of q] fi enddef; - -vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false - tx_:=true_x; fx_:=false_x; - forever: x_:=.5[tx_,fx_]; exitif abs(tx_-fx_)<=tolerance; - if @#(x_): tx_ else: fx_ fi :=x_; endfor - x_ enddef; % now x_ is near where @# changes from true to false -newinternal tolerance, tx_,fx_,x_; tolerance:=.01; - -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: - errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect"); - fi - i_ := i; - endfor - for i=1 upto k_: subpath (ta_[i],tb_[i]) of pp_[i] .. endfor - cycle -enddef; - - - -%% units of measure - -mm=2.83464; pt=0.99626; dd=1.06601; bp:=1; -cm=28.34645; pc=11.95517; cc=12.79213; in:=72; - -vardef magstep primary m = mexp(46.67432m) enddef; - - - -%% macros for drawing and filling - -def drawoptions(text t) = - def _op_ = t enddef -enddef; - -linejoin:=rounded; % parameters that effect drawing -linecap:=rounded; -miterlimit:=10; - -drawoptions(); - -pen currentpen; -picture currentpicture; - -def fill expr c = addto currentpicture contour c _op_ enddef; -def draw expr p = - addto currentpicture - if picture p: - also p - else: - doublepath p withpen currentpen - fi - _op_ -enddef; -def filldraw expr c = - addto currentpicture contour c withpen currentpen - _op_ enddef; -def drawdot expr z = - addto currentpicture contour makepath currentpen shifted z - _op_ enddef; - -def unfill expr c = fill c withcolor background enddef; -def undraw expr p = draw p withcolor background enddef; -def unfilldraw expr c = filldraw c withcolor background enddef; -def undrawdot expr z = drawdot z withcolor background enddef; -def erase text t = - def _e_ = withcolor background hide(def _e_=enddef;) enddef; - t _e_ -enddef; -def _e_= enddef; - -def cutdraw text t = - begingroup interim linecap:=butt; draw t _e_; endgroup enddef; - -vardef image(text t) = - save currentpicture; - picture currentpicture; - currentpicture := nullpicture; - t; - currentpicture -enddef; - -def pickup secondary q = - if numeric q: numeric_pickup_ else: pen_pickup_ fi q enddef; -def numeric_pickup_ primary q = - if unknown pen_[q]: errmessage "Unknown pen"; clearpen - else: currentpen:=pen_[q]; - pen_lft:=pen_lft_[q]; - pen_rt:=pen_rt_[q]; - pen_top:=pen_top_[q]; - pen_bot:=pen_bot_[q]; - currentpen_path:=pen_path_[q] fi; enddef; -def pen_pickup_ primary q = - currentpen:=q; - pen_lft:=xpart penoffset down of currentpen; - pen_rt:=xpart penoffset up of currentpen; - pen_top:=ypart penoffset left of currentpen; - pen_bot:=ypart penoffset right of currentpen; - path currentpen_path; enddef; -newinternal pen_lft,pen_rt,pen_top,pen_bot,pen_count_; - -vardef savepen = pen_[incr pen_count_]=currentpen; - pen_lft_[pen_count_]=pen_lft; - pen_rt_[pen_count_]=pen_rt; - pen_top_[pen_count_]=pen_top; - pen_bot_[pen_count_]=pen_bot; - pen_path_[pen_count_]=currentpen_path; - pen_count_ enddef; - -def clearpen = currentpen:=nullpen; - pen_lft:=pen_rt:=pen_top:=pen_bot:=0; - path currentpen_path; - enddef; -def clear_pen_memory = - pen_count_:=0; - numeric pen_lft_[],pen_rt_[],pen_top_[],pen_bot_[]; - pen currentpen,pen_[]; - path currentpen_path, pen_path_[]; - enddef; - -vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef; -vardef rt primary x = x + if pair x: (pen_rt,0) else: pen_rt fi enddef; -vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef; -vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef; - -vardef penpos@#(expr b,d) = - (x@#r-x@#l,y@#r-y@#l)=(b,0) rotated d; - x@#=.5(x@#l+x@#r); y@#=.5(y@#l+y@#r) enddef; - -def penstroke text t = - forsuffixes e = l,r: path_.e:=t; endfor - fill path_.l -- reverse path_.r -- cycle enddef; -path path_.l,path_.r; - - - -%% High level drawing commands - -newinternal ahlength, ahangle; -ahlength := 4; % default arrowhead length 4bp -ahangle := 45; % default head angle 45 degrees - -vardef arrowhead expr p = - save q,e; path q; pair e; - e = point length p of p; - q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) - cuttings; - (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e -enddef; - -path _apth; -def drawarrow expr p = _apth:=p; _finarr enddef; -def drawdblarrow expr p = _apth:=p; _findarr enddef; - -def _finarr text t = - draw _apth t; - filldraw arrowhead _apth t -enddef; - -def _findarr text t = - draw _apth t; - fill arrowhead _apth withpen currentpen t; - fill arrowhead reverse _apth withpen currentpen t -enddef; - - - -%% macros for labels - -newinternal bboxmargin; bboxmargin:=2bp; - -vardef bbox primary p = - llcorner p-(bboxmargin,bboxmargin) -- lrcorner p+(bboxmargin,-bboxmargin) - -- urcorner p+(bboxmargin,bboxmargin) -- ulcorner p+(-bboxmargin,bboxmargin) - -- cycle -enddef; - -string defaultfont; -newinternal defaultscale, labeloffset; -defaultfont = "cmr10"; -defaultscale := 1; -labeloffset := 3bp; - -vardef thelabel@#(expr s,z) = % Position s near z - save p; picture p; - if picture s: p=s - else: p = s infont defaultfont scaled defaultscale - fi; - p shifted (z + labeloffset*laboff@# - - (labxf@#*lrcorner p + labyf@#*ulcorner p - + (1-labxf@#-labyf@#)*llcorner p - ) - ) -enddef; - -def label = draw thelabel enddef; -newinternal dotlabeldiam; dotlabeldiam:=3bp; -vardef dotlabel@#(expr s,z) text t_ = - label@#(s,z) t_; -% label@#(s,z); - interim linecap:=rounded; - draw z withpen pencircle scaled dotlabeldiam t_; -enddef; -def makelabel = dotlabel enddef; - -pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot; -pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt; -laboff =(0,0); labxf =.5; labyf =.5; -laboff.lft=(-1,0); labxf.lft=1; labyf.lft=.5; -laboff.rt =(1,0); labxf.rt =0; labyf.rt =.5; -laboff.bot=(0,-1); labxf.bot=.5; labyf.bot=1; -laboff.top=(0,1); labxf.top=.5; labyf.top=0; -laboff.ulft=(-.7,.7);labxf.ulft=1; labyf.ulft=0; -laboff.urt=(.7,.7); labxf.urt=0; labyf.urt=0; -laboff.llft=-(.7,.7);labxf.llft=1; labyf.llft=1; -laboff.lrt=(.7,-.7); labxf.lrt=0; labyf.lrt=1; - -vardef labels@#(text t) = - forsuffixes $=t: - label@#(str$,z$); endfor - enddef; -vardef dotlabels@#(text t) = - forsuffixes $=t: - dotlabel@#(str$,z$); endfor - enddef; -vardef penlabels@#(text t) = - forsuffixes $$=l,,r: forsuffixes $=t: - makelabel@#(str$.$$,z$.$$); endfor endfor - enddef; - - -def range expr x = numtok[x] enddef; -def numtok suffix x=x enddef; -tertiarydef m thru n = - m for x=m+1 step 1 until n: , numtok[x] endfor enddef; - - - -%% Overall adminstration - -string extra_beginfig, extra_endfig; -extra_beginfig = extra_endfig = "" ; - -def beginfig(expr c) = - begingroup - charcode:=c; - clearxy; clearit; clearpen; - pickup defaultpen; - drawoptions(); - scantokens extra_beginfig; -enddef; - -def endfig = - ; % added by HH - scantokens extra_endfig; - shipit ; - endgroup -enddef; - - -%% last-minute items - -vardef z@#=(x@#,y@#) enddef; - -def clearxy = save x,y enddef; -def clearit = currentpicture:=nullpicture enddef; -def shipit = shipout currentpicture enddef; - -let bye = end; outer end,bye; - -clear_pen_memory; % initialize the `savepen' mechanism -clearit; - -newinternal defaultpen; -pickup pencircle scaled .5bp; % set default line width -defaultpen := savepen; diff --git a/metapost/context/base/mp-base.mpii b/metapost/context/base/mp-base.mpii new file mode 100644 index 000000000..93cb5e90c --- /dev/null +++ b/metapost/context/base/mp-base.mpii @@ -0,0 +1,558 @@ +% This is (currently) a copy of the plain.mp file. We use a copy +% because (1) we want to make sure that there are no unresolved +% dependencies, and (2) we may patch this file eventually. + +% This file gives the macros for plain MetaPost +% It contains all the features of plain METAFONT except those specific to +% font-making. (See The METAFONTbook by D.E. Knuth). +% There are also a number of macros for labeling figures, etc. +string base_name, base_version; base_name="plain"; base_version="0.63"; + +message "Preloading the plain mem file, version "&base_version; + +delimiters (); % this makes parentheses behave like parentheses +def upto = step 1 until enddef; % syntactic sugar +def downto = step -1 until enddef; +def exitunless expr c = exitif not c enddef; +let relax = \; % ignore the word `relax', as in TeX +let \\ = \; % double relaxation is like single +def ]] = ] ] enddef; % right brackets should be loners +def -- = {curl 1}..{curl 1} enddef; +def --- = .. tension infinity .. enddef; +def ... = .. tension atleast 1 .. enddef; + +def gobble primary g = enddef; +primarydef g gobbled gg = enddef; +def hide(text t) = exitif numeric begingroup t;endgroup; enddef; +def ??? = hide(interim showstopping:=1; showdependencies) enddef; +def stop expr s = message s; gobble readstring enddef; + +warningcheck:=1; +tracinglostchars:=1; + +def interact = % sets up to make "show" commands stop + hide(showstopping:=1; tracingonline:=1) enddef; + +def loggingall = % puts tracing info into the log + tracingcommands:=3; tracingtitles:=1; tracingequations:=1; + tracingcapsules:=1; tracingspecs:=2; tracingchoices:=1; tracinglostchars:=1; + tracingstats:=1; tracingoutput:=1; tracingmacros:=1; tracingrestores:=1; + enddef; + +def tracingall = % turns on every form of tracing + tracingonline:=1; showstopping:=1; loggingall enddef; + +def tracingnone = % turns off every form of tracing + tracingcommands:=0; tracingtitles:=0; tracingequations:=0; + tracingcapsules:=0; tracingspecs:=0; tracingchoices:=0; tracinglostchars:=0; + tracingstats:=0; tracingoutput:=0; tracingmacros:=0; tracingrestores:=0; + enddef; + + + +%% dash patterns + +vardef dashpattern(text t) = + save on, off, w; + let on=_on_; + let off=_off_; + w = 0; + nullpicture t +enddef; + +tertiarydef p _on_ d = + begingroup save pic; + picture pic; pic=p; + addto pic doublepath (w,w)..(w+d,w); + w := w+d; + pic shifted (0,d) + endgroup +enddef; + +tertiarydef p _off_ d = + begingroup w:=w+d; + p shifted (0,d) + endgroup +enddef; + + + +%% basic constants and mathematical macros + +% numeric constants +newinternal eps,epsilon,infinity,_; +eps := .00049; % this is a pretty small positive number +epsilon := 1/256/256; % but this is the smallest +infinity := 4095.99998; % and this is the largest +_ := -1; % internal constant to make macros unreadable but shorter + +newinternal mitered, rounded, beveled, butt, squared; +mitered:=0; rounded:=1; beveled:=2; % linejoin types +butt:=0; rounded:=1; squared:=2; % linecap types + + +% pair constants +pair right,left,up,down,origin; +origin=(0,0); up=-down=(0,1); right=-left=(1,0); + +% path constants +path quartercircle,halfcircle,fullcircle,unitsquare; +fullcircle = makepath pencircle; +halfcircle = subpath (0,4) of fullcircle; +quartercircle = subpath (0,2) of fullcircle; +unitsquare=(0,0)--(1,0)--(1,1)--(0,1)--cycle; + +% transform constants +transform identity; +for z=origin,right,up: z transformed identity = z; endfor + +% color constants +color black, white, red, green, blue, background; +black = (0,0,0); +white = (1,1,1); +red = (1,0,0); +green = (0,1,0); +blue = (0,0,1); +background = white; % The user can reset this + +% picture constants +picture blankpicture,evenly,withdots; +blankpicture=nullpicture; % `display blankpicture...' +evenly=dashpattern(on 3 off 3); % `dashed evenly' +withdots=dashpattern(off 2.5 on 0 off 2.5); % `dashed withdots' + +% string constants +string ditto, EOF; +ditto = char 34; % ASCII double-quote mark +EOF = char 0; % end-of-file for readfrom and write..to + +% pen constants +pen pensquare,penrazor,penspeck; +pensquare = makepen(unitsquare shifted -(.5,.5)); +penrazor = makepen((-.5,0)--(.5,0)--cycle); +penspeck=pensquare scaled eps; + +% nullary operators +vardef whatever = save ?; ? enddef; + +% unary operators +let abs = length; + +vardef round primary u = + if numeric u: floor(u+.5) + elseif pair u: (round xpart u, round ypart u) + else: u fi enddef; + +vardef ceiling primary x = -floor(-x) enddef; + +vardef byte primary s = + if string s: ASCII fi s enddef; + +vardef dir primary d = right rotated d enddef; + +vardef unitvector primary z = z/abs z enddef; + +vardef inverse primary T = + transform T_; T_ transformed T = identity; T_ enddef; + +vardef counterclockwise primary c = + if turningnumber c <= 0: reverse fi c enddef; + +vardef tensepath expr r = + for k=0 upto length r - 1: point k of r --- endfor + if cycle r: cycle else: point infinity of r fi enddef; + +vardef center primary p = .5[llcorner p, urcorner p] enddef; + + + +% binary operators + +primarydef x mod y = (x-y*floor(x/y)) enddef; +primarydef x div y = floor(x/y) enddef; +primarydef w dotprod z = (xpart w * xpart z + ypart w * ypart z) enddef; + +primarydef x**y = if y=2: x*x else: takepower y of x fi enddef; +def takepower expr y of x = + if x>0: mexp(y*mlog x) + elseif (x=0) and (y>0): 0 + else: 1 + if y=floor y: + if y>=0: for n=1 upto y: *x endfor + else: for n=_ downto y: /x endfor + fi + else: hide(errmessage "Undefined power: " & decimal x&"**"&decimal y) + fi fi enddef; + +vardef direction expr t of p = + postcontrol t of p - precontrol t of p enddef; + +vardef directionpoint expr z of p = + a_:=directiontime z of p; + if a_<0: errmessage("The direction doesn't occur"); fi + point a_ of p enddef; + +secondarydef p intersectionpoint q = + begingroup save x_,y_; (x_,y_)=p intersectiontimes q; + if x_<0: errmessage("The paths don't intersect"); origin + else: .5[point x_ of p, point y_ of q] fi endgroup +enddef; + +tertiarydef p softjoin q = + begingroup c_:=fullcircle scaled 2join_radius shifted point 0 of q; + a_:=ypart(c_ intersectiontimes p); b_:=ypart(c_ intersectiontimes q); + if a_<0:point 0 of p{direction 0 of p} else: subpath(0,a_) of p fi + ... if b_<0:{direction infinity of q}point infinity of q + else: subpath(b_,infinity) of q fi endgroup enddef; +newinternal join_radius,a_,b_; path c_; + + +path cuttings; % what got cut off + +tertiarydef a cutbefore b = % tries to cut as little as possible + begingroup save t; + (t, whatever) = a intersectiontimes b; + if t<0: + cuttings:=point 0 of a; + a + else: cuttings:= subpath (0,t) of a; + subpath (t,length a) of a + fi + endgroup +enddef; + +tertiarydef a cutafter b = + reverse (reverse a cutbefore b) + hide(cuttings:=reverse cuttings) +enddef; + + + +% special operators +vardef incr suffix $ = $:=$+1; $ enddef; +vardef decr suffix $ = $:=$-1; $ enddef; + +def reflectedabout(expr w,z) = % reflects about the line w..z + transformed + begingroup transform T_; + w transformed T_ = w; z transformed T_ = z; + xxpart T_ = -yypart T_; xypart T_ = yxpart T_; % T_ is a reflection + T_ endgroup enddef; + +def rotatedaround(expr z, d) = % rotates d degrees around z + shifted -z rotated d shifted z enddef; +let rotatedabout = rotatedaround; % for roundabout people + +vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings + save u_; setu_ u; for uu = t: if uuu_: u_:=uu; fi endfor + u_ enddef; + +def setu_ primary u = + if pair u: pair u_ elseif string u: string u_ fi; + u_=u enddef; + +def flex(text t) = % t is a list of pairs + hide(n_:=0; for z=t: z_[incr n_]:=z; endfor + dz_:=z_[n_]-z_1) + z_1 for k=2 upto n_-1: ...z_[k]{dz_} endfor ...z_[n_] enddef; +newinternal n_; pair z_[],dz_; + +def superellipse(expr r,t,l,b,s)= + r{up}...(s[xpart t,xpart r],s[ypart r,ypart t]){t-r}... + t{left}...(s[xpart t,xpart l],s[ypart l,ypart t]){l-t}... + l{down}...(s[xpart b,xpart l],s[ypart l,ypart b]){b-l}... + b{right}...(s[xpart b,xpart r],s[ypart r,ypart b]){r-b}...cycle enddef; + +vardef interpath(expr a,p,q) = + for t=0 upto length p-1: a[point t of p, point t of q] + ..controls a[postcontrol t of p, postcontrol t of q] + and a[precontrol t+1 of p, precontrol t+1 of q] .. endfor + if cycle p: cycle + else: a[point infinity of p, point infinity of q] fi enddef; + +vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false + tx_:=true_x; fx_:=false_x; + forever: x_:=.5[tx_,fx_]; exitif abs(tx_-fx_)<=tolerance; + if @#(x_): tx_ else: fx_ fi :=x_; endfor + x_ enddef; % now x_ is near where @# changes from true to false +newinternal tolerance, tx_,fx_,x_; tolerance:=.01; + +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: + errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect"); + fi + i_ := i; + endfor + for i=1 upto k_: subpath (ta_[i],tb_[i]) of pp_[i] .. endfor + cycle +enddef; + + + +%% units of measure + +mm=2.83464; pt=0.99626; dd=1.06601; bp:=1; +cm=28.34645; pc=11.95517; cc=12.79213; in:=72; + +vardef magstep primary m = mexp(46.67432m) enddef; + + + +%% macros for drawing and filling + +def drawoptions(text t) = + def _op_ = t enddef +enddef; + +linejoin:=rounded; % parameters that effect drawing +linecap:=rounded; +miterlimit:=10; + +drawoptions(); + +pen currentpen; +picture currentpicture; + +def fill expr c = addto currentpicture contour c _op_ enddef; +def draw expr p = + addto currentpicture + if picture p: + also p + else: + doublepath p withpen currentpen + fi + _op_ +enddef; +def filldraw expr c = + addto currentpicture contour c withpen currentpen + _op_ enddef; +def drawdot expr z = + addto currentpicture contour makepath currentpen shifted z + _op_ enddef; + +def unfill expr c = fill c withcolor background enddef; +def undraw expr p = draw p withcolor background enddef; +def unfilldraw expr c = filldraw c withcolor background enddef; +def undrawdot expr z = drawdot z withcolor background enddef; +def erase text t = + def _e_ = withcolor background hide(def _e_=enddef;) enddef; + t _e_ +enddef; +def _e_= enddef; + +def cutdraw text t = + begingroup interim linecap:=butt; draw t _e_; endgroup enddef; + +vardef image(text t) = + save currentpicture; + picture currentpicture; + currentpicture := nullpicture; + t; + currentpicture +enddef; + +def pickup secondary q = + if numeric q: numeric_pickup_ else: pen_pickup_ fi q enddef; +def numeric_pickup_ primary q = + if unknown pen_[q]: errmessage "Unknown pen"; clearpen + else: currentpen:=pen_[q]; + pen_lft:=pen_lft_[q]; + pen_rt:=pen_rt_[q]; + pen_top:=pen_top_[q]; + pen_bot:=pen_bot_[q]; + currentpen_path:=pen_path_[q] fi; enddef; +def pen_pickup_ primary q = + currentpen:=q; + pen_lft:=xpart penoffset down of currentpen; + pen_rt:=xpart penoffset up of currentpen; + pen_top:=ypart penoffset left of currentpen; + pen_bot:=ypart penoffset right of currentpen; + path currentpen_path; enddef; +newinternal pen_lft,pen_rt,pen_top,pen_bot,pen_count_; + +vardef savepen = pen_[incr pen_count_]=currentpen; + pen_lft_[pen_count_]=pen_lft; + pen_rt_[pen_count_]=pen_rt; + pen_top_[pen_count_]=pen_top; + pen_bot_[pen_count_]=pen_bot; + pen_path_[pen_count_]=currentpen_path; + pen_count_ enddef; + +def clearpen = currentpen:=nullpen; + pen_lft:=pen_rt:=pen_top:=pen_bot:=0; + path currentpen_path; + enddef; +def clear_pen_memory = + pen_count_:=0; + numeric pen_lft_[],pen_rt_[],pen_top_[],pen_bot_[]; + pen currentpen,pen_[]; + path currentpen_path, pen_path_[]; + enddef; + +vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef; +vardef rt primary x = x + if pair x: (pen_rt,0) else: pen_rt fi enddef; +vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef; +vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef; + +vardef penpos@#(expr b,d) = + (x@#r-x@#l,y@#r-y@#l)=(b,0) rotated d; + x@#=.5(x@#l+x@#r); y@#=.5(y@#l+y@#r) enddef; + +def penstroke text t = + forsuffixes e = l,r: path_.e:=t; endfor + fill path_.l -- reverse path_.r -- cycle enddef; +path path_.l,path_.r; + + + +%% High level drawing commands + +newinternal ahlength, ahangle; +ahlength := 4; % default arrowhead length 4bp +ahangle := 45; % default head angle 45 degrees + +vardef arrowhead expr p = + save q,e; path q; pair e; + e = point length p of p; + q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) + cuttings; + (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e +enddef; + +path _apth; +def drawarrow expr p = _apth:=p; _finarr enddef; +def drawdblarrow expr p = _apth:=p; _findarr enddef; + +def _finarr text t = + draw _apth t; + filldraw arrowhead _apth t +enddef; + +def _findarr text t = + draw _apth t; + fill arrowhead _apth withpen currentpen t; + fill arrowhead reverse _apth withpen currentpen t +enddef; + + + +%% macros for labels + +newinternal bboxmargin; bboxmargin:=2bp; + +vardef bbox primary p = + llcorner p-(bboxmargin,bboxmargin) -- lrcorner p+(bboxmargin,-bboxmargin) + -- urcorner p+(bboxmargin,bboxmargin) -- ulcorner p+(-bboxmargin,bboxmargin) + -- cycle +enddef; + +string defaultfont; +newinternal defaultscale, labeloffset; +defaultfont = "cmr10"; +defaultscale := 1; +labeloffset := 3bp; + +vardef thelabel@#(expr s,z) = % Position s near z + save p; picture p; + if picture s: p=s + else: p = s infont defaultfont scaled defaultscale + fi; + p shifted (z + labeloffset*laboff@# - + (labxf@#*lrcorner p + labyf@#*ulcorner p + + (1-labxf@#-labyf@#)*llcorner p + ) + ) +enddef; + +def label = draw thelabel enddef; +newinternal dotlabeldiam; dotlabeldiam:=3bp; +vardef dotlabel@#(expr s,z) text t_ = + label@#(s,z) t_; +% label@#(s,z); + interim linecap:=rounded; + draw z withpen pencircle scaled dotlabeldiam t_; +enddef; +def makelabel = dotlabel enddef; + +pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot; +pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt; +laboff =(0,0); labxf =.5; labyf =.5; +laboff.lft=(-1,0); labxf.lft=1; labyf.lft=.5; +laboff.rt =(1,0); labxf.rt =0; labyf.rt =.5; +laboff.bot=(0,-1); labxf.bot=.5; labyf.bot=1; +laboff.top=(0,1); labxf.top=.5; labyf.top=0; +laboff.ulft=(-.7,.7);labxf.ulft=1; labyf.ulft=0; +laboff.urt=(.7,.7); labxf.urt=0; labyf.urt=0; +laboff.llft=-(.7,.7);labxf.llft=1; labyf.llft=1; +laboff.lrt=(.7,-.7); labxf.lrt=0; labyf.lrt=1; + +vardef labels@#(text t) = + forsuffixes $=t: + label@#(str$,z$); endfor + enddef; +vardef dotlabels@#(text t) = + forsuffixes $=t: + dotlabel@#(str$,z$); endfor + enddef; +vardef penlabels@#(text t) = + forsuffixes $$=l,,r: forsuffixes $=t: + makelabel@#(str$.$$,z$.$$); endfor endfor + enddef; + + +def range expr x = numtok[x] enddef; +def numtok suffix x=x enddef; +tertiarydef m thru n = + m for x=m+1 step 1 until n: , numtok[x] endfor enddef; + + + +%% Overall adminstration + +string extra_beginfig, extra_endfig; +extra_beginfig = extra_endfig = "" ; + +def beginfig(expr c) = + begingroup + charcode:=c; + clearxy; clearit; clearpen; + pickup defaultpen; + drawoptions(); + scantokens extra_beginfig; +enddef; + +def endfig = + ; % added by HH + scantokens extra_endfig; + shipit ; + endgroup +enddef; + + +%% last-minute items + +vardef z@#=(x@#,y@#) enddef; + +def clearxy = save x,y enddef; +def clearit = currentpicture:=nullpicture enddef; +def shipit = shipout currentpicture enddef; + +let bye = end; outer end,bye; + +clear_pen_memory; % initialize the `savepen' mechanism +clearit; + +newinternal defaultpen; +pickup pencircle scaled .5bp; % set default line width +defaultpen := savepen; diff --git a/metapost/context/base/mp-base.mpiv b/metapost/context/base/mp-base.mpiv new file mode 100644 index 000000000..cd0c79728 --- /dev/null +++ b/metapost/context/base/mp-base.mpiv @@ -0,0 +1,860 @@ +% This is a reformatted copy of the plain.mp file. We use a copy +% because (1) we want to make sure that there are no unresolved +% dependencies, and (2) we may patch this file eventually. + +% This file gives the macros for plain MetaPost It contains all the +% features of plain METAFONT except those specific to font-making. +% There are also a number of macros for labeling figures, etc. + +string base_name, base_version ; + +base_name := "plain" ; +base_version := "0.63" ; + +message "Preloading the plain mem file, version " & base_version ; + +delimiters () ; % this makes parentheses behave like parentheses + +def upto = + step 1 until +enddef ; + +def downto = + step -1 until +enddef ; + +def exitunless expr c = + exitif not c +enddef ; + +let relax = \ ; % ignore the word `relax', as in TeX +let \\ = \ ; % double relaxation is like single + +def ]] = % right brackets should be loners + ] ] +enddef ; + +def -- = + {curl 1}..{curl 1} +enddef ; + +def --- = + .. tension infinity .. +enddef ; + +def ... = + .. tension atleast 1 .. +enddef ; + +def gobble primary g = +enddef ; + +primarydef g gobbled gg = +enddef ; + +def hide(text t) = + exitif numeric begingroup t ; endgroup ; +enddef ; + +def ??? = + hide ( + interim showstopping : =1 ; + showdependencies + ) +enddef ; + +def stop expr s = + message s ; + gobble readstring +enddef ; + +warningcheck :=1 ; +tracinglostchars :=1 ; + +def interact = % sets up to make "show" commands stop + hide ( + showstopping := 1 ; + tracingonline := 1 ; + ) +enddef ; + +def loggingall = % puts tracing info into the log + tracingcommands := 3 ; + tracingtitles := 1 ; + tracingequations := 1 ; + tracingcapsules := 1 ; + tracingspecs := 2 ; + tracingchoices := 1 ; + tracinglostchars := 1 ; + tracingstats := 1 ; + tracingoutput := 1 ; + tracingmacros := 1 ; + tracingrestores := 1 ; +enddef ; + +def tracingall = % turns on every form of tracing + tracingonline := 1 ; + showstopping := 1 ; + loggingall +enddef ; + +def tracingnone = % turns off every form of tracing + tracingcommands := 0 ; + tracingtitles := 0 ; + tracingequations := 0 ; + tracingcapsules := 0 ; + tracingspecs := 0 ; + tracingchoices := 0 ; + tracinglostchars := 0 ; + tracingstats := 0 ; + tracingoutput := 0 ; + tracingmacros := 0 ; + tracingrestores := 0 ; +enddef ; + +%% dash patterns + +vardef dashpattern(text t) = + save on, off, w ; + let on = _on_ ; + let off = _off_ ; + w = 0 ; + nullpicture t +enddef ; + +tertiarydef p _on_ d = + begingroup save pic ; + picture pic; + pic = p ; + addto pic doublepath (w,w) .. (w+d,w) ; + w := w + d ; + pic shifted (0,d) + endgroup +enddef; + +tertiarydef p _off_ d = + begingroup w:=w+d; + p shifted (0,d) + endgroup +enddef; + +%% basic constants and mathematical macros + +% numeric constants + +newinternal eps, epsilon,infinity, _ ; + +eps := .00049 ; % this is a pretty small positive number +epsilon := 1/256/256 ; % but this is the smallest +infinity := 4095.99998 ; % and this is the largest +_ := -1 ; % internal constant to make macros unreadable but shorter + +% linejoin and linecap types + +newinternal mitered, rounded, beveled, butt, squared ; + +mitered := 0 ; rounded := 1 ; beveled := 2 ; +butt := 0 ; rounded := 1 ; squared := 2 ; + +% pair constants + +pair right, left, up, down, origin; + +origin = (0,0) ; +up = -down = (0,1) ; +right = -left = (1,0) ; + +% path constants + +path quartercircle, halfcircle, fullcircle, unitsquare ; + +fullcircle = makepath pencircle ; +halfcircle = subpath (0,4) of fullcircle ; +quartercircle = subpath (0,2) of fullcircle ; +unitsquare = (0,0) -- (1,0) -- (1,1) -- (0,1) -- cycle ; + +% transform constants + +transform identity ; + +for z=origin,right,up : + z transformed identity = z ; +endfor + +% color constants + +color black, white, red, green, blue, background; + +black = (0,0,0) ; +white = (1,1,1) ; +red = (1,0,0) ; +green = (0,1,0) ; +blue = (0,0,1) ; +background = white ; + +% picture constants + +picture blankpicture, evenly, withdots ; + +blankpicture = nullpicture ; % display blankpicture... +evenly = dashpattern(on 3 off 3) ; % dashed evenly +withdots = dashpattern(off 2.5 on 0 off 2.5) ; % dashed withdots + +% string constants + +string ditto, EOF ; + +ditto = char 34 ; % ASCII double-quote mark +EOF = char 0 ; % end-of-file for readfrom and write..to + +% pen constants + +pen pensquare, penrazor, penspeck ; + +pensquare = makepen(unitsquare shifted -(.5,.5)) ; +penrazor = makepen((-.5,0)--(.5,0)--cycle) ; +penspeck = pensquare scaled eps ; + +% nullary operators + +vardef whatever = + save ? ; + ? +enddef ; + +% unary operators + +let abs = length ; + +vardef round primary u = + if numeric u : + floor(u+.5) + elseif pair u : + (round xpart u, round ypart u) + else : + u + fi +enddef ; + +vardef ceiling primary x = + -floor(-x) +enddef ; + +vardef byte primary s = + if string s : + ASCII + fi s +enddef ; + +vardef dir primary d = + right rotated d +enddef ; + +vardef unitvector primary z = + z/abs z +enddef ; + +vardef inverse primary T = + transform T_ ; + T_ transformed T = identity ; + T_ +enddef ; + +vardef counterclockwise primary c = + if turningnumber c <= 0 : + reverse + fi c +enddef ; + +vardef tensepath expr r = + for k=0 upto length r - 1 : + point k of r --- + endfor + if cycle r : + cycle + else : + point infinity of r + fi +enddef ; + +vardef center primary p = + .5[llcorner p, urcorner p] +enddef ; + +% binary operators + +primarydef x mod y = + (x-y*floor(x/y)) +enddef ; + +primarydef x div y = + floor(x/y) +enddef ; + +primarydef w dotprod z = + (xpart w * xpart z + ypart w * ypart z) +enddef ; + +primarydef x**y = + if y=2 : + x*x + else : + takepower y of x + fi +enddef ; + +def takepower expr y of x = + if x>0 : + mexp(y*mlog x) + elseif (x=0) and (y>0) : + 0 + else : + 1 + if y = floor y : + if y >= 0 : + for n=1 upto y : + *x + endfor + else : + for n=-1 downto y : + /x + endfor + fi + else : + hide(errmessage "Undefined power: " & decimal x&"**"&decimal y) + fi + fi +enddef ; + +vardef direction expr t of p = + postcontrol t of p - precontrol t of p +enddef ; + +vardef directionpoint expr z of p = + a_ := directiontime z of p ; + if a_<0 : + errmessage("The direction doesn't occur") ; + fi + point a_ of p +enddef ; + +secondarydef p intersectionpoint q = + begingroup + save x_, y_ ; + (x_,y_) = p intersectiontimes q ; + if x_<0 : + errmessage("The paths don't intersect") ; + origin + else : + .5[point x_ of p, point y_ of q] + fi + endgroup +enddef; + +tertiarydef p softjoin q = + begingroup + c_ := fullcircle scaled 2join_radius shifted point 0 of q ; + a_ := ypart(c_ intersectiontimes p) ; + b_ := ypart(c_ intersectiontimes q) ; + if a_<0 : + point 0 of p{direction 0 of p} + else : + subpath(0,a_) of p + fi + ... + if b_<0 : + {direction infinity of q} point infinity of q + else : + subpath(b_,infinity) of q + fi + endgroup +enddef ; + +newinternal join_radius, a_, b_ ; path c_ ; + + +path cuttings ; % what got cut off + +tertiarydef a cutbefore b = % tries to cut as little as possible + begingroup + save t ; + (t, whatever) = a intersectiontimes b ; + if t<0 : + cuttings := point 0 of a ; + a + else : + cuttings := subpath (0,t) of a ; + subpath (t,length a) of a + fi + endgroup +enddef ; + +tertiarydef a cutafter b = + reverse (reverse a cutbefore b) + hide(cuttings := reverse cuttings) +enddef; + +% special operators + +vardef incr suffix $ = $:=$+1; $ enddef ; +vardef decr suffix $ = $:=$-1; $ enddef ; + +def reflectedabout(expr w,z) = % reflects about the line w..z + transformed + begingroup + transform T_ ; + w transformed T_ = w ; + z transformed T_ = z ; + xxpart T_ = -yypart T_ ; + xypart T_ = yxpart T_ ; % T_ is a reflection + T_ + endgroup +enddef ; + +def rotatedaround(expr z, d) = % rotates d degrees around z + shifted -z rotated d shifted z +enddef ; + +let rotatedabout = rotatedaround ; % for roundabout people + +vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings + save u_ ; + setu_ u ; + for uu = t : + if uuu_ : + u_ := uu ; + fi + endfor + u_ +enddef ; + +def setu_ primary u = + if pair u : + pair u_ + elseif string u : + string u_ + fi ; + u_=u +enddef ; + +def flex(text t) = % t is a list of pairs + hide ( + n_ := 0 ; + for z=t : + z_[incr n_] := z ; + endfor + dz_ := z_[n_]-z_1 + ) + z_1 for k=2 upto n_-1 : + ... z_[k]{dz_} + endfor ... z_[n_] +enddef ; + +newinternal n_; pair z_[],dz_; + +def superellipse(expr r,t,l,b,s) = + r{up} ... (s[xpart t,xpart r],s[ypart r,ypart t]){t-r} ... + t{left} ... (s[xpart t,xpart l],s[ypart l,ypart t]){l-t} ... + l{down} ... (s[xpart b,xpart l],s[ypart l,ypart b]){b-l} ... + b{right} ... (s[xpart b,xpart r],s[ypart r,ypart b]){r-b} ... cycle enddef ; + +vardef interpath(expr a,p,q) = + for t=0 upto length p-1 : + a[point t of p, point t of q] .. controls a[postcontrol t of p, postcontrol t of q] and a[precontrol t+1 of p, precontrol t+1 of q] .. + endfor + if cycle p : + cycle + else : + a[point infinity of p, point infinity of q] + fi +enddef ; + +vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false + tx_:=true_x; fx_:=false_x; + forever : + x_ := .5[tx_,fx_] ; + exitif abs(tx_-fx_) <= tolerance ; + if @#(x_) : + tx_ + else : + fx_ + fi := x_ ; + endfor + x_ % now x_ is near where @# changes from true to false +enddef ; + +newinternal tolerance, tx_, fx_, x_ ; + +tolerance := .01 ; + +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 : + errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect") ; + fi + i_ := i; + endfor + for i=1 upto k_ : + subpath (ta_[i],tb_[i]) of pp_[i] .. + endfor + cycle +enddef ; + +%% units of measure + +mm := 2.83464 ; +pt := 0.99626 ; +dd := 1.06601 ; +bp := 1 ; +cm := 28.34645 ; +pc := 11.95517 ; +cc := 12.79213 ; +in := 72 ; + +vardef magstep primary m = + mexp(46.67432m) +enddef ; + +%% macros for drawing and filling + +def drawoptions(text t) = + def _op_ = t enddef +enddef ; + +% parameters that effect drawing + +linejoin := rounded ; +linecap := rounded ; +miterlimit := 10 ; + +drawoptions() ; + +pen currentpen ; +picture currentpicture ; + +def fill expr c = + addto currentpicture contour c _op_ +enddef ; + +def draw expr p = + addto currentpicture + if picture p : + also p + else : + doublepath p withpen currentpen + fi + _op_ +enddef ; + +def filldraw expr c = + addto currentpicture contour c withpen currentpen _op_ +enddef ; + +def drawdot expr z = + addto currentpicture contour makepath currentpen shifted z _op_ +enddef ; + +def unfill expr c = fill c withcolor background enddef ; +def undraw expr p = draw p withcolor background enddef ; +def unfilldraw expr c = filldraw c withcolor background enddef ; +def undrawdot expr z = drawdot z withcolor background enddef ; + +def erase text t = + def _e_ = + withcolor background hide(def _e_ = enddef ;) + enddef ; + t _e_ +enddef; + +def _e_ = enddef ; + +def cutdraw text t = + begingroup + interim linecap := butt ; + draw t _e_ ; + endgroup +enddef ; + +vardef image(text t) = + save currentpicture ; + picture currentpicture ; + currentpicture := nullpicture ; + t ; + currentpicture +enddef; + +def pickup secondary q = + if numeric q : + numeric_pickup_ + else : + pen_pickup_ + fi q +enddef ; + +def numeric_pickup_ primary q = + if unknown pen_[q] : + errmessage "Unknown pen" ; + clearpen + else : + currentpen := pen_ [q] ; + pen_lft := pen_lft_[q] ; + pen_rt := pen_rt_ [q] ; + pen_top := pen_top_[q] ; + pen_bot := pen_bot_[q] ; + currentpen_path := pen_path_[q] + fi ; +enddef ; + +def pen_pickup_ primary q = + currentpen := q ; + pen_lft :=xpart penoffset down of currentpen ; + pen_rt :=xpart penoffset up of currentpen ; + pen_top :=ypart penoffset left of currentpen ; + pen_bot :=ypart penoffset right of currentpen ; + path currentpen_path ; +enddef; + +newinternal pen_lft, pen_rt, pen_top, pen_bot, pen_count_ ; + +vardef savepen = + pen_[incr pen_count_] = currentpen ; + pen_lft_ [pen_count_] = pen_lft ; + pen_rt_ [pen_count_] = pen_rt ; + pen_top_ [pen_count_] = pen_top ; + pen_bot_ [pen_count_] = pen_bot ; + pen_path_[pen_count_] = currentpen_path ; + pen_count_ +enddef; + +def clearpen = currentpen:=nullpen; + pen_lft := pen_rt := pen_top := pen_bot := 0 ; + path currentpen_path ; +enddef ; + +def clear_pen_memory = + pen_count_ := 0 ; + numeric pen_lft_[], pen_rt_[], pen_top_[], pen_bot_[] ; + pen currentpen, pen_[]; + path currentpen_path, pen_path_[] ; +enddef ; + +vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef ; +vardef rt primary x = x + if pair x: (pen_rt,0) else: pen_rt fi enddef ; +vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef ; +vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef ; + +vardef penpos@#(expr b,d) = + (x@#r-x@#l,y@#r-y@#l) = (b,0) rotated d ; + x@# = .5(x@#l+x@#r) ; + y@# = .5(y@#l+y@#r) +enddef ; + +path path_.l, path_.r ; + +def penstroke text t = + forsuffixes e = l, r : + path_.e := t ; + endfor + fill path_.l -- reverse path_.r -- cycle +enddef ; + +%% High level drawing commands + +newinternal ahlength, ahangle ; + +ahlength := 4 ; % default arrowhead length 4bp +ahangle := 45 ; % default head angle 45 degrees + +vardef arrowhead expr p = + save q, e ; path q ; pair e ; + e = point length p of p ; + q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) cuttings ; + (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e +enddef; + +path _apth ; + +def drawarrow expr p = _apth := p ; _finarr enddef ; +def drawdblarrow expr p = _apth := p ; _findarr enddef ; + +def _finarr text t = + draw _apth t ; + filldraw arrowhead _apth t +enddef; + +def _findarr text t = + draw _apth t ; + fill arrowhead _apth withpen currentpen t ; + fill arrowhead reverse _apth withpen currentpen t ; % ; added HH +enddef ; + +%% macros for labels + +newinternal bboxmargin ; + +bboxmargin := 2bp ; % this can bite you + +vardef bbox primary p = + llcorner p-( bboxmargin, bboxmargin) + -- lrcorner p+( bboxmargin,-bboxmargin) + -- urcorner p+( bboxmargin, bboxmargin) + -- ulcorner p+(-bboxmargin, bboxmargin) + -- cycle +enddef ; + +string defaultfont ; newinternal defaultscale, labeloffset ; + +defaultfont := "cmr10" ; +defaultscale := 1 ; +labeloffset := 3bp ; + +vardef thelabel@#(expr s,z) = % Position s near z + save p ; picture p ; + if picture s : + p = s + else : + p = s infont defaultfont scaled defaultscale + fi ; + p shifted (z + labeloffset*laboff@# - ( labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p) ) +enddef; + +def label = + draw thelabel +enddef ; + +newinternal dotlabeldiam ; + +dotlabeldiam := 3bp ; + +vardef dotlabel@#(expr s,z) text t_ = + label@#(s,z) t_ ; + % label@#(s,z) ; + interim linecap:=rounded ; + draw z withpen pencircle scaled dotlabeldiam t_ ; +enddef ; + +def makelabel = + dotlabel +enddef ; + +pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot ; +pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt ; + +laboff = (0,0) ; labxf = .5 ; labyf = .5 ; +laboff.lft = (-1,0) ; labxf.lft = 1 ; labyf.lft = .5 ; +laboff.rt = (1,0) ; labxf.rt = 0 ; labyf.rt = .5 ; +laboff.bot = (0,-1) ; labxf.bot = .5 ; labyf.bot = 1 ; +laboff.top = (0,1) ; labxf.top = .5 ; labyf.top = 0 ; +laboff.ulft = (-.7,.7) ; labxf.ulft = 1 ; labyf.ulft = 0 ; +laboff.urt = (.7,.7) ; labxf.urt = 0 ; labyf.urt = 0 ; +laboff.llft = -(.7,.7) ; labxf.llft = 1 ; labyf.llft = 1 ; +laboff.lrt = (.7,-.7) ; labxf.lrt = 0 ; labyf.lrt = 1 ; + +vardef labels@#(text t) = + forsuffixes $=t : + label@#(str$,z$) ; + endfor +enddef ; + +vardef dotlabels@#(text t) = + forsuffixes $=t: + dotlabel@#(str$,z$) ; + endfor +enddef ; + +vardef penlabels@#(text t) = + forsuffixes $$=l,,r : + forsuffixes $=t : + makelabel@#(str$.$$,z$.$$) ; + endfor + endfor +enddef ; + +def range expr x = + numtok[x] +enddef ; + +def numtok suffix x = + x +enddef ; + +tertiarydef m thru n = + m for x=m+1 step 1 until n : + , numtok[x] + endfor +enddef ; + +%% Overall adminstration + +string extra_beginfig, extra_endfig ; + +extra_beginfig := "" ; +extra_endfig := "" ; + +def beginfig(expr c) = + begingroup + charcode := c ; + clearxy ; + clearit ; + clearpen ; + pickup defaultpen ; + drawoptions() ; + scantokens extra_beginfig ; +enddef; + +def endfig = + ; % added by HH + scantokens extra_endfig ; + shipit ; + endgroup +enddef; + +%% last-minute items + +vardef z@# = + (x@#,y@#) +enddef ; + +def clearxy = + save x, y +enddef ; + +def clearit = + currentpicture := nullpicture +enddef ; + +def shipit = + shipout currentpicture +enddef ; + +let bye = end ; +outer end, bye ; + +clear_pen_memory ; % initialize the savepen mechanism +clearit ; + +% set default line width + +newinternal defaultpen ; + +pickup pencircle scaled .5bp ; + +defaultpen := savepen ; -- cgit v1.2.3