mp-tool.mpxl /size: 132 Kb    last modification: 2023-12-21 09:43
1%D \module
2%D   [       file=mp-tool.mpiv,
3%D        version=1998.02.15,
4%D          title=\CONTEXT\ \METAPOST\ graphics,
5%D       subtitle=auxiliary macros,
6%D         author=Hans Hagen,
7%D           date=\currentdate,
8%D      copyright={PRAGMA ADE \& \CONTEXT\ Development Team}]
9%C
10%C This module is part of the \CONTEXT\ macro||package and is
11%C therefore copyrighted by \PRAGMA. See mreadme.pdf for
12%C details.
13
14if known metafun_loaded_tool : endinput ; fi ;
15
16newinternal boolean metafun_loaded_tool ; metafun_loaded_tool := true ; immutable metafun_loaded_tool ;
17
18let @## = @# ;
19
20let noexpand = quote ;
21
22permanent @##, noexpand ;
23
24%D New, version number testing:
25%D
26%D \starttyping
27%D fill fullcircle scaled 2cm withcolor if mpversiongt("0.6") : red  else : green fi ;
28%D fill fullcircle scaled 1cm withcolor if mpversionlt(0.6)   : blue else : white fi ;
29%D \stoptyping
30
31if not known mpversion : string mpversion ; mpversion := "0.641" ; fi ;
32
33% newinternal metapostversion ; metapostversion := scantokens(mpversion) ;
34
35newinternal metapostversion ; metapostversion := 3.0 ; permanent metapostversion ;
36
37%D We always want \EPS\ conforming output, so we say:
38
39warningcheck := 0 ;
40
41%D Handy:
42
43def nothing = enddef ;
44
45%D Namespace handling:
46
47% let exclamationmark = ! ;
48% let questionmark    = ? ;
49%
50% def unprotect =
51%   let ! = relax ;
52%   let ? = relax ;
53% enddef ;
54%
55% def protect =
56%   let ! = exclamationmark ;
57%   let ? = questionmark ;
58% enddef ;
59%
60% unprotect ;
61%
62% mp!some!module = 10 ; show mp!some!module ; show somemodule ;
63%
64% protect ;
65
66string space   ; space   := char 32 ;
67string percent ; percent := char 37 ;
68string crlf    ; crlf    := char 10 & char 13 ;
69string dquote  ; dquote  := char 34 ;
70
71% let SPACE   = space ;
72% let CRLF    = crlf ;
73% let DQUOTE  = dquote ;
74% let PERCENT = percent ;
75
76permanent space, percent, crlf, dquote ;
77
78% %D Plain compatibility:
79%
80% string plain_compatibility_data ; plain_compatibility_data := "" ;
81%
82% def startplaincompatibility =
83%     begingroup ;
84%     scantokens plain_compatibility_data ;
85% enddef ;
86%
87% def stopplaincompatibility =
88%     endgroup ;
89% enddef ;
90
91%D More neutral:
92
93let triplet    = rgbcolor ;
94let quadruplet = cmykcolor ;
95
96permanent triplet, quadruplet ;
97
98%D Image redefined, for Alan:
99
100vardef image@#(text t) =
101    save currentpicture ;
102    picture currentpicture ;
103    currentpicture := nullpicture ;
104    t ;
105    currentpicture
106    if str @# <> "" :
107        shifted (
108              mfun_labxf@#               * lrcorner p
109         +                 mfun_labyf@#  * ulcorner p
110         + (1-mfun_labxf@#-mfun_labyf@#) * llcorner p
111        )
112    fi
113enddef ;
114
115permanent image ;
116
117%D Variables
118
119def dispose suffix s =
120    if known s :
121        begingroup ;
122            save ss ;
123            if     numeric   s : numeric   ss
124            elseif boolean   s : boolean   ss
125            elseif pair      s : pair      ss
126            elseif path      s : path      ss
127            elseif picture   s : picture   ss
128            elseif string    s : string    ss
129            elseif transform s : transform ss
130            elseif color     s : color     ss
131            elseif rgbcolor  s : rgbcolor  ss
132            elseif cmykcolor s : cmykcolor ss
133            elseif pen       s : pen       ss
134            else             s : numeric   ss
135            fi ;
136            s := ss ;
137        endgroup ;
138    fi ;
139enddef ;
140
141permanent dispose ;
142
143%D Colors:
144
145let grayscale = graycolor ;
146let greyscale = greycolor ;
147
148vardef colorpart expr c =
149    if not picture c :
150        0
151    elseif colormodel c = greycolormodel :
152        greypart c
153    elseif colormodel c = rgbcolormodel  :
154        (redpart c,greenpart c,bluepart c)
155    elseif colormodel c = cmykcolormodel :
156        (cyanpart c,magentapart c,yellowpart c,blackpart c)
157    else :
158        0 % black
159    fi
160enddef ;
161
162vardef colorlike(text c) text v = % colorlike(a) b, c, d ;
163    save temp_p ; picture temp_p ;
164    forsuffixes i=v :
165        temp_p := image(draw origin withcolor c ;) ; % intercept pre and postscripts
166        if (colormodel temp_p = cmykcolormodel) :
167            cmykcolor i ;
168        elseif (colormodel temp_p = rgbcolormodel) :
169            rgbcolor i ;
170        else :
171            greycolor i ;
172        fi ;
173    endfor ;
174enddef ;
175
176permanent nocolormodel, greycolormodel, graycolormodel, rgbcolormodel, cmykcolormodel,
177    greyscale, grayscale, colorpart, colorlike ;
178
179%D Also multiple d's: handy (when we flush colors):
180
181vardef ddecimal primary p =
182    decimal xpart p & " " & decimal ypart p
183enddef ;
184
185vardef dddecimal primary c =
186    decimal redpart c & " " & decimal greenpart c & " " & decimal bluepart c
187enddef ;
188
189vardef ddddecimal primary c =
190    decimal cyanpart c & " " & decimal magentapart c & " " & decimal yellowpart c & " " & decimal blackpart c
191enddef ;
192
193vardef colordecimals primary c =
194    if cmykcolor c  :
195        decimal cyanpart c & ":" & decimal magentapart c & ":" & decimal yellowpart c & ":" & decimal blackpart c
196    elseif rgbcolor c :
197        decimal redpart c & ":" & decimal greenpart c & ":" & decimal bluepart c
198    elseif string c:
199        colordecimals resolvedcolor(c)
200    else :
201        decimal c
202    fi
203enddef ;
204
205vardef colordecimalslist(text t) =
206    save b ; boolean b ; b := false ;
207    for s=t :
208        if b : & " " & fi
209        colordecimals(s)
210        hide(b := true ;)
211    endfor
212enddef ;
213
214permanent decimal, ddecimal, dddecimal, ddddecimal, colordecimals, colordecimalslist ;
215
216% vardef _ctx_color_spec_ primary c =
217%     if cmykcolor c  :
218%          "c=" & decimal cyanpart    c &
219%         ",m=" & decimal magentapart c &
220%         ",y=" & decimal yellowpart  c &
221%         ",k=" & decimal blackpart   c
222%     elseif rgbcolor c :
223%          "r=" & decimal redpart   c &
224%         ",g=" & decimal greenpart c &
225%         ",b=" & decimal bluepart  c
226%     else :
227%          "s=" & decimal c
228%     fi
229% enddef ;
230%
231% vardef _ctx_color_spec_list_(text t) =
232%     save b ; boolean b ; b := false ;
233%     for s=t :
234%         if b : & " " & fi
235%         _ctx_color_spec_(s)
236%         hide(b := true ;)
237%     endfor
238% enddef ;
239
240%D Because \METAPOST\ has a hard coded limit of 4~datafiles, we need some trickery
241%D when we have multiple files. This will be redone (via \LUA).
242
243boolean savingdata     ; savingdata     := false ;
244boolean savingdatadone ; savingdatadone := false ;
245
246def savedata expr txt =
247    lua.mp.mf_save_data(txt);
248enddef ;
249
250def startsavingdata =
251    lua.mp.mf_start_saving_data();
252enddef ;
253
254def stopsavingdata =
255    lua.mp.mf_stop_saving_data() ;
256enddef ;
257
258def finishsavingdata =
259  % lua.mp.mf_finish_saving_data() ;
260enddef ;
261
262%D Instead of a keystroke eating save and allocation sequence, you can use the \quote
263%D {new} alternatives to save and allocate in one command.
264
265%D Are these used?
266
267def newcolor     text v = forsuffixes i=v : save i ; color     i ; endfor ; enddef ;
268def newrgbcolor  text v = forsuffixes i=v : save i ; rgbcolor  i ; endfor ; enddef ;
269def newcmykcolor text v = forsuffixes i=v : save i ; cmykcolor i ; endfor ; enddef ;
270def newnumeric   text v = forsuffixes i=v : save i ; numeric   i ; endfor ; enddef ;
271def newboolean   text v = forsuffixes i=v : save i ; boolean   i ; endfor ; enddef ;
272def newtransform text v = forsuffixes i=v : save i ; transform i ; endfor ; enddef ;
273def newpath      text v = forsuffixes i=v : save i ; path      i ; endfor ; enddef ;
274def newpicture   text v = forsuffixes i=v : save i ; picture   i ; endfor ; enddef ;
275def newstring    text v = forsuffixes i=v : save i ; string    i ; endfor ; enddef ;
276def newpair      text v = forsuffixes i=v : save i ; pair      i ; endfor ; enddef ;
277
278permanent newcolor, newrgbcolor, newcmykcolor, newnumeric, newboolean, newtransform, newpath, newpicture, newstring, newpair ;
279
280%D Sometimes we don't want parts of the graphics add to the bounding box. One way of
281%D doing this is to save the bounding box, draw the graphics that may not count, and
282%D restore the bounding box.
283%D
284%D \starttyping
285%D push_boundingbox currentpicture;
286%D pop_boundingbox currentpicture;
287%D \stoptyping
288%D
289%D The bounding box can be called with:
290%D
291%D \starttyping
292%D boundingbox currentpicture
293%D inner_boundingbox currentpicture
294%D outer_boundingbox currentpicture
295%D \stoptyping
296%D
297%D Especially the latter one can be of use when we include the graphic in a document
298%D that is clipped to the bounding box. In such occasions one can use:
299%D
300%D \starttyping
301%D set_outer_boundingbox currentpicture;
302%D \stoptyping
303%D
304%D Its counterpart is:
305%D
306%D \starttyping
307%D set_inner_boundingbox p
308%D \stoptyping
309
310path    mfun_boundingbox_stack[] ;
311numeric mfun_boundingbox_stack_depth ;
312
313mfun_boundingbox_stack_depth := 0 ;
314
315def pushboundingbox text p =
316    mfun_boundingbox_stack_depth := mfun_boundingbox_stack_depth + 1 ;
317    mfun_boundingbox_stack[mfun_boundingbox_stack_depth] := boundingbox p ;
318enddef ;
319
320def popboundingbox text p =
321    setbounds p to mfun_boundingbox_stack[mfun_boundingbox_stack_depth] ;
322    mfun_boundingbox_stack[mfun_boundingbox_stack_depth] := origin -- cycle ;
323    mfun_boundingbox_stack_depth := mfun_boundingbox_stack_depth - 1 ;
324enddef ;
325
326% let push_boundingbox = pushboundingbox ; % downward compatible
327% let pop_boundingbox  = popboundingbox  ; % downward compatible
328
329% vardef boundingbox primary p =
330%     if (path p) or (picture p) :
331%         llcorner p -- lrcorner p -- urcorner p -- ulcorner p
332%     else :
333%         origin
334%     fi -- cycle
335% enddef;
336
337% vardef boundingbox primary p =
338%     if (path p) or (picture p) :
339%         save a, b ; pair a, b ; a := llcorner p ; b:= urcorner p ;
340%         a -- (xpart b, ypart a) -- b -- (xpart a, ypart b)
341%     else :
342%         origin
343%     fi -- cycle
344% enddef;
345
346% vardef innerboundingbox primary p =
347%     top  rt llcorner p --
348%     top lft lrcorner p --
349%     bot lft urcorner p --
350%     bot  rt ulcorner p -- cycle
351% enddef;
352
353% vardef outerboundingbox primary p =
354%     bot lft llcorner p --
355%     bot  rt lrcorner p --
356%     top  rt urcorner p --
357%     top lft ulcorner p -- cycle
358% enddef;
359
360let boundingbox = corners ;
361
362vardef innerboundingbox primary p =
363    save b ; path b ; b := corners p ;
364    top  rt point 0 of b --
365    top lft point 1 of b --
366    bot lft point 2 of b --
367    bot  rt point 3 of b -- cycle
368enddef;
369
370vardef outerboundingbox primary p =
371    save b ; path b ; b := corners p ;
372    bot lft point 0 of b --
373    bot  rt point 1 of b --
374    top  rt point 2 of b --
375    top lft point 3 of b -- cycle
376enddef;
377
378% def inner_boundingbox = innerboundingbox enddef ;
379% def outer_boundingbox = outerboundingbox enddef ;
380%
381% vardef set_inner_boundingbox text q = % obsolete
382%     setbounds q to innerboundingbox q;
383% enddef;
384%
385% vardef set_outer_boundingbox text q = % obsolete
386%     setbounds q to outerboundingbox q;
387% enddef;
388
389% secondarydef a boundedto b = % will this cleanup ?
390%     hide(picture mfun_a_b ; mfun_a_b := a ; setbounds mfun_a_b to b;)
391%     mfun_a_b
392% enddef ;
393
394%D Here are some special ones, cooked up in the process of Alan's mp-node
395%D module:
396
397vardef boundingradius primary p =
398    if picture p :
399        pair c ; c := -center p;
400        max(
401            abs((llcorner p) shifted c),
402            abs((lrcorner p) shifted c),
403            abs((urcorner p) shifted c),
404            abs((ulcorner p) shifted c)
405        )
406    elseif pen p :
407        boundingradius image(draw makepath p ;)
408    elseif path p :
409        boundingradius image(draw p ;)
410    fi
411enddef ;
412
413vardef boundingcircle primary p =
414    fullcircle scaled 2boundingradius p shifted center p
415enddef ;
416
417vardef boundingpoint@#(expr p) =
418    if picture p : % pen?
419        (                 mfun_labxf@# *ulcorner p
420         +                mfun_labyf@# *lrcorner p
421         +(1-mfun_labxf@#-mfun_labyf@#)*urcorner p)
422    elseif path p :
423        boundingpoint@#(image(draw p ;))
424   %elseif pair p :
425   %    p
426   %else :
427   %    origin
428    fi
429enddef ;
430
431permanent pushboundingbox, popboundingbox, boundingbox, innerboundingbox, outerboundingbox,
432    boundingradius, boundingcircle, boundingpoint ;
433
434%D Whatever:
435
436def mirrored primary a =
437    a scaled -1
438enddef ;
439
440primarydef a mirroredabout b =
441    (a shifted -b) scaled -1 shifted b
442enddef ;
443
444permanent mirrored, mirroredabout ;
445
446%D Some missing functions can be implemented rather straightforward (thanks to Taco
447%D and others):
448
449% oldpi := 3.14159265358979323846 ; % from <math.h>
450pi      := 3.14159265358979323846264338327950288419716939937510 ; % 50 digits
451radian  := 180/pi ; % 2pi*radian = 360 ;
452
453permanent pi, radian ;
454
455% let +++ = ++ ;
456
457vardef sqr  primary x = x*x                                 enddef ;
458vardef log  primary x = if x=0: 0 else: mlog(x)/mlog(10) fi enddef ;
459vardef ln   primary x = if x=0: 0 else: mlog(x)/256 fi      enddef ;
460vardef exp  primary x = (mexp 256)**x                       enddef ;
461vardef inv  primary x = if x=0: 0 else: x**-1 fi            enddef ;
462
463vardef pow (expr x,p) = x**p                                enddef ;
464
465vardef tand   primary x = sind(x)/cosd(x)  enddef ;
466vardef cotd   primary x = cosd(x)/sind(x)  enddef ;
467
468%      sin    primary x = sind(x*radian)   enddef ;
469%      cos    primary x = cosd(x*radian)   enddef ;
470%      tan    primary x = sin(x)/cos(x)    enddef ;
471vardef cot    primary x = cos(x)/sin(x)    enddef ;
472
473%      asin   primary x = angle((1+-+x,x)) enddef ;
474%      acos   primary x = angle((x,1+-+x)) enddef ;
475%      atan   primary x = angle(1,x)       enddef ;
476
477%      invsin primary x = (asin(x))/radian enddef ;
478%      invcos primary x = (acos(x))/radian enddef ;
479%      invtan primary x = (atan(x))/radian enddef ;
480
481%      acosh  primary x = ln(x+(x+-+1))    enddef ;
482%      asinh  primary x = ln(x+(x++1))     enddef ;
483
484%      sinh   primary x = save xx ; xx = exp x ; (xx-1/xx)/2 enddef ;
485%      cosh   primary x = save xx ; xx = exp x ; (xx+1/xx)/2 enddef ;
486%      tanh   primary x = save xx ; xx = exp x ; (xx-1/xx)/(xx+1/xx) enddef ;
487
488%D Like mod, but useful for angles, it returns (-.5d,+.5d] and is used
489%D in for instance mp-chem.
490
491primarydef a zmod b = (-((b/2 - a) mod b) + b/2) enddef ;
492
493permanent sqr, log, ln, exp, inv, pow, tand, cotd, cot, zmod ;
494
495%D Sometimes this is handy:
496
497def undashed =
498    dashed nullpicture
499enddef ;
500
501permanent undashed ;
502
503%D We provide two macros for drawing stripes across a shape. The first method (with the
504%D n suffix) uses another method, slower in calculation, but more efficient when drawn.
505%D The first macro divides the sides into n equal parts. The first argument specifies the
506%D way the lines are drawn, while the second argument identifier the way the shape is to
507%D be drawn.
508%D
509%D \starttyping
510%D stripe_path_n
511%D   (dashed evenly withcolor blue)
512%D   (filldraw)
513%D   fullcircle xscaled 100 yscaled 40 shifted (50,50) withpen pencircle scaled 4;
514%D \stoptyping
515%D
516%D The a (or angle) alternative supports arbitrary angles and is therefore more versatile.
517%D
518%D \starttyping
519%D stripe_path_a
520%D   (withpen pencircle scaled 2 withcolor red)
521%D   (draw)
522%D   fullcircle xscaled 100 yscaled 40 withcolor blue;
523%D \stoptyping
524%D
525%D We have two alternatives, controlled by arguments or defaults (when arguments are zero).
526%D
527%D The newer and nicer interface is used as follows (triggered by a question by Mari):
528%D
529%D \starttyping
530%D draw image (draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green) numberstriped (1,10,3) withcolor red ;
531%D draw image (draw fullcircle scaled 3cm shifted (3cm,0cm) withcolor green) numberstriped (2,20,3) withcolor green ;
532%D draw image (draw fullcircle scaled 3cm shifted (3cm,3cm) withcolor green) numberstriped (3,10,5) withcolor blue ;
533%D draw image (draw fullcircle scaled 3cm shifted (0cm,3cm) withcolor green) numberstriped (4,20,5) withcolor yellow ;
534%D
535%D draw image (draw fullcircle scaled 3cm shifted (6cm,0cm) withcolor green) anglestriped (1,20,2) withcolor red ;
536%D draw image (draw fullcircle scaled 3cm shifted (9cm,0cm) withcolor green) anglestriped (2,40,2) withcolor green ;
537%D draw image (draw fullcircle scaled 3cm shifted (9cm,3cm) withcolor green) anglestriped (3,60,2) withcolor blue ;
538%D draw image (draw fullcircle scaled 3cm shifted (6cm,3cm) withcolor green) anglestriped (4,80,2) withcolor yellow ;
539%D
540%D draw image (
541%D     draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ;
542%D     draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue  withpen pencircle scaled 3mm ;
543%D ) shifted (9cm,0cm) numberstriped (1,10,3) withcolor red ;
544%D
545%D draw image (
546%D     draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green  withpen pencircle scaled 2mm ;
547%D     draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue   withpen pencircle scaled 3mm ;
548%D ) shifted (12cm,0cm) numberstriped (2,10,3) withcolor red ;
549%D
550%D draw image (
551%D     draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green  withpen pencircle scaled 2mm ;
552%D     draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue   withpen pencircle scaled 3mm ;
553%D ) shifted (9cm,5cm) numberstriped (3,10,3) withcolor red ;
554%D
555%D draw image (
556%D     draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green  withpen pencircle scaled 2mm ;
557%D     draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue   withpen pencircle scaled 3mm ;
558%D ) shifted (12cm,5cm) numberstriped (4,10,3) withcolor red ;
559%D \stoptyping
560
561stripe_n     := 10;
562stripe_slot  :=  3;
563stripe_gap   :=  5;
564stripe_angle := 45;
565
566def mfun_tool_striped_number_action text extra =
567    for i = 1/used_n step 1/used_n until 1 :
568        draw point (1+i) of bounds -- point (3-i) of bounds withpen pencircle scaled penwidth extra ;
569    endfor ;
570    for i = 0 step 1/used_n until 1 :
571        draw point (3+i) of bounds -- point (1-i) of bounds withpen pencircle scaled penwidth extra ;
572    endfor ;
573enddef ;
574
575def mfun_tool_striped_set_options(expr option) =
576    save isinner, swapped, isdrawn ;
577    boolean isinner, swapped, isdrawn ;
578    if option = 0 :
579        isdrawn := true;
580        isinner := true ;
581        swapped := false ;
582    elseif option = 1 :
583        isdrawn := false ;
584        isinner := false ;
585        swapped := false ;
586    elseif option = 2 :
587        isdrawn := false ;
588        isinner := true ;
589        swapped := false ;
590    elseif option = 3 :
591        isdrawn := false ;
592        isinner := false ;
593        swapped := true ;
594    elseif option = 4 :
595        isdrawn := false ;
596        isinner := true ;
597        swapped := true ;
598    else :
599        isdrawn := false ;
600        isinner := false ;
601        swapped := false ;
602    fi ;
603enddef ;
604
605vardef mfun_tool_striped_number(expr option, p, asked_n, asked_slot) text extra =
606%     image (
607        begingroup ;
608        save pattern, shape, bounds, penwidth, used_n, used_slot ;
609        picture pattern, shape ; path bounds ; numeric used_s, used_slot ;
610        mfun_tool_striped_set_options(option) ;
611        used_slot := if asked_slot = 0 : stripe_slot else : asked_slot fi ;
612        used_n := if asked_n = 0 : stripe_n else : asked_n fi ;
613        shape := image(draw p) ;
614        bounds := boundingbox shape ;
615        penwidth := min(ypart urcorner shape - ypart llcorner shape, xpart urcorner shape - xpart llcorner shape) / (used_slot * used_n) ;
616        pattern := image (
617            if isinner :
618                mfun_tool_striped_number_action extra ;
619                for s within shape :
620                    if stroked s or filled s :
621                        clip currentpicture to pathpart s ;
622                    fi
623                endfor ;
624            else :
625                for s within shape :
626                    if stroked s or filled s :
627                        draw image (
628                            mfun_tool_striped_number_action extra ;
629                            clip currentpicture to pathpart s ;
630                        ) ;
631                    fi ;
632                endfor ;
633            fi ;
634        ) ;
635        if isdrawn :
636            addto currentpicture also pattern ;
637        elseif swapped :
638            addto currentpicture also shape ;
639            addto currentpicture also pattern ;
640        else :
641            addto currentpicture also pattern ;
642            addto currentpicture also shape ;
643        fi ;
644        endgroup ;
645%     )
646enddef ;
647
648% def mfun_tool_striped_angle_action text extra =
649%     for i = minimum -.5used_gap step used_gap until maximum :
650%         draw (minimum,i) -- (maximum,i) extra ;
651%     endfor ;
652%     currentpicture := currentpicture rotated used_angle ;
653% enddef ;
654
655def mfun_tool_striped_angle_action text extra =
656    for i = minimum -.5used_gap step used_gap until maximum :
657        nodraw (minimum,i) -- (maximum,i) extra ;
658    endfor ;
659    dodraw origin ;
660    currentpicture := currentpicture rotated used_angle ;
661enddef ;
662
663vardef mfun_tool_striped_angle(expr option, p, asked_angle, asked_gap) text extra =
664%     image (
665        begingroup ;
666        save pattern, shape, mask, maximum, minimum, centrum, used_angle, used_gap ;
667        picture pattern, shape, mask ; numeric maximum, minimum ; pair centrum ; numeric used_angle, used_gap ;
668        mfun_tool_striped_set_options(option) ;
669        used_angle := if asked_angle = 0 : stripe_angle else : asked_angle fi ;
670        used_gap := if asked_gap = 0 : stripe_gap else : asked_gap fi ;
671        shape := image(draw p) ;
672      % centrum := center shape ;
673        centrum := llcorner shape ;
674        shape := shape shifted - centrum ;
675        mask := shape rotated used_angle ;
676        maximum := max (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ;
677        minimum := min (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ;
678        % a hack:
679        maximum := maximum + max(xpart urcorner shape, ypart urcorner shape);
680        minimum := minimum - max(xpart urcorner shape, ypart urcorner shape);
681        %
682        pattern := image (
683            if isinner :
684                mfun_tool_striped_angle_action extra ;
685                for s within shape :
686                    if stroked s or filled s :
687                       clip currentpicture to pathpart s ;
688                    fi
689                endfor ;
690            else :
691                for s within shape :
692                    if stroked s or filled s :
693                        draw image (
694                            mfun_tool_striped_angle_action extra ;
695                            clip currentpicture to pathpart s ;
696                        ) ;
697                    fi ;
698                endfor ;
699            fi ;
700        ) ;
701        if isdrawn :
702            addto currentpicture also pattern ;
703        elseif swapped :
704            addto currentpicture also shape ;
705            addto currentpicture also pattern ;
706        else :
707            addto currentpicture also pattern ;
708            addto currentpicture also shape ;
709        fi ;
710        currentpicture := currentpicture shifted centrum ;
711        endgroup ;
712%     )
713enddef;
714
715newinternal striped_normal_inner  ; striped_normal_inner  := 1 ;
716newinternal striped_reverse_inner ; striped_reverse_inner := 2 ;
717newinternal striped_normal_outer  ; striped_normal_outer  := 3 ;
718newinternal striped_reverse_outer ; striped_reverse_outer := 4 ;
719
720secondarydef p anglestriped s =
721  % mfun_tool_striped_angle(redpart s,p,greenpart s,bluepart s)
722    image(mfun_tool_striped_angle(redpart s,p,greenpart s,bluepart s)) % for 'withcolor'
723enddef ;
724
725secondarydef p numberstriped s =
726  % mfun_tool_striped_number(redpart s,p,greenpart s,bluepart s)
727    image(mfun_tool_striped_number(redpart s,p,greenpart s,bluepart s)) % for 'withcolor'
728enddef ;
729
730% for old times sake:
731
732def stripe_path_n (text asked_spec) (text asked_draw) expr asked_path =
733    do_stripe_path_n (asked_spec) (asked_draw) (asked_path)
734enddef;
735
736def do_stripe_path_n (text asked_spec) (text asked_draw) (expr asked_path) text asked_text =
737    draw image(asked_draw asked_path asked_text) numberstriped(3,0,0) asked_spec ;
738enddef ;
739
740def stripe_path_a (text asked_spec) (text asked_draw) expr asked_path =
741    do_stripe_path_a (asked_spec) (asked_draw) (asked_path)
742enddef;
743
744def do_stripe_path_a (text asked_spec) (text asked_draw) (expr asked_path) text asked_text =
745    draw image(asked_draw asked_path asked_text) anglestriped(3,0,0) asked_spec ;
746enddef ;
747
748%D A more efficient variant by Mikael:
749
750% path p ; p := fullcircle scaled 3cm && (unitsquare scaled 2cm shifted (4cm,4cm)) && cycle ;
751% draw hatch(p,30,0.2cm) ; draw p ;
752
753vardef hatch(expr p, a, d) =
754    save thestripe, diag, b ; picture thestripe ; numeric diag ; path b ;
755    b := boundingbox p;
756    diag := 0.55 * ( abs((urcorner b) - (llcorner b)) ) ;
757    thestripe := image (
758        draw (-diag,0) -- (diag, 0) &&
759        for i = d step d until diag:
760            (-diag, i) -- (diag, i) &&
761            (-diag,-i) -- (diag,-i) &&
762        endfor nocycle
763        withpen currentpen ;
764    ) ;
765    thestripe := thestripe shifted center b ;
766    thestripe := thestripe rotatedaround(center b, a) ;
767    clip thestripe to p ;
768    thestripe
769enddef ;
770
771%D A few normalizing macros:
772
773% primarydef p xsized w =
774%     (p if (bbwidth (p) > 0) and (w > 0) : scaled (w/bbwidth (p)) fi)
775% enddef ;
776% primarydef p xsized w =
777%     begingroup
778%     save b, l ; path b;
779%     b := corners p ;
780%     l := xpart point 1 of b - xpart point 0 of b ;
781%     (p if (l > 0) and (w > 0) : scaled (w/l) fi)
782%     endgroup
783% enddef ;
784primarydef p xsized w =
785    begingroup
786    save r, l ; pair r;
787    r := xrange p ;
788    l := ypart r - xpart r ;
789    (p if (l > 0) and (w > 0) : scaled (w/l) fi)
790    endgroup
791enddef ;
792
793% primarydef p ysized h =
794%     (p if (bbheight(p) > 0) and (h > 0) : scaled (h/bbheight(p)) fi)
795% enddef ;
796% primarydef p ysized h =
797%     begingroup
798%     save b, l ; path b;
799%     b := corners p ;
800%     l := ypart point 2 of b - ypart point 1 of b ;
801%     (p if (l > 0) and (h > 0) : scaled (h/l) fi)
802%     endgroup
803% enddef ;
804primarydef p ysized h =
805    begingroup
806    save r, l ; pair r ;
807    r := yrange p ;
808    l := ypart r - xpart r ;
809    (p if (l > 0) and (h > 0) : scaled (h/l) fi)
810    endgroup
811enddef ;
812
813% primarydef p xysized s = % a one step transform might be faster
814%     begingroup
815%     save wh, w, h ; pair wh ; numeric w, h ;
816%     wh := paired (s) ; w := bbwidth(p) ; h := bbheight(p) ;
817%     p
818%         if (w > 0) and (h > 0) :
819%             if xpart wh > 0 : xscaled (xpart wh/w) fi
820%             if ypart wh > 0 : yscaled (ypart wh/h) fi
821%         fi
822%     endgroup
823% enddef ;
824primarydef p xysized s = % a one step transform might be faster
825    begingroup
826    save wh, w, h, b ; pair wh ; path b;
827    b := corners p ;
828    w := xpart point 1 of b - xpart point 0 of b ;
829    h := ypart point 2 of b - ypart point 1 of b ;
830    wh := paired (s) ;
831    p
832        if (w > 0) and (h > 0) :
833            if xpart wh > 0 : xscaled (xpart wh/w) fi
834            if ypart wh > 0 : yscaled (ypart wh/h) fi
835        fi
836    endgroup
837enddef ;
838
839% to be tested
840%
841% primarydef p xysized s =
842%     begingroup
843%     save wh, w, h ; pair wh ; numeric w, h ;
844%     wh := paired (s) ; w := bbwidth(p) ; h := bbheight(p) ;
845%     if (w > 0) and (h > 0) :
846%         transform t ; t := identity if xpart wh > 0 : xscaled (xpart wh/w) fi if ypart wh > 0 : yscaled (ypart wh/h)
847%     fi ;
848%     p if (w > 0) and (h > 0) : transformed t fi
849%     endgroup
850% enddef ;
851
852let sized = xysized ;
853
854permanent xsized, ysized, xysized, sized ;
855
856% primarydef p xynormalized s =
857%     begingroup
858%     save w, h ; numeric w, h ;
859%     w := bbwidth(p) ;
860%     h := bbheight(p) ;
861%     if (w > 0) and (h > 0) :
862%         save t, wh ; transform t ; pair wh ;
863%         wh := paired (s) ;
864%         t := identity
865%             shifted - llcorner p
866%             if xpart wh > 0 : xscaled (xpart wh/w) fi
867%             if ypart wh > 0 : yscaled (ypart wh/h) fi
868%         ;
869%         p transformed t
870%     else :
871%         p
872%     fi
873%     endgroup
874% enddef ;
875primarydef p xynormalized s =
876    begingroup save w, h, b ; path b;
877    b := corners p ;
878    w := xpart point 1 of b - xpart point 0 of b ;
879    h := ypart point 2 of b - ypart point 1 of b ;
880    if (w > 0) and (h > 0) :
881        save t, wh ; transform t ; pair wh ;
882        wh := paired (s) ;
883        t := identity
884            shifted - llcorner p
885            if xpart wh > 0 : xscaled (xpart wh/w) fi
886            if ypart wh > 0 : yscaled (ypart wh/h) fi
887        ;
888        p transformed t
889    else :
890        p
891    fi
892    endgroup
893enddef ;
894
895% primarydef p xnormalized s =
896%     begingroup
897%     save w ; numeric w ;
898%     w := bbwidth(p) ;
899%     if (w > 0) :
900%         save t ; transform t ;
901%         t := identity
902%             shifted - llcorner p
903%             if s > 0 : xscaled (s/w) fi
904%         ;
905%         p transformed t
906%     else :
907%         p
908%     fi
909%     endgroup
910% enddef ;
911primarydef p xnormalized s =
912    begingroup save h, r ; pair r ;
913    r := xrange p ;
914    w := ypart r - xpart r ;
915    if (w > 0) :
916        save t ; transform t ;
917        t := identity
918            shifted - llcorner p
919            if s > 0 : xscaled (s/w) fi
920        ;
921        p transformed t
922    else :
923        p
924    fi
925    endgroup
926enddef ;
927
928% primarydef p ynormalized s =
929%     begingroup
930%     save h ; numeric h ;
931%     h := bbheight(p) ;
932%     if (h > 0) :
933%         save t ; transform t ;
934%         t := identity
935%             shifted - llcorner p
936%             if s > 0 : yscaled (s/h) fi
937%         ;
938%         p transformed t
939%     else :
940%         p
941%     fi
942%     endgroup
943% enddef ;
944primarydef p ynormalized s =
945    begingroup save h, r ; pair r ;
946    r := yrange p ;
947    h := ypart r - xpart r ;
948    if (h > 0) :
949        save t ; transform t ;
950        t := identity
951            shifted - llcorner p
952            if s > 0 : yscaled (s/h) fi
953        ;
954        p transformed t
955    else :
956        p
957    fi
958    endgroup
959enddef ;
960
961permanent xnormalized, ynormalized, xynormalized ;
962
963% def xscale_currentpicture(expr w) = % obsolete
964%     currentpicture := currentpicture xsized w ;
965% enddef;
966%
967% def yscale_currentpicture(expr h) = % obsolete
968%     currentpicture := currentpicture ysized h ;
969% enddef;
970%
971% def xyscale_currentpicture(expr w, h) = % obsolete
972%     currentpicture := currentpicture xysized (w,h) ;
973% enddef;
974%
975% def scale_currentpicture(expr w, h) = % obsolete
976%     currentpicture := currentpicture xsized w ;
977%     currentpicture := currentpicture ysized h ;
978% enddef;
979
980%D A full circle is centered at the origin, while a unitsquare is located in the first
981%D quadrant. Now guess what kind of path fullsquare and unitcircle do return.
982
983path fullsquare, unitcircle ;
984
985fullsquare := unitsquare shifted - center unitsquare ;
986unitcircle := fullcircle shifted urcorner fullcircle ;
987
988%D Some more paths:
989
990path urcircle, ulcircle, llcircle, lrcircle ;
991
992urcircle := origin -- (+.5,0) & (+.5,0){up}    .. (0,+.5) & (0,+.5) -- cycle ;
993ulcircle := origin -- (0,+.5) & (0,+.5){left}  .. (-.5,0) & (-.5,0) -- cycle ;
994llcircle := origin -- (-.5,0) & (-.5,0){down}  .. (0,-.5) & (0,-.5) -- cycle ;
995lrcircle := origin -- (0,-.5) & (0,-.5){right} .. (+.5,0) & (+.5,0) -- cycle ;
996
997path tcircle, bcircle, lcircle, rcircle ;
998
999tcircle := origin -- (+.5,0) & (+.5,0) {up}    .. (0,+.5) .. {down}  (-.5,0) -- cycle ;
1000bcircle := origin -- (-.5,0) & (-.5,0) {down}  .. (0,-.5) .. {up}    (+.5,0) -- cycle ;
1001lcircle := origin -- (0,+.5) & (0,+.5) {left}  .. (-.5,0) .. {right} (0,-.5) -- cycle ;
1002rcircle := origin -- (0,-.5) & (0,-.5) {right} .. (+.5,0) .. {left}  (0,+.5) -- cycle ;
1003
1004path urtriangle, ultriangle, lltriangle, lrtriangle ; % watch out: it's contrary to what you expect and starts in the origin
1005
1006urtriangle := origin -- (+.5,0) -- (0,+.5) -- cycle ;
1007ultriangle := origin -- (0,+.5) -- (-.5,0) -- cycle ;
1008lltriangle := origin -- (-.5,0) -- (0,-.5) -- cycle ;
1009lrtriangle := origin -- (0,-.5) -- (+.5,0) -- cycle ;
1010
1011path triangle, uptriangle, downtriangle, lefttriangle, righttriangle ;
1012
1013triangle      := (1,0) -- (1,0) rotated 120 -- (1,0) rotated -120 -- cycle ;
1014
1015uptriangle    := triangle rotated  90 ;
1016downtriangle  := triangle rotated -90 ;
1017lefttriangle  := triangle rotated 180 ;
1018righttriangle := triangle ;
1019
1020path unitdiamond, fulldiamond ;
1021
1022unitdiamond := (.5,0) -- (1,.5) -- (.5,1) -- (0,.5) -- cycle ;
1023fulldiamond := unitdiamond shifted - center unitdiamond ;
1024
1025path unitoctagon, fulloctagon ;
1026
1027unitoctagon := for i within (unitcircle rotated 45/2) : pathpoint -- endfor cycle ;
1028fulloctagon := unitoctagon shifted - center unitoctagon ;
1029
1030path unithexagon, fullhexagon ;
1031
1032%%%%hexagon := for i = 0 upto 5 : .5dir (60i) -- endfor cycle ;
1033fullhexagon := for i = 0 step 60 until 360 : .5 dir(i) -- endfor cycle ;
1034unithexagon := fullhexagon shifted (.5,.5) ;
1035
1036permanent
1037    fullsquare, unitcircle,
1038    urcircle, ulcircle, llcircle, lrcircle,
1039    tcircle, bcircle, lcircle, rcircle,
1040    urtriangle, ultriangle, lltriangle, lrtriangle,
1041    triangle, uptriangle, downtriangle, lefttriangle, righttriangle,
1042    unitdiamond, fulldiamond, unitoctagon, fulloctagon, unithexagon, fullhexagon ;
1043
1044%D More robust:
1045
1046% let  normalscaled =  scaled ;
1047% let normalxscaled = xscaled ;
1048% let normalyscaled = yscaled ;
1049%
1050% def  scaled expr s =  normalscaled (s) enddef ;
1051% def xscaled expr s = normalxscaled (s) enddef ;
1052% def yscaled expr s = normalyscaled (s) enddef ;
1053
1054%D Shorter
1055
1056primarydef p xyscaled q = % secundarydef does not work out well
1057    begingroup
1058    save qq ; pair qq ;
1059    qq = paired(q) ;
1060    p
1061        if xpart qq <> 0 : xscaled (xpart qq) fi
1062        if ypart qq <> 0 : yscaled (ypart qq) fi
1063    endgroup
1064enddef ;
1065
1066permanent xyscaled ;
1067
1068%D Some personal code that might move to another module (todo: save).
1069
1070def set_grid(expr w, h, nx, ny) =
1071    boolean grid[][] ; boolean grid_full ;
1072    numeric grid_w, grid_h, grid_nx, grid_ny, grid_x, grid_y, grid_left ;
1073    grid_w := w ;
1074    grid_h := h ;
1075    grid_nx := nx ;
1076    grid_ny := ny ;
1077    grid_x := round(w/grid_nx) ; % +.5) ;
1078    grid_y := round(h/grid_ny) ; % +.5) ;
1079    grid_left := (1+grid_x)*(1+grid_y) ;
1080    grid_full := false ;
1081    for i=0 upto grid_x :
1082        for j=0 upto grid_y :
1083            grid[i][j] := false ;
1084        endfor ;
1085    endfor ;
1086enddef ;
1087
1088vardef new_on_grid(expr grid_dx, grid_dy) =
1089    dx := grid_dx ;
1090    dy := grid_dy ;
1091    ddx := min(round(dx/grid_nx),grid_x) ; % +.5),grid_x) ;
1092    ddy := min(round(dy/grid_ny),grid_y) ; % +.5),grid_y) ;
1093    if not grid_full and not grid[ddx][ddy] :
1094        grid[ddx][ddy] := true ;
1095        grid_left := grid_left-1 ;
1096        grid_full := (grid_left=0) ;
1097        true
1098    else :
1099        false
1100    fi
1101enddef ;
1102
1103%D usage: \type{innerpath peepholed outerpath}.
1104%D
1105%D \startMPcode
1106%D   fill (fullsquare scaled 200) withcolor red ;
1107%D   path p ; p := (fullcircle scaled 100) ; bboxmargin := 0 ;
1108%D   fill p peepholed bbox p ;
1109%D \stopMPcode
1110
1111secondarydef p peepholed q =
1112    begingroup
1113    save start ; pair start ;
1114    start := point 0 of p ;
1115    if xpart start >= xpart center p :
1116        if ypart start >= ypart center p :
1117            urcorner q -- ulcorner q -- llcorner q -- lrcorner q --
1118            reverse  p -- lrcorner q -- cycle
1119        else :
1120            lrcorner q -- urcorner q -- ulcorner q -- llcorner q --
1121            reverse  p -- llcorner q -- cycle
1122        fi
1123    else :
1124        if ypart start > ypart center p :
1125            ulcorner q -- llcorner q -- lrcorner q -- urcorner q --
1126            reverse  p -- urcorner q -- cycle
1127        else :
1128            llcorner q -- lrcorner q -- urcorner q -- ulcorner q --
1129            reverse  p -- ulcorner q -- cycle
1130        fi
1131    fi
1132    endgroup
1133enddef ;
1134
1135newinternal boolean intersection_found ;
1136
1137secondarydef p intersection_point q =
1138    begingroup
1139    save temp_x, temp_y ;
1140    (temp_x,temp_y) = p intersectiontimes q ;
1141    if temp_x < 0 :
1142        intersection_found := false ;
1143        center p % origin
1144    else :
1145        intersection_found := true ;
1146        .5[point temp_x of p, point temp_y of q]
1147    fi
1148    endgroup
1149enddef ;
1150
1151permanent intersection_found, intersection_point ;
1152
1153%D New, undocumented, experimental:
1154
1155vardef tensecircle (expr width, height, offset) =
1156    (-width/2,-height/2) ... (0,-height/2-offset) ...
1157    (+width/2,-height/2) ... (+width/2+offset,0)  ...
1158    (+width/2,+height/2) ... (0,+height/2+offset) ...
1159    (-width/2,+height/2) ... (-width/2-offset,0)  ... cycle
1160enddef ;
1161
1162vardef roundedsquare (expr width, height, offset) =
1163    (offset,0)            -- (width-offset,0)      {right} ..
1164    (width,offset)        -- (width,height-offset) {up}    ..
1165    (width-offset,height) -- (offset,height)       {left}  ..
1166    (0,height-offset)     -- (0,offset)            {down}  .. cycle
1167enddef ;
1168
1169vardef roundedsquarexy (expr width, height, dx, dy) =
1170    (dx,0)            -- (width-dx,0)      {right} ..
1171    (width,dy)        -- (width,height-dy) {up}    ..
1172    (width-dx,height) -- (dx,height)       {left}  ..
1173    (0,height-dy)     -- (0,dy)            {down}  .. cycle
1174enddef ;
1175
1176permanent tensecircle, roundedsquare, roundedsquarexy ;
1177
1178%D Some colors.
1179
1180def resolvedcolor(expr s) =
1181    .5white
1182enddef ;
1183
1184let normalwithcolor = withcolor ;
1185
1186def withcolor expr c =
1187     normalwithcolor if string c : resolvedcolor(c) else : c fi
1188enddef ;
1189
1190permanent resolvedcolor, normalwithcolor, withcolor ;
1191
1192% I don't want a "withcolor black" in case of an empty string ... who knows how that can
1193% interfere with outer colors. Somehow the next one doesn't always work out ok, but why
1194% ... must be some parsing issue. Anyway, when we cannot do that, we need to fix some
1195% chem macros instead as empty strings now lead to black while everywhere else in context
1196% empty means: leave color untouched.
1197
1198% def withcolor expr c =
1199%     if not string c :
1200%         normalwithcolor c
1201%     elseif c <> "" :
1202%         normalwithcolor resolvedcolor(c)
1203%     fi
1204% enddef ;
1205
1206% So why does this work better than the above:
1207%
1208% def withcolor expr c =
1209%     if string c :
1210%         if c <> "" :
1211%             normalwithcolor resolvedcolor(c)
1212%         fi
1213%     else :
1214%         normalwithcolor c
1215%     fi
1216% enddef ;
1217
1218vardef colortype expr c =
1219        if cmykcolor c : cmykcolor
1220    elseif rgbcolor  c : rgbcolor
1221    elseif numeric   c : grayscale
1222        fi
1223enddef ;
1224
1225vardef whitecolor expr c =
1226        if cmykcolor c : (0,0,0,0)
1227    elseif rgbcolor  c : (1,1,1)
1228    elseif numeric   c : 1
1229    elseif string    c : whitecolor resolvedcolor(c)
1230        fi
1231enddef ;
1232
1233vardef blackcolor expr c =
1234        if cmykcolor c : (0,0,0,1)
1235    elseif rgbcolor  c : (0,0,0)
1236    elseif numeric   c : 0
1237    elseif string    c : blackcolor resolvedcolor(c)
1238        fi
1239enddef ;
1240
1241vardef complementary expr c =
1242        if cmykcolor c : (1,1,1,1) - c
1243    elseif rgbcolor  c : (1,1,1) - c
1244    elseif pair      c : (1,1) - c
1245    elseif numeric   c :  1 - c
1246    elseif string    c : complementary resolvedcolor(c)
1247        fi
1248enddef ;
1249
1250vardef complemented expr c =
1251    save m ;
1252        if cmykcolor c : m := max(cyanpart c, magentapart c, yellowpart c, blackpart c) ;
1253                         (m,m,m,m) - c
1254    elseif rgbcolor  c : m := max(redpart c, greenpart c, bluepart c) ;
1255                         (m,m,m) - c
1256    elseif pair      c : m := max(xpart c, ypart c) ;
1257                         (m,m) - c
1258    elseif numeric   c : m - c
1259    elseif string    c : complemented resolvedcolor(c)
1260        fi
1261enddef ;
1262
1263permanent colortype, whitecolor, blackcolor, complementary, complemented ;
1264
1265%D Well, this is the dangerous and naive version:
1266
1267% def drawfill text t =
1268%     fill t ;
1269%     draw t ;
1270% enddef;
1271
1272%D This two step approach saves the path first, since it can be a function. Attributes
1273%D must not be randomized.
1274
1275def drawfill expr c =
1276    path temp_c ; temp_c := c ;
1277    mfun_do_drawfill
1278enddef ;
1279
1280def mfun_do_drawfill text t =
1281    draw temp_c t ;
1282    fill temp_c t ;
1283enddef;
1284
1285def undrawfill expr c =
1286    drawfill c withcolor background % rather useless
1287enddef ;
1288
1289permanent drawfill, undrawfill ;
1290
1291%D Moved from mp-char.mp
1292
1293vardef paired primary d =
1294    if pair d : d else : (d,d) fi
1295enddef ;
1296
1297vardef tripled primary d =
1298    if color d : d else : (d,d,d) fi
1299enddef ;
1300
1301permanent paired, tripled ;
1302
1303% maybe secondaries:
1304
1305primarydef p enlarged       d = ( p llmoved d -- p lrmoved d -- p urmoved d -- p ulmoved d -- cycle ) enddef ;
1306primarydef p llenlarged     d = ( p llmoved d -- lrcorner p  -- urcorner p  -- ulcorner p  -- cycle ) enddef ;
1307primarydef p lrenlarged     d = ( llcorner p  -- p lrmoved d -- urcorner p  -- ulcorner p  -- cycle ) enddef ;
1308primarydef p urenlarged     d = ( llcorner p  -- lrcorner p  -- p urmoved d -- ulcorner p  -- cycle ) enddef ;
1309primarydef p ulenlarged     d = ( llcorner p  -- lrcorner p  -- urcorner p  -- p ulmoved d -- cycle ) enddef ;
1310
1311primarydef p llmoved        d = ( (llcorner p) shifted (-xpart paired(d),-ypart paired(d)) ) enddef ;
1312primarydef p lrmoved        d = ( (lrcorner p) shifted (+xpart paired(d),-ypart paired(d)) ) enddef ;
1313primarydef p urmoved        d = ( (urcorner p) shifted (+xpart paired(d),+ypart paired(d)) ) enddef ;
1314primarydef p ulmoved        d = ( (ulcorner p) shifted (-xpart paired(d),+ypart paired(d)) ) enddef ;
1315
1316primarydef p leftenlarged   d = ( (llcorner p) shifted (-d,0) -- lrcorner p -- urcorner p -- (ulcorner p) shifted (-d,0) -- cycle ) enddef ;
1317primarydef p rightenlarged  d = ( llcorner p -- (lrcorner p) shifted (d,0) -- (urcorner p) shifted (d,0) -- ulcorner p -- cycle   ) enddef ;
1318primarydef p topenlarged    d = ( llcorner p -- lrcorner p -- (urcorner p) shifted (0,d) -- (ulcorner p) shifted (0,d) -- cycle   ) enddef ;
1319primarydef p bottomenlarged d = ( llcorner p shifted (0,-d) -- lrcorner p shifted (0,-d) -- urcorner p -- ulcorner p -- cycle     ) enddef ;
1320
1321
1322permanent
1323    enlarged, llenlarged, lrenlarged, urenlarged, ulenlarged,
1324    llmoved, lrmoved, urmoved, ulmoved,
1325    leftenlarged, rightenlarged, topenlarged, bottomenlarged ;
1326
1327%D Handy as stepper:
1328
1329vardef rotation(expr i, n) =
1330    if (n == 0) : 0 else : i * 360 / n fi
1331enddef ;
1332
1333
1334permanent rotation ;
1335
1336%D Handy for testing/debugging; the ladders are for math:
1337
1338primarydef p crossed d = (
1339    if pair p :
1340        p shifted (-d, 0) -- p --
1341        p shifted ( 0,-d) -- p --
1342        p shifted (+d, 0) -- p --
1343        p shifted ( 0,+d) -- p -- cycle
1344    else :
1345        center p shifted (-d, 0) -- llcorner p --
1346        center p shifted ( 0,-d) -- lrcorner p --
1347        center p shifted (+d, 0) -- urcorner p --
1348        center p shifted ( 0,+d) -- ulcorner p -- cycle
1349    fi
1350) enddef ;
1351
1352% vardef laddered primary p = % was expr
1353%     point 0 of p
1354%     for i=1 upto length(p) :
1355%         -- (xpart (point i of p), ypart (point (i-1) of p)) -- (point i of p)
1356%     endfor
1357% enddef ;
1358
1359vardef laddered primary p = % was expr
1360    save a; pair a ; a := point 0 of p ; a --
1361    for i within p :
1362        if i > 0 : (xpart pathpoint, ypart a) -- pathpoint -- fi
1363        hide(a := pathpoint)
1364    endfor
1365    if cycle p :
1366        (xpart point 0 of p, ypart a) -- point 0 of p -- cycle
1367    else :
1368        nocycle
1369    fi
1370enddef ;
1371
1372permanent crossed, laddered ;
1373
1374%D Saves typing:
1375
1376% vardef bottomboundary primary p = (llcorner p -- lrcorner p) enddef ;
1377% vardef rightboundary  primary p = (lrcorner p -- urcorner p) enddef ;
1378% vardef topboundary    primary p = (urcorner p -- ulcorner p) enddef ;
1379% vardef leftboundary   primary p = (ulcorner p -- llcorner p) enddef ;
1380
1381vardef bottomboundary primary p = if pair p : p else : (llcorner p -- lrcorner p) fi enddef ;
1382vardef rightboundary  primary p = if pair p : p else : (lrcorner p -- urcorner p) fi enddef ;
1383vardef topboundary    primary p = if pair p : p else : (urcorner p -- ulcorner p) fi enddef ;
1384vardef leftboundary   primary p = if pair p : p else : (ulcorner p -- llcorner p) fi enddef ;
1385
1386permanent bottomboundary, rightboundary, topboundary, leftboundary ;
1387
1388%D Nice too:
1389
1390primarydef p superellipsed s =
1391    superellipse (
1392        .5[lrcorner p,urcorner p],
1393        .5[urcorner p,ulcorner p],
1394        .5[ulcorner p,llcorner p],
1395        .5[llcorner p,lrcorner p],
1396        s
1397    )
1398enddef ;
1399
1400primarydef p squeezed s = (
1401    (llcorner p .. .5[llcorner p,lrcorner p] shifted ( 0, ypart paired(s)) .. lrcorner p) &
1402    (lrcorner p .. .5[lrcorner p,urcorner p] shifted (-xpart paired(s), 0) .. urcorner p) &
1403    (urcorner p .. .5[urcorner p,ulcorner p] shifted ( 0,-ypart paired(s)) .. ulcorner p) &
1404    (ulcorner p .. .5[ulcorner p,llcorner p] shifted ( xpart paired(s), 0) .. llcorner p) & cycle
1405) enddef ;
1406
1407primarydef p randomshifted s =
1408    begingroup ;
1409    save ss ; pair ss ;
1410    ss := paired(s) ;
1411    p shifted (-.5xpart ss + uniformdeviate xpart ss,-.5ypart ss + uniformdeviate ypart ss)
1412    endgroup
1413enddef ;
1414
1415% vardef mfun_randomized_path(expr p,s) =
1416%     for i=0 upto length(p)-1 :
1417%          (point       i    of p) .. controls
1418%         ((postcontrol i    of p) randomshifted s) and
1419%         ((precontrol (i+1) of p) randomshifted s) ..
1420%     endfor
1421%     if cycle p :
1422%         cycle
1423%     else :
1424%         (point length(p) of p)
1425%     fi
1426% enddef;
1427%
1428% Here is a Mikael Sundqvist improved version. This time we also use
1429% some new functionality.
1430
1431vardef mfun_randomized_path(expr p,s) =
1432    save r, oldr, newr, firstr, l ; pair r, oldr, newr, firstr ;
1433    r := paired(s) ;
1434    l := length(p) ;
1435    newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ;
1436    firstr := newr ;
1437    for i within p :
1438        hide (
1439            oldr := newr ;
1440            newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ;
1441        )
1442        pathpoint ..
1443        controls  (pathpostcontrol shifted oldr )
1444        and      ((deltaprecontrol 1) shifted if (i <> l - 1) : - newr else : - firstr fi) ..
1445    endfor if cycle p : cycle else : nocycle fi
1446enddef ;
1447
1448
1449vardef mfun_randomrotated_path(expr p, s) =
1450    save r, oldr, newr, firstr, l ;
1451    l := length(p) ;
1452    newr := (-1/2+uniformdeviate(1))*s ;
1453    firstr := newr ;
1454    for i within p :
1455        hide (
1456            oldr := newr ;
1457            newr := (-1/2+uniformdeviate(1)) * s ;
1458        )
1459        pathpoint ..
1460        controls  (pathpostcontrol rotatedaround(pathpoint, oldr) )
1461        and      ((deltaprecontrol 1) rotatedaround(deltapoint 1, if (i <> l - 1) : newr else : firstr fi)) ..
1462    endfor if cycle p : cycle else : nocycle fi
1463enddef ;
1464
1465vardef mfun_randomized_picture(expr p,s)(text rnd) =
1466    save currentpicture ;
1467    picture currentpicture ;
1468    currentpicture := nullpicture ;
1469    for i within p :
1470        addto currentpicture
1471            if stroked i :
1472                doublepath pathpart i rnd s
1473                dashed dashpart i
1474                withpen penpart i
1475                withcolor colorpart i
1476                withprescript prescriptpart i
1477                withpostscript postscriptpart i
1478            elseif filled i :
1479                contour pathpart i rnd s
1480                withpen penpart i
1481                withcolor colorpart i
1482                withprescript prescriptpart i
1483                withpostscript postscriptpart i
1484            else :
1485                also i
1486            fi
1487        ;
1488    endfor ;
1489    currentpicture
1490enddef ;
1491
1492primarydef p randomizedcontrols s = (
1493    if path p :
1494        mfun_randomized_path(p,s)
1495    elseif picture p :
1496        mfun_randomized_picture(p,s)(randomizedcontrols)
1497    else :
1498        p randomized s
1499    fi
1500) enddef ;
1501
1502primarydef p randomrotatedcontrols s = (
1503    if path p :
1504        mfun_randomrotated_path(p,s)
1505    elseif picture p :
1506        mfun_randomized_picture(p,s)(randomrotatedcontrols)
1507    else :
1508        p randomized s
1509    fi
1510) enddef ;
1511
1512primarydef p randomized s = (
1513    if path p :
1514        for i=0 upto length(p)-1 :
1515            ((point       i    of p) randomshifted s) .. controls
1516            ((postcontrol i    of p) randomshifted s) and
1517            ((precontrol (i+1) of p) randomshifted s) ..
1518        endfor
1519        if cycle p :
1520            cycle
1521        else :
1522            ((point length(p) of p) randomshifted s)
1523        fi
1524    elseif pair p :
1525        p randomshifted s
1526    elseif cmykcolor p :
1527        if cmykcolor s :
1528           ((uniformdeviate cyanpart    s) * cyanpart    p,
1529            (uniformdeviate magentapart s) * magentapart p,
1530            (uniformdeviate yellowpart  s) * yellowpart  p,
1531            (uniformdeviate blackpart   s) * blackpart   p)
1532        elseif pair s :
1533            ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1534        else :
1535            ((uniformdeviate s) * p)
1536        fi
1537    elseif rgbcolor p :
1538        if rgbcolor s :
1539           ((uniformdeviate redpart   s) * redpart   p,
1540            (uniformdeviate greenpart s) * greenpart p,
1541            (uniformdeviate bluepart  s) * bluepart  p)
1542        elseif pair s :
1543           ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1544        else :
1545           ((uniformdeviate s) * p)
1546        fi
1547    elseif color p :
1548        if color s :
1549            ((uniformdeviate greypart s) * greypart p)
1550        elseif pair s :
1551            ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1552        else :
1553            ((uniformdeviate s) * p)
1554        fi
1555    elseif string p :
1556        (resolvedcolor(p)) randomized s
1557    elseif picture p :
1558        mfun_randomized_picture(p,s)(randomized)
1559    else :
1560      % p - s/2 + uniformdeviate s % would have been better but we want to be positive
1561        p + uniformdeviate s
1562    fi
1563) enddef ;
1564
1565permanent superellipsed, squeezed, randomshifted, randomized,
1566    randomizedcontrols, randomrotatedcontrols ;
1567
1568%D Not perfect (alternative for interpath)
1569
1570vardef interpolated(expr s, p, q) =
1571    save m ; numeric m ;
1572    m := max(length(p),length(q)) ;
1573    if path p :
1574        for i=0 upto m-1 :
1575            s[point       (i   /m) along p,point       (i   /m) along q] .. controls
1576            s[postcontrol (i   /m) along p,postcontrol (i   /m) along q] and
1577            s[precontrol ((i+1)/m) along p,precontrol ((i+1)/m) along q] ..
1578        endfor
1579        if cycle p :
1580            cycle
1581        else :
1582            s[point infinity of p,point infinity of q]
1583        fi
1584    else :
1585        a[p,q]
1586    fi
1587enddef ;
1588
1589permanent interpolated ;
1590
1591%D Interesting too:
1592
1593% primarydef p paralleled d = (
1594%     p shifted if d < 0 : - fi ((point abs(d) on (p rotatedaround(point 0 of p,90))) - point 0 of p)
1595% ) enddef ;
1596%
1597% primarydef p paralleled d = (
1598%     p shifted ((d*unitvector(direction 0 of p) - point 0 of p) rotated 90)
1599% ) enddef ;
1600
1601%D Alan came up with an improved version and stepwise we ended up with (or might up
1602%D with a variant of):
1603
1604def istextext(expr p) =
1605    (picture p and ((substring(0,3) of prescriptpart p) = "tx_"))
1606enddef ;
1607
1608vardef perpendicular expr t of p =
1609    unitvector((direction t of p) rotated 90)
1610enddef ;
1611
1612primarydef p paralleled d = (
1613    if path p :
1614        begingroup ;
1615        save dp ; pair dp ;
1616        for i=0 upto length p if cycle p : -1 fi :
1617            hide(dp := d * perpendicular i of p)
1618            if i > 0 : .. fi
1619            (point i of p + dp)
1620            if i < length p :
1621                .. controls (postcontrol i    of p + dp) and
1622                            (precontrol (i+1) of p + dp)
1623            fi
1624        endfor
1625        if cycle p : .. cycle fi
1626        endgroup
1627    elseif picture p :
1628        image(
1629            for i within p :
1630                draw (pathpart i)
1631                if not istextext(i) : % dirty trick
1632                    paralleled d
1633                fi
1634                mfun_decoration_i i ;
1635            endfor ;
1636        )
1637    elseif pair p :
1638        p
1639    fi
1640) enddef ;
1641
1642vardef punked primary p =
1643    point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor
1644    if cycle p : -- cycle else : -- point length(p) of p fi
1645enddef ;
1646
1647vardef curved primary p =
1648    point 0 of p for i=1 upto length(p)-1 : .. point i of p endfor
1649    if cycle p : .. cycle else : .. point length(p) of p fi
1650enddef ;
1651
1652primarydef p blownup s =
1653    begingroup
1654        save temp_p ; path temp_p ;
1655        temp_p := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ;
1656        (temp_p shifted (center p - center temp_p))
1657    endgroup
1658enddef ;
1659
1660permanent perpendicular, istextext, paralleled, punked, curved, blownup ;
1661
1662%D Rather fundamental.
1663
1664% not yet ok
1665
1666vardef mfun_left_right_path(expr p, l) = % used in s-pre-19
1667    save q, r, t, b ; path q, r ; pair t, b ;
1668    t := (ulcorner p -- urcorner p) intersection_point p ;
1669    b := (llcorner p -- lrcorner p) intersection_point p ;
1670    r := if xpart directionpoint t of p < 0 : reverse p else : p fi ; % r is needed, else problems when reverse is fed
1671    q := r cutbefore if l: t else: b fi ;
1672    q := q if xpart point 0 of r > 0 : & r fi cutafter  if l: b else: t fi ;
1673    q
1674enddef ;
1675
1676vardef  leftpath expr p = mfun_left_right_path(p,true ) enddef ;
1677vardef rightpath expr p = mfun_left_right_path(p,false) enddef ;
1678
1679permanent leftpath, rightpath ;
1680
1681%D Drawoptions
1682
1683def saveoptions =
1684    save base_draw_options ; def base_draw_options = enddef ;
1685enddef ;
1686
1687permanent saveoptions ;
1688
1689%D Tracing. (not yet in lexer)
1690
1691let normaldraw = draw ;
1692let normalfill = fill ;
1693
1694% bugged in mplib so ...
1695
1696def normalfill expr c = addto currentpicture contour c base_draw_options enddef ;
1697def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi base_draw_options enddef ;
1698
1699def drawlineoptions   (text t) = def mfun_opt_lin = t enddef ; enddef ;
1700def drawpointoptions  (text t) = def mfun_opt_pnt = t enddef ; enddef ;
1701def drawcontroloptions(text t) = def mfun_opt_ctr = t enddef ; enddef ;
1702def drawlabeloptions  (text t) = def mfun_opt_lab = t enddef ; enddef ;
1703def draworiginoptions (text t) = def mfun_opt_ori = t enddef ; enddef ;
1704def drawboundoptions  (text t) = def mfun_opt_bnd = t enddef ; enddef ;
1705def drawpathoptions   (text t) = def mfun_opt_pth = t enddef ; enddef ;
1706
1707numeric drawoptionsfactor ; drawoptionsfactor := pt ;
1708
1709def resetdrawoptions =
1710    drawlineoptions   (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1711    drawpointoptions  (withpen pencircle scaled 4.0 drawoptionsfactor withcolor   black) ;
1712    drawcontroloptions(withpen pencircle scaled 2.5 drawoptionsfactor withcolor   black) ;
1713    drawlabeloptions  () ;
1714    draworiginoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1715    drawboundoptions  (dashed evenly mfun_opt_ori) ;
1716    drawpathoptions   (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ;
1717enddef ;
1718
1719resetdrawoptions ;
1720
1721%D Path.
1722
1723def drawpath expr p =
1724    normaldraw p mfun_opt_pth
1725enddef ;
1726
1727permanent
1728    drawlineoptions, drawpointoptions, drawcontroloptions, drawlabeloptions, draworiginoptions,
1729    drawboundoptions, drawpathoptions, drawpath, normaldraw ;
1730
1731%D Arrow.
1732
1733newinternal ahvariant ; ahvariant := 0 ;
1734newinternal ahdimple  ; ahdimple  := 1/5 ;
1735newinternal ahscale   ; ahscale   := 3/4 ;
1736
1737permanent ahvariant, ahdimple, ahscale ;
1738
1739vardef arrowhead expr p =
1740     save q, e, r ;
1741     pair e ; e = point length p of p ;
1742     path q ; q = gobble(p shifted -e cutafter makepath(pencircle scaled (2ahlength))) cuttings ;
1743     if ahvariant > 0:
1744         path r ; r = gobble(p shifted -e cutafter makepath(pencircle scaled ((1-ahdimple)*2ahlength))) cuttings ;
1745     fi
1746     (q rotated (ahangle/2) & reverse q rotated -(ahangle/2)
1747         if ahvariant = 1 :
1748             -- point 0 of r --
1749         elseif ahvariant = 2 :
1750             ... point 0 of r ...
1751         else :
1752         --
1753         fi
1754         cycle
1755     ) shifted e
1756enddef ;
1757
1758vardef drawarrowpath expr p =
1759%     save autoarrows ; boolean autoarrows ; autoarrows := true ;
1760    interim autoarrows := true ;
1761    drawarrow p mfun_opt_pth
1762enddef ;
1763
1764def midarrowhead expr p =
1765    arrowhead p cutafter (point length(p cutafter point .5 along p) + ahlength on p)
1766enddef ;
1767
1768vardef arrowheadonpath (expr p, s) =
1769%     save autoarrows ; boolean autoarrows ;
1770    interim autoarrows := true ;
1771    set_ahlength(scaled ahfactor) ; % added
1772    arrowhead p if s < 1 : cutafter (point (s*arclength(p) + (ahlength/2)) on p) fi
1773enddef ;
1774
1775def resetarrows =
1776    hide (
1777        ahlength  := 4 ;
1778        ahangle   := 45 ;
1779        ahvariant := 0 ;
1780        ahdimple  := 1/5 ;
1781        ahscale   := 3/4 ;
1782)
1783enddef ;
1784
1785permanent arrowhead, drawarrowpath, midarrowhead, arrowheadonpath ;
1786
1787%D Points.
1788
1789vardef dotlabel@#(expr s,z) text t =
1790    label@#(s,z) t ;
1791    interim linecap := rounded ;
1792    normaldraw z withpen pencircle scaled dotlabeldiam t ;
1793enddef ;
1794
1795def drawpoint expr c =
1796    if string c :
1797        string temp_c ;
1798        temp_c := "(" & c & ")" ;
1799        dotlabel.urt(temp_c, scantokens temp_c) ;
1800        drawdot scantokens temp_c
1801    else :
1802        dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ;
1803        drawdot c
1804    fi mfun_opt_pnt
1805enddef ;
1806
1807%D PathPoints.
1808
1809def drawpoints        expr c = path temp_c ; temp_c := c ; mfun_draw_points        enddef ;
1810def drawcontrolpoints expr c = path temp_c ; temp_c := c ; mfun_draw_controlpoints enddef ;
1811def drawcontrollines  expr c = path temp_c ; temp_c := c ; mfun_draw_controllines  enddef ;
1812def drawpointlabels   expr c = path temp_c ; temp_c := c ; mfun_draw_pointlabels   enddef ;
1813
1814def mfun_draw_points text t =
1815    for i within temp_c :
1816        normaldraw pathpoint mfun_opt_pnt t ;
1817    endfor ;
1818enddef;
1819
1820% def mfun_draw_controlpoints text t =
1821%     for i within temp_c :
1822%         normaldraw pathprecontrol  t mfun_opt_ctr t ;
1823%         normaldraw pathpostcontrol t mfun_opt_ctr t ;
1824%     endfor ;
1825% enddef;
1826
1827% def mfun_draw_controllines text t =
1828%     for i within temp_c :
1829%         normaldraw pathpoint -- pathprecontrol  t mfun_opt_lin t ;
1830%         normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ;
1831%     endfor ;
1832% enddef;
1833
1834def mfun_draw_controlpoints text t =
1835    for i within temp_c :
1836        if (pathstate == 0) or (pathstate == 2) :
1837            normaldraw pathprecontrol  t mfun_opt_ctr t ;
1838        fi ;
1839        if (pathstate == 0) or (pathstate == 1) :
1840            normaldraw pathpostcontrol t mfun_opt_ctr t ;
1841        fi ;
1842    endfor ;
1843enddef;
1844
1845def mfun_draw_controllines text t =
1846    for i within temp_c :
1847        if (pathstate == 0) or (pathstate == 2) :
1848            normaldraw pathpoint -- pathprecontrol  t mfun_opt_lin t ;
1849        fi ;
1850        if (pathstate == 0) or (pathstate == 1) :
1851            normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ;
1852        fi ;
1853    endfor ;
1854enddef;
1855
1856boolean swappointlabels ; swappointlabels := false ;
1857numeric pointlabelscale ; pointlabelscale := 0 ;
1858string  pointlabelfont  ; pointlabelfont  := "" ;
1859
1860def mfun_draw_pointlabels text asked_options =
1861    % todo: for i within temp_c : pathdirection
1862    for i=0 upto length(temp_c) if cycle temp_c : -1 fi :
1863        pair temp_u ; temp_u := unitvector(direction i of temp_c) rotated if swappointlabels : - fi 90 ;
1864        pair temp_p ; temp_p := (point i of temp_c) ;
1865        begingroup ;
1866        if pointlabelscale > 0 :
1867            save defaultscale ; numeric defaultscale ;
1868            defaultscale := pointlabelscale ;
1869        fi ;
1870        if pointlabelfont <> "" :
1871            save defaultfont ; string defaultfont ;
1872            defaultfont := pointlabelfont ;
1873        fi ;
1874        temp_u := 10 * drawoptionsfactor * defaultscale * temp_u ;
1875        normaldraw thelabel ( decimal i, temp_p shifted if cycle temp_c and (i=0) : - fi temp_u ) mfun_opt_lab asked_options ;
1876        endgroup ;
1877    endfor ;
1878enddef;
1879
1880%D Bounding box.
1881
1882def drawboundingbox expr p =
1883    normaldraw boundingbox p mfun_opt_bnd
1884enddef ;
1885
1886%D Origin.
1887
1888numeric originlength ; originlength := .5cm ;
1889
1890def draworigin text t =
1891    normaldraw (origin shifted (0, originlength) -- origin shifted (0,-originlength)) mfun_opt_ori t ;
1892    normaldraw (origin shifted ( originlength,0) -- origin shifted (-originlength,0)) mfun_opt_ori t ;
1893enddef;
1894
1895permanent dotlabel, swappointlabels, pointlabelscale, pointlabelfont ;
1896permanent drawboundingbox, drawpoints, drawcontrolpoints, drawcontrollines, drawpointlabels, draworigin ;
1897
1898%D Axis.
1899
1900numeric tickstep   ; tickstep   := 5mm ;
1901numeric ticklength ; ticklength := 2mm ;
1902
1903def drawxticks expr c = path temp_c ; temp_c := c ; mfun_draw_xticks enddef ;
1904def drawyticks expr c = path temp_c ; temp_c := c ; mfun_draw_yticks enddef ;
1905def drawticks  expr c = path temp_c ; temp_c := c ; mfun_draw_ticks  enddef ;
1906
1907% Adding eps prevents disappearance due to rounding errors.
1908
1909def mfun_draw_xticks text t =
1910    for i=0 step -tickstep until xpart llcorner temp_c - eps :
1911        if (i<=xpart lrcorner temp_c) :
1912        normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ;
1913        fi ;
1914    endfor ;
1915    for i=0 step  tickstep until xpart lrcorner temp_c + eps :
1916        if (i>=xpart llcorner temp_c) :
1917            normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ;
1918        fi ;
1919    endfor ;
1920    normaldraw (llcorner temp_c -- ulcorner temp_c) shifted (-xpart llcorner temp_c,0) mfun_opt_ori t ;
1921enddef ;
1922
1923def mfun_draw_yticks text t =
1924    for i=0 step -tickstep until ypart llcorner temp_c - eps :
1925        if (i<=ypart ulcorner temp_c) :
1926            normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1927        fi ;
1928    endfor ;
1929    for i=0 step  tickstep until ypart ulcorner temp_c + eps :
1930        if (i>=ypart llcorner temp_c) :
1931            normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1932        fi ;
1933    endfor ;
1934    normaldraw (llcorner temp_c -- lrcorner temp_c) shifted (0,-ypart llcorner temp_c) mfun_opt_ori t ;
1935enddef ;
1936
1937def mfun_draw_ticks text t =
1938    drawxticks temp_c t ;
1939    drawyticks temp_c t ;
1940enddef ;
1941
1942%D All of it except axis.
1943
1944def drawwholepath expr p =
1945    draworigin          ;
1946    drawpath          p ;
1947    drawcontrollines  p ;
1948    drawcontrolpoints p ;
1949    drawpoints        p ;
1950    drawboundingbox   p ;
1951    drawpointlabels   p ;
1952enddef ;
1953
1954def drawpathonly expr p =
1955    drawpath          p ;
1956    drawcontrollines  p ;
1957    drawcontrolpoints p ;
1958    drawpoints        p ;
1959    drawpointlabels   p ;
1960enddef ;
1961
1962%D Tracing.
1963
1964def visualizeddraw expr c =
1965    if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_visualizeddraw fi
1966enddef ;
1967
1968def visualizedfill expr c =
1969    if picture c : normalfill c else : path temp_c ; temp_c := c ; do_visualizedfill fi
1970enddef ;
1971
1972def do_visualizeddraw text t =
1973    draworigin            ;
1974    drawpath          temp_c t ;
1975    drawcontrollines  temp_c ;
1976    drawcontrolpoints temp_c ;
1977    drawpoints        temp_c ;
1978    drawboundingbox   temp_c ;
1979    drawpointlabels   temp_c ;
1980enddef ;
1981
1982def do_visualizedfill text t =
1983    if cycle temp_c : normalfill temp_c t fi ;
1984    draworigin            ;
1985    drawcontrollines  temp_c ;
1986    drawcontrolpoints temp_c ;
1987    drawpoints        temp_c ;
1988    drawboundingbox   temp_c ;
1989    drawpointlabels   temp_c ;
1990enddef ;
1991
1992def detaileddraw expr c =
1993    if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_detaileddraw fi
1994enddef ;
1995
1996def do_detaileddraw text t =
1997    drawpath          temp_c t ;
1998    drawcontrollines  temp_c ;
1999    drawcontrolpoints temp_c ;
2000    drawpoints        temp_c ;
2001  % % for labels we need an third run (as the second will mark the numbers); i could preroll them
2002  % % but then the hash needs to handle that as well (as now we keep numbering)
2003  % drawpointlabels   temp_c ;
2004enddef ;
2005
2006def visualizepaths =
2007    let fill = visualizedfill ;
2008    let draw = visualizeddraw ;
2009enddef ;
2010
2011def detailpaths =
2012    let draw = detaileddraw ;
2013enddef ;
2014
2015def naturalizepaths =
2016    let fill = normalfill ;
2017    let draw = normaldraw ;
2018enddef ;
2019
2020extra_endfig := extra_endfig & " naturalizepaths ; " ;
2021
2022permanent
2023    visualizeddraw, detaileddraw, visualizedfill,
2024    visualizepaths, detailpaths, naturalizepaths ;
2025
2026%D Nice tracer:
2027
2028def drawboundary primary p =
2029    draw p dashed evenly withcolor white ;
2030    draw p dashed oddly  withcolor black ;
2031    draw (- llcorner p) withpen pencircle scaled 3   withcolor white ;
2032    draw (- llcorner p) withpen pencircle scaled 1.5 withcolor black ;
2033enddef ;
2034
2035permanent drawboundary ;
2036
2037%D Also handy:
2038
2039extra_beginfig := extra_beginfig & " truecorners :=  0 ; "   ; % restores
2040extra_beginfig := extra_beginfig & " miterlimit  := 10 ; "   ; % restores
2041extra_beginfig := extra_beginfig & " linejoin := rounded ; " ; % restores
2042extra_beginfig := extra_beginfig & " linecap  := rounded ; " ; % restores
2043
2044%D Normally, arrowheads don't scale well. So we provide a hack.
2045
2046% boolean autoarrows ; autoarrows := false ;  % todo: newinternal boolean autoarrows ;
2047numeric ahfactor   ; ahfactor   := 2.5 ;    % todo: newinternal         ahfactor ;
2048
2049newinternal boolean autoarrows ;
2050
2051permanent ahfactor, ahlength, autoarrows ;
2052
2053def set_ahlength (text t) = % called to often
2054  % ahlength := (ahfactor*pen_size(base_draw_options t)) ; % base_draw_options added
2055  % problem: base_draw_options can contain color so a no-go, we could apply the transform
2056  % but i need to figure out the best way (fakepicture and take components).
2057    ahlength := (ahfactor*pen_size(t)) ;
2058enddef ;
2059
2060vardef pen_size (text t) =
2061    save p ; picture p ; p := nullpicture ;
2062    addto p doublepath (top origin -- bot origin) t ;
2063    (ypart urcorner p - ypart lrcorner p)
2064enddef ;
2065
2066%D The next two macros are adapted versions of plain
2067%D \METAPOST\ definitions.
2068
2069vardef arrowpath expr p = % patch by Peter Rolf: supports squared pen and shifting (hh: maybe just use center of head as first)
2070    (p cutafter makepath(pencircle
2071        scaled (if ahvariant > 0 : (1-ahdimple)* fi 2ahlength*cosd(ahangle/2))
2072        shifted point length p of p
2073    ))
2074enddef;
2075
2076permanent arrowpath ;
2077
2078% New experimental extension: also handling pictures:
2079%
2080% drawarrow fullsquare scaled 2cm withcolor green ;
2081% drawarrow fullcircle scaled 3cm withcolor green ;
2082% drawarrow image (
2083%     draw fullsquare scaled 4cm withcolor red ;
2084%     draw fullcircle scaled 5cm withcolor blue ;
2085% ) ;
2086% currentpicture := currentpicture shifted (-bbwidth(currentpicture)-1cm,0) ;
2087% drawdblarrow fullsquare scaled 2cm withcolor green ;
2088% drawdblarrow fullcircle scaled 3cm withcolor green ;
2089% drawdblarrow image (
2090%     draw fullsquare scaled 4cm withcolor red ;
2091%     draw fullcircle scaled 5cm withcolor blue ;
2092% ) ;
2093
2094vardef stroked_paths(expr p) =
2095    save n ; numeric n ; n := 0 ;
2096    for i within p :
2097        if stroked i :
2098            n := n + 1 ;
2099        fi
2100    endfor ;
2101    n
2102enddef ;
2103
2104def mfun_decoration_i expr i =
2105    withpen penpart i
2106    withcolor colorpart i
2107    withprescript prescriptpart i
2108    withpostscript postscriptpart i
2109enddef ;
2110
2111%D We could collapse all in one helper but in context we nowaways don't want the added
2112%D obscurity. Tokens come cheap.
2113
2114numeric mfun_arrow_snippets ;
2115numeric mfun_arrow_count ;
2116
2117def drawarrow expr p =
2118    begingroup ;
2119    save mfun_arrow_path ;
2120    path mfun_arrow_path ;
2121    if path p :
2122        mfun_arrow_path := p ;
2123        expandafter mfun_draw_arrow_path
2124    elseif picture p :
2125        save mfun_arrow_picture ;
2126        picture mfun_arrow_picture ;
2127        mfun_arrow_picture := p ;
2128        expandafter mfun_draw_arrow_picture
2129    else :
2130        expandafter mfun_draw_arrow_nothing
2131    fi
2132enddef ;
2133
2134def drawdblarrow expr p =
2135    begingroup ;
2136    save mfun_arrow_path ;
2137    path mfun_arrow_path ;
2138    if path p :
2139        mfun_arrow_path := p ;
2140        expandafter mfun_draw_arrow_path_double
2141    elseif picture p :
2142        save mfun_arrow_picture ;
2143        picture mfun_arrow_picture ;
2144        mfun_arrow_picture := p ;
2145        expandafter mfun_draw_arrow_picture_double
2146    else :
2147        expandafter mfun_draw_arrow_nothing
2148    fi
2149enddef ;
2150
2151def mfun_draw_arrow_nothing text t =
2152enddef ;
2153
2154%D The path is shortened so that the arrow head extends it to the original length. In
2155%D case of a double arrow the path gets shortened twice.
2156
2157def mfun_draw_arrow_path text t =
2158    if autoarrows :
2159        set_ahlength(t) ;
2160    fi
2161    draw arrowpath mfun_arrow_path t ;
2162    fillup arrowhead mfun_arrow_path t ;
2163    endgroup ;
2164enddef ;
2165
2166def mfun_draw_arrow_path_double text t =
2167    if autoarrows :
2168        set_ahlength(t) ;
2169    fi
2170    draw arrowpath (reverse arrowpath mfun_arrow_path) t ;
2171    fillup arrowhead mfun_arrow_path t ;
2172    fillup arrowhead reverse mfun_arrow_path t ;
2173    endgroup ;
2174enddef ;
2175
2176%D The picture variant is not treating each path but only the first and last path. This
2177%D can be somewhat counterintuitive but is needed for Alan's macros. So here the last
2178%D and in case of a double path first paths in a icture get the shortening.
2179
2180def mfun_with_arrow_picture (text t) =
2181    mfun_arrow_count := 0 ;
2182    mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ;
2183    for i within mfun_arrow_picture :
2184        if istextext(i) :
2185            draw i
2186        else :
2187            mfun_arrow_count := mfun_arrow_count + 1 ;
2188            mfun_arrow_path := pathpart i ;
2189            t
2190        fi ;
2191    endfor ;
2192enddef ;
2193
2194def mfun_draw_arrow_picture text t =
2195    if autoarrows :
2196        set_ahlength(t) ;
2197    fi
2198    mfun_with_arrow_picture (
2199        if mfun_arrow_count = mfun_arrow_snippets :
2200            draw arrowpath mfun_arrow_path mfun_decoration_i i t ;
2201            fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2202        else :
2203            draw mfun_arrow_path mfun_decoration_i i t ;
2204        fi ;
2205    )
2206    endgroup ;
2207enddef ;
2208
2209def mfun_draw_arrow_picture_double text t =
2210    if autoarrows :
2211        set_ahlength(t) ;
2212    fi
2213    mfun_with_arrow_picture (
2214        draw
2215        if mfun_arrow_count = 1 :
2216            arrowpath reverse
2217        elseif mfun_arrow_count = mfun_arrow_snippets :
2218            arrowpath
2219        fi
2220        mfun_arrow_path mfun_decoration_i i t ;
2221        if mfun_arrow_count = 1 :
2222            fillup arrowhead reverse mfun_arrow_path mfun_decoration_i i t ;
2223        fi
2224        if mfun_arrow_count = mfun_arrow_snippets :
2225            fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2226        fi
2227    )
2228    endgroup ;
2229enddef ;
2230
2231%D Some more arrow magic, by Alan:
2232
2233let drawdoublearrow = drawdblarrow ;
2234
2235def drawdoublearrows expr p =
2236    begingroup ;
2237    save mfun_arrow_path ;
2238    path mfun_arrow_path ;
2239    save mfun_arrow_path_parallel ;
2240    path mfun_arrow_path_parallel ;
2241    if path p :
2242        mfun_arrow_path := p ;
2243        expandafter mfun_draw_arrow_paths
2244    elseif picture p :
2245        save mfun_arrow_picture ;
2246        picture mfun_arrow_picture ;
2247        mfun_arrow_picture := p ;
2248        expandafter mfun_draw_arrow_pictures
2249    else :
2250        expandafter mfun_draw_arrow_nothing
2251    fi
2252enddef ;
2253
2254def mfun_draw_arrow_paths text t =
2255    if autoarrows :
2256        set_ahlength(t) ;
2257    fi
2258    save d ; d := ahscale*ahlength*sind(ahangle/2) ;
2259    mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2260    draw   arrowpath mfun_arrow_path_parallel t ;
2261    fillup arrowhead mfun_arrow_path_parallel t ;
2262    mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2263    draw   arrowpath mfun_arrow_path_parallel t ;
2264    fillup arrowhead mfun_arrow_path_parallel t ;
2265    endgroup ;
2266enddef ;
2267
2268def mfun_draw_arrow_pictures text t =
2269    if autoarrows :
2270        set_ahlength(t) ;
2271    fi
2272    save d ; d := ahscale*ahlength*sind(ahangle/2) ;
2273    mfun_with_arrow_picture(
2274        if mfun_arrow_count = 1 :
2275            draw (mfun_arrow_path  paralleled d)          mfun_decoration_i i t ;
2276            mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2277            draw   arrowpath mfun_arrow_path_parallel     mfun_decoration_i i t ;
2278            fillup arrowhead mfun_arrow_path_parallel     mfun_decoration_i i t ;
2279        elseif mfun_arrow_count = mfun_arrow_snippets :
2280            draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2281            mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2282            draw   arrowpath mfun_arrow_path_parallel     mfun_decoration_i i t ;
2283            fillup arrowhead mfun_arrow_path_parallel     mfun_decoration_i i t ;
2284        else :
2285            draw (         mfun_arrow_path  paralleled d) mfun_decoration_i i t ;
2286            draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2287        fi
2288    )
2289    endgroup ;
2290enddef ;
2291
2292%D Handy too ......
2293
2294vardef pointarrow (expr pat, loc, len, off) =
2295    save l, r, s, t ; path l, r ; numeric s ; pair t ;
2296    t := if pair loc : loc else : point loc along pat fi ;
2297    s := len/2 - off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2298    r := pat cutbefore t ;
2299    r := (r cutafter point (arctime s of r) of r) ;
2300    s := len/2 + off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2301    l := reverse (pat cutafter t) ;
2302    l := (reverse (l cutafter point (arctime s of l) of l)) ;
2303    (l..r)
2304enddef ;
2305
2306def rightarrow  (expr pat,tim,len) = pointarrow(pat,tim,len,-len) enddef ;
2307def leftarrow   (expr pat,tim,len) = pointarrow(pat,tim,len,+len) enddef ;
2308def centerarrow (expr pat,tim,len) = pointarrow(pat,tim,len,   0) enddef ;
2309
2310permanent drawarrow, drawdblarrow, drawdoublearrows, drawdoublearrow, pointarrow, rightarrow, leftarrow, centerarrow ;
2311
2312%D The \type {along} and \type {on} operators can be used as follows:
2313%D
2314%D \starttyping
2315%D drawdot point .5  along somepath ;
2316%D drawdot point 3cm on    somepath ;
2317%D \stoptyping
2318%D
2319%D The number denotes a percentage (fraction).
2320
2321primarydef pct along pat = % also negative
2322    (arctime (pct * (arclength pat)) of pat) of pat
2323enddef ;
2324
2325primarydef len on pat = % no outer ( ) .. somehow fails
2326    (arctime if len>=0 : len else : (arclength(pat)+len) fi of pat) of pat
2327enddef ;
2328
2329% this cuts of a piece from both ends
2330
2331tertiarydef pat cutends len =
2332    begingroup
2333    save tap ; path tap ;
2334    tap := pat cutbefore (point (xpart paired(len)) on pat) ;
2335    (tap cutafter (point -(ypart paired(len)) on tap))
2336    endgroup
2337enddef ;
2338
2339permanent along, on, cutends ;
2340
2341%D To be documented.
2342
2343path freesquare ; freesquare := (
2344    (-1,0) -- (-1,-1) -- (0,-1) -- (+1,-1) --
2345    (+1,0) -- (+1,+1) -- (0,+1) -- (-1,+1) -- cycle
2346) scaled .5 ;
2347
2348numeric freelabeloffset  ; freelabeloffset  := 3pt ;
2349numeric freedotlabelsize ; freedotlabelsize := 3pt ;
2350
2351vardef thefreelabel (expr asked_text, asked_location, asked_origin) =
2352    save s, p, q, l ; picture s ; path p, q ; pair l ;
2353    interim labeloffset := freelabeloffset ;
2354    s := if string asked_text : thelabel(asked_text,asked_location) else : asked_text shifted -center asked_text shifted asked_location fi ;
2355    setbounds s to boundingbox s enlarged freelabeloffset ;
2356    p := fullcircle scaled (2*length(asked_location-asked_origin)) shifted asked_origin ;
2357    q := freesquare xyscaled (urcorner s - llcorner s) ;
2358    l := point xpart (p intersectiontimes (asked_origin--asked_location shifted (asked_location-asked_origin))) of q ;
2359    setbounds s to boundingbox s enlarged -freelabeloffset ; % new
2360  % draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ;
2361    (s shifted -l)
2362enddef ;
2363
2364vardef freelabel (expr asked_text, asked_location, asked_origin) =
2365    draw thefreelabel(asked_text,asked_location,asked_origin) ;
2366enddef ;
2367
2368vardef freedotlabel (expr asked_text, asked_location, asked_origin) =
2369    interim linecap := rounded ;
2370    draw asked_location withpen pencircle scaled freedotlabelsize ;
2371    draw thefreelabel(asked_text,asked_location,asked_origin) ;
2372enddef ;
2373
2374immutable freesquare ;
2375permanent freelabeloffset, freedotlabelsize, thefreelabel, freelabel, freedotlabel ;
2376
2377%D \starttyping
2378%D drawarrow anglebetween(line_a,line_b,somelabel) ;
2379%D \stoptyping
2380
2381newinternal angleoffset ; angleoffset :=  0pt ;
2382newinternal anglelength ; anglelength := 20pt ;
2383newinternal anglemethod ; anglemethod :=    1 ;
2384
2385vardef anglebetween (expr a, b, s) = % path path string
2386    save pointa, pointb, common, middle, offset ;
2387    pair pointa, pointb, common, middle, offset ;
2388    save curve ; path curve ;
2389    save where ; numeric where ;
2390    if round point 0 of a = round point 0 of b :
2391        common := point 0 of a ;
2392    else :
2393        common := a intersectionpoint b ;
2394    fi ;
2395    pointa := point anglelength on a ;
2396    pointb := point anglelength on b ;
2397    where  := turningnumber (common--pointa--pointb--cycle) ;
2398    middle := (reverse(common--pointa) rotatedaround (pointa,-where*90))
2399        intersection_point
2400        (reverse(common--pointb) rotatedaround (pointb, where*90)) ;
2401    if not intersection_found :
2402        middle := point .5 along
2403        ((reverse(common--pointa) rotatedaround (pointa,-where*90)) --
2404        (       (common--pointb) rotatedaround (pointb, where*90))) ;
2405    fi ;
2406    if     anglemethod = 0 :
2407        curve  := pointa{unitvector(middle-pointa)}.. pointb;
2408        middle := point .5 along curve ;
2409        curve  := common ;
2410    elseif anglemethod = 1 :
2411        curve  := pointa{unitvector(middle-pointa)}.. pointb;
2412        middle := point .5 along curve ;
2413    elseif anglemethod = 2 :
2414        middle := common rotatedaround(.5[pointa,pointb],180) ;
2415        curve  := pointa--middle--pointb ;
2416    elseif anglemethod = 3 :
2417        curve  := pointa--middle--pointb ;
2418    elseif anglemethod = 4 :
2419        curve  := pointa..controls middle..pointb ;
2420        middle := point .5 along curve ;
2421    fi ;
2422    draw thefreelabel(s, middle, common) ; % withcolor black ;
2423    curve
2424enddef ;
2425
2426permanent anglebetween, angleoffset, anglelength, anglemethod ;
2427
2428% Stack
2429
2430picture mfun_current_picture_stack[] ;
2431numeric mfun_current_picture_depth   ;
2432
2433mfun_current_picture_depth := 0 ;
2434
2435def pushcurrentpicture =
2436    mfun_current_picture_depth := mfun_current_picture_depth + 1 ;
2437    mfun_current_picture_stack[mfun_current_picture_depth] := currentpicture ;
2438    currentpicture := nullpicture ;
2439enddef ;
2440
2441def popcurrentpicture text t = % optional text
2442    if mfun_current_picture_depth > 0 :
2443        addto mfun_current_picture_stack[mfun_current_picture_depth] also currentpicture t ;
2444        currentpicture := mfun_current_picture_stack[mfun_current_picture_depth] ;
2445        mfun_current_picture_stack[mfun_current_picture_depth] := nullpicture ;
2446        mfun_current_picture_depth := mfun_current_picture_depth - 1 ;
2447    fi ;
2448enddef ;
2449
2450permanent pushcurrentpicture, popcurrentpicture ;
2451
2452% penpoint (i,2) of somepath -> inner / outer point
2453
2454vardef penpoint expr pnt of p =
2455    save n, d ; numeric n, d ;
2456    (n,d) = if pair pnt : pnt else : (pnt,1) fi ;
2457    (point n of p shifted ((penoffset direction n of p of currentpen) scaled d))
2458enddef ;
2459
2460permanent penpoint ;
2461
2462%D colorcircle(size, red, green, blue) ;
2463
2464vardef colorcircle (expr size, red, green, blue) = % might move
2465    save r, g, b, c, m, y, w ; save radius ;
2466    path r, g, b, c, m, y, w ; numeric radius ;
2467
2468    radius := 5cm ; pickup pencircle scaled (radius/25) ;
2469
2470    transform t ; t := identity rotatedaround(origin,120) ;
2471
2472    r := fullcircle rotated 90 scaled radius shifted (0,radius/4) rotatedaround(origin,135) ;
2473
2474    b := r transformed t ; g := b transformed t ;
2475
2476    c := buildcycle(subpath(1,7) of g,subpath(1,7) of b) ;
2477    y := c transformed t ; m := y transformed t ;
2478
2479    w := buildcycle(subpath(3,5) of r, subpath(3,5) of g,subpath(3,5) of b) ;
2480
2481    pushcurrentpicture ;
2482
2483    fill r withcolor         red   ;
2484    fill g withcolor         green ;
2485    fill b withcolor         blue  ;
2486    fill c withcolor white - red   ;
2487    fill m withcolor white - green ;
2488    fill y withcolor white - blue  ;
2489    fill w withcolor white         ;
2490
2491    for i = r,g,b,c,m,y : draw i withcolor .5white ; endfor ;
2492
2493    currentpicture := currentpicture xsized size ;
2494
2495    popcurrentpicture ;
2496enddef ;
2497
2498% nice: currentpicture := inverted currentpicture ;
2499
2500primarydef p uncolored c = % not complete ... needs text and scripts and ...
2501    if color p :
2502        c - p
2503    else :
2504        image (
2505            for i within p :
2506                addto currentpicture
2507                    if stroked i or filled i :
2508                        if filled i :
2509                            contour
2510                        else :
2511                            doublepath
2512                        fi
2513                        pathpart i
2514                        dashed dashpart i withpen penpart i
2515                    else :
2516                        also i
2517                    fi
2518                    withcolor c-(redpart i, greenpart i, bluepart i) ;
2519            endfor ;
2520        )
2521  fi
2522enddef ;
2523
2524vardef inverted primary p =
2525    p uncolored white
2526enddef ;
2527
2528primarydef p softened c =
2529    begingroup
2530    save cc ; color cc ; cc := tripled(c) ;
2531    if color p :
2532        (redpart cc * redpart p,greenpart cc * greenpart p, bluepart cc * bluepart p)
2533    else :
2534        image (
2535            for i within p :
2536                addto currentpicture
2537                    if stroked i or filled i :
2538                        if filled i :
2539                            contour
2540                        else :
2541                            doublepath
2542                        fi
2543                        pathpart i
2544                        dashed dashpart i withpen penpart i
2545                    else :
2546                        also i
2547                    fi
2548                    withcolor (redpart cc * redpart i, greenpart cc * greenpart i, bluepart cc * bluepart i) ;
2549            endfor ;
2550        )
2551    fi
2552    endgroup
2553enddef ;
2554
2555vardef grayed primary p =
2556    if rgbcolor p :
2557        tripled(.30redpart p+.59greenpart p+.11bluepart p)
2558    elseif cmykcolor p :
2559        tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i)
2560    elseif greycolor p :
2561        p
2562    elseif string p :
2563        grayed resolvedcolor(p)
2564    elseif picture p :
2565        image (
2566            for i within p :
2567                addto currentpicture
2568                    if stroked i or filled i :
2569                        if filled i :
2570                            contour
2571                        else :
2572                            doublepath
2573                        fi
2574                        pathpart i
2575                        dashed dashpart i
2576                        withpen penpart i
2577                    else :
2578                        also i
2579                    fi
2580                if unknown colorpart i :
2581                    % nothing
2582                elseif rgbcolor colorpart i :
2583                    withcolor tripled(.30redpart i+.59greenpart i+.11bluepart i) ;
2584                elseif cmykcolor colorpart i :
2585                    withcolor tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i) ;
2586                else :
2587                    withcolor colorpart i ;
2588                fi
2589            endfor ;
2590        )
2591    else :
2592        p
2593    fi
2594enddef ;
2595
2596let greyed = grayed ;
2597
2598vardef hsvtorgb(expr h,s,v) =
2599    save H, S, V, x ;
2600    H = h mod 360 ;
2601    S = if s < 0 : 0 elseif s > 1 : 1 else: s fi ;
2602    V = if v < 0 : 0 elseif v > 1 : 1 else: v fi ;
2603    x = 1 - abs(H mod 120 - 60)/60 ;
2604    V * ( (1-S) * (1,1,1) + S *
2605        if     H <  60 : (1,x,0)
2606        elseif H < 120 : (x,1,0)
2607        elseif H < 180 : (0,1,x)
2608        elseif H < 240 : (0,x,1)
2609        elseif H < 300 : (x,0,1)
2610        else           : (1,0,x)
2611    fi )
2612enddef ;
2613
2614permanent colorcircle, uncolored, inverted, grayed, greyed, hsvtorgb ;
2615
2616% yes or no: "text" infont "cmr12" at 24pt ;
2617
2618% let normalinfont = infont ;
2619%
2620% numeric lastfontsize ; lastfontsize = fontsize defaultfont ;
2621%
2622% def infont primary name =  % no vardef, no expr
2623%   hide(lastfontsize := fontsize name) % no ;
2624%   normalinfont name
2625% enddef ;
2626%
2627% def scaledat expr size =
2628%   scaled (size/lastfontsize)
2629% enddef ;
2630%
2631% let at = scaledat ;
2632
2633% like decimal
2634
2635def condition primary b = if b : "true" else : "false" fi enddef ;
2636
2637permanent condition ;
2638
2639% undocumented
2640
2641primarydef p stretched s =
2642    begingroup
2643    save pp ; path pp ; pp := p xyscaled s ;
2644    (pp shifted ((point 0 of p) - (point 0 of pp)))
2645    endgroup
2646enddef ;
2647
2648primarydef p enlonged len =
2649    begingroup
2650    if len == 0 :
2651        p
2652    elseif pair p :
2653        save q ; path q ; q := origin -- p ;
2654        save al ; al := arclength(q) ;
2655        if al > 0 :
2656            point 1 of (q stretched ((al+len)/al))
2657        else :
2658            p
2659        fi
2660    else :
2661        save al ; al := arclength(p) ;
2662        if al > 0 :
2663            p stretched ((al+len)/al)
2664        else :
2665            p
2666        fi
2667    fi
2668    endgroup
2669enddef ;
2670
2671% path p ; p := (0,0) -- (10cm,5cm) ;
2672% drawarrow p withcolor red ;
2673% drawarrow p shortened 1cm withcolor green ;
2674
2675% primarydef p shortened d =
2676%     reverse ( ( reverse (p enlonged -d) ) enlonged -d )
2677% enddef ;
2678
2679primarydef p shortened d =
2680    reverse ( ( reverse (p enlonged -xpart paired(d)) ) enlonged -ypart paired(d) )
2681enddef ;
2682
2683% yes or no, untested -)
2684
2685def xshifted expr dx = shifted(dx,0) enddef ;
2686def yshifted expr dy = shifted(0,dy) enddef ;
2687
2688
2689permanent stretched, enlonged, shortened, xshifted, yshifted ;
2690
2691% also handy
2692
2693% right: str = readfrom ("abc" & ".def" ) ;
2694% wrong: str = readfrom  "abc" & ".def"   ;
2695
2696% Every 62th read fails so we need to try again!
2697
2698% def readfile (expr name) =
2699%   if (readfrom (name) <> EOF) :
2700%     scantokens("input " & name & ";") ;
2701%   elseif (readfrom (name) <> EOF) :
2702%     scantokens("input " & name & ";") ;
2703%   fi ;
2704%   closefrom (name) ;
2705% enddef ;
2706%
2707% this sometimes fails on the elseif, so :
2708%
2709
2710def readfile (expr name) =
2711    begingroup ; save ok ; boolean ok ;
2712    if (readfrom (name) <> EOF) :
2713        ok := false ;
2714    elseif (readfrom (name) <> EOF) :
2715        ok := false ;
2716    else :
2717        ok := true ;
2718    fi ;
2719    if not ok :
2720        scantokens("input " & name & " ") ;
2721    fi ;
2722    closefrom (name) ;
2723    endgroup ;
2724enddef ;
2725
2726permanent readfile ; % todo: lmtx
2727
2728% permits redefinition of end in macro
2729
2730inner end ;
2731
2732% this will be redone (when needed) using scripts and backend handling
2733
2734let mfun_remap_colors_normalwithcolor = normalwithcolor ;
2735
2736def remapcolors =
2737    def normalwithcolor primary c =
2738        mfun_remap_colors_normalwithcolor remappedcolor(c)
2739    enddef ;
2740enddef ;
2741
2742def normalcolors =
2743    let normalwithcolor = mfun_remap_colors_normalwithcolor ;
2744enddef ;
2745
2746def resetcolormap =
2747    color color_map[][][] ;
2748    normalcolors ;
2749enddef ;
2750
2751resetcolormap ;
2752
2753def r_color primary c = redpart   c enddef ; % still neeeded?
2754def g_color primary c = greenpart c enddef ; % still neeeded?
2755def b_color primary c = bluepart  c enddef ; % still neeeded?
2756
2757def remapcolor(expr old, new) =
2758    color_map[redpart old][greenpart old][bluepart old] := new ;
2759enddef ;
2760
2761def remappedcolor(expr c) =
2762    if known color_map[redpart c][greenpart c][bluepart c] :
2763        color_map[redpart c][greenpart c][bluepart c]
2764    else :
2765        c
2766    fi
2767enddef ;
2768
2769% Thanks to Jens-Uwe Morawski for pointing out that we need
2770% to treat bounded and clipped components as local pictures.
2771
2772def recolor suffix p = p := mfun_repathed (0,p) enddef ;
2773def refill  suffix p = p := mfun_repathed (1,p) enddef ;
2774def redraw  suffix p = p := mfun_repathed (2,p) enddef ;
2775def retext  suffix p = p := mfun_repathed (3,p) enddef ;
2776def untext  suffix p = p := mfun_repathed (4,p) enddef ;
2777
2778% primarydef p recolored t = mfun_repathed(0,p) t enddef ;
2779% primarydef p refilled  t = mfun_repathed(1,p) t enddef ;
2780% primarydef p redrawn   t = mfun_repathed(2,p) t enddef ;
2781% primarydef p retexted  t = mfun_repathed(3,p) t enddef ;
2782% primarydef p untexted  t = mfun_repathed(4,p) t enddef ;
2783
2784color refillbackground ; refillbackground := (1,1,1) ;
2785
2786def restroke  suffix p = p := mfun_repathed (21,p) enddef ; % keep attributes
2787def reprocess suffix p = p := mfun_repathed (22,p) enddef ; % no attributes
2788
2789permanent recolor, refill, redraw, retext, untext, restroke, reprocess, refillbackground ;
2790
2791% also 11 and 12
2792
2793vardef mfun_repathed (expr mode, p) text t =
2794    begingroup ;
2795    if mode = 0 :
2796        save normalwithcolor ;
2797        remapcolors ;
2798    fi ;
2799    save temp_p, temp_q, temp_r, temp_f, temp_b ;
2800    picture temp_p, temp_q, temp_r ; color temp_f ; path temp_b ;
2801    temp_b := boundingbox p ;
2802    temp_p := nullpicture ;
2803    for i within p :
2804        temp_f := (redpart i, greenpart i, bluepart i) ;
2805        if bounded i :
2806            temp_q := mfun_repathed(mode,i) t ;
2807            setbounds temp_q to pathpart i ;
2808            addto temp_p also temp_q ;
2809        elseif clipped i :
2810            temp_q := mfun_repathed(mode,i) t ;
2811            clip temp_q to pathpart i ;
2812            addto temp_p also temp_q ;
2813        elseif stroked i :
2814            if mode=21 :
2815                temp_r := i ; % indirectness is needed
2816                addto temp_p also image(scantokens(t & " pathpart temp_r")
2817                    dashed dashpart i withpen penpart i
2818                    withcolor temp_f ; ) ;
2819            elseif mode=22 :
2820                temp_r := i ; % indirectness is needed
2821                addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2822            else :
2823                addto temp_p doublepath pathpart i
2824                    dashed dashpart i withpen penpart i
2825                    withcolor temp_f % (redpart i, greenpart i, bluepart i)
2826                    if mode = 2 :
2827                        t
2828                    fi ;
2829            fi ;
2830        elseif filled  i :
2831            if mode=11 :
2832                temp_r := i ; % indirectness is needed
2833                addto temp_p also image(scantokens(t & " pathpart temp_r")
2834                    withcolor temp_f ; ) ;
2835            elseif mode=12 :
2836                temp_r := i ; % indirectness is needed
2837                addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2838            else :
2839                addto temp_p contour pathpart i
2840                    withcolor temp_f
2841                    if (mode=1) and (temp_f<>refillbackground) :
2842                        t
2843                    fi ;
2844            fi ;
2845        else :
2846            addto temp_p also i ;
2847        fi ;
2848    endfor ;
2849    setbounds temp_p to temp_b ;
2850    temp_p
2851    endgroup
2852enddef ;
2853
2854%D After a question of Denis on how to erase a z variable, Jacko suggested to assign
2855%D whatever to x and y. So a clearz variable can be defined as:
2856%
2857% vardef clearz@# =
2858%   x@# := whatever ;
2859%   y@# := whatever ;
2860% enddef ;
2861%
2862% but Jacko suggested a redefinition of clearxy:
2863%
2864% def clearxy text s =
2865%  clearxy_index_:=0;
2866%  for $:=s:
2867%    clearxy_index_:=clearxy_index_+1; endfor;
2868%  if clearxy_index_=0:
2869%    save x,y;
2870%  else:
2871%    forsuffixes $:=s: x$:=whatever; y$:=whatever; endfor;
2872%  fi
2873% enddef;
2874%
2875% which i decided to simplify to:
2876
2877def clearxy text s =
2878    if false for $ := s : or true endfor :
2879        forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ;
2880    else :
2881        save x, y ;
2882    fi
2883enddef ;
2884
2885permanent clearxy ;
2886
2887% so now we can say: clearxy ; as well as clearxy 1, 2, 3 ;
2888
2889% show x0 ; z0 = (10,10) ;
2890% show x0 ; x0 := whatever ; y0 := whatever ;
2891% show x0 ; z0 = (20,20) ;
2892% show x0 ; clearxy 0 ;
2893% show x0 ; z0 = (30,30) ;
2894
2895primarydef p smoothed d =
2896   (p llmoved (-xpart paired(d),0) -- p lrmoved (-xpart paired(d),0) {right} ..
2897    p lrmoved (0,-ypart paired(d)) -- p urmoved (0,-ypart paired(d)) {up}    ..
2898    p urmoved (-xpart paired(d),0) -- p ulmoved (-xpart paired(d),0) {left}  ..
2899    p ulmoved (0,-ypart paired(d)) -- p llmoved (0,-ypart paired(d)) {down}  .. cycle)
2900enddef ;
2901
2902primarydef p cornered c =
2903    ((point 0 of p) shifted (c*(unitvector(point 1 of p - point 0 of p))) --
2904    for i=1 upto length(p) :
2905        (point i-1 of p) shifted (c*(unitvector(point i   of p - point i-1 of p))) --
2906        (point i   of p) shifted (c*(unitvector(point i-1 of p - point i   of p))) ..
2907        controls point i of p ..
2908    endfor cycle)
2909enddef ;
2910
2911% Mikael Sundqvist came up with this one. We made it robust for points being too close
2912% for smoothing.
2913
2914primarydef p smoothcornered c =
2915    ( begingroup ;
2916        save cc ;
2917        if not cycle p: (point 0 of p) -- fi
2918        for i=1 upto length(p) :
2919            hide (cc := min(c,arclength (subpath(i-1,i) of p)/2);)
2920            (point i-1 of p) shifted (cc*(unitvector(point i   of p - point i-1 of p))) --
2921            (point i   of p) shifted (cc*(unitvector(point i-1 of p - point i   of p))) ..
2922            controls point i of p ..
2923        endfor
2924        if cycle p : cycle else : point 1 along p fi
2925    endgroup )
2926enddef ;
2927
2928permanent smoothed, cornered, smoothcornered ;
2929
2930% cmyk color support
2931
2932% vardef cmyk(expr c,m,y,k) = % elsewhere
2933%     (1-c-k,1-m-k,1-y-k)
2934% enddef ;
2935
2936% handy
2937
2938% vardef bbwidth (expr p) = % vardef width_of primary p =
2939%     if known p :
2940%         if path p or picture p :
2941%             xpart (lrcorner p - llcorner p)
2942%         else :
2943%             0
2944%         fi
2945%     else :
2946%         0
2947%     fi
2948% enddef ;
2949% vardef bbwidth primary p =
2950%     if unknown p :
2951%         0
2952%     elseif path p or picture p :
2953%         xpart (lrcorner p - llcorner p)
2954%     else :
2955%         0
2956%     fi
2957% enddef ;
2958% vardef bbwidth primary p =
2959%     if unknown p :
2960%         0
2961%     elseif path p or picture p :
2962%         save b ; path b; b := corners p ;
2963%         xpart point 0 of b - xpart point 1 of b
2964%     else :
2965%         0
2966%     fi
2967% enddef ;
2968vardef bbwidth primary p =
2969    if unknown p :
2970        0
2971    elseif path p or picture p :
2972        save r ; pair r ; r := xrange p ;
2973        ypart r - xpart r
2974    else :
2975        0
2976    fi
2977enddef ;
2978
2979% vardef bbheight (expr p) = % vardef heigth_of primary p =
2980%     if known p :
2981%         if path p or picture p :
2982%             ypart (urcorner p - lrcorner p)
2983%         else :
2984%             0
2985%         fi
2986%     else :
2987%         0
2988%     fi
2989% enddef ;
2990% vardef bbheight primary p =
2991%     if unknown p :
2992%         0
2993%     elseif path p or picture p :
2994%         ypart (urcorner p - lrcorner p)
2995%     else :
2996%         0
2997%     fi
2998% enddef ;
2999% vardef bbheight primary p =
3000%     if unknown p :
3001%         0
3002%     elseif path p or picture p :
3003%         save b ; path b; b := corners p ;
3004%         ypart point 2 of b - ypart point 1 of b
3005%     else :
3006%         0
3007%     fi
3008% enddef ;
3009vardef bbheight primary p =
3010    if unknown p :
3011        0
3012    elseif path p or picture p :
3013        save r ; pair r ; r := yrange p ;
3014        ypart r - xpart r
3015    else :
3016        0
3017    fi
3018enddef ;
3019
3020permanent bbwidth, bbheight ;
3021
3022color nocolor ; numeric noline ; % both unknown signals
3023
3024def dowithpath (expr p, lw, lc, bc) =
3025    if known p :
3026        if known bc :
3027            fill p withcolor bc ;
3028        fi ;
3029        if known lw and known lc :
3030            draw p withpen pencircle scaled lw withcolor lc ;
3031        elseif known lw :
3032            draw p withpen pencircle scaled lw ;
3033        elseif known lc :
3034            draw p withcolor lc ;
3035        fi ;
3036    fi ;
3037enddef ;
3038
3039% result from metafont discussion list (denisr/boguslawj)
3040
3041def [[[ = [ [ [ enddef ; % already: def [[ = [ [ enddef ;
3042def ]]] = ] ] ] enddef ; % already: def ]] = ] ] enddef ;
3043
3044let == = = ; % magic
3045
3046permanent [[[, ]]], ==;
3047
3048% added
3049
3050picture oddly ; % evenly already defined
3051
3052evenly := dashpattern(on  3 off 3) ;
3053oddly  := dashpattern(off 3 on  3) ;
3054
3055% not perfect, but useful since it removes redundant points.
3056
3057vardef mfun_straightened(expr sign, p) =
3058    save temp_p, temp_q ; path temp_p, temp_q ;
3059    temp_p := p ;
3060    forever :
3061        temp_q := mfun_do_straightened(sign, temp_p) ;
3062        exitif length(temp_p) = length(temp_q) ;
3063        temp_p := temp_q ;
3064    endfor ;
3065    temp_q
3066enddef ;
3067
3068% vardef mfun_straightened(expr sign, p) =
3069%     save lp, lq, q ; path q ; q := p ;
3070%     lp := length(p) ;
3071%     forever :
3072%         q := mfun_do_straightened(sign,q) ;
3073%         lq := length(q) ;
3074%         exitif lp = lq ;
3075%         lp := lq ;
3076%     endfor ;
3077%     q
3078% enddef ;
3079
3080% can be optimized:
3081
3082vardef mfun_do_straightened(expr sign, p) =
3083    if length(p) > 2 : % was 1, but straight lines are ok
3084        save pp ; path pp ;
3085        pp := point 0 of p ;
3086        for i=1 upto length(p)-1 :
3087            if round(point i of p) <> round(point length(pp) of pp) :
3088                pp := pp -- point i of p ;
3089            fi ;
3090        endfor ;
3091        save n, ok ; numeric n ; boolean ok ;
3092        n := length(pp) ; ok := false ;
3093        if n > 2 :
3094            for i=0 upto n :
3095                if unitvector(round(point i of pp - point if i=0 : n else : i-1 fi of pp)) <>
3096            sign * unitvector(round(point if i=n : 0 else : i+1 fi of pp - point i of pp)) :
3097                    if ok :
3098                        --
3099                    else :
3100                        ok := true ;
3101                    fi point i of pp
3102                fi
3103            endfor
3104            if ok and (cycle p) :
3105                -- cycle
3106            fi
3107        else :
3108            pp
3109        fi
3110    else :
3111        p
3112    fi
3113enddef ;
3114
3115vardef simplified expr p = (
3116    reverse mfun_straightened(+1,mfun_straightened(+1,reverse p))
3117) enddef ;
3118
3119vardef unspiked expr p = (
3120    reverse mfun_straightened(-1,mfun_straightened(-1,reverse p))
3121) enddef ;
3122
3123permanent simplified, unspiked ;
3124
3125% path p ;
3126% p := (2cm,1cm) -- (2cm,1cm) -- (2cm,1cm) -- (3cm,1cm) --
3127%      (4cm,1cm) -- (4cm,2cm) -- (4cm,2.5cm) -- (4cm,3cm) --
3128%      (3cm,3cm) -- (2cm,3cm) -- (1cm,3cm) -- (-1cm,3cm) --
3129%      .5[(-1cm,3cm),(1cm,1cm)] -- (1cm,1cm) -- cycle ;
3130%
3131% p := unitcircle scaled 4cm ;
3132%
3133% drawpath p ; drawpoints p ; drawpointlabels p ;
3134% p := p shifted (4cm,0) ; p := straightened p ;
3135% drawpath p ; drawpoints p ; drawpointlabels p ;
3136% p := p shifted (4cm,0) ; p := straightened p ;
3137% drawpath p ; drawpoints p ; drawpointlabels p ;
3138
3139% new
3140
3141path originpath ; originpath := origin -- cycle ;
3142
3143vardef unitvector primary z =
3144    if abs z = abs origin : z else : z/abs z fi % hm, abs origin is just origin
3145enddef;
3146
3147vardef epsed (expr e) = % epsed(1.2345)
3148    e if e>0 : + eps elseif e < 0 : - eps fi
3149enddef ;
3150
3151immutable originpath ;
3152permanent unitvector, epsed ;
3153
3154% handy
3155
3156def withgray primary g =
3157    withcolor g
3158enddef ;
3159
3160if unknown darkred     : color darkred     ; darkred     := .625(1,0,0) fi ;
3161if unknown darkgreen   : color darkgreen   ; darkgreen   := .625(0,1,0) fi ;
3162if unknown darkblue    : color darkblue    ; darkblue    := .625(0,0,1) fi ;
3163if unknown darkcyan    : color darkcyan    ; darkcyan    := .625(0,1,1) fi ;
3164if unknown darkmagenta : color darkmagenta ; darkmagenta := .625(1,0,1) fi ;
3165if unknown darkyellow  : color darkyellow  ; darkyellow  := .625(1,1,0) fi ;
3166if unknown darkgray    : color darkgray    ; darkgray    := .625(1,1,1) fi ;
3167if unknown lightgray   : color lightgray   ; lightgray   := .850(1,1,1) fi ;
3168
3169permanent withgray ;
3170
3171% an improved plain mp macro
3172
3173% vardef center primary p =
3174%     if pair p :
3175%         p
3176%     else :
3177%         .5[llcorner p, urcorner p]
3178%     fi
3179% enddef;
3180%
3181% permanent center ;
3182
3183vardef center primary p =
3184    centerof p
3185enddef ;
3186
3187% new, yet undocumented
3188
3189vardef rangepath (expr p, d, a) =
3190    if length p>0 :
3191        (d*unitvector(direction 0 of p) rotated a) shifted point 0 of p
3192        -- p --
3193        (d*unitvector(direction length(p) of p) rotated a) shifted point length(p) of p
3194    else :
3195        p
3196    fi
3197enddef ;
3198
3199% under construction
3200
3201vardef straightpath (expr a, b, method) =
3202    if (method<1) or (method>6)  :
3203        (a--b)
3204    elseif method = 1 :
3205        (a --
3206            if xpart a > xpart b :
3207                if ypart a > ypart b :
3208                    (xpart b,ypart a) --
3209                elseif ypart a < ypart b :
3210                    (xpart a,ypart b) --
3211                fi
3212            elseif xpart a < xpart b :
3213                if ypart a > ypart b :
3214                    (xpart a,ypart b) --
3215                elseif ypart a < ypart b :
3216                    (xpart b,ypart a) --
3217                fi
3218            fi
3219        b)
3220    elseif method = 3 :
3221        (a --
3222            if xpart a > xpart b :
3223                (xpart b,ypart a) --
3224            elseif xpart a < xpart b :
3225                (xpart a,ypart b) --
3226            fi
3227        b)
3228    elseif method = 5 :
3229        (a --
3230            if ypart a > ypart b :
3231                (xpart b,ypart a) --
3232            elseif ypart a < ypart b :
3233                (xpart a,ypart b) --
3234            fi
3235        b)
3236    else :
3237        (reverse straightpath(b,a,method-1))
3238    fi
3239enddef ;
3240
3241permanent straightpath ;
3242
3243% handy for myself
3244
3245def addbackground text t =
3246    begingroup ;
3247    save p, b ; picture p ; path b ;
3248    b := boundingbox currentpicture ;
3249    p := currentpicture ; currentpicture := nullpicture ;
3250    fill b t ;
3251    setbounds currentpicture to b ;
3252    addto currentpicture also p ;
3253    endgroup ;
3254enddef ;
3255
3256permanent addbackground ;
3257
3258% makes a (line) into an infinite one (handy for calculating
3259% intersection points
3260
3261vardef infinite expr p =
3262    (-infinity*unitvector(direction 0 of p)
3263    shifted point 0 of p
3264    -- p --
3265    +infinity*unitvector(direction length(p) of p)
3266        shifted point length(p) of p)
3267enddef ;
3268
3269permanent infinite ;
3270
3271% obscure macros: create var from string and replace - and :
3272% (needed for process color id's) .. will go away
3273
3274% this will become a lua helper
3275
3276% string mfun_clean_ascii[] ;
3277%
3278% def register_dirty_chars(expr str) =
3279%     for i = 0 upto length(str)-1 :
3280%         mfun_clean_ascii[ASCII substring(i,i+1) of str] := "_" ;
3281%     endfor ;
3282% enddef ;
3283%
3284% register_dirty_chars("+-*/:;., ") ;
3285%
3286% vardef cleanstring (expr s) =
3287%     save ss ; string ss, si ; ss = "" ; save i ;
3288%     for i=0 upto length(s) :
3289%         si := substring(i,i+1) of s ;
3290%         ss := ss & if known mfun_clean_ascii[ASCII si] : mfun_clean_ascii[ASCII si] else : si fi ;
3291%     endfor ;
3292%     ss
3293% enddef ;
3294%
3295% vardef asciistring (expr s) =
3296%     save ss ; string ss, si ; ss = "" ; save i ;
3297%     for i=0 upto length(s) :
3298%         si := substring(i,i+1) of s ;
3299%         if (ASCII si >= ASCII "0") and (ASCII si <= ASCII "9") :
3300%             ss := ss & char(scantokens(si) + ASCII "A") ;
3301%         else :
3302%             ss := ss & si ;
3303%         fi ;
3304%     endfor ;
3305%     ss
3306% enddef ;
3307%
3308% vardef setunstringed (expr s, v) =
3309%     scantokens(cleanstring(s)) := v ;
3310% enddef ;
3311%
3312% vardef getunstringed (expr s) =
3313%     scantokens(cleanstring(s))
3314% enddef ;
3315%
3316% vardef unstringed (expr s) =
3317%     expandafter known scantokens(cleanstring(s))
3318% enddef ;
3319
3320% for david arnold: showgrid(-5,10,1cm,-10,10,1cm);
3321
3322def showgrid (expr minx, maxx, deltax, miny, maxy, deltay) = % will move
3323    begingroup
3324    save size ; numeric size ; size := 2pt ;
3325    for x=minx upto maxx :
3326        for y=miny upto maxy :
3327            draw (x*deltax, y*deltay) withpen pencircle scaled
3328                if (x mod 5 = 0) and (y mod 5 = 0) :
3329                    1.5size withcolor .50white
3330                else :
3331                       size withcolor .75white
3332                fi ;
3333        endfor ;
3334    endfor ;
3335    for x=minx upto maxx:
3336        label.bot(textext("\infofont " & decimal x), (x*deltax,-size)) ;
3337    endfor ;
3338    for y=miny upto maxy:
3339        label.lft(textext("\infofont " & decimal y), (-size,y*deltay)) ;
3340    endfor ;
3341    endgroup
3342enddef;
3343
3344% new, handy for:
3345%
3346% \startuseMPgraphic{map}{n}
3347%   \includeMPgraphic{map:germany} ;
3348%   c_phantom (\MPvar{n}<1) (
3349%     fill map_germany withcolor \MPcolor{lightgray} ;
3350%     draw map_germany withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
3351%   ) ;
3352%   \includeMPgraphic{map:austria} ;
3353%   c_phantom (\MPvar{n}<2) (
3354%     fill map_austria withcolor \MPcolor{lightgray} ;
3355%     draw map_austria withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
3356%   ) ;
3357%   c_phantom (\MPvar{n}<3) (
3358%   \includeMPgraphic{map:swiss} ;
3359%     fill map_swiss withcolor \MPcolor{lightgray} ;
3360%     draw map_swiss withpen pencircle scaled 1pt withcolor \MPcolor{darkgray}  ;
3361%   ) ;
3362%   c_phantom (\MPvar{n}<4) (
3363%   \includeMPgraphic{map:luxembourg} ;
3364%     fill map_luxembourg withcolor \MPcolor{lightgray} ;
3365%     draw map_luxembourg withpen pencircle scaled 1pt withcolor \MPcolor{darkgray}  ;
3366%   ) ;
3367% \stopuseMPgraphic
3368%
3369% \useMPgraphic{map}{n=3}
3370
3371vardef phantom (text t) = % to be checked
3372    picture temp_p ;
3373    temp_p := image(t) ;
3374    addto temp_p also currentpicture ;
3375    setbounds currentpicture to boundingbox temp_p ;
3376enddef ;
3377
3378vardef c_phantom (expr b) (text t) =
3379    if b :
3380        save temp_p; picture temp_p ;
3381        temp_p := image(t) ;
3382        addto temp_p also currentpicture ;
3383        setbounds currentpicture to boundingbox temp_p ;
3384    else :
3385        t ;
3386    fi ;
3387enddef ;
3388
3389permanent phantom ;
3390
3391%D Handy:
3392
3393def break =
3394    exitif true ; % fi
3395enddef ;
3396
3397permanent break ;
3398
3399%D New too:
3400
3401% primarydef p xstretched w = (
3402%     p if (bbwidth (p)>0) and (w>0) : xscaled (w/bbwidth (p)) fi
3403% ) enddef ;
3404%
3405% primarydef p ystretched h = (
3406%     p if (bbheight(p)>0) and (h>0) : yscaled (h/bbheight(p)) fi
3407% ) enddef ;
3408
3409primarydef p xstretched w = (
3410    begingroup save l, r ; pair r;
3411    r := xrange p ;
3412    l := ypart r - xpart r ;
3413    p if (l > 0) and (w > 0) : xscaled (w/l) fi
3414    endgroup
3415) enddef ;
3416
3417primarydef p ystretched h = (
3418    begingroup save l, r ; pair r;
3419    r := yrange p ;
3420    l := ypart r - xpart r ;
3421    p if (l > 0) and (h > 0) : yscaled (h/l) fi
3422    endgroup
3423) enddef ;
3424
3425permanent xstretched, ystretched ;
3426
3427%D Newer:
3428
3429vardef area expr p =
3430    % we could calculate the boundingbox once
3431    (xpart llcorner boundingbox p,0) -- p --
3432    (xpart lrcorner boundingbox p,0) -- cycle
3433enddef ;
3434
3435vardef basiccolors[] =
3436    if @ = 0 :
3437        white
3438    else :
3439        save n ; n := @ mod 7 ;
3440        if     n = 1 : red
3441        elseif n = 2 : green
3442        elseif n = 3 : blue
3443        elseif n = 4 : cyan
3444        elseif n = 5 : magenta
3445        elseif n = 6 : yellow
3446        else         : black
3447        fi
3448    fi
3449enddef ;
3450
3451% vardef somecolor = (1,1,0,0) enddef ;
3452
3453% fill OverlayBox withcolor (rcomponent somecolor,gcomponent somecolor,bcomponent somecolor) ;
3454% fill OverlayBox withcolor (ccomponent somecolor,mcomponent somecolor,ycomponent somecolor,bcomponent somecolor) ;
3455
3456% This could be standard mplib 2 behaviour:
3457
3458% vardef rcomponent expr p = if rgbcolor  p : redpart     elseif cmykcolor p : 1 - cyanpart    fi p enddef ;
3459
3460vardef rcomponent expr p = if rgbcolor  p : redpart     p elseif cmykcolor p : 1 - cyanpart    p else : p fi enddef ;
3461vardef gcomponent expr p = if rgbcolor  p : greenpart   p elseif cmykcolor p : 1 - magentapart p else : p fi enddef ;
3462vardef bcomponent expr p = if rgbcolor  p : bluepart    p elseif cmykcolor p : 1 - yellowpart  p else : p fi enddef ;
3463vardef ccomponent expr p = if cmykcolor p : cyanpart    p elseif rgbcolor  p : 1 - redpart     p else : p fi enddef ;
3464vardef mcomponent expr p = if cmykcolor p : magentapart p elseif rgbcolor  p : 1 - greenpart   p else : p fi enddef ;
3465vardef ycomponent expr p = if cmykcolor p : yellowpart  p elseif rgbcolor  p : 1 - bluepart    p else : p fi enddef ;
3466vardef kcomponent expr p = if cmykcolor p : blackpart   p elseif rgbcolor  p : 0                 else : p fi enddef ;
3467
3468permanent rcomponent, gcomponent, bcomponent, ccomponent, mcomponent, ycomponent, kcomponent ;
3469
3470% draw image       (...) ... ; % prescripts prepended to first, postscripts appended to last
3471% draw decorated   (...) ... ; % prescripts prepended to each,  postscripts appended to each
3472% draw redecorated (...) ... ; % prescripts assigned  to each,  postscripts assigned to each
3473% draw undecorated (...) ... ; % following properties are ignored, existing properties are kept
3474%
3475% draw decorated (
3476%     draw fullcircle scaled 20cm withpen pencircle scaled 20mm withcolor red   withtransparency (1,.40) ;
3477%     draw fullcircle scaled 15cm withpen pencircle scaled 15mm withcolor green withtransparency (1,.30) ;
3478%     draw fullcircle scaled 10cm withpen pencircle scaled 10mm withcolor blue  withtransparency (1,.20) ;
3479% )
3480%     withcolor blue
3481%     withtransparency (1,.125) % selectively applied
3482%     withpen pencircle scaled 10mm
3483% ;
3484
3485% vardef image (text imagedata) = % already defined
3486%     save currentpicture ;
3487%     picture currentpicture ;
3488%     currentpicture := nullpicture ;
3489%     imagedata ;
3490%     currentpicture
3491% enddef ;
3492
3493vardef undecorated (text t) text decoration =
3494    save currentpicture ;
3495    picture currentpicture ;
3496    currentpicture := nullpicture ;
3497    t ;
3498    currentpicture
3499enddef ;
3500
3501vardef decorated (text imagedata) text decoration =
3502    save mfun_decorated_path, currentpicture ;
3503    picture mfun_decorated_path, currentpicture ;
3504    currentpicture := nullpicture ;
3505    imagedata ;
3506    mfun_decorated_path := currentpicture ;
3507    currentpicture := nullpicture ;
3508    for i within mfun_decorated_path :
3509        addto currentpicture
3510            if stroked i :
3511                doublepath pathpart i
3512                dashed dashpart i
3513                withpen penpart i
3514                withcolor colorpart i
3515                withprescript prescriptpart i
3516                withpostscript postscriptpart i
3517                decoration
3518            elseif filled i :
3519                contour pathpart i
3520                withpen penpart i
3521                withcolor colorpart i
3522                withprescript prescriptpart i
3523                withpostscript postscriptpart i
3524                decoration
3525            elseif textual i :
3526                also i
3527                withcolor colorpart i
3528                withprescript prescriptpart i
3529                withpostscript postscriptpart i
3530                decoration
3531            else :
3532                also i
3533            fi
3534        ;
3535    endfor ;
3536    currentpicture
3537enddef ;
3538
3539vardef redecorated (text imagedata) text decoration =
3540    save mfun_decorated_path, currentpicture ;
3541    picture mfun_decorated_path, currentpicture ;
3542    currentpicture := nullpicture ;
3543    imagedata ;
3544    mfun_decorated_path := currentpicture ;
3545    currentpicture := nullpicture ;
3546    for i within mfun_decorated_path :
3547        addto currentpicture
3548            if stroked i :
3549                doublepath pathpart i
3550                dashed dashpart i
3551                withpen penpart i
3552                decoration
3553            elseif filled i :
3554                contour pathpart i
3555                withpen penpart i
3556                decoration
3557            elseif textual i :
3558                also i
3559                decoration
3560            else :
3561                also i
3562            fi
3563        ;
3564    endfor ;
3565    currentpicture
3566enddef ;
3567
3568permanent decorated, undecorated, redecorated ;
3569
3570% path mfun_bleed_box ;
3571
3572% primarydef p bleeded d =
3573%     image (
3574%         mfun_bleed_box := boundingbox p ;
3575%         if pair d :
3576%             draw p xysized (bbwidth(p)+2*xpart d,bbheight(p)+2*ypart d) shifted -d ;
3577%         else :
3578%             draw p xysized (bbwidth(p)+2d,bbheight(p)+2d) shifted (-d,-d) ;
3579%         fi ;
3580%         setbounds currentpicture to mfun_bleed_box ;
3581%     )
3582% enddef ;
3583
3584vardef mfun_snapped(expr p, s) =
3585    if p < 0 : - ( - else : ( fi p div s) * s % the less tokens the better
3586enddef ;
3587
3588vardef mfun_applied(expr p, s)(suffix a) =
3589    if path p :
3590        if pair s :
3591            for i=0 upto length(p)-1 :
3592                (a(xpart point i of p,xpart s),a(ypart point i of p,ypart s)) --
3593            endfor
3594            if cycle p :
3595                cycle
3596            else :
3597                (a(xpart point length(p) of p,xpart s),a(ypart point length(p) of p,ypart s))
3598            fi
3599        else :
3600            for i=0 upto length(p)-1 :
3601                (a(xpart point i of p,s),a(ypart point i of p,s)) --
3602            endfor
3603            if cycle p :
3604                cycle
3605            else :
3606                (a(xpart point length(p) of p,s),a(ypart point length(p) of p,s))
3607            fi
3608        fi
3609    elseif pair p :
3610        if pair s :
3611            (a(xpart p,xpart s),a(ypart p,ypart s))
3612        else :
3613            (a(xpart p,s),a(ypart p,s))
3614        fi
3615    elseif cmykcolor p :
3616       (a(cyanpart p,s),a(magentapart p,s),a(yellowpart p,s),a(blackpart p,s))
3617    elseif rgbcolor p :
3618       (a(redpart p,s),a(greenpart p,s),a(bluepart p,s))
3619    elseif graycolor p :
3620        a(p,s)
3621    elseif numeric p :
3622        a(p,s)
3623    else
3624        p
3625    fi
3626enddef ;
3627
3628primarydef p snapped s =
3629    mfun_applied(p,s)(mfun_snapped) % so we can play with variants
3630enddef ;
3631
3632permanent snapped ;
3633
3634%D Take a look at mp-tool.mpiv for the old implementation if the next code. We only provide
3635%D this for old times sake. We assume that the lmt_ commands are defined by the time this
3636%D is used:
3637
3638% beginfont("demo-symbols");
3639%     beginglyph(9754,2,4,0) ; % high voltage
3640%         interim ahlength := 1 ;
3641%         drawarrow (1,4) -- (0,2) -- (2,3) -- (1,0) withcolor darkred ;
3642%     endglyph ;
3643% endfont;
3644
3645picture font_glyph[][] ;
3646numeric font_count ; font_count := 0;
3647
3648def beginfont(expr n) =
3649    begingroup ;
3650    save name ; string name; name := n;
3651    font_count := font_count + 1 ;
3652    lmt_registerglyphs [
3653        name   = name,
3654        units  = 10,
3655        width  = 10,
3656        height = 8,
3657        depth  = 2,
3658    ] ;
3659enddef ;
3660
3661def endfont =
3662    endgroup;
3663enddef ;
3664
3665def beginglyph(expr u, w, h, d) =
3666    save unicode ; unicode := u;
3667    lmt_registerglyph [
3668        category = name,
3669        unicode  = u,
3670        code     = "draw font_glyph[" & decimal font_count & "][" & decimal u & "];"
3671        width    = w,
3672        height   = h,
3673        depth    = d,
3674    ] ;
3675    currentpicture := nullpicture ;
3676enddef ;
3677
3678def endglyph =
3679    font_glyph[font_count][unicode] := currentpicture ;
3680enddef ;
3681
3682permanent beginfont, endfont, beginglyph, endglyph ;
3683
3684%D Dimensions have never been an issue as traditional MP can't make that large pictures,
3685%D but with double mode we need a catch:
3686
3687newinternal maxdimensions ; maxdimensions := 14000 ;
3688
3689def mfun_apply_max_dimensions = % not a generic helper, we want to protect this one
3690    if bbwidth currentpicture > maxdimensions :
3691        currentpicture := currentpicture if bbheight currentpicture  > bbwidth currentpicture : ysized else : xsized fi maxdimensions ;
3692    elseif bbheight currentpicture  > maxdimensions :
3693        currentpicture := currentpicture ysized maxdimensions ;
3694    fi ;
3695enddef;
3696
3697extra_endfig := extra_endfig & "mfun_apply_max_dimensions ;" ;
3698
3699%D Bonus shapes (need along):
3700
3701path unittriangle, fulltriangle ; % not really units but circle based
3702
3703unittriangle := point 0   along unitcircle
3704             -- point 1/3 along unitcircle
3705             -- point 2/3 along unitcircle
3706             -- cycle ;
3707fulltriangle := point 0   along fullcircle
3708             -- point 1/3 along fullcircle
3709             -- point 2/3 along fullcircle
3710             -- cycle ;
3711
3712immutable unittriangle, fulltriangle ;
3713
3714%D Kind of special and undocumented. On Wikipedia one can find examples of quick sort
3715%D routines. Here we have a variant that permits a method.
3716
3717% vardef listsize(suffix list) =
3718%     numeric len ; len := 0 ;
3719%     forever :
3720%         exitif unknown list[len+1] ;
3721%         len := len + 1 ;
3722%     endfor ;
3723%     len
3724% enddef ;
3725
3726vardef listsize(suffix list) =
3727    numeric len ; len := 1 ;
3728    forever :
3729        exitif unknown list[len] ;
3730        len := len + 1 ;
3731    endfor ;
3732    len if unknown list[0] : - 1 fi
3733enddef ;
3734
3735vardef listlast(suffix list) =
3736    numeric len ; len := if known list[0] : 0 else : 1 fi  ;
3737    forever :
3738        len := len + 1 ;
3739        exitif unknown list[len] ;
3740    endfor ;
3741    len - 1
3742enddef ;
3743
3744vardef mfun_quick_sort(suffix list)(expr asked_min, asked_max)(text what) =
3745    save l, r, m ;
3746    numeric l ; l := asked_min ;
3747    numeric r ; r := asked_max ;
3748    numeric m ; m := floor(.5[asked_min,asked_max]) ;
3749    asked_mid := what list[m] ;
3750    forever :
3751        exitif l >= r ;
3752        forever :
3753            exitif l > asked_max ;
3754          % exitif (what list[l]) >= (what list[m]) ;
3755            exitif (what list[l]) >= asked_mid ;
3756            l := l + 1 ;
3757        endfor ;
3758        forever :
3759            exitif r < asked_min ;
3760          % exitif (what list[m]) >= (what list[r]) ;
3761            exitif asked_mid >= (what list[r]) ;
3762            r := r - 1 ;
3763        endfor ;
3764        if l <= r :
3765          temp := list[l] ;
3766          list[l] := list[r] ;
3767          list[r] := temp ;
3768          l := l + 1 ;
3769          r := r - 1 ;
3770        fi ;
3771    endfor ;
3772    if asked_min < r :
3773        mfun_quick_sort(list)(asked_min,r)(what) ;
3774    fi ;
3775    if l < asked_max :
3776        mfun_quick_sort(list)(l,asked_max)(what) ;
3777    fi ;
3778enddef ;
3779
3780vardef sortlist(suffix list)(text what) =
3781    save asked_max ; numeric asked_max ;
3782    save asked_mid ; numeric asked_mid ;
3783    save temp ;
3784  % asked_max := listsize(list) ;
3785    asked_max := listlast(list) ;
3786    if pair list[asked_max] :
3787        pair temp ;
3788    else :
3789        numeric temp ;
3790    fi ;
3791    if pair what list[asked_max] :
3792        pair asked_mid ;
3793    else :
3794        numeric asked_mid ;
3795    fi ;
3796    if asked_max > 1 :
3797      % mfun_quick_sort(list)(1,asked_max)(what) ;
3798        mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,asked_max)(what) ;
3799    fi ;
3800enddef ;
3801
3802vardef uniquelist(suffix list) =
3803    % this one will be defined later
3804enddef ;
3805
3806vardef copylist(suffix list, target) =
3807    save i ; i := 1 ;
3808    forever :
3809        exitif unknown list[i] ;
3810        target[i] := list[i] ;
3811        i := i + 1 ;
3812    endfor ;
3813enddef ;
3814
3815vardef listtolines(suffix list) =
3816    list[1] for i=2 upto listsize(list) : -- list[i] endfor
3817enddef ;
3818
3819vardef listtocurves(suffix list) =
3820    list[1] for i=2 upto listsize(list) : .. list[i] endfor
3821enddef ;
3822
3823%D The sorter is used in:
3824
3825% not yet ok
3826
3827vardef shapedlist(suffix p) = % takes a list of paths
3828    save l ; pair l[] ;
3829    save r ; pair r[] ;
3830    save i ; i := 1 ;
3831    save n ; n := 0 ;
3832    forever :
3833        exitif unknown p[i] ;
3834        n := n + 1 ;
3835        l[n] := ulcorner p[i] ;
3836        r[n] := urcorner p[i] ;
3837        n := n + 1 ;
3838        l[n] := llcorner p[i] ;
3839        r[n] := lrcorner p[i] ;
3840        i := i + 1 ;
3841    endfor ;
3842    for i = 3 upto n :
3843        if xpart r[i] < xpart r[i-1] :
3844            r[i] := (xpart r[i],ypart r[i-1]) ;
3845        elseif xpart r[i] > xpart r[i-1] :
3846            r[i-1] := (xpart r[i-1],ypart r[i]) ;
3847        fi ;
3848        if xpart l[i] < xpart l[i-1] :
3849            l[i-1] := (xpart l[i-1],ypart l[i]) ;
3850        elseif xpart l[i] > xpart l[i-1] :
3851            l[i] := (xpart l[i],ypart l[i-1]) ;
3852        fi ;
3853    endfor ;
3854    if n > 0 :
3855        simplified (
3856            for i = 1 upto   n : r[i] -- endfor
3857            for i = n downto 1 : l[i] -- endfor
3858            cycle
3859        )
3860    else :
3861        origin -- cycle
3862    fi
3863enddef ;
3864
3865permanent listsize, listlast, sortlist, uniquelist, copylist, listtolines, listtocurves, shapedlist ;
3866
3867%D Dumping is fake anyway but let's keep this:
3868
3869let dump = relax ;
3870
3871%D Loading modules can be done with:
3872
3873def loadmodule expr name = % no vardef
3874    % input can't be used directly in a macro
3875    if (unknown scantokens("context_" & name)) and (unknown scantokens("metafun_loaded_" & name)) :
3876        save s ; string s ; s := "input " & ditto & "mp-" & name & ditto & ";" ;
3877        expandafter scantokens expandafter s
3878    fi ;
3879enddef ;
3880
3881def loadfile  (expr filename) =       scantokens("input " & filename)   enddef ;
3882def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ;
3883
3884permanent loadmodule, loadfile, loadimage ;
3885
3886%D Handy for backgrounds:
3887
3888def drawpathwithpoints expr p =
3889    do_drawpathwithpoints(p)
3890enddef ;
3891
3892def do_drawpathwithpoints(expr p) text t =
3893    draw p t ;
3894    if length(p) > 2 :
3895        begingroup ;
3896        save temp_c ; path temp_c ;
3897        save temp_p; picture temp_p ;
3898        temp_p := image (
3899            temp_c := if cycle p : fullsquare else : fullcircle fi scaled 6pt ;
3900            for i=0 upto length(p) if cycle p : -1 fi :
3901                fill temp_c shifted point i of p withcolor white ;
3902                draw temp_c shifted point i of p withcolor white/2 withpen pencircle scaled .5pt ;
3903                if (i = 0) and cycle p :
3904                    temp_c := fullcircle scaled 6pt ;
3905                fi ;
3906            endfor ;
3907            for i=0 upto length(p) if cycle p : -1 fi :
3908                draw textext("\infofont " & decimal i) ysized 2pt shifted point i of p ;
3909            endfor ;
3910        ) ;
3911        setbounds temp_p to boundingbox p ;
3912        draw temp_p ;
3913    fi ;
3914enddef ;
3915
3916%D These new helpers are by Alan and are used in for instance the mp-node module.
3917
3918newinternal crossingdebug     ; crossingdebug     := 0 ;
3919newinternal crossingscale     ; crossingscale     := 10 ;
3920newinternal crossingnumbermax ; crossingnumbermax := 1000 ;
3921
3922% primary, secondary or tertiary? always hard to decide but primary makes sense
3923
3924vardef infotext@#(expr txt, ysize) =
3925    textext@#("\infofont " & if numeric txt : decimal fi txt) ysized ysize
3926enddef ;
3927
3928primarydef p crossingunder q =
3929    begingroup
3930    save pic ; picture pic ; pic := nullpicture ;
3931    if picture p :
3932        for i within p :
3933            if stroked i :
3934                addto pic also image(draw pathpart i crossingunder q) ;
3935            fi
3936        endfor
3937    elseif path p :
3938        save n, t, a, b, c, r, bcuttings, hold ;
3939        numeric n, t[], hold ;
3940        path a, b, c, r, bcuttings, hold[] ;
3941        c := makepath(currentpen scaled crossingscale) ;
3942        r := if picture q : boundingbox fi q ;
3943        t[0] := n := hold := 0 ;
3944        a := p ;
3945        % The cutbefore/cutafter using c below prevents endless loops!
3946       %forever : % find all intersections
3947        for i=1 upto crossingnumbermax : % safeguard
3948            clearxy ; z = a intersectiontimes r ;
3949            if x < 0 :
3950                exitif hold < 1 ;
3951                a := hold[hold] ; hold := hold - 1 ;
3952                clearxy ; z = a intersectiontimes r ;
3953            fi
3954            (t[incr n], whatever) = p intersectiontimes point x of a ;
3955            if x = 0 :
3956                a := a cutbefore c shifted point x of a ;
3957            elseif x = length a :
3958                a := a cutafter  c shifted point x of a ;
3959            else : % before or after?
3960                b := subpath (0,x)        of a cutafter  c shifted point x of a ;
3961                bcuttings := cuttings ;
3962                a := subpath (x,length a) of a cutbefore c shifted point x of a ;
3963                clearxy ; z = a intersectiontimes r ;
3964                if x < 0 :
3965                    a := b ;
3966                    cuttings := bcuttings ;
3967                else :
3968                    if length bcuttings > 0 :
3969                        clearxy ; z = b intersectiontimes r ;
3970                        if x >= 0 :
3971                            hold[incr hold] := b ;
3972                        fi
3973                    fi
3974                fi
3975            fi
3976            if length cuttings = 0 : % a single point: nothing cut
3977                exitif hold < 1 ;
3978                a := hold[hold] ; hold := hold - 1 ;
3979            fi
3980            if i = crossingnumbermax :
3981                message("crossingunder reached maximum " & decimal i & " intersections.");
3982            fi
3983        endfor
3984
3985        if n = 0 : % No crossings, we return the PATH
3986            save pic ; path pic ; pic := p ;
3987        else : % n>0
3988            sortlist(t,) ;
3989            % we add too much, maybe a test is needed
3990            t[incr n] = length p if cycle p : + t[1] fi ;
3991% save tt[] ; numeric tt[] ; uniquelist(t,tt) ; t := tt ;
3992            % Now, n>1 !
3993            % t[0] is the first point of the path and t[n] is the last point
3994            % (or the first intersection beyond the length if cyclic)
3995            save m ; m := 0 ;
3996            for i=if cycle p: 2 else: 1 fi upto n :
3997                % skip the first segment if cyclic
3998                % as it gets repeated (fully) at the end.
3999                if crossingdebug > 0 :
4000                    if crossingdebug = 1 :
4001                        addto pic doublepath c shifted point t[i] of p
4002                        withpen currentpen withtransparency(1,.5) ;
4003                    elseif crossingdebug = 2 :
4004                        addto pic also
4005                        infotext (incr m,crossingscale/5)
4006                        shifted point t[i] of p ;
4007                    fi
4008                fi
4009                a := subpath (t[i-1],t[i]) of p
4010                    if i > 1 :
4011                        cutbefore (c shifted point t[i-1] of p)
4012                    fi
4013                    if (i < n) or (cycle p) :
4014                        cutafter  (c shifted point t[i]   of p)
4015                    fi ;
4016                if (not picture q) or (a outsideof q) :
4017                    addto pic doublepath a withpen currentpen ;
4018                fi
4019            endfor
4020        fi
4021    fi
4022    pic
4023    endgroup
4024enddef ;
4025
4026primarydef p insideof q =
4027    begingroup
4028        save pth, pic, t ;
4029        path pth ; picture pic ;
4030        pic := if path q : image(draw q;) else : q fi ;
4031        pth := p -- center pic ;
4032        (t, whatever) = pth intersectiontimes boundingbox pic ;
4033        t < 0
4034    endgroup
4035enddef ;
4036
4037% primarydef p insideof q =
4038%     if (path q or picture q) :
4039%         if (path p or picture p) :
4040%             (xpart llcorner p > xpart llcorner q) and
4041%             (xpart urcorner p < xpart urcorner q) and
4042%             (ypart llcorner p > ypart llcorner q) and
4043%             (ypart urcorner p < ypart urcorner q)
4044%         elseif pair p  :
4045%             (xpart p > xpart llcorner q) and
4046%             (xpart p < xpart urcorner q) and
4047%             (ypart p > ypart llcorner q) and
4048%             (ypart p < ypart urcorner q)
4049%         fi
4050%     elseif (numeric p and pair q) :
4051%         % range check
4052%         (p >= xpart q) and (p <= ypart q)
4053%     else : % maybe triplets and such
4054%         false
4055%     fi
4056% enddef ;
4057
4058primarydef p outsideof q =
4059    not (p insideof q)
4060enddef ;
4061
4062permanent crossingdebug, crossingscale, crossingnumbermax, infotext, crossingunder, insideof, outsideof ;
4063
4064%D Also handy:
4065
4066vardef circularpath primary n =
4067    reverse (for i=0 step 2/n until 8-2/n+2eps: point i of fullcircle .. endfor cycle) rotated 90
4068enddef ;
4069
4070vardef squarepath primary n =
4071    for i=0 step 1/n until 4-1/n + 2eps: point i of fullsquare -- endfor cycle
4072enddef ;
4073
4074vardef linearpath primary n =
4075    origin for i=1/n step 1/n until 1-1/n + 2eps: -- point i of (origin--(1,0)) endfor
4076enddef ;
4077
4078permanent circularpath, squarepath, linearpath ;
4079
4080%D  A nice tracing helper:
4081
4082color       pensilcolor ; pensilcolor := .5red ;
4083newinternal pensilstep  ; pensilstep  := 1/25 ;
4084
4085vardef pensilled(expr p, q) =
4086    image (
4087        draw p withcolor pensilcolor withpen q ;
4088        for i = 0 step pensilstep until length(p) + eps:
4089            draw point i of p withcolor white withtransparency (1,.5) withpen q ;
4090        endfor ;
4091    )
4092enddef ;
4093
4094permanent pensilled, pensilcolor, pensilstep ;
4095
4096%D Easy to forget but handy for manuals:
4097
4098vardef tolist(suffix l)(text t) =
4099    save n ; n := 1 ;
4100    for p = t :
4101        if numeric p :
4102            n := p ;
4103            dispose(l[n])
4104        elseif pair p :
4105            l[n] := p ;
4106            n := n + 1 ;
4107        elseif path p :
4108            for i=0 step 1 until length(p) :
4109                l[n] := point i of p ;
4110                n := n + 1 ;
4111            endfor ;
4112        else :
4113            % ignore
4114        fi ;
4115    endfor ;
4116    forever :
4117        exitif unknown l[n] ;
4118        dispose(l[n])
4119        n := n + 1 ;
4120    endfor ;
4121enddef ;
4122
4123vardef topath(suffix p)(text t) =
4124    save i ; i := if known p[1] : 2 ; p[1] elseif known p[0] : 1 ; p[0] else : 0 ; origin fi
4125    forever :
4126        exitif unknown p[i] ;
4127        t p[i]
4128        hide(i := i + 1)
4129    endfor
4130enddef ;
4131
4132vardef tocycle(suffix p)(text t) =
4133    topath(p,t) t cycle
4134enddef ;
4135
4136permanent tolist, topath, tocycle ;
4137
4138% reimplemented to support paths and pictures
4139
4140def drawdot expr p =
4141    if pair p :
4142        addto currentpicture doublepath p
4143            withpen currentpen base_draw_options
4144    elseif path p :
4145        draw image (
4146            for i=0 upto length p :
4147                addto currentpicture doublepath point i of p
4148                    withpen currentpen base_draw_options ;
4149            endfor ;
4150        )
4151    elseif picture p :
4152        draw image (
4153            save pp ; path pp ;
4154            for i within p :
4155                if stroked i or filled i :
4156                    pp := pathpart i ;
4157                    for j=0 upto length pp :
4158                        addto currentpicture doublepath point j of pp
4159                            withpen currentpen base_draw_options ;
4160                    endfor ;
4161                fi ;
4162            endfor ;
4163        )
4164    fi
4165enddef ;
4166
4167permanent drawdot ;
4168
4169% vardef textlength(text t) =
4170%     save n ; n := 0 ;
4171%     for i = t :
4172% 		n := n + 1 ;
4173% 	endfor;
4174%     n
4175% enddef;
4176
4177vardef mfun_timestamp =
4178    decimal year                        & "-" &
4179    decimal month                       & "-" &
4180    decimal day                         & " " &
4181    if ((time div 60) < 10)           :   "0" & fi
4182    decimal (time div 60)               & ":" &
4183    if ((time-(time div 60)*60) < 10) :   "0" & fi
4184    decimal (time-(time div 60)*60)
4185enddef ;
4186
4187vardef totransform(expr x, y, xx, xy, yx, yy) =
4188    save t ; transform t ;
4189    xxpart t = xx ; yypart t = yy ;
4190    xypart t = xy ; yxpart t = yx ;
4191    xpart  t = x  ; ypart  t = y  ;
4192    t
4193enddef ;
4194
4195vardef bymatrix(expr rx, sx, sy, ry, tx, ty) =
4196    save t ; transform t ;
4197    xxpart t = rx ; yypart t = ry ;
4198    xypart t = sx ; yxpart t = sy ;
4199    xpart  t = tx ; ypart  t = ty ;
4200    t
4201enddef ;
4202
4203% vardef bytopdownmatrix(expr rx, sx, sy, ry, tx, ty) =
4204%     save t ; transform t ;
4205%     xxpart t =  rx ; yypart t =  ry ;
4206%     xypart t = -sy ; yxpart t = -sx ;
4207%     xpart  t =  tx ; ypart  t =  ty ;
4208%     t
4209% enddef ;
4210
4211vardef closedcurve primary p =
4212    p if (path p and not cycle p) or (pair p) : .. cycle fi
4213enddef ;
4214
4215vardef closedlines primary p =
4216    p if (path p and not cycle p) or (pair p) : -- cycle fi
4217enddef ;
4218
4219permanent totransform, bymatrix, closedcurve, closedlines ;
4220
4221let xslanted = slanted ;
4222
4223def yslanted primary s =
4224    transformed
4225        begingroup
4226            save t ; transform t ;
4227            xxpart t = 1 ; yypart t = 1 ;
4228            xypart t = 0 ; yxpart t = s ;
4229            xpart  t = 0 ; ypart  t = 0 ;
4230            t
4231        endgroup
4232enddef ;
4233
4234permanent xslanted, yslanted ;
4235
4236vardef processpath (expr p) (text pp) =
4237    if path p :
4238        for i=0 upto length(p)-1 :
4239            pp(point       i    of p) .. controls
4240            pp(postcontrol i    of p) and
4241            pp(precontrol (i+1) of p) ..
4242        endfor
4243        if cycle p :
4244            cycle
4245        else :
4246            pp(point length(p) of p)
4247        fi
4248    elseif pair p :
4249        pp(p)
4250    else :
4251        p
4252    fi
4253enddef ;
4254
4255permanent processpath ;
4256
4257% By Bogluslaw Jackowski (public domain):
4258%
4259% draw hatched (fullcircle scaled 10cm) (45, 4, 1) withcolor "red" ;
4260
4261newinternal hatch_match; hatch_match := 1;
4262
4263vardef hatched(expr o) primary c =
4264    save a_, b_, d_, l_, i_, r_, za_, zb_, zc_, zd_;
4265    path b_; picture r_; pair za_, zb_, zc_, zd_;
4266    r_ := image (
4267        a_ := redpart(c) mod 180 ;
4268        l_ := greenpart(c) ;
4269        d_ := -bluepart(c) ;
4270        b_ := o rotated -a_ ;
4271        b_ :=
4272            if a_ >= 90 :
4273                (lrcorner b_ -- llcorner b_ -- ulcorner b_ -- urcorner b_ -- cycle)
4274            else :
4275                (llcorner b_ -- lrcorner b_ -- urcorner b_ -- ulcorner b_ -- cycle)
4276            fi
4277            rotated a_ ;
4278        za_ := point 0 of b_ ;
4279        zb_ := point 1 of b_ ;
4280        zc_ := point 2 of b_ ;
4281        zd_ := point 3 of b_ ;
4282        if hatch_match > 0 :
4283            n_ := round(length(zd_-za_) / l_) ;
4284            if n_ < 2:
4285                n_ := 2 ;
4286            fi ;
4287            l_ := length(zd_-za_) / n_ ;
4288        else :
4289            n_ := length(zd_-za_) / l_ ;
4290        fi
4291        save currentpen; pen currentpen ; pickup pencircle scaled d_;
4292        % we use a single path instead:
4293        for i_ := if hatch_match > 0 : 1 else : 0 fi upto ceiling n_ - 1 :
4294            nodraw (i_/n_)[zd_,za_] -- (i_/n_)[zc_,zb_] ;
4295        endfor
4296        dodraw origin ;
4297    ) ;
4298    clip r_ to o;
4299    r_
4300enddef;
4301
4302permanent hatched ;
4303
4304% By Mikael Sundqvist, with a little evolution:
4305
4306numeric mfun_dash_on, mfun_dash_off ;
4307
4308% primarydef p withdashes len =
4309%     hide (
4310%         save l, t, n, m ; pair t ;
4311%         l := arclength p ;
4312%         t := paired(len) ;
4313%         m := xpart t + ypart t ;
4314%         n := l / (l div m) / m ;
4315%         mfun_dash_on  := n * xpart t ;
4316%         mfun_dash_off := n * ypart t ;
4317%     )
4318%     p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
4319% enddef ;
4320
4321primarydef p withdashes len =
4322    hide (
4323        save l, t, n, m, don, doff; pair t ;
4324        l := arclength p ;
4325        t := paired (len) ;
4326        m := xpart t + ypart t ;
4327        n := (l if not cycle p : - xpart t fi) div m ;
4328        (n if not cycle p : + 1 fi) * don + n * doff = l ;
4329        don*(ypart t) = doff*(xpart t) ;
4330        mfun_dash_on := don ;
4331        mfun_dash_off := doff ;
4332    )
4333    p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
4334enddef ;
4335
4336permanent withdashes ;
4337
4338%D For Mikael:
4339
4340path mfun_b ;
4341pair mfun_k ;
4342
4343path mfun_nullpath ;
4344
4345tertiarydef p sortedintersectiontimes q =
4346    sortedpath (p intersectiontimeslist q)
4347enddef ;
4348
4349tertiarydef p intersectionpath q =
4350    begingroup ;
4351    save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4352    save mfun_k ; pair mfun_k ; mfun_k := point 0 of mfun_b;
4353    if mfun_k <> (-1,-1) :
4354        .5[point xpart mfun_k of p, point ypart mfun_k of q]
4355        for i = 1 upto length(mfun_b) :
4356            hide(mfun_k := point i of mfun_b;)
4357            -- .5[point xpart mfun_k of p, point ypart mfun_k of q]
4358        endfor
4359    else :
4360        mfun_nullpath
4361    fi
4362    endgroup
4363enddef ;
4364
4365tertiarydef p firstintersectionpath q =
4366    begingroup ;
4367    save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4368    if (point 0 of mfun_b) <> (-1,-1) :
4369        point xpart (point 0 of mfun_b) of p
4370        for i = 1 upto length(mfun_b) :
4371            -- point xpart (point i of mfun_b) of p
4372        endfor
4373    else :
4374        mfun_nullpath
4375    fi
4376    endgroup
4377enddef ;
4378
4379tertiarydef p secondintersectionpath q =
4380    q firstintersectionpath p
4381enddef;
4382
4383vardef intersectionsfound expr p =
4384    (point 0 of p) <> (-1,-1)
4385enddef ;
4386
4387%D As part of our intersection journey MS came up with:
4388
4389tertiarydef p cutbeforefirst q =
4390    begingroup ;
4391    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4392    if (point 0 of mfun_b) <> (-1,-1) :
4393        mfun_p := subpath(xpart point 0 of mfun_b, length p) of p;
4394    else :
4395        mfun_p := p ;
4396    fi ;
4397    mfun_p
4398    endgroup
4399enddef ;
4400
4401tertiarydef p cutafterfirst q =
4402    begingroup ;
4403    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4404    if (point 0 of mfun_b) <> (-1,-1) :
4405        mfun_p := subpath(0, xpart point 0 of mfun_b) of p;
4406    else :
4407        mfun_p := p ;
4408    fi ;
4409    mfun_p
4410    endgroup
4411enddef ;
4412
4413
4414tertiarydef p cutbeforelast q =
4415    begingroup ;
4416    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4417    if (point 0 of mfun_b) <> (-1,-1) :
4418        mfun_p := subpath(xpart point (length mfun_b) of mfun_b, length p) of p;
4419    else :
4420        mfun_p := p ;
4421    fi ;
4422    mfun_p
4423    endgroup
4424enddef ;
4425
4426tertiarydef p cutafterlast q =
4427    begingroup ;
4428    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4429    if (point 0 of mfun_b) <> (-1,-1) :
4430        mfun_p := subpath(0, xpart point (length mfun_b) of mfun_b) of p;
4431    else :
4432        mfun_p := p ;
4433    fi ;
4434    mfun_p
4435    endgroup
4436enddef ;
4437
4438% I don't want to define this path every time I make a demo:
4439
4440vardef starring(expr e) =
4441    save a, b, c, d ;
4442    pair a, b, c, d ;
4443    a := (-1,-1) ; b := ( 1,-1) ;
4444    c := ( 1, 1) ; d := (-1, 1) ;
4445    a -- (.5[a,b] shifted (0,-e)) --
4446    b -- (.5[b,c] shifted (e, 0)) --
4447    c -- (.5[c,d] shifted (0, e)) --
4448    d -- (.5[d,a] shifted (-e,0)) -- cycle
4449enddef ;
4450
4451vardef dashing (expr pth, shp, stp) =
4452    for i within arcpointlist stp of pth :
4453        shp
4454            rotated angle(pathdirection)
4455            shifted pathpoint
4456        &&
4457    endfor nocycle
4458enddef ;
4459
4460% like center, mod and div this is a candidate for a primitive
4461
4462% vardef centerofmass primary p =
4463%     (origin for i within p : + pathpoint endfor) / length(p)
4464% enddef ;
4465