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