Source Browser ?

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 ;
824
825primarydef p xysized s = % a one step transform might be faster
826    begingroup
827    save wh, w, h, b ; pair wh ; path b;
828    b := corners p ;
829    w := xpart point 1 of b - xpart point 0 of b ;
830    h := ypart point 2 of b - ypart point 1 of b ;
831    wh := paired (s) ;
832    p
833        if (w > 0) and (h > 0) :
834            if xpart wh > 0 : xscaled (xpart wh/w) fi
835            if ypart wh > 0 : yscaled (ypart wh/h) fi
836        fi
837    endgroup
838enddef ;
839
840% to be tested
841%
842% primarydef p xysized s =
843%     begingroup
844%     save wh, w, h ; pair wh ; numeric w, h ;
845%     wh := paired (s) ; w := bbwidth(p) ; h := bbheight(p) ;
846%     if (w > 0) and (h > 0) :
847%         transform t ; t := identity if xpart wh > 0 : xscaled (xpart wh/w) fi if ypart wh > 0 : yscaled (ypart wh/h)
848%     fi ;
849%     p if (w > 0) and (h > 0) : transformed t fi
850%     endgroup
851% enddef ;
852
853let sized = xysized ;
854
855permanent xsized, ysized, xysized, sized ;
856
857% primarydef p xynormalized s =
858%     begingroup
859%     save w, h ; numeric w, h ;
860%     w := bbwidth(p) ;
861%     h := bbheight(p) ;
862%     if (w > 0) and (h > 0) :
863%         save t, wh ; transform t ; pair wh ;
864%         wh := paired (s) ;
865%         t := identity
866%             shifted - llcorner p
867%             if xpart wh > 0 : xscaled (xpart wh/w) fi
868%             if ypart wh > 0 : yscaled (ypart wh/h) fi
869%         ;
870%         p transformed t
871%     else :
872%         p
873%     fi
874%     endgroup
875% enddef ;
876primarydef p xynormalized s =
877    begingroup save w, h, b ; path b;
878    b := corners p ;
879    w := xpart point 1 of b - xpart point 0 of b ;
880    h := ypart point 2 of b - ypart point 1 of b ;
881    if (w > 0) and (h > 0) :
882        save t, wh ; transform t ; pair wh ;
883        wh := paired (s) ;
884        t := identity
885            shifted - llcorner p
886            if xpart wh > 0 : xscaled (xpart wh/w) fi
887            if ypart wh > 0 : yscaled (ypart wh/h) fi
888        ;
889        p transformed t
890    else :
891        p
892    fi
893    endgroup
894enddef ;
895
896% primarydef p xnormalized s =
897%     begingroup
898%     save w ; numeric w ;
899%     w := bbwidth(p) ;
900%     if (w > 0) :
901%         save t ; transform t ;
902%         t := identity
903%             shifted - llcorner p
904%             if s > 0 : xscaled (s/w) fi
905%         ;
906%         p transformed t
907%     else :
908%         p
909%     fi
910%     endgroup
911% enddef ;
912primarydef p xnormalized s =
913    begingroup save h, r ; pair r ;
914    r := xrange p ;
915    w := ypart r - xpart r ;
916    if (w > 0) :
917        save t ; transform t ;
918        t := identity
919            shifted - llcorner p
920            if s > 0 : xscaled (s/w) fi
921        ;
922        p transformed t
923    else :
924        p
925    fi
926    endgroup
927enddef ;
928
929% primarydef p ynormalized s =
930%     begingroup
931%     save h ; numeric h ;
932%     h := bbheight(p) ;
933%     if (h > 0) :
934%         save t ; transform t ;
935%         t := identity
936%             shifted - llcorner p
937%             if s > 0 : yscaled (s/h) fi
938%         ;
939%         p transformed t
940%     else :
941%         p
942%     fi
943%     endgroup
944% enddef ;
945primarydef p ynormalized s =
946    begingroup save h, r ; pair r ;
947    r := yrange p ;
948    h := ypart r - xpart r ;
949    if (h > 0) :
950        save t ; transform t ;
951        t := identity
952            shifted - llcorner p
953            if s > 0 : yscaled (s/h) fi
954        ;
955        p transformed t
956    else :
957        p
958    fi
959    endgroup
960enddef ;
961
962permanent xnormalized, ynormalized, xynormalized ;
963
964% def xscale_currentpicture(expr w) = % obsolete
965%     currentpicture := currentpicture xsized w ;
966% enddef;
967%
968% def yscale_currentpicture(expr h) = % obsolete
969%     currentpicture := currentpicture ysized h ;
970% enddef;
971%
972% def xyscale_currentpicture(expr w, h) = % obsolete
973%     currentpicture := currentpicture xysized (w,h) ;
974% enddef;
975%
976% def scale_currentpicture(expr w, h) = % obsolete
977%     currentpicture := currentpicture xsized w ;
978%     currentpicture := currentpicture ysized h ;
979% enddef;
980
981%D A full circle is centered at the origin, while a unitsquare is located in the first
982%D quadrant. Now guess what kind of path fullsquare and unitcircle do return.
983
984path fullsquare, unitcircle ;
985
986fullsquare := unitsquare shifted - center unitsquare ;
987unitcircle := fullcircle shifted urcorner fullcircle ;
988
989%D Some more paths:
990
991path urcircle, ulcircle, llcircle, lrcircle ;
992
993urcircle := origin -- (+.5,0) & (+.5,0){up}    .. (0,+.5) & (0,+.5) -- cycle ;
994ulcircle := origin -- (0,+.5) & (0,+.5){left}  .. (-.5,0) & (-.5,0) -- cycle ;
995llcircle := origin -- (-.5,0) & (-.5,0){down}  .. (0,-.5) & (0,-.5) -- cycle ;
996lrcircle := origin -- (0,-.5) & (0,-.5){right} .. (+.5,0) & (+.5,0) -- cycle ;
997
998path tcircle, bcircle, lcircle, rcircle ;
999
1000tcircle := origin -- (+.5,0) & (+.5,0) {up}    .. (0,+.5) .. {down}  (-.5,0) -- cycle ;
1001bcircle := origin -- (-.5,0) & (-.5,0) {down}  .. (0,-.5) .. {up}    (+.5,0) -- cycle ;
1002lcircle := origin -- (0,+.5) & (0,+.5) {left}  .. (-.5,0) .. {right} (0,-.5) -- cycle ;
1003rcircle := origin -- (0,-.5) & (0,-.5) {right} .. (+.5,0) .. {left}  (0,+.5) -- cycle ;
1004
1005path urtriangle, ultriangle, lltriangle, lrtriangle ; % watch out: it's contrary to what you expect and starts in the origin
1006
1007urtriangle := origin -- (+.5,0) -- (0,+.5) -- cycle ;
1008ultriangle := origin -- (0,+.5) -- (-.5,0) -- cycle ;
1009lltriangle := origin -- (-.5,0) -- (0,-.5) -- cycle ;
1010lrtriangle := origin -- (0,-.5) -- (+.5,0) -- cycle ;
1011
1012path triangle, uptriangle, downtriangle, lefttriangle, righttriangle ;
1013
1014triangle      := (1,0) -- (1,0) rotated 120 -- (1,0) rotated -120 -- cycle ;
1015
1016uptriangle    := triangle rotated  90 ;
1017downtriangle  := triangle rotated -90 ;
1018lefttriangle  := triangle rotated 180 ;
1019righttriangle := triangle ;
1020
1021path unitdiamond, fulldiamond ;
1022
1023unitdiamond := (.5,0) -- (1,.5) -- (.5,1) -- (0,.5) -- cycle ;
1024fulldiamond := unitdiamond shifted - center unitdiamond ;
1025
1026path unitoctagon, fulloctagon ;
1027
1028unitoctagon := for i within (unitcircle rotated 45/2) : pathpoint -- endfor cycle ;
1029fulloctagon := unitoctagon shifted - center unitoctagon ;
1030
1031path unithexagon, fullhexagon ;
1032
1033%%%%hexagon := for i = 0 upto 5 : .5dir (60i) -- endfor cycle ;
1034fullhexagon := for i = 0 step 60 until 360 : .5 dir(i) -- endfor cycle ;
1035unithexagon := fullhexagon shifted (.5,.5) ;
1036
1037permanent
1038    fullsquare, unitcircle,
1039    urcircle, ulcircle, llcircle, lrcircle,
1040    tcircle, bcircle, lcircle, rcircle,
1041    urtriangle, ultriangle, lltriangle, lrtriangle,
1042    triangle, uptriangle, downtriangle, lefttriangle, righttriangle,
1043    unitdiamond, fulldiamond, unitoctagon, fulloctagon, unithexagon, fullhexagon ;
1044
1045%D More robust:
1046
1047% let  normalscaled =  scaled ;
1048% let normalxscaled = xscaled ;
1049% let normalyscaled = yscaled ;
1050%
1051% def  scaled expr s =  normalscaled (s) enddef ;
1052% def xscaled expr s = normalxscaled (s) enddef ;
1053% def yscaled expr s = normalyscaled (s) enddef ;
1054
1055%D Shorter
1056
1057% primarydef p xyscaled q = % secundarydef does not work out well
1058%     begingroup
1059%     save qq ; pair qq ;
1060%     qq = paired(q) ;
1061%     p
1062%       % if xpart qq <> 0 : xscaled (xpart qq) fi
1063%       % if ypart qq <> 0 : yscaled (ypart qq) fi
1064%         xscaled (xpart qq)
1065%         yscaled (ypart qq)
1066%     endgroup
1067% enddef ;
1068%
1069% permanent xyscaled ;
1070
1071%D Some personal code that might move to another module (todo: save).
1072
1073def set_grid(expr w, h, nx, ny) =
1074    boolean grid[][] ; boolean grid_full ;
1075    numeric grid_w, grid_h, grid_nx, grid_ny, grid_x, grid_y, grid_left ;
1076    grid_w := w ;
1077    grid_h := h ;
1078    grid_nx := nx ;
1079    grid_ny := ny ;
1080    grid_x := round(w/grid_nx) ; % +.5) ;
1081    grid_y := round(h/grid_ny) ; % +.5) ;
1082    grid_left := (1+grid_x)*(1+grid_y) ;
1083    grid_full := false ;
1084    for i=0 upto grid_x :
1085        for j=0 upto grid_y :
1086            grid[i][j] := false ;
1087        endfor ;
1088    endfor ;
1089enddef ;
1090
1091vardef new_on_grid(expr grid_dx, grid_dy) =
1092    dx := grid_dx ;
1093    dy := grid_dy ;
1094    ddx := min(round(dx/grid_nx),grid_x) ; % +.5),grid_x) ;
1095    ddy := min(round(dy/grid_ny),grid_y) ; % +.5),grid_y) ;
1096    if not grid_full and not grid[ddx][ddy] :
1097        grid[ddx][ddy] := true ;
1098        grid_left := grid_left-1 ;
1099        grid_full := (grid_left=0) ;
1100        true
1101    else :
1102        false
1103    fi
1104enddef ;
1105
1106%D usage: \type{innerpath peepholed outerpath}.
1107%D
1108%D \startMPcode
1109%D   fill (fullsquare scaled 200) withcolor red ;
1110%D   path p ; p := (fullcircle scaled 100) ; bboxmargin := 0 ;
1111%D   fill p peepholed bbox p ;
1112%D \stopMPcode
1113
1114secondarydef p peepholed q =
1115    begingroup
1116    save start ; pair start ;
1117    start := point 0 of p ;
1118    if xpart start >= xpart center p :
1119        if ypart start >= ypart center p :
1120            urcorner q -- ulcorner q -- llcorner q -- lrcorner q --
1121            reverse  p -- lrcorner q -- cycle
1122        else :
1123            lrcorner q -- urcorner q -- ulcorner q -- llcorner q --
1124            reverse  p -- llcorner q -- cycle
1125        fi
1126    else :
1127        if ypart start > ypart center p :
1128            ulcorner q -- llcorner q -- lrcorner q -- urcorner q --
1129            reverse  p -- urcorner q -- cycle
1130        else :
1131            llcorner q -- lrcorner q -- urcorner q -- ulcorner q --
1132            reverse  p -- ulcorner q -- cycle
1133        fi
1134    fi
1135    endgroup
1136enddef ;
1137
1138newinternal boolean intersection_found ;
1139
1140secondarydef p intersection_point q =
1141    begingroup
1142    save temp_x, temp_y ;
1143    (temp_x,temp_y) = p intersectiontimes q ;
1144    if temp_x < 0 :
1145        intersection_found := false ;
1146        center p % origin
1147    else :
1148        intersection_found := true ;
1149        .5[point temp_x of p, point temp_y of q]
1150    fi
1151    endgroup
1152enddef ;
1153
1154permanent intersection_found, intersection_point ;
1155
1156%D New, undocumented, experimental:
1157
1158vardef tensecircle (expr width, height, offset) =
1159    (-width/2,-height/2) ... (0,-height/2-offset) ...
1160    (+width/2,-height/2) ... (+width/2+offset,0)  ...
1161    (+width/2,+height/2) ... (0,+height/2+offset) ...
1162    (-width/2,+height/2) ... (-width/2-offset,0)  ... cycle
1163enddef ;
1164
1165vardef roundedsquare (expr width, height, offset) =
1166    (offset,0)            -- (width-offset,0)      {right} ..
1167    (width,offset)        -- (width,height-offset) {up}    ..
1168    (width-offset,height) -- (offset,height)       {left}  ..
1169    (0,height-offset)     -- (0,offset)            {down}  .. cycle
1170enddef ;
1171
1172vardef roundedsquarexy (expr width, height, dx, dy) =
1173    (dx,0)            -- (width-dx,0)      {right} ..
1174    (width,dy)        -- (width,height-dy) {up}    ..
1175    (width-dx,height) -- (dx,height)       {left}  ..
1176    (0,height-dy)     -- (0,dy)            {down}  .. cycle
1177enddef ;
1178
1179permanent tensecircle, roundedsquare, roundedsquarexy ;
1180
1181%D Some colors.
1182
1183def resolvedcolor(expr s) =
1184    .5white
1185enddef ;
1186
1187let normalwithcolor = withcolor ;
1188
1189def withcolor expr c =
1190     normalwithcolor if string c : resolvedcolor(c) else : c fi
1191enddef ;
1192
1193permanent resolvedcolor, normalwithcolor, withcolor ;
1194
1195% I don't want a "withcolor black" in case of an empty string ... who knows how that can
1196% interfere with outer colors. Somehow the next one doesn't always work out ok, but why
1197% ... must be some parsing issue. Anyway, when we cannot do that, we need to fix some
1198% chem macros instead as empty strings now lead to black while everywhere else in context
1199% empty means: leave color untouched.
1200
1201% def withcolor expr c =
1202%     if not string c :
1203%         normalwithcolor c
1204%     elseif c <> "" :
1205%         normalwithcolor resolvedcolor(c)
1206%     fi
1207% enddef ;
1208
1209% So why does this work better than the above:
1210%
1211% def withcolor expr c =
1212%     if string c :
1213%         if c <> "" :
1214%             normalwithcolor resolvedcolor(c)
1215%         fi
1216%     else :
1217%         normalwithcolor c
1218%     fi
1219% enddef ;
1220
1221vardef colortype expr c =
1222        if cmykcolor c : cmykcolor
1223    elseif rgbcolor  c : rgbcolor
1224    elseif numeric   c : grayscale
1225        fi
1226enddef ;
1227
1228vardef whitecolor expr c =
1229        if cmykcolor c : (0,0,0,0)
1230    elseif rgbcolor  c : (1,1,1)
1231    elseif numeric   c : 1
1232    elseif string    c : whitecolor resolvedcolor(c)
1233        fi
1234enddef ;
1235
1236vardef blackcolor expr c =
1237        if cmykcolor c : (0,0,0,1)
1238    elseif rgbcolor  c : (0,0,0)
1239    elseif numeric   c : 0
1240    elseif string    c : blackcolor resolvedcolor(c)
1241        fi
1242enddef ;
1243
1244vardef complementary expr c =
1245        if cmykcolor c : (1,1,1,1) - c
1246    elseif rgbcolor  c : (1,1,1) - c
1247    elseif pair      c : (1,1) - c
1248    elseif numeric   c :  1 - c
1249    elseif string    c : complementary resolvedcolor(c)
1250        fi
1251enddef ;
1252
1253vardef complemented expr c =
1254    save m ;
1255        if cmykcolor c : m := max(cyanpart c, magentapart c, yellowpart c, blackpart c) ;
1256                         (m,m,m,m) - c
1257    elseif rgbcolor  c : m := max(redpart c, greenpart c, bluepart c) ;
1258                         (m,m,m) - c
1259    elseif pair      c : m := max(xpart c, ypart c) ;
1260                         (m,m) - c
1261    elseif numeric   c : m - c
1262    elseif string    c : complemented resolvedcolor(c)
1263        fi
1264enddef ;
1265
1266permanent colortype, whitecolor, blackcolor, complementary, complemented ;
1267
1268%D Well, this is the dangerous and naive version:
1269
1270% def drawfill text t =
1271%     fill t ;
1272%     draw t ;
1273% enddef;
1274
1275%D This two step approach saves the path first, since it can be a function. Attributes
1276%D must not be randomized.
1277
1278def drawfill expr c =
1279    path temp_c ; temp_c := c ;
1280    mfun_do_drawfill
1281enddef ;
1282
1283def mfun_do_drawfill text t =
1284    draw temp_c t ;
1285    fill temp_c t ;
1286enddef;
1287
1288def undrawfill expr c =
1289    drawfill c withcolor background % rather useless
1290enddef ;
1291
1292permanent drawfill, undrawfill ;
1293
1294%D Moved from mp-char.mp
1295
1296vardef paired primary d =
1297    if pair d : d else : (d,d) fi
1298enddef ;
1299
1300vardef tripled primary d =
1301    if color d : d else : (d,d,d) fi
1302enddef ;
1303
1304permanent paired, tripled ;
1305
1306% maybe secondaries:
1307
1308primarydef p enlarged       d = ( p llmoved d -- p lrmoved d -- p urmoved d -- p ulmoved d -- cycle ) enddef ;
1309primarydef p llenlarged     d = ( p llmoved d -- lrcorner p  -- urcorner p  -- ulcorner p  -- cycle ) enddef ;
1310primarydef p lrenlarged     d = ( llcorner p  -- p lrmoved d -- urcorner p  -- ulcorner p  -- cycle ) enddef ;
1311primarydef p urenlarged     d = ( llcorner p  -- lrcorner p  -- p urmoved d -- ulcorner p  -- cycle ) enddef ;
1312primarydef p ulenlarged     d = ( llcorner p  -- lrcorner p  -- urcorner p  -- p ulmoved d -- cycle ) enddef ;
1313
1314primarydef p llmoved        d = ( (llcorner p) shifted (-xpart paired(d),-ypart paired(d)) ) enddef ;
1315primarydef p lrmoved        d = ( (lrcorner p) shifted (+xpart paired(d),-ypart paired(d)) ) enddef ;
1316primarydef p urmoved        d = ( (urcorner p) shifted (+xpart paired(d),+ypart paired(d)) ) enddef ;
1317primarydef p ulmoved        d = ( (ulcorner p) shifted (-xpart paired(d),+ypart paired(d)) ) enddef ;
1318
1319primarydef p leftenlarged   d = ( (llcorner p) shifted (-d,0) -- lrcorner p -- urcorner p -- (ulcorner p) shifted (-d,0) -- cycle ) enddef ;
1320primarydef p rightenlarged  d = ( llcorner p -- (lrcorner p) shifted (d,0) -- (urcorner p) shifted (d,0) -- ulcorner p -- cycle   ) enddef ;
1321primarydef p topenlarged    d = ( llcorner p -- lrcorner p -- (urcorner p) shifted (0,d) -- (ulcorner p) shifted (0,d) -- cycle   ) enddef ;
1322primarydef p bottomenlarged d = ( llcorner p shifted (0,-d) -- lrcorner p shifted (0,-d) -- urcorner p -- ulcorner p -- cycle     ) enddef ;
1323
1324
1325permanent
1326    enlarged, llenlarged, lrenlarged, urenlarged, ulenlarged,
1327    llmoved, lrmoved, urmoved, ulmoved,
1328    leftenlarged, rightenlarged, topenlarged, bottomenlarged ;
1329
1330%D Handy as stepper:
1331
1332vardef rotation(expr i, n) =
1333    if (n == 0) : 0 else : i * 360 / n fi
1334enddef ;
1335
1336
1337permanent rotation ;
1338
1339%D Handy for testing/debugging; the ladders are for math:
1340
1341primarydef p crossed d = (
1342    if pair p :
1343        p shifted (-d, 0) -- p --
1344        p shifted ( 0,-d) -- p --
1345        p shifted (+d, 0) -- p --
1346        p shifted ( 0,+d) -- p -- cycle
1347    else :
1348        center p shifted (-d, 0) -- llcorner p --
1349        center p shifted ( 0,-d) -- lrcorner p --
1350        center p shifted (+d, 0) -- urcorner p --
1351        center p shifted ( 0,+d) -- ulcorner p -- cycle
1352    fi
1353) enddef ;
1354
1355% vardef laddered primary p = % was expr
1356%     point 0 of p
1357%     for i=1 upto length(p) :
1358%         -- (xpart (point i of p), ypart (point (i-1) of p)) -- (point i of p)
1359%     endfor
1360% enddef ;
1361
1362vardef laddered primary p = % was expr
1363    save a; pair a ; a := point 0 of p ; a --
1364    for i within p :
1365        if i > 0 : (xpart pathpoint, ypart a) -- pathpoint -- fi
1366        hide(a := pathpoint)
1367    endfor
1368    if cycle p :
1369        (xpart point 0 of p, ypart a) -- point 0 of p -- cycle
1370    else :
1371        nocycle
1372    fi
1373enddef ;
1374
1375permanent crossed, laddered ;
1376
1377%D Saves typing:
1378
1379% vardef bottomboundary primary p = (llcorner p -- lrcorner p) enddef ;
1380% vardef rightboundary  primary p = (lrcorner p -- urcorner p) enddef ;
1381% vardef topboundary    primary p = (urcorner p -- ulcorner p) enddef ;
1382% vardef leftboundary   primary p = (ulcorner p -- llcorner p) enddef ;
1383
1384vardef bottomboundary primary p = if pair p : p else : (llcorner p -- lrcorner p) fi enddef ;
1385vardef rightboundary  primary p = if pair p : p else : (lrcorner p -- urcorner p) fi enddef ;
1386vardef topboundary    primary p = if pair p : p else : (urcorner p -- ulcorner p) fi enddef ;
1387vardef leftboundary   primary p = if pair p : p else : (ulcorner p -- llcorner p) fi enddef ;
1388
1389permanent bottomboundary, rightboundary, topboundary, leftboundary ;
1390
1391%D Nice too:
1392
1393primarydef p superellipsed s =
1394    superellipse (
1395        .5[lrcorner p,urcorner p],
1396        .5[urcorner p,ulcorner p],
1397        .5[ulcorner p,llcorner p],
1398        .5[llcorner p,lrcorner p],
1399        s
1400    )
1401enddef ;
1402
1403primarydef p squeezed s = (
1404    (llcorner p .. .5[llcorner p,lrcorner p] shifted ( 0, ypart paired(s)) .. lrcorner p) &
1405    (lrcorner p .. .5[lrcorner p,urcorner p] shifted (-xpart paired(s), 0) .. urcorner p) &
1406    (urcorner p .. .5[urcorner p,ulcorner p] shifted ( 0,-ypart paired(s)) .. ulcorner p) &
1407    (ulcorner p .. .5[ulcorner p,llcorner p] shifted ( xpart paired(s), 0) .. llcorner p) & cycle
1408) enddef ;
1409
1410primarydef p randomshifted s =
1411    begingroup ;
1412    save ss ; pair ss ;
1413    ss := paired(s) ;
1414    p shifted (-.5xpart ss + uniformdeviate xpart ss,-.5ypart ss + uniformdeviate ypart ss)
1415    endgroup
1416enddef ;
1417
1418% vardef mfun_randomized_path(expr p,s) =
1419%     for i=0 upto length(p)-1 :
1420%          (point       i    of p) .. controls
1421%         ((postcontrol i    of p) randomshifted s) and
1422%         ((precontrol (i+1) of p) randomshifted s) ..
1423%     endfor
1424%     if cycle p :
1425%         cycle
1426%     else :
1427%         (point length(p) of p)
1428%     fi
1429% enddef;
1430%
1431% Here is a Mikael Sundqvist improved version. This time we also use
1432% some new functionality.
1433
1434vardef mfun_randomized_path(expr p,s) =
1435    save r, oldr, newr, firstr, l ; pair r, oldr, newr, firstr ;
1436    r := paired(s) ;
1437    l := length(p) ;
1438    newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ;
1439    firstr := newr ;
1440    for i within p :
1441        hide (
1442            oldr := newr ;
1443            newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ;
1444        )
1445        pathpoint ..
1446        controls  (pathpostcontrol shifted oldr )
1447        and      ((deltaprecontrol 1) shifted if (i <> l - 1) : - newr else : - firstr fi) ..
1448    endfor if cycle p : cycle else : nocycle fi
1449enddef ;
1450
1451
1452vardef mfun_randomrotated_path(expr p, s) =
1453    save r, oldr, newr, firstr, l ;
1454    l := length(p) ;
1455    newr := (-1/2+uniformdeviate(1))*s ;
1456    firstr := newr ;
1457    for i within p :
1458        hide (
1459            oldr := newr ;
1460            newr := (-1/2+uniformdeviate(1)) * s ;
1461        )
1462        pathpoint ..
1463        controls  (pathpostcontrol rotatedaround(pathpoint, oldr) )
1464        and      ((deltaprecontrol 1) rotatedaround(deltapoint 1, if (i <> l - 1) : newr else : firstr fi)) ..
1465    endfor if cycle p : cycle else : nocycle fi
1466enddef ;
1467
1468vardef mfun_randomized_picture(expr p,s)(text rnd) =
1469    save currentpicture ;
1470    picture currentpicture ;
1471    currentpicture := nullpicture ;
1472    for i within p :
1473        addto currentpicture
1474            if stroked i :
1475                doublepath pathpart i rnd s
1476                dashed dashpart i
1477                withpen penpart i
1478                withcolor colorpart i
1479                withprescript prescriptpart i
1480                withpostscript postscriptpart i
1481            elseif filled i :
1482                contour pathpart i rnd s
1483                withpen penpart i
1484                withcolor colorpart i
1485                withprescript prescriptpart i
1486                withpostscript postscriptpart i
1487            else :
1488                also i
1489            fi
1490        ;
1491    endfor ;
1492    currentpicture
1493enddef ;
1494
1495primarydef p randomizedcontrols s = (
1496    if path p :
1497        mfun_randomized_path(p,s)
1498    elseif picture p :
1499        mfun_randomized_picture(p,s)(randomizedcontrols)
1500    else :
1501        p randomized s
1502    fi
1503) enddef ;
1504
1505primarydef p randomrotatedcontrols s = (
1506    if path p :
1507        mfun_randomrotated_path(p,s)
1508    elseif picture p :
1509        mfun_randomized_picture(p,s)(randomrotatedcontrols)
1510    else :
1511        p randomized s
1512    fi
1513) enddef ;
1514
1515primarydef p randomized s = (
1516    if path p :
1517        for i=0 upto length(p)-1 :
1518            ((point       i    of p) randomshifted s) .. controls
1519            ((postcontrol i    of p) randomshifted s) and
1520            ((precontrol (i+1) of p) randomshifted s) ..
1521        endfor
1522        if cycle p :
1523            cycle
1524        else :
1525            ((point length(p) of p) randomshifted s)
1526        fi
1527    elseif pair p :
1528        p randomshifted s
1529    elseif cmykcolor p :
1530        if cmykcolor s :
1531           ((uniformdeviate cyanpart    s) * cyanpart    p,
1532            (uniformdeviate magentapart s) * magentapart p,
1533            (uniformdeviate yellowpart  s) * yellowpart  p,
1534            (uniformdeviate blackpart   s) * blackpart   p)
1535        elseif pair s :
1536            ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1537        else :
1538            ((uniformdeviate s) * p)
1539        fi
1540    elseif rgbcolor p :
1541        if rgbcolor s :
1542           ((uniformdeviate redpart   s) * redpart   p,
1543            (uniformdeviate greenpart s) * greenpart p,
1544            (uniformdeviate bluepart  s) * bluepart  p)
1545        elseif pair s :
1546           ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1547        else :
1548           ((uniformdeviate s) * p)
1549        fi
1550    elseif color p :
1551        if color s :
1552            ((uniformdeviate greypart s) * greypart p)
1553        elseif pair s :
1554            ((xpart s + (uniformdeviate (ypart s - xpart s))) * p)
1555        else :
1556            ((uniformdeviate s) * p)
1557        fi
1558    elseif string p :
1559        (resolvedcolor(p)) randomized s
1560    elseif picture p :
1561        mfun_randomized_picture(p,s)(randomized)
1562    else :
1563      % p - s/2 + uniformdeviate s % would have been better but we want to be positive
1564        p + uniformdeviate s
1565    fi
1566) enddef ;
1567
1568permanent superellipsed, squeezed, randomshifted, randomized,
1569    randomizedcontrols, randomrotatedcontrols ;
1570
1571%D Not perfect (alternative for interpath)
1572
1573vardef interpolated(expr s, p, q) =
1574    save m ; numeric m ;
1575    m := max(length(p),length(q)) ;
1576    if path p :
1577        for i=0 upto m-1 :
1578            s[point       (i   /m) along p,point       (i   /m) along q] .. controls
1579            s[postcontrol (i   /m) along p,postcontrol (i   /m) along q] and
1580            s[precontrol ((i+1)/m) along p,precontrol ((i+1)/m) along q] ..
1581        endfor
1582        if cycle p :
1583            cycle
1584        else :
1585            s[point infinity of p,point infinity of q]
1586        fi
1587    else :
1588        a[p,q]
1589    fi
1590enddef ;
1591
1592permanent interpolated ;
1593
1594%D Interesting too:
1595
1596% primarydef p paralleled d = (
1597%     p shifted if d < 0 : - fi ((point abs(d) on (p rotatedaround(point 0 of p,90))) - point 0 of p)
1598% ) enddef ;
1599%
1600% primarydef p paralleled d = (
1601%     p shifted ((d*unitvector(direction 0 of p) - point 0 of p) rotated 90)
1602% ) enddef ;
1603
1604%D Alan came up with an improved version and stepwise we ended up with (or might up
1605%D with a variant of):
1606
1607def istextext(expr p) =
1608    (picture p and ((substring(0,3) of prescriptpart p) = "tx_"))
1609enddef ;
1610
1611vardef perpendicular expr t of p =
1612    unitvector((direction t of p) rotated 90)
1613enddef ;
1614
1615primarydef p paralleled d = (
1616    if path p :
1617        begingroup ;
1618        save dp ; pair dp ;
1619        for i=0 upto length p if cycle p : -1 fi :
1620            hide(dp := d * perpendicular i of p)
1621            if i > 0 : .. fi
1622            (point i of p + dp)
1623            if i < length p :
1624                .. controls (postcontrol i    of p + dp) and
1625                            (precontrol (i+1) of p + dp)
1626            fi
1627        endfor
1628        if cycle p : .. cycle fi
1629        endgroup
1630    elseif picture p :
1631        image(
1632            for i within p :
1633                draw (pathpart i)
1634                if not istextext(i) : % dirty trick
1635                    paralleled d
1636                fi
1637                mfun_decoration_i i ;
1638            endfor ;
1639        )
1640    elseif pair p :
1641        p
1642    fi
1643) enddef ;
1644
1645vardef punked primary p =
1646    point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor
1647    if cycle p : -- cycle else : -- point length(p) of p fi
1648enddef ;
1649
1650vardef curved primary p =
1651    point 0 of p for i=1 upto length(p)-1 : .. point i of p endfor
1652    if cycle p : .. cycle else : .. point length(p) of p fi
1653enddef ;
1654
1655primarydef p blownup s =
1656    begingroup
1657        save temp_p ; path temp_p ;
1658        temp_p := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ;
1659        (temp_p shifted (center p - center temp_p))
1660    endgroup
1661enddef ;
1662
1663permanent perpendicular, istextext, paralleled, punked, curved, blownup ;
1664
1665%D Rather fundamental.
1666
1667% not yet ok
1668
1669vardef mfun_left_right_path(expr p, l) = % used in s-pre-19
1670    save q, r, t, b ; path q, r ; pair t, b ;
1671    t := (ulcorner p -- urcorner p) intersection_point p ;
1672    b := (llcorner p -- lrcorner p) intersection_point p ;
1673    r := if xpart directionpoint t of p < 0 : reverse p else : p fi ; % r is needed, else problems when reverse is fed
1674    q := r cutbefore if l: t else: b fi ;
1675    q := q if xpart point 0 of r > 0 : & r fi cutafter  if l: b else: t fi ;
1676    q
1677enddef ;
1678
1679vardef  leftpath expr p = mfun_left_right_path(p,true ) enddef ;
1680vardef rightpath expr p = mfun_left_right_path(p,false) enddef ;
1681
1682permanent leftpath, rightpath ;
1683
1684%D Drawoptions
1685
1686def saveoptions =
1687    save base_draw_options ; def base_draw_options = enddef ;
1688enddef ;
1689
1690permanent saveoptions ;
1691
1692%D Tracing. (not yet in lexer)
1693
1694let normaldraw = draw ;
1695let normalfill = fill ;
1696
1697% bugged in mplib so ...
1698
1699def normalfill expr c = addto currentpicture contour c base_draw_options enddef ;
1700def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi base_draw_options enddef ;
1701
1702def drawlineoptions   (text t) = def mfun_opt_lin = t enddef ; enddef ;
1703def drawpointoptions  (text t) = def mfun_opt_pnt = t enddef ; enddef ;
1704def drawcontroloptions(text t) = def mfun_opt_ctr = t enddef ; enddef ;
1705def drawlabeloptions  (text t) = def mfun_opt_lab = t enddef ; enddef ;
1706def draworiginoptions (text t) = def mfun_opt_ori = t enddef ; enddef ;
1707def drawboundoptions  (text t) = def mfun_opt_bnd = t enddef ; enddef ;
1708def drawpathoptions   (text t) = def mfun_opt_pth = t enddef ; enddef ;
1709
1710numeric drawoptionsfactor ; drawoptionsfactor := pt ;
1711
1712def resetdrawoptions =
1713    drawlineoptions   (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1714    drawpointoptions  (withpen pencircle scaled 4.0 drawoptionsfactor withcolor   black) ;
1715    drawcontroloptions(withpen pencircle scaled 2.5 drawoptionsfactor withcolor   black) ;
1716    drawlabeloptions  () ;
1717    draworiginoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ;
1718    drawboundoptions  (dashed evenly mfun_opt_ori) ;
1719    drawpathoptions   (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ;
1720enddef ;
1721
1722resetdrawoptions ;
1723
1724%D Path.
1725
1726def drawpath expr p =
1727    normaldraw p mfun_opt_pth
1728enddef ;
1729
1730permanent
1731    drawlineoptions, drawpointoptions, drawcontroloptions, drawlabeloptions, draworiginoptions,
1732    drawboundoptions, drawpathoptions, drawpath, normaldraw ;
1733
1734%D Arrow.
1735
1736newinternal ahvariant ; ahvariant := 0 ;
1737newinternal ahdimple  ; ahdimple  := 1/5 ;
1738newinternal ahscale   ; ahscale   := 3/4 ;
1739
1740permanent ahvariant, ahdimple, ahscale ;
1741
1742vardef arrowhead expr p =
1743     save q, e, r ;
1744     pair e ; e = point length p of p ;
1745     path q ; q = gobble(p shifted -e cutafter makepath(pencircle scaled (2ahlength))) cuttings ;
1746     if ahvariant > 0:
1747         path r ; r = gobble(p shifted -e cutafter makepath(pencircle scaled ((1-ahdimple)*2ahlength))) cuttings ;
1748     fi
1749     (q rotated (ahangle/2) & reverse q rotated -(ahangle/2)
1750         if ahvariant = 1 :
1751             -- point 0 of r --
1752         elseif ahvariant = 2 :
1753             ... point 0 of r ...
1754         else :
1755         --
1756         fi
1757         cycle
1758     ) shifted e
1759enddef ;
1760
1761vardef drawarrowpath expr p =
1762%     save autoarrows ; boolean autoarrows ; autoarrows := true ;
1763    interim autoarrows := true ;
1764    drawarrow p mfun_opt_pth
1765enddef ;
1766
1767def midarrowhead expr p =
1768    arrowhead p cutafter (point length(p cutafter point .5 along p) + ahlength on p)
1769enddef ;
1770
1771vardef arrowheadonpath (expr p, s) =
1772%     save autoarrows ; boolean autoarrows ;
1773    interim autoarrows := true ;
1774    set_ahlength(scaled ahfactor) ; % added
1775    arrowhead p if s < 1 : cutafter (point (s*arclength(p) + (ahlength/2)) on p) fi
1776enddef ;
1777
1778def resetarrows =
1779    hide (
1780        ahlength  := 4 ;
1781        ahangle   := 45 ;
1782        ahvariant := 0 ;
1783        ahdimple  := 1/5 ;
1784        ahscale   := 3/4 ;
1785)
1786enddef ;
1787
1788permanent arrowhead, drawarrowpath, midarrowhead, arrowheadonpath ;
1789
1790%D Points.
1791
1792vardef dotlabel@#(expr s,z) text t =
1793    label@#(s,z) t ;
1794    interim linecap := rounded ;
1795    normaldraw z withpen pencircle scaled dotlabeldiam t ;
1796enddef ;
1797
1798def drawpoint expr c =
1799    if string c :
1800        string temp_c ;
1801        temp_c := "(" & c & ")" ;
1802        dotlabel.urt(temp_c, scantokens temp_c) ;
1803        drawdot scantokens temp_c
1804    else :
1805        dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ;
1806        drawdot c
1807    fi mfun_opt_pnt
1808enddef ;
1809
1810%D PathPoints.
1811
1812def drawpoints        expr c = path temp_c ; temp_c := c ; mfun_draw_points        enddef ;
1813def drawcontrolpoints expr c = path temp_c ; temp_c := c ; mfun_draw_controlpoints enddef ;
1814def drawcontrollines  expr c = path temp_c ; temp_c := c ; mfun_draw_controllines  enddef ;
1815def drawpointlabels   expr c = path temp_c ; temp_c := c ; mfun_draw_pointlabels   enddef ;
1816
1817def mfun_draw_points text t =
1818    for i within temp_c :
1819        normaldraw pathpoint mfun_opt_pnt t ;
1820    endfor ;
1821enddef;
1822
1823% def mfun_draw_controlpoints text t =
1824%     for i within temp_c :
1825%         normaldraw pathprecontrol  t mfun_opt_ctr t ;
1826%         normaldraw pathpostcontrol t mfun_opt_ctr t ;
1827%     endfor ;
1828% enddef;
1829
1830% def mfun_draw_controllines text t =
1831%     for i within temp_c :
1832%         normaldraw pathpoint -- pathprecontrol  t mfun_opt_lin t ;
1833%         normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ;
1834%     endfor ;
1835% enddef;
1836
1837def mfun_draw_controlpoints text t =
1838    for i within temp_c :
1839        if (pathstate == 0) or (pathstate == 2) :
1840            normaldraw pathprecontrol  t mfun_opt_ctr t ;
1841        fi ;
1842        if (pathstate == 0) or (pathstate == 1) :
1843            normaldraw pathpostcontrol t mfun_opt_ctr t ;
1844        fi ;
1845    endfor ;
1846enddef;
1847
1848def mfun_draw_controllines text t =
1849    for i within temp_c :
1850        if (pathstate == 0) or (pathstate == 2) :
1851            normaldraw pathpoint -- pathprecontrol  t mfun_opt_lin t ;
1852        fi ;
1853        if (pathstate == 0) or (pathstate == 1) :
1854            normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ;
1855        fi ;
1856    endfor ;
1857enddef;
1858
1859boolean swappointlabels ; swappointlabels := false ;
1860numeric pointlabelscale ; pointlabelscale := 0 ;
1861string  pointlabelfont  ; pointlabelfont  := "" ;
1862
1863def mfun_draw_pointlabels text asked_options =
1864    % todo: for i within temp_c : pathdirection
1865    for i=0 upto length(temp_c) if cycle temp_c : -1 fi :
1866        pair temp_u ; temp_u := unitvector(direction i of temp_c) rotated if swappointlabels : - fi 90 ;
1867        pair temp_p ; temp_p := (point i of temp_c) ;
1868        begingroup ;
1869        if pointlabelscale > 0 :
1870            save defaultscale ; numeric defaultscale ;
1871            defaultscale := pointlabelscale ;
1872        fi ;
1873        if pointlabelfont <> "" :
1874            save defaultfont ; string defaultfont ;
1875            defaultfont := pointlabelfont ;
1876        fi ;
1877        temp_u := 10 * drawoptionsfactor * defaultscale * temp_u ;
1878        normaldraw thelabel ( decimal i, temp_p shifted if cycle temp_c and (i=0) : - fi temp_u ) mfun_opt_lab asked_options ;
1879        endgroup ;
1880    endfor ;
1881enddef;
1882
1883%D Bounding box.
1884
1885def drawboundingbox expr p =
1886    normaldraw boundingbox p mfun_opt_bnd
1887enddef ;
1888
1889%D Origin.
1890
1891numeric originlength ; originlength := .5cm ;
1892
1893def draworigin text t =
1894    normaldraw (origin shifted (0, originlength) -- origin shifted (0,-originlength)) mfun_opt_ori t ;
1895    normaldraw (origin shifted ( originlength,0) -- origin shifted (-originlength,0)) mfun_opt_ori t ;
1896enddef;
1897
1898permanent dotlabel, swappointlabels, pointlabelscale, pointlabelfont ;
1899permanent drawboundingbox, drawpoints, drawcontrolpoints, drawcontrollines, drawpointlabels, draworigin ;
1900
1901%D Axis.
1902
1903numeric tickstep   ; tickstep   := 5mm ;
1904numeric ticklength ; ticklength := 2mm ;
1905
1906def drawxticks expr c = path temp_c ; temp_c := c ; mfun_draw_xticks enddef ;
1907def drawyticks expr c = path temp_c ; temp_c := c ; mfun_draw_yticks enddef ;
1908def drawticks  expr c = path temp_c ; temp_c := c ; mfun_draw_ticks  enddef ;
1909
1910% Adding eps prevents disappearance due to rounding errors.
1911
1912def mfun_draw_xticks text t =
1913    for i=0 step -tickstep until xpart llcorner temp_c - eps :
1914        if (i<=xpart lrcorner temp_c) :
1915        normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ;
1916        fi ;
1917    endfor ;
1918    for i=0 step  tickstep until xpart lrcorner temp_c + eps :
1919        if (i>=xpart llcorner temp_c) :
1920            normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ;
1921        fi ;
1922    endfor ;
1923    normaldraw (llcorner temp_c -- ulcorner temp_c) shifted (-xpart llcorner temp_c,0) mfun_opt_ori t ;
1924enddef ;
1925
1926def mfun_draw_yticks text t =
1927    for i=0 step -tickstep until ypart llcorner temp_c - eps :
1928        if (i<=ypart ulcorner temp_c) :
1929            normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1930        fi ;
1931    endfor ;
1932    for i=0 step  tickstep until ypart ulcorner temp_c + eps :
1933        if (i>=ypart llcorner temp_c) :
1934            normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ;
1935        fi ;
1936    endfor ;
1937    normaldraw (llcorner temp_c -- lrcorner temp_c) shifted (0,-ypart llcorner temp_c) mfun_opt_ori t ;
1938enddef ;
1939
1940def mfun_draw_ticks text t =
1941    drawxticks temp_c t ;
1942    drawyticks temp_c t ;
1943enddef ;
1944
1945%D All of it except axis.
1946
1947def drawwholepath expr p =
1948    draworigin          ;
1949    drawpath          p ;
1950    drawcontrollines  p ;
1951    drawcontrolpoints p ;
1952    drawpoints        p ;
1953    drawboundingbox   p ;
1954    drawpointlabels   p ;
1955enddef ;
1956
1957def drawpathonly expr p =
1958    drawpath          p ;
1959    drawcontrollines  p ;
1960    drawcontrolpoints p ;
1961    drawpoints        p ;
1962    drawpointlabels   p ;
1963enddef ;
1964
1965%D Tracing.
1966
1967def visualizeddraw expr c =
1968    if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_visualizeddraw fi
1969enddef ;
1970
1971def visualizedfill expr c =
1972    if picture c : normalfill c else : path temp_c ; temp_c := c ; do_visualizedfill fi
1973enddef ;
1974
1975def do_visualizeddraw text t =
1976    draworigin            ;
1977    drawpath          temp_c t ;
1978    drawcontrollines  temp_c ;
1979    drawcontrolpoints temp_c ;
1980    drawpoints        temp_c ;
1981    drawboundingbox   temp_c ;
1982    drawpointlabels   temp_c ;
1983enddef ;
1984
1985def do_visualizedfill text t =
1986    if cycle temp_c : normalfill temp_c t fi ;
1987    draworigin            ;
1988    drawcontrollines  temp_c ;
1989    drawcontrolpoints temp_c ;
1990    drawpoints        temp_c ;
1991    drawboundingbox   temp_c ;
1992    drawpointlabels   temp_c ;
1993enddef ;
1994
1995def detaileddraw expr c =
1996    if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_detaileddraw fi
1997enddef ;
1998
1999def do_detaileddraw text t =
2000    drawpath          temp_c t ;
2001    drawcontrollines  temp_c ;
2002    drawcontrolpoints temp_c ;
2003    drawpoints        temp_c ;
2004  % % for labels we need an third run (as the second will mark the numbers); i could preroll them
2005  % % but then the hash needs to handle that as well (as now we keep numbering)
2006  % drawpointlabels   temp_c ;
2007enddef ;
2008
2009def visualizepaths =
2010    let fill = visualizedfill ;
2011    let draw = visualizeddraw ;
2012enddef ;
2013
2014def detailpaths =
2015    let draw = detaileddraw ;
2016enddef ;
2017
2018def naturalizepaths =
2019    let fill = normalfill ;
2020    let draw = normaldraw ;
2021enddef ;
2022
2023extra_endfig := extra_endfig & " naturalizepaths ; " ;
2024
2025permanent
2026    visualizeddraw, detaileddraw, visualizedfill,
2027    visualizepaths, detailpaths, naturalizepaths ;
2028
2029%D Nice tracer:
2030
2031def drawboundary primary p =
2032    draw p dashed evenly withcolor white ;
2033    draw p dashed oddly  withcolor black ;
2034    draw (- llcorner p) withpen pencircle scaled 3   withcolor white ;
2035    draw (- llcorner p) withpen pencircle scaled 1.5 withcolor black ;
2036enddef ;
2037
2038permanent drawboundary ;
2039
2040%D Also handy:
2041
2042extra_beginfig := extra_beginfig & " truecorners :=  0 ; "   ; % restores
2043extra_beginfig := extra_beginfig & " miterlimit  := 10 ; "   ; % restores
2044extra_beginfig := extra_beginfig & " linejoin := rounded ; " ; % restores
2045extra_beginfig := extra_beginfig & " linecap  := rounded ; " ; % restores
2046
2047%D Normally, arrowheads don't scale well. So we provide a hack.
2048
2049% boolean autoarrows ; autoarrows := false ;  % todo: newinternal boolean autoarrows ;
2050numeric ahfactor   ; ahfactor   := 2.5 ;    % todo: newinternal         ahfactor ;
2051
2052newinternal boolean autoarrows ;
2053
2054permanent ahfactor, ahlength, autoarrows ;
2055
2056def set_ahlength (text t) = % called to often
2057  % ahlength := (ahfactor*pen_size(base_draw_options t)) ; % base_draw_options added
2058  % problem: base_draw_options can contain color so a no-go, we could apply the transform
2059  % but i need to figure out the best way (fakepicture and take components).
2060    ahlength := (ahfactor*pen_size(t)) ;
2061enddef ;
2062
2063vardef pen_size (text t) =
2064    save p ; picture p ; p := nullpicture ;
2065    addto p doublepath (top origin -- bot origin) t ;
2066    (ypart urcorner p - ypart lrcorner p)
2067enddef ;
2068
2069%D The next two macros are adapted versions of plain
2070%D \METAPOST\ definitions.
2071
2072vardef arrowpath expr p = % patch by Peter Rolf: supports squared pen and shifting (hh: maybe just use center of head as first)
2073    (p cutafter makepath(pencircle
2074        scaled (if ahvariant > 0 : (1-ahdimple)* fi 2ahlength*cosd(ahangle/2))
2075        shifted point length p of p
2076    ))
2077enddef;
2078
2079permanent arrowpath ;
2080
2081% New experimental extension: also handling pictures:
2082%
2083% drawarrow fullsquare scaled 2cm withcolor green ;
2084% drawarrow fullcircle scaled 3cm withcolor green ;
2085% drawarrow image (
2086%     draw fullsquare scaled 4cm withcolor red ;
2087%     draw fullcircle scaled 5cm withcolor blue ;
2088% ) ;
2089% currentpicture := currentpicture shifted (-bbwidth(currentpicture)-1cm,0) ;
2090% drawdblarrow fullsquare scaled 2cm withcolor green ;
2091% drawdblarrow fullcircle scaled 3cm withcolor green ;
2092% drawdblarrow image (
2093%     draw fullsquare scaled 4cm withcolor red ;
2094%     draw fullcircle scaled 5cm withcolor blue ;
2095% ) ;
2096
2097vardef stroked_paths(expr p) =
2098    save n ; numeric n ; n := 0 ;
2099    for i within p :
2100        if stroked i :
2101            n := n + 1 ;
2102        fi
2103    endfor ;
2104    n
2105enddef ;
2106
2107def mfun_decoration_i expr i =
2108    withpen penpart i
2109    withcolor colorpart i
2110    withprescript prescriptpart i
2111    withpostscript postscriptpart i
2112enddef ;
2113
2114%D We could collapse all in one helper but in context we nowaways don't want the added
2115%D obscurity. Tokens come cheap.
2116
2117numeric mfun_arrow_snippets ;
2118numeric mfun_arrow_count ;
2119
2120def drawarrow expr p =
2121    begingroup ;
2122    save mfun_arrow_path ;
2123    path mfun_arrow_path ;
2124    if path p :
2125        mfun_arrow_path := p ;
2126        expandafter mfun_draw_arrow_path
2127    elseif picture p :
2128        save mfun_arrow_picture ;
2129        picture mfun_arrow_picture ;
2130        mfun_arrow_picture := p ;
2131        expandafter mfun_draw_arrow_picture
2132    else :
2133        expandafter mfun_draw_arrow_nothing
2134    fi
2135enddef ;
2136
2137def drawdblarrow expr p =
2138    begingroup ;
2139    save mfun_arrow_path ;
2140    path mfun_arrow_path ;
2141    if path p :
2142        mfun_arrow_path := p ;
2143        expandafter mfun_draw_arrow_path_double
2144    elseif picture p :
2145        save mfun_arrow_picture ;
2146        picture mfun_arrow_picture ;
2147        mfun_arrow_picture := p ;
2148        expandafter mfun_draw_arrow_picture_double
2149    else :
2150        expandafter mfun_draw_arrow_nothing
2151    fi
2152enddef ;
2153
2154def mfun_draw_arrow_nothing text t =
2155enddef ;
2156
2157%D The path is shortened so that the arrow head extends it to the original length. In
2158%D case of a double arrow the path gets shortened twice.
2159
2160def mfun_draw_arrow_path text t =
2161    if autoarrows :
2162        set_ahlength(t) ;
2163    fi
2164    draw arrowpath mfun_arrow_path t ;
2165    fillup arrowhead mfun_arrow_path t ;
2166    endgroup ;
2167enddef ;
2168
2169def mfun_draw_arrow_path_double text t =
2170    if autoarrows :
2171        set_ahlength(t) ;
2172    fi
2173    draw arrowpath (reverse arrowpath mfun_arrow_path) t ;
2174    fillup arrowhead mfun_arrow_path t ;
2175    fillup arrowhead reverse mfun_arrow_path t ;
2176    endgroup ;
2177enddef ;
2178
2179%D The picture variant is not treating each path but only the first and last path. This
2180%D can be somewhat counterintuitive but is needed for Alan's macros. So here the last
2181%D and in case of a double path first paths in a icture get the shortening.
2182
2183def mfun_with_arrow_picture (text t) =
2184    mfun_arrow_count := 0 ;
2185    mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ;
2186    for i within mfun_arrow_picture :
2187        if istextext(i) :
2188            draw i
2189        else :
2190            mfun_arrow_count := mfun_arrow_count + 1 ;
2191            mfun_arrow_path := pathpart i ;
2192            t
2193        fi ;
2194    endfor ;
2195enddef ;
2196
2197def mfun_draw_arrow_picture text t =
2198    if autoarrows :
2199        set_ahlength(t) ;
2200    fi
2201    mfun_with_arrow_picture (
2202        if mfun_arrow_count = mfun_arrow_snippets :
2203            draw arrowpath mfun_arrow_path mfun_decoration_i i t ;
2204            fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2205        else :
2206            draw mfun_arrow_path mfun_decoration_i i t ;
2207        fi ;
2208    )
2209    endgroup ;
2210enddef ;
2211
2212def mfun_draw_arrow_picture_double text t =
2213    if autoarrows :
2214        set_ahlength(t) ;
2215    fi
2216    mfun_with_arrow_picture (
2217        draw
2218        if mfun_arrow_count = 1 :
2219            arrowpath reverse
2220        elseif mfun_arrow_count = mfun_arrow_snippets :
2221            arrowpath
2222        fi
2223        mfun_arrow_path mfun_decoration_i i t ;
2224        if mfun_arrow_count = 1 :
2225            fillup arrowhead reverse mfun_arrow_path mfun_decoration_i i t ;
2226        fi
2227        if mfun_arrow_count = mfun_arrow_snippets :
2228            fillup arrowhead mfun_arrow_path mfun_decoration_i i t ;
2229        fi
2230    )
2231    endgroup ;
2232enddef ;
2233
2234%D Some more arrow magic, by Alan:
2235
2236let drawdoublearrow = drawdblarrow ;
2237
2238def drawdoublearrows expr p =
2239    begingroup ;
2240    save mfun_arrow_path ;
2241    path mfun_arrow_path ;
2242    save mfun_arrow_path_parallel ;
2243    path mfun_arrow_path_parallel ;
2244    if path p :
2245        mfun_arrow_path := p ;
2246        expandafter mfun_draw_arrow_paths
2247    elseif picture p :
2248        save mfun_arrow_picture ;
2249        picture mfun_arrow_picture ;
2250        mfun_arrow_picture := p ;
2251        expandafter mfun_draw_arrow_pictures
2252    else :
2253        expandafter mfun_draw_arrow_nothing
2254    fi
2255enddef ;
2256
2257def mfun_draw_arrow_paths text t =
2258    if autoarrows :
2259        set_ahlength(t) ;
2260    fi
2261    save d ; d := ahscale*ahlength*sind(ahangle/2) ;
2262    mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2263    draw   arrowpath mfun_arrow_path_parallel t ;
2264    fillup arrowhead mfun_arrow_path_parallel t ;
2265    mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2266    draw   arrowpath mfun_arrow_path_parallel t ;
2267    fillup arrowhead mfun_arrow_path_parallel t ;
2268    endgroup ;
2269enddef ;
2270
2271def mfun_draw_arrow_pictures text t =
2272    if autoarrows :
2273        set_ahlength(t) ;
2274    fi
2275    save d ; d := ahscale*ahlength*sind(ahangle/2) ;
2276    mfun_with_arrow_picture(
2277        if mfun_arrow_count = 1 :
2278            draw (mfun_arrow_path  paralleled d)          mfun_decoration_i i t ;
2279            mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ;
2280            draw   arrowpath mfun_arrow_path_parallel     mfun_decoration_i i t ;
2281            fillup arrowhead mfun_arrow_path_parallel     mfun_decoration_i i t ;
2282        elseif mfun_arrow_count = mfun_arrow_snippets :
2283            draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2284            mfun_arrow_path_parallel := mfun_arrow_path paralleled d ;
2285            draw   arrowpath mfun_arrow_path_parallel     mfun_decoration_i i t ;
2286            fillup arrowhead mfun_arrow_path_parallel     mfun_decoration_i i t ;
2287        else :
2288            draw (         mfun_arrow_path  paralleled d) mfun_decoration_i i t ;
2289            draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ;
2290        fi
2291    )
2292    endgroup ;
2293enddef ;
2294
2295%D Handy too ......
2296
2297vardef pointarrow (expr pat, loc, len, off) =
2298    save l, r, s, t ; path l, r ; numeric s ; pair t ;
2299    t := if pair loc : loc else : point loc along pat fi ;
2300    s := len/2 - off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2301    r := pat cutbefore t ;
2302    r := (r cutafter point (arctime s of r) of r) ;
2303    s := len/2 + off ; if s<=0 : s := 0 elseif s>len : s := len fi ;
2304    l := reverse (pat cutafter t) ;
2305    l := (reverse (l cutafter point (arctime s of l) of l)) ;
2306    (l..r)
2307enddef ;
2308
2309def rightarrow  (expr pat,tim,len) = pointarrow(pat,tim,len,-len) enddef ;
2310def leftarrow   (expr pat,tim,len) = pointarrow(pat,tim,len,+len) enddef ;
2311def centerarrow (expr pat,tim,len) = pointarrow(pat,tim,len,   0) enddef ;
2312
2313permanent drawarrow, drawdblarrow, drawdoublearrows, drawdoublearrow, pointarrow, rightarrow, leftarrow, centerarrow ;
2314
2315%D The \type {along} and \type {on} operators can be used as follows:
2316%D
2317%D \starttyping
2318%D drawdot point .5  along somepath ;
2319%D drawdot point 3cm on    somepath ;
2320%D \stoptyping
2321%D
2322%D The number denotes a percentage (fraction).
2323
2324primarydef pct along pat = % also negative
2325    (arctime (pct * (arclength pat)) of pat) of pat
2326enddef ;
2327
2328primarydef len on pat = % no outer ( ) .. somehow fails
2329    (arctime if len>=0 : len else : (arclength(pat)+len) fi of pat) of pat
2330enddef ;
2331
2332% this cuts of a piece from both ends
2333
2334tertiarydef pat cutends len =
2335    begingroup
2336    save tap ; path tap ;
2337    tap := pat cutbefore (point (xpart paired(len)) on pat) ;
2338    (tap cutafter (point -(ypart paired(len)) on tap))
2339    endgroup
2340enddef ;
2341
2342permanent along, on, cutends ;
2343
2344%D To be documented.
2345
2346path freesquare ; freesquare := (
2347    (-1,0) -- (-1,-1) -- (0,-1) -- (+1,-1) --
2348    (+1,0) -- (+1,+1) -- (0,+1) -- (-1,+1) -- cycle
2349) scaled .5 ;
2350
2351numeric freelabeloffset  ; freelabeloffset  := 3pt ;
2352numeric freedotlabelsize ; freedotlabelsize := 3pt ;
2353
2354vardef thefreelabel (expr asked_text, asked_location, asked_origin) =
2355    save s, p, q, l ; picture s ; path p, q ; pair l ;
2356    interim labeloffset := freelabeloffset ;
2357    s := if string asked_text : thelabel(asked_text,asked_location) else : asked_text shifted -center asked_text shifted asked_location fi ;
2358    setbounds s to boundingbox s enlarged freelabeloffset ;
2359    p := fullcircle scaled (2*length(asked_location-asked_origin)) shifted asked_origin ;
2360    q := freesquare xyscaled (urcorner s - llcorner s) ;
2361    l := point xpart (p intersectiontimes (asked_origin--asked_location shifted (asked_location-asked_origin))) of q ;
2362    setbounds s to boundingbox s enlarged -freelabeloffset ; % new
2363  % draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ;
2364    (s shifted -l)
2365enddef ;
2366
2367vardef freelabel (expr asked_text, asked_location, asked_origin) =
2368    draw thefreelabel(asked_text,asked_location,asked_origin) ;
2369enddef ;
2370
2371vardef freedotlabel (expr asked_text, asked_location, asked_origin) =
2372    interim linecap := rounded ;
2373    draw asked_location withpen pencircle scaled freedotlabelsize ;
2374    draw thefreelabel(asked_text,asked_location,asked_origin) ;
2375enddef ;
2376
2377immutable freesquare ;
2378permanent freelabeloffset, freedotlabelsize, thefreelabel, freelabel, freedotlabel ;
2379
2380%D \starttyping
2381%D drawarrow anglebetween(line_a,line_b,somelabel) ;
2382%D \stoptyping
2383
2384newinternal angleoffset ; angleoffset :=  0pt ;
2385newinternal anglelength ; anglelength := 20pt ;
2386newinternal anglemethod ; anglemethod :=    1 ;
2387
2388vardef anglebetween (expr a, b, s) = % path path string
2389    save pointa, pointb, common, middle, offset ;
2390    pair pointa, pointb, common, middle, offset ;
2391    save curve ; path curve ;
2392    save where ; numeric where ;
2393    if round point 0 of a = round point 0 of b :
2394        common := point 0 of a ;
2395    else :
2396        common := a intersectionpoint b ;
2397    fi ;
2398    pointa := point anglelength on a ;
2399    pointb := point anglelength on b ;
2400    where  := turningnumber (common--pointa--pointb--cycle) ;
2401    middle := (reverse(common--pointa) rotatedaround (pointa,-where*90))
2402        intersection_point
2403        (reverse(common--pointb) rotatedaround (pointb, where*90)) ;
2404    if not intersection_found :
2405        middle := point .5 along
2406        ((reverse(common--pointa) rotatedaround (pointa,-where*90)) --
2407        (       (common--pointb) rotatedaround (pointb, where*90))) ;
2408    fi ;
2409    if     anglemethod = 0 :
2410        curve  := pointa{unitvector(middle-pointa)}.. pointb;
2411        middle := point .5 along curve ;
2412        curve  := common ;
2413    elseif anglemethod = 1 :
2414        curve  := pointa{unitvector(middle-pointa)}.. pointb;
2415        middle := point .5 along curve ;
2416    elseif anglemethod = 2 :
2417        middle := common rotatedaround(.5[pointa,pointb],180) ;
2418        curve  := pointa--middle--pointb ;
2419    elseif anglemethod = 3 :
2420        curve  := pointa--middle--pointb ;
2421    elseif anglemethod = 4 :
2422        curve  := pointa..controls middle..pointb ;
2423        middle := point .5 along curve ;
2424    fi ;
2425    draw thefreelabel(s, middle, common) ; % withcolor black ;
2426    curve
2427enddef ;
2428
2429permanent anglebetween, angleoffset, anglelength, anglemethod ;
2430
2431% Stack
2432
2433picture mfun_current_picture_stack[] ;
2434numeric mfun_current_picture_depth   ;
2435
2436mfun_current_picture_depth := 0 ;
2437
2438def pushcurrentpicture =
2439    mfun_current_picture_depth := mfun_current_picture_depth + 1 ;
2440    mfun_current_picture_stack[mfun_current_picture_depth] := currentpicture ;
2441    currentpicture := nullpicture ;
2442enddef ;
2443
2444def popcurrentpicture text t = % optional text
2445    if mfun_current_picture_depth > 0 :
2446        addto mfun_current_picture_stack[mfun_current_picture_depth] also currentpicture t ;
2447        currentpicture := mfun_current_picture_stack[mfun_current_picture_depth] ;
2448        mfun_current_picture_stack[mfun_current_picture_depth] := nullpicture ;
2449        mfun_current_picture_depth := mfun_current_picture_depth - 1 ;
2450    fi ;
2451enddef ;
2452
2453permanent pushcurrentpicture, popcurrentpicture ;
2454
2455% penpoint (i,2) of somepath -> inner / outer point
2456
2457vardef penpoint expr pnt of p =
2458    save n, d ; numeric n, d ;
2459    (n,d) = if pair pnt : pnt else : (pnt,1) fi ;
2460    (point n of p shifted ((penoffset direction n of p of currentpen) scaled d))
2461enddef ;
2462
2463permanent penpoint ;
2464
2465%D colorcircle(size, red, green, blue) ;
2466
2467vardef colorcircle (expr size, red, green, blue) = % might move
2468    save r, g, b, c, m, y, w ; save radius ;
2469    path r, g, b, c, m, y, w ; numeric radius ;
2470
2471    radius := 5cm ; pickup pencircle scaled (radius/25) ;
2472
2473    transform t ; t := identity rotatedaround(origin,120) ;
2474
2475    r := fullcircle rotated 90 scaled radius shifted (0,radius/4) rotatedaround(origin,135) ;
2476
2477    b := r transformed t ; g := b transformed t ;
2478
2479    c := buildcycle(subpath(1,7) of g,subpath(1,7) of b) ;
2480    y := c transformed t ; m := y transformed t ;
2481
2482    w := buildcycle(subpath(3,5) of r, subpath(3,5) of g,subpath(3,5) of b) ;
2483
2484    pushcurrentpicture ;
2485
2486    fill r withcolor         red   ;
2487    fill g withcolor         green ;
2488    fill b withcolor         blue  ;
2489    fill c withcolor white - red   ;
2490    fill m withcolor white - green ;
2491    fill y withcolor white - blue  ;
2492    fill w withcolor white         ;
2493
2494    for i = r,g,b,c,m,y : draw i withcolor .5white ; endfor ;
2495
2496    currentpicture := currentpicture xsized size ;
2497
2498    popcurrentpicture ;
2499enddef ;
2500
2501% nice: currentpicture := inverted currentpicture ;
2502
2503primarydef p uncolored c = % not complete ... needs text and scripts and ...
2504    if color p :
2505        c - p
2506    else :
2507        image (
2508            for i within p :
2509                addto currentpicture
2510                    if stroked i or filled i :
2511                        if filled i :
2512                            contour
2513                        else :
2514                            doublepath
2515                        fi
2516                        pathpart i
2517                        dashed dashpart i withpen penpart i
2518                    else :
2519                        also i
2520                    fi
2521                    withcolor c-(redpart i, greenpart i, bluepart i) ;
2522            endfor ;
2523        )
2524  fi
2525enddef ;
2526
2527vardef inverted primary p =
2528    p uncolored white
2529enddef ;
2530
2531primarydef p softened c =
2532    begingroup
2533    save cc ; color cc ; cc := tripled(c) ;
2534    if color p :
2535        (redpart cc * redpart p,greenpart cc * greenpart p, bluepart cc * bluepart p)
2536    else :
2537        image (
2538            for i within p :
2539                addto currentpicture
2540                    if stroked i or filled i :
2541                        if filled i :
2542                            contour
2543                        else :
2544                            doublepath
2545                        fi
2546                        pathpart i
2547                        dashed dashpart i withpen penpart i
2548                    else :
2549                        also i
2550                    fi
2551                    withcolor (redpart cc * redpart i, greenpart cc * greenpart i, bluepart cc * bluepart i) ;
2552            endfor ;
2553        )
2554    fi
2555    endgroup
2556enddef ;
2557
2558vardef grayed primary p =
2559    if rgbcolor p :
2560        tripled(.30redpart p+.59greenpart p+.11bluepart p)
2561    elseif cmykcolor p :
2562        tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i)
2563    elseif greycolor p :
2564        p
2565    elseif string p :
2566        grayed resolvedcolor(p)
2567    elseif picture p :
2568        image (
2569            for i within p :
2570                addto currentpicture
2571                    if stroked i or filled i :
2572                        if filled i :
2573                            contour
2574                        else :
2575                            doublepath
2576                        fi
2577                        pathpart i
2578                        dashed dashpart i
2579                        withpen penpart i
2580                    else :
2581                        also i
2582                    fi
2583                if unknown colorpart i :
2584                    % nothing
2585                elseif rgbcolor colorpart i :
2586                    withcolor tripled(.30redpart i+.59greenpart i+.11bluepart i) ;
2587                elseif cmykcolor colorpart i :
2588                    withcolor tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i) ;
2589                else :
2590                    withcolor colorpart i ;
2591                fi
2592            endfor ;
2593        )
2594    else :
2595        p
2596    fi
2597enddef ;
2598
2599let greyed = grayed ;
2600
2601vardef hsvtorgb(expr h,s,v) =
2602    save H, S, V, x ;
2603    H = h mod 360 ;
2604    S = if s < 0 : 0 elseif s > 1 : 1 else: s fi ;
2605    V = if v < 0 : 0 elseif v > 1 : 1 else: v fi ;
2606    x = 1 - abs(H mod 120 - 60)/60 ;
2607    V * ( (1-S) * (1,1,1) + S *
2608        if     H <  60 : (1,x,0)
2609        elseif H < 120 : (x,1,0)
2610        elseif H < 180 : (0,1,x)
2611        elseif H < 240 : (0,x,1)
2612        elseif H < 300 : (x,0,1)
2613        else           : (1,0,x)
2614    fi )
2615enddef ;
2616
2617permanent colorcircle, uncolored, inverted, grayed, greyed, hsvtorgb ;
2618
2619% yes or no: "text" infont "cmr12" at 24pt ;
2620
2621% let normalinfont = infont ;
2622%
2623% numeric lastfontsize ; lastfontsize = fontsize defaultfont ;
2624%
2625% def infont primary name =  % no vardef, no expr
2626%   hide(lastfontsize := fontsize name) % no ;
2627%   normalinfont name
2628% enddef ;
2629%
2630% def scaledat expr size =
2631%   scaled (size/lastfontsize)
2632% enddef ;
2633%
2634% let at = scaledat ;
2635
2636% like decimal
2637
2638def condition primary b = if b : "true" else : "false" fi enddef ;
2639
2640permanent condition ;
2641
2642% undocumented
2643
2644primarydef p stretched s =
2645    begingroup
2646    save pp ; path pp ; pp := p xyscaled s ;
2647    (pp shifted ((point 0 of p) - (point 0 of pp)))
2648    endgroup
2649enddef ;
2650
2651primarydef p enlonged len =
2652    begingroup
2653    if len == 0 :
2654        p
2655    elseif pair p :
2656        save q ; path q ; q := origin -- p ;
2657        save al ; al := arclength(q) ;
2658        if al > 0 :
2659            point 1 of (q stretched ((al+len)/al))
2660        else :
2661            p
2662        fi
2663    else :
2664        save al ; al := arclength(p) ;
2665        if al > 0 :
2666            p stretched ((al+len)/al)
2667        else :
2668            p
2669        fi
2670    fi
2671    endgroup
2672enddef ;
2673
2674% path p ; p := (0,0) -- (10cm,5cm) ;
2675% drawarrow p withcolor red ;
2676% drawarrow p shortened 1cm withcolor green ;
2677
2678% primarydef p shortened d =
2679%     reverse ( ( reverse (p enlonged -d) ) enlonged -d )
2680% enddef ;
2681
2682primarydef p shortened d =
2683    reverse ( ( reverse (p enlonged -xpart paired(d)) ) enlonged -ypart paired(d) )
2684enddef ;
2685
2686% yes or no, untested -)
2687
2688def xshifted expr dx = shifted(dx,0) enddef ;
2689def yshifted expr dy = shifted(0,dy) enddef ;
2690
2691
2692permanent stretched, enlonged, shortened, xshifted, yshifted ;
2693
2694% also handy
2695
2696% right: str = readfrom ("abc" & ".def" ) ;
2697% wrong: str = readfrom  "abc" & ".def"   ;
2698
2699% Every 62th read fails so we need to try again!
2700
2701% def readfile (expr name) =
2702%   if (readfrom (name) <> EOF) :
2703%     scantokens("input " & name & ";") ;
2704%   elseif (readfrom (name) <> EOF) :
2705%     scantokens("input " & name & ";") ;
2706%   fi ;
2707%   closefrom (name) ;
2708% enddef ;
2709%
2710% this sometimes fails on the elseif, so :
2711%
2712
2713def readfile (expr name) =
2714    begingroup ; save ok ; boolean ok ;
2715    if (readfrom (name) <> EOF) :
2716        ok := false ;
2717    elseif (readfrom (name) <> EOF) :
2718        ok := false ;
2719    else :
2720        ok := true ;
2721    fi ;
2722    if not ok :
2723        scantokens("input " & name & " ") ;
2724    fi ;
2725    closefrom (name) ;
2726    endgroup ;
2727enddef ;
2728
2729permanent readfile ; % todo: lmtx
2730
2731% permits redefinition of end in macro
2732
2733inner end ;
2734
2735% this will be redone (when needed) using scripts and backend handling
2736
2737let mfun_remap_colors_normalwithcolor = normalwithcolor ;
2738
2739def remapcolors =
2740    def normalwithcolor primary c =
2741        mfun_remap_colors_normalwithcolor remappedcolor(c)
2742    enddef ;
2743enddef ;
2744
2745def normalcolors =
2746    let normalwithcolor = mfun_remap_colors_normalwithcolor ;
2747enddef ;
2748
2749def resetcolormap =
2750    color color_map[][][] ;
2751    normalcolors ;
2752enddef ;
2753
2754resetcolormap ;
2755
2756def r_color primary c = redpart   c enddef ; % still neeeded?
2757def g_color primary c = greenpart c enddef ; % still neeeded?
2758def b_color primary c = bluepart  c enddef ; % still neeeded?
2759
2760def remapcolor(expr old, new) =
2761    color_map[redpart old][greenpart old][bluepart old] := new ;
2762enddef ;
2763
2764def remappedcolor(expr c) =
2765    if known color_map[redpart c][greenpart c][bluepart c] :
2766        color_map[redpart c][greenpart c][bluepart c]
2767    else :
2768        c
2769    fi
2770enddef ;
2771
2772% Thanks to Jens-Uwe Morawski for pointing out that we need
2773% to treat bounded and clipped components as local pictures.
2774
2775def recolor suffix p = p := mfun_repathed (0,p) enddef ;
2776def refill  suffix p = p := mfun_repathed (1,p) enddef ;
2777def redraw  suffix p = p := mfun_repathed (2,p) enddef ;
2778def retext  suffix p = p := mfun_repathed (3,p) enddef ;
2779def untext  suffix p = p := mfun_repathed (4,p) enddef ;
2780
2781% primarydef p recolored t = mfun_repathed(0,p) t enddef ;
2782% primarydef p refilled  t = mfun_repathed(1,p) t enddef ;
2783% primarydef p redrawn   t = mfun_repathed(2,p) t enddef ;
2784% primarydef p retexted  t = mfun_repathed(3,p) t enddef ;
2785% primarydef p untexted  t = mfun_repathed(4,p) t enddef ;
2786
2787color refillbackground ; refillbackground := (1,1,1) ;
2788
2789def restroke  suffix p = p := mfun_repathed (21,p) enddef ; % keep attributes
2790def reprocess suffix p = p := mfun_repathed (22,p) enddef ; % no attributes
2791
2792permanent recolor, refill, redraw, retext, untext, restroke, reprocess, refillbackground ;
2793
2794% also 11 and 12
2795
2796vardef mfun_repathed (expr mode, p) text t =
2797    begingroup ;
2798    if mode = 0 :
2799        save normalwithcolor ;
2800        remapcolors ;
2801    fi ;
2802    save temp_p, temp_q, temp_r, temp_f, temp_b ;
2803    picture temp_p, temp_q, temp_r ; color temp_f ; path temp_b ;
2804    temp_b := boundingbox p ;
2805    temp_p := nullpicture ;
2806    for i within p :
2807        temp_f := (redpart i, greenpart i, bluepart i) ;
2808        if bounded i :
2809            temp_q := mfun_repathed(mode,i) t ;
2810            setbounds temp_q to pathpart i ;
2811            addto temp_p also temp_q ;
2812        elseif clipped i :
2813            temp_q := mfun_repathed(mode,i) t ;
2814            clip temp_q to pathpart i ;
2815            addto temp_p also temp_q ;
2816        elseif stroked i :
2817            if mode=21 :
2818                temp_r := i ; % indirectness is needed
2819                addto temp_p also image(scantokens(t & " pathpart temp_r")
2820                    dashed dashpart i withpen penpart i
2821                    withcolor temp_f ; ) ;
2822            elseif mode=22 :
2823                temp_r := i ; % indirectness is needed
2824                addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2825            else :
2826                addto temp_p doublepath pathpart i
2827                    dashed dashpart i withpen penpart i
2828                    withcolor temp_f % (redpart i, greenpart i, bluepart i)
2829                    if mode = 2 :
2830                        t
2831                    fi ;
2832            fi ;
2833        elseif filled  i :
2834            if mode=11 :
2835                temp_r := i ; % indirectness is needed
2836                addto temp_p also image(scantokens(t & " pathpart temp_r")
2837                    withcolor temp_f ; ) ;
2838            elseif mode=12 :
2839                temp_r := i ; % indirectness is needed
2840                addto temp_p also image(scantokens(t & " pathpart temp_r")) ;
2841            else :
2842                addto temp_p contour pathpart i
2843                    withcolor temp_f
2844                    if (mode=1) and (temp_f<>refillbackground) :
2845                        t
2846                    fi ;
2847            fi ;
2848        else :
2849            addto temp_p also i ;
2850        fi ;
2851    endfor ;
2852    setbounds temp_p to temp_b ;
2853    temp_p
2854    endgroup
2855enddef ;
2856
2857%D After a question of Denis on how to erase a z variable, Jacko suggested to assign
2858%D whatever to x and y. So a clearz variable can be defined as:
2859%
2860% vardef clearz@# =
2861%   x@# := whatever ;
2862%   y@# := whatever ;
2863% enddef ;
2864%
2865% but Jacko suggested a redefinition of clearxy:
2866%
2867% def clearxy text s =
2868%  clearxy_index_:=0;
2869%  for $:=s:
2870%    clearxy_index_:=clearxy_index_+1; endfor;
2871%  if clearxy_index_=0:
2872%    save x,y;
2873%  else:
2874%    forsuffixes $:=s: x$:=whatever; y$:=whatever; endfor;
2875%  fi
2876% enddef;
2877%
2878% which i decided to simplify to:
2879
2880def clearxy text s =
2881    if false for $ := s : or true endfor :
2882        forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ;
2883    else :
2884        save x, y ;
2885    fi
2886enddef ;
2887
2888permanent clearxy ;
2889
2890% so now we can say: clearxy ; as well as clearxy 1, 2, 3 ;
2891
2892% show x0 ; z0 = (10,10) ;
2893% show x0 ; x0 := whatever ; y0 := whatever ;
2894% show x0 ; z0 = (20,20) ;
2895% show x0 ; clearxy 0 ;
2896% show x0 ; z0 = (30,30) ;
2897
2898primarydef p smoothed d =
2899   (p llmoved (-xpart paired(d),0) -- p lrmoved (-xpart paired(d),0) {right} ..
2900    p lrmoved (0,-ypart paired(d)) -- p urmoved (0,-ypart paired(d)) {up}    ..
2901    p urmoved (-xpart paired(d),0) -- p ulmoved (-xpart paired(d),0) {left}  ..
2902    p ulmoved (0,-ypart paired(d)) -- p llmoved (0,-ypart paired(d)) {down}  .. cycle)
2903enddef ;
2904
2905primarydef p cornered c =
2906    ((point 0 of p) shifted (c*(unitvector(point 1 of p - point 0 of p))) --
2907    for i=1 upto length(p) :
2908        (point i-1 of p) shifted (c*(unitvector(point i   of p - point i-1 of p))) --
2909        (point i   of p) shifted (c*(unitvector(point i-1 of p - point i   of p))) ..
2910        controls point i of p ..
2911    endfor cycle)
2912enddef ;
2913
2914% Mikael Sundqvist came up with this one. We made it robust for points being too close
2915% for smoothing.
2916
2917primarydef p smoothcornered c =
2918    ( begingroup ;
2919        save cc ;
2920        if not cycle p: (point 0 of p) -- fi
2921        for i=1 upto length(p) :
2922            hide (cc := min(c,arclength (subpath(i-1,i) of p)/2);)
2923            (point i-1 of p) shifted (cc*(unitvector(point i   of p - point i-1 of p))) --
2924            (point i   of p) shifted (cc*(unitvector(point i-1 of p - point i   of p))) ..
2925            controls point i of p ..
2926        endfor
2927        if cycle p : cycle else : point 1 along p fi
2928    endgroup )
2929enddef ;
2930
2931permanent smoothed, cornered, smoothcornered ;
2932
2933% cmyk color support
2934
2935% vardef cmyk(expr c,m,y,k) = % elsewhere
2936%     (1-c-k,1-m-k,1-y-k)
2937% enddef ;
2938
2939% handy
2940
2941% vardef bbwidth (expr p) = % vardef width_of primary p =
2942%     if known p :
2943%         if path p or picture p :
2944%             xpart (lrcorner p - llcorner p)
2945%         else :
2946%             0
2947%         fi
2948%     else :
2949%         0
2950%     fi
2951% enddef ;
2952% vardef bbwidth primary p =
2953%     if unknown p :
2954%         0
2955%     elseif path p or picture p :
2956%         xpart (lrcorner p - llcorner p)
2957%     else :
2958%         0
2959%     fi
2960% enddef ;
2961% vardef bbwidth primary p =
2962%     if unknown p :
2963%         0
2964%     elseif path p or picture p :
2965%         save b ; path b; b := corners p ;
2966%         xpart point 0 of b - xpart point 1 of b
2967%     else :
2968%         0
2969%     fi
2970% enddef ;
2971vardef bbwidth primary p =
2972    if unknown p :
2973        0
2974    elseif path p or picture p :
2975        save r ; pair r ; r := xrange p ;
2976        ypart r - xpart r
2977    else :
2978        0
2979    fi
2980enddef ;
2981
2982% vardef bbheight (expr p) = % vardef heigth_of primary p =
2983%     if known p :
2984%         if path p or picture p :
2985%             ypart (urcorner p - lrcorner p)
2986%         else :
2987%             0
2988%         fi
2989%     else :
2990%         0
2991%     fi
2992% enddef ;
2993% vardef bbheight primary p =
2994%     if unknown p :
2995%         0
2996%     elseif path p or picture p :
2997%         ypart (urcorner p - lrcorner p)
2998%     else :
2999%         0
3000%     fi
3001% enddef ;
3002% vardef bbheight primary p =
3003%     if unknown p :
3004%         0
3005%     elseif path p or picture p :
3006%         save b ; path b; b := corners p ;
3007%         ypart point 2 of b - ypart point 1 of b
3008%     else :
3009%         0
3010%     fi
3011% enddef ;
3012vardef bbheight primary p =
3013    if unknown p :
3014        0
3015    elseif path p or picture p :
3016        save r ; pair r ; r := yrange p ;
3017        ypart r - xpart r
3018    else :
3019        0
3020    fi
3021enddef ;
3022
3023permanent bbwidth, bbheight ;
3024
3025color nocolor ; numeric noline ; % both unknown signals
3026
3027def dowithpath (expr p, lw, lc, bc) =
3028    if known p :
3029        if known bc :
3030            fill p withcolor bc ;
3031        fi ;
3032        if known lw and known lc :
3033            draw p withpen pencircle scaled lw withcolor lc ;
3034        elseif known lw :
3035            draw p withpen pencircle scaled lw ;
3036        elseif known lc :
3037            draw p withcolor lc ;
3038        fi ;
3039    fi ;
3040enddef ;
3041
3042% result from metafont discussion list (denisr/boguslawj)
3043
3044def [[[ = [ [ [ enddef ; % already: def [[ = [ [ enddef ;
3045def ]]] = ] ] ] enddef ; % already: def ]] = ] ] enddef ;
3046
3047let == = = ; % magic
3048
3049permanent [[[, ]]], ==;
3050
3051% added
3052
3053picture oddly ; % evenly already defined
3054
3055evenly := dashpattern(on  3 off 3) ;
3056oddly  := dashpattern(off 3 on  3) ;
3057
3058% not perfect, but useful since it removes redundant points.
3059
3060vardef mfun_straightened(expr sign, p) =
3061    save temp_p, temp_q ; path temp_p, temp_q ;
3062    temp_p := p ;
3063    forever :
3064        temp_q := mfun_do_straightened(sign, temp_p) ;
3065        exitif length(temp_p) = length(temp_q) ;
3066        temp_p := temp_q ;
3067    endfor ;
3068    temp_q
3069enddef ;
3070
3071% vardef mfun_straightened(expr sign, p) =
3072%     save lp, lq, q ; path q ; q := p ;
3073%     lp := length(p) ;
3074%     forever :
3075%         q := mfun_do_straightened(sign,q) ;
3076%         lq := length(q) ;
3077%         exitif lp = lq ;
3078%         lp := lq ;
3079%     endfor ;
3080%     q
3081% enddef ;
3082
3083% can be optimized:
3084
3085vardef mfun_do_straightened(expr sign, p) =
3086    if length(p) > 2 : % was 1, but straight lines are ok
3087        save pp ; path pp ;
3088        pp := point 0 of p ;
3089        for i=1 upto length(p)-1 :
3090            if round(point i of p) <> round(point length(pp) of pp) :
3091                pp := pp -- point i of p ;
3092            fi ;
3093        endfor ;
3094        save n, ok ; numeric n ; boolean ok ;
3095        n := length(pp) ; ok := false ;
3096        if n > 2 :
3097            for i=0 upto n :
3098                if unitvector(round(point i of pp - point if i=0 : n else : i-1 fi of pp)) <>
3099            sign * unitvector(round(point if i=n : 0 else : i+1 fi of pp - point i of pp)) :
3100                    if ok :
3101                        --
3102                    else :
3103                        ok := true ;
3104                    fi point i of pp
3105                fi
3106            endfor
3107            if ok and (cycle p) :
3108                -- cycle
3109            fi
3110        else :
3111            pp
3112        fi
3113    else :
3114        p
3115    fi
3116enddef ;
3117
3118vardef simplified expr p = (
3119    reverse mfun_straightened(+1,mfun_straightened(+1,reverse p))
3120) enddef ;
3121
3122vardef unspiked expr p = (
3123    reverse mfun_straightened(-1,mfun_straightened(-1,reverse p))
3124) enddef ;
3125
3126permanent simplified, unspiked ;
3127
3128% path p ;
3129% p := (2cm,1cm) -- (2cm,1cm) -- (2cm,1cm) -- (3cm,1cm) --
3130%      (4cm,1cm) -- (4cm,2cm) -- (4cm,2.5cm) -- (4cm,3cm) --
3131%      (3cm,3cm) -- (2cm,3cm) -- (1cm,3cm) -- (-1cm,3cm) --
3132%      .5[(-1cm,3cm),(1cm,1cm)] -- (1cm,1cm) -- cycle ;
3133%
3134% p := unitcircle scaled 4cm ;
3135%
3136% drawpath p ; drawpoints p ; drawpointlabels p ;
3137% p := p shifted (4cm,0) ; p := straightened p ;
3138% drawpath p ; drawpoints p ; drawpointlabels p ;
3139% p := p shifted (4cm,0) ; p := straightened p ;
3140% drawpath p ; drawpoints p ; drawpointlabels p ;
3141
3142% new
3143
3144path originpath ; originpath := origin -- cycle ;
3145
3146vardef unitvector primary z =
3147    if abs z = abs origin : z else : z/abs z fi % hm, abs origin is just origin
3148enddef;
3149
3150vardef epsed (expr e) = % epsed(1.2345)
3151    e if e>0 : + eps elseif e < 0 : - eps fi
3152enddef ;
3153
3154immutable originpath ;
3155permanent unitvector, epsed ;
3156
3157% handy
3158
3159def withgray primary g =
3160    withcolor g
3161enddef ;
3162
3163if unknown darkred     : color darkred     ; darkred     := .625(1,0,0) fi ;
3164if unknown darkgreen   : color darkgreen   ; darkgreen   := .625(0,1,0) fi ;
3165if unknown darkblue    : color darkblue    ; darkblue    := .625(0,0,1) fi ;
3166if unknown darkcyan    : color darkcyan    ; darkcyan    := .625(0,1,1) fi ;
3167if unknown darkmagenta : color darkmagenta ; darkmagenta := .625(1,0,1) fi ;
3168if unknown darkyellow  : color darkyellow  ; darkyellow  := .625(1,1,0) fi ;
3169if unknown darkgray    : color darkgray    ; darkgray    := .625(1,1,1) fi ;
3170if unknown lightgray   : color lightgray   ; lightgray   := .850(1,1,1) fi ;
3171
3172permanent withgray ;
3173
3174% an improved plain mp macro
3175
3176% vardef center primary p =
3177%     if pair p :
3178%         p
3179%     else :
3180%         .5[llcorner p, urcorner p]
3181%     fi
3182% enddef;
3183%
3184% permanent center ;
3185
3186vardef center primary p =
3187    centerof p
3188enddef ;
3189
3190% new, yet undocumented
3191
3192vardef rangepath (expr p, d, a) =
3193    if length p>0 :
3194        (d*unitvector(direction 0 of p) rotated a) shifted point 0 of p
3195        -- p --
3196        (d*unitvector(direction length(p) of p) rotated a) shifted point length(p) of p
3197    else :
3198        p
3199    fi
3200enddef ;
3201
3202% under construction
3203
3204vardef straightpath (expr a, b, method) =
3205    if (method<1) or (method>6)  :
3206        (a--b)
3207    elseif method = 1 :
3208        (a --
3209            if xpart a > xpart b :
3210                if ypart a > ypart b :
3211                    (xpart b,ypart a) --
3212                elseif ypart a < ypart b :
3213                    (xpart a,ypart b) --
3214                fi
3215            elseif xpart a < xpart b :
3216                if ypart a > ypart b :
3217                    (xpart a,ypart b) --
3218                elseif ypart a < ypart b :
3219                    (xpart b,ypart a) --
3220                fi
3221            fi
3222        b)
3223    elseif method = 3 :
3224        (a --
3225            if xpart a > xpart b :
3226                (xpart b,ypart a) --
3227            elseif xpart a < xpart b :
3228                (xpart a,ypart b) --
3229            fi
3230        b)
3231    elseif method = 5 :
3232        (a --
3233            if ypart a > ypart b :
3234                (xpart b,ypart a) --
3235            elseif ypart a < ypart b :
3236                (xpart a,ypart b) --
3237            fi
3238        b)
3239    else :
3240        (reverse straightpath(b,a,method-1))
3241    fi
3242enddef ;
3243
3244permanent straightpath ;
3245
3246% handy for myself
3247
3248def addbackground text t =
3249    begingroup ;
3250    save p, b ; picture p ; path b ;
3251    b := boundingbox currentpicture ;
3252    p := currentpicture ; currentpicture := nullpicture ;
3253    fill b t ;
3254    setbounds currentpicture to b ;
3255    addto currentpicture also p ;
3256    endgroup ;
3257enddef ;
3258
3259permanent addbackground ;
3260
3261% makes a (line) into an infinite one (handy for calculating
3262% intersection points
3263
3264vardef infinite expr p =
3265    (-infinity*unitvector(direction 0 of p)
3266    shifted point 0 of p
3267    -- p --
3268    +infinity*unitvector(direction length(p) of p)
3269        shifted point length(p) of p)
3270enddef ;
3271
3272permanent infinite ;
3273
3274% obscure macros: create var from string and replace - and :
3275% (needed for process color id's) .. will go away
3276
3277% this will become a lua helper
3278
3279% string mfun_clean_ascii[] ;
3280%
3281% def register_dirty_chars(expr str) =
3282%     for i = 0 upto length(str)-1 :
3283%         mfun_clean_ascii[ASCII substring(i,i+1) of str] := "_" ;
3284%     endfor ;
3285% enddef ;
3286%
3287% register_dirty_chars("+-*/:;., ") ;
3288%
3289% vardef cleanstring (expr s) =
3290%     save ss ; string ss, si ; ss = "" ; save i ;
3291%     for i=0 upto length(s) :
3292%         si := substring(i,i+1) of s ;
3293%         ss := ss & if known mfun_clean_ascii[ASCII si] : mfun_clean_ascii[ASCII si] else : si fi ;
3294%     endfor ;
3295%     ss
3296% enddef ;
3297%
3298% vardef asciistring (expr s) =
3299%     save ss ; string ss, si ; ss = "" ; save i ;
3300%     for i=0 upto length(s) :
3301%         si := substring(i,i+1) of s ;
3302%         if (ASCII si >= ASCII "0") and (ASCII si <= ASCII "9") :
3303%             ss := ss & char(scantokens(si) + ASCII "A") ;
3304%         else :
3305%             ss := ss & si ;
3306%         fi ;
3307%     endfor ;
3308%     ss
3309% enddef ;
3310%
3311% vardef setunstringed (expr s, v) =
3312%     scantokens(cleanstring(s)) := v ;
3313% enddef ;
3314%
3315% vardef getunstringed (expr s) =
3316%     scantokens(cleanstring(s))
3317% enddef ;
3318%
3319% vardef unstringed (expr s) =
3320%     expandafter known scantokens(cleanstring(s))
3321% enddef ;
3322
3323% for david arnold: showgrid(-5,10,1cm,-10,10,1cm);
3324
3325def showgrid (expr minx, maxx, deltax, miny, maxy, deltay) = % will move
3326    begingroup
3327    save size ; numeric size ; size := 2pt ;
3328    for x=minx upto maxx :
3329        for y=miny upto maxy :
3330            draw (x*deltax, y*deltay) withpen pencircle scaled
3331                if (x mod 5 = 0) and (y mod 5 = 0) :
3332                    1.5size withcolor .50white
3333                else :
3334                       size withcolor .75white
3335                fi ;
3336        endfor ;
3337    endfor ;
3338    for x=minx upto maxx:
3339        label.bot(textext("\infofont " & decimal x), (x*deltax,-size)) ;
3340    endfor ;
3341    for y=miny upto maxy:
3342        label.lft(textext("\infofont " & decimal y), (-size,y*deltay)) ;
3343    endfor ;
3344    endgroup
3345enddef;
3346
3347% new, handy for:
3348%
3349% \startuseMPgraphic{map}{n}
3350%   \includeMPgraphic{map:germany} ;
3351%   c_phantom (\MPvar{n}<1) (
3352%     fill map_germany withcolor \MPcolor{lightgray} ;
3353%     draw map_germany withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
3354%   ) ;
3355%   \includeMPgraphic{map:austria} ;
3356%   c_phantom (\MPvar{n}<2) (
3357%     fill map_austria withcolor \MPcolor{lightgray} ;
3358%     draw map_austria withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ;
3359%   ) ;
3360%   c_phantom (\MPvar{n}<3) (
3361%   \includeMPgraphic{map:swiss} ;
3362%     fill map_swiss withcolor \MPcolor{lightgray} ;
3363%     draw map_swiss withpen pencircle scaled 1pt withcolor \MPcolor{darkgray}  ;
3364%   ) ;
3365%   c_phantom (\MPvar{n}<4) (
3366%   \includeMPgraphic{map:luxembourg} ;
3367%     fill map_luxembourg withcolor \MPcolor{lightgray} ;
3368%     draw map_luxembourg withpen pencircle scaled 1pt withcolor \MPcolor{darkgray}  ;
3369%   ) ;
3370% \stopuseMPgraphic
3371%
3372% \useMPgraphic{map}{n=3}
3373
3374vardef phantom (text t) = % to be checked
3375    picture temp_p ;
3376    temp_p := image(t) ;
3377    addto temp_p also currentpicture ;
3378    setbounds currentpicture to boundingbox temp_p ;
3379enddef ;
3380
3381vardef c_phantom (expr b) (text t) =
3382    if b :
3383        save temp_p; picture temp_p ;
3384        temp_p := image(t) ;
3385        addto temp_p also currentpicture ;
3386        setbounds currentpicture to boundingbox temp_p ;
3387    else :
3388        t ;
3389    fi ;
3390enddef ;
3391
3392permanent phantom ;
3393
3394%D Handy:
3395
3396def break =
3397    exitif true ; % fi
3398enddef ;
3399
3400permanent break ;
3401
3402%D New too:
3403
3404% primarydef p xstretched w = (
3405%     p if (bbwidth (p)>0) and (w>0) : xscaled (w/bbwidth (p)) fi
3406% ) enddef ;
3407%
3408% primarydef p ystretched h = (
3409%     p if (bbheight(p)>0) and (h>0) : yscaled (h/bbheight(p)) fi
3410% ) enddef ;
3411
3412primarydef p xstretched w = (
3413    begingroup save l, r ; pair r;
3414    r := xrange p ;
3415    l := ypart r - xpart r ;
3416    p if (l > 0) and (w > 0) : xscaled (w/l) fi
3417    endgroup
3418) enddef ;
3419
3420primarydef p ystretched h = (
3421    begingroup save l, r ; pair r;
3422    r := yrange p ;
3423    l := ypart r - xpart r ;
3424    p if (l > 0) and (h > 0) : yscaled (h/l) fi
3425    endgroup
3426) enddef ;
3427
3428permanent xstretched, ystretched ;
3429
3430%D Newer:
3431
3432% vardef area expr p =
3433%     % we could calculate the boundingbox once
3434%     (xpart llcorner boundingbox p,0) -- p --
3435%     (xpart lrcorner boundingbox p,0) -- cycle
3436% enddef ;
3437
3438vardef area expr p = % kind of useless so it can be dropped
3439    llcorner boundingbox p -- p --
3440    lrcorner boundingbox p -- cycle
3441enddef ;
3442
3443vardef basiccolors[] =
3444    if @ = 0 :
3445        white
3446    else :
3447        save n ; n := @ mod 7 ;
3448        if     n = 1 : red
3449        elseif n = 2 : green
3450        elseif n = 3 : blue
3451        elseif n = 4 : cyan
3452        elseif n = 5 : magenta
3453        elseif n = 6 : yellow
3454        else         : black
3455        fi
3456    fi
3457enddef ;
3458
3459% vardef somecolor = (1,1,0,0) enddef ;
3460
3461% fill OverlayBox withcolor (rcomponent somecolor,gcomponent somecolor,bcomponent somecolor) ;
3462% fill OverlayBox withcolor (ccomponent somecolor,mcomponent somecolor,ycomponent somecolor,bcomponent somecolor) ;
3463
3464% This could be standard mplib 2 behaviour:
3465
3466% vardef rcomponent expr p = if rgbcolor  p : redpart     elseif cmykcolor p : 1 - cyanpart    fi p enddef ;
3467
3468vardef rcomponent expr p = if rgbcolor  p : redpart     p elseif cmykcolor p : 1 - cyanpart    p else : p fi enddef ;
3469vardef gcomponent expr p = if rgbcolor  p : greenpart   p elseif cmykcolor p : 1 - magentapart p else : p fi enddef ;
3470vardef bcomponent expr p = if rgbcolor  p : bluepart    p elseif cmykcolor p : 1 - yellowpart  p else : p fi enddef ;
3471vardef ccomponent expr p = if cmykcolor p : cyanpart    p elseif rgbcolor  p : 1 - redpart     p else : p fi enddef ;
3472vardef mcomponent expr p = if cmykcolor p : magentapart p elseif rgbcolor  p : 1 - greenpart   p else : p fi enddef ;
3473vardef ycomponent expr p = if cmykcolor p : yellowpart  p elseif rgbcolor  p : 1 - bluepart    p else : p fi enddef ;
3474vardef kcomponent expr p = if cmykcolor p : blackpart   p elseif rgbcolor  p : 0                 else : p fi enddef ;
3475
3476permanent rcomponent, gcomponent, bcomponent, ccomponent, mcomponent, ycomponent, kcomponent ;
3477
3478% draw image       (...) ... ; % prescripts prepended to first, postscripts appended to last
3479% draw decorated   (...) ... ; % prescripts prepended to each,  postscripts appended to each
3480% draw redecorated (...) ... ; % prescripts assigned  to each,  postscripts assigned to each
3481% draw undecorated (...) ... ; % following properties are ignored, existing properties are kept
3482%
3483% draw decorated (
3484%     draw fullcircle scaled 20cm withpen pencircle scaled 20mm withcolor red   withtransparency (1,.40) ;
3485%     draw fullcircle scaled 15cm withpen pencircle scaled 15mm withcolor green withtransparency (1,.30) ;
3486%     draw fullcircle scaled 10cm withpen pencircle scaled 10mm withcolor blue  withtransparency (1,.20) ;
3487% )
3488%     withcolor blue
3489%     withtransparency (1,.125) % selectively applied
3490%     withpen pencircle scaled 10mm
3491% ;
3492
3493% vardef image (text imagedata) = % already defined
3494%     save currentpicture ;
3495%     picture currentpicture ;
3496%     currentpicture := nullpicture ;
3497%     imagedata ;
3498%     currentpicture
3499% enddef ;
3500
3501vardef undecorated (text t) text decoration =
3502    save currentpicture ;
3503    picture currentpicture ;
3504    currentpicture := nullpicture ;
3505    t ;
3506    currentpicture
3507enddef ;
3508
3509vardef decorated (text imagedata) text decoration =
3510    save mfun_decorated_path, currentpicture ;
3511    picture mfun_decorated_path, currentpicture ;
3512    currentpicture := nullpicture ;
3513    imagedata ;
3514    mfun_decorated_path := currentpicture ;
3515    currentpicture := nullpicture ;
3516    for i within mfun_decorated_path :
3517        addto currentpicture
3518            if stroked i :
3519                doublepath pathpart i
3520                dashed dashpart i
3521                withpen penpart i
3522                withcolor colorpart i
3523                withprescript prescriptpart i
3524                withpostscript postscriptpart i
3525                decoration
3526            elseif filled i :
3527                contour pathpart i
3528                withpen penpart i
3529                withcolor colorpart i
3530                withprescript prescriptpart i
3531                withpostscript postscriptpart i
3532                decoration
3533            elseif textual i :
3534                also i
3535                withcolor colorpart i
3536                withprescript prescriptpart i
3537                withpostscript postscriptpart i
3538                decoration
3539            else :
3540                also i
3541            fi
3542        ;
3543    endfor ;
3544    currentpicture
3545enddef ;
3546
3547vardef redecorated (text imagedata) text decoration =
3548    save mfun_decorated_path, currentpicture ;
3549    picture mfun_decorated_path, currentpicture ;
3550    currentpicture := nullpicture ;
3551    imagedata ;
3552    mfun_decorated_path := currentpicture ;
3553    currentpicture := nullpicture ;
3554    for i within mfun_decorated_path :
3555        addto currentpicture
3556            if stroked i :
3557                doublepath pathpart i
3558                dashed dashpart i
3559                withpen penpart i
3560                decoration
3561            elseif filled i :
3562                contour pathpart i
3563                withpen penpart i
3564                decoration
3565            elseif textual i :
3566                also i
3567                decoration
3568            else :
3569                also i
3570            fi
3571        ;
3572    endfor ;
3573    currentpicture
3574enddef ;
3575
3576permanent decorated, undecorated, redecorated ;
3577
3578% path mfun_bleed_box ;
3579
3580% primarydef p bleeded d =
3581%     image (
3582%         mfun_bleed_box := boundingbox p ;
3583%         if pair d :
3584%             draw p xysized (bbwidth(p)+2*xpart d,bbheight(p)+2*ypart d) shifted -d ;
3585%         else :
3586%             draw p xysized (bbwidth(p)+2d,bbheight(p)+2d) shifted (-d,-d) ;
3587%         fi ;
3588%         setbounds currentpicture to mfun_bleed_box ;
3589%     )
3590% enddef ;
3591
3592vardef mfun_snapped(expr p, s) =
3593    if p < 0 : - ( - else : ( fi p div s) * s % the less tokens the better
3594enddef ;
3595
3596vardef mfun_applied(expr p, s)(suffix a) =
3597    if path p :
3598        if pair s :
3599            for i=0 upto length(p)-1 :
3600                (a(xpart point i of p,xpart s),a(ypart point i of p,ypart s)) --
3601            endfor
3602            if cycle p :
3603                cycle
3604            else :
3605                (a(xpart point length(p) of p,xpart s),a(ypart point length(p) of p,ypart s))
3606            fi
3607        else :
3608            for i=0 upto length(p)-1 :
3609                (a(xpart point i of p,s),a(ypart point i of p,s)) --
3610            endfor
3611            if cycle p :
3612                cycle
3613            else :
3614                (a(xpart point length(p) of p,s),a(ypart point length(p) of p,s))
3615            fi
3616        fi
3617    elseif pair p :
3618        if pair s :
3619            (a(xpart p,xpart s),a(ypart p,ypart s))
3620        else :
3621            (a(xpart p,s),a(ypart p,s))
3622        fi
3623    elseif cmykcolor p :
3624       (a(cyanpart p,s),a(magentapart p,s),a(yellowpart p,s),a(blackpart p,s))
3625    elseif rgbcolor p :
3626       (a(redpart p,s),a(greenpart p,s),a(bluepart p,s))
3627    elseif graycolor p :
3628        a(p,s)
3629    elseif numeric p :
3630        a(p,s)
3631    else
3632        p
3633    fi
3634enddef ;
3635
3636primarydef p snapped s =
3637    mfun_applied(p,s)(mfun_snapped) % so we can play with variants
3638enddef ;
3639
3640permanent snapped ;
3641
3642%D Take a look at mp-tool.mpiv for the old implementation if the next code. We only provide
3643%D this for old times sake. We assume that the lmt_ commands are defined by the time this
3644%D is used:
3645
3646% beginfont("demo-symbols");
3647%     beginglyph(9754,2,4,0) ; % high voltage
3648%         interim ahlength := 1 ;
3649%         drawarrow (1,4) -- (0,2) -- (2,3) -- (1,0) withcolor darkred ;
3650%     endglyph ;
3651% endfont;
3652
3653picture font_glyph[][] ;
3654numeric font_count ; font_count := 0;
3655
3656def beginfont(expr n) =
3657    begingroup ;
3658    save name ; string name; name := n;
3659    font_count := font_count + 1 ;
3660    lmt_registerglyphs [
3661        name   = name,
3662        units  = 10,
3663        width  = 10,
3664        height = 8,
3665        depth  = 2,
3666    ] ;
3667enddef ;
3668
3669def endfont =
3670    endgroup;
3671enddef ;
3672
3673def beginglyph(expr u, w, h, d) =
3674    save unicode ; unicode := u;
3675    lmt_registerglyph [
3676        category = name,
3677        unicode  = u,
3678        code     = "draw font_glyph[" & decimal font_count & "][" & decimal u & "];"
3679        width    = w,
3680        height   = h,
3681        depth    = d,
3682    ] ;
3683    currentpicture := nullpicture ;
3684enddef ;
3685
3686def endglyph =
3687    font_glyph[font_count][unicode] := currentpicture ;
3688enddef ;
3689
3690permanent beginfont, endfont, beginglyph, endglyph ;
3691
3692%D Dimensions have never been an issue as traditional MP can't make that large pictures,
3693%D but with double mode we need a catch:
3694
3695newinternal maxdimensions ; maxdimensions := 14000 ;
3696
3697def mfun_apply_max_dimensions = % not a generic helper, we want to protect this one
3698    if bbwidth currentpicture > maxdimensions :
3699        currentpicture := currentpicture if bbheight currentpicture  > bbwidth currentpicture : ysized else : xsized fi maxdimensions ;
3700    elseif bbheight currentpicture  > maxdimensions :
3701        currentpicture := currentpicture ysized maxdimensions ;
3702    fi ;
3703enddef;
3704
3705extra_endfig := extra_endfig & "mfun_apply_max_dimensions ;" ;
3706
3707%D Bonus shapes (need along):
3708
3709path unittriangle, fulltriangle ; % not really units but circle based
3710
3711unittriangle := point 0   along unitcircle
3712             -- point 1/3 along unitcircle
3713             -- point 2/3 along unitcircle
3714             -- cycle ;
3715fulltriangle := point 0   along fullcircle
3716             -- point 1/3 along fullcircle
3717             -- point 2/3 along fullcircle
3718             -- cycle ;
3719
3720immutable unittriangle, fulltriangle ;
3721
3722%D Kind of special and undocumented. On Wikipedia one can find examples of quick sort
3723%D routines. Here we have a variant that permits a method.
3724
3725% vardef listsize(suffix list) =
3726%     numeric len ; len := 0 ;
3727%     forever :
3728%         exitif unknown list[len+1] ;
3729%         len := len + 1 ;
3730%     endfor ;
3731%     len
3732% enddef ;
3733
3734vardef listsize(suffix list) =
3735    numeric len ; len := 1 ;
3736    forever :
3737        exitif unknown list[len] ;
3738        len := len + 1 ;
3739    endfor ;
3740    len if unknown list[0] : - 1 fi
3741enddef ;
3742
3743vardef listlast(suffix list) =
3744    numeric len ; len := if known list[0] : 0 else : 1 fi  ;
3745    forever :
3746        len := len + 1 ;
3747        exitif unknown list[len] ;
3748    endfor ;
3749    len - 1
3750enddef ;
3751
3752vardef mfun_quick_sort(suffix list)(expr asked_min, asked_max)(text what) =
3753    save l, r, m ;
3754    numeric l ; l := asked_min ;
3755    numeric r ; r := asked_max ;
3756    numeric m ; m := floor(.5[asked_min,asked_max]) ;
3757    asked_mid := what list[m] ;
3758    forever :
3759        exitif l >= r ;
3760        forever :
3761            exitif l > asked_max ;
3762          % exitif (what list[l]) >= (what list[m]) ;
3763            exitif (what list[l]) >= asked_mid ;
3764            l := l + 1 ;
3765        endfor ;
3766        forever :
3767            exitif r < asked_min ;
3768          % exitif (what list[m]) >= (what list[r]) ;
3769            exitif asked_mid >= (what list[r]) ;
3770            r := r - 1 ;
3771        endfor ;
3772        if l <= r :
3773          temp := list[l] ;
3774          list[l] := list[r] ;
3775          list[r] := temp ;
3776          l := l + 1 ;
3777          r := r - 1 ;
3778        fi ;
3779    endfor ;
3780    if asked_min < r :
3781        mfun_quick_sort(list)(asked_min,r)(what) ;
3782    fi ;
3783    if l < asked_max :
3784        mfun_quick_sort(list)(l,asked_max)(what) ;
3785    fi ;
3786enddef ;
3787
3788vardef sortlist(suffix list)(text what) =
3789    save asked_max ; numeric asked_max ;
3790    save asked_mid ; numeric asked_mid ;
3791    save temp ;
3792  % asked_max := listsize(list) ;
3793    asked_max := listlast(list) ;
3794    if pair list[asked_max] :
3795        pair temp ;
3796    else :
3797        numeric temp ;
3798    fi ;
3799    if pair what list[asked_max] :
3800        pair asked_mid ;
3801    else :
3802        numeric asked_mid ;
3803    fi ;
3804    if asked_max > 1 :
3805      % mfun_quick_sort(list)(1,asked_max)(what) ;
3806        mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,asked_max)(what) ;
3807    fi ;
3808enddef ;
3809
3810vardef uniquelist(suffix list) =
3811    % this one will be defined later
3812enddef ;
3813
3814vardef copylist(suffix list, target) =
3815    save i ; i := 1 ;
3816    forever :
3817        exitif unknown list[i] ;
3818        target[i] := list[i] ;
3819        i := i + 1 ;
3820    endfor ;
3821enddef ;
3822
3823vardef listtolines(suffix list) =
3824    list[1] for i=2 upto listsize(list) : -- list[i] endfor
3825enddef ;
3826
3827vardef listtocurves(suffix list) =
3828    list[1] for i=2 upto listsize(list) : .. list[i] endfor
3829enddef ;
3830
3831%D The sorter is used in:
3832
3833% not yet ok
3834
3835vardef shapedlist(suffix p) = % takes a list of paths
3836    save l ; pair l[] ;
3837    save r ; pair r[] ;
3838    save i ; i := 1 ;
3839    save n ; n := 0 ;
3840    forever :
3841        exitif unknown p[i] ;
3842        n := n + 1 ;
3843        l[n] := ulcorner p[i] ;
3844        r[n] := urcorner p[i] ;
3845        n := n + 1 ;
3846        l[n] := llcorner p[i] ;
3847        r[n] := lrcorner p[i] ;
3848        i := i + 1 ;
3849    endfor ;
3850    for i = 3 upto n :
3851        if xpart r[i] < xpart r[i-1] :
3852            r[i] := (xpart r[i],ypart r[i-1]) ;
3853        elseif xpart r[i] > xpart r[i-1] :
3854            r[i-1] := (xpart r[i-1],ypart r[i]) ;
3855        fi ;
3856        if xpart l[i] < xpart l[i-1] :
3857            l[i-1] := (xpart l[i-1],ypart l[i]) ;
3858        elseif xpart l[i] > xpart l[i-1] :
3859            l[i] := (xpart l[i],ypart l[i-1]) ;
3860        fi ;
3861    endfor ;
3862    if n > 0 :
3863        simplified (
3864            for i = 1 upto   n : r[i] -- endfor
3865            for i = n downto 1 : l[i] -- endfor
3866            cycle
3867        )
3868    else :
3869        origin -- cycle
3870    fi
3871enddef ;
3872
3873permanent listsize, listlast, sortlist, uniquelist, copylist, listtolines, listtocurves, shapedlist ;
3874
3875%D Dumping is fake anyway but let's keep this:
3876
3877let dump = relax ;
3878
3879%D Loading modules can be done with:
3880
3881def loadmodule expr name = % no vardef
3882    % input can't be used directly in a macro
3883    if (unknown scantokens("context_" & name)) and (unknown scantokens("metafun_loaded_" & name)) :
3884        save s ; string s ; s := "input " & ditto & "mp-" & name & ditto & ";" ;
3885        expandafter scantokens expandafter s
3886    fi ;
3887enddef ;
3888
3889def loadfile  (expr filename) =       scantokens("input " & filename)   enddef ;
3890def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ;
3891
3892permanent loadmodule, loadfile, loadimage ;
3893
3894%D Handy for backgrounds:
3895
3896def drawpathwithpoints expr p =
3897    do_drawpathwithpoints(p)
3898enddef ;
3899
3900def do_drawpathwithpoints(expr p) text t =
3901    draw p t ;
3902    if length(p) > 2 :
3903        begingroup ;
3904        save temp_c ; path temp_c ;
3905        save temp_p; picture temp_p ;
3906        temp_p := image (
3907            temp_c := if cycle p : fullsquare else : fullcircle fi scaled 6pt ;
3908            for i=0 upto length(p) if cycle p : -1 fi :
3909                fill temp_c shifted point i of p withcolor white ;
3910                draw temp_c shifted point i of p withcolor white/2 withpen pencircle scaled .5pt ;
3911                if (i = 0) and cycle p :
3912                    temp_c := fullcircle scaled 6pt ;
3913                fi ;
3914            endfor ;
3915            for i=0 upto length(p) if cycle p : -1 fi :
3916                draw textext("\infofont " & decimal i) ysized 2pt shifted point i of p ;
3917            endfor ;
3918        ) ;
3919        setbounds temp_p to boundingbox p ;
3920        draw temp_p ;
3921    fi ;
3922enddef ;
3923
3924%D These new helpers are by Alan and are used in for instance the mp-node module.
3925
3926newinternal crossingdebug     ; crossingdebug     := 0 ;
3927newinternal crossingscale     ; crossingscale     := 10 ;
3928newinternal crossingnumbermax ; crossingnumbermax := 1000 ;
3929
3930% primary, secondary or tertiary? always hard to decide but primary makes sense
3931
3932vardef infotext@#(expr txt, ysize) =
3933    textext@#("\infofont " & if numeric txt : decimal fi txt) ysized ysize
3934enddef ;
3935
3936primarydef p crossingunder q =
3937    begingroup
3938    save pic ; picture pic ; pic := nullpicture ;
3939    if picture p :
3940        for i within p :
3941            if stroked i :
3942                addto pic also image(draw pathpart i crossingunder q) ;
3943            fi
3944        endfor
3945    elseif path p :
3946        save n, t, a, b, c, r, bcuttings, hold ;
3947        numeric n, t[], hold ;
3948        path a, b, c, r, bcuttings, hold[] ;
3949        c := makepath(currentpen scaled crossingscale) ;
3950        r := if picture q : boundingbox fi q ;
3951        t[0] := n := hold := 0 ;
3952        a := p ;
3953        % The cutbefore/cutafter using c below prevents endless loops!
3954       %forever : % find all intersections
3955        for i=1 upto crossingnumbermax : % safeguard
3956            clearxy ; z = a intersectiontimes r ;
3957            if x < 0 :
3958                exitif hold < 1 ;
3959                a := hold[hold] ; hold := hold - 1 ;
3960                clearxy ; z = a intersectiontimes r ;
3961            fi
3962            (t[incr n], whatever) = p intersectiontimes point x of a ;
3963            if x = 0 :
3964                a := a cutbefore c shifted point x of a ;
3965            elseif x = length a :
3966                a := a cutafter  c shifted point x of a ;
3967            else : % before or after?
3968                b := subpath (0,x)        of a cutafter  c shifted point x of a ;
3969                bcuttings := cuttings ;
3970                a := subpath (x,length a) of a cutbefore c shifted point x of a ;
3971                clearxy ; z = a intersectiontimes r ;
3972                if x < 0 :
3973                    a := b ;
3974                    cuttings := bcuttings ;
3975                else :
3976                    if length bcuttings > 0 :
3977                        clearxy ; z = b intersectiontimes r ;
3978                        if x >= 0 :
3979                            hold[incr hold] := b ;
3980                        fi
3981                    fi
3982                fi
3983            fi
3984            if length cuttings = 0 : % a single point: nothing cut
3985                exitif hold < 1 ;
3986                a := hold[hold] ; hold := hold - 1 ;
3987            fi
3988            if i = crossingnumbermax :
3989                message("crossingunder reached maximum " & decimal i & " intersections.");
3990            fi
3991        endfor
3992
3993        if n = 0 : % No crossings, we return the PATH
3994            save pic ; path pic ; pic := p ;
3995        else : % n>0
3996            sortlist(t,) ;
3997            % we add too much, maybe a test is needed
3998            t[incr n] = length p if cycle p : + t[1] fi ;
3999% save tt[] ; numeric tt[] ; uniquelist(t,tt) ; t := tt ;
4000            % Now, n>1 !
4001            % t[0] is the first point of the path and t[n] is the last point
4002            % (or the first intersection beyond the length if cyclic)
4003            save m ; m := 0 ;
4004            for i=if cycle p: 2 else: 1 fi upto n :
4005                % skip the first segment if cyclic
4006                % as it gets repeated (fully) at the end.
4007                if crossingdebug > 0 :
4008                    if crossingdebug = 1 :
4009                        addto pic doublepath c shifted point t[i] of p
4010                        withpen currentpen withtransparency(1,.5) ;
4011                    elseif crossingdebug = 2 :
4012                        addto pic also
4013                        infotext (incr m,crossingscale/5)
4014                        shifted point t[i] of p ;
4015                    fi
4016                fi
4017                a := subpath (t[i-1],t[i]) of p
4018                    if i > 1 :
4019                        cutbefore (c shifted point t[i-1] of p)
4020                    fi
4021                    if (i < n) or (cycle p) :
4022                        cutafter  (c shifted point t[i]   of p)
4023                    fi ;
4024                if (not picture q) or (a outsideof q) :
4025                    addto pic doublepath a withpen currentpen ;
4026                fi
4027            endfor
4028        fi
4029    fi
4030    pic
4031    endgroup
4032enddef ;
4033
4034primarydef p insideof q =
4035    begingroup
4036        save pth, pic, t ;
4037        path pth ; picture pic ;
4038        pic := if path q : image(draw q;) else : q fi ;
4039        pth := p -- center pic ;
4040        (t, whatever) = pth intersectiontimes boundingbox pic ;
4041        t < 0
4042    endgroup
4043enddef ;
4044
4045% primarydef p insideof q =
4046%     if (path q or picture q) :
4047%         if (path p or picture p) :
4048%             (xpart llcorner p > xpart llcorner q) and
4049%             (xpart urcorner p < xpart urcorner q) and
4050%             (ypart llcorner p > ypart llcorner q) and
4051%             (ypart urcorner p < ypart urcorner q)
4052%         elseif pair p  :
4053%             (xpart p > xpart llcorner q) and
4054%             (xpart p < xpart urcorner q) and
4055%             (ypart p > ypart llcorner q) and
4056%             (ypart p < ypart urcorner q)
4057%         fi
4058%     elseif (numeric p and pair q) :
4059%         % range check
4060%         (p >= xpart q) and (p <= ypart q)
4061%     else : % maybe triplets and such
4062%         false
4063%     fi
4064% enddef ;
4065
4066primarydef p outsideof q =
4067    not (p insideof q)
4068enddef ;
4069
4070permanent crossingdebug, crossingscale, crossingnumbermax, infotext, crossingunder, insideof, outsideof ;
4071
4072%D Also handy:
4073
4074vardef circularpath primary n =
4075    reverse (for i=0 step 2/n until 8-2/n+2eps: point i of fullcircle .. endfor cycle) rotated 90
4076enddef ;
4077
4078vardef squarepath primary n =
4079    for i=0 step 1/n until 4-1/n + 2eps: point i of fullsquare -- endfor cycle
4080enddef ;
4081
4082vardef linearpath primary n =
4083    origin for i=1/n step 1/n until 1-1/n + 2eps: -- point i of (origin--(1,0)) endfor
4084enddef ;
4085
4086permanent circularpath, squarepath, linearpath ;
4087
4088%D  A nice tracing helper:
4089
4090color       pensilcolor ; pensilcolor := .5red ;
4091newinternal pensilstep  ; pensilstep  := 1/25 ;
4092
4093vardef pensilled(expr p, q) =
4094    image (
4095        draw p withcolor pensilcolor withpen q ;
4096        for i = 0 step pensilstep until length(p) + eps:
4097            draw point i of p withcolor white withtransparency (1,.5) withpen q ;
4098        endfor ;
4099    )
4100enddef ;
4101
4102permanent pensilled, pensilcolor, pensilstep ;
4103
4104%D Easy to forget but handy for manuals:
4105
4106vardef tolist(suffix l)(text t) =
4107    save n ; n := 1 ;
4108    for p = t :
4109        if numeric p :
4110            n := p ;
4111            dispose(l[n])
4112        elseif pair p :
4113            l[n] := p ;
4114            n := n + 1 ;
4115        elseif path p :
4116            for i=0 step 1 until length(p) :
4117                l[n] := point i of p ;
4118                n := n + 1 ;
4119            endfor ;
4120        else :
4121            % ignore
4122        fi ;
4123    endfor ;
4124    forever :
4125        exitif unknown l[n] ;
4126        dispose(l[n])
4127        n := n + 1 ;
4128    endfor ;
4129enddef ;
4130
4131vardef topath(suffix p)(text t) =
4132    save i ; i := if known p[1] : 2 ; p[1] elseif known p[0] : 1 ; p[0] else : 0 ; origin fi
4133    forever :
4134        exitif unknown p[i] ;
4135        t p[i]
4136        hide(i := i + 1)
4137    endfor
4138enddef ;
4139
4140vardef tocycle(suffix p)(text t) =
4141    topath(p,t) t cycle
4142enddef ;
4143
4144permanent tolist, topath, tocycle ;
4145
4146% reimplemented to support paths and pictures
4147
4148def drawdot expr p =
4149    if pair p :
4150        addto currentpicture doublepath p
4151            withpen currentpen base_draw_options
4152    elseif path p :
4153        draw image (
4154            for i=0 upto length p :
4155                addto currentpicture doublepath point i of p
4156                    withpen currentpen base_draw_options ;
4157            endfor ;
4158        )
4159    elseif picture p :
4160        draw image (
4161            save pp ; path pp ;
4162            for i within p :
4163                if stroked i or filled i :
4164                    pp := pathpart i ;
4165                    for j=0 upto length pp :
4166                        addto currentpicture doublepath point j of pp
4167                            withpen currentpen base_draw_options ;
4168                    endfor ;
4169                fi ;
4170            endfor ;
4171        )
4172    fi
4173enddef ;
4174
4175permanent drawdot ;
4176
4177% vardef textlength(text t) =
4178%     save n ; n := 0 ;
4179%     for i = t :
4180% 		n := n + 1 ;
4181% 	endfor;
4182%     n
4183% enddef;
4184
4185vardef mfun_timestamp =
4186    decimal year                        & "-" &
4187    decimal month                       & "-" &
4188    decimal day                         & " " &
4189    if ((time div 60) < 10)           :   "0" & fi
4190    decimal (time div 60)               & ":" &
4191    if ((time-(time div 60)*60) < 10) :   "0" & fi
4192    decimal (time-(time div 60)*60)
4193enddef ;
4194
4195vardef totransform(expr x, y, xx, xy, yx, yy) =
4196    save t ; transform t ;
4197    xxpart t = xx ; yypart t = yy ;
4198    xypart t = xy ; yxpart t = yx ;
4199    xpart  t = x  ; ypart  t = y  ;
4200    t
4201enddef ;
4202
4203vardef bymatrix(expr rx, sx, sy, ry, tx, ty) =
4204    save t ; transform t ;
4205    xxpart t = rx ; yypart t = ry ;
4206    xypart t = sx ; yxpart t = sy ;
4207    xpart  t = tx ; ypart  t = ty ;
4208    t
4209enddef ;
4210
4211% vardef bytopdownmatrix(expr rx, sx, sy, ry, tx, ty) =
4212%     save t ; transform t ;
4213%     xxpart t =  rx ; yypart t =  ry ;
4214%     xypart t = -sy ; yxpart t = -sx ;
4215%     xpart  t =  tx ; ypart  t =  ty ;
4216%     t
4217% enddef ;
4218
4219vardef closedcurve primary p =
4220    p if (path p and not cycle p) or (pair p) : .. cycle fi
4221enddef ;
4222
4223vardef closedlines primary p =
4224    p if (path p and not cycle p) or (pair p) : -- cycle fi
4225enddef ;
4226
4227permanent totransform, bymatrix, closedcurve, closedlines ;
4228
4229let xslanted = slanted ;
4230
4231def yslanted primary s =
4232    transformed
4233        begingroup
4234            save t ; transform t ;
4235            xxpart t = 1 ; yypart t = 1 ;
4236            xypart t = 0 ; yxpart t = s ;
4237            xpart  t = 0 ; ypart  t = 0 ;
4238            t
4239        endgroup
4240enddef ;
4241
4242permanent xslanted, yslanted ;
4243
4244vardef processpath (expr p) (text pp) =
4245    if path p :
4246        for i=0 upto length(p)-1 :
4247            pp(point       i    of p) .. controls
4248            pp(postcontrol i    of p) and
4249            pp(precontrol (i+1) of p) ..
4250        endfor
4251        if cycle p :
4252            cycle
4253        else :
4254            pp(point length(p) of p)
4255        fi
4256    elseif pair p :
4257        pp(p)
4258    else :
4259        p
4260    fi
4261enddef ;
4262
4263permanent processpath ;
4264
4265% By Bogluslaw Jackowski (public domain):
4266%
4267% draw hatched (fullcircle scaled 10cm) (45, 4, 1) withcolor "red" ;
4268
4269newinternal hatch_match; hatch_match := 1;
4270
4271vardef hatched(expr o) primary c =
4272    save a_, b_, d_, l_, i_, r_, za_, zb_, zc_, zd_;
4273    path b_; picture r_; pair za_, zb_, zc_, zd_;
4274    r_ := image (
4275        a_ := redpart(c) mod 180 ;
4276        l_ := greenpart(c) ;
4277        d_ := -bluepart(c) ;
4278        b_ := o rotated -a_ ;
4279        b_ :=
4280            if a_ >= 90 :
4281                (lrcorner b_ -- llcorner b_ -- ulcorner b_ -- urcorner b_ -- cycle)
4282            else :
4283                (llcorner b_ -- lrcorner b_ -- urcorner b_ -- ulcorner b_ -- cycle)
4284            fi
4285            rotated a_ ;
4286        za_ := point 0 of b_ ;
4287        zb_ := point 1 of b_ ;
4288        zc_ := point 2 of b_ ;
4289        zd_ := point 3 of b_ ;
4290        if hatch_match > 0 :
4291            n_ := round(length(zd_-za_) / l_) ;
4292            if n_ < 2:
4293                n_ := 2 ;
4294            fi ;
4295            l_ := length(zd_-za_) / n_ ;
4296        else :
4297            n_ := length(zd_-za_) / l_ ;
4298        fi
4299        save currentpen; pen currentpen ; pickup pencircle scaled d_;
4300        % we use a single path instead:
4301        for i_ := if hatch_match > 0 : 1 else : 0 fi upto ceiling n_ - 1 :
4302            nodraw (i_/n_)[zd_,za_] -- (i_/n_)[zc_,zb_] ;
4303        endfor
4304        dodraw origin ;
4305    ) ;
4306    clip r_ to o;
4307    r_
4308enddef;
4309
4310permanent hatched ;
4311
4312% By Mikael Sundqvist, with a little evolution:
4313
4314numeric mfun_dash_on, mfun_dash_off ;
4315
4316% primarydef p withdashes len =
4317%     hide (
4318%         save l, t, n, m ; pair t ;
4319%         l := arclength p ;
4320%         t := paired(len) ;
4321%         m := xpart t + ypart t ;
4322%         n := l / (l div m) / m ;
4323%         mfun_dash_on  := n * xpart t ;
4324%         mfun_dash_off := n * ypart t ;
4325%     )
4326%     p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
4327% enddef ;
4328
4329primarydef p withdashes len =
4330    hide (
4331        save l, t, n, m, don, doff; pair t ;
4332        l := arclength p ;
4333        t := paired (len) ;
4334        m := xpart t + ypart t ;
4335        n := (l if not cycle p : - xpart t fi) div m ;
4336        (n if not cycle p : + 1 fi) * don + n * doff = l ;
4337        don*(ypart t) = doff*(xpart t) ;
4338        mfun_dash_on := don ;
4339        mfun_dash_off := doff ;
4340    )
4341    p dashed dashpattern (on mfun_dash_on off mfun_dash_off)
4342enddef ;
4343
4344permanent withdashes ;
4345
4346%D For Mikael:
4347
4348path mfun_b ;
4349pair mfun_k ;
4350
4351path mfun_nullpath ;
4352
4353tertiarydef p sortedintersectiontimes q =
4354    sortedpath (p intersectiontimeslist q)
4355enddef ;
4356
4357tertiarydef p intersectionpath q =
4358    begingroup ;
4359    save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4360    save mfun_k ; pair mfun_k ; mfun_k := point 0 of mfun_b;
4361    if mfun_k <> (-1,-1) :
4362        .5[point xpart mfun_k of p, point ypart mfun_k of q]
4363        for i = 1 upto length(mfun_b) : % use fast loop
4364            hide(mfun_k := point i of mfun_b;)
4365            -- .5[point xpart mfun_k of p, point ypart mfun_k of q]
4366        endfor
4367    else :
4368        mfun_nullpath
4369    fi
4370    endgroup
4371enddef ;
4372
4373tertiarydef p firstintersectionpath q =
4374    begingroup ;
4375    save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4376    if (point 0 of mfun_b) <> (-1,-1) :
4377        point xpart (point 0 of mfun_b) of p
4378        for i = 1 upto length(mfun_b) :
4379            -- point xpart (point i of mfun_b) of p
4380        endfor
4381    else :
4382        mfun_nullpath
4383    fi
4384    endgroup
4385enddef ;
4386
4387tertiarydef p secondintersectionpath q =
4388    q firstintersectionpath p
4389enddef;
4390
4391vardef intersectionsfound expr p =
4392    (point 0 of p) <> (-1,-1)
4393enddef ;
4394
4395permanent intersectionpath, sortedintersectiontimes,
4396    firstintersectionpath, secondintersectionpath, intersectionsfound ;
4397
4398%D As part of our intersection journey MS came up with:
4399
4400tertiarydef p cutbeforefirst q =
4401    begingroup ;
4402    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4403    if (point 0 of mfun_b) <> (-1,-1) :
4404        mfun_p := subpath(xpart point 0 of mfun_b, length p) of p;
4405    else :
4406        mfun_p := p ;
4407    fi ;
4408    mfun_p
4409    endgroup
4410enddef ;
4411
4412tertiarydef p cutafterfirst q =
4413    begingroup ;
4414    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4415    if (point 0 of mfun_b) <> (-1,-1) :
4416        mfun_p := subpath(0, xpart point 0 of mfun_b) of p;
4417    else :
4418        mfun_p := p ;
4419    fi ;
4420    mfun_p
4421    endgroup
4422enddef ;
4423
4424tertiarydef p cutbeforelast q =
4425    begingroup ;
4426    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4427    if (point 0 of mfun_b) <> (-1,-1) :
4428        mfun_p := subpath(xpart point (length mfun_b) of mfun_b, length p) of p;
4429    else :
4430        mfun_p := p ;
4431    fi ;
4432    mfun_p
4433    endgroup
4434enddef ;
4435
4436tertiarydef p cutafterlast q =
4437    begingroup ;
4438    save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ;
4439    if (point 0 of mfun_b) <> (-1,-1) :
4440        mfun_p := subpath(0, xpart point (length mfun_b) of mfun_b) of p;
4441    else :
4442        mfun_p := p ;
4443    fi ;
4444    mfun_p
4445    endgroup
4446enddef ;
4447
4448permanent cutbeforefirst, cutafterfirst, cutbeforelast, cutafterlast ;
4449
4450% And:
4451
4452vardef selfintersectiontimeslist expr p =
4453    save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist p) ;
4454    if (known mfun_b) and (length mfun_b > 0) :
4455        save b ; boolean b ; b := false ;
4456        save n ; numeric n ; n := length(p) ;
4457        for i within mfun_b :
4458             if     (xpart pathpoint = ypart pathpoint) :
4459             elseif (xpart pathpoint = n) and (ypart pathpoint = 0) :
4460             elseif (xpart pathpoint - ypart pathpoint < 0.1) :
4461             else :
4462                hide(b := true)
4463                pathpoint --
4464            fi
4465        endfor if b : nocycle else : mfun_nullpath fi
4466    else :
4467        mfun_nullpath
4468    fi
4469enddef ;
4470
4471permanent selfintersectiontimeslist ;
4472
4473% I don't want to define this path every time I make a demo:
4474
4475vardef starring(expr e) =
4476    save a, b, c, d ;
4477    pair a, b, c, d ;
4478    a := (-1,-1) ; b := ( 1,-1) ;
4479    c := ( 1, 1) ; d := (-1, 1) ;
4480    a -- (.5[a,b] shifted (0,-e)) --
4481    b -- (.5[b,c] shifted (e, 0)) --
4482    c -- (.5[c,d] shifted (0, e)) --
4483    d -- (.5[d,a] shifted (-e,0)) -- cycle
4484enddef ;
4485
4486vardef dashing (expr pth, shp, stp) =
4487    for i within arcpointlist stp of pth :
4488        shp
4489            rotated angle(pathdirection)
4490            shifted pathpoint
4491        &&
4492    endfor nocycle
4493enddef ;
4494
4495permanent starring, dashing ;
4496
4497% like center, mod and div this is a candidate for a primitive
4498
4499% vardef centerofmass primary p =
4500%     (origin for i within p : + pathpoint endfor) / length(p)
4501% enddef ;
4502
4503numeric mfun_arc_factor ; mfun_arc_factor := 8/360 ;
4504
4505vardef arc(expr from_angle, to_angle) =
4506    (subpath (0,mfun_arc_factor*(to_angle-from_angle)) of fullcircle)
4507    rotated from_angle
4508enddef ;
4509
4510% draw ( 0,0) -- (arc(  0,180) scaled 10 shifted ( 0,10)) -- cycle ;
4511% draw (15,0) -- (arc(180, 40) scaled 10 shifted (15,10)) -- cycle ;
4512
4513%D This macro is part of our (MS & HH) envelope exploration and it's probably the macro that
4514%D took most time to get right, but it is rewarding. It took us quite some tests with various
4515%D paths and pens to get it right. We tried several strategies and eventually got there. It's
4516%D not always fast but the results can be rewarding. And yes, we have much fun figuring it
4517%D out (a lot of chatting).
4518
4519primarydef a crossprod b =
4520    (xpart a * ypart b) - (ypart a * xpart b)
4521enddef;
4522
4523permanent crossprod ;
4524
4525newinternal scrutinizing ; scrutinizing := 3 ;
4526newinternal curvarturetolerance ; curvarturetolerance := 5eps ;
4527newinternal boolean tracereducedpath ; tracereducedpath := false ;
4528
4529vardef hasreducedcurvature(expr p,i,tolerance) =
4530    save ldir, mdir, rdir ; pair ldir, mdir, rdir ;
4531    ldir := unitvector(direction i + 10eps of p) ;
4532    mdir := unitvector(direction i + 1/2 of p) ;
4533    rdir := unitvector(direction i + 1 - 10eps of p) ;
4534    not (
4535        ((ldir dotprod mdir) > 1 - tolerance)
4536        and
4537        ((mdir dotprod rdir) > 1 - tolerance)
4538    )
4539enddef ;
4540
4541vardef reducedpath(expr target) =
4542    save result ; path result ;
4543    save iproduct, oldlength, newlength ;
4544    result := target scrutinized 1 ; % needs to be large for starring on circle
4545    newlength := length(result) ;
4546    if tracereducedpath : message("reducedpath: start main loop") ; fi
4547    forever:
4548        if tracereducedpath : message("  start inner loop") ; fi
4549        oldlength := newlength ;
4550        if tracereducedpath : message("  length of path is " & decimal oldlength) ; fi
4551        for i = 1 upto oldlength :
4552            if tracereducedpath : message("  iteration " & decimal(i)) ; fi
4553            if hasreducedcurvature(result, i - 1, curvarturetolerance) or
4554               hasreducedcurvature(result, i, curvarturetolerance) :
4555                if tracereducedpath : message("  not two lines, skipping") ; fi
4556            else :
4557                if tracereducedpath : message("  two lines, checking") ; fi
4558                iproduct :=
4559                    unitvector (point i of result - point (i - 1) of result)
4560                    dotprod
4561                    unitvector (point (i + 1) of result - point i of result) ;
4562                if iproduct > 1 - eps :
4563                    if tracereducedpath : message("  parallel and same direction, replacing 0->1->2 by 0--2") ; fi
4564                    result :=
4565                        if i > 1 : (subpath(0,i - 1) of result) && fi
4566                        if i < oldlength - 1 :
4567                          (point i - 1 of result -- point i + 1 of result) &&
4568                          (subpath(i + 1,oldlength) of result) &&
4569                        fi
4570                        if cycle result : cycle fi;
4571                    break
4572                elseif iproduct < -1 + eps :
4573                    if tracereducedpath : message("  parallel but opposite, more testing needed") ; fi
4574                    if not hasreducedcurvature(result, i + 1, curvarturetolerance) :
4575                        if tracereducedpath : message("  the next segment is straight") ; fi
4576                        iproduct :=
4577                            unitvector( point (i + 2) of result - point (i + 1) of result)
4578                            dotprod
4579                            unitvector( point (i + 1) of result - point i of result) ;
4580                        if (iproduct < 1 - eps) and (iproduct > -1 + eps) :
4581                            if tracereducedpath : message("  the next segment is not parallel to the previous, skipping") ; fi
4582                        elseif iproduct > 1 - eps :
4583                            if tracereducedpath : message("   the points are in order 0321, 3021 or 3201 while in all cases we need 0->1->3") ; fi
4584                            result :=
4585                                (subpath(0,i) of result)
4586                                && (point i of result -- point i + 2 of result)
4587                                && (subpath(i + 2,oldlength) of result)
4588                                if cycle result : && cycle fi;
4589                            break
4590                        else :
4591                            if tracereducedpath : message("  points are in order 0231, 0213, 2031 or 2013") ; fi
4592                            if (abs(point (i + 1) of result - point i of result)
4593                                >
4594                                abs(point (i + 2) of result - point (i + 1) of result)) :
4595                                if tracereducedpath : message("  we have case 0231 or 2031") ; fi
4596                                if (abs(point (i + 1) of result - point i of result)
4597                                    >
4598                                    abs(point i of result - point (i - 1) of result)) :
4599                                    if tracereducedpath : message("  we are in case 2031, quitting") ; fi
4600                                else :
4601                                    if tracereducedpath : message("  we are in case 0231 but need 0 -> 1 -> 3") ; fi
4602                                    result :=
4603                                        (subpath(0,i) of result)
4604                                        && (point i of result -- point i + 2 of result)
4605                                        && (subpath(i + 2,oldlength) of result)
4606                                        if cycle result : && cycle fi;
4607                                    break
4608                                fi
4609                            else :
4610                                if tracereducedpath : message("  we are in case 0213 or 2013") ; fi
4611                                if (abs(point (i + 2) of result - point (i - 1) of result)
4612                                    >
4613                                    abs(point (i + 2) of result - point (i + 1) of result)) :
4614                                    if tracereducedpath : message("  we are in 0213, replace by 0 -> 3") ; fi
4615                                    result :=
4616                                        (subpath(0,i - 1) of result)
4617                                        && (point (i - 1) of result -- point (i + 2) of result)
4618                                        && (subpath(i + 2,oldlength) of result)
4619                                        if cycle result : && cycle fi;
4620                                    break
4621                                else :
4622                                    if tracereducedpath : message("  we are in 2013, replace by 0 -> 2 -> 3") ; fi
4623                                    result :=
4624                                        (subpath(0,i - 1) of result)
4625                                        && (point (i - 1) of result -- point (i + 1) of result)
4626                                        && (subpath(i + 1,oldlength) of result)
4627                                        if cycle result : && cycle fi;
4628                                    break
4629                                fi
4630                            fi
4631                        fi
4632                    fi
4633                else :
4634                    if tracereducedpath : message ("  next iteration") ; fi
4635                fi
4636            fi
4637            if tracereducedpath : message ("  next step") ; fi
4638        endfor
4639        result := result scrutinized scrutinizing ;
4640        newlength := length(result) ;
4641        exitif newlength >= oldlength ;
4642    endfor
4643    if tracereducedpath : message ("reducedpath: done") ; fi
4644    result
4645enddef ;
4646
4647newinternal envelopeprecision ; envelopeprecision := 2 ;
4648
4649vardef reducedenvelope(expr target) =
4650    save original, tmppath, tmppaths ; path original, tmppath, tmppaths[] ;
4651    save curi, n, l, iproduct, vproduct ; numeric curi, n, l, iproduct, vproduct ;
4652    original := reducedpath(target) ;
4653    % drawpoints original withpen pencircle scaled 7 withcolor "orange" ;
4654    % drawpointlabels original shifted (0,5) withcolor "orange" ;
4655    l := length(original) ;
4656    curi := 0 ;
4657    n := 0 ;
4658    for i = 0 upto (l + 1) :
4659        if not hasreducedcurvature(original, i, curvarturetolerance) :
4660            % message("Are we here?" & decimal(i)) ;
4661            iproduct := (unitvector (point i + 1 of original - point i of original))
4662                        dotprod
4663                        (unitvector (point i of original - precontrol i of original)) ;
4664            if (i > 0) and (not hasreducedcurvature(original, i - 1, curvarturetolerance)) :
4665                vproduct := (unitvector (point i of original - point (i - 1) of original))
4666                            crossprod
4667                            (unitvector (point (i + 1) of original - point i of original)) ;
4668                % message("i vproduct iproduct = " & dddecimal(i,vproduct,iproduct)) ;
4669                if (vproduct > -eps) and (iproduct < 0) : % -1 + eps :
4670                    tmppath := subpath(curi,i) of original ;
4671                    % sanity check :
4672                    if length(tmppath scrutinized scrutinizing) <> 0 :
4673                        n := n + 1 ;
4674                        tmppaths[n] := tmppath ;
4675                        curi := i + 1 ;
4676                    fi
4677                fi
4678            else :
4679                % message("i and iproduct = " & ddecimal(i,iproduct));
4680                if (iproduct < 0) or (i == 0) : % -1 + eps :
4681                    % message("We are here, and i is " & decimal(i)) ;
4682                    tmppath := subpath(curi,i) of original ;
4683                    % sanity check :
4684                    if length(tmppath scrutinized scrutinizing) <> 0 :
4685                        n := n + 1 ;
4686                        tmppaths[n] := tmppath ;
4687                        curi := i + 1 ;
4688                    fi
4689                fi
4690            fi
4691        fi
4692    endfor
4693    % message("l n curi = " & dddecimal(l,n,curi)) ;
4694    if curi < l :
4695        n := n + 1 ;
4696        tmppaths[n] := subpath(curi,l) of original ;
4697    fi
4698    % message("l n = ",ddecimal(l,n)) ;
4699    interim intersectionprecision := 2 ;
4700    if n = 0 :
4701        original
4702    elseif n = 1 :
4703        tmppaths[1] && cycle
4704    elseif n = 2 :
4705        (tmppaths[1] cutafterlast tmppaths[2]) &&
4706        (tmppaths[2] cutbeforefirst tmppaths[1]) && cycle % can use intersectiontimes
4707    else :
4708        save s ; numeric s ; % start
4709        if (abs(point length(tmppaths[1]) of tmppaths[1] - point length(tmppaths[n]) of tmppaths[n]) < eps) :
4710            s := 2 ;
4711        else :
4712            s := 1 ;
4713        fi
4714        intersectionprecision := envelopeprecision ;
4715        for i = s upto (n - 1) :
4716          % tmppath := tmppaths[i] intersectiontimeslist tmppaths[i + 1] ;
4717          % if (point 0 of tmppath) = (-1,-1) :
4718            if (tmppaths[i] intersectiontimes tmppaths[i + 1]) = (-1,-1) :
4719                tmppaths[i] := tmppaths[i] -- point 0 of tmppaths[i + 1];
4720            fi
4721            tmppath     := tmppaths[i] ;
4722            tmppaths[i] := tmppath cutafterfirst tmppaths[i + 1] ; % can use intersectiontimes
4723            tmppaths[i + 1] := tmppaths[i + 1] cutbeforefirst tmppath ; % can use intersectiontimes
4724        endfor
4725      % tmppath := tmppaths[n] intersectiontimeslist tmppaths[s] ;
4726      % if (point 0 of tmppath) = (-1,-1) :
4727        if (tmppaths[n] intersectiontimes tmppaths[s]) = (-1,-1) :
4728            tmppaths[n] := tmppaths[n] -- point 0 of tmppaths[s];
4729        fi
4730        intersectionprecision := 2 ;
4731        tmppath   := tmppaths[n] ;
4732        tmppaths[n] := tmppath cutafterfirst tmppaths[s] ; % can use intersectiontimes
4733        tmppaths[s] := tmppaths[s] cutbeforelast tmppath ;
4734
4735        if true : % so we can disable when testing
4736
4737            intersectionprecision := envelopeprecision ;
4738
4739            % Here we remove funny pieces that were not see in a previous pass. These
4740            % are likely to show up on paths with tight bends and complex pens. Here We
4741            % check for self intersecting.
4742
4743            save i ; numeric i ;
4744            save a ; pair a ;
4745
4746            tmppath := for i = s upto n :
4747                tmppaths[i] if i < n: &&& else : -- fi
4748            endfor cycle ;
4749
4750            l := length(tmppath) ;
4751            n := 0 ;
4752            curi := 0 ;
4753            i := 0 ;
4754
4755            forever :
4756                a := subpath(i,i + 1 - eps) of tmppath intersectiontimes subpath(i + 1,l - eps) of tmppath;
4757                if xpart a > 0 :
4758                    n := n + 1 ;
4759                    tmppaths[n] := subpath(curi,i + xpart a) of tmppath ;
4760                    curi := i + 1 + ypart a ;
4761                    i := floor(curi) ;
4762                else :
4763                    i := i + 1 ;
4764                fi
4765                exitif i >= l ;
4766            endfor
4767            n := n + 1 ;
4768            tmppaths[n] := subpath(curi,l) of tmppath ;
4769        fi
4770
4771        for i = 1 upto n :
4772            tmppaths[i] if i < n: &&& else : -- fi
4773        endfor cycle
4774    fi
4775enddef ;
4776
4777primarydef p enveloped q =
4778    reducedenvelope(envelope q of p)
4779enddef ;
4780
4781permanent hasreducedcurvature, reducedpath, reducedenvelope, enveloped ;
4782
4783% This is a new one, and for now we keep it small:
4784
4785jointolerance := 2eps ;
4786
4787vardef mfun_total_area_step(expr p, c, cc, pp) =
4788  (p  crossprod pp)     / 20 +
4789  (p  crossprod  c) * 3 / 10 +
4790  (p  crossprod cc) * 3 / 20 +
4791  (c  crossprod cc) * 3 / 20 +
4792  (c  crossprod pp) * 3 / 20 +
4793  (cc crossprod pp) * 6 / 20
4794enddef ;
4795
4796vardef totalarea(expr p) =
4797    0 for i within p :
4798        + mfun_total_area_step(pathpoint,pathpostcontrol,deltaprecontrol 1,deltapoint 1)
4799    endfor
4800enddef ;
4801
4802permanent totalarea ;
4803
4804% Here we emulate penstroke but with a plugin:
4805
4806% path p ; p := fullcircle xyscaled (100,70) ;
4807% path s ; s := nepstroke (1000) (.25 + uniformdeviate(5)) ;
4808% path t ; t := nepstroke (100) .25sin(10*pi*strokestep/strokesteps) ;
4809% picture c ; c := lmt_outline [text = "CMS", kind = "path" ] ;
4810% c := c shifted -center c ;
4811% fill p penstroked s withcolor darkblue ;
4812% for i within c :
4813%     fill ((pathpart i) penstroked t) scaled 3
4814%         withpen pencircle scaled 3
4815%         withcolor darkred
4816%     ;
4817% endfor ;
4818
4819tertiarydef p penstroked s =
4820    begingroup
4821    interim defaultzeroangle := 0;
4822    save N ; numeric N ; N := length s ;
4823    save pp ; path pp ; pp := arcpointlist N of p ;
4824    save pl ; path pl ; pl := for i within pp :
4825        pathpoint shifted ((ypart point i of s,0) rotated (angle(pathdirection) + 90)) ..
4826    endfor nocycle ;
4827    save pr ; path pr ; pr := for i within pp :
4828        pathpoint shifted ((ypart point i of s,0) rotated (angle(pathdirection) - 90)) ..
4829    endfor nocycle ;
4830  % pl -- reverse pr -- cycle
4831    if cycle p :
4832      (pl -- cycle) && (reverse pr -- cycle) && cycle
4833    else :
4834      pl -- reverse pr -- cycle
4835    fi
4836    endgroup
4837enddef;
4838
4839vardef nepstroke (expr N) text F =
4840    save strokesteps ; numeric strokesteps ; strokesteps := N ;
4841    for strokestep = 0 upto strokesteps : (strokestep,F) -- endfor nocycle
4842enddef ;
4843
4844permanent penstroked, nepstroke ;
4845