Source Browser ?

1%D \module
2%D   [       file=mp-mlib.mpiv,
3%D        version=2008.03.21,
4%D          title=\CONTEXT\ \METAPOST\ graphics,
5%D       subtitle=plugins,
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 licen-en.pdf for
12%C details.
13
14if known metafun_loaded_mlib : endinput ; fi ;
15
16newinternal boolean metafun_loaded_mlib ; metafun_loaded_mlib := true ; immutable metafun_loaded_mlib ;
17
18% numeric LUATEXFUNCTIONALITY ; LUATEXFUNCTIONALITY := runscript("mp.print(LUATEXFUNCTIONALITY or (status and status.development_id) or 6346)") ;
19
20%D Color and transparency
21%D
22%D Separable:
23
24newinternal normaltransparent     ; normaltransparent     :=  1 ;
25newinternal multiplytransparent   ; multiplytransparent   :=  2 ;
26newinternal screentransparent     ; screentransparent     :=  3 ;
27newinternal overlaytransparent    ; overlaytransparent    :=  4 ;
28newinternal softlighttransparent  ; softlighttransparent  :=  5 ;
29newinternal hardlighttransparent  ; hardlighttransparent  :=  6 ;
30newinternal colordodgetransparent ; colordodgetransparent :=  7 ;
31newinternal colorburntransparent  ; colorburntransparent  :=  8 ;
32newinternal darkentransparent     ; darkentransparent     :=  9 ;
33newinternal lightentransparent    ; lightentransparent    := 10 ;
34newinternal differencetransparent ; differencetransparent := 11 ;
35newinternal exclusiontransparent  ; exclusiontransparent  := 12 ;
36
37%D Nonseparable:
38
39newinternal huetransparent        ; huetransparent        := 13 ;
40newinternal saturationtransparent ; saturationtransparent := 14 ;
41newinternal colortransparent      ; colortransparent      := 15 ;
42newinternal luminositytransparent ; luminositytransparent := 16 ;
43
44permanent normaltransparent, multiplytransparent, screentransparent, overlaytransparent,
45    softlighttransparent, hardlighttransparent, colordodgetransparent, colorburntransparent,
46    darkentransparent, lightentransparent, differencetransparent, exclusiontransparent,
47    huetransparent, saturationtransparent, colortransparent, luminositytransparent ;
48
49vardef transparency_alternative_to_number(expr name) =
50    if string name :
51        if expandafter known scantokens(name & "transparent") :
52            scantokens(name & "transparent")
53        else :
54            0
55        fi
56    elseif name < 17 :
57        name
58    else :
59        0
60    fi
61enddef ;
62
63def namedcolor expr n =
64    (1)
65    withnestedprescript "sp_type=named"
66    withnestedprescript "sp_name=" & n
67enddef ;
68
69% def mfun_spotcolor(expr n, v) =
70%     1
71%     withnestedprescript "sp_type=xspot"
72%     withnestedprescript "sp_name="  & n
73%     withnestedprescript "sp_value=" & (if numeric v : decimal v else : v fi)
74% enddef ;
75
76% def mfun_multispotcolor(expr name, fractions, components, value) =
77%     1
78%     withnestedprescript "sp_type=multispot"
79%     withnestedprescript "sp_name="       & name
80%     withnestedprescript "sp_fractions="  & decimal fractions
81%     withnestedprescript "sp_components=" & components
82%     withnestedprescript "sp_value="      & value
83% enddef ;
84
85def spotcolor(expr name, v) =
86    (1)
87    withnestedprescript "sp_type=spot"
88    withnestedprescript "sp_name=" & name
89    withnestedprescript "sp_value=" & colordecimals v
90enddef ;
91
92% In this case a mixed color will be calculated:
93
94def multitonecolor(expr name)(text t) =
95    (1)
96    withnestedprescript "sp_type=multitone"
97    withnestedprescript "sp_name=" & name
98    withnestedprescript "sp_value=" & colordecimalslist(t)
99enddef ;
100
101def transparent(expr a, t)(text c) = % use withtransparency instead
102    (1) % this permits withcolor x intoshade y
103    withnestedprescript "tr_alternative=" & decimal transparency_alternative_to_number(a)
104    withnestedprescript "tr_transparency=" & decimal t
105    withcolor c
106enddef ;
107
108def withtransparency(expr a, t) =
109    withnestedprescript "tr_alternative="  & decimal transparency_alternative_to_number(a)
110    withnestedprescript "tr_transparency=" & decimal t
111enddef ;
112
113% for svg:
114
115def withopacity expr o =
116    if o <> 1 :
117        withnestedprescript "tr_alternative="  & decimal normaltransparent
118        withnestedprescript "tr_transparency=" & decimal o
119    fi
120enddef ;
121
122% Provided for downward compability:
123
124def cmyk(expr c, m, y, k) =
125    (c,m,y,k)
126enddef ;
127
128permanent spotcolor, multitonecolor, transparent, withtransparency, namedcolor, withopacity, cmyk ;
129
130% Texts (todo: better strut ratio, now .7 hardcoded, should be passed)
131
132newinternal textextoffset ; textextoffset := 0 ;
133
134permanent textextoffset ;
135
136rgbcolor mfun_tt_r ;
137numeric  mfun_tt_n ; mfun_tt_n := 0 ;
138picture  mfun_tt_p ; mfun_tt_p := nullpicture ;
139picture  mfun_tt_o ; mfun_tt_o := nullpicture ;
140picture  mfun_tt_c ; mfun_tt_c := nullpicture ;
141
142if unknown mfun_trial_run :
143    boolean mfun_trial_run ;
144    mfun_trial_run := false ;
145else :
146    % already defined before the format is loaded
147fi ;
148
149def mfun_reset_tex_texts =
150    mfun_tt_n := 0 ;
151    mfun_tt_p := nullpicture ;
152    mfun_tt_o := nullpicture ; % redundant
153    mfun_tt_c := nullpicture ; % redundant
154enddef ;
155
156def mfun_flush_tex_texts =
157    addto currentpicture also mfun_tt_p
158enddef ;
159
160extra_endfig   := "mfun_flush_tex_texts ;" & extra_endfig ;
161extra_beginfig := extra_beginfig & "mfun_reset_tex_texts ;" ;
162
163% We collect and flush them all, as we can also have temporary textexts
164% that gets never really flushed but are used for calculations. So, we
165% flush twice: once in location in order to pick up e.g. color properties,
166% and once at the end because we need to flush missing ones.
167
168boolean mfun_onetime_textext ; mfun_onetime_textext := false ;
169numeric mfun_global_textext ; mfun_global_textext := 0 ;
170
171def keepcached =
172    hide(mfun_global_textext := mfun_global_textext + 1;)
173    withprescript ("tx_cache=" & decimal mfun_global_textext)
174enddef ;
175
176def notcached =
177    withprescript "tx_cache=no"
178enddef ;
179
180permanent keepcached, notcached ;
181
182% todo: onetime
183
184rgbcolor mfun_tt_r ;
185
186newinternal inicatcoderegime ; inicatcoderegime := runscript("return catcodes.numbers.ctxcatcodes") ;
187newinternal texcatcoderegime ; texcatcoderegime := runscript("return catcodes.numbers.texcatcodes") ;
188newinternal luacatcoderegime ; luacatcoderegime := runscript("return catcodes.numbers.luacatcodes") ;
189newinternal notcatcoderegime ; notcatcoderegime := runscript("return catcodes.numbers.notcatcodes") ;
190newinternal vrbcatcoderegime ; vrbcatcoderegime := runscript("return catcodes.numbers.vrbcatcodes") ;
191newinternal prtcatcoderegime ; prtcatcoderegime := runscript("return catcodes.numbers.prtcatcodes") ;
192newinternal ctxcatcoderegime ; ctxcatcoderegime := runscript("return catcodes.numbers.ctxcatcodes") ;
193newinternal txtcatcoderegime ; txtcatcoderegime := runscript("return catcodes.numbers.txtcatcodes") ;
194
195newinternal catcoderegime    ; catcoderegime    := ctxcatcoderegime ;
196
197immutable inicatcoderegime, texcatcoderegime, luacatcoderegime, notcatcoderegime,
198    vrbcatcoderegime, prtcatcoderegime, ctxcatcoderegime, txtcatcoderegime ;
199
200permanent catcoderegime ;
201
202newscriptindex mfid_sometextext   ; mfid_sometextext   := scriptindex "sometextext" ;
203newscriptindex mfid_madetextext   ; mfid_madetextext   := scriptindex "madetextext" ;
204newscriptindex mfid_boxdimensions ; mfid_boxdimensions := scriptindex "boxdimensions" ;
205
206vardef rawtextext(expr s) =
207    if s = "" :
208        nullpicture
209    else :
210        mfun_tt_n := mfun_tt_n + 1 ;
211        mfun_tt_c := nullpicture ;
212        mfun_tt_o := nullpicture ;
213        addto mfun_tt_o doublepath origin base_draw_options ;
214        mfun_tt_r := runscript mfid_sometextext mfun_tt_n s catcoderegime ;
215        addto mfun_tt_c doublepath unitsquare
216            xscaled wdpart mfun_tt_r
217            yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
218            shifted (0,-dppart mfun_tt_r)
219            withprescript "mf_object=text"
220            withprescript "tx_index=" & decimal mfun_tt_n
221            withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
222        ;
223        mfun_tt_c
224    fi
225enddef ;
226
227vardef rawmadetext =
228    mfun_tt_n := mfun_tt_n + 1 ;
229    mfun_tt_c := nullpicture ;
230    mfun_tt_o := nullpicture ;
231    addto mfun_tt_o doublepath origin base_draw_options ;
232    mfun_tt_r := runscript mfid_madetextext mfun_tt_n ;
233    addto mfun_tt_c doublepath unitsquare
234        xscaled wdpart mfun_tt_r
235        yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
236        shifted (0,-dppart mfun_tt_r)
237        withprescript "mf_object=text"
238        withprescript "tx_index=" & decimal mfun_tt_n
239        withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
240    ;
241    mfun_tt_c
242enddef ;
243
244% \setbox\scratchbox\hbox{!!!!!!!!!!!!!}
245% \putboxincache{one}{a}\scratchbox
246% \startMPcode draw rawtexbox("one","a") ; \stopMPcode
247
248vardef validtexbox(expr category, name) =
249    if category == "" :
250        false
251    elseif string name :
252        name <> ""
253    elseif numeric name :
254        name > 0
255    else :
256        true
257    fi
258enddef ;
259
260vardef rawtexbox(expr category, name) =
261    mfun_tt_c := nullpicture ;
262    if validtexbox(category,name) :
263      % mfun_tt_r := lua.mp.mf_tb_dimensions(category, name) ;
264        mfun_tt_r := runscript mfid_boxdimensions category name ;
265        addto mfun_tt_c doublepath unitsquare
266            xscaled wdpart mfun_tt_r
267            yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
268            shifted (0,- dppart mfun_tt_r)
269            withprescript "mf_object=box"
270            withprescript "bx_category=" & if numeric category : decimal fi category
271            withprescript "bx_name=" & if numeric name : decimal fi name ;
272    fi
273    mfun_tt_c
274enddef ;
275
276% More text
277
278defaultfont  := "Mono" ;
279defaultscale := 1 ;
280
281extra_beginfig := extra_beginfig & "defaultscale:=1;" ;
282
283vardef fontsize expr name =
284    save size ; numeric size ;
285    size := bbwidth(textext("\MPfontsizehskip{" & name & "}")) ;
286    if size = 0 :
287        12pt
288    else :
289        size
290    fi
291enddef ;
292
293permanent fontsize ;
294
295pair mfun_laboff        ; mfun_laboff        := origin   ;
296pair mfun_laboff.lft    ; mfun_laboff.lft    := (-1,0)   ;
297pair mfun_laboff.rt     ; mfun_laboff.rt     := (1,0)    ;
298pair mfun_laboff.bot    ; mfun_laboff.bot    := (0,-1)   ;
299pair mfun_laboff.top    ; mfun_laboff.top    := (0,1)    ;
300pair mfun_laboff.ulft   ; mfun_laboff.ulft   := (-.7,.7) ;
301pair mfun_laboff.urt    ; mfun_laboff.urt    := (.7,.7)  ;
302pair mfun_laboff.llft   ; mfun_laboff.llft   := -(.7,.7) ;
303pair mfun_laboff.lrt    ; mfun_laboff.lrt    := (.7,-.7) ;
304
305pair mfun_laboff.d      ; mfun_laboff.d      := mfun_laboff     ;
306pair mfun_laboff.dlft   ; mfun_laboff.dlft   := mfun_laboff.lft ;
307pair mfun_laboff.drt    ; mfun_laboff.drt    := mfun_laboff.rt  ;
308pair mfun_laboff.origin ; mfun_laboff.origin := mfun_laboff     ;
309pair mfun_laboff.raw    ; mfun_laboff.raw    := mfun_laboff     ;
310
311pair mfun_laboff.l      ; mfun_laboff.l      := mfun_laboff.lft  ;
312pair mfun_laboff.r      ; mfun_laboff.r      := mfun_laboff.rt   ;
313pair mfun_laboff.b      ; mfun_laboff.b      := mfun_laboff.bot  ;
314pair mfun_laboff.t      ; mfun_laboff.t      := mfun_laboff.top  ;
315pair mfun_laboff.l_t    ; mfun_laboff.l_t    := mfun_laboff.ulft ;
316pair mfun_laboff.r_t    ; mfun_laboff.r_t    := mfun_laboff.urt  ;
317pair mfun_laboff.l_b    ; mfun_laboff.l_b    := mfun_laboff.llft ;
318pair mfun_laboff.r_b    ; mfun_laboff.r_b    := mfun_laboff.lrt  ;
319pair mfun_laboff.t_l    ; mfun_laboff.t_l    := mfun_laboff.ulft ;
320pair mfun_laboff.t_r    ; mfun_laboff.t_r    := mfun_laboff.urt  ;
321pair mfun_laboff.b_l    ; mfun_laboff.b_l    := mfun_laboff.llft ;
322pair mfun_laboff.b_r    ; mfun_laboff.b_r    := mfun_laboff.lrt  ;
323
324mfun_labxf                                              := 0.5 ;
325mfun_labxf.lft      := mfun_labxf.l                     := 1   ;
326mfun_labxf.rt       := mfun_labxf.r                     := 0   ;
327mfun_labxf.bot      := mfun_labxf.b                     := 0.5 ;
328mfun_labxf.top      := mfun_labxf.t                     := 0.5 ;
329mfun_labxf.ulft     := mfun_labxf.l_t := mfun_labxf.t_l := 1   ;
330mfun_labxf.urt      := mfun_labxf.r_t := mfun_labxf.t_r := 0   ;
331mfun_labxf.llft     := mfun_labxf.l_b := mfun_labxf.b_l := 1   ;
332mfun_labxf.lrt      := mfun_labxf.r_b := mfun_labxf.b_r := 0   ;
333
334mfun_labxf.d        := mfun_labxf     ;
335mfun_labxf.dlft     := mfun_labxf.lft ;
336mfun_labxf.drt      := mfun_labxf.rt  ;
337mfun_labxf.origin   := 0              ;
338mfun_labxf.raw      := 0              ;
339
340mfun_labyf                                              := 0.5 ;
341mfun_labyf.lft      := mfun_labyf.l                     := 0.5 ;
342mfun_labyf.rt       := mfun_labyf.r                     := 0.5 ;
343mfun_labyf.bot      := mfun_labyf.b                     := 1   ;
344mfun_labyf.top      := mfun_labyf.t                     := 0   ;
345mfun_labyf.ulft     := mfun_labyf.l_t := mfun_labyf.t_l := 0   ;
346mfun_labyf.urt      := mfun_labyf.r_t := mfun_labyf.t_r := 0   ;
347mfun_labyf.llft     := mfun_labyf.l_b := mfun_labyf.b_l := 1   ;
348mfun_labyf.lrt      := mfun_labyf.r_b := mfun_labyf.b_r := 1   ;
349
350mfun_labyf.d        := mfun_labyf     ;
351mfun_labyf.dlft     := mfun_labyf.lft ;
352mfun_labyf.drt      := mfun_labyf.rt  ;
353mfun_labyf.origin   := 0              ;
354mfun_labyf.raw      := 0              ;
355
356mfun_labtype                                                 :=  0 ;
357mfun_labtype.lft    := mfun_labtype.l                        :=  1 ;
358mfun_labtype.rt     := mfun_labtype.r                        :=  2 ;
359mfun_labtype.bot    := mfun_labtype.b                        :=  3 ;
360mfun_labtype.top    := mfun_labtype.t                        :=  4 ;
361mfun_labtype.ulft   := mfun_labtype.l_t :=  mfun_labtype.t_l :=  5 ;
362mfun_labtype.urt    := mfun_labtype.r_t :=  mfun_labtype.t_r :=  6 ;
363mfun_labtype.llft   := mfun_labtype.l_b :=  mfun_labtype.b_l :=  7 ;
364mfun_labtype.lrt    := mfun_labtype.r_b :=  mfun_labtype.b_r :=  8 ;
365mfun_labtype.d                                               := 10 ;
366mfun_labtype.dlft                                            := 11 ;
367mfun_labtype.drt                                             := 12 ;
368mfun_labtype.origin                                          :=  0 ;
369mfun_labtype.raw                                             :=  0 ;
370
371vardef installlabel@# (expr type, x, y, offset) =
372    numeric mfun_labtype@# ; mfun_labtype@# := type ;
373    pair    mfun_laboff @# ; mfun_laboff @# := offset ;
374    numeric mfun_labxf  @# ; mfun_labxf  @# := x ;
375    numeric mfun_labyf  @# ; mfun_labyf  @# := y ;
376enddef ;
377
378permanent installlabel ;
379
380installlabel.center (0, 0.5, 0.5, (0,0)) ;
381installlabel.c      (0, 0.5, 0.5, (0,0)) ;
382
383installlabel.hcenter(0, 0.5, 0.5, (1,0)) ;
384installlabel.h      (0, 0.5, 0.5, (1,0)) ;
385
386installlabel.vcenter(0, 0.5, 0.5, (0,1)) ;
387installlabel.v      (0, 0.5, 0.5, (0,1)) ;
388
389vardef mfun_labshift@#(expr p) =
390    (mfun_labxf@#*lrcorner p +
391     mfun_labyf@#*ulcorner p +
392     (1-mfun_labxf@#-mfun_labyf@#)*llcorner p)
393enddef ;
394
395vardef mfun_picshift@#(expr p) =
396    (mfun_labxf@#*ulcorner p +
397     mfun_labyf@#*lrcorner p +
398     (1-mfun_labxf@#-mfun_labyf@#)*urcorner p)
399enddef ;
400
401% we save the plain variant
402
403% vardef plain_thelabel@#(expr p,z) =
404%     if string p :
405%         plain_thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
406%     else :
407%         p shifted (z + labeloffset*laboff@# - mfun_labshift@#(p))
408%     fi
409% enddef;
410%
411% def plain_label = % takes two arguments, contrary to textext that takes one
412%     normaldraw plain_thelabel
413% enddef ;
414%
415% let mfun_label    = label ;
416% let mfun_thelabel = thelabel ;
417%
418% def useplainlabels = % somehow let doesn't work for all code
419%     def label    = plain_label    enddef ;
420%     def thelabel = plain_thelabel enddef ;
421% enddef ;
422%
423% def usemetafunlabels =
424%     let label    = mfun_label ;
425%     let thelabel = mfun_thelabel ;
426% enddef ;
427%
428% plain_compatibility_data := plain_compatibility_data & "save label, thelabel ;" & "useplainlabels ;" ;
429
430newinternal anchortextexts ; anchortextexts := 0 ; % disabled by default
431
432vardef thetextext@#(expr p,z) =
433  % interim labeloffset := textextoffset ;
434    if string p :
435        thetextext@#(rawtextext(p),z)
436    elseif numeric p :
437        thetextext@#(rawtextext(decimal p),z)
438    elseif pair p :
439        thetextext@#(rawtextext(ddecimal p),z)
440    else :
441        if anchortextexts > 0 :
442            image(draw p withprescript "tx_anchor=" & ddecimal z)
443        else :
444            p
445        fi
446        if (mfun_labtype@# >= 10) :
447            shifted (0,ypart center p)
448        fi
449        shifted (z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
450    fi
451enddef ;
452
453vardef textext@#(expr p) = % no draw here
454    thetextext@#(p,origin)
455enddef ;
456
457vardef onetimetextext@#(expr p) = % no draw here
458    mfun_onetime_textext := true ;
459    thetextext@#(p,origin)
460enddef ;
461
462permanent rawtextext, rawmadetext, validtexbox, rawtexbox, thetextext, textext, onetimetextext ;
463
464% formatted text
465
466pair mfun_tt_z ;
467
468vardef rawfmttext(text t) =
469    mfun_tt_n := mfun_tt_n + 1 ;
470    mfun_tt_c := nullpicture ;
471    mfun_tt_o := nullpicture ;
472    addto mfun_tt_o doublepath origin base_draw_options ;
473    mfun_tt_r := lua.mp.mf_formatted_text(mfun_tt_n,t) ;
474    addto mfun_tt_c doublepath unitsquare
475        xscaled wdpart mfun_tt_r
476        yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
477        shifted (0,-dppart mfun_tt_r)
478        withprescript "mf_object=text"
479        withprescript "tx_index=" & decimal mfun_tt_n
480        withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
481    ;
482    for s = t :
483        if pair s : mfun_tt_z := s ; fi
484    endfor ;
485    mfun_tt_c
486enddef ;
487
488vardef thefmttext@#(text t) =
489    mfun_tt_z := origin ; % initialization
490    save p ; picture p ; p := rawfmttext(t) ;
491    if anchortextexts > 0 :
492        image(draw p withprescript "tx_anchor=" & ddecimal mfun_tt_z)
493    else :
494        p
495    fi
496        if (mfun_labtype@# >= 10) :
497            shifted (0,ypart center p)
498        fi
499        shifted (mfun_tt_z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
500enddef ;
501
502vardef fmttext@#(text t) = % no draw here
503    thefmttext@#(t,origin)
504enddef ;
505
506% or just: def fmttext = thefmttext enddef ;
507
508vardef onetimefmttext@#(text t) = % no draw here
509    mfun_onetime_textext := true ;
510    thefmttext@#(t,origin)
511enddef ;
512
513% so much for formatted text
514
515vardef thetexbox@#(expr category, name, z) =
516    save p ; picture p ; p := rawtexbox(category,name) ;
517    p
518        if (mfun_labtype@# >= 10) :
519            shifted (0,ypart center p)
520        fi
521        shifted (z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
522enddef ;
523
524vardef texbox@#(expr category, name) = % no draw here
525    thetexbox@#(category,name,origin)
526enddef ;
527
528permanent rawfmttext, thefmttext, fmttext, onetimefmttext, thetexbox, texbox ;
529
530% vardef thelabel@#(expr p,z) =
531%     if string p :
532%         thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
533%     else :
534%         p shifted (z + labeloffset*mfun_laboff@# - (mfun_labxf@#*lrcorner p + mfun_labyf@#*ulcorner p + (1-mfun_labxf@#-mfun_labyf@#)*llcorner p))
535%     fi
536% enddef;
537
538vardef theoffset@#(expr z) =
539    if pair z :
540        z
541    elseif path z :
542        if mfun_laboff@# = origin :
543            center z
544        else :
545            ((center z)-- mfun_picshift@#(z)) intersectionpoint (z if not cycle z: --cycle fi)
546        fi
547    else : % picture
548        mfun_picshift@#(z)
549    fi
550enddef;
551
552vardef thelabel@#(expr p,z) =
553    if string p :
554        thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
555    elseif numeric p :
556        thelabel@#(decimal p,z)
557    elseif pair p :
558        thelabel@#("(" & decimal(xpart p) & "," & decimal(ypart p) & ")",z)
559    else :
560        p shifted (theoffset@#(z) + labeloffset*mfun_laboff@# - mfun_labshift@#(p))
561    fi
562enddef;
563
564def label = % takes two arguments, contrary to textext that takes one
565    normaldraw thelabel
566enddef ;
567
568vardef anchored@#(expr p, z) = % beware: no "+ mfun_laboff@#" here (never!)
569    p
570        if (mfun_labtype@# >= 10) :
571            shifted (0,ypart center p)
572        fi
573        shifted (z + mfun_labshift@#(p))
574enddef ;
575
576let normalinfont = infont ;
577
578primarydef s infont name = % nasty hack
579    if name = "" :
580        textext(s)
581    else :
582        textext("\definedfont[" & name & "]" & s)
583    fi
584enddef ;
585
586permanent theoffset, thelabel, anchored ;
587primitive infont ; % fake primitive
588
589% Helper
590
591string mfun_prescript_separator ; mfun_prescript_separator := char(13) ;
592
593% Shades
594
595% for while we had this:
596
597newinternal shadefactor  ; shadefactor  := 1 ;      % currently obsolete
598pair        shadeoffset  ; shadeoffset  := origin ; % currently obsolete
599boolean     trace_shades ; trace_shades := false ;  % still there
600
601permanent shadefactor, shadeoffset ;
602
603% def withlinearshading (expr a, b) =
604%     withprescript "sh_type=linear"
605%     withprescript "sh_domain=0 1"
606%     withprescript "sh_factor="   & decimal shadefactor
607%     withprescript "sh_center_a=" & ddecimal (a shifted shadeoffset)
608%     withprescript "sh_center_b=" & ddecimal (b shifted shadeoffset)
609% enddef ;
610%
611% def withcircularshading (expr a, b, ra, rb) =
612%     withprescript "sh_type=circular"
613%     withprescript "sh_domain=0 1"
614%     withprescript "sh_factor="   & decimal shadefactor
615%     withprescript "sh_center_a=" & ddecimal (a shifted shadeoffset)
616%     withprescript "sh_center_b=" & ddecimal (b shifted shadeoffset)
617%     withprescript "sh_radius_a=" & decimal ra
618%     withprescript "sh_radius_b=" & decimal rb
619% enddef ;
620%
621% def withshading (expr how)(text rest) =
622%     if how = "linear" :
623%         withlinearshading(rest)
624%     elseif how = "circular" :
625%         withcircularshading(rest)
626%     else :
627%         % nothing
628%     fi
629% enddef ;
630%
631% def withfromshadecolor expr t =
632%     withprescript "sh_color=into"
633%     withprescript "sh_color_a=" & colordecimals t
634% enddef ;
635
636% def withtoshadecolor expr t =
637%     withprescript "sh_color=into"
638%     withprescript "sh_color_b=" & colordecimals t
639% enddef ;
640
641% but this is nicer
642
643% fill fullcircle scaled 10cm
644%     withshademethod "circular"
645%     withshadevector (5cm,1cm)
646%     withshadecenter (.1,.5)
647%     withshadedomain (.2,.6)
648%     withshadefactor 1.2
649%     withshadecolors (red,green)
650% ;
651
652path    mfun_shade_path ;
653numeric mfun_shade_step ; mfun_shade_step := 0 ;
654
655def withshadestep =
656    hide(mfun_shade_step := mfun_shade_step + 1 ;)
657    mfun_withshadestep
658enddef ;
659
660def mfun_withshadestep (text t) =
661    withprescript "sh_step=" & decimal mfun_shade_step
662    t
663    withnothing % otherwise we scan ahead and can unwantingly bump the step
664enddef ;
665
666numeric mfun_shade_fx, mfun_shade_fy ;
667numeric mfun_shade_lx, mfun_shade_ly ;
668numeric mfun_shade_nx, mfun_shade_ny ;
669numeric mfun_shade_dx, mfun_shade_dy ;
670numeric mfun_shade_tx, mfun_shade_ty ;
671pair    mfun_shade_center ;
672path    mfun_shade_bbox ;
673
674numeric mfun_shade_height, mfun_shade_width;
675
676% def mfun_with_shade_method_analyze(expr p) =
677%     mfun_shade_path   := p ;
678%     mfun_shade_bbox   := boundingbox p ;
679%     mfun_shade_center := center p ;
680%     mfun_shade_width  := bbwidth p ;
681%     mfun_shade_height := bbheight p ;
682%     mfun_shade_step   := 1 ;
683%     mfun_shade_fx     := xpart point 0 of p ;
684%     mfun_shade_fy     := ypart point 0 of p ;
685%     mfun_shade_lx     := mfun_shade_fx ;
686%     mfun_shade_ly     := mfun_shade_fy ;
687%     mfun_shade_nx     := 0 ;
688%     mfun_shade_ny     := 0 ;
689%     mfun_shade_dx     := abs(mfun_shade_fx - mfun_shade_lx) ;
690%     mfun_shade_dy     := abs(mfun_shade_fy - mfun_shade_ly) ;
691%     for i=1 upto length(p) :
692%         mfun_shade_tx := abs(mfun_shade_fx - xpart point i of p) ;
693%         mfun_shade_ty := abs(mfun_shade_fy - ypart point i of p) ;
694%         if mfun_shade_tx > mfun_shade_dx :
695%             mfun_shade_nx := i + 1 ;
696%             mfun_shade_lx := xpart point i of p ;
697%             mfun_shade_dx := mfun_shade_tx ;
698%         fi ;
699%         if mfun_shade_ty > mfun_shade_dy :
700%             mfun_shade_ny := i + 1 ;
701%             mfun_shade_ly := ypart point i of p ;
702%             mfun_shade_dy := mfun_shade_ty ;
703%         fi ;
704%     endfor ;
705% enddef ;
706
707def mfun_with_shade_method_analyze(expr p) =
708    mfun_shade_path   := p ;
709    mfun_shade_bbox   := boundingbox p ;
710    mfun_shade_center := center mfun_shade_bbox ;
711    mfun_shade_width  := bbwidth mfun_shade_bbox ;
712    mfun_shade_height := bbheight mfun_shade_bbox ;
713    mfun_shade_step   := 1 ;
714    mfun_shade_fx     := xpart point 0 of p ;
715    mfun_shade_fy     := ypart point 0 of p ;
716    mfun_shade_lx     := mfun_shade_fx ;
717    mfun_shade_ly     := mfun_shade_fy ;
718    mfun_shade_nx     := 0 ;
719    mfun_shade_ny     := 0 ;
720    mfun_shade_dx     := abs(mfun_shade_fx - mfun_shade_lx) ;
721    mfun_shade_dy     := abs(mfun_shade_fy - mfun_shade_ly) ;
722    for i within p :
723        mfun_shade_tx := abs(mfun_shade_fx - xpart pathpoint) ;
724        mfun_shade_ty := abs(mfun_shade_fy - ypart pathpoint) ;
725        if mfun_shade_tx > mfun_shade_dx :
726            mfun_shade_nx := i + 1 ;
727            mfun_shade_lx := xpart pathpoint ;
728            mfun_shade_dx := mfun_shade_tx ;
729        fi ;
730        if mfun_shade_ty > mfun_shade_dy :
731            mfun_shade_ny := i + 1 ;
732            mfun_shade_ly := ypart pathpoint ;
733            mfun_shade_dy := mfun_shade_ty ;
734        fi ;
735    endfor ;
736enddef ;
737
738% todo: native bbox
739
740vardef mfun_shade_center_fraction_do expr a =
741    ddecimal (
742        (xpart llcorner mfun_shade_bbox) + (xpart a) * mfun_shade_width,
743        (ypart llcorner mfun_shade_bbox) + (ypart a) * mfun_shade_height
744    )
745enddef ;
746
747def withshadecenterfraction expr a =
748    withprescript "sh_center_a=" & mfun_shade_center_fraction_do a
749    withprescript "sh_center_b=" & mfun_shade_center_fraction_do a
750enddef ;
751
752def withshadecenteronefraction expr a =
753    withprescript "sh_center_a=" & mfun_shade_center_fraction_do a
754enddef ;
755
756def withshadecentertwofraction expr a =
757    withprescript "sh_center_b=" & mfun_shade_center_fraction_do a
758enddef ;
759
760def withshaderadiusfraction expr a =
761    withprescript "sh_radius_a=0"
762    withprescript "sh_radius_b=" & decimal (a * sqrt(mfun_shade_width*mfun_shade_width+mfun_shade_height*mfun_shade_height)/2)
763enddef ;
764
765vardef mfun_max_radius(expr p) =
766    max (
767        (xpart center   p - xpart llcorner p) ++ (ypart center   p - ypart llcorner p),
768        (xpart center   p - xpart ulcorner p) ++ (ypart ulcorner p - ypart center   p),
769        (xpart lrcorner p - xpart center   p) ++ (ypart center   p - ypart lrcorner p),
770        (xpart urcorner p - xpart center   p) ++ (ypart urcorner p - ypart center   p)
771    )
772enddef ;
773
774vardef mfun_min_radius(expr p) =
775    min (
776        (xpart center   p - xpart llcorner p) ++ (ypart center   p - ypart llcorner p),
777        (xpart center   p - xpart ulcorner p) ++ (ypart ulcorner p - ypart center   p),
778        (xpart lrcorner p - xpart center   p) ++ (ypart center   p - ypart lrcorner p),
779        (xpart urcorner p - xpart center   p) ++ (ypart urcorner p - ypart center   p)
780    )
781enddef ;
782
783primarydef p withshademethod m =
784    hide(mfun_with_shade_method_analyze(p))
785    p
786    withprescript "sh_domain=0 1"
787    withprescript "sh_transform=yes"
788    withprescript "sh_color=into"
789    withprescript "sh_color_a=" & colordecimals white
790    withprescript "sh_color_b=" & colordecimals black
791    withprescript "sh_first=" & ddecimal point 0 of p % used for support scaling
792    withprescript "sh_set_x=" & ddecimal (mfun_shade_nx,mfun_shade_lx) %
793    withprescript "sh_set_y=" & ddecimal (mfun_shade_ny,mfun_shade_ly) %
794    if m = "linear" :
795        withprescript "sh_type=linear"
796        withprescript "sh_factor=1"
797        withprescript "sh_center_a=" & ddecimal llcorner p
798        withprescript "sh_center_b=" & ddecimal urcorner p
799    else :
800        withprescript "sh_type=circular"
801        withprescript "sh_factor=1.2"
802        withprescript "sh_center_a=" & ddecimal center p
803        withprescript "sh_center_b=" & ddecimal center p
804        withprescript "sh_radius_a=" & decimal 0
805        withprescript "sh_radius_b=" & decimal mfun_max_radius(p)
806    fi
807enddef ;
808
809def withshaderadius expr a =
810    withprescript "sh_radius_a=" & decimal (xpart a)
811    withprescript "sh_radius_b=" & decimal (ypart a)
812enddef ;
813
814def withshadeorigin expr a =
815    withprescript "sh_center_a=" & ddecimal a
816    withprescript "sh_center_b=" & ddecimal a
817enddef ;
818
819def withshadecenterone expr a =
820    withprescript "sh_center_a=" & ddecimal a
821enddef ;
822
823def withshadecentertwo expr a =
824    withprescript "sh_center_b=" & ddecimal a
825enddef ;
826
827def withshadevector expr a =
828    withprescript "sh_center_a=" & ddecimal (point xpart a of mfun_shade_path)
829    withprescript "sh_center_b=" & ddecimal (point ypart a of mfun_shade_path)
830enddef ;
831
832def withshadedirection expr a =
833    withprescript "sh_center_a=" & ddecimal (point xpart a of boundingbox(mfun_shade_path))
834    withprescript "sh_center_b=" & ddecimal (point ypart a of boundingbox(mfun_shade_path))
835enddef ;
836
837def withshadetransform expr a = % yes | no
838    withprescript "sh_transform=" & a
839enddef ;
840
841def withshadetransformation expr a =
842    withprescript "sh_transformation=" &
843        decimal (xxpart a) & " " &
844        decimal (yxpart a) & " " &
845        decimal (xypart a) & " " &
846        decimal (yypart a) & " " &
847        decimal (xpart  a) & " " &
848        decimal (ypart  a)
849enddef ;
850
851pair shadedup    ; shadedup    := (0.5,2.5) ;
852pair shadeddown  ; shadeddown  := (2.5,0.5) ;
853pair shadedleft  ; shadedleft  := (1.5,3.5) ;
854pair shadedright ; shadedright := (3.5,1.5) ;
855
856def withshadecenter expr a =
857    withprescript "sh_center_a=" & ddecimal (
858        center mfun_shade_path shifted (
859            xpart a * bbwidth (mfun_shade_path)/2,
860            ypart a * bbheight(mfun_shade_path)/2
861        )
862    )
863enddef ;
864
865def withshadedomain expr d =
866    withprescript "sh_domain=" & ddecimal d
867enddef ;
868
869def withshadefactor expr f =
870    withprescript "sh_factor=" & decimal f
871enddef ;
872
873% def withshadebound (expr a) =
874%     if mfun_shade_step > 0 :
875%         withprescript "sh_bound_" & decimal mfun_shade_step & "=" & decimal a
876%     fi
877% enddef ;
878
879def withshadefraction expr a =
880    if mfun_shade_step > 0 :
881        withprescript "sh_fraction_" & decimal mfun_shade_step & "=" & decimal a
882    fi
883enddef ;
884
885% def withshadeopacity expr a =
886%     if mfun_shade_step > 0 :
887%         withprescript "sh_opacity_" & decimal mfun_shade_step & "=" & decimal a
888%         % withtransparency(3,1)
889%     fi
890% enddef ;
891
892def withshadecolors (expr a, b) =
893    if mfun_shade_step > 0 :
894        withprescript "sh_color=into"
895        withprescript "sh_color_a_" & decimal mfun_shade_step & "=" & colordecimals a
896        withprescript "sh_color_b_" & decimal mfun_shade_step & "=" & colordecimals b
897    else :
898        withprescript "sh_color=into"
899        withprescript "sh_color_a=" & colordecimals a
900        withprescript "sh_color_b=" & colordecimals b
901    fi
902enddef ;
903
904primarydef a shadedinto b = % withcolor red shadedinto green
905    1 % does not work with transparency
906    withprescript "sh_color=into"
907    withprescript "sh_color_a=" & colordecimals a
908    withprescript "sh_color_b=" & colordecimals b
909enddef ;
910
911primarydef p withshade sc =
912    p withprescript mfun_defined_cs_pre[sc]
913enddef ;
914
915def defineshade suffix s =
916    mfun_defineshade(str s)
917enddef ;
918
919def mfun_defineshade (expr s) text t =
920    expandafter def scantokens s = t enddef ;
921enddef ;
922
923def shaded text s =
924    s
925enddef ;
926
927
928% For me.
929
930primarydef p shownshadevector v =
931    image (
932        drawarrow (point xpart v of p) -- (point ypart v of p) ;
933        fill fullcircle scaled 2 shifted point xpart v of p ;
934        setbounds currentpicture to center currentpicture -- cycle ;
935    )
936enddef ;
937
938primarydef p shownshadedirection v =
939    image (
940        drawarrow (point xpart v of boundingbox p) -- (point ypart v of boundingbox p) ;
941        fill fullcircle scaled 2 shifted (point xpart v of boundingbox p) ;
942        setbounds currentpicture to center currentpicture -- cycle ;
943    )
944enddef ;
945
946primarydef p shownshadecenter v =
947    image (
948        fill fullcircle scaled 2
949            shifted center p shifted (
950            xpart v * bbwidth (p)/2,
951            ypart v * bbheight(p)/2
952        ) ;
953        setbounds currentpicture to center currentpicture -- cycle ;
954    )
955enddef ;
956
957primarydef p shownshadeorigin v =
958    image (
959        fill fullcircle scaled 2 shifted v ;
960        setbounds currentpicture to center currentpicture -- cycle ;
961    )
962enddef ;
963
964permanent withshademethod, withshaderadius, withshadeorigin, withshadevector, withshadedirection,
965    withshadetransform, withshadedomain, withshadefactor, withshadecenter, withshadefraction, withshadestep,
966    withshadecolors, shadedinto, withshade, shaded, shadedup, shadeddown, shadedleft, shadedright,
967    shownshadevector, shownshadedirection, shownshadecenter, shownshadeorigin ;
968
969% Old macros:
970
971def withcircularshade (expr a, b, ra, rb, ca, cb) =
972    withprescript "sh_type=circular"
973    withprescript "sh_transform=yes"
974    withprescript "sh_domain=0 1"
975    withprescript "sh_factor=1"
976    withprescript "sh_color_a="  & colordecimals ca
977    withprescript "sh_color_b="  & colordecimals cb
978    withprescript "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
979    withprescript "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
980    withprescript "sh_radius_a=" & decimal ra
981    withprescript "sh_radius_b=" & decimal rb
982enddef ;
983
984def withlinearshade (expr a, b, ca, cb) =
985    withprescript "sh_type=linear"
986    withprescript "sh_transform=yes"
987    withprescript "sh_domain=0 1"
988    withprescript "sh_factor=1"
989    withprescript "sh_color_a="  & colordecimals ca
990    withprescript "sh_color_b="  & colordecimals cb
991    withprescript "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
992    withprescript "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
993enddef ;
994
995permanent withcircularshade, withlinearshade ;
996
997% replaced (obsolete):
998
999def set_linear_vector (suffix a,b)(expr p,n) =
1000    if     (n=1) : a := llcorner p ; b := urcorner p ;
1001    elseif (n=2) : a := lrcorner p ; b := ulcorner p ;
1002    elseif (n=3) : a := urcorner p ; b := llcorner p ;
1003    elseif (n=4) : a := ulcorner p ; b := lrcorner p ;
1004    elseif (n=5) : a := .5[ulcorner p,llcorner p] ; b := .5[urcorner p,lrcorner p] ;
1005    elseif (n=6) : a := .5[llcorner p,lrcorner p] ; b := .5[ulcorner p,urcorner p] ;
1006    elseif (n=7) : a := .5[lrcorner p,urcorner p] ; b := .5[llcorner p,ulcorner p] ;
1007    elseif (n=8) : a := .5[urcorner p,ulcorner p] ; b := .5[lrcorner p,llcorner p] ;
1008    else         : a := .5[ulcorner p,llcorner p] ; b := .5[urcorner p,lrcorner p] ;
1009    fi ;
1010enddef ;
1011
1012def set_circular_vector (suffix ab,r)(expr p,n) =
1013    if     (n=1) : ab := llcorner p ;
1014    elseif (n=2) : ab := lrcorner p ;
1015    elseif (n=3) : ab := urcorner p ;
1016    elseif (n=4) : ab := ulcorner p ;
1017    else         : ab := center   p ; r := .5r ;
1018    fi ;
1019enddef ;
1020
1021def circular_shade (expr p, n, ca, cb) =
1022    begingroup ;
1023        save ab, r ; pair ab ; numeric r ;
1024        r := (xpart lrcorner p - xpart llcorner p) ++ (ypart urcorner p - ypart lrcorner p) ;
1025        set_circular_vector(ab,r)(p,n) ;
1026        fill p withcircularshade(ab,ab,0,r,ca,cb) ;
1027        if trace_shades :
1028            drawarrow ab -- ab shifted (0,r) withpen pencircle scaled 1pt withcolor .5white ;
1029        fi ;
1030    endgroup ;
1031enddef ;
1032
1033def linear_shade (expr p, n, ca, cb) =
1034    begingroup ;
1035        save a, b ; pair a, b ;
1036        set_linear_vector(a,b)(p,n) ;
1037        fill p withlinearshade(a,b,ca,cb) ;
1038        if trace_shades :
1039            drawarrow a -- b withpen pencircle scaled 1pt withcolor .5white ;
1040        fi ;
1041    endgroup ;
1042enddef ;
1043
1044string mfun_defined_cs_pre[] ; numeric mfun_defined_cs ; mfun_defined_cs := 0 ;
1045
1046vardef define_circular_shade (expr a, b, ra, rb, ca, cb) =
1047    mfun_defined_cs := mfun_defined_cs + 1 ;
1048    mfun_defined_cs_pre[mfun_defined_cs] := "sh_type=circular"
1049    & mfun_prescript_separator & "sh_domain=0 1"
1050    & mfun_prescript_separator & "sh_factor=1"
1051    & mfun_prescript_separator & "sh_color_a="  & colordecimals ca
1052    & mfun_prescript_separator & "sh_color_b="  & colordecimals cb
1053    & mfun_prescript_separator & "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
1054    & mfun_prescript_separator & "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
1055    & mfun_prescript_separator & "sh_radius_a=" & decimal ra
1056    & mfun_prescript_separator & "sh_radius_b=" & decimal rb
1057    ;
1058    mfun_defined_cs
1059enddef ;
1060
1061vardef define_linear_shade (expr a, b, ca, cb) =
1062    mfun_defined_cs := mfun_defined_cs + 1 ;
1063    mfun_defined_cs_pre[mfun_defined_cs] := "sh_type=linear"
1064    & mfun_prescript_separator & "sh_domain=0 1"
1065    & mfun_prescript_separator & "sh_factor=1"
1066    & mfun_prescript_separator & "sh_color_a=" & colordecimals ca
1067    & mfun_prescript_separator & "sh_color_b=" & colordecimals cb
1068    & mfun_prescript_separator & "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
1069    & mfun_prescript_separator & "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
1070    ;
1071    mfun_defined_cs
1072enddef ;
1073
1074% I lost the example code that uses this:
1075%
1076% vardef define_sampled_linear_shade(expr a,b,n)(text t) =
1077%     mfun_defined_cs := mfun_defined_cs + 1 ;
1078%     mfun_defined_cs_pre[mfun_defined_cs] := "ssh_type=linear"
1079%     & mfun_prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
1080%     & mfun_prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
1081%     & mfun_prescript_separator & "ssh_nofcolors=" & decimal n
1082%     & mfun_prescript_separator & "ssh_domain=" & domstr
1083%     & mfun_prescript_separator & "ssh_extend=" & extstr
1084%     & mfun_prescript_separator & "ssh_colors=" & colstr
1085%     & mfun_prescript_separator & "ssh_bounds=" & bndstr
1086%     & mfun_prescript_separator & "ssh_ranges=" & ranstr
1087%     ;
1088%     mfun_defined_cs
1089% enddef ;
1090%
1091% vardef define_sampled_circular_shade(expr a,b,ra,rb,n)(text t) =
1092%     mfun_defined_cs := mfun_defined_cs + 1 ;
1093%     mfun_defined_cs_pre[mfun_defined_cs] := "ssh_type=circular"
1094%     & mfun_prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
1095%     & mfun_prescript_separator & "ssh_radius_a=" & decimal ra
1096%     & mfun_prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
1097%     & mfun_prescript_separator & "ssh_radius_b=" & decimal rb
1098%     & mfun_prescript_separator & "ssh_nofcolors=" & decimal n
1099%     & mfun_prescript_separator & "ssh_domain=" & domstr
1100%     & mfun_prescript_separator & "ssh_extend=" & extstr
1101%     & mfun_prescript_separator & "ssh_colors=" & colstr
1102%     & mfun_prescript_separator & "ssh_bounds=" & bndstr
1103%     & mfun_prescript_separator & "ssh_ranges=" & ranstr
1104%     ;
1105%     mfun_defined_cs
1106% enddef ;
1107
1108% vardef predefined_linear_shade (expr p, n, ca, cb) =
1109%     save a, b, sh ; pair a, b ;
1110%     set_linear_vector(a,b)(p,n) ;
1111%     define_linear_shade (a,b,ca,cb)
1112% enddef ;
1113%
1114% vardef predefined_circular_shade (expr p, n, ca, cb) =
1115%     save ab, r ; pair ab ; numeric r ;
1116%     r := (xpart lrcorner p - xpart llcorner p) ++ (ypart urcorner p - ypart lrcorner p) ;
1117%     set_circular_vector(ab,r)(p,n) ;
1118%     define_circular_shade(ab,ab,0,r,ca,cb)
1119% enddef ;
1120
1121% Layers
1122
1123def onlayer primary name =
1124    withprescript "la_name=" & name
1125enddef ;
1126
1127permanent onlayer ;
1128
1129% Figures
1130
1131% def externalfigure primary filename =
1132%     doexternalfigure (filename)
1133% enddef ;
1134%
1135% def doexternalfigure (expr filename) text transformation =
1136%     if true : % a bit incompatible esp scaled 1cm now scaled the natural size
1137%         draw rawtextext("\externalfigure[" & filename & "]") transformation ;
1138%     else :
1139%         draw unitsquare transformation withprescript "fg_name=" & filename ;
1140%     fi ;
1141% enddef ;
1142
1143def withmask primary filename =
1144    withprescript "fg_mask=" & filename
1145enddef ;
1146
1147vardef externalfigure primary filename =
1148    mfun_tt_c := nullpicture ;
1149    mfun_tt_r := lua.mp.mf_external_figure(filename) ;
1150    addto mfun_tt_c doublepath unitsquare
1151        xscaled wdpart mfun_tt_r
1152        yscaled htpart mfun_tt_r
1153        withprescript "mf_object=figure"
1154        withprescript "fg_name=" & filename ;
1155    ;
1156    mfun_tt_c
1157enddef ;
1158
1159def figure primary filename =
1160    rawtextext("\externalfigure[" & filename & "]")
1161enddef ;
1162
1163vardef svgembeddedfigure primary index =
1164%     mfun_onetime_textext := true ;
1165    rawtextext("\svgembeddedfigure{" & decimal index & "}")
1166enddef ;
1167
1168permanent withmask, externalfigure, figure ;
1169
1170% Positions
1171
1172def register (expr tag, width, height, offset) =
1173%     draw image (
1174        addto currentpicture doublepath unitsquare xscaled width yscaled height shifted offset
1175            withprescript "ps_label=" & tag ;
1176%     ) ; % no transformations
1177enddef ;
1178
1179permanent register ;
1180
1181% outlines (todo: pass around less arguments)
1182
1183numeric currentoutlinetext ; currentoutlinetext := 0 ;
1184
1185vardef mfun_do_outline_text_flush (expr kind, n, x, y, c) (text t) =
1186    if kind = "f" :
1187        mfun_do_outline_text_f (n, x, y, c) (t)
1188    elseif kind = "d" :
1189        mfun_do_outline_text_d (n, x, y, c) (t)
1190    elseif kind = "b" :
1191        mfun_do_outline_text_b (n, x, y, c) (t)
1192    elseif kind = "r" :
1193        mfun_do_outline_text_r (n, x, y, c) (t)
1194    elseif kind = "p" :
1195        mfun_do_outline_text_p (n, x, y, c) (t)
1196    elseif kind = "u" :
1197        mfun_do_outline_text_u (n, x, y, c) (t)
1198    else :
1199        mfun_do_outline_text_n (n, x, y, c) (t)
1200    fi ;
1201enddef ;
1202
1203vardef mfun_do_outline_rule_flush (expr kind, x, y, w, h) =
1204  % mfun_do_outline_text_flush (kind, 1, x, y, "") (fullsquare xyscaled(w,h))
1205    mfun_do_outline_text_flush (kind, 1, x, y, "") (unitsquare xyscaled(w,h))
1206enddef ;
1207
1208numeric mfun_do_outline_n ; mfun_do_outline_n := 0 ;
1209
1210vardef mfun_do_outline_text_f (expr n, x, y, c) (text t) =
1211    mfun_do_outline_n := 0 ;
1212    for i=t :
1213        mfun_do_outline_n := mfun_do_outline_n + 1 ;
1214        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f withpen pencircle scaled 0 withprescript c ;
1215    endfor ;
1216enddef ;
1217
1218vardef mfun_do_outline_text_u (expr n, x, y, c) (text t) =
1219    mfun_do_outline_n := 0 ;
1220    for i=t :
1221        mfun_do_outline_n := mfun_do_outline_n + 1 ;
1222        if mfun_do_outline_n = n : fillup else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f withprescript c ;
1223    endfor ;
1224enddef ;
1225
1226vardef mfun_do_outline_text_d (expr n, x, y, c) (text t) =
1227    for i=t :
1228        draw i shifted(x,y) mfun_do_outline_options_d ;
1229    endfor ;
1230enddef ;
1231
1232vardef mfun_do_outline_text_p (expr n, x, y, c) (text t) =
1233    for i=t :
1234        draw i shifted(x,y) withprescript c ;
1235    endfor ;
1236enddef ;
1237
1238vardef mfun_do_outline_text_b (expr n, x, y, c) (text t) =
1239    mfun_do_outline_n := 0 ;
1240    for i=t :
1241        mfun_do_outline_n := mfun_do_outline_n + 1 ;
1242        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f ;
1243    endfor ;
1244    for i=t :
1245        draw i shifted(x,y) mfun_do_outline_options_d ;
1246    endfor ;
1247enddef ;
1248
1249vardef mfun_do_outline_text_r (expr n, x, y, c) (text t) =
1250    mfun_do_outline_n := 0 ;
1251    for i=t :
1252        draw i shifted(x,y) mfun_do_outline_options_d ;
1253    endfor ;
1254    for i=t :
1255        mfun_do_outline_n := mfun_do_outline_n + 1 ;
1256        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f;
1257    endfor ;
1258enddef ;
1259
1260vardef mfun_do_outline_text_n (expr n, x, y, c) (text t) =
1261    mfun_do_outline_n := 0 ;
1262    for i=t :
1263        mfun_do_outline_n := mfun_do_outline_n + 1 ;
1264        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) ;
1265    endfor ;
1266enddef ;
1267
1268vardef mfun_do_outline_text_set_f (text f) text r =
1269    def mfun_do_outline_options_f = f enddef ;
1270    def mfun_do_outline_options_r = r enddef ;
1271enddef ;
1272
1273vardef mfun_do_outline_text_set_u (text f) text r =
1274    def mfun_do_outline_options_f = f enddef ;
1275enddef ;
1276
1277vardef mfun_do_outline_text_set_d (text d) text r =
1278    def mfun_do_outline_options_d = d enddef ;
1279    def mfun_do_outline_options_r = r enddef ;
1280enddef ;
1281
1282vardef mfun_do_outline_text_set_b (text f) (text d) text r =
1283    def mfun_do_outline_options_f = f enddef ;
1284    def mfun_do_outline_options_d = d enddef ;
1285    def mfun_do_outline_options_r = r enddef ;
1286enddef ;
1287
1288vardef mfun_do_outline_text_set_r (text d) (text f) text r =
1289    def mfun_do_outline_options_d = d enddef ;
1290    def mfun_do_outline_options_f = f enddef ;
1291    def mfun_do_outline_options_r = r enddef ;
1292enddef ;
1293
1294vardef mfun_do_outline_text_set_n text r =
1295    def mfun_do_outline_options_r = r enddef ;
1296enddef ;
1297
1298vardef mfun_do_outline_text_set_p =
1299enddef ;
1300
1301def mfun_do_outline_options_d = enddef ;
1302def mfun_do_outline_options_f = enddef ;
1303def mfun_do_outline_options_r = enddef ;
1304
1305def outlinetexttopath (text o, p, n) =
1306    scantokens("numeric " & str n &   ";") ;
1307    scantokens("path "    & str p & "[];") ;
1308    n := 0 ;
1309    for i within o : p[incr(n)] := pathpart i ; endfor ;
1310enddef ;
1311
1312def filloutlinetext (expr o) =
1313    draw image (
1314        save n, m ; numeric n, m ; n := m := 0 ;
1315        for i within o :
1316            n := n + 1 ;
1317        endfor ;
1318        for i within o :
1319            m := m + 1 ;
1320            if n = m :
1321                eofill
1322            else :
1323                nofill
1324            fi pathpart i ;
1325        endfor ;
1326    )
1327enddef ;
1328
1329def drawoutlinetext (expr o) =
1330    draw image (
1331        % nicer for properties
1332        for i within o :
1333            draw pathpart i ;
1334        endfor ;
1335    )
1336enddef ;
1337
1338vardef outlinetext@# (expr t) text rest =
1339    save kind ; string kind ; kind := str @# ;
1340    currentoutlinetext := currentoutlinetext + 1 ;
1341    def mfun_do_outline_options_d = enddef ;
1342    def mfun_do_outline_options_f = enddef ;
1343    def mfun_do_outline_options_r = enddef ;
1344    image ( normaldraw image (
1345      % lua.mp.report("set outline text",currentoutlinetext);
1346        lua.mp.mf_outline_text(currentoutlinetext,t,kind) ;
1347      % lua.mp.report("get outline text",currentoutlinetext);
1348        if kind = "f" :
1349            mfun_do_outline_text_set_f rest ;
1350        elseif kind = "d" :
1351            mfun_do_outline_text_set_d rest ;
1352        elseif kind = "b" :
1353            mfun_do_outline_text_set_b rest ;
1354        elseif kind = "u" :
1355            mfun_do_outline_text_set_f rest ;
1356        elseif kind = "r" :
1357            mfun_do_outline_text_set_r rest ;
1358        elseif kind = "p" :
1359            mfun_do_outline_text_set_p ;
1360        else :
1361            mfun_do_outline_text_set_n rest ;
1362        fi ;
1363        lua.mp.mf_get_outline_text(currentoutlinetext) ;
1364    ) mfun_do_outline_options_r ; )
1365enddef ;
1366
1367
1368permanent outlinetexttopath, filloutlinetext, drawoutlinetext, outlinetext ;
1369
1370% A few helpers:
1371
1372numeric mfun_c_b_llx, mfun_c_b_h, mfun_c_b_w, mfun_c_b_l ;
1373
1374vardef checkedbounds(expr llx,lly,urx,ury) =
1375    mfun_c_b_llx := min(xpart llcorner currentpicture,llx) ;
1376    mfun_c_b_urx := max(xpart urcorner currentpicture,urx) ;
1377    mfun_c_b_lly := min(ypart llcorner currentpicture,lly) ;
1378    mfun_c_b_ury := max(ypart urcorner currentpicture,ury) ;
1379    (mfun_c_b_llx,mfun_c_b_lly) --
1380    (mfun_c_b_urx,mfun_c_b_lly) --
1381    (mfun_c_b_urx,mfun_c_b_ury) --
1382    (mfun_c_b_llx,mfun_c_b_ury) -- cycle
1383enddef ;
1384
1385vardef checkbounds(expr llx,lly,urx,ury) =
1386    setbounds currentpicture to checkedbounds(llx,lly,urx,ury) ;
1387enddef ;
1388
1389vardef strut(expr ht,dp) =
1390    setbounds currentpicture to checkedbounds(0,0,ht,dp) ;
1391enddef ;
1392
1393vardef rule(expr wd,ht,dp) =
1394    image (fill (0,-dp)--(wd,-dp)--(wd,ht)--(0,ht)--cycle)
1395enddef ;
1396
1397permanent checkedbounds, checkbounds, strut, rule ;
1398
1399% Housekeeping
1400
1401extra_beginfig := extra_beginfig & "currentgraphictext := 0 ; " ;
1402extra_beginfig := extra_beginfig & "currentoutlinetext := 0 ; " ;
1403extra_endfig   := extra_endfig   & "finishsavingdata ; " ;
1404extra_endfig   := extra_endfig   & "mfun_reset_tex_texts ; " ;
1405
1406% Bonus
1407
1408vardef verbatim(expr s) =
1409    ditto & "\detokenize{" & s & "}" & ditto
1410enddef ;
1411
1412permanent verbatim ;
1413
1414% New
1415
1416% def bitmapimage(expr xresolution, yresolution, data) =
1417%     image (
1418%         addto currentpicture doublepath unitsquare
1419%             withprescript  "bm_xresolution=" & decimal xresolution
1420%             withprescript  "bm_yresolution=" & decimal yresolution
1421%             withpostscript data ;
1422%     )
1423% enddef ;
1424
1425vardef bitmapimage(expr xresolution, yresolution, data) =
1426    save p ; picture p ; p := nullpicture ;
1427    addto p doublepath unitsquare
1428%         xscaled xresolution
1429%         yscaled yresolution
1430        withprescript  "bm_xresolution=" & decimal xresolution
1431        withprescript  "bm_yresolution=" & decimal yresolution
1432        withpostscript data
1433    ;
1434    p
1435enddef ;
1436
1437permanent bitmapimage ;
1438
1439% Experimental:
1440%
1441% property p ; p = properties(withcolor (1,1,0,0)) ;
1442% fill fullcircle scaled 20cm withproperties p ;
1443
1444let property = picture ; permanent property ;
1445
1446vardef properties(text t) =
1447    image(draw unitcircle t)
1448enddef ;
1449
1450def withproperties expr p =
1451    if colormodel p = graycolormodel :
1452        withcolor greypart p
1453    elseif colormodel p = rgbcolormodel :
1454        withcolor (redpart p,greenpart p,bluepart p)
1455    elseif colormodel p = cmykcolormodel :
1456        withcolor (cyanpart p,magentapart p,yellowpart p,blackpart p)
1457    fi
1458    withpen penpart p
1459    if length (dashpart p) > 0 :
1460        dashed dashpart p
1461    fi
1462    if stackingpart p <> 0 :
1463        withstacking stackingpart p
1464    fi
1465    withprescript prescriptpart p
1466    withpostscript postscriptpart p
1467enddef ;
1468
1469permanent properties, withproperties ;
1470
1471% Experimental:
1472
1473primarydef t asgroup s = % s = isolated|knockout
1474    begingroup
1475    save temp_p, temp_q, temp_r ;
1476    picture temp_p, temp_q ; path temp_r ;
1477    temp_p := if picture t : t else : image(draw t) fi ;
1478    temp_r := boundingbox temp_p ;
1479    temp_q:= nullpicture ;
1480    addto temp_q contour temp_r
1481        withprescript "gr_state=start"
1482        withprescript "gr_type=" & s
1483    ;
1484    addto temp_q also temp_p ;
1485    addto temp_q contour temp_r
1486        withprescript "gr_state=stop"
1487    ;
1488    temp_q
1489    endgroup
1490enddef ;
1491
1492permanent asgroup ;
1493
1494% Even more experimental:
1495
1496pair    mfun_pattern_s ; mfun_pattern_s := origin ; % auto scale to fraction of shape (svg)
1497boolean mfun_pattern_f ; mfun_pattern_f := false  ; % anchor or not (normally we do that)
1498
1499def withpatternscale primary s = hide (mfun_pattern_s := paired s ;) enddef ;
1500def withpatternfloat primary s = hide (mfun_pattern_f := s ;) enddef ;
1501
1502primarydef t withpattern p =
1503    begingroup
1504    %
1505    save temp_q, temp_r ;
1506    picture temp_q ; path temp_r ;
1507    % the combination
1508    temp_q:= nullpicture ;
1509    % the pattern
1510    temp_r := boundingbox p ;
1511    if mfun_pattern_s <> origin :
1512        sx := (xpart mfun_pattern_s) * bbwidth (t) ;
1513        sy := (ypart mfun_pattern_s) * bbheight(t) ;
1514        temp_r := temp_r xysized (sx,sy) ;
1515        addto temp_q contour temp_r
1516            withprescript "pt_state=start"
1517            withprescript "pt_action=set"
1518            withprescript "pt_float=" & tostring(mfun_pattern_f)
1519        ;
1520        addto temp_q also (p xysized (sx,sy));
1521    else :
1522        addto temp_q contour temp_r
1523            withprescript "pt_state=start"
1524            withprescript "pt_action=set"
1525            withprescript "pt_float=" & tostring(mfun_pattern_f)
1526        ;
1527        addto temp_q also p ;
1528    fi ;
1529    addto temp_q contour temp_r
1530        withprescript "pt_state=stop"
1531        withprescript "pt_action=set" ;
1532    % the path
1533    temp_r := boundingbox t ;
1534    addto temp_q contour temp_r
1535        withprescript "pt_state=start"
1536        withprescript "pt_action=get"
1537    ;
1538    addto temp_q contour temp_r
1539        withprescript "pt_state=stop"
1540        withprescript "pt_action=get" ;
1541    % make sure we fill only t
1542    clip temp_q to t ;
1543    % reset
1544    mfun_pattern_s := origin ;
1545    mfun_pattern_f := false ;
1546    % the path
1547    temp_q
1548    endgroup
1549enddef ;
1550
1551% Also experimental ... needs to be made better ... so it can change!
1552
1553string mfun_auto_align[] ;
1554
1555mfun_auto_align[0] := "rt" ;
1556mfun_auto_align[1] := "urt" ;
1557mfun_auto_align[2] := "top" ;
1558mfun_auto_align[3] := "ulft" ;
1559mfun_auto_align[4] := "lft" ;
1560mfun_auto_align[5] := "llft" ;
1561mfun_auto_align[6] := "bot" ;
1562mfun_auto_align[7] := "lrt" ;
1563mfun_auto_align[8] := "rt" ;
1564
1565def autoalign(expr n) =
1566    scantokens mfun_auto_align[round((n mod 360)/45)]
1567enddef ;
1568
1569% draw textext.autoalign(60) ("\strut oeps 1") ;
1570% draw textext.autoalign(160)("\strut oeps 2") ;
1571% draw textext.autoalign(260)("\strut oeps 3") ;
1572% draw textext.autoalign(360)("\strut oeps 4") ;
1573
1574% new
1575%
1576% passvariable("version","1.0") ;
1577% passvariable("number",123) ;
1578% passvariable("string","whatever") ;
1579% passvariable("point",(1,2)) ;
1580% passvariable("triplet",(1,2,3)) ;
1581% passvariable("quad",(1,2,3,4)) ;
1582% passvariable("boolean",false) ;
1583% passvariable("path",fullcircle scaled 1cm) ;
1584
1585% we could use the new lua interface but there is not that much gain i.e.
1586% we still need to serialize
1587
1588vardef mfun_point_to_string(expr p,i) =
1589    decimal xpart (point       i of p) & " " &
1590    decimal ypart (point       i of p) & " " &
1591    decimal xpart (precontrol  i of p) & " " &
1592    decimal ypart (precontrol  i of p) & " " &
1593    decimal xpart (postcontrol i of p) & " " &
1594    decimal ypart (postcontrol i of p)
1595enddef ;
1596
1597vardef mfun_transform_to_string(expr t) =
1598    decimal xxpart t & " " &   % rx
1599    decimal xypart t & " " &   % sx
1600    decimal yxpart t & " " &   % sy
1601    decimal yypart t & " " &   % ry
1602    decimal xpart  t & " " &   % tx
1603    decimal ypart  t           % ty
1604enddef ;
1605
1606vardef mfun_numeric_to_string(expr n) =
1607    decimal n
1608enddef ;
1609
1610vardef mfun_pair_to_string(expr p) =
1611    decimal xpart p & " " &
1612    decimal ypart p
1613enddef ;
1614
1615vardef mfun_rgbcolor_to_string(expr c) =
1616    decimal redpart   c & " " &
1617    decimal greenpart c & " " &
1618    decimal bluepart  c
1619enddef ;
1620
1621vardef mfun_cmykcolor_to_string(expr c) =
1622    decimal cyanpart    c & " " &
1623    decimal magentapart c & " " &
1624    decimal yellowpart  c & " " &
1625    decimal blackpart   c
1626enddef ;
1627
1628vardef mfun_pair_to_table(expr p) =
1629    "{" & decimal xpart p &
1630    "," & decimal ypart p &
1631    "}"
1632enddef ;
1633
1634vardef mfun_point_to_table(expr p,i) =
1635    "{" & decimal xpart (point       i of p) &
1636    "," & decimal ypart (point       i of p) &
1637    "," & decimal xpart (precontrol  i of p) &
1638    "," & decimal ypart (precontrol  i of p) &
1639    "," & decimal xpart (postcontrol i of p) &
1640    "," & decimal ypart (postcontrol i of p) &
1641    "}"
1642enddef ;
1643
1644vardef mfun_path_to_table(expr p) =
1645    "{" & mfun_point_to_table(p,0) for i=1 upto length(p) : & "," & mfun_point_to_table(p,i) endfor & "}"
1646enddef ;
1647
1648vardef mfun_rgb_to_table(expr c) =
1649    "{" & decimal redpart   c &
1650    "," & decimal greenpart c &
1651    "," & decimal bluepart  c &
1652    "}"
1653enddef ;
1654
1655vardef mfun_cmyk_to_table(expr c) =
1656    "{" & decimal cyanpart    c &
1657    "," & decimal magentapart c &
1658    "," & decimal yellowpart  c &
1659    "," & decimal blackpart   c &
1660    "}"
1661enddef ;
1662
1663vardef mfun_grey_to_string(expr n) =
1664    decimal n
1665enddef ;
1666
1667vardef mfun_path_to_string(expr p) =
1668    mfun_point_to_string(p,0) for i=1 upto length(p) : & " " & mfun_point_to_string(p,i) endfor
1669enddef ;
1670
1671vardef mfun_boolean_to_string(expr b) =
1672    if b : "true" else : "false" fi
1673enddef ;
1674
1675vardef tostring primary v =
1676    if     numeric   v : mfun_numeric_to_string(v)
1677    elseif pair      v : mfun_pair_to_string(v)
1678    elseif rgbcolor  v : mfun_rgbcolor_to_string(v)
1679    elseif cmykcolor v : mfun_cmykcolor_to_string(v)
1680    elseif greycolor v : mfun_greycolor_to_string(v)
1681    elseif boolean   v : mfun_boolean_to_string(v)
1682    elseif path      v : mfun_path_to_string(v)
1683    elseif transform v : mfun_transform_to_string(v)
1684    else               : v
1685    fi
1686enddef ;
1687
1688vardef topair primary p =
1689    if     pair    p : "(" & decimal xpart p & "," & decimal ypart p & ")"
1690    elseif numeric p : "(" & decimal       p & "," & decimal       p & ")"
1691    else             : "" fi
1692enddef ;
1693
1694string dq ; dq := char 92 & char 34 ;
1695string sq ; sq := char 92 & char 39 ;
1696
1697permanent dq, sq ;
1698
1699vardef quote     primary s = sq & tostring(s) & sq enddef;
1700vardef quotation primary s = dq & tostring(s) & dq enddef;
1701
1702vardef mfun_tagged_string(expr value) =
1703    if     numeric   value : "1:" & mfun_numeric_to_string(value)
1704    elseif pair      value : "4:" & mfun_pair_to_string(value)
1705    elseif rgbcolor  value : "5:" & mfun_rgbcolor_to_string(value)
1706    elseif cmykcolor value : "6:" & mfun_cmykcolor_to_string(value)
1707    elseif boolean   value : "3:" & mfun_boolean_to_string(value)
1708    elseif path      value : "7:" & mfun_path_to_string(value)
1709    elseif transform value : "8:" & mfun_transform_to_string(value)
1710    else                   : "2:" & value
1711    fi
1712enddef ;
1713
1714permanent tostring, topair, quote, quotation ;
1715
1716% A more flexible variant for passing data to context. We used to construct strings
1717% but running lua is fast enough so we can gain on string construction in metapost
1718% which is also not that efficient.
1719
1720newscriptindex mfid_passvariable ; mfid_passvariable := scriptindex("passvariable") ;
1721newscriptindex mfid_pushvariable ; mfid_pushvariable := scriptindex("pushvariable") ;
1722newscriptindex mfid_popvariable  ; mfid_popvariable  := scriptindex("popvariable") ;
1723
1724def passvariable        (expr key, value) = runscript mfid_passvariable key value ; enddef ;
1725def startpassingvariable(expr key)        = runscript mfid_pushvariable key ; enddef ;
1726def stoppassingvariable                   = runscript mfid_popvariable ; enddef ;
1727
1728def passarrayvariable(expr key)(suffix values)(expr first, last, stp) =
1729    startpassingvariable(key) ;
1730    for i=first step stp until last :
1731        passvariable(i, values[i]) ;
1732    endfor
1733    stoppassingvariable ;
1734enddef ;
1735
1736permanent passvariable, passarrayvariable, startpassingvariable, stoppassingvariable ;
1737
1738% moved here from mp-grap.mpiv
1739
1740% vardef escaped_format(expr s) =
1741%     "" for n=0 upto length(s) : &
1742%         if ASCII substring (n,n+1) of s = 37 :
1743%             "@"
1744%         else :
1745%             substring (n,n+1) of s
1746%         fi
1747%     endfor
1748% enddef ;
1749
1750numeric mfun_esc_b ; % begin
1751numeric mfun_esc_l ; % length
1752string  mfun_esc_s ; % character
1753
1754mfun_esc_s := "%" ; % or: char(37)
1755
1756% this one is the fastest when we have a match
1757
1758% vardef escaped_format(expr s) =
1759%     "" for n=0 upto length(s)-1 : &
1760%       % if ASCII substring (n,n+1) of s = 37 :
1761%         if substring (n,n+1) of s = mfun_esc_s :
1762%             "@"
1763%         else :
1764%             substring (n,n+1) of s
1765%         fi
1766%     endfor
1767% enddef ;
1768
1769% this one wins when we have no match
1770
1771vardef escaped_format(expr s) =
1772    mfun_esc_b := 0 ;
1773    mfun_esc_l := length(s) ;
1774    for n=0 upto mfun_esc_l-1 :
1775      % if ASCII substring (n,n+1) of s = 37 :
1776        if substring (n,n+1) of s = mfun_esc_s :
1777            if mfun_esc_b = 0 :
1778                ""
1779            fi
1780            if n >= mfun_esc_b :
1781                & (substring (mfun_esc_b,n) of s)
1782                exitif numeric begingroup mfun_esc_b := n+1 endgroup ; % hide
1783            fi
1784            & "@"
1785        fi
1786    endfor
1787    if mfun_esc_b = 0 :
1788        s
1789  % elseif mfun_esc_b > 0 :
1790    elseif mfun_esc_b < mfun_esc_l :
1791        & (substring (mfun_esc_b,mfun_esc_l) of s)
1792    fi
1793enddef ;
1794
1795vardef strfmt(expr f, x) = "\MPgraphformat{" & escaped_format(f) & "}{" & mfun_tagged_string(x) & "}" enddef ;
1796vardef varfmt(expr f, x) = "\MPformatted{"   & escaped_format(f) & "}{" & mfun_tagged_string(x) & "}" enddef ;
1797
1798vardef format@#   (expr f, x) = textext@#(strfmt(f, x)) enddef ;
1799vardef formatted@#(expr f, x) = textext@#(varfmt(f, x)) enddef ;
1800
1801permanent format, formatted ;
1802
1803% could be this (something to discuss with alan as it involves graph):
1804%
1805% vardef format   (expr f,x) = lua.mp.graphformat(f,mfun_tagged_string(x) enddef ;
1806% vardef formatted(expr f,x) = lua.mp.format     (f,                   x) enddef ;
1807%
1808% def strfmt = format    enddef ; % old
1809% def varfmt = formatted enddef ; % old
1810
1811% def fmttext = lua.mp.formatted enddef ;
1812
1813% new
1814
1815def fillup   text t = draw t withpostscript "both"     enddef ; % we use draw because we need the proper boundingbox
1816def eofillup text t = draw t withpostscript "eoboth"   enddef ; % we use draw because we need the proper boundingbox
1817def eofill   text t = fill t withpostscript "evenodd"  enddef ;
1818def nofill   text t = fill t withpostscript "collect"  enddef ;
1819def nodraw   text t = draw t withpostscript "collect"  enddef ;
1820def dodraw   text t = draw t withpostscript "flush"    enddef ;
1821%   eodraw   text t = draw t withpostscript "evenodd"  enddef ;
1822def dofill   text t = fill t withpostscript "flush"    enddef ;
1823def eoclip   text t = clip t withpostscript "evenodd"  enddef ;
1824def enfill   text t = fill t withpostscript "envelope" enddef ;
1825
1826permanent fillup, eofillup, eofill, nofill, nodraw, dodraw, dofill, eoclip ;
1827
1828% maybe (saves a bogus path but the problem is that it can influence the dimensions):
1829
1830% def dodraw text t = draw center currentpicture         withpostscript "flush" enddef ;
1831% def dofill text t = fill center currentpicture --cycle withpostscript "flush" enddef ;
1832
1833% def withrule expr r =
1834%     if (t = "even-odd") or (t = "evenodd") : withpostscript "evenodd" fi
1835% enddef ;
1836
1837% A comment will end up on top of the graphic in the output. This can be handy for
1838% locating a graphic: comment("test graphic").
1839
1840% This can be a prescript to currentpicture ... we can actually make
1841%
1842% setprescript  str to picture/path ;
1843% setpostscript str to picture/path ;
1844
1845def special text t = enddef ;
1846
1847def comment expr str =
1848    special "metapost.comment[[" & str & "]]" ;
1849enddef ;
1850
1851vardef report(text t) =
1852    lua.mp.report(t)
1853enddef ;
1854
1855permanent comment, report ;
1856
1857% This nechanism is not really promoted and more an experiment. It scales better than
1858% \METAPOST\ own hash.
1859
1860% todo: use mfid_* cum suis
1861
1862newscriptindex mfid_hash_new     ; mfid_hash_new     := scriptindex("lmt_hash_new") ;     % mkiv compatible
1863newscriptindex mfid_hash_dispose ; mfid_hash_dispose := scriptindex("lmt_hash_dispose") ; % mkiv compatible
1864
1865newscriptindex mfid_hash_reset   ; mfid_hash_dispose := scriptindex("lmt_hash_reset") ;
1866newscriptindex mfid_hash_in      ; mfid_hash_in      := scriptindex("lmt_hash_in") ;
1867newscriptindex mfid_hash_from    ; mfid_hash_from    := scriptindex("lmt_hash_from") ;
1868newscriptindex mfid_hash_to      ; mfid_hash_to      := scriptindex("lmt_hash_to") ;
1869
1870def newhash                          = runscript mfid_hash_new                 enddef ; % optional, returns index
1871def disposehash (expr n)             = runscript mfid_hash_dispose n           enddef ;
1872
1873def resethash   (expr n)             = runscript mfid_hash_reset   n           enddef ;
1874def inhash      (expr n, key)        = runscript mfid_hash_in      n key       enddef ;
1875def fromhash    (expr n, key)        = runscript mfid_hash_from    n key       enddef ;
1876def tohash      (expr n, key, value) = runscript mfid_hash_to      n key value enddef ;
1877
1878string mfun_u_l_h ; mfun_u_l_h := "mfun_u_l_h" ;
1879
1880vardef uniquelist(suffix list) =
1881    % this can be optimized by passing all values at once and returning
1882    % a result but for now this is ok .. we need an undef foo
1883    save i, j ;
1884    if known lis[0] :
1885        i := 0 ;
1886        j := -1 ;
1887    else :
1888        i := 1 ;
1889        j := 0 ;
1890    fi ;
1891  % mfun_u_l_h := runscript mfid_hash_new ; % here mfun_u_l_h has to be a numeric
1892    forever :
1893        exitif unknown list[i] ;
1894        if not (runscript mfid_hash_in (mfun_u_l_h) list[i]) :
1895            j := j + 1 ;
1896            list[j] := list[i] ;
1897            runscript mfid_hash_to (mfun_u_l_h) (j) list[i] ;
1898        fi ;
1899        i := i + 1 ;
1900    endfor ;
1901    for n = j + 1 step 1 until i - 1 :
1902        dispose(list[n])
1903    endfor ;
1904    runscript mfid_hash_dispose mfun_u_l_h ;
1905enddef ;
1906
1907permanent uniquelist ;
1908
1909% This influences the decision for a curve or path segment; 1/4096 is the default but
1910% 10/2048 works quite well.
1911
1912def withtolerance expr n =
1913    withprescript ("tolerance=" & decimal n)
1914enddef ;
1915
1916% fun stuff: randomseed := repeatablerandom("default") ;
1917
1918newscriptindex mfid_repeatablerandom ; mfid_repeatablerandom := scriptindex("repeatablerandom") ;
1919
1920def repeatablerandom = runscript mfid_repeatablerandom enddef ;
1921
1922% somewhat esoteric
1923
1924picture mfun_luminosity_picture ;
1925
1926def registerluminositygroup (expr name) (text t) =
1927    begingroup ;
1928    save  mfun_luminosity_picture ;
1929    picture  mfun_luminosity_picture ;
1930    mfun_luminosity_picture := image ( t ) ;
1931    setgroup mfun_luminosity_picture to boundingbox mfun_luminosity_picture ;
1932    draw mfun_luminosity_picture
1933        withprescript "gs_type=luminosity"
1934        withprescript "gs_action=register"
1935        withprescript "gs_name=" & name
1936    ;
1937    endgroup ;
1938enddef ;
1939
1940def applyluminositygroup (expr name) (text t) =
1941    begingroup ;
1942    save  mfun_luminosity_picture ;
1943    picture  mfun_luminosity_picture ;
1944    mfun_luminosity_picture := image ( t ) ;
1945    setgroup  mfun_luminosity_picture to boundingbox mfun_luminosity_picture ;
1946    draw mfun_luminosity_picture
1947        withprescript "gs_type=luminosity"
1948        withprescript "gs_action=apply"
1949        withprescript "gs_name=" & name
1950    ;
1951    endgroup ;
1952enddef ;
1953
1954def luminositygroup (text a) (text b) =
1955    image (
1956        registerluminositygroup ("default") (a) ;
1957        applyluminositygroup    ("default") (b) ;
1958    )
1959enddef ;
1960
1961def luminosityshade (expr p) (text a) (text b) =
1962    image (
1963        registerluminositygroup ("default") (fill p a) ;
1964        applyluminositygroup    ("default") (fill p b) ;
1965    )
1966enddef ;
1967
1968permanent registerluminositygroup, applyluminositygroup, luminositygroup, luminosityshade ;
1969
1970% message(subpath(2,3) of fullcircle scaled 10cm hascurvature 0.02);
1971% message(subpath(2,3) of fullsquare scaled 10cm hascurvature 0.02);
1972
1973newscriptindex mfid_hascurvature ; mfid_hascurvature := scriptindex("hascurvature") ;
1974
1975primarydef p hascurvature c = runscript mfid_hascurvature (p) (c) enddef ;
1976
1977permanent hascurvature ;
1978
1979newscriptindex mfid_setbackendoption ; mfid_setbackendoption := scriptindex("setbackendoption") ;
1980
1981def setbackendoption = runscript mfid_setbackendoption enddef ;
1982
1983permanent setbackendoption ;
1984
1985newscriptindex mfid_namedstacking ; mfid_namedstacking := scriptindex("namedstacking") ;
1986
1987def namedstacking expr str = runscript mfid_namedstacking str enddef ;
1988
1989def withnamedstacking expr s  =
1990    withstacking if numeric s :
1991        s
1992    elseif string s :
1993        namedstacking s
1994    else :
1995        0
1996    fi
1997enddef ;
1998
1999permanent namedstacking, withnamedstacking ;
2000
2001% \enabledirectives[metapost.annotations=actual]      % default
2002% \enabledirectives[metapost.annotations=alternative]
2003%
2004% fill fullcircle scaled 4cm withannotation "Oh, a circle." ;
2005
2006def withannotation expr txt =
2007    withprescript ("an_text=" & txt)
2008enddef ;
2009
2010permanent withannotation ;
2011