git.oblomov.eu Git - mplib/blob - src/texk/web2c/mpdir/tests/plain.mp

   1 % This file gives the macros for plain MetaPost
   2 % It contains all the features of plain METAFONT except those specific to
   3 % font-making.  (See The METAFONTbook by D.E. Knuth).
   4 % There are also a number of macros for labeling figures, etc.
   5 string base_name, base_version; base_name="plain"; base_version="0.64";
   6
   7 message "Preloading the plain mem file, version "&base_version;
   8
   9 delimiters ();  % this makes parentheses behave like parentheses
  10 def upto = step 1 until enddef; % syntactic sugar
  11 def downto = step -1 until enddef;
  12 def exitunless expr c = exitif not c enddef;
  13 let relax = \;  % ignore the word `relax', as in TeX
  14 let \\ = \; % double relaxation is like single
  15 def ]] = ] ] enddef; % right brackets should be loners
  16 def -- = {curl 1}..{curl 1} enddef;
  17 def --- = .. tension infinity .. enddef;
  18 def ... = .. tension atleast 1 .. enddef;
  19
  20 def gobble primary g = enddef;
  21 primarydef g gobbled gg = enddef;
  22 def hide(text t) = exitif numeric begingroup t;endgroup; enddef;
  23 def ??? = hide(interim showstopping:=1; showdependencies) enddef;
  24 def stop expr s = message s; gobble readstring enddef;
  25
  26 warningcheck:=1;
  27 tracinglostchars:=1;
  28
  29 def interact = % sets up to make "show" commands stop
  30  hide(showstopping:=1; tracingonline:=1) enddef;
  31
  32 def loggingall =        % puts tracing info into the log
  33  tracingcommands:=3; tracingtitles:=1; tracingequations:=1;
  34  tracingcapsules:=1; tracingspecs:=2; tracingchoices:=1; tracinglostchars:=1;
  35  tracingstats:=1; tracingoutput:=1; tracingmacros:=1; tracingrestores:=1;
  36  enddef;
  37
  38 def tracingall =        % turns on every form of tracing
  39  tracingonline:=1; showstopping:=1; loggingall enddef;
  40
  41 def tracingnone =       % turns off every form of tracing
  42  tracingcommands:=0; tracingtitles:=0; tracingequations:=0;
  43  tracingcapsules:=0; tracingspecs:=0; tracingchoices:=0; tracinglostchars:=0;
  44  tracingstats:=0; tracingoutput:=0; tracingmacros:=0; tracingrestores:=0;
  45  enddef;
  46
  47
  48
  49 %% dash patterns
  50
  51 vardef dashpattern(text t) =
  52   save on, off, w;
  53   let on=_on_;
  54   let off=_off_;
  55   w = 0;
  56   nullpicture t
  57 enddef;
  58
  59 tertiarydef p _on_ d =
  60   begingroup save pic;
  61   picture pic; pic=p;
  62   addto pic doublepath (w,w)..(w+d,w);
  63   w := w+d;
  64   pic shifted (0,d)
  65   endgroup
  66 enddef;
  67
  68 tertiarydef p _off_ d =
  69   begingroup w:=w+d;
  70   p shifted (0,d)
  71   endgroup
  72 enddef;
  73
  74
  75
  76 %% basic constants and mathematical macros
  77
  78 % numeric constants
  79 newinternal eps,epsilon,infinity,_;
  80 eps := .00049;    % this is a pretty small positive number
  81 epsilon := 1/256/256;   % but this is the smallest
  82 infinity := 4095.99998;    % and this is the largest
  83 _ := -1; % internal constant to make macros unreadable but shorter
  84
  85 newinternal mitered, rounded, beveled, butt, squared;
  86 mitered:=0; rounded:=1; beveled:=2; % linejoin types
  87 butt:=0;    rounded:=1; squared:=2; % linecap types
  88
  89
  90 % pair constants
  91 pair right,left,up,down,origin;
  92 origin=(0,0); up=-down=(0,1); right=-left=(1,0);
  93
  94 % path constants
  95 path quartercircle,halfcircle,fullcircle,unitsquare;
  96 fullcircle = makepath pencircle;
  97 halfcircle = subpath (0,4) of fullcircle;
  98 quartercircle = subpath (0,2) of fullcircle;
  99 unitsquare=(0,0)--(1,0)--(1,1)--(0,1)--cycle;
 100
 101 % transform constants
 102 transform identity;
 103 for z=origin,right,up: z transformed identity = z; endfor
 104
 105 % color constants
 106 color black, white, red, green, blue, background;
 107 black = (0,0,0);
 108 white = (1,1,1);
 109 red = (1,0,0);
 110 green = (0,1,0);
 111 blue = (0,0,1);
 112 background = white;   % The user can reset this
 113
 114 % picture constants
 115 picture blankpicture,evenly,withdots;
 116 blankpicture=nullpicture; % `display blankpicture...'
 117 evenly=dashpattern(on 3 off 3); % `dashed evenly'
 118 withdots=dashpattern(off 2.5 on 0 off 2.5); % `dashed withdots'
 119
 120 % string constants
 121 string ditto, EOF;
 122 ditto = char 34; % ASCII double-quote mark
 123 EOF = char 0;    % end-of-file for readfrom and write..to
 124
 125 % pen constants
 126 pen pensquare,penrazor,penspeck;
 127 pensquare = makepen(unitsquare shifted -(.5,.5));
 128 penrazor = makepen((-.5,0)--(.5,0)--cycle);
 129 penspeck=pensquare scaled eps;
 130
 131 % nullary operators
 132 vardef whatever = save ?; ? enddef;
 133
 134 % unary operators
 135 let abs = length;
 136
 137 vardef round primary u =
 138  if numeric u: floor(u+.5)
 139  elseif pair u: (round xpart u, round ypart u)
 140  else: u fi enddef;
 141
 142 vardef ceiling primary x = -floor(-x) enddef;
 143
 144 vardef byte primary s =
 145  if string s: ASCII fi s enddef;
 146
 147 vardef dir primary d = right rotated d enddef;
 148
 149 vardef unitvector primary z = z/abs z enddef;
 150
 151 vardef inverse primary T =
 152  transform T_; T_ transformed T = identity; T_ enddef;
 153
 154 vardef counterclockwise primary c =
 155  if turningnumber c <= 0: reverse fi c enddef;
 156
 157 vardef tensepath expr r =
 158  for k=0 upto length r - 1: point k of r --- endfor
 159  if cycle r: cycle else: point infinity of r fi enddef;
 160
 161 vardef center primary p = .5[llcorner p, urcorner p] enddef;
 162
 163
 164
 165 % binary operators
 166
 167 primarydef x mod y = (x-y*floor(x/y)) enddef;
 168 primarydef x div y = floor(x/y) enddef;
 169 primarydef w dotprod z = (xpart w * xpart z + ypart w * ypart z) enddef;
 170
 171 primarydef x**y = if y=2: x*x else: takepower y of x fi enddef;
 172 def takepower expr y of x =
 173  if x>0: mexp(y*mlog x)
 174  elseif (x=0) and (y>0): 0
 175  else: 1
 176   if y=floor y:
 177    if y>=0: for n=1 upto y: *x endfor
 178    else: for n=_ downto y: /x endfor
 179    fi
 180   else: hide(errmessage "Undefined power: " & decimal x&"**"&decimal y)
 181   fi fi enddef;
 182
 183 vardef direction expr t of p =
 184  postcontrol t of p - precontrol t of p enddef;
 185
 186 vardef directionpoint expr z of p =
 187  a_:=directiontime z of p;
 188  if a_<0: errmessage("The direction doesn't occur"); fi
 189  point a_ of p enddef;
 190
 191 secondarydef p intersectionpoint q =
 192  begingroup save x_,y_; (x_,y_)=p intersectiontimes q;
 193  if x_<0: errmessage("The paths don't intersect"); origin
 194  else: .5[point x_ of p, point y_ of q] fi endgroup
 195 enddef;
 196
 197 tertiarydef p softjoin q =
 198  begingroup c_:=fullcircle scaled 2join_radius shifted point 0 of q;
 199  a_:=ypart(c_ intersectiontimes p); b_:=ypart(c_ intersectiontimes q);
 200  if a_<0:point 0 of p{direction 0 of p} else: subpath(0,a_) of p fi
 201   ... if b_<0:{direction infinity of q}point infinity of q
 202    else: subpath(b_,infinity) of q fi endgroup enddef;
 203 newinternal join_radius,a_,b_; path c_;
 204
 205
 206 path cuttings;  % what got cut off
 207
 208 tertiarydef a cutbefore b =  % tries to cut as little as possible
 209   begingroup save t;
 210   (t, whatever) = a intersectiontimes b;
 211   if t<0:
 212     cuttings:=point 0 of a;
 213     a
 214   else: cuttings:= subpath (0,t) of a;
 215     subpath (t,length a) of a
 216   fi
 217   endgroup
 218 enddef;
 219
 220 tertiarydef a cutafter b =
 221   reverse (reverse a  cutbefore  b)
 222   hide(cuttings:=reverse cuttings)
 223 enddef;
 224
 225
 226
 227 % special operators
 228 vardef incr suffix $ = $:=$+1; $ enddef;
 229 vardef decr suffix $ = $:=$-1; $ enddef;
 230
 231 def reflectedabout(expr w,z) =    % reflects about the line w..z
 232  transformed
 233   begingroup transform T_;
 234   w transformed T_ = w;  z transformed T_ = z;
 235   xxpart T_ = -yypart T_; xypart T_ = yxpart T_; % T_ is a reflection
 236   T_ endgroup enddef;
 237
 238 def rotatedaround(expr z, d) =    % rotates d degrees around z
 239  shifted -z rotated d shifted z enddef;
 240 let rotatedabout = rotatedaround;   % for roundabout people
 241
 242 vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings
 243  save u_; setu_ u; for uu = t: if uu<u_: u_:=uu; fi endfor
 244  u_ enddef;
 245
 246 vardef max(expr u)(text t) = % t is a list of numerics, pairs, or strings
 247  save u_; setu_ u; for uu = t: if uu>u_: u_:=uu; fi endfor
 248  u_ enddef;
 249
 250 def setu_ primary u =
 251  if pair u: pair u_ elseif string u: string u_ fi;
 252  u_=u enddef;
 253
 254 def flex(text t) =           % t is a list of pairs
 255  hide(n_:=0; for z=t: z_[incr n_]:=z; endfor
 256   dz_:=z_[n_]-z_1)
 257  z_1 for k=2 upto n_-1: ...z_[k]{dz_} endfor ...z_[n_] enddef;
 258 newinternal n_; pair z_[],dz_;
 259
 260 def superellipse(expr r,t,l,b,s)=
 261  r{up}...(s[xpart t,xpart r],s[ypart r,ypart t]){t-r}...
 262  t{left}...(s[xpart t,xpart l],s[ypart l,ypart t]){l-t}...
 263  l{down}...(s[xpart b,xpart l],s[ypart l,ypart b]){b-l}...
 264  b{right}...(s[xpart b,xpart r],s[ypart r,ypart b]){r-b}...cycle enddef;
 265
 266 vardef interpath(expr a,p,q) =
 267  for t=0 upto length p-1: a[point t of p, point t of q]
 268   ..controls a[postcontrol t of p, postcontrol t of q]
 269    and a[precontrol t+1 of p, precontrol t+1 of q] .. endfor
 270  if cycle p: cycle
 271  else: a[point infinity of p, point infinity of q] fi enddef;
 272
 273 vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false
 274  tx_:=true_x; fx_:=false_x;
 275  forever: x_:=.5[tx_,fx_]; exitif abs(tx_-fx_)<=tolerance;
 276  if @#(x_): tx_ else: fx_ fi :=x_; endfor
 277  x_ enddef; % now x_ is near where @# changes from true to false
 278 newinternal tolerance, tx_,fx_,x_; tolerance:=.01;
 279
 280 vardef buildcycle(text ll) =
 281   save ta_, tb_, k_, i_, pp_; path pp_[];
 282   k_=0;
 283   for q=ll: pp_[incr k_]=q; endfor
 284   i_=k_;
 285   for i=1 upto k_:
 286     (ta_[i], length pp_[i_]-tb_[i_]) =
 287       pp_[i] intersectiontimes reverse pp_[i_];
 288     if ta_[i]<0:
 289       errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect");
 290     fi
 291     i_ := i;
 292   endfor
 293   for i=1 upto k_: subpath (ta_[i],tb_[i]) of pp_[i] .. endfor
 294     cycle
 295 enddef;
 296
 297
 298
 299 %% units of measure
 300
 301 mm=2.83464;      pt=0.99626;        dd=1.06601;      bp:=1;
 302 cm=28.34645;     pc=11.95517;       cc=12.79213;     in:=72;
 303
 304 vardef magstep primary m = mexp(46.67432m) enddef;
 305
 306
 307
 308 %% macros for drawing and filling
 309
 310 def drawoptions(text t) =
 311   def _op_ = t enddef
 312 enddef;
 313
 314 linejoin:=rounded;               % parameters that effect drawing
 315 linecap:=rounded;
 316 miterlimit:=10;
 317
 318 drawoptions();
 319
 320 pen currentpen;
 321 picture currentpicture;
 322
 323 def fill expr c = addto currentpicture contour c _op_ enddef;
 324 def draw expr p =
 325   addto currentpicture
 326   if picture p:
 327     also p
 328   else:
 329     doublepath p withpen currentpen
 330   fi
 331   _op_
 332 enddef;
 333 def filldraw expr c =
 334   addto currentpicture contour c withpen currentpen
 335   _op_ enddef;
 336 def drawdot expr z =
 337   addto currentpicture contour makepath currentpen shifted z
 338   _op_ enddef;
 339
 340 def unfill expr c = fill c withcolor background enddef;
 341 def undraw expr p = draw p withcolor background enddef;
 342 def unfilldraw expr c = filldraw c withcolor background enddef;
 343 def undrawdot expr z = drawdot z withcolor background enddef;
 344 def erase text t =
 345   def _e_ = withcolor background hide(def _e_=enddef;) enddef;
 346   t _e_
 347 enddef;
 348 def _e_= enddef;
 349
 350 def cutdraw text t =
 351   begingroup interim linecap:=butt; draw t _e_; endgroup enddef;
 352
 353 vardef image(text t) =
 354   save currentpicture;
 355   picture currentpicture;
 356   currentpicture := nullpicture;
 357   t;
 358   currentpicture
 359 enddef;
 360
 361 def pickup secondary q =
 362  if numeric q: numeric_pickup_ else: pen_pickup_ fi q enddef;
 363 def numeric_pickup_ primary q =
 364  if unknown pen_[q]: errmessage "Unknown pen"; clearpen
 365  else: currentpen:=pen_[q];
 366   pen_lft:=pen_lft_[q];
 367   pen_rt:=pen_rt_[q];
 368   pen_top:=pen_top_[q];
 369   pen_bot:=pen_bot_[q];
 370   currentpen_path:=pen_path_[q] fi; enddef;
 371 def pen_pickup_ primary q =
 372   currentpen:=q;
 373   pen_lft:=xpart penoffset down of currentpen;
 374   pen_rt:=xpart penoffset up of currentpen;
 375   pen_top:=ypart penoffset left of currentpen;
 376   pen_bot:=ypart penoffset right of currentpen;
 377   path currentpen_path; enddef;
 378 newinternal pen_lft,pen_rt,pen_top,pen_bot,pen_count_;
 379
 380 vardef savepen = pen_[incr pen_count_]=currentpen;
 381  pen_lft_[pen_count_]=pen_lft;
 382  pen_rt_[pen_count_]=pen_rt;
 383  pen_top_[pen_count_]=pen_top;
 384  pen_bot_[pen_count_]=pen_bot;
 385  pen_path_[pen_count_]=currentpen_path;
 386  pen_count_ enddef;
 387
 388 def clearpen = currentpen:=nullpen;
 389  pen_lft:=pen_rt:=pen_top:=pen_bot:=0;
 390  path currentpen_path;
 391  enddef;
 392 def clear_pen_memory =
 393  pen_count_:=0;
 394  numeric pen_lft_[],pen_rt_[],pen_top_[],pen_bot_[];
 395  pen currentpen,pen_[];
 396  path currentpen_path, pen_path_[];
 397  enddef;
 398
 399 vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef;
 400 vardef rt primary x = x + if pair x: (pen_rt,0) else: pen_rt fi enddef;
 401 vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef;
 402 vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef;
 403
 404 vardef penpos@#(expr b,d) =
 405  (x@#r-x@#l,y@#r-y@#l)=(b,0) rotated d;
 406  x@#=.5(x@#l+x@#r); y@#=.5(y@#l+y@#r) enddef;
 407
 408 def penstroke text t =
 409  forsuffixes e = l,r: path_.e:=t; endfor
 410  fill path_.l -- reverse path_.r -- cycle enddef;
 411 path path_.l,path_.r;
 412
 413
 414
 415 %% High level drawing commands
 416
 417 newinternal ahlength, ahangle;
 418 ahlength := 4;            % default arrowhead length 4bp
 419 ahangle := 45;           % default head angle 45 degrees
 420
 421 vardef arrowhead expr p =
 422   save q,e; path q; pair e;
 423   e = point length p of p;
 424   q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength))
 425     cuttings;
 426   (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle)  shifted e
 427 enddef;
 428
 429 path _apth;
 430 def drawarrow expr p = _apth:=p; _finarr enddef;
 431 def drawdblarrow expr p = _apth:=p; _findarr enddef;
 432
 433 def _finarr text t =
 434   draw _apth t;
 435   filldraw arrowhead _apth  t
 436 enddef;
 437
 438 def _findarr text t =
 439   draw _apth t;
 440   filldraw arrowhead _apth withpen currentpen  t;
 441   filldraw arrowhead  reverse _apth  withpen currentpen  t
 442 enddef;
 443
 444
 445
 446 %% macros for labels
 447
 448 newinternal bboxmargin; bboxmargin:=2bp;
 449
 450 vardef bbox primary p =
 451   llcorner p-(bboxmargin,bboxmargin) -- lrcorner p+(bboxmargin,-bboxmargin)
 452   -- urcorner p+(bboxmargin,bboxmargin) -- ulcorner p+(-bboxmargin,bboxmargin)
 453   -- cycle
 454 enddef;
 455
 456 string defaultfont;
 457 newinternal defaultscale, labeloffset;
 458 defaultfont = "cmr10";
 459 defaultscale := 1;
 460 labeloffset := 3bp;
 461
 462 vardef thelabel@#(expr s,z) =  % Position s near z
 463   save p; picture p;
 464   if picture s:  p=s
 465   else:    p = s infont defaultfont scaled defaultscale
 466   fi;
 467   p shifted (z + labeloffset*laboff@# -
 468      (labxf@#*lrcorner p + labyf@#*ulcorner p
 469        + (1-labxf@#-labyf@#)*llcorner p
 470      )
 471   )
 472 enddef;
 473
 474 def label = draw thelabel enddef;
 475 newinternal dotlabeldiam; dotlabeldiam:=3bp;
 476 vardef dotlabel@#(expr s,z) =
 477   label@#(s,z);
 478   interim linecap:=rounded;
 479   draw z withpen pencircle scaled dotlabeldiam;
 480 enddef;
 481 def makelabel = dotlabel enddef;
 482
 483 pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot;
 484 pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt;
 485 laboff    =(0,0);    labxf    =.5;  labyf    =.5;
 486 laboff.lft=(-1,0);   labxf.lft=1;   labyf.lft=.5;
 487 laboff.rt =(1,0);    labxf.rt =0;   labyf.rt =.5;
 488 laboff.bot=(0,-1);   labxf.bot=.5;  labyf.bot=1;
 489 laboff.top=(0,1);    labxf.top=.5;  labyf.top=0;
 490 laboff.ulft=(-.7,.7);labxf.ulft=1;  labyf.ulft=0;
 491 laboff.urt=(.7,.7);  labxf.urt=0;   labyf.urt=0;
 492 laboff.llft=-(.7,.7);labxf.llft=1;  labyf.llft=1;
 493 laboff.lrt=(.7,-.7); labxf.lrt=0;   labyf.lrt=1;
 494
 495 vardef labels@#(text t) =
 496  forsuffixes $=t:
 497    label@#(str$,z$); endfor
 498  enddef;
 499 vardef dotlabels@#(text t) =
 500  forsuffixes $=t:
 501    dotlabel@#(str$,z$); endfor
 502  enddef;
 503 vardef penlabels@#(text t) =
 504  forsuffixes $$=l,,r: forsuffixes $=t:
 505    makelabel@#(str$.$$,z$.$$); endfor endfor
 506  enddef;
 507
 508
 509 def range expr x = numtok[x] enddef;
 510 def numtok suffix x=x enddef;
 511 tertiarydef m thru n =
 512  m for x=m+1 step 1 until n: , numtok[x] endfor enddef;
 513
 514
 515
 516 %% Overall adminstration
 517
 518 string extra_beginfig, extra_endfig;
 519 extra_beginfig = extra_endfig = "";
 520
 521 def beginfig(expr c) =
 522   begingroup
 523   charcode:=c;
 524   clearxy; clearit; clearpen;
 525   pickup defaultpen;
 526   drawoptions();
 527   scantokens extra_beginfig;
 528 enddef;
 529
 530 def endfig =
 531   scantokens extra_endfig;
 532   shipit;
 533   endgroup
 534 enddef;
 535
 536
 537 %% last-minute items
 538
 539 vardef z@#=(x@#,y@#) enddef;
 540
 541 def clearxy = save x,y enddef;
 542 def clearit = currentpicture:=nullpicture enddef;
 543 def shipit = shipout currentpicture enddef;
 544
 545 let bye = end; outer end,bye;
 546
 547 clear_pen_memory;     % initialize the `savepen' mechanism
 548 clearit;
 549
 550 newinternal defaultpen;
 551 pickup pencircle scaled .5bp;  % set default line width
 552 defaultpen := savepen;