SourceBrowser

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