mp-lmtx.mpxl /size: 86 Kb    last modification: 2021-10-28 13:50
1%D \module
2%D   [       file=mp-luas.lmtx,
3%D        version=2019.06.23,
4%D          title=\CONTEXT\ \METAPOST\ graphics,
5%D       subtitle=\LUA,
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
14% This is an experimental module where I test some new interface methods;
15% for real advanced graphics use the luapost module.
16
17if known metafun_loaded_lmtx : endinput ; fi ;
18
19newinternal boolean metafun_loaded_lmtx ; metafun_loaded_lmtx := true ; immutable metafun_loaded_lmtx ;
20
21presetparameters "text" [
22    offset     = 0,
23    strut      = "auto",
24    style      = "",
25    color      = "",
26    text       = "",
27    anchor     = "",
28    format     = "",
29    position   = origin,
30    trace      = false,
31
32    background      = "", % "color",
33    backgroundcolor = "gray",
34] ;
35
36def lmt_text = applyparameters "text" "lmt_do_text" enddef ;
37
38vardef lmt_do_text =
39    image (
40        pushparameters "text" ;
41        save style, anchor, txt, fmt, strt ;
42        string style, anchor, txt, fmt, strt, bgr ;
43        interim textextoffset := getparameter "offset" ;
44        style := getparameter "style" ;
45        anchor := getparameter "anchor" ;
46        strt := getparameter "strut" ;
47        fmt := getparameter "format" ;
48        txt := getparameter "text" ;
49        bgr := getparameter "background" ;
50        if fmt <> "" :
51            txt := "\formatone{" & fmt & "}{" & txt & "}"
52        fi ;
53        if strt = "yes" :
54            txt := "\strut " & txt ;
55        elseif strt = "auto" :
56            txt := "\setstrut\strut " & txt ;
57        fi ;
58        if style <> "" :
59            txt := "\style[" & style & "]{" & txt & "}" ;
60        fi ;
61        if getparameter "trace" :
62            txt := "\ruledhbox{\showstruts" & txt & "}" ;
63        fi ;
64        draw
65            if anchor = "" : thetextext else : scantokens("thetextext." & anchor) fi (
66                txt,
67                getparameter "position"
68            )
69            withcolor getparameter "color" ;
70        if bgr = "color" :
71            addbackground withcolor getparameter "backgroundcolor" ;
72        fi ;
73        popparameters ;
74    )
75enddef ;
76
77presetparameters "grid" [
78    nx = 1, dx = 1,
79    ny = 1, dy = 1,
80] ;
81
82def lmt_grid = applyparameters "grid" "lmt_do_grid" enddef ;
83
84vardef lmt_do_grid =
85    image (
86        save nx; nx := getparameter "grid" "nx" ;
87        save ny; ny := getparameter "grid" "ny" ;
88        save dx; dx := getparameter "grid" "dx" ;
89        save dy; dy := getparameter "grid" "dy" ;
90        for i = 0 step dx until nx :
91            draw ((0,0) -- (0,ny)) shifted (i,0) ;
92        endfor ;
93        for i = 0 step dy until ny :
94            draw ((0,0) -- (nx,0)) shifted (0,i) ;
95        endfor ;
96    )
97enddef ;
98
99def lmt_axis = applyparameters "axis" "lmt_do_axis" enddef ;
100
101presetparameters "axis" [
102    nx = 1, dx = 1, tx = 0, sx = 1, startx = 0,
103    ny = 1, dy = 1, ty = 0, sy = 1, starty = 0,
104
105    samples      = { },
106    list         = { },
107    connect      = false,
108    list         = [ close = false ],
109    samplecolors = { "" },
110    axiscolor    = "",
111    textcolor    = "",
112] ;
113
114vardef lmt_do_axis =
115    image (
116
117        pushparameters "axis" ;
118            save nx, ny, dx, dy, tx, ty ;
119            save c, startx, starty ; string c ;
120            nx := getparameter "nx" ;
121            ny := getparameter "ny" ;
122            dx := getparameter "dx" ;
123            dy := getparameter "dy" ;
124            tx := getparameter "tx" ;
125            ty := getparameter "ty" ;
126            c := getparameter "axiscolor" ;
127            startx := getparameter "startx" ;
128            starty := getparameter "starty" ;
129            draw (startx,starty) -- (startx,ny) withcolor c ;
130            draw (startx,starty) -- (nx,starty) withcolor c ;
131            for i = startx step dx until nx :
132                if (i > startx) or (startx = 0) :
133                    draw ((0,0) -- (0,-2)) shifted (i,starty) withcolor c ;
134                fi ;
135            endfor ;
136            for i = starty step dy until ny :
137                if (i > starty) or (starty = 0) :
138                    draw ((0,0) -- (-2,0)) shifted (startx,i) withcolor c ;
139                fi ;
140            endfor ;
141            if tx <> 0 :
142                c := getparameter "textcolor" ;
143                for i = startx step tx until nx :
144                    if (i > startx) or (startx = 0) :
145                        draw
146                            textext("\strut " & decimal (i)) ysized 2 shifted (i,-4+starty)
147                            withcolor c;
148                    fi ;
149                endfor ;
150            fi ;
151            if ty <> 0 :
152                c := getparameter "textcolor" ;
153                for i = starty step ty until ny :
154                    if (i > starty) or (starty = 0) :
155                        draw
156                            textext.lft("\strut " & decimal (i)) ysized 2 shifted (-3+startx,i)
157                            withcolor c;
158                    fi ;
159                endfor ;
160            fi ;
161
162            if (getparametercount "samples") > 0 :
163                if getparameter "connect" :
164                    for s = 1 upto getparametercount "samples" :
165                        c := getparameter "samplecolors" s ;
166                        draw for i = 1 upto getparametercount "samples" s :
167                            if (i > 1) : -- fi (i, getparameter "samples" s i)
168                        endfor
169                        withcolor c ;
170                    endfor ;
171                else :
172                    for s = 1 upto getparametercount "samples" :
173                        c := getparameter "samplecolors" s ;
174                        for i = 1 upto getparametercount "samples" s :
175                            draw (i, getparameter "samples" s i)
176                            withcolor c ;
177                        endfor ;
178                    endfor ;
179                fi ;
180            fi ;
181
182            if (getparametercount "list") > 0 :
183
184                save p, ts, a, d ; path p ; numeric ts ; pair a, d ;
185
186                ts := (getparameter "sy") / 20 ;
187
188                pushparameters "list" ;
189                    for s = 1 upto getparametercount :
190                        pushparameters s ;
191
192                            c := getparameter "color" ;
193
194                            % p := for i = 1 upto getparametercount "points":
195                            %     if (i > 1) : -- fi (getparameter "points" i)
196                            % endfor
197                            % if (getparameterdefault "close" false) : -- cycle fi ;
198
199                            % this can become:
200
201                            % p := if (getparameterdefault "close" false) :
202                            %   % getparameterpath "points" "--" true ;
203                            %     getparameterpath "points" true ;
204                            % else :
205                            %   % getparameterpath "points" "--" false ;
206                            %     getparameterpath "points" ;
207                            % fi ;
208
209                            % p := getparameterpath "points" if (getparameterdefault "close" false) : true fi ;
210
211                            p := getparameterpath "points" (getparameterdefault "close" false) ;
212                          % p := getparameterpath "points" getparameterdefault "close" false ;
213
214                            draw p withcolor c ;
215
216                            pushparameters "labels" ;
217                                if (getparametercount) > 0 :
218                                    for i = 1 upto getparametercount:
219                                        n := i - 1 ;
220                                        a := point n of p ;
221                                        d := direction n of p ;
222                                        draw
223                                            textext(getparametertext i true)
224                                            ysized ts
225                                            shifted (a + .5 * unitvector(d) rotated 90) ;
226                                    endfor ;
227                                fi ;
228                            popparameters ;
229
230                            pushparameters "texts" ;
231                                if (getparametercount) > 0 :
232                                    for i = 1 upto getparametercount :
233                                        n := i + 0.5 ;
234                                        a := point n of p ;
235                                        d := direction n of p ;
236                                        draw textext.d(getparametertext i true)
237                                            if d < left : rotated 180 shifted (0,-5) else : shifted (0,5) fi
238                                            ysized ts
239                                            shifted a
240                                            if d <> origin :
241                                                rotatedaround(a,angle(d))
242                                            fi ;
243                                    endfor ;
244                                fi ;
245                            popparameters ;
246
247                        popparameters ;
248                    endfor ;
249                popparameters ;
250            fi ;
251
252        popparameters ;
253
254    )
255        xyscaled(getparameter "axis" "sx",getparameter "axis" "sy")
256enddef ;
257
258presetparameters "outline" [
259    text          = "",
260    kind          = "draw",
261    fillcolor     = "",
262    drawcolor     = "",
263    rulethickness = 1/10,
264    align         = "",
265    style         = "",
266    width         = 0,
267] ;
268
269def lmt_outline = applyparameters "outline" "lmt_do_outline" enddef ;
270
271vardef lmt_do_outline =
272    image ( normaldraw image (
273        save kind  ; string kind   ; kind  := getparameter "outline" "kind"  ;
274        save align ; string align  ; align := getparameter "outline" "align" ;
275        save style ; string style  ; style := getparameter "outline" "style" ;
276        save width ; numeric width ; width := getparameter "outline" "width" ;
277        if kind = "draw" :
278            kind := "d" ;
279        elseif kind = "fill" :
280            kind := "f" ;
281        elseif kind = "both" :
282            kind := "b" ;
283        elseif kind = "reverse" :
284            kind := "r" ;
285        elseif kind = "fillup" :
286            kind := "u" ;
287        fi ;
288        currentoutlinetext := currentoutlinetext + 1 ;
289        lua.mp.mf_outline_text(
290            currentoutlinetext,
291            if align = "" :
292                getparameter "outline" "text",
293            else :
294                "\framed[align={" & align & "}"
295                if width > 0 :
296                    & ",width=" & decimal width & "bp"
297                fi
298                if style <> "" :
299                    & ",foregroundstyle={" & style & "}"
300                fi
301                & ",offset=none,frame=off]{"
302                & (getparameter "outline" "text")
303                & "}",
304            fi,
305            kind
306        ) ;
307        save currentpen; pen currentpen ;
308        pickup pencircle scaled getparameter "outline" "rulethickness"  ;
309        if kind = "f" :
310            mfun_do_outline_text_set_f (
311                withcolor getparameter "outline" "fillcolor"
312            );
313        elseif kind = "d" :
314            mfun_do_outline_text_set_d (
315                withcolor getparameter "outline" "drawcolor"
316            );
317        elseif kind = "b" :
318            mfun_do_outline_text_set_b (
319                withcolor getparameter "outline" "fillcolor"
320            ) (
321                withcolor getparameter "outline" "drawcolor"
322            );
323        elseif kind = "u" :
324            mfun_do_outline_text_set_u (
325                withcolor getparameter "outline" "fillcolor"
326            );
327        elseif kind = "r" :
328            mfun_do_outline_text_set_r (
329                withcolor getparameter "outline" "drawcolor"
330            ) (
331                withcolor getparameter "outline" "fillcolor"
332            ) ;
333        elseif kind = "p" :
334            mfun_do_outline_text_set_p ;
335        else :
336            mfun_do_outline_text_set_n (
337                % what to use here
338            );
339        fi ;
340        lua.mp.mf_get_outline_text(currentoutlinetext) ;
341    ) )
342enddef ;
343
344presetparameters "followtext" [
345    text          = "",
346    spread        = true,
347    trace         = false,
348    reverse       = false,
349    autoscaleup   = "no",
350    autoscaledown = "no",
351    path          = (fullcircle),
352] ;
353
354def lmt_followtext = applyparameters "followtext" "lmt_do_followtext" enddef ;
355
356vardef lmt_do_followtext =
357    image (
358        pushparameters "followtext" ;
359        save scale_up   ; string scale_up   ; scale_up   := getparameter "autoscaleup" ;
360        save scale_down ; string scale_down ; scale_down := getparameter "autoscaledown" ;
361        save followtextalternative   ; followtextalternative   := if getparameter "spread" : 1 else : 0 fi ;
362        save autoscaleupfollowtext   ; autoscaleupfollowtext   := if scale_up   = "yes" : 1 elseif scale_up   = "max" : 2 else : 0 fi ;
363        save autoscaledownfollowtext ; autoscaledownfollowtext := if scale_down = "yes" : 1 elseif scale_down = "max" : 2 else : 0 fi ;
364      % save tracingfollowtext       ; tracingfollowtext          := if getparameter "trace"  : 1 else : 0 fi ;
365        interim tracingfollowtext := if getparameter "trace" : 1 else : 0 fi ;
366        draw followtext (
367            if (getparameter "reverse") : reverse fi (getparameter "path"),
368            (getparameter "text")
369        ) ;
370        popparameters ;
371    )
372enddef ;
373
374presetparameters "arrow" [
375    path        = origin,
376  % pen         = ...,
377    kind        = "fill",
378    dimple      = 1/5,
379    scale       = 3/4,
380    penscale    = 3,
381    length      = 4,
382    angle       = 45,
383    location    = "end",    % middle both
384    alternative = "normal", % dimpled curved
385    percentage  = 50,
386    headonly    = false,
387] ;
388
389def lmt_arrow = applyparameters "arrow" "lmt_do_arrow" enddef ;
390
391vardef lmt_do_arrow =
392    image (
393        pushparameters "arrow" ;
394        save a ; string a ; a := getparameter "alternative" ;
395        save l ; string l ; l := getparameter "location" ;
396        save k ; string k ; k := getparameter "kind" ;
397        save p ; path   p ; p := getparameter "path" ;
398        interim ahvariant := if a = "dimpled" : 1 elseif a = "curved" : 2 else : 0 fi ;
399        interim ahdimple  := getparameter "dimple" ;
400        interim ahscale   := getparameter "scale" ;
401        interim ahangle   := getparameter "angle" ;
402        interim ahlength  := getparameter "length" ;
403        if not getparameter "headonly" :
404            draw p ;
405        fi ;
406        if hasparameter "pen" :
407            % a cheat: we should have a type check in lua
408            if hasoption "pen" "auto" :
409                ahlength := (getparameter "penscale") * boundingradius(currentpen) ;
410            else :
411                ahlength := (getparameter "penscale") * boundingradius(getparameterpen "pen") ;
412            fi ;
413        fi ;
414        if k = "draw" : draw elseif k = "both" : filldraw else : fill fi
415        if l = "middle" :
416            midarrowhead p ;
417        elseif l = "percentage" :
418            arrowheadonpath (p, (getparameter "percentage")/100) ;
419        elseif l = "both" :
420            arrowhead p ;
421            if k = "draw" : draw elseif k = "both" : filldraw else : fill fi
422            arrowhead reverse p ;
423        else :
424            arrowhead p ;
425        fi ;
426        popparameters ;
427    )
428enddef ;
429
430% from dum
431
432presetparameters "placeholder" [
433    color       = "red",
434    width       = 1,
435    height      = 1,
436    reduction   = 0,
437    alternative = "circle",
438] ;
439
440def lmt_placeholder = applyparameters "placeholder" "lmt_do_placeholder" enddef ;
441
442def lmt_do_placeholder =
443    begingroup ;
444    pushparameters "placeholder" ;
445    save w, h, d, r, p, c, b, s, q, a ;
446    numeric w, h, d, r ; path p ; string s, a ;
447    s := getparameter "color" ;
448    w := getparameter "width" ;
449    h := getparameter "height" ;
450    r := getparameter "reduction" ;
451    a := getparameter "alternative" ;
452    d := max(w,h) ;
453    if cmykcolor resolvedcolor(s) :
454        cmykcolor c, b ; b := (0,0,0,0)
455    else :
456        color c, b ; b := (1,1,1)
457    fi ;
458    c := resolvedcolor(s) ;
459    p := unitsquare xyscaled (w,h) ;
460    fill p withcolor r[.5c,b] ;
461    if a = "square" :
462        vardef q = fullsquare enddef ;
463    elseif a = "triangle" :
464        vardef q = fulltriangle rotated (90 * round(uniformdeviate(4))) enddef ;
465    else :
466        vardef q = fullcircle enddef ;
467    fi ;
468    for i := 1 upto 60 :
469        fill q
470            scaled (d/5 randomized (d/5))
471            shifted (center p randomized (d))
472            withcolor r[c randomized(.3,.9),b] ;
473    endfor ;
474    clip currentpicture to p ;
475    popparameters ;
476    endgroup ;
477enddef ;
478
479% maybe:
480
481vardef lmt_connected(text t) =
482    save p ; path p ;
483    p := origin t ;
484    subpath (1,length(p)) of p
485enddef ;
486
487def lmt_connection expr t =
488    -- t
489enddef ;
490
491% also (todo)
492
493% % draw lmt_path [
494% %     points   = [ color = "darkred",    size  = 6 ],
495% %     controls = [ color = "darkgreen",  size  = 4 ],
496% %     lines    = [ color = "darkgray",   size  = 1 ],
497% %     shape    = [ color = "middlegray", size  = 8 ],
498% %     labels   = [ ],
499% %     path     = ((1cm,1cm) -- (1.5cm,1.5cm) .. (2cm,0cm) .. cycle)
500% % ] ;
501%
502% presetparameters "path" [
503%     labels    = [
504%         color = "",
505%         size  = 1
506%     ],
507%     controls  = [
508%         color = "black",
509%         size  = 2.5
510%     ],
511%     lines  = [
512%         color = "middlegray",
513%         size  = 1
514%     ],
515%     points    = [
516%         color = "black",
517%         size  = 4
518%     ],
519%     path      = [
520%         color = "lightgray",
521%         size  = 5,
522%         path  = origin
523%     ]
524% ] ;
525%
526% def lmt_path = applyparameters "path" "lmt_do_path" enddef ;
527%
528% vardef lmt_do_path =
529%     image (
530%         % This one is not that efficient ... we can better inline the drawing routines here, but
531%         % it's just an interfacing test after all.
532%             if hasparameter "path" "path" :
533%             save p ; path p ; p := getparameter "path" "path" ;
534%             drawpath p
535%                 withpen pencircle scaled (drawoptionsfactor * getparameterdefault "path" "shape" "size" "*")
536%                 withcolor getparameterdefault "path" "shape" "color" "*"
537%             ;
538%             if hasparameter "path" "controls" :
539%                 drawcontrollines  p
540%                     withpen pencircle scaled (drawoptionsfactor * getparameterdefault "path" "lines" "size" "*" )
541%                     withcolor getparameterdefault "path" "lines" "color" "*"
542%                 ;
543%                 drawcontrolpoints p
544%                     withpen pencircle scaled (drawoptionsfactor * getparameterdefault "path" "controls" "size" "*")
545%                     withcolor getparameterdefault "path" "controls" "color" "*"
546%                 ;
547%             fi ;
548%             if hasparameter "path" "points" :
549%                 drawpoints p
550%                     withpen pencircle scaled (drawoptionsfactor * getparameterdefault "path" "points" "size" "*")
551%                     withcolor getparameterdefault "path" "points" "color" "*"
552%                 ;
553%                 if hasparameter "path" "labels" :
554%                     drawpointlabels p
555%                         withcolor getparameterdefault "path" "labels" "color" "*"
556%                     ;
557%                 fi ;
558%             fi ;
559%         fi ;
560%     )
561% enddef ;
562
563% Here we use nodraw and dodraw to create efficient axis ticks. Yet another demo
564% of coding.
565
566presetparameters "function" [
567    sx          = 1mm,
568    sy          = 1mm,
569    offset      = 0,
570    xmin        = 1,
571    xmax        = 1,
572    xstep       = 1,
573    xsmall      = 0,
574    xlarge      = 0,
575    xlabels     = "no",
576    xticks      = "bottom", % top bottom middle
577    xcaption    = "",
578    ymin        = 1,
579    ymax        = 1,
580    ystep       = 1,
581    ysmall      = 0,
582    ylarge      = 0,
583  % xfirst      = 0,
584  % xlast       = 0,
585  % yfirst      = 0,
586  % ylast       = 0,
587    ylabels     = "no",
588    yticks      = "left", % left right middle
589    ycaption    = "",
590    code        = "",
591    close       = false,
592    shape       = "curve",
593    fillcolor   = "",
594    drawsize    = 1,
595    drawcolor   = "",
596    frame       = "",     % yes ticks
597    linewidth   = .05mm,
598    pointsymbol = "",
599    pointsize   = 2,
600    pointcolor  = "",
601    xarrow      = "",
602    yarrow      = "",
603    reverse     = false,
604] ;
605
606def lmt_function = applyparameters "function" "lmt_do_function" enddef ;
607
608vardef lmt_do_function_p(expr xmin, xmax, xstep, code, shape, close, fcolor, dsize, dcolor, psymbol, psize, pcolor) =
609    save p, q ; path p, q ;
610    p := lua.mp.lmt_function_x(xmin,xmax,xstep,code,shape) ;
611    if close :
612        q := (xmin,0) -- p -- (xmax,0) -- cycle ;
613        fill q withcolor fcolor ;
614    else :
615        draw p withpen currentpen scaled dsize withcolor dcolor
616            ;
617    fi ;
618    if psize > 0 :
619        if psymbol = "dot" :
620            draw image (
621                for i = 0 upto length(p) :
622                    draw point i of p ;
623                endfor ;
624            ) withpen currentpen scaled psize withcolor pcolor ;
625        fi ;
626    fi ;
627enddef ;
628
629vardef lmt_do_function =
630    image (
631        pushparameters "function" ;
632        save sx, sy, lw, tl, tr, ts, tt, currentpen ; transform tr, tt ; pen currentpen ;
633        sx := getparameter "sx" ;
634        sy := getparameter "sy" ;
635        lw := getparameter "linewidth" ;
636        tl := 1/20 ; % tick length
637        ts := 1/10 ; % text scale
638        tr := identity xyscaled(10/sx,10/sy) ;
639        tt := identity xyscaled(ts/sx,ts/sy) ;
640        pickup pencircle xyscaled(lw/sx,lw/sy) ;
641        draw image (
642            save xmin, xmax, xstep, xsmall, xlarge, ymin, ymax, ystep, ysmall, ylarge, p ;
643            save code, option, txl, txs, tyl, tys, swap ;
644            string code, option ;
645            path txl, txs, tyl, tys ; boolean swap ;
646            picture p ;
647
648            xmin    := getparameter "xmin" ;
649            xmax    := getparameter "xmax" ;
650            xstep   := getparameter "xstep" ;
651            xsmall  := getparameter "xsmall" ;
652            xlarge  := getparameter "xlarge" ;
653            ymin    := getparameter "ymin" ;
654            ymax    := getparameter "ymax" ;
655            ystep   := getparameter "ystep" ;
656            ysmall  := getparameter "ysmall" ;
657            ylarge  := getparameter "ylarge" ;
658            code    := getparameter "code" ;
659            swap    := getparameter "reverse" ;
660
661            p := image (
662
663                if (getparametercount "functions") > 0 :
664                    for s = 1 upto getparametercount "functions" :
665                        pushparameters "functions" s ;
666                        lmt_do_function_p (
667                            getparameter "xmin",
668                            getparameter "xmax",
669                            getparameter "xstep",
670                            getparameter "code",
671                            getparameter "shape",
672                            getparameter "close",
673                            getparameter "fillcolor",
674                            getparameter "drawsize",
675                            getparameter "drawcolor",
676                            getparameter "pointsymbol",
677                            getparameter "pointsize",
678                            getparameter "pointcolor"
679                        ) ;
680                        popparameters ;
681                    endfor ;
682                elseif code <> "" :
683                    lmt_do_function_p (
684                        getparameter "xmin",
685                        getparameter "xmax",
686                        getparameter "xstep",
687                        getparameter "code",
688                        getparameter "shape",
689                        getparameter "close",
690                        getparameter "fillcolor",
691                        getparameter "drawsize",
692                        getparameter "drawcolor",
693                        getparameter "pointsymbol",
694                        getparameter "pointsize",
695                        getparameter "pointcolor"
696                    ) ;
697                fi ;
698            ) ;
699
700            if not swap : draw p fi ;
701
702            option := getparameter "xticks" ;
703            if option = "top" :
704                txs := (0,0) -- (0,tl) ;
705            elseif option = "bottom" :
706                txs := (0,-tl) -- (0,0) ;
707            else :
708                txs := (0,-tl) -- (0,tl) ;
709            fi ;
710
711            option := getparameter "yticks" ;
712            if option = "left" :
713                tys := (-tl,0) -- (0,0) ;
714            elseif option = "right" :
715                tys := (0,0) -- (tl,0) ;
716            else :
717                tys := (-tl,0) -- (tl,0) ;
718            fi ;
719
720            txs := txs transformed tr ;
721            tys := tys transformed tr ;
722            txl := txs scaled 2 ;
723            tyl := tys scaled 2 ;
724
725            % this arrow head scaling is for Alan to sort out ...
726
727            xmin := getparameterdefault "xfirst" xmin ;
728            xmax := getparameterdefault "xlast"  xmax ;
729            ymin := getparameterdefault "yfirst" ymin ;
730            ymax := getparameterdefault "ylast"  ymax ;
731
732            if hasoption "frame" "ticks,sticks" :
733                if xsmall > 0 :
734                    if hasoption "frame" "horizontal" :
735                        for i = ymin step ((ymax-ymin)/ysmall) until ymax :
736                            draw (xmin,i) -- (xmax,i) ;
737                        endfor ;
738                        dodraw (xmin,ymin) ; % flush snippets
739                    fi ;
740                fi ;
741                if ysmall > 0 :
742                    if hasoption "frame" "vertical" :
743                        for i = xmin step ((xmax-xmin)/xsmall) until xmax :
744                            draw (i,ymin) -- (i,ymax) ;
745                        endfor ;
746                        dodraw (xmin,ymin) ; % flush snippets
747                    fi ;
748                fi ;
749            fi ;
750
751            option := getparameter "xarrow" ;
752            if option = "yes" :
753                save ahlength ; ahlength  := tl ;
754                % save ahangle  ; ahangle   := 100/sy ;
755                drawarrow (xmin,0) -- (xmax,0) ;
756            else :
757                draw (xmin,0) -- (xmax,0) ;
758            fi ;
759
760            option := getparameter "yarrow" ;
761            if option = "yes" :
762                save ahlength ; ahlength := tl ;
763                % save ahangle  ; ahangle  := 100/sx ;
764                drawarrow (xmin,ymin) -- (xmin,ymax) ;
765            else :
766                draw (xmin,ymin) -- (xmin,ymax) ;
767            fi ;
768
769            if hasoption "frame" "yes" :
770                draw (xmin,ymin) -- (xmax,ymin) -- (xmax,ymax) -- (xmin,ymax) -- cycle ;
771            fi ;
772
773            if hasoption "frame" "ticks,sticks" :
774                if xsmall > 0 :
775                    if hasoption "frame" "horizontal" :
776                        for i = ymin step ((ymax-ymin)/ysmall) until ymax :
777                            draw (xmin,i) -- (xmax,i) ;
778                        endfor ;
779                    fi ;
780                    if hasoption "frame" "bottom" :
781                        txs := ((0,0) -- (0,tl)) if hasoption "frame" "sticks" : rotated 180 fi ;
782                        txs := txs transformed tr ;
783                        for i = xmin step ((xmax-xmin)/xsmall) until xmax :
784                            nodraw txs shifted (i,ymin) ;
785                        endfor ;
786                    fi ;
787                    if hasoption "frame" "top" :
788                        txs := (0,0) -- (0,-tl) if hasoption "frame" "sticks" : rotated 180 fi ;
789                        txs := txs transformed tr ;
790                        for i = xmin step ((xmax-xmin)/xsmall) until xmax :
791                            nodraw txs shifted (i,ymax) ;
792                        endfor ;
793                    fi ;
794                    dodraw (xmin,ymin) ; % flush snippets
795                fi ;
796                if ysmall > 0 :
797                    if hasoption "frame" "vertical" :
798                        for i = xmin step ((xmax-xmin)/xsmall) until xmax :
799                            draw (i,ymin) -- (i,ymax) ;
800                        endfor ;
801                    fi ;
802                    if hasoption "frame" "left" :
803                        tys := (0,0) -- (tl,0) if hasoption "frame" "sticks" : rotated 180 fi ;
804                        tys := tys transformed tr ;
805                        for i = ymin step ((ymax-ymin)/ysmall) until ymax :
806                            nodraw tys shifted (xmin,i) ;
807                        endfor ;
808                    fi ;
809                    if hasoption "frame" "right" :
810                        tys := (0,0) -- (-tl,0) if hasoption "frame" "sticks" : rotated 180 fi ;
811                        tys := tys transformed tr ;
812                        for i = ymin step ((ymax-ymin)/ysmall) until ymax :
813                            nodraw tys shifted (xmax,i) ;
814                        endfor ;
815                    fi ;
816                    dodraw (xmin,ymin) ; % flush snippets
817                fi ;
818            fi ;
819
820            if xsmall > 0 :
821                for i = xmin step xsmall until xmax :
822                    nodraw txs shifted (i,0) ;
823                endfor ;
824            fi ;
825
826            if xlarge > 0 :
827                for i = xmin step xlarge until xmax :
828                    nodraw txl shifted (i,0) ;
829                endfor ;
830                dodraw (xmin,0) ; % flush snippets
831            elseif xsmall > 0 :
832                dodraw (xmin,0) ; % flush snippets
833            fi ;
834
835            if ysmall > 0 :
836                for i = ymin step ysmall until ymax :
837                    nodraw tys shifted (xmin,i) ;
838                endfor ;
839            fi ;
840
841            if ylarge > 0 :
842                for i = ymin step ylarge until ymax :
843                    nodraw tyl shifted (xmin,i) ;
844                endfor ;
845                dodraw (xmin,ymin) ; % flush snippets
846            elseif ysmall > 0 :
847                dodraw (xmin,ymin) ; % flush snippets
848            fi ;
849
850            if swap : draw p fi ;
851
852            if xlarge > 0 :
853                option := getparameter "xlabels" ;
854                if option <> "no" :
855                    for i = xmin step xlarge until xmax :
856                        if ((i <> 0) and ((option <> "nolimits") or ((i > xmin) and (i < xmax)))) :
857                            draw textext.bot(decimal i) transformed tt
858                                shifted (i,1.25*(ypart point 0 of txl)) ;
859                        fi ;
860                    endfor ;
861                fi ;
862            fi ;
863
864            if ylarge > 0 :
865                option := getparameter "ylabels" ;
866                if option <> "no" :
867                    for i = ymin step ylarge until ymax :
868                        if ((i <> 0) and ((option <> "nolimits") or ((i > ymin) and (i < ymax)))) :
869                            draw textext.lft(decimal i) transformed tt
870                                shifted (xmin+1.25*(xpart point 0 of tyl),i) ;
871                        fi ;
872                    endfor ;
873                fi ;
874            fi ;
875
876            option := getparameter "xcaption" ;
877            if (option <> "") :
878                draw textext.bot(option) transformed tt
879                    shifted (xmin,-tl)
880                    shifted center bottomboundary currentpicture ;
881            fi ;
882
883            option := getparameter "ycaption" ;
884            if (option <> "") :
885                draw textext.lft(option) transformed tt
886                    shifted (xmin-tl,0)
887                    shifted center leftboundary currentpicture ;
888            fi ;
889        )
890
891        xyscaled(sx,sy) ;
892
893        setbounds currentpicture to
894            boundingbox currentpicture
895            enlarged (getparameter "offset") ;
896
897        popparameters ;
898    )
899enddef ;
900
901% Don't use this one!
902
903presetparameters "mesh" [
904    trace = false,
905    auto  = false,
906    step  = 0.05,
907  % box   = ...
908  % paths = { ..., ..., ... }
909] ;
910
911def lmt_mesh = applyparameters "mesh" "lmt_do_mesh" enddef ;
912
913vardef lmt_do_mesh =
914    image (
915        save p, b ; path p, b ;
916        pushparameters "mesh" ;
917        if getparameter "auto" :
918            b := if hasparameter "box" : getparameter "box" else : OverlayBox fi ;
919            for i=1 upto getparametercount "paths" :
920                p := getparameter "paths" i ;
921                p := meshed(p if not cycle p : -- cycle fi,b,getparameter "step") ;
922                if getparameter "trace" :
923                    draw p ;
924                fi ;
925                runscript("mp.lmt_mesh_update()") i p ;
926            endfor ;
927        elseif getparameter "trace" :
928            for i=1 upto getparametercount "paths" :
929                p := getparameter "paths" i ;
930                draw p if not cycle p : -- cycle fi ;
931            endfor ;
932        fi ;
933        popparameters ;
934        runscript("mp.lmt_mesh_set()") ;
935    )
936enddef ;
937
938vardef mfun_meshed_clipped(expr pat, box, pct) =
939    pp := point (arctime pct of pat) of pat ;
940    if (ypart pp <= lly) or (ypart pp >= ury) or (xpart pp <= llx) or (xpart pp >= urx) :
941        (cp -- pp) intersection_point bb
942    else :
943        pp
944    fi
945enddef ;
946
947vardef mfun_meshed_clipped(expr pat, box, pct) =
948    pp := point (arctime pct of pat) of pat ;
949    if     ypart pp <= lly :
950        if xpart pp <= llx :
951            (llx, lly)
952        elseif xpart pp >= urx :
953            (urx, lly)
954        else :
955            (xpart pp, lly)
956        fi
957    elseif ypart pp >= ury :
958        if xpart pp <= llx :
959            (llx, ury)
960        elseif xpart pp >= urx :
961            (urx, ury)
962        else :
963            (xpart pp, ury)
964        fi
965    elseif xpart pp <= llx :
966        (llx, ypart pp)
967    elseif xpart pp >= urx :
968        (urx, ypart pp)
969    else :
970        pp
971    fi
972enddef ;
973
974vardef meshed(expr pth, box, stp) =
975    begingroup
976    save cb, cp, llx, lly, urx, ury, pp, lp, bb ; pair cb, cp, pp ; path bb ;
977    bb := box enlarged -1/10;
978    cb := center bb ;
979    cp := center pth ;
980    llx := xpart llcorner bb;
981    lly := ypart llcorner bb;
982    urx := xpart urcorner bb;
983    ury := ypart urcorner bb;
984    lp := arclength pth ;
985    for i=stp step stp until 1+stp/2 :
986        cp --
987        mfun_meshed_clipped(pth,bb,lp*(i-stp)) --
988        mfun_meshed_clipped(pth,bb,lp*(i    )) --
989        cp --
990    endfor cycle
991    endgroup
992enddef ;
993
994vardef OverlayMesh(expr p, s) =
995    lmt_mesh [ paths = { meshed(p,OverlayBox,s) } ]
996enddef ;
997
998permanent meshed, OverlayMesh ;
999
1000% charts
1001
1002presetparameters "chart" [
1003    originsize      = 1mm,
1004    trace           = false,
1005    showlabels      = true,
1006    center          = false,
1007
1008    samples         = { },
1009
1010    cumulative      = false,
1011    percentage      = false,
1012    maximum         = 0,
1013    distance        = 1mm,
1014
1015  % labels          = { },
1016    labelstyle      = "",
1017    labelformat     = "",
1018  % labelstrut      = "auto",
1019  % labelanchor     = "",
1020  % labeloffset     = 0,
1021    labelfraction   = 0.8,
1022    labelcolor      = "",
1023
1024    backgroundcolor = "",
1025    drawcolor       = "white",
1026    fillcolors      = { % use color palet
1027        "darkred", "darkgreen", "darkblue",
1028        "darkyellow", "darkmagenta", "darkcyan",
1029        "darkgray"
1030    },
1031    colormode       = "global",
1032
1033    linewidth       = .25mm,
1034
1035    legendcolor     = "",
1036    legendstyle     = "",
1037    legend          = { },
1038] ;
1039
1040presetparameters "chart:circle" "chart" [
1041    height      = 5cm,
1042    width       = 5mm,
1043    labelanchor = "",
1044    labeloffset = 0,
1045    labelstrut  = "no",
1046] ;
1047
1048presetparameters "chart:histogram" "chart" [
1049    height      = 5cm,
1050    width       = 5mm,
1051    labelanchor = "bot",
1052    labeloffset = 1mm,
1053    labelstrut  = "auto",
1054] ;
1055
1056presetparameters "chart:bar" "chart" [
1057    height      = 5mm,
1058    width       = 5cm,
1059    labelanchor = "lft",
1060    labeloffset = 1mm,
1061    labelstrut  = "no",
1062] ;
1063
1064def lmt_chart_circle    = applyparameters "chart:circle"    "lmt_do_chart_circle"    enddef ;
1065def lmt_chart_histogram = applyparameters "chart:histogram" "lmt_do_chart_histogram" enddef ;
1066def lmt_chart_bar       = applyparameters "chart:bar"       "lmt_do_chart_bar"       enddef ;
1067
1068def lmt_do_chart_start (expr what) =
1069    pushparameters what ;
1070    save width, height, distance, linewidth, labelgap, labelfraction, value, nofsamples, nofsamplesets ;
1071    save fillcolor, drawcolor, labelcolor, labelstyle, labelformat, labelstrut, labelanchor, colormode ;
1072    string fillcolor, drawcolor, labelcolor, labelstyle, labelformat, labelstrut, labelanchor, colormode ;
1073    if hasparameter "sampleset" :
1074        setluaparameter "what" "samples" (getparameter "sampleset") ;
1075    fi ;
1076    height := getparameter "height" ;
1077    width := getparameter "width" ;
1078    distance := getparameter "distance" ;
1079    linewidth := getparameter "linewidth" ;
1080    drawcolor := getparameter "drawcolor" ;
1081    colormode :=  getparameter "colormode" ;
1082    labelcolor := getparameter "labelcolor" ;
1083    labelgap := getparameter "labeloffset" ;
1084    labelstyle := getparameter "labelstyle" ;
1085    labelformat := getparameter "labelformat" ;
1086    labelstrut := getparameter "labelstrut" ;
1087    labelanchor := getparameter "labelanchor" ;
1088    labelfraction := getparameter "labelfraction" ;
1089    nofsamplesets := getparametercount "samples" ;
1090    nofsamples := getmaxparametercount "samples" ;
1091enddef ;
1092
1093def lmt_do_chart_stop =
1094    if getparameter "center" :
1095        currentpicture := currentpicture shifted - center currentpicture ;
1096    fi
1097    if (getparameter "backgroundcolor") <> "" :
1098        addbackground withcolor getparameter "backgroundcolor" ;
1099    fi
1100    if getparameter "trace" :
1101        save b ; path b ; b := boundingbox currentpicture ;
1102        draw image (
1103            draw fullcircle scaled 1mm ;
1104            draw b
1105        )
1106        dashed evenly scaled 1/4
1107        withpen pencircle scaled .125mm
1108        withcolor "darkgray" ;
1109    fi
1110    popparameters ;
1111enddef ;
1112
1113vardef lmt_do_chart_text(expr s, i, value) =
1114    lmt_text [
1115        style      = labelstyle,
1116        format     = labelformat,
1117        strut      = labelstrut,
1118        anchor     = labelanchor,
1119        offset     = labelgap,
1120        color      = labelcolor,
1121        text       = (getparameterdefault "labels" s i (decimal value))
1122        background = "",
1123    ]
1124enddef ;
1125
1126def lmt_do_chart_legend =
1127    n := getparametercount "legend" ;
1128    if n > 0 :
1129        save dx, dy, p, l, w, o, d, ddy ; picture l ;
1130        dx := xpart urcorner currentpicture + EmWidth ;
1131        dy := ypart urcorner currentpicture ;
1132        labelcolor := getparameter "legendcolor" ;
1133        labelstyle := getparameter "legendstyle" ;
1134        w := 2EmWidth ;
1135        o := .25EmWidth ;
1136        d := ExHeight ;
1137        ddy := .8LineHeight ;
1138        for i=1 upto n :
1139            dy := dy - ddy ;
1140            l := lmt_text [
1141                text       = getparameter "legend" i,
1142                anchor     = "rt"
1143                style      = labelstyle,
1144                color      = labelcolor,
1145                background = "",
1146            ] ;
1147            fill leftboundary l rightenlarged w
1148                shifted (dx,dy+d)
1149                withcolor getparameter "fillcolors" i ;
1150            draw l
1151                shifted (dx+w+o,dy+d) ;
1152        endfor ;
1153    fi ;
1154enddef ;
1155
1156vardef lmt_do_chart_circle =
1157    image (
1158        lmt_do_chart_start("chart:circle") ;
1159        if (nofsamplesets > 0) and (nofsamples > 0) :
1160            nofsamplesets := 1 ;
1161            save p, r, s, first, last, total, factor, n, percentage ;
1162            path p, r, s[] ; boolean percentage ;
1163            percentage := getparameter "percentage" ;
1164            total := 0 ;
1165            for i = 1 upto nofsamples :
1166                total := total + getparameter "samples" (1) i ; % () is needed else 1i
1167            endfor ;
1168            factor := 100/total ;
1169            first := 0 ;
1170            p := fullcircle ysized (height) ;
1171            r := origin -- (2*height,0) ;
1172            for i = 1 upto nofsamples :
1173                fillcolor := getparameter "fillcolors" i ;
1174                value := (getparameter "samples" (1) i) * factor ;
1175                last := first + (360 / 100) * value ;
1176                s[i] := ((p cutbefore (r rotated first)) cutafter (r rotated last)) ;
1177                fill origin -- s[i] -- cycle withcolor fillcolor ;
1178                first := last ;
1179            endfor ;
1180            if linewidth > 0 :
1181                if drawcolor = "" :
1182                    drawcolor := backgroundcolor ;
1183                fi ;
1184                for i = 1 upto nofsamples :
1185                    interim linecap := butt ;
1186                    draw origin -- (point 0            of s[i]) withpen pencircle scaled linewidth withcolor drawcolor ;
1187                    draw origin -- (point length(s[i]) of s[i]) withpen pencircle scaled linewidth withcolor drawcolor ;
1188                endfor ;
1189            fi ;
1190            if getparameter "showlabels" :
1191                first := 0 ;
1192                for i = 1 upto nofsamples :
1193                    value := getparameter "samples" (1) i ;
1194                    last := first + (360/100) * value * factor ;
1195                    draw lmt_do_chart_text (s,i,value)
1196                        shifted ((labelfraction*(height/2),0) rotated ((first+last)/2)) ;
1197                    first := last ;
1198                endfor ;
1199            fi ;
1200            lmt_do_chart_legend ;
1201            n := getparameter "originsize" ;
1202            if n > 0 :
1203                fill fullcircle scaled n withcolor "white"  ;
1204            fi ;
1205        fi ;
1206        lmt_do_chart_stop ;
1207    )
1208enddef ;
1209
1210vardef lmt_do_chart_histogram =
1211    image (
1212        lmt_do_chart_start("chart:histogram") ;
1213        if (nofsamplesets > 0) and (nofsamples > 0) :
1214            save value, maximum, cumulative, maxwidth ; boolean cumulative ;
1215            maximum := getparameter "maximum" ;
1216            cumulative := getparameter "cumulative" ;
1217            if labelanchor = "center" :
1218                labelanchor := "vcenter" ;
1219            fi ;
1220            if maximum = 0 :
1221                for s = 1 upto nofsamplesets :
1222                    for i = 1 upto nofsamples :
1223                        value := getparameter "samples" s i ;
1224                        maximum := if cumulative :
1225                            maximum + value ;
1226                        else :
1227                            max(maximum,value) ;
1228                        fi ;
1229                    endfor ;
1230                endfor ;
1231            fi ;
1232            if nofsamplesets = 1 :
1233                distance := 0 ;
1234            fi ;
1235            maxwidth := nofsamplesets * nofsamples * width + (nofsamples - 1)* distance ;
1236            value := 0 ;
1237            for s = 1 upto nofsamplesets :
1238                for i = 1 upto nofsamples :
1239                    value := if cumulative : value + fi (getparameter "samples" s i) * height / maximum ;
1240                    fill unitsquare xyscaled (width,value)
1241                        if linewidth > 0 :
1242                            if i > 1          : leftenlarged  (-linewidth/2) fi
1243                            if i < nofsamples : rightenlarged (-linewidth/2) fi
1244                        fi
1245                        shifted (nofsamplesets*(i-1)*width+(s-1)*width+(i-1)*distance,0)
1246                        withcolor getparameter "fillcolors" if colormode = "local" : s else : i fi ;
1247                endfor ;
1248            endfor ;
1249            setbounds currentpicture to unitsquare xyscaled (maxwidth,height) ;
1250            for s = 1 upto nofsamplesets :
1251                if getparameter "showlabels" :
1252                    for i = 1 upto nofsamples :
1253                        draw lmt_do_chart_text (s,i,getparameter "samples" s i)
1254                            shifted (nofsamplesets*((i-1)*width)+width/2+(s-1)*width+(i-1)*distance,0) ;
1255                    endfor ;
1256                fi ;
1257            endfor ;
1258            lmt_do_chart_legend ;
1259        fi ;
1260        lmt_do_chart_stop ;
1261    )
1262enddef ;
1263
1264vardef lmt_do_chart_bar =
1265
1266    image (
1267        lmt_do_chart_start("chart:bar") ;
1268        if (nofsamplesets > 0) and (nofsamples > 0) :
1269            save value, maximum, cumulative, maxheight ; boolean cumulative ;
1270            maximum := getparameter "maximum" ;
1271            cumulative := getparameter "cumulative" ;
1272            if labelanchor = "center" :
1273                labelanchor := "hcenter" ;
1274            fi ;
1275            if maximum = 0 :
1276                for s = 1 upto nofsamplesets :
1277                    for i = 1 upto nofsamples :
1278                        value := getparameter "samples" s i ;
1279                        maximum := if cumulative : maximum + value else : max(maximum,value) fi ;
1280                    endfor ;
1281                endfor ;
1282            fi ;
1283            if nofsamplesets = 1 :
1284                distance := 0 ;
1285            fi ;
1286            maxheight := nofsamplesets * nofsamples * height + (nofsamples - 1)* distance ;
1287            for s = 1 upto nofsamplesets :
1288                value := 0 ;
1289                for i = 1 upto nofsamples :
1290                    value := if cumulative : value + fi (getparameter "samples" s i) * width / maximum ;
1291                    fill unitsquare xyscaled (value,height)
1292                        if linewidth > 0 :
1293                            if i > 1          : topenlarged    (-linewidth/2) fi
1294                            if i < nofsamples : bottomenlarged (-linewidth/2) fi
1295                        fi
1296                        shifted (0,maxheight-nofsamplesets*i*height+(s-1)*height-(i-1)*distance)
1297                        withcolor getparameter "fillcolors" if colormode = "local" : s else : i fi ;
1298                endfor ;
1299            endfor ;
1300            setbounds currentpicture to unitsquare xyscaled (width,maxheight) ;
1301            if getparameter "showlabels" :
1302                for s = 1 upto nofsamplesets :
1303                    for i = 1 upto nofsamples :
1304                        draw lmt_do_chart_text (s,i,getparameter "samples" s i)
1305                            shifted (0,maxheight-nofsamplesets*(i*height)+height/2+(s-1)*height-(i-1)*distance) ;
1306                    endfor ;
1307                endfor ;
1308            fi ;
1309            lmt_do_chart_legend ;
1310        fi ;
1311        lmt_do_chart_stop ;
1312    )
1313enddef ;
1314
1315%D This one is more complex than needed but I want to trace so I need all those
1316%D variables.
1317
1318presetparameters "shade" [
1319    alternative = "circular",
1320    path        = origin -- cycle,
1321    trace       = false
1322
1323 %  alternative = "circular" | "linear"
1324 %  domain      = { a, b }
1325 %  radius      = a | { a, b }
1326 %  factor      = a
1327 %  origin      = (a,b) | { (a,b), {c, d) }
1328 %  vector      = { a, b }
1329 %  colors      = { a, b }
1330 %  center      = a | { a, b }
1331 %  direction   = "up" | "down" | "left" | "right" | { a, b }
1332
1333] ;
1334
1335% TODO: pass colors as strings
1336
1337def lmt_shade = applyparameters "shade" "lmt_do_shade" enddef ;
1338
1339vardef lmt_do_shade =
1340    image (
1341        pushparameters "shade" ;
1342
1343        save domain_min, domain_max, radius_a, radius_b, factor ;
1344        save color_a, color_b, center_a, center_b, alternative, s ;
1345        string color_a, color_b, alternative, s ; pair center_a, center_b ;
1346
1347        alternative := getparameter "alternative" ;
1348
1349        mfun_with_shade_method_analyze(getparameter "path") ;
1350
1351        domain_min := 0 ;
1352        domain_max := 1 ;
1353
1354        color_a := "white" ;
1355        color_b := "black" ;
1356
1357        if alternative = "circular" :
1358            center_a := center mfun_shade_path ;
1359            center_b := center_a ;
1360            radius_a := 0 ;
1361            radius_b := mfun_max_radius(mfun_shade_path) ;
1362            factor   := 1.2 ;
1363        else :
1364            center_a := llcorner mfun_shade_path ;
1365            center_b := urcorner mfun_shade_path ;
1366            radius_a := 0 ;
1367            radius_b := 0 ;
1368            factor   := 0;
1369        fi ;
1370
1371        if hasparameter "domain" :
1372            domain_min := getparameter "domain" 1 ;
1373            domain_max := getparameter "domain" 2 ;
1374        fi
1375        if hasparameter "radius" :
1376            if numeric getparameter "radius" :
1377                radius_a := 0 ;
1378                radius_b := getparameter "radius" ;
1379            else :
1380                radius_a := getparameter "radius" 1 ;
1381                radius_b := getparameter "radius" 2 ;
1382            fi ;
1383            factor := 1 ;
1384        fi
1385        if hasparameter "factor" :
1386            factor := getparameter "factor" ;
1387        fi
1388        if hasparameter "origin" :
1389            if pair getparameter "origin" :
1390                center_a := getparameter "origin" ;
1391                center_b := center_b ;
1392            else :
1393                center_a := getparameter "origin" 1 ;
1394                center_b := getparameter "origin" 2 ;
1395            fi ;
1396        fi
1397        if hasparameter "colors" :
1398            color_a := getparameter "colors" 1 ;
1399            color_b := getparameter "colors" 2 ;
1400        fi
1401        if hasparameter "direction" :
1402            save a, b, bb, temp_x, temp_y ; path bb ;
1403            temp_x := temp_y := 0 ;
1404            bb := boundingbox(mfun_shade_path) ;
1405            a := b := -1 ;
1406            if string getparameter "direction" :
1407                s := getparameter "direction" ;
1408                if     s = "up"    :
1409                    temp_x := xpart shadedup ;
1410                    temp_y := ypart shadedup ;
1411                elseif s = "down"  :
1412                    temp_x := xpart shadeddown ;
1413                    temp_y := ypart shadeddown ;
1414                elseif s = "left"  :
1415                    temp_x := xpart shadedleft ;
1416                    temp_y := ypart shadedleft ;
1417                elseif s = "right" :
1418                    temp_x := xpart shadedright ;
1419                    temp_y := ypart shadedright ;
1420                fi
1421            else :
1422                temp_x := getparameter "direction" 1 ;
1423                temp_y := getparameter "direction" 2 ;
1424            fi
1425            if temp_x >= 0 :
1426                center_a := point temp_x of bb ;
1427            fi
1428            if temp_y >= 0 :
1429                center_b := point temp_y of bb ;
1430            fi
1431        fi ;
1432        if hasparameter "center" :
1433            save cx, cy ;
1434            if numeric getparameter "center" :
1435                cx := getparameter "center" ;
1436                cx := cy ;
1437          % elseif pair getparameter "center" :
1438          %     cx := xpart getparameter "center" ;
1439          %     cy := ypart getparameter "center" ;
1440            else :
1441                cx := getparameter "center" 1 ;
1442                cy := getparameter "center" 2 ;
1443            fi
1444            center_a := center mfun_shade_path shifted (
1445                cx * bbwidth (mfun_shade_path)/2,
1446                cy * bbheight(mfun_shade_path)/2
1447            ) ;
1448        elseif hasparameter "vector" :
1449            center_a := point (getparameter "vector" 1) of mfun_shade_path ;
1450            center_b := point (getparameter "vector" 2) of mfun_shade_path ;
1451        fi
1452        fill mfun_shade_path
1453            withprescript "sh_domain=" & decimal domain_min & " " & decimal domain_max
1454            withprescript "sh_transform=yes"
1455            withprescript "sh_color=into"
1456            withprescript "sh_color_a=" & colordecimals color_a
1457            withprescript "sh_color_b=" & colordecimals color_b
1458            withprescript "sh_first=" & ddecimal point 0 of mfun_shade_path % used for support scaling
1459            withprescript "sh_set_x=" & ddecimal (mfun_shade_nx,mfun_shade_lx) %
1460            withprescript "sh_set_y=" & ddecimal (mfun_shade_ny,mfun_shade_ly) %
1461            if alternative = "linear" :
1462                withprescript "sh_type=linear"
1463             %  withprescript "sh_factor=1"
1464                withprescript "sh_factor=" & decimal factor
1465                withprescript "sh_center_a=" & ddecimal center_a
1466                withprescript "sh_center_b=" & ddecimal center_b
1467            else :
1468                withprescript "sh_type=circular"
1469              % withprescript "sh_factor=1.2"
1470                withprescript "sh_factor=" & decimal factor
1471                withprescript "sh_center_a=" & ddecimal center_a
1472                withprescript "sh_center_b=" & ddecimal center_b
1473                withprescript "sh_radius_a=" & decimal radius_a
1474                withprescript "sh_radius_b=" & decimal radius_b
1475            fi ;
1476        if getparameter "trace" :
1477            draw fullcircle scaled 1mm shifted center_a ;
1478            draw fullsquare scaled 2mm shifted center_b ;
1479            draw textext.top("\strut\ttx center a") ysized LineHeight shifted center_a shifted (0, 2mm) ;
1480            draw textext.bot("\strut\ttx center b") ysized LineHeight shifted center_b shifted (0,-2mm) ;
1481            if alternative = "circular" :
1482%                 draw fullcircle scaled (         radius_a * 2) shifted  center_a dashed evenly ;
1483%                 draw fullcircle scaled (factor * radius_b * 2) shifted -center_b dashed evenly ;
1484                draw fullcircle scaled (         radius_a) shifted  center_a dashed evenly ;
1485                draw fullcircle scaled (factor * radius_b) shifted -center_b dashed evenly ;
1486            fi
1487        fi
1488        popparameters ;
1489    )
1490enddef ;
1491
1492% This is very experimental and will first be tested by a few users who
1493% are interested in this.
1494
1495presetparameters "contour" [
1496    xmin             = 0,
1497    xmax             = 0,
1498    ymin             = 0,
1499    ymax             = 0,
1500    xstep            = 0,
1501    ystep            = 0,
1502    levels           = 10,
1503  % colors           = { },          % used when set
1504    preamble         = "",
1505    function         = "x + y",
1506    color            = "lin(l)",     % l/n
1507    background       = "bitmap",     % bitmap | shape | band
1508    foreground       = "auto",       % cell| edge | shape | auto: bitmap/edge shape/shape
1509    linewidth        = .25,
1510    backgroundcolor  = "black",
1511    linecolor        = "gray",
1512    xformat          = "@0.2N",
1513    yformat          = "@0.2N",
1514    zformat          = "@0.2N",
1515    xstyle           = "",
1516    ystyle           = "",
1517    zstyle           = "",
1518
1519    width            = 0,            % auto when 0
1520    height           = 0,            % auto when 0
1521
1522    trace            = false,
1523    checkresult      = false,
1524    defaultnan       = 0,
1525    defaultinf       = 0,
1526
1527    legend           = "all",  % x | y | z | function | range | all (but range)
1528    legendheight     = LineHeight,
1529    legendwidth      = LineHeight,
1530    legendgap        = 0,
1531    legenddistance   = EmWidth,
1532    textdistance     = 2EmWidth/3,
1533    functiondistance = ExHeight,
1534    functionstyle    = "",
1535
1536    level            = 4096,        % for selecting one (can't be too large for scaled)
1537
1538    axisdistance     = ExHeight,
1539    axislinewidth    = .25,
1540    axisoffset       = ExHeight/4,
1541    axiscolor        = "black",
1542    ticklength       = ExHeight,
1543
1544    xtick            = 5,
1545    ytick            = 5,
1546    xlabel           = 5,
1547    ylabel           = 5,
1548
1549] ;
1550
1551% we can as well push ...
1552
1553def lmt_contour = applyparameters "contour" "lmt_do_contour" enddef ;
1554
1555def mfun_only_draw          = addto currentpicture doublepath enddef ;
1556def mfun_only_fill          = addto currentpicture contour    enddef ;
1557def mfun_only_fillup text t = addto currentpicture doublepath t withpostscript "both"    enddef ;
1558def mfun_only_nodraw text t = addto currentpicture doublepath t withpostscript "collect" enddef ;
1559def mfun_only_nofill text t = addto currentpicture contour    t withpostscript "evenodd" enddef ;
1560def mfun_only_eofill text t = addto currentpicture contour    t withpostscript "collect" enddef ;
1561
1562def lmt_do_contour_shortcuts =
1563    save D ; let D = mfun_only_draw   ;
1564    save E ; let E = mfun_only_eofill ;
1565    save F ; let F = mfun_only_fill   ;
1566    save U ; let U = mfun_only_fillup ;
1567    save d ; let d = mfun_only_nodraw ;
1568    save e ; let f = mfun_only_eofill ;
1569    save f ; let f = mfun_only_nofill ;
1570    save C ; let C = cycle ;
1571    save B ; let B = controls ;
1572    save A ; let A = and ;
1573enddef ;
1574
1575def lmt_do_contour_band =
1576    lua.mp.lmt_contours_edge_set_by_band() ;
1577    for v=1 upto lua.mp.lmt_contours_nofvalues() :
1578        draw image (
1579            lua.mp.lmt_contours_edge_get_band(v) ;
1580        )
1581            withcolor lua.mp.lmt_contours_color(v) ;
1582    endfor ;
1583enddef;
1584
1585def lmt_do_contour_cell(expr dx,dy) =
1586    lua.mp.lmt_contours_edge_set_by_cell() ;
1587    draw image (
1588        if level = 4096 :
1589            for v=1+1 upto lua.mp.lmt_contours_nofvalues() :
1590                lua.mp.lmt_contours_edge_get_cell(v) ;
1591            endfor ;
1592        else :
1593            lua.mp.lmt_contours_edge_get_cell(level) ;
1594        fi
1595    )
1596        if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1597        withcolor getparameter "linecolor"
1598        withpen pencircle scaled getparameter "linewidth" ;
1599enddef ;
1600
1601def lmt_do_contour_edge(expr dx, dy) =
1602    lua.mp.lmt_contours_edge_set() ;
1603    draw image (
1604        if level = 4096 :
1605            for v=1+1 upto lua.mp.lmt_contours_nofvalues() :
1606                lua.mp.lmt_contours_edge_paths(v);
1607            endfor ;
1608        else :
1609            lua.mp.lmt_contours_edge_paths(level);
1610        fi
1611    )
1612        if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1613        withcolor getparameter "linecolor"
1614        withpen pencircle scaled getparameter "linewidth" ;
1615enddef ;
1616
1617def lmt_do_contour_edges(expr dx, dy) =
1618    lua.mp.lmt_contours_edge_set() ;
1619    if level = 4096 :
1620        for v=1+1 upto lua.mp.lmt_contours_nofvalues() :
1621            draw image (
1622                lua.mp.lmt_contours_edge_paths(v);
1623            )
1624            if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1625            withpen pencircle scaled getparameter "linewidth"
1626            withcolor lua.mp.lmt_contours_color(v) ;
1627        endfor ;
1628    else :
1629        draw image (
1630            lua.mp.lmt_contours_edge_paths(level);
1631        )
1632        if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1633        withpen pencircle scaled getparameter "linewidth"
1634        withcolor lua.mp.lmt_contours_color(level) ;
1635    fi ;
1636enddef ;
1637
1638def lmt_do_contour_cells(expr dx, dy) =
1639    lua.mp.lmt_contours_edge_set_by_cell() ;
1640    if level = 4096 :
1641        for v=1+1 upto lua.mp.lmt_contours_nofvalues() :
1642            draw image (
1643                lua.mp.lmt_contours_edge_get_cell(v) ;
1644            )
1645        if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1646            withpen pencircle scaled getparameter "linewidth"
1647            withcolor lua.mp.lmt_contours_color(v) ;
1648        endfor ;
1649    else :
1650        draw image (
1651            lua.mp.lmt_contours_edge_get_cell(level) ;
1652        )
1653        if offset : shifted (-1/2,-1/2) fi
1654        withpen pencircle scaled getparameter "linewidth"
1655        withcolor lua.mp.lmt_contours_color(v) ;
1656    fi ;
1657enddef ;
1658
1659def lmt_do_contour_shape(expr dx, dy) =
1660    draw image (
1661        if level = 4096 :
1662            for v=1+1 upto lua.mp.lmt_contours_nofvalues() :
1663                lua.mp.lmt_contours_shape_paths(v);
1664            endfor ;
1665        else :
1666            lua.mp.lmt_contours_shape_paths(level);
1667            lua.mp.lmt_contours_shape_paths(1);
1668        fi
1669    )
1670        if (dx <>0) or (dy <> 0) : shifted (dx,dy) fi
1671        withcolor getparameter "linecolor"
1672        withpen pencircle scaled getparameter "linewidth" ;
1673enddef ;
1674
1675def lmt_do_contour_bitmap =
1676    lua.mp.lmt_contours_bitmap_set() ;
1677    lua.mp.lmt_contours_bitmap_get() ;
1678enddef ;
1679
1680def lmt_do_contour_shades(expr outlines) =
1681    lua.mp.lmt_contours_shade_set(outlines) ;
1682    if level = 4096 :
1683        for v=1 upto lua.mp.lmt_contours_nofvalues() : % no + 1 here
1684            draw image (
1685                lua.mp.lmt_contours_shade_paths(v) ;
1686            )
1687            withpen pencircle scaled 0
1688            withcolor lua.mp.lmt_contours_color(v) ;
1689        endfor ;
1690    else :
1691        draw image (
1692            lua.mp.lmt_contours_shade_paths(level);
1693        )
1694        withpen pencircle scaled 0
1695        withcolor lua.mp.lmt_contours_color(level) ;
1696    fi ;
1697enddef ;
1698
1699def lmt_load_mlib_cnt =
1700    runscript("lua.registercode('mlib-cnt')");
1701    extra_beginfig := extra_beginfig & % todo: use different hook
1702        "runscript(" & ditto & "mp.lmt_contours_cleanup()" & ditto & ")" ;
1703    let lmt_load_mlib_cnt = relax ;
1704enddef ;
1705
1706vardef lmt_do_contour =
1707    image (
1708
1709        lmt_load_mlib_cnt ;
1710
1711        pushparameters "contour" ;
1712
1713        lua.mp.lmt_contours_start() ;
1714
1715        % graphic
1716
1717        save bg, fg, nx, ny, trace, level, b, done ; string bg, fg ; boolean trace, done ; path b ;
1718
1719        bg    := getparameter "background" ;
1720        fg    := getparameter "foreground" ;
1721        nx    := lua.mp.lmt_contours_nx() ;
1722        ny    := lua.mp.lmt_contours_ny() ;
1723        trace := getparameter "trace" ;
1724        level := getparameter "level" ;
1725        done  := true ;
1726
1727        begingroup ;
1728
1729            lmt_do_contour_shortcuts ;
1730
1731            if bg = "band" :
1732                lmt_do_contour_band ;
1733                b := boundingbox currentpicture ;
1734                if (fg = "auto") or (fg = "cell") :
1735                    lmt_do_contour_cell(0,0) ;
1736                elseif (fg = "edge") :
1737                    lmt_do_contour_edge(0,0) ; % true ?
1738                fi ;
1739
1740            elseif bg = "bitmap" :
1741
1742                lmt_do_contour_bitmap ;
1743                b := boundingbox currentpicture ;
1744                if (fg = "auto") or (fg = "cell") :
1745                    lmt_do_contour_cell(-1/2,-1/2) ;
1746                elseif (fg = "edge") :
1747                    lmt_do_contour_edge(-1/2,-1/2) ;
1748                fi ;
1749
1750            elseif bg = "shape" :
1751
1752                lmt_do_contour_shades((fg = "auto") or (fg = "shape")) ;
1753                b := boundingbox currentpicture ;
1754                if (fg == "auto") or (fg = "shape") :
1755                    lmt_do_contour_shape(0,0) ;
1756                elseif fg == "cell" :
1757                    lmt_do_contour_cell(-1,-1) ;
1758                elseif fg == "edge" :
1759                    lmt_do_contour_edge(-1,-1) ;
1760                fi ;
1761
1762                % currentpicture := currentpicture reflectedabout ( (0, ny/2), (nx,ny/2) ) ;
1763
1764            elseif fg = "cell" :
1765
1766                lmt_do_contour_shortcuts ;
1767                lmt_do_contour_cells(0,0) ;
1768                b := boundingbox currentpicture ;
1769
1770            elseif fg = "edge" :
1771
1772                lmt_do_contour_shortcuts ;
1773                lmt_do_contour_edges(0,0) ;
1774                b := boundingbox currentpicture ;
1775
1776            else :
1777
1778                done := false ;
1779
1780            fi ;
1781
1782        endgroup ;
1783
1784        if done :
1785
1786            save w, h, cx, cy ;
1787
1788            cx := - bbwidth (b)/(nx - 1) ;
1789            cy := - bbheight(b)/(ny - 1) ;
1790            clip currentpicture to b
1791                leftenlarged cx rightenlarged  cx
1792                topenlarged  cy bottomenlarged cy ;
1793            currentpicture := currentpicture
1794                shifted (cx,cy) ;
1795
1796            w := getparameter "width" ;
1797            h := getparameter "height" ;
1798
1799            % axis
1800
1801            save xtic, ytic, auto ; boolean auto ;
1802
1803            xtic   := getparameter "xtick" ;
1804            ytic   := getparameter "ytick" ;
1805            auto   := (w = 0) and (h = 0) ;
1806
1807            % resize
1808
1809            if w <> 0 :
1810                if h <> 0 :
1811                    currentpicture := currentpicture xysized (w,h) ;
1812                else :
1813                    currentpicture := currentpicture xsized w ;
1814                fi ;
1815            elseif h <> 0 :
1816                currentpicture := currentpicture ysized h ;
1817            fi ;
1818            if w = 0 :
1819                w := bbwidth(currentpicture) ;
1820            fi ;
1821            if h = 0 :
1822                h := bbheight(currentpicture) ;
1823            fi ;
1824
1825            % legend
1826
1827            if hasoption "legend" "all,x,y,z,range" :
1828
1829                save u, s, sx, sy, ax, ay, ao, al, at, tl, ox, oy, lg, tx, ty, wx, hx, ry, fmt, pmin, pmax ; string fmt; picture pmin, pmax ;
1830
1831                % move some in the ifs
1832
1833                if hasoption "legend" "all,z" :
1834
1835                    % colorbar
1836
1837                    fmt  := lua.mp.lmt_contours_format() ;
1838                    pmin := lmt_text [ format = fmt, text = decimal lua.mp.lmt_contours_minmean() ] ;
1839                    pmax := lmt_text [ format = fmt, text = decimal lua.mp.lmt_contours_maxmean() ] ;
1840                    wx   := max(bbwidth(pmin),bbwidth(pmax)) ;
1841                    hx   := bbheight(pmin) ;
1842
1843                else :
1844
1845                    hx   := 0;
1846
1847                fi ;
1848
1849                if auto :
1850                  % u  := 1 ;
1851                    u := lua.mp.lmt_contours_ny() / 100 ;
1852                    ry := 4u ;
1853                    sy := 5u ;
1854                    sx := 5u ;
1855                    lg := 0 ;
1856                    ox := 5u ;
1857                    oy := - sy/2 + ry/2 ;
1858                    tx := 2u ;
1859                    ty := 1u ;
1860                    ax := 1u ;
1861                    ay := 1u ;
1862                    ao := u ;
1863                    al := u/8 ;
1864                    at := 3u/2 ;
1865                    al := u/4 ;
1866                else :
1867                    ry := 0 ;
1868                    sy := getparameter "legendheight" ;
1869                    sx := getparameter "legendwidth" ;
1870                    lg := getparameter "legendgap" ;
1871                    ox := getparameter "legenddistance" ;
1872                    oy := - sy/2 + hx/2 ;
1873                    tx := getparameter "textdistance" ;
1874                    ty := getparameter "functiondistance" ;
1875                    ax := getparameter "axisdistance" ;
1876                    ay := ax ;
1877                    ao := getparameter "axisoffset" ;
1878                    at := getparameter "ticklength" ;
1879                    al := getparameter "axislinewidth" ;
1880                fi ;
1881
1882                if hasoption "legend" "all,z" :
1883
1884                    save dy ; dy := h ;
1885
1886                    for v=1 upto lua.mp.lmt_contours_nofvalues() :
1887                        dy := dy - sy ;
1888                        fill unitsquare xyscaled (sx,sy)
1889                            shifted (w+ox,dy)
1890                            withcolor lua.mp.lmt_contours_color(v) ;
1891                        draw
1892                            lmt_text [
1893                                trace      = trace,
1894                                anchor     = "llft",
1895                                format     = fmt,
1896                                text       = decimal lua.mp.lmt_contours_value(v),
1897                                style      = getparameter "zstyle",
1898                                position   = (wx,0),
1899                                background = "",
1900                            ]
1901                            if ry <> 0 : ysized (ry) fi
1902                            shifted (w+ox+tx+sx,dy+sy+oy)
1903                        ;
1904                        dy := dy - lg ;
1905                    endfor ;
1906
1907                fi ;
1908
1909                if hasoption "legend" "x,all" :
1910
1911                    save n, d, s, xmin, xmax, xlab ;
1912
1913                    xmin := getparameter "xmin" ;
1914                    xmax := getparameter "xmax" ;
1915                    xlab := getparameter "xlabel" ;
1916
1917                    draw image (
1918                        interim linecap := butt ;
1919                        draw ((0,0) -- (w,0)) ;
1920                        n := al/2 ; s := (w - al) / xtic ; d := (xmax - xmin) / xtic ;
1921                        for i=xmin step d until xmax :
1922                            draw (n,0) -- (n,-at) ;
1923                            n := n + s ;
1924                        endfor ;
1925                    )  shifted (0,-ay)
1926                        withpen pencircle scaled al
1927                        withcolor getparameter "axiscolor"
1928                    ;
1929
1930                    if hasoption "legend" "label,all" :
1931
1932                        draw image (
1933                            n := al/2 ; s := (w - al) / xlab ; d := (xmax - xmin) / xlab ;
1934                            for i=xmin step d until xmax :
1935                                draw lmt_text [
1936                                    trace      = trace,
1937                                    anchor     = "bot",
1938                                    format     = getparameter "xformat",
1939                                    style      = getparameter "xstyle",
1940                                    text       = decimal i
1941                                    background = "",
1942                                ]
1943                                    if ry <> 0 : ysized (ry) fi
1944                                    shifted (n,-at-ao)
1945                                ;
1946                                n := n + s ;
1947                            endfor ;
1948                        )  shifted (0,-ay) ;
1949
1950                    fi ;
1951
1952                fi ;
1953
1954                if hasoption "legend" "y,all" :
1955
1956                    save n, d, s, ymin, ymax, ylab ;
1957
1958                    ymin := getparameter "ymin" ;
1959                    ymax := getparameter "ymax" ;
1960                    ylab := getparameter "ylabel" ;
1961
1962                    draw image (
1963                        interim linecap := butt ;
1964                        draw ((0,0) -- (0,h)) ;
1965                        n := al/2 ; s := (h - al) / ytic ; d := (ymax - ymin) / ytic ;
1966                        for i=ymin step d until ymax :
1967                            draw (0,n) -- (-at,n) ;
1968                            n := n + s ;
1969                        endfor ;
1970                    )  shifted (-ax,0)
1971                        withpen pencircle scaled al
1972                        withcolor getparameter "axiscolor" ;
1973                    ;
1974
1975                    if hasoption "legend" "label,all" :
1976
1977                        draw image (
1978                            n := al/2 ; s := (h - al) / ylab ; d := (ymax - ymin) / ylab ;
1979                            for i=ymin step d until ymax :
1980                                draw lmt_text [
1981                                    trace      = trace,
1982                                    anchor     = "lft",
1983                                    format     = getparameter "yformat",
1984                                    style      = getparameter "ystyle",
1985                                    text       = decimal i
1986                                    background = "",
1987                                ]
1988                                    if ry <> 0 : ysized (ry) fi
1989                                    shifted (-at-ao,n)
1990                                ;
1991                                n := n + s ;
1992                            endfor ;
1993                        )  shifted (-ax,0) ;
1994
1995                    fi ;
1996
1997                fi ;
1998
1999                if hasoption "legend" "range,all" :
2000
2001                    % range
2002
2003                    save d ; d := ypart llcorner currentpicture ;
2004
2005                    draw
2006                        lmt_text [
2007                            trace      = trace,
2008                            anchor     = "bot",
2009                            text       = lua.mp.lmt_contours_range()
2010                            background = "",
2011                        ]
2012                        if ry <> 0 : ysized (ry) fi
2013                        shifted (w/2,d-ty)
2014                    ;
2015
2016                    % minmax
2017
2018                    draw
2019                        lmt_text [
2020                            trace      = trace,
2021                            anchor     = "lrt",
2022                            text       = lua.mp.lmt_contours_xrange()
2023                            background = "",
2024                        ]
2025                        if ry <> 0 : ysized (ry) fi
2026                        shifted (0,d-ty)
2027                    ;
2028
2029                    draw
2030                        lmt_text [
2031                            trace      = trace,
2032                            anchor     = "llft",
2033                            text       = lua.mp.lmt_contours_yrange()
2034                            background = "",
2035                        ]
2036                        if ry <> 0 : ysized (ry) fi
2037                        shifted (w,d-ty)
2038                    ;
2039
2040                fi ;
2041
2042                if hasoption "legend" "function,all" :
2043
2044                    % formula
2045
2046                    draw
2047                        lmt_text [
2048                            trace      = trace,
2049                            anchor     = "bot",
2050                            style      = getparameter "functionstyle",
2051                            text       = lua.mp.lmt_contours_function()
2052                            background = "",
2053                        ]
2054                        if ry <> 0 : ysized (ry) fi
2055                        shifted (w/2,ypart llcorner currentpicture - ty)
2056                    ;
2057
2058                fi ;
2059
2060                if trace :
2061                    draw boundingbox currentpicture
2062                        dashed evenly
2063                        withpen pencircle scaled al ;
2064                fi ;
2065
2066            fi ;
2067
2068        fi ;
2069
2070        lua.mp.lmt_contours_stop() ;
2071
2072        popparameters ;
2073    )
2074enddef ;
2075
2076newinternal svgforcecmyk ; svgforcecmyk := 0 ;
2077
2078vardef svgcolor(expr r, g, b) =
2079    if svgforcecmyk > 0 :
2080        (1-r,1-g,1-b,0) % simple: no black component, kind of ok for emoji
2081    else :
2082        (r,g,b)
2083    fi
2084enddef ;
2085
2086vardef svgcmyk(expr c, m, y, k) =
2087    (c,m,y,k)
2088enddef ;
2089
2090vardef svggray(expr s) =
2091    s
2092enddef ;
2093
2094permanent svgforcecmyk, svgcolor, svgcmyk, svggray ;
2095
2096presetparameters "svg" [
2097    filename = "",
2098    fontname = "",
2099    colormap = "",
2100  % unicode  = 0,
2101    width    = 0,
2102    height   = 0,
2103    origin   = false,
2104    offset   = 0,
2105] ;
2106
2107def lmt_svg = applyparameters "svg" "lmt_do_svg" enddef ;
2108
2109vardef lmt_do_svg =
2110    save w, h, o;
2111    image (
2112        pushparameters "svg" ;
2113        w := getparameter "width" ;
2114        h := getparameter "height" ;
2115        o := getparameter "offset" ;
2116        lua.mp.lmt_svg_include() ; % textext runs twice .. maybe force once here
2117        if getparameter "origin" :
2118            currentpicture := currentpicture shifted -llcorner currentpicture ;
2119        fi ;
2120        popparameters ;
2121        if o <> 0 :
2122            setbounds currentpicture to boundingbox currentpicture enlarged o ;
2123        fi ;
2124    )
2125    if w > 0 :
2126        if h > 0 : xysized(w,h) else : xsized(w) fi
2127    else :
2128        if h > 0 :                     ysized(h) fi
2129    fi
2130enddef ;
2131
2132% Another experiment. Parameters might change pending a discussion between Alan
2133% and me.
2134
2135presetparameters "surface" [
2136    code          = "x + y",
2137    color         = "f, 0, 0",
2138    linecolor     = 1,
2139    xmin          = -1,
2140    xmax          =  1,
2141    ymin          = -1,
2142    ymax          =  1,
2143    xstep         = .1,
2144    ystep         = .1,
2145    snap          = .01,
2146    xvector       = { -0.7, -0.7 },
2147    yvector       = { 1, 0 },
2148    zvector       = { 0, 1 },
2149    light         = { 3, 3, 10 },
2150    bright        = 100,
2151    clip          = false,
2152    lines         = true,
2153    linecolor     = 1,
2154  % axis          = { }
2155  % clipaxis      = false
2156    axiscolor     = "gray"
2157    axislinewidth = 1/2,
2158] ;
2159
2160def lmt_surface = applyparameters "surface" "lmt_do_surface" enddef ;
2161
2162vardef lmt_do_surface =
2163    image (
2164
2165        lmt_load_mlib_cnt ;
2166
2167        pushparameters "surface" ;
2168
2169        save currentpen; pen currentpen ;
2170        currentpen := pencircle scaled .25 ;
2171
2172        interim linejoin := butt ;
2173
2174        lmt_do_contour_shortcuts ;
2175
2176        lua.mp.lmt_surface_do() ;
2177
2178        currentpicture := currentpicture ysized getparameter "height" ;
2179
2180        if hasparameter "axis" :
2181
2182            save p ; picture p ; p := image (
2183                if hasparameter "axis" 1 :
2184                    draw ((origin) -- unitvector(getparameter "xvector")) scaled (getparameter "axis" 1) ;
2185                fi ;
2186                if hasparameter "axis" 2 :
2187                    draw ((origin) -- unitvector(getparameter "yvector")) scaled (getparameter "axis" 2) ;
2188                fi ;
2189                if hasparameter "axis" 3 :
2190                    draw ((origin) -- unitvector(getparameter "zvector")) scaled (getparameter "axis" 3) ;
2191                fi ;
2192            ) ;
2193
2194            if getparameterdefault "clipaxis" false :
2195                clip p to boundingbox currentpicture ;
2196            fi ;
2197
2198            draw p
2199                withpen pencircle scaled getparameter "axislinewidth"
2200                withcolor getparameter "axiscolor"
2201            ;
2202
2203        fi ;
2204
2205        popparameters ;
2206    )
2207enddef ;
2208
2209% I can make a variant that avoids the lmt_do ... and does an immediate function
2210% call instead.
2211
2212presetparameters "mpsglyphs" [
2213    name  = "dummy",
2214    units = 1000,
2215] ;
2216
2217presetparameters "mpsglyph" [
2218    category = "dummy",
2219    unicode  = 0,
2220  % unichar  = ""
2221] ;
2222
2223def lmt_registerglyphs = applyparameters "mpsglyphs" "lmt_do_registerglyphs" enddef ;
2224def lmt_registerglyph  = applyparameters "mpsglyph"  "lmt_do_registerglyph"  enddef ;
2225
2226newscriptindex mfid_registerglyphs ; mfid_registerglyphs := scriptindex "registerglyphs" ; def lmt_do_registerglyphs = runscript mfid_registerglyphs enddef ;
2227newscriptindex mfid_registerglyph  ; mfid_registerglyph  := scriptindex "registerglyph"  ; def lmt_do_registerglyph  = runscript mfid_registerglyph  enddef ;
2228
2229% An experimental macro:
2230
2231vardef registercomposedglyph (expr u) (suffix snippets) =
2232    save s ; s := getparameterdefault "mpsfont" "scale" 1 ;
2233    save llx, lly, urx, ury ;
2234    llx := xpart llcorner snippets[u] ;
2235    if llx <> 0 :
2236        % this should be an option or we need a lsb
2237        snippets[u] := snippets[u] shifted (-llx, 0) ;
2238        llx := 0;
2239    fi ;
2240    lly := ypart llcorner snippets[u] / s ;
2241    urx := xpart urcorner snippets[u] / s ;
2242    ury := ypart urcorner snippets[u] / s ;
2243    lmt_registerglyph [
2244        category    = getparameter "mpsfont" "category",
2245        unicode     = u,
2246        code        = "draw " & str snippets & "[" & decimal u & "]",
2247        height      =   ury,
2248        depth       = - lly,
2249        width       =   urx - llx,
2250        boundingbox = { llx, lly, urx, ury }
2251    ] ;
2252enddef ;
2253
2254vardef composeglyph (suffix snippets) =
2255    save u ; u := getparameter "mpsfont" "unicode" ;
2256    save s ; s := getparameterdefault "mpsfont" "scale" 1 ;
2257    snippets[u] := image (
2258        for i=1 upto getparametercount "mpsfont" "shapes" :
2259            draw scantokens ( getparameter "mpsfont" "shapes" i "shape" )
2260                if hasparameter "mpsfont" "shapes" i "color" :
2261                    withcolor getparameter "mpsfont" "shapes" i "color"
2262                fi ;
2263        endfor ;
2264    ) scaled s ;
2265    registercomposedglyph(u, snippets) ;
2266enddef ;
2267
2268permanent registercomposeglyph, composeglyph ;
2269
2270% Again an experiment (todo: the faster method):
2271
2272% watch the ; that we scan!
2273
2274newscriptindex mfid_remaptext ; mfid_remaptext := scriptindex "remaptext" ; def lmt_remaptext = runscript mfid_remaptext ; enddef ;
2275
2276triplet mfun_tt_s ;
2277
2278vardef rawmaptext(expr s) =
2279    mfun_tt_n := mfun_tt_n + 1 ;
2280    mfun_tt_c := nullpicture ;
2281    mfun_tt_o := nullpicture ;
2282    addto mfun_tt_o doublepath origin base_draw_options ;
2283    mfun_tt_r := lua.mp.mf_map_text(mfun_tt_n,s,catcoderegime) ; % can become mfid_maptext
2284    mfun_tt_s := lua.mp.mf_map_move(mfun_tt_n) ;                 % can become mfid_mapmove
2285    addto mfun_tt_c doublepath unitsquare
2286        xscaled wdpart mfun_tt_r
2287        yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
2288        shifted (0,-dppart mfun_tt_r)
2289        withprescript "mf_object=text"
2290        withprescript "tx_index=" & decimal mfun_tt_n
2291        withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
2292    ;
2293    mfun_tt_c
2294enddef ;
2295
2296vardef svgtext(expr t) =
2297    save p ; picture p ;
2298  % mfun_tt_s := (0,0,0) ;
2299  % mfun_tt_r := (0,0,0) ;
2300    p := rawmaptext(t) ;
2301    p
2302    if (mfun_labtype.drt >= 10) : % drt etc
2303        shifted (0,ypart center p)
2304    fi
2305    shifted (
2306        - mfun_labshift.drt(p)
2307        - (redpart mfun_tt_s,0)
2308        + (greenpart mfun_tt_s,bluepart mfun_tt_s)
2309    )
2310enddef ;
2311
2312vardef svg expr c = lmt_svg [ code = c ] enddef ;
2313
2314% Fun stuff:
2315
2316presetparameters "poisson" [
2317    width     = 50,
2318    height    = 50,
2319    initialx  =  0,
2320    initialy  =  0,
2321    distance  =  1,
2322    count     = 20,
2323    macro     = "draw",
2324    arguments = 2
2325] ;
2326
2327def lmt_poisson = applyparameters "poisson" "lmt_do_poisson" enddef ;
2328
2329vardef lmt_do_poisson =
2330    image (
2331        pushparameters "poisson" ;
2332            lua.mp.lmt_poisson_generate();
2333        popparameters ;
2334    )
2335enddef ;
2336
2337permanent
2338    lmt_text, lmt_grid, lmt_axis, lmt_outline, lmt_followtext,
2339    lmt_arrow, lmt_placeholder, % lmt_path,
2340    lmt_function, lmt_poisson, lmt_mesh,
2341    lmt_chart_circle, lmt_chart_histogram, lmt_chart_bar,
2342    lmt_shade, lmt_contour, lmt_svg, lmt_surface,
2343    lmt_registerglyphs, lmt_registerglyph,
2344    lmt_remaptext, rawmaptext, svgtext, svg,
2345    OverlayMesh ;
2346
2347% nice hack
2348
2349newscriptindex mfid_scrutinized ; mfid_scrutinized := scriptindex "scrutinized" ;
2350
2351primarydef p scrutinized n =
2352    runscript mfid_scrutinized p n
2353enddef ;
2354
2355permanent scrutinized ;
2356
2357% for now here
2358
2359% newscriptindex mfid_mpv_numeric   ; mfid_mpv_numeric   := scriptindex "mpv_numeric" ;
2360% newscriptindex mfid_mpv_dimension ; mfid_mpv_dimension := scriptindex "mpv_dimension" ;
2361% newscriptindex mfid_mpv_string    ; mfid_mpv_string    := scriptindex "mpv_string" ;
2362%
2363% def mpv_numeric   = runscript mfid_mpv_numeric   enddef ;
2364% def mpv_dimension = runscript mfid_mpv_dimension enddef ;
2365% def mpv_string    = runscript mfid_mpv_string    enddef ;
2366%
2367% permanent mpv_numeric, mpv_dimension, mpv_string ;
2368
2369% newscriptindex mfid_mpvar ; mfid_mpvar := scriptindex "mpvar" ;
2370%
2371% def mpvar = runscript mfid_mpvar enddef ;
2372
2373% d(imension) n(umber) s(tring) b(oolean) <heuristic>
2374
2375newscriptindex mfid_mpvard ; mfid_mpvard := scriptindex "mpvard" ; def mpvard = runscript mfid_mpvard enddef ; % dimension
2376newscriptindex mfid_mpvarn ; mfid_mpvarn := scriptindex "mpvarn" ; def mpvarn = runscript mfid_mpvarn enddef ; % numeric
2377newscriptindex mfid_mpvars ; mfid_mpvars := scriptindex "mpvars" ; def mpvars = runscript mfid_mpvars enddef ; % string
2378newscriptindex mfid_mpvarb ; mfid_mpvarb := scriptindex "mpvarb" ; def mpvarb = runscript mfid_mpvarb enddef ; % string
2379newscriptindex mfid_mpvar  ; mfid_mpvar  := scriptindex "mpvar"  ; def mpvar  = runscript mfid_mpvar  enddef ; % automatic
2380
2381permanent mpvard, mpvarn, mpvars, mpvarb, mpvar ;
2382
2383% for old times sake (metafun manual)
2384
2385vardef textual primary p = false enddef ;
2386
2387% also for the menafun manual:
2388
2389newscriptindex mfid_labtorgb ; mfid_labtorgb := scriptindex "labtorgb" ;
2390
2391def labtorgb(expr l, a, b) = runscript mfid_labtorgb l a b enddef ;
2392
2393permanent labtorgb ;
2394
2395presetparameters "labtorgb" [
2396    mina = -100,
2397    maxa =  100,
2398    minb = -100,
2399    maxb =  100,
2400    step =    5,
2401    l    =   50,
2402] ;
2403
2404def lmt_labtorgb = applyparameters "labtorgb" "lmt_do_labtorgb" enddef ;
2405
2406vardef lmt_do_labtorgb =
2407    image (
2408        pushparameters "labtorgb" ;
2409            save l ; l := getparameter "l" ;
2410            for a = getparameter "mina" step getparameter "step" until getparameter "maxa" :
2411                for b = getparameter "minb" step getparameter "step" until getparameter "maxb" :
2412                  % draw (a,b) withcolor labtorgb(l,a,b) ;
2413                    draw (a,b) withcolor runscript mfid_labtorgb l a b ;
2414                endfor ;
2415            endfor ;
2416        popparameters ;
2417    )
2418enddef ;
2419
2420% For now we collect all lmt namespace extensions here, so also this one:
2421
2422presetparameters "matrix" [
2423  % cell    = (1, 1),
2424  % from    = (1, 1),
2425  % to      = (1, 1),
2426  % shape   = { "circle", "square" },
2427    connect = { "center", "center" },
2428  % text    = "",
2429] ;
2430
2431def lmt_matrix = applyparameters "matrix" "lmt_do_matrix" enddef ;
2432
2433vardef mfun_lmt_matrix_cell (expr p) =
2434  % anchorbox ("matrix", xpart p, ypart p) ("matrix", xpart p + 1, ypart p)
2435    matrixcell (xpart p, ypart p)
2436enddef ;
2437
2438% todo: lft rt etc but then we need to push/pop the linewidth too
2439
2440def mfun_lmt_matrix_connect (expr h, p, r, l, u, d, gap) =
2441    if     h == "right"  : center rightboundary   (p enlarged gap) { r }
2442    elseif h == "left"   : center leftboundary    (p enlarged gap) { l }
2443    elseif h == "top"    : center topboundary     (p enlarged gap) { u }
2444    elseif h == "bottom" : center bottomboundary  (p enlarged gap) { d }
2445    else                 : center                 (p enlarged gap)
2446    fi
2447enddef ;
2448
2449def mfun_lmt_matrix_source (expr p, h, gap) =
2450    mfun_lmt_matrix_connect(h, p, right, left, up, down, gap)
2451enddef ;
2452
2453def mfun_lmt_matrix_target (expr p, h, gap) =
2454    mfun_lmt_matrix_connect(h, p, left, right, down, up, gap)
2455enddef ;
2456
2457vardef mfun_lmt_matrix_enhance (expr p, h) =
2458    if h = "circle" :
2459        fullcircle xysized (bbwidth p, bbheight p) shifted center p
2460    elseif h = "round" :
2461        (p smoothed getparameterdefault "radius" ExHeight) xysized (bbwidth p, bbheight p)
2462    elseif h = "path" :
2463        (getparameterpath "path") shifted center p
2464    elseif h = "scaledpath" :
2465        (getparameterpath "path") xysized (bbwidth p, bbheight p) shifted center p
2466    else :
2467        p
2468    fi
2469enddef ;
2470
2471vardef lmt_do_matrix =
2472    image (
2473        pushparameters "matrix" ;
2474        draw image (
2475            save a, b, c, o, g ; path a, b, c ; numeric o, g ;
2476            if (hasparameter "arrowoffset") :
2477                g := getparameter "arrowoffset" ;
2478            elseif (hasparameter "linewidth") :
2479                g := getparameter "linewidth" ;
2480            else :
2481                g := 0;
2482            fi ;
2483            if (hasparameter "from") and (hasparameter "to") :
2484                a := mfun_lmt_matrix_cell(getparameter "from") ;
2485                b := mfun_lmt_matrix_cell(getparameter "to") ;
2486                if hasparameter "offset" :
2487                    o := getparameter "offset" ;
2488                    a := a enlarged o ;
2489                    b := b enlarged o ;
2490                fi ;
2491                if hasparameter "shapes" :
2492                    a := mfun_lmt_matrix_enhance(a, getparameter "shapes" 1) ;
2493                    b := mfun_lmt_matrix_enhance(b, getparameter "shapes" 2) ;
2494                fi ;
2495                draw a
2496                    if (hasparameter "colors") :
2497                        withcolor (getparameter "colors" 1)
2498                    elseif (hasparameter "color") :
2499                        withcolor (getparameter "color")
2500                    fi
2501                ;
2502                draw b
2503                    if (hasparameter "colors") :
2504                        withcolor (getparameter "colors" 2)
2505                    elseif (hasparameter "color") :
2506                        withcolor (getparameter "color")
2507                    fi
2508                ;
2509                c :=
2510                    mfun_lmt_matrix_source(a, getparameter "connect" 1, g) ..
2511                    mfun_lmt_matrix_target(b, getparameter "connect" 2, g) ;
2512                drawarrow c
2513                    if (hasparameter "arrowcolor") :
2514                        withcolor (getparameter "arrowcolor")
2515                    elseif (hasparameter "color") :
2516                        withcolor (getparameter "color")
2517                    fi
2518                ;
2519                if hasparameter "label" :
2520                    pushparameters "label" ;
2521                    draw lmt_text [
2522                        text     = getparameter "text",
2523                        position = point (getparameterdefault "fraction" 1/2) of c,
2524                        offset   = if hasparameter "offset" : getparameter "offset" fi,
2525                        color    = if hasparameter "color"  : getparameter "color"  fi,
2526                        anchor   = if hasparameter "anchor" : getparameter "anchor" fi,
2527                      % strut style format background backgroundcolor
2528                    ] ;
2529                    popparameters ;
2530                fi ;
2531            elseif (hasparameter "cell") :
2532                a := mfun_lmt_matrix_cell(getparameter "cell") ;
2533                if hasparameter "offset" :
2534                    o := getparameter "offset" ;
2535                    a := a enlarged o ;
2536                fi ;
2537                if hasparameter "shape" :
2538                    a := mfun_lmt_matrix_enhance(a, getparameter "shape") ;
2539                fi ;
2540                draw a
2541                    if (hasparameter "color") :
2542                        withcolor (getparameter "color")
2543                    fi
2544                ;
2545            fi;
2546        )
2547        if (hasparameter "linewidth") :
2548            withpen pencircle scaled (getparameter "linewidth")
2549        fi
2550        popparameters
2551    )
2552enddef ;
2553