mp-base.mpiv /size: 21 Kb    last modification: 2021-10-28 13:50
1% This is a reformatted copy of the plain.mp file. We use a copy
2% because (1) we want to make sure that there are no unresolved
3% dependencies, and (2) we may patch this file eventually.
4
5% This file gives the macros for plain MetaPost It contains all the
6% features of plain METAFONT except those specific to font-making.
7% There are also a number of macros for labeling figures, etc.
8
9% For practical reasons I have moved some new code here (and might
10% remove some code as well). After all, there is no development in
11% this format.
12
13string base_name, base_version ;
14
15base_name    := "plain" ;
16base_version := "1.004 for metafun iv and xl"  ;
17
18message "loading metafun, including plain.mp version " & base_version ;
19
20delimiters () ; % this makes parentheses behave like parentheses
21
22def upto   = step  1 until enddef ;
23def downto = step -1 until enddef ;
24
25def exitunless expr c =
26    exitif not c
27enddef ;
28
29let relax = \ ; % ignore the word relax, as in TeX
30let \\    = \ ; % double relaxation is like single
31
32def [[ = [ [ enddef ;
33def ]] = ] ] enddef ;
34
35def -- =
36    {curl 1} .. {curl 1}
37enddef ;
38
39def --- =
40    .. tension infinity ..
41enddef ;
42
43def ... =
44    .. tension atleast 1 ..
45enddef ;
46
47def gobble primary g =
48enddef ;
49
50primarydef g gobbled gg =
51enddef ;
52
53def hide(text t) =
54    exitif numeric begingroup t ; endgroup ;
55enddef ;
56
57def ??? =
58    hide (
59        interim showstopping := 1 ;
60        showdependencies
61    )
62enddef ;
63
64def stop expr s =
65    message s ;
66    gobble readstring
67enddef ;
68
69warningcheck     := 1 ;
70tracinglostchars := 1 ;
71
72def interact = % sets up to make "show" commands stop
73    hide (
74        showstopping  := 1 ;
75        tracingonline := 1 ;
76    )
77enddef ;
78
79def loggingall = % puts tracing info into the log
80    tracingcommands  := 3 ;
81    tracingtitles    := 1 ;
82    tracingequations := 1 ;
83    tracingcapsules  := 1 ;
84    tracingspecs     := 2 ;
85    tracingchoices   := 1 ;
86    tracinglostchars := 1 ;
87    tracingstats     := 1 ;
88    tracingmacros    := 1 ;
89    tracingrestores  := 1 ;
90enddef ;
91
92def tracingall = % turns on every form of tracing
93    tracingonline := 1 ;
94    showstopping  := 1 ;
95    loggingall ;
96enddef ;
97
98def tracingnone = % turns off every form of tracing
99    tracingcommands  := 0 ;
100    tracingtitles    := 0 ;
101    tracingequations := 0 ;
102    tracingcapsules  := 0 ;
103    tracingspecs     := 0 ;
104    tracingchoices   := 0 ;
105    tracinglostchars := 0 ;
106    tracingstats     := 0 ;
107    tracingmacros    := 0 ;
108    tracingrestores  := 0 ;
109enddef ;
110
111%% dash patterns
112
113vardef dashpattern(text t) =
114    save on, off, w ;
115    let on = _on_ ;
116    let off = _off_ ;
117    w = 0 ;
118    nullpicture t
119enddef ;
120
121tertiarydef p _on_ d =
122    begingroup save pic ;
123        picture pic;
124        pic = p ;
125        addto pic doublepath (w,w) .. (w+d,w) ;
126        w := w + d ;
127        pic shifted (0,d)
128    endgroup
129enddef ;
130
131tertiarydef p _off_ d =
132    begingroup w := w + d ;
133        p shifted (0,d)
134    endgroup
135enddef ;
136
137%% basic constants and mathematical macros
138
139% numeric constants
140
141newinternal eps, epsilon, infinity, _ ;
142
143eps      := .00049 ;      % this is a pretty small positive number
144epsilon  := 1/256/256 ;   % but this is the smallest
145infinity := 4095.99998 ;  % and this is the largest
146_        := -1 ;          % internal constant to make macros unreadable but shorter
147
148% linejoin and linecap types
149
150newinternal mitered, rounded, beveled, butt, squared ;
151
152mitered := 0 ; rounded := 1 ; beveled := 2 ;
153butt    := 0 ; rounded := 1 ; squared := 2 ;
154
155% pair constants
156
157pair right, left, up, down, origin;
158
159origin = (0,0) ;
160up     = -down = (0,1) ;
161right  = -left = (1,0) ;
162
163% path constants
164
165path quartercircle, halfcircle, fullcircle, unitsquare ;
166
167fullcircle    = makepath pencircle ;
168halfcircle    = subpath (0,4) of fullcircle ;
169quartercircle = subpath (0,2) of fullcircle ;
170unitsquare    = (0,0) -- (1,0) -- (1,1) -- (0,1) -- cycle ;
171
172% transform constants
173
174transform identity ;
175
176for z=origin,right,up :
177    z transformed identity = z ;
178endfor
179
180% color constants (all in rgb color space)
181
182color black, white, red, green, blue, cyan, magenta, yellow, background;
183
184black      := (0,0,0) ;
185white      := (1,1,1) ;
186red        := (1,0,0) ;
187green      := (0,1,0) ;
188blue       := (0,0,1) ;
189cyan       := (0,1,1) ;
190magenta    := (1,0,1) ;
191yellow     := (1,1,0) ;
192
193background := white ; % obsolete
194
195let graypart  = greypart ;
196let greycolor = numeric ;
197let graycolor = numeric ;
198
199% color part (will be overloaded)
200
201newinternal nocolormodel   ; nocolormodel   := 1 ;
202newinternal greycolormodel ; greycolormodel := 3 ;
203newinternal graycolormodel ; graycolormodel := 3 ;
204newinternal rgbcolormodel  ; rgbcolormodel  := 5 ;
205newinternal cmykcolormodel ; cmykcolormodel := 7 ;
206
207def colorpart primary t =
208    if colormodel t = cmykcolormodel:
209        (cyanpart t, magentapart t, yellowpart t, blackpart t)
210    elseif colormodel t = rgbcolormodel :
211        (redpart t, greenpart t, bluepart t)
212    elseif colormodel t = graycolormodel :
213        (greypart t)
214    elseif colormodel t = nocolormodel :
215        false
216    elseif defaultcolormodel = cmykcolormodel :
217        (0,0,0,1)
218    elseif defaultcolormodel = rgbcolormodel :
219        black
220    elseif defaultcolormodel = graycolormodel :
221        0
222    else :
223        false
224    fi
225enddef ;
226
227% picture constants
228
229picture blankpicture, evenly, withdots ;
230
231blankpicture = nullpicture ;                       % display blankpicture...
232evenly       = dashpattern(on 3 off 3) ;           % dashed evenly
233withdots     = dashpattern(off 2.5 on 0 off 2.5) ; % dashed withdots
234
235% string constants
236
237string ditto, EOF ;
238
239ditto = char 34 ; % ASCII double-quote mark
240EOF   = char  0 ; % end-of-file for readfrom and write..to
241
242% pen constants
243
244pen pensquare, penrazor, penspec ;
245
246pensquare = makepen(unitsquare shifted -(.5,.5)) ;
247penrazor  = makepen((-.5,0) -- (.5,0) -- cycle) ;
248penspec   = pensquare scaled eps ;
249
250def penspeck = penspec enddef ;
251
252% nullary operators
253
254vardef whatever =
255    save ? ;
256    ?
257enddef ;
258
259% unary operators (with patched round)
260
261let abs = length ;
262
263vardef round primary u =
264    if numeric u :
265        floor(u+.5)
266    elseif pair u :
267        (floor(xpart u+.5), floor(ypart u+.5))
268    elseif path u :
269        % added by HH
270        for i=0 upto length u-1 :
271            round(point i of u) ..
272            controls round(postcontrol i of u) and round(precontrol i+1 of u) ..
273        endfor
274        if cycle u : cycle else : point infinity of u fi
275    else :
276        u
277    fi
278enddef ;
279
280vardef ceiling primary x =
281    -floor(-x)
282enddef ;
283
284vardef byte primary s =
285    if string s :
286        ASCII
287    fi s
288enddef ;
289
290vardef dir primary d =
291    right rotated d
292enddef ;
293
294vardef unitvector primary z =
295    z/abs z
296enddef ;
297
298vardef inverse primary T =
299    transform T_ ;
300    T_ transformed T = identity ;
301    T_
302enddef ;
303
304vardef counterclockwise primary c =
305    if turningnumber c <= 0 :
306        reverse
307    fi c
308enddef ;
309
310vardef tensepath expr r =
311    for k=0 upto length r - 1 :
312        point k of r ---
313    endfor
314    if cycle r :
315        cycle
316    else :
317        point infinity of r
318    fi
319enddef ;
320
321vardef center primary p =
322    .5[llcorner p, urcorner p]
323enddef ;
324
325% binary operators
326
327primarydef x mod y =
328    (x-y*floor(x/y))
329enddef ;
330
331primarydef x div y =
332    floor(x/y)
333enddef ;
334
335primarydef w dotprod z =
336    (xpart w * xpart z + ypart w * ypart z)
337enddef ;
338
339% primarydef x**y =
340%     if y = 2 :
341%         x*x
342%     else :
343%         takepower y of x
344%     fi
345% enddef ;
346%
347% def takepower expr y of x =
348%     if x>0 :
349%         mexp(y*mlog x)
350%     elseif (x=0) and (y>0) :
351%         0
352%     else :
353%         1
354%         if y = floor y :
355%             if y >= 0 :
356%                 for n=1 upto y :
357%                     *x
358%                 endfor
359%             else :
360%                 for n=-1 downto y :
361%                     /x
362%                 endfor
363%             fi
364%         else :
365%             hide(errmessage "Undefined power: " & decimal x & "**" & decimal y)
366%         fi
367%     fi
368% enddef ;
369
370% for big number systems:
371
372primarydef x**y =
373    if y = 0 :
374        1
375    elseif x = 0 :
376        0
377    elseif y < 0 :
378        1/(x**-y)
379    elseif y = 1 :
380        x
381    elseif y = 2 :
382        x*x
383    elseif y = 3 :
384        x*x*x
385    else :
386        takepower y of x
387    fi
388enddef ;
389
390def takepower expr y of x =
391    if y=0 : % isn't x**0 = 1 even if x=0 ?
392        1
393    elseif x=0 :
394        0
395    else :
396        if y = floor y :
397            1
398            if y >= 0 :
399                for n=1 upto y :
400                    *x
401                endfor
402            else :
403                for n=-1 downto y :
404                    /x
405                endfor
406            fi
407        elseif x>0 :
408            mexp(y*mlog x)
409        else :
410            -mexp(y*mlog -x)
411        fi
412    fi
413enddef ;
414
415vardef direction expr t of p =
416    postcontrol t of p - precontrol t of p
417enddef ;
418
419vardef directionpoint expr z of p =
420    a_ := directiontime z of p ;
421    if a_ < 0 :
422        errmessage("The direction doesn't occur") ;
423    fi
424    point a_ of p
425enddef ;
426
427secondarydef p intersectionpoint q =
428    begingroup
429    save x_, y_ ;
430    (x_,y_) = p intersectiontimes q ;
431    if x_ < 0 :
432        errmessage("The paths don't intersect") ;
433        origin
434    else :
435        .5[point x_ of p, point y_ of q]
436    fi
437    endgroup
438enddef ;
439
440tertiarydef p softjoin q =
441    begingroup
442    c_ := fullcircle scaled 2join_radius shifted point 0 of q ;
443    a_ := ypart(c_ intersectiontimes p) ;
444    b_ := ypart(c_ intersectiontimes q) ;
445    if a_ < 0 :
446        point 0 of p{direction 0 of p}
447    else :
448        subpath(0,a_) of p
449    fi
450    ...
451    if b_ < 0 :
452        {direction infinity of q} point infinity of q
453    else :
454        subpath(b_,infinity) of q
455    fi
456    endgroup
457enddef ;
458
459newinternal join_radius, a_, b_ ; path c_ ;
460
461path cuttings ; % what got cut off
462
463tertiarydef a cutbefore b =  % tries to cut as little as possible
464    begingroup
465    save t ;
466    (t, whatever) = a intersectiontimes b ;
467    if t < 0 :
468        cuttings := point 0 of a ;
469        a
470    else :
471        cuttings := subpath (0,t) of a ;
472        subpath (t,length a) of a
473    fi
474    endgroup
475enddef ;
476
477tertiarydef a cutafter b =
478    reverse (reverse a  cutbefore  b)
479    hide(cuttings := reverse cuttings)
480enddef ;
481
482% special operators
483
484vardef incr suffix $ = $ := $ + 1 ; $ enddef ;
485vardef decr suffix $ = $ := $ - 1 ; $ enddef ;
486
487def reflectedabout(expr w,z) = % reflects about the line w..z
488    transformed
489        begingroup
490        transform T_ ;
491        w transformed T_ = w ;
492        z transformed T_ = z ;
493        xxpart T_ = -yypart T_ ;
494        xypart T_ =  yxpart T_ ; % T_ is a reflection
495        T_
496        endgroup
497enddef ;
498
499def rotatedaround(expr z, d) = % rotates d degrees around z
500    shifted -z rotated d shifted z
501enddef ;
502
503let rotatedabout = rotatedaround ; % for roundabout people
504
505vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings
506    save u_ ;
507    setu_ u ;
508    for uu = t :
509        if uu < u_ :
510            u_ := uu ;
511        fi
512    endfor
513    u_
514enddef ;
515
516vardef max(expr u)(text t) = % t is a list of numerics, pairs, or strings
517    save u_ ;
518    setu_ u ;
519    for uu = t :
520        if uu > u_ :
521            u_ := uu ;
522        fi
523    endfor
524    u_
525enddef ;
526
527def setu_ primary u =
528    if pair u :
529        pair u_
530    elseif string u :
531        string u_
532    fi ;
533    u_=u
534enddef ;
535
536def flex(text t) = % t is a list of pairs
537    hide (
538        n_ := 0 ;
539        for z=t :
540            z_[incr n_] := z ;
541        endfor
542        dz_ := z_[n_]-z_1
543    )
544    z_1 for k=2 upto n_-1 :
545        ... z_[k]{dz_}
546    endfor ... z_[n_]
547enddef ;
548
549newinternal n_; pair z_[],dz_;
550
551def superellipse(expr r,t,l,b,s) =
552    r { up    } ... (s[xpart t,xpart r],s[ypart r,ypart t]) { t-r } ...
553    t { left  } ... (s[xpart t,xpart l],s[ypart l,ypart t]) { l-t } ...
554    l { down  } ... (s[xpart b,xpart l],s[ypart l,ypart b]) { b-l } ...
555    b { right } ... (s[xpart b,xpart r],s[ypart r,ypart b]) { r-b } ... cycle enddef ;
556
557vardef interpath(expr a,p,q) =
558    for t=0 upto length p-1 :
559        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] ..
560    endfor
561    if cycle p :
562        cycle
563    else :
564        a[point infinity of p, point infinity of q]
565    fi
566enddef ;
567
568vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false
569    tx_:=true_x; fx_:=false_x;
570    forever :
571        x_ := .5[tx_,fx_] ;
572        exitif abs(tx_-fx_) <= tolerance ;
573        if @#(x_) :
574            tx_
575        else :
576            fx_
577        fi := x_ ;
578    endfor
579    x_  % now x_ is near where @# changes from true to false
580enddef ;
581
582newinternal tolerance, tx_, fx_, x_ ;
583
584tolerance := .01 ;
585
586vardef buildcycle(text ll) =
587    save ta_, tb_, k_, i_, pp_ ; path pp_[] ;
588    k_ = 0 ;
589    for q=ll :
590        pp_[incr k_] = q ;
591    endfor
592    i_ = k_ ;
593    for i=1 upto k_ :
594        (ta_[i], length pp_[i_]-tb_[i_]) = pp_[i] intersectiontimes reverse pp_[i_] ;
595        if ta_[i]<0 :
596          errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect") ;
597        fi
598        i_ := i;
599    endfor
600    for i=1 upto k_ :
601        subpath (ta_[i],tb_[i]) of pp_[i] ..
602    endfor
603    cycle
604enddef ;
605
606%% units of measure
607
608mm :=  2.83464 ;
609pt :=  0.99626 ;
610dd :=  1.06601 ;
611bp :=  1 ;
612cm := 28.34645 ;
613pc := 11.95517 ;
614cc := 12.79213 ;
615in := 72 ;
616
617vardef magstep primary m = % obsolete
618    mexp(46.67432m)
619enddef ;
620
621%% macros for drawing and filling
622
623def drawoptions(text t) =
624    def _op_ = t enddef
625enddef ;
626
627% parameters that effect drawing
628
629linejoin   := rounded ;
630linecap    := rounded ;
631miterlimit := 10 ;
632
633drawoptions() ;
634
635pen currentpen ;
636picture currentpicture ;
637
638def fill expr c =
639    addto currentpicture contour c _op_
640enddef ;
641
642def draw expr p =
643    addto currentpicture
644    if picture p :
645        also p
646    else :
647        doublepath p withpen currentpen
648    fi
649    _op_
650enddef ;
651
652def filldraw expr c =
653    addto currentpicture contour c withpen currentpen _op_
654enddef ;
655
656% def drawdot expr z =
657%     addto currentpicture contour makepath currentpen shifted z _op_
658% enddef ;
659%
660% testcase DEK:
661%
662% for j=1 upto 9 :
663%     pickup pencircle xscaled .4 yscaled .2 ;
664%     drawdot (10j,0) withpen pencircle xscaled .5j yscaled .25j rotated 45 ;
665%     pickup pencircle xscaled .5j yscaled .25j rotated 45 ;
666%     drawdot (10j,10);
667% endfor ;
668%
669% or:
670%
671%\startMPpage
672%
673% def drawdot expr z =
674%     addto currentpicture contour (makepath currentpen shifted z) _op_
675% enddef;
676%
677% drawdot origin shifted (0,-3cm) withpen pencircle scaled 2cm ;
678% pickup pencircle scaled 2cm ; drawdot origin withcolor red ;
679
680def drawdot expr p =
681    if pair p :
682        addto currentpicture doublepath p withpen currentpen _op_
683    else :
684        errmessage("drawdot only accepts a pair expression")
685    fi
686enddef ;
687
688def unfill     expr c = fill     c withcolor background enddef ;
689def undraw     expr p = draw     p withcolor background enddef ;
690def unfilldraw expr c = filldraw c withcolor background enddef ;
691def undrawdot  expr z = drawdot  z withcolor background enddef ;
692
693def erase text t =
694    def _e_ =
695        withcolor background hide(def _e_ = enddef ;)
696    enddef ;
697    t _e_
698enddef ;
699
700def _e_ = enddef ;
701
702def cutdraw text t =
703    begingroup
704        interim linecap := butt ;
705        draw t _e_ ;
706    endgroup
707enddef ;
708
709vardef image(text t) =
710    save currentpicture ;
711    picture currentpicture ;
712    currentpicture := nullpicture ;
713    t ;
714    currentpicture
715enddef ;
716
717def pickup secondary q =
718    if numeric q :
719        numeric_pickup_
720    else :
721        pen_pickup_
722    fi q
723enddef ;
724
725def numeric_pickup_ primary q =
726    if unknown pen_[q] :
727        errmessage "Unknown pen" ;
728        clearpen
729    else :
730        currentpen := pen_ [q] ;
731        pen_lft := pen_lft_[q] ;
732        pen_rt  := pen_rt_ [q] ;
733        pen_top := pen_top_[q] ;
734        pen_bot := pen_bot_[q] ;
735        currentpen_path := pen_path_[q]
736    fi ;
737enddef ;
738
739def pen_pickup_ primary q =
740    currentpen := q ;
741    pen_lft := xpart penoffset down  of currentpen ;
742    pen_rt  := xpart penoffset up    of currentpen ;
743    pen_top := ypart penoffset left  of currentpen ;
744    pen_bot := ypart penoffset right of currentpen ;
745    path currentpen_path ;
746enddef ;
747
748newinternal pen_lft, pen_rt, pen_top, pen_bot, pen_count_ ;
749
750vardef savepen =
751    pen_[incr pen_count_] = currentpen ;
752    pen_lft_ [pen_count_] = pen_lft ;
753    pen_rt_  [pen_count_] = pen_rt ;
754    pen_top_ [pen_count_] = pen_top ;
755    pen_bot_ [pen_count_] = pen_bot ;
756    pen_path_[pen_count_] = currentpen_path ;
757    pen_count_
758enddef ;
759
760def clearpen =
761    currentpen := nullpen;
762    pen_lft := pen_rt := pen_top := pen_bot := 0 ;
763    path currentpen_path ;
764enddef ;
765
766def clear_pen_memory =
767    pen_count_ := 0 ;
768    numeric pen_lft_[], pen_rt_[], pen_top_[], pen_bot_[] ;
769    pen currentpen, pen_[];
770    path currentpen_path, pen_path_[] ;
771enddef ;
772
773vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef ;
774vardef rt  primary x = x + if pair x: (pen_rt,0)  else: pen_rt  fi enddef ;
775vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef ;
776vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef ;
777
778vardef penpos@#(expr b,d) =
779    (x@#r-x@#l,y@#r-y@#l) = (b,0) rotated d ;
780    x@# = .5(x@#l+x@#r) ;
781    y@# = .5(y@#l+y@#r) ; % ; added HH
782enddef ;
783
784path path_.l, path_.r ;
785
786def penstroke text t =
787    forsuffixes e = l, r :
788        path_.e := t ;
789    endfor
790    fill path_.l -- reverse path_.r -- cycle
791enddef ;
792
793%% High level drawing commands
794
795newinternal ahlength, ahangle ;
796
797ahlength :=  4 ; % default arrowhead length 4bp
798ahangle  := 45 ; % default head angle 45 degrees
799
800vardef arrowhead expr p =
801    save q, e ; path q ; pair e ;
802    e = point length p of p ;
803    q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) cuttings ;
804    (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e
805enddef ;
806
807path _apth ;
808
809def drawarrow    expr p = _apth := p ; _finarr  enddef ;
810def drawdblarrow expr p = _apth := p ; _findarr enddef ;
811
812def _finarr text t =
813    draw _apth t ;
814    filldraw arrowhead _apth t
815enddef ;
816
817def _findarr text t = % this had fill in 0.63 (potential incompatibility)
818    draw _apth t ;
819    filldraw arrowhead         _apth withpen currentpen t ;
820    filldraw arrowhead reverse _apth withpen currentpen t ; % ; added HH
821enddef ;
822
823%% macros for labels
824
825newinternal bboxmargin ;
826
827bboxmargin := 2bp ; % this can bite you, just don't use it in \METAFUN
828
829vardef bbox primary p =
830    llcorner p - ( bboxmargin, bboxmargin) --
831    lrcorner p + ( bboxmargin,-bboxmargin) --
832    urcorner p + ( bboxmargin, bboxmargin) --
833    ulcorner p + (-bboxmargin, bboxmargin) -- cycle
834enddef ;
835
836string defaultfont ; newinternal defaultscale, labeloffset ;
837
838defaultfont  := "cmr10" ;
839defaultscale := 1 ;
840labeloffset  := 3bp ;
841
842vardef thelabel@#(expr s,z) = % Position s near z
843    save p ; picture p ;
844    if picture s :
845        p = s
846    else :
847        p = s infont defaultfont scaled defaultscale
848    fi ;
849    p shifted (z + labeloffset*laboff@# - ( labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p) )
850enddef ;
851
852def label =
853    draw thelabel
854enddef ;
855
856newinternal dotlabeldiam ;
857
858dotlabeldiam := 3bp ;
859
860vardef dotlabel@#(expr s,z) text t_ =
861    label@#(s,z) t_ ;
862  % label@#(s,z) ;
863    interim linecap := rounded ;
864    draw z withpen pencircle scaled dotlabeldiam t_ ;
865enddef ;
866
867def makelabel =
868    dotlabel
869enddef ;
870
871% this will be overloaded
872
873pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot ;
874pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt ;
875
876laboff      = (0,0)    ; labxf      = .5 ; labyf      = .5 ;
877laboff.lft  = (-1,0)   ; labxf.lft  = 1  ; labyf.lft  = .5 ;
878laboff.rt   = (1,0)    ; labxf.rt   = 0  ; labyf.rt   = .5 ;
879laboff.bot  = (0,-1)   ; labxf.bot  = .5 ; labyf.bot  = 1  ;
880laboff.top  = (0,1)    ; labxf.top  = .5 ; labyf.top  = 0  ;
881laboff.ulft = (-.7,.7) ; labxf.ulft = 1  ; labyf.ulft = 0  ;
882laboff.urt  = (.7,.7)  ; labxf.urt  = 0  ; labyf.urt  = 0  ;
883laboff.llft = -(.7,.7) ; labxf.llft = 1  ; labyf.llft = 1  ;
884laboff.lrt  = (.7,-.7) ; labxf.lrt  = 0  ; labyf.lrt  = 1  ;
885
886vardef labels@#(text t) =
887    forsuffixes $=t :
888        label@#(str$,z$) ;
889    endfor
890enddef ;
891
892% till lhere
893
894vardef dotlabels@#(text t) =
895    forsuffixes $=t:
896        dotlabel@#(str$,z$) ;
897    endfor
898enddef ;
899
900vardef penlabels@#(text t) =
901    forsuffixes $$=l,,r :
902        forsuffixes $=t :
903            makelabel@#(str$.$$,z$.$$) ;
904        endfor
905    endfor
906enddef ;
907
908% range 4 thru 10
909
910def range expr x =
911    _numtok_[x]
912enddef ;
913
914def _numtok_ suffix x =
915    x
916enddef ;
917
918tertiarydef m thru n =
919    m for x=m+1 step 1 until n :
920        , _numtok_[x]
921    endfor
922enddef ;
923
924%% Overall administration
925
926string extra_beginfig, extra_endfig ;
927
928extra_beginfig := "" ;
929extra_endfig   := "" ;
930
931boolean makingfigure ; makingfigure := false ;
932numeric stacking ; stacking := 0 ;
933
934def beginfig(expr c) = % redefined in mp-grph !
935    begingroup
936    save makingfigure ; boolean makingfigure ;
937    save stacking ; numeric stacking;
938    charcode := c ;
939    clearxy ;
940    clearit ;
941    clearpen ;
942    pickup defaultpen ;
943    drawoptions() ;
944    stacking := 0 ;
945    makingfigure := true;
946    scantokens extra_beginfig ;
947enddef ;
948
949def endfig =
950    ; % added by HH
951    scantokens extra_endfig ;
952    shipit ;
953    endgroup
954enddef ;
955
956%% last-minute items
957
958vardef z@# =
959    (x@#,y@#)
960enddef ;
961
962def clearxy =
963    save x, y
964enddef ;
965
966def clearit =
967    currentpicture := nullpicture
968enddef ;
969
970def shipit =
971    shipout currentpicture
972enddef ;
973
974let bye = end ;
975outer end, bye ;
976
977clear_pen_memory ; % initialize the savepen mechanism
978clearit ;
979
980% set default line width
981
982newinternal defaultpen ;
983
984pickup pencircle scaled .5bp ;
985
986defaultpen := savepen ;
987