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    else :
293        u
294    fi
295enddef ;
296
297vardef ceiling primary x =
298    -floor(-x)
299enddef ;
300
301vardef byte primary s =
302    if string s :
303        ASCII
304    fi s
305enddef ;
306
307vardef dir primary d =
308    right rotated d
309enddef ;
310
311vardef unitvector primary z =
312    z/abs z
313enddef ;
314
315vardef inverse primary t =
316    transform temp_transform ;
317    temp_transform transformed t = identity ;
318    temp_transform
319enddef ;
320
321vardef counterclockwise primary c =
322    if turningnumber c <= 0 :
323        reverse
324    fi c
325enddef ;
326
327vardef tensepath expr r =
328    for k=0 upto length r - 1 :
329        point k of r ---
330    endfor
331    if cycle r :
332        cycle
333    else :
334        point infinity of r
335    fi
336enddef ;
337
338vardef center primary p =
339    .5[llcorner p, urcorner p]
340enddef ;
341
342permanent abs, round, ceiling, byte, dir, unitvector, inverse, counterclockwise, tensepath, center ;
343
344% binary operators
345
346primarydef x mod y =
347    (x-y*floor(x/y))
348enddef ;
349
350primarydef x div y =
351    floor(x/y)
352enddef ;
353
354primarydef w dotprod z =
355    (xpart w * xpart z + ypart w * ypart z)
356enddef ;
357
358permanent mod, div, dotprod ;
359
360% primarydef x**y =
361%     if y = 2 :
362%         x*x
363%     else :
364%         takepower y of x
365%     fi
366% enddef ;
367%
368% def takepower expr y of x =
369%     if x>0 :
370%         mexp(y*mlog x)
371%     elseif (x=0) and (y>0) :
372%         0
373%     else :
374%         1
375%         if y = floor y :
376%             if y >= 0 :
377%                 for n=1 upto y :
378%                     *x
379%                 endfor
380%             else :
381%                 for n=-1 downto y :
382%                     /x
383%                 endfor
384%             fi
385%         else :
386%             hide(errmessage "Undefined power: " & decimal x & "**" & decimal y)
387%         fi
388%     fi
389% enddef ;
390
391% for big number systems:
392
393primarydef x**y =
394    if     y = 0 : 1
395    elseif x = 0 : 0
396    elseif y < 0 : 1/(x**-y)
397    elseif y = 1 : x
398    elseif y = 2 : x*x
399    elseif y = 3 : x*x*x
400    else         : takepower y of x
401    fi
402enddef ;
403
404def takepower expr y of x =
405    if y=0 : % isn't x**0 = 1 even if x=0 ?
406        1
407    elseif x=0 :
408        0
409    else :
410        if y = floor y :
411            1
412            if y >= 0 :
413                for n=1 upto y :
414                    *x
415                endfor
416            else :
417                for n=-1 downto y :
418                    /x
419                endfor
420            fi
421        elseif x > 0 :
422            mexp(y*mlog x)
423        else :
424            -mexp(y*mlog -x)
425        fi
426    fi
427enddef ;
428
429permanent **, takepower ;
430
431newinternal temp_internal_a, temp_internal_b ;
432newinternal temp_numeric_x, temp_numeric_y ;
433newinternal temp_internal_tx, temp_internal_ty, temp_internal_fx, temp_internal_fy ;
434newinternal temp_internal_n ;
435path        temp_path_a, temp_path_b ;
436pair        temp_pair_dz, temp_pair_z[] ;
437
438vardef direction expr t of p =
439    postcontrol t of p - precontrol t of p
440enddef ;
441
442vardef directionpoint expr z of p =
443    temp_internal_a := directiontime z of p ;
444    if temp_internal_a < 0 :
445        errmessage("The direction doesn't occur") ;
446    fi
447    point temp_internal_a of p
448enddef ;
449
450secondarydef p intersectionpoint q =
451    begingroup
452    save temp_numeric_x, temp_numeric_y ;
453    (temp_numeric_x,temp_numeric_y) = p intersectiontimes q ;
454    if temp_numeric_x < 0 :
455        errmessage("The paths don't intersect") ;
456        origin
457    else :
458        .5[point temp_numeric_x of p, point temp_numeric_y of q]
459    fi
460    endgroup
461enddef ;
462
463tertiarydef p softjoin q =
464    begingroup
465    temp_path_a := fullcircle scaled 2join_radius shifted point 0 of q ;
466    temp_internal_a := ypart(temp_path_a intersectiontimes p) ;
467    temp_internal_b := ypart(temp_path_a intersectiontimes q) ;
468    if temp_internal_a < 0 :
469        point 0 of p {direction 0 of p}
470    else :
471        subpath(0,temp_internal_a) of p
472    fi
473    ...
474    if temp_internal_b < 0 :
475        {direction infinity of q} point infinity of q
476    else :
477        subpath(temp_internal_b,infinity) of q
478    fi
479    endgroup
480enddef ;
481
482permanent direction, directionpoint, intersectionpoint, softjoin ;
483
484newinternal join_radius ;
485path cuttings ; % what got cut off
486
487tertiarydef a cutbefore b =  % tries to cut as little as possible
488    begingroup
489    save t ;
490    (t, whatever) = a intersectiontimes b ;
491    if t < 0 :
492        cuttings := point 0 of a ;
493        a
494    else :
495        cuttings := subpath (0,t) of a ;
496        subpath (t,length a) of a
497    fi
498    endgroup
499enddef ;
500
501tertiarydef a cutafter b =
502    reverse (reverse a  cutbefore  b)
503    hide(cuttings := reverse cuttings)
504enddef ;
505
506permanent join_radius, cuttings, cutbefore, cutafter ;
507
508% special operators
509
510vardef incr suffix $ = $ := $ + 1 ; $ enddef ;
511vardef decr suffix $ = $ := $ - 1 ; $ enddef ;
512
513permanent incr, decr ;
514
515def reflectedabout(expr w,z) = % reflects about the line w..z
516    transformed
517        begingroup
518        transform temp_transform ;
519        w transformed temp_transform = w ;
520        z transformed temp_transform = z ;
521        xxpart temp_transform = -yypart temp_transform ;
522        xypart temp_transform =  yxpart temp_transform ; % temp_transform is a reflection
523        temp_transform
524        endgroup
525enddef ;
526
527def rotatedaround(expr z, d) = % rotates d degrees around z
528    shifted -z rotated d shifted z
529enddef ;
530
531let rotatedabout = rotatedaround ; % for roundabout people
532
533permanent reflectedabout, rotatedaround, rotatedabout ;
534
535vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings
536    save temp_any_u ;
537    if pair u :
538        pair temp_any_u
539    elseif string u :
540        string temp_any_u
541    fi ;
542    temp_any_u := u ;
543    for i = t :
544        if i < temp_any_u :
545            temp_any_u := i ;
546        fi
547    endfor
548    temp_any_u
549enddef ;
550
551vardef max(expr u)(text t) = % t is a list of numerics, pairs, or strings
552    save temp_any_u ;
553    if pair u :
554        pair temp_any_u
555    elseif string u :
556        string temp_any_u
557    fi ;
558    temp_any_u := u ;
559    for i = t :
560        if i > temp_any_u :
561            temp_any_u := i ;
562        fi
563    endfor
564    temp_any_u
565enddef ;
566
567def flex(text t) = % t is a list of pairs
568    hide (
569        temp_internal_n := 0 ;
570        for z=t :
571            temp_pair_z[incr temp_internal_n] := z ;
572        endfor
573        temp_pair_dz := temp_pair_z[temp_internal_n]-temp_pair_z[1]
574    )
575    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]
576enddef ;
577
578permanent min, max, flex ;
579
580def superellipse(expr r, t, l, b, s) =
581    r { up    } ... (s[xpart t,xpart r],s[ypart r,ypart t]) { t-r } ...
582    t { left  } ... (s[xpart t,xpart l],s[ypart l,ypart t]) { l-t } ...
583    l { down  } ... (s[xpart b,xpart l],s[ypart l,ypart b]) { b-l } ...
584    b { right } ... (s[xpart b,xpart r],s[ypart r,ypart b]) { r-b } ... cycle enddef ;
585
586vardef interpath(expr a,p,q) =
587    for t=0 upto length p-1 :
588        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] ..
589    endfor
590    if cycle p :
591        cycle
592    else :
593        a[point infinity of p, point infinity of q]
594    fi
595enddef ;
596
597permanent superellipse, interpath ;
598
599newinternal tolerance ; tolerance := .01 ;
600
601vardef solve@#(expr t, f)= % @#(t)=true, @#(f)=false
602    temp_internal_tx := t;
603    temp_internal_fx := f;
604    forever :
605        temp_numeric_x := .5[temp_internal_tx,temp_internal_fx] ;
606        exitif abs(temp_internal_tx - temp_internal_fx) <= tolerance ;
607        if @#(temp_numeric_x) :
608            temp_internal_tx
609        else :
610            temp_internal_fx
611        fi := temp_numeric_x ;
612    endfor
613    temp_numeric_x  % now temp_numeric_x is near where @# changes from true to false
614enddef ;
615
616vardef buildcycle(text ll) =
617    save temp_a, temp_b, temp_k, temp_i, temp_p ; path temp_p[] ;
618    temp_k = 0 ;
619    for q=ll :
620        temp_p[incr temp_k] = q ;
621    endfor
622    temp_i = temp_k ;
623    for i=1 upto temp_k :
624        (temp_a[i], length temp_p[temp_i]-temp_b[temp_i]) = temp_p[i] intersectiontimes reverse temp_p[temp_i] ;
625        if temp_a[i]<0 :
626            errmessage("Paths "& decimal i &" and "& decimal temp_i &" don't intersect") ;
627        fi
628        temp_i := i;
629    endfor
630    for i=1 upto temp_k :
631        subpath (temp_a[i],temp_b[i]) of temp_p[i] ..
632    endfor
633    cycle
634enddef ;
635
636permanent interpath, solve, buildcycle, tolerance ;
637
638%% units of measure
639
640mm :=  2.83464 ;
641pt :=  0.99626 ;
642dd :=  1.06601 ; % 1.0660068107174
643bp :=  1 ;
644cm := 28.34645 ;
645pc := 11.95517 ;
646cc := 12.79213 ;
647in := 72 ;
648dk :=  6.41577 ; % 6.4157650704225 ;
649
650immutable mm, pt, bp, cm, in ; % we don't protect (yet): dd, pc cc (used as locals)
651
652% vardef magstep primary m = % obsolete
653%     mexp(46.67432m)
654% enddef ;
655
656%% macros for drawing and filling
657
658def drawoptions(text t) =
659    def base_draw_options = t enddef
660enddef ;
661
662% parameters that effect drawing
663
664linejoin   := rounded ;
665linecap    := rounded ;
666miterlimit := 10 ;
667
668drawoptions() ;
669
670pen currentpen ;
671picture currentpicture ;
672
673def fill expr c =
674    addto currentpicture contour c base_draw_options
675enddef ;
676
677def draw expr p =
678    addto currentpicture
679    if picture p :
680        also p
681    else :
682        doublepath p withpen currentpen
683    fi
684    base_draw_options
685enddef ;
686
687def filldraw expr c =
688    addto currentpicture contour c withpen currentpen base_draw_options
689enddef ;
690
691% def drawdot expr z =
692%     addto currentpicture contour makepath currentpen shifted z base_draw_options
693% enddef ;
694%
695% testcase DEK:
696%
697% for j=1 upto 9 :
698%     pickup pencircle xscaled .4 yscaled .2 ;
699%     drawdot (10j,0) withpen pencircle xscaled .5j yscaled .25j rotated 45 ;
700%     pickup pencircle xscaled .5j yscaled .25j rotated 45 ;
701%     drawdot (10j,10);
702% endfor ;
703%
704% or:
705%
706%\startMPpage
707%
708% def drawdot expr z =
709%     addto currentpicture contour (makepath currentpen shifted z) base_draw_options
710% enddef;
711%
712% drawdot origin shifted (0,-3cm) withpen pencircle scaled 2cm ;
713% pickup pencircle scaled 2cm ; drawdot origin withcolor red ;
714
715def drawdot expr p =
716    if pair p :
717        addto currentpicture doublepath p withpen currentpen base_draw_options
718    else :
719        errmessage("drawdot only accepts a pair expression")
720    fi
721enddef ;
722
723permanent drawoptions, currentpen, filldraw, drawdot ; % redefined later: fill, draw
724
725% permanent currentpicture; % not yet
726
727% Kind of obsolete:
728
729def unfill     expr c = fill     c withcolor background enddef ;
730def undraw     expr p = draw     p withcolor background enddef ;
731def unfilldraw expr c = filldraw c withcolor background enddef ;
732def undrawdot  expr z = drawdot  z withcolor background enddef ;
733
734def plain_erase = enddef ;
735
736def erase text t =
737    def plain_erase =
738        withcolor background hide(def plain_erase = enddef ;)
739    enddef ;
740    t plain_erase
741enddef ;
742
743def cutdraw text t =
744    begingroup
745        interim linecap := butt ;
746        draw t plain_erase ;
747    endgroup
748enddef ;
749
750permanent unfill, undraw, unfilldraw, undrawdot, erase, cutdraw ;
751
752% Popular:
753
754vardef image(text t) =
755    save currentpicture ;
756    picture currentpicture ;
757    currentpicture := nullpicture ;
758    t ;
759    currentpicture
760enddef ;
761
762permanent image ;
763
764def pickup secondary q =
765    if numeric q :
766        plain_pickup_numeric
767    else :
768        plain_pickup_path
769    fi q
770enddef ;
771
772% pens
773
774newinternal pen_lft, pen_rt, pen_top, pen_bot ;
775
776newinternal temp_pen_count ;
777path        temp_pen_result ;
778path        temp_pen_path.l, temp_pen_path.r ;
779numeric     temp_pen_l[], temp_pen_r[], temp_pen_t[], temp_pen_b[] ;
780pen         temp_pen_stack[] ;
781path        temp_pen_p[] ;
782
783pen         currentpen ;
784
785temp_pen_count := 0 ;
786
787def plain_pickup_numeric primary q =
788    if unknown temp_pen_stack[q] :
789        errmessage "Unknown pen" ;
790        clearpen
791    else :
792        currentpen := temp_pen_stack[q] ;
793        pen_lft := temp_pen_l[q] ;
794        pen_rt  := temp_pen_r[q] ;
795        pen_top := temp_pen_t[q] ;
796        pen_bot := temp_pen_b[q] ;
797        temp_pen_result := temp_pen_p[q]
798    fi ;
799enddef ;
800
801def plain_pickup_path primary q =
802    currentpen := q ;
803    pen_lft := xpart penoffset down  of currentpen ;
804    pen_rt  := xpart penoffset up    of currentpen ;
805    pen_top := ypart penoffset left  of currentpen ;
806    pen_bot := ypart penoffset right of currentpen ;
807    path temp_pen_result ;
808enddef ;
809
810vardef savepen =
811    temp_pen_stack[incr temp_pen_count] = currentpen ;
812    temp_pen_l[temp_pen_count] = pen_lft ;
813    temp_pen_r[temp_pen_count] = pen_rt ;
814    temp_pen_t[temp_pen_count] = pen_top ;
815    temp_pen_b[temp_pen_count] = pen_bot ;
816    temp_pen_p[temp_pen_count] = temp_pen_result ;
817    temp_pen_count
818enddef ;
819
820def clearpen =
821    currentpen := nullpen;
822    pen_lft := pen_rt := pen_top := pen_bot := 0 ;
823    path temp_pen_result ;
824enddef ;
825
826vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef ;
827vardef rt  primary x = x + if pair x: (pen_rt, 0) else: pen_rt  fi enddef ;
828vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef ;
829vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef ;
830
831vardef penpos@#(expr b,d) =
832    (x@#r-x@#l,y@#r-y@#l) = (b,0) rotated d ;
833    x@# = .5(x@#l+x@#r) ;
834    y@# = .5(y@#l+y@#r) ; % ; added HH
835enddef ;
836
837def penstroke text t =
838    forsuffixes e = l, r :
839        temp_pen_path.e := t ;
840    endfor
841    fill temp_pen_path.l -- reverse temp_pen_path.r -- cycle
842enddef ;
843
844permanent
845    pen_lft, pen_rt, pen_top, pen_bot,
846    lft, rt, top, bot,
847    pickup, penpos, clearpen, penstroke, savepen ;
848
849%% High level drawing commands
850
851newinternal ahlength, ahangle ;
852
853ahlength :=  4 ; % default arrowhead length 4bp
854ahangle  := 45 ; % default head angle 45 degrees
855
856path temp_arrow_path ;
857
858vardef arrowhead expr p =
859    save q, e ; path q ; pair e ;
860    e = point length p of p ;
861    q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) cuttings ;
862    (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e
863enddef ;
864
865def drawarrow    expr p = temp_arrow_path := p ; plain_arrow_finish enddef ;
866def drawdblarrow expr p = temp_arrow_path := p ; plain_arrow_find   enddef ;
867
868def plain_arrow_finish text t =
869    draw temp_arrow_path t ;
870    filldraw arrowhead temp_arrow_path t
871enddef ;
872
873def plain_arrow_find text t = % this had fill in 0.63 (potential incompatibility)
874    draw temp_arrow_path t ;
875    filldraw arrowhead         temp_arrow_path withpen currentpen t ;
876    filldraw arrowhead reverse temp_arrow_path withpen currentpen t ; % ; added HH
877enddef ;
878
879permanent ahlength, ahangle, arrowhead, drawarrow, drawdblarrow ;
880
881%% macros for labels
882
883newinternal bboxmargin ;
884
885bboxmargin := 2bp ; % this can bite you, just don't use it in \METAFUN
886
887vardef bbox primary p =
888    llcorner p - ( bboxmargin, bboxmargin) --
889    lrcorner p + ( bboxmargin,-bboxmargin) --
890    urcorner p + ( bboxmargin, bboxmargin) --
891    ulcorner p + (-bboxmargin, bboxmargin) -- cycle
892enddef ;
893
894permanent bboxmargin, bbox ;
895
896string defaultfont ; newinternal defaultscale, labeloffset, dotlabeldiam ;
897
898defaultfont  := "cmr10" ;
899defaultscale := 1 ;
900labeloffset  := 3bp ;
901dotlabeldiam := 3bp ;
902
903mutable defaultfont, defaultscale, labeloffset, dotlabeldiam ;
904
905vardef thelabel@#(expr s,z) = % Position s near z
906    save p ; picture p ;
907    if picture s :
908        p = s
909    else :
910        p = s infont defaultfont scaled defaultscale
911    fi ;
912    p shifted (z + labeloffset*laboff@# - ( labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p) )
913enddef ;
914
915def label =
916    draw thelabel
917enddef ;
918
919vardef dotlabel@#(expr s,z) text t =
920    label@#(s,z) t ;
921    interim linecap := rounded ;
922    draw z withpen pencircle scaled dotlabeldiam t ;
923enddef ;
924
925% def makelabel =
926%     dotlabel
927% enddef ;
928
929permanent label, dotlabel ;
930
931% this will be overloaded
932
933pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot ;
934pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt ;
935
936laboff      = (0,0)    ; labxf      = .5 ; labyf      = .5 ;
937laboff.lft  = (-1,0)   ; labxf.lft  = 1  ; labyf.lft  = .5 ;
938laboff.rt   = (1,0)    ; labxf.rt   = 0  ; labyf.rt   = .5 ;
939laboff.bot  = (0,-1)   ; labxf.bot  = .5 ; labyf.bot  = 1  ;
940laboff.top  = (0,1)    ; labxf.top  = .5 ; labyf.top  = 0  ;
941laboff.ulft = (-.7,.7) ; labxf.ulft = 1  ; labyf.ulft = 0  ;
942laboff.urt  = (.7,.7)  ; labxf.urt  = 0  ; labyf.urt  = 0  ;
943laboff.llft = -(.7,.7) ; labxf.llft = 1  ; labyf.llft = 1  ;
944laboff.lrt  = (.7,-.7) ; labxf.lrt  = 0  ; labyf.lrt  = 1  ;
945
946vardef labels@#(text t) =
947    forsuffixes $=t :
948        label@#(str$,z$) ;
949    endfor
950enddef ;
951
952% till lhere
953
954vardef dotlabels@#(text t) =
955    forsuffixes $=t:
956        dotlabel@#(str$,z$) ;
957    endfor
958enddef ;
959
960vardef penlabels@#(text t) =
961    forsuffixes $$=l,,r :
962        forsuffixes $=t :
963            dotlabel@#(str$.$$,z$.$$) ;
964        endfor
965    endfor
966enddef ;
967
968permanent dotlabels, penlabels ;
969
970% range 4 thru 10
971
972def plain_numtok suffix x =
973    x
974enddef ;
975
976def range expr x =
977    plain_numtok[x]
978enddef ;
979
980tertiarydef m thru n =
981    m for x=m+1 step 1 until n :
982        , plain_numtok[x]
983    endfor
984enddef ;
985
986permanent range, thru ;
987
988%% Overall administration
989
990% Todo: make an add to this helper thet temporarily disables warning
991
992string extra_beginfig, extra_endfig ;
993
994extra_beginfig := "" ;
995extra_endfig   := "" ;
996
997newinternal boolean makingfigure ; makingfigure := false ;
998
999def beginfig(expr c) = % redefined in mp-grph !
1000    begingroup
1001    charcode := c ;
1002    clearxy ;
1003    clearit ;
1004    clearpen ;
1005    pickup defaultpen ;
1006    drawoptions() ;
1007    interim stacking := 0 ;
1008    interim makingfigure := true;
1009    scantokens extra_beginfig ;
1010enddef ;
1011
1012def endfig =
1013    ; % added by HH
1014    scantokens extra_endfig ;
1015    shipit ;
1016    endgroup
1017enddef ;
1018
1019permanent
1020  % extra_beginfig, extra_endfig,
1021    beginfig, endfig ;
1022
1023%% last-minute items
1024
1025vardef z@# =
1026    (x@#,y@#)
1027enddef ;
1028
1029def clearxy =
1030    save x, y
1031enddef ;
1032
1033def clearit =
1034    currentpicture := nullpicture
1035enddef ;
1036
1037clearit ;
1038
1039permanent z, clearit ; % redefined: clearxy
1040
1041def shipit =
1042    shipout currentpicture
1043enddef ;
1044
1045let bye = end ;
1046outer end, bye ;
1047
1048permanent shipit, bye ;
1049
1050% set default line width
1051
1052newinternal defaultpen ;
1053
1054pickup pencircle scaled .5bp ;
1055
1056defaultpen := savepen ;
1057
1058permanent defaultpen ;
1059