% 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. % For practical reasons I have moved some new code here (and might % remove some code as well). After all, there is no development in % this format. string base_name, base_version ; base_name := "plain" ; base_version := "1.004 for metafun iv and xl" ; message "loading metafun, including plain.mp 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 [[ = [ [ enddef ; def ]] = ] ] 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 ; 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 ; 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 (all in rgb color space) color black, white, red, green, blue, cyan, magenta, yellow, background; black := (0,0,0) ; white := (1,1,1) ; red := (1,0,0) ; green := (0,1,0) ; blue := (0,0,1) ; cyan := (0,1,1) ; magenta := (1,0,1) ; yellow := (1,1,0) ; background := white ; % obsolete let graypart = greypart ; let greycolor = numeric ; let graycolor = numeric ; % color part (will be overloaded) newinternal nocolormodel ; nocolormodel := 1 ; newinternal greycolormodel ; greycolormodel := 3 ; newinternal graycolormodel ; graycolormodel := 3 ; newinternal rgbcolormodel ; rgbcolormodel := 5 ; newinternal cmykcolormodel ; cmykcolormodel := 7 ; def colorpart primary t = if colormodel t = cmykcolormodel: (cyanpart t, magentapart t, yellowpart t, blackpart t) elseif colormodel t = rgbcolormodel : (redpart t, greenpart t, bluepart t) elseif colormodel t = graycolormodel : (greypart t) elseif colormodel t = nocolormodel : false elseif defaultcolormodel = cmykcolormodel : (0,0,0,1) elseif defaultcolormodel = rgbcolormodel : black elseif defaultcolormodel = graycolormodel : 0 else : false fi enddef ; % 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, penspec ; pensquare = makepen(unitsquare shifted -(.5,.5)) ; penrazor = makepen((-.5,0) -- (.5,0) -- cycle) ; penspec = pensquare scaled eps ; def penspeck = penspec enddef ; % nullary operators vardef whatever = save ? ; ? enddef ; % unary operators (with patched round) let abs = length ; vardef round primary u = if numeric u : floor(u+.5) elseif pair u : (floor(xpart u+.5), floor(ypart u+.5)) elseif path u : % added by HH for i=0 upto length u-1 : round(point i of u) .. controls round(postcontrol i of u) and round(precontrol i+1 of u) .. endfor if cycle u : cycle else : point infinity of u fi 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 ; % for big number systems: primarydef x**y = if y = 0 : 1 elseif x = 0 : 0 elseif y < 0 : 1/(x**-y) elseif y = 1 : x elseif y = 2 : x*x elseif y = 3 : x*x*x else : takepower y of x fi enddef ; def takepower expr y of x = if y=0 : % isn't x**0 = 1 even if x=0 ? 1 elseif x=0 : 0 else : if y = floor y : 1 if y >= 0 : for n=1 upto y : *x endfor else : for n=-1 downto y : /x endfor fi elseif x>0 : mexp(y*mlog x) else : -mexp(y*mlog -x) 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 uu < u_ : u_ := uu ; fi endfor u_ enddef ; vardef max(expr u)(text t) = % t is a list of numerics, pairs, or strings save u_ ; setu_ u ; for uu = t : if uu > u_ : 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 = % obsolete 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 ; % % testcase DEK: % % for j=1 upto 9 : % pickup pencircle xscaled .4 yscaled .2 ; % drawdot (10j,0) withpen pencircle xscaled .5j yscaled .25j rotated 45 ; % pickup pencircle xscaled .5j yscaled .25j rotated 45 ; % drawdot (10j,10); % endfor ; % % or: % %\startMPpage % % def drawdot expr z = % addto currentpicture contour (makepath currentpen shifted z) _op_ % enddef; % % drawdot origin shifted (0,-3cm) withpen pencircle scaled 2cm ; % pickup pencircle scaled 2cm ; drawdot origin withcolor red ; def drawdot expr p = if pair p : addto currentpicture doublepath p withpen currentpen _op_ else : errmessage("drawdot only accepts a pair expression") fi 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) ; % ; added HH 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 = % this had fill in 0.63 (potential incompatibility) draw _apth t ; filldraw arrowhead _apth withpen currentpen t ; filldraw arrowhead reverse _apth withpen currentpen t ; % ; added HH enddef ; %% macros for labels newinternal bboxmargin ; bboxmargin := 2bp ; % this can bite you, just don't use it in \METAFUN 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 ; % this will be overloaded 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 ; % till lhere 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 ; % range 4 thru 10 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 administration string extra_beginfig, extra_endfig ; extra_beginfig := "" ; extra_endfig := "" ; boolean makingfigure ; makingfigure := false ; numeric stacking ; stacking := 0 ; def beginfig(expr c) = % redefined in mp-grph ! begingroup save makingfigure ; boolean makingfigure ; save stacking ; numeric stacking; charcode := c ; clearxy ; clearit ; clearpen ; pickup defaultpen ; drawoptions() ; stacking := 0 ; makingfigure := true; 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 ;