Source Browser ?

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