%D \module
%D   [       file=mp-mlib.mpiv,
%D        version=2008.03.21,
%D          title=\CONTEXT\ \METAPOST\ graphics,
%D       subtitle=plugins,
%D         author=Hans Hagen,
%D           date=\currentdate,
%D      copyright={PRAGMA ADE \& \CONTEXT\ Development Team}]
%C
%C This module is part of the \CONTEXT\ macro||package and is
%C therefore copyrighted by \PRAGMA. See licen-en.pdf for
%C details.

% todo: ... & mfun_prescript_separator & ...

if known metafun_loaded_mlib : endinput ; fi ;

newinternal boolean metafun_loaded_mlib ; metafun_loaded_mlib := true ; immutable metafun_loaded_mlib ;

% numeric LUATEXFUNCTIONALITY ; LUATEXFUNCTIONALITY := runscript("mp.print(LUATEXFUNCTIONALITY or (status and status.development_id) or 6346)") ;

%D Color and transparency
%D
%D Separable:

newinternal normaltransparent     ; normaltransparent     :=  1 ;
newinternal multiplytransparent   ; multiplytransparent   :=  2 ;
newinternal screentransparent     ; screentransparent     :=  3 ;
newinternal overlaytransparent    ; overlaytransparent    :=  4 ;
newinternal softlighttransparent  ; softlighttransparent  :=  5 ;
newinternal hardlighttransparent  ; hardlighttransparent  :=  6 ;
newinternal colordodgetransparent ; colordodgetransparent :=  7 ;
newinternal colorburntransparent  ; colorburntransparent  :=  8 ;
newinternal darkentransparent     ; darkentransparent     :=  9 ;
newinternal lightentransparent    ; lightentransparent    := 10 ;
newinternal differencetransparent ; differencetransparent := 11 ;
newinternal exclusiontransparent  ; exclusiontransparent  := 12 ;

%D Nonseparable:

newinternal huetransparent        ; huetransparent        := 13 ;
newinternal saturationtransparent ; saturationtransparent := 14 ;
newinternal colortransparent      ; colortransparent      := 15 ;
newinternal luminositytransparent ; luminositytransparent := 16 ;

permanent normaltransparent, multiplytransparent, screentransparent, overlaytransparent,
    softlighttransparent, hardlighttransparent, colordodgetransparent, colorburntransparent,
    darkentransparent, lightentransparent, differencetransparent, exclusiontransparent,
    huetransparent, saturationtransparent, colortransparent, luminositytransparent ;

vardef transparency_alternative_to_number(expr name) =
    if string name :
        if expandafter known scantokens(name & "transparent") :
            scantokens(name & "transparent")
        else :
            0
        fi
    elseif name < 17 :
        name
    else :
        0
    fi
enddef ;

def namedcolor expr n =
    (1)
    withnestedprescript "sp_type=named"
    withnestedprescript "sp_name=" & n
enddef ;

% def mfun_spotcolor(expr n, v) =
%     1
%     withnestedprescript "sp_type=xspot"
%     withnestedprescript "sp_name="  & n
%     withnestedprescript "sp_value=" & (if numeric v : decimal v else : v fi)
% enddef ;

% def mfun_multispotcolor(expr name, fractions, components, value) =
%     1
%     withnestedprescript "sp_type=multispot"
%     withnestedprescript "sp_name="       & name
%     withnestedprescript "sp_fractions="  & decimal fractions
%     withnestedprescript "sp_components=" & components
%     withnestedprescript "sp_value="      & value
% enddef ;

def spotcolor(expr name, v) =
    (1)
    withnestedprescript "sp_type=spot"
    withnestedprescript "sp_name=" & name
    withnestedprescript "sp_value=" & colordecimals v
enddef ;

% In this case a mixed color will be calculated:

def multitonecolor(expr name)(text t) =
    (1)
    withnestedprescript "sp_type=multitone"
    withnestedprescript "sp_name=" & name
    withnestedprescript "sp_value=" & colordecimalslist(t)
enddef ;

def transparent(expr a, t)(text c) = % use withtransparency instead
    (1) % this permits withcolor x intoshade y
    withnestedprescript "tr_alternative=" & decimal transparency_alternative_to_number(a)
    withnestedprescript "tr_transparency=" & decimal t
    withcolor c
enddef ;

def withtransparency(expr a, t) =
    withnestedprescript "tr_alternative="  & decimal transparency_alternative_to_number(a)
    withnestedprescript "tr_transparency=" & decimal t
enddef ;

% for svg:

def withopacity expr o =
    if o <> 1 :
        withnestedprescript "tr_alternative="  & decimal normaltransparent
        withnestedprescript "tr_transparency=" & decimal o
    fi
enddef ;

% Provided for downward compability:

def cmyk(expr c, m, y, k) =
    (c,m,y,k)
enddef ;

permanent spotcolor, multitonecolor, transparent, withtransparency, namedcolor, withopacity, cmyk ;

% Texts (todo: better strut ratio, now .7 hardcoded, should be passed)

newinternal textextoffset ; textextoffset := 0 ;

permanent textextoffset ;

rgbcolor mfun_tt_r ;
numeric  mfun_tt_n ; mfun_tt_n := 0 ;
picture  mfun_tt_p ; mfun_tt_p := nullpicture ;
picture  mfun_tt_o ; mfun_tt_o := nullpicture ;
picture  mfun_tt_c ; mfun_tt_c := nullpicture ;

if unknown mfun_trial_run :
    boolean mfun_trial_run ;
    mfun_trial_run := false ;
else :
    % already defined before the format is loaded
fi ;

def mfun_reset_tex_texts =
    mfun_tt_n := 0 ;
    mfun_tt_p := nullpicture ;
    mfun_tt_o := nullpicture ; % redundant
    mfun_tt_c := nullpicture ; % redundant
enddef ;

def mfun_flush_tex_texts =
    addto currentpicture also mfun_tt_p
enddef ;

extra_endfig   := "mfun_flush_tex_texts ;" & extra_endfig ;
extra_beginfig := extra_beginfig & "mfun_reset_tex_texts ;" ;

% We collect and flush them all, as we can also have temporary textexts
% that gets never really flushed but are used for calculations. So, we
% flush twice: once in location in order to pick up e.g. color properties,
% and once at the end because we need to flush missing ones.

boolean mfun_onetime_textext ; mfun_onetime_textext := false ;
numeric mfun_global_textext ; mfun_global_textext := 0 ;

def keepcached =
    hide(mfun_global_textext := mfun_global_textext + 1;)
    withprescript ("tx_cache=" & decimal mfun_global_textext)
enddef ;

def notcached =
    withprescript "tx_cache=no"
enddef ;

permanent keepcached, notcached ;

% todo: onetime

rgbcolor mfun_tt_r ;

newinternal inicatcoderegime ; inicatcoderegime := runscript("return catcodes.numbers.ctxcatcodes") ;
newinternal texcatcoderegime ; texcatcoderegime := runscript("return catcodes.numbers.texcatcodes") ;
newinternal luacatcoderegime ; luacatcoderegime := runscript("return catcodes.numbers.luacatcodes") ;
newinternal notcatcoderegime ; notcatcoderegime := runscript("return catcodes.numbers.notcatcodes") ;
newinternal vrbcatcoderegime ; vrbcatcoderegime := runscript("return catcodes.numbers.vrbcatcodes") ;
newinternal prtcatcoderegime ; prtcatcoderegime := runscript("return catcodes.numbers.prtcatcodes") ;
newinternal ctxcatcoderegime ; ctxcatcoderegime := runscript("return catcodes.numbers.ctxcatcodes") ;
newinternal txtcatcoderegime ; txtcatcoderegime := runscript("return catcodes.numbers.txtcatcodes") ;

newinternal catcoderegime    ; catcoderegime    := ctxcatcoderegime ;

immutable inicatcoderegime, texcatcoderegime, luacatcoderegime, notcatcoderegime,
    vrbcatcoderegime, prtcatcoderegime, ctxcatcoderegime, txtcatcoderegime ;

permanent catcoderegime ;

newscriptindex mfid_sometextext   ; mfid_sometextext   := scriptindex "sometextext" ;
newscriptindex mfid_madetextext   ; mfid_madetextext   := scriptindex "madetextext" ;
newscriptindex mfid_boxdimensions ; mfid_boxdimensions := scriptindex "boxdimensions" ;

vardef rawtextext(expr s) =
    if s = "" :
        nullpicture
    else :
        mfun_tt_n := mfun_tt_n + 1 ;
        mfun_tt_c := nullpicture ;
        mfun_tt_o := nullpicture ;
        addto mfun_tt_o doublepath origin base_draw_options ;
        mfun_tt_r := runscript mfid_sometextext mfun_tt_n s catcoderegime ;
        addto mfun_tt_c doublepath unitsquare
            xscaled wdpart mfun_tt_r
            yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
            shifted (0,-dppart mfun_tt_r)
            withprescript "mf_object=text"
            withprescript "tx_index=" & decimal mfun_tt_n
            withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
        ;
        mfun_tt_c
    fi
enddef ;

vardef rawmadetext =
    mfun_tt_n := mfun_tt_n + 1 ;
    mfun_tt_c := nullpicture ;
    mfun_tt_o := nullpicture ;
    addto mfun_tt_o doublepath origin base_draw_options ;
    mfun_tt_r := runscript mfid_madetextext mfun_tt_n ;
    addto mfun_tt_c doublepath unitsquare
        xscaled wdpart mfun_tt_r
        yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
        shifted (0,-dppart mfun_tt_r)
        withprescript "mf_object=text"
        withprescript "tx_index=" & decimal mfun_tt_n
        withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
    ;
    mfun_tt_c
enddef ;

% \setbox\scratchbox\hbox{!!!!!!!!!!!!!}
% \putboxincache{one}{a}\scratchbox
% \startMPcode draw rawtexbox("one","a") ; \stopMPcode

vardef validtexbox(expr category, name) =
    if category == "" :
        false
    elseif string name :
        name <> ""
    elseif numeric name :
        name > 0
    else :
        true
    fi
enddef ;

vardef rawtexbox(expr category, name) =
    mfun_tt_c := nullpicture ;
    if validtexbox(category,name) :
      % mfun_tt_r := lua.mp.mf_tb_dimensions(category, name) ;
        mfun_tt_r := runscript mfid_boxdimensions category name ;
        addto mfun_tt_c doublepath unitsquare
            xscaled wdpart mfun_tt_r
            yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
            shifted (0,- dppart mfun_tt_r)
            withprescript "mf_object=box"
            withprescript "bx_category=" & if numeric category : decimal fi category
            withprescript "bx_name=" & if numeric name : decimal fi name ;
    fi
    mfun_tt_c
enddef ;

% More text

defaultfont  := "Mono" ;
defaultscale := 1 ;

extra_beginfig := extra_beginfig & "defaultscale:=1;" ;

vardef fontsize expr name =
    save size ; numeric size ;
    size := bbwidth(textext("\MPfontsizehskip{" & name & "}")) ;
    if size = 0 :
        12pt
    else :
        size
    fi
enddef ;

permanent fontsize ;

pair mfun_laboff        ; mfun_laboff        := origin   ;
pair mfun_laboff.lft    ; mfun_laboff.lft    := (-1,0)   ;
pair mfun_laboff.rt     ; mfun_laboff.rt     := (1,0)    ;
pair mfun_laboff.bot    ; mfun_laboff.bot    := (0,-1)   ;
pair mfun_laboff.top    ; mfun_laboff.top    := (0,1)    ;
pair mfun_laboff.ulft   ; mfun_laboff.ulft   := (-.7,.7) ;
pair mfun_laboff.urt    ; mfun_laboff.urt    := (.7,.7)  ;
pair mfun_laboff.llft   ; mfun_laboff.llft   := -(.7,.7) ;
pair mfun_laboff.lrt    ; mfun_laboff.lrt    := (.7,-.7) ;

pair mfun_laboff.d      ; mfun_laboff.d      := mfun_laboff     ;
pair mfun_laboff.dlft   ; mfun_laboff.dlft   := mfun_laboff.lft ;
pair mfun_laboff.drt    ; mfun_laboff.drt    := mfun_laboff.rt  ;
pair mfun_laboff.origin ; mfun_laboff.origin := mfun_laboff     ;
pair mfun_laboff.raw    ; mfun_laboff.raw    := mfun_laboff     ;

pair mfun_laboff.l      ; mfun_laboff.l      := mfun_laboff.lft  ;
pair mfun_laboff.r      ; mfun_laboff.r      := mfun_laboff.rt   ;
pair mfun_laboff.b      ; mfun_laboff.b      := mfun_laboff.bot  ;
pair mfun_laboff.t      ; mfun_laboff.t      := mfun_laboff.top  ;
pair mfun_laboff.l_t    ; mfun_laboff.l_t    := mfun_laboff.ulft ;
pair mfun_laboff.r_t    ; mfun_laboff.r_t    := mfun_laboff.urt  ;
pair mfun_laboff.l_b    ; mfun_laboff.l_b    := mfun_laboff.llft ;
pair mfun_laboff.r_b    ; mfun_laboff.r_b    := mfun_laboff.lrt  ;
pair mfun_laboff.t_l    ; mfun_laboff.t_l    := mfun_laboff.ulft ;
pair mfun_laboff.t_r    ; mfun_laboff.t_r    := mfun_laboff.urt  ;
pair mfun_laboff.b_l    ; mfun_laboff.b_l    := mfun_laboff.llft ;
pair mfun_laboff.b_r    ; mfun_laboff.b_r    := mfun_laboff.lrt  ;

mfun_labxf                                              := 0.5 ;
mfun_labxf.lft      := mfun_labxf.l                     := 1   ;
mfun_labxf.rt       := mfun_labxf.r                     := 0   ;
mfun_labxf.bot      := mfun_labxf.b                     := 0.5 ;
mfun_labxf.top      := mfun_labxf.t                     := 0.5 ;
mfun_labxf.ulft     := mfun_labxf.l_t := mfun_labxf.t_l := 1   ;
mfun_labxf.urt      := mfun_labxf.r_t := mfun_labxf.t_r := 0   ;
mfun_labxf.llft     := mfun_labxf.l_b := mfun_labxf.b_l := 1   ;
mfun_labxf.lrt      := mfun_labxf.r_b := mfun_labxf.b_r := 0   ;

mfun_labxf.d        := mfun_labxf     ;
mfun_labxf.dlft     := mfun_labxf.lft ;
mfun_labxf.drt      := mfun_labxf.rt  ;
mfun_labxf.origin   := 0              ;
mfun_labxf.raw      := 0              ;

mfun_labyf                                              := 0.5 ;
mfun_labyf.lft      := mfun_labyf.l                     := 0.5 ;
mfun_labyf.rt       := mfun_labyf.r                     := 0.5 ;
mfun_labyf.bot      := mfun_labyf.b                     := 1   ;
mfun_labyf.top      := mfun_labyf.t                     := 0   ;
mfun_labyf.ulft     := mfun_labyf.l_t := mfun_labyf.t_l := 0   ;
mfun_labyf.urt      := mfun_labyf.r_t := mfun_labyf.t_r := 0   ;
mfun_labyf.llft     := mfun_labyf.l_b := mfun_labyf.b_l := 1   ;
mfun_labyf.lrt      := mfun_labyf.r_b := mfun_labyf.b_r := 1   ;

mfun_labyf.d        := mfun_labyf     ;
mfun_labyf.dlft     := mfun_labyf.lft ;
mfun_labyf.drt      := mfun_labyf.rt  ;
mfun_labyf.origin   := 0              ;
mfun_labyf.raw      := 0              ;

mfun_labtype                                                 :=  0 ;
mfun_labtype.lft    := mfun_labtype.l                        :=  1 ;
mfun_labtype.rt     := mfun_labtype.r                        :=  2 ;
mfun_labtype.bot    := mfun_labtype.b                        :=  3 ;
mfun_labtype.top    := mfun_labtype.t                        :=  4 ;
mfun_labtype.ulft   := mfun_labtype.l_t :=  mfun_labtype.t_l :=  5 ;
mfun_labtype.urt    := mfun_labtype.r_t :=  mfun_labtype.t_r :=  6 ;
mfun_labtype.llft   := mfun_labtype.l_b :=  mfun_labtype.b_l :=  7 ;
mfun_labtype.lrt    := mfun_labtype.r_b :=  mfun_labtype.b_r :=  8 ;
mfun_labtype.d                                               := 10 ;
mfun_labtype.dlft                                            := 11 ;
mfun_labtype.drt                                             := 12 ;
mfun_labtype.origin                                          :=  0 ;
mfun_labtype.raw                                             :=  0 ;

vardef installlabel@# (expr type, x, y, offset) =
    numeric mfun_labtype@# ; mfun_labtype@# := type ;
    pair    mfun_laboff @# ; mfun_laboff @# := offset ;
    numeric mfun_labxf  @# ; mfun_labxf  @# := x ;
    numeric mfun_labyf  @# ; mfun_labyf  @# := y ;
enddef ;

permanent installlabel ;

installlabel.center (0, 0.5, 0.5, (0,0)) ;
installlabel.c      (0, 0.5, 0.5, (0,0)) ;

installlabel.hcenter(0, 0.5, 0.5, (1,0)) ;
installlabel.h      (0, 0.5, 0.5, (1,0)) ;

installlabel.vcenter(0, 0.5, 0.5, (0,1)) ;
installlabel.v      (0, 0.5, 0.5, (0,1)) ;

vardef mfun_labshift@#(expr p) =
    (mfun_labxf@#*lrcorner p +
     mfun_labyf@#*ulcorner p +
     (1-mfun_labxf@#-mfun_labyf@#)*llcorner p)
enddef ;

vardef mfun_picshift@#(expr p) =
    (mfun_labxf@#*ulcorner p +
     mfun_labyf@#*lrcorner p +
     (1-mfun_labxf@#-mfun_labyf@#)*urcorner p)
enddef ;

% we save the plain variant

% vardef plain_thelabel@#(expr p,z) =
%     if string p :
%         plain_thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
%     else :
%         p shifted (z + labeloffset*laboff@# - mfun_labshift@#(p))
%     fi
% enddef;
%
% def plain_label = % takes two arguments, contrary to textext that takes one
%     normaldraw plain_thelabel
% enddef ;
%
% let mfun_label    = label ;
% let mfun_thelabel = thelabel ;
%
% def useplainlabels = % somehow let doesn't work for all code
%     def label    = plain_label    enddef ;
%     def thelabel = plain_thelabel enddef ;
% enddef ;
%
% def usemetafunlabels =
%     let label    = mfun_label ;
%     let thelabel = mfun_thelabel ;
% enddef ;
%
% plain_compatibility_data := plain_compatibility_data & "save label, thelabel ;" & "useplainlabels ;" ;

newinternal anchortextexts ; anchortextexts := 0 ; % disabled by default

vardef thetextext@#(expr p,z) =
  % interim labeloffset := textextoffset ;
    if string p :
        thetextext@#(rawtextext(p),z)
    elseif numeric p :
        thetextext@#(rawtextext(decimal p),z)
    elseif pair p :
        thetextext@#(rawtextext(ddecimal p),z)
    else :
        if anchortextexts > 0 :
            image(draw p withprescript "tx_anchor=" & ddecimal z)
        else :
            p
        fi
        if (mfun_labtype@# >= 10) :
            shifted (0,ypart center p)
        fi
        shifted (z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
    fi
enddef ;

vardef textext@#(expr p) = % no draw here
    thetextext@#(p,origin)
enddef ;

vardef onetimetextext@#(expr p) = % no draw here
    mfun_onetime_textext := true ;
    thetextext@#(p,origin)
enddef ;

permanent rawtextext, rawmadetext, validtexbox, rawtexbox, thetextext, textext, onetimetextext ;

% formatted text

pair mfun_tt_z ;

vardef rawfmttext(text t) =
    mfun_tt_n := mfun_tt_n + 1 ;
    mfun_tt_c := nullpicture ;
    mfun_tt_o := nullpicture ;
    addto mfun_tt_o doublepath origin base_draw_options ;
    mfun_tt_r := lua.mp.mf_formatted_text(mfun_tt_n,t) ;
    addto mfun_tt_c doublepath unitsquare
        xscaled wdpart mfun_tt_r
        yscaled (htpart mfun_tt_r + dppart mfun_tt_r)
        shifted (0,-dppart mfun_tt_r)
        withprescript "mf_object=text"
        withprescript "tx_index=" & decimal mfun_tt_n
        withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
    ;
    for s = t :
        if pair s : mfun_tt_z := s ; fi
    endfor ;
    mfun_tt_c
enddef ;

vardef thefmttext@#(text t) =
    mfun_tt_z := origin ; % initialization
    save p ; picture p ; p := rawfmttext(t) ;
    if anchortextexts > 0 :
        image(draw p withprescript "tx_anchor=" & ddecimal mfun_tt_z)
    else :
        p
    fi
        if (mfun_labtype@# >= 10) :
            shifted (0,ypart center p)
        fi
        shifted (mfun_tt_z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
enddef ;

vardef fmttext@#(text t) = % no draw here
    thefmttext@#(t,origin)
enddef ;

% or just: def fmttext = thefmttext enddef ;

vardef onetimefmttext@#(text t) = % no draw here
    mfun_onetime_textext := true ;
    thefmttext@#(t,origin)
enddef ;

% so much for formatted text

vardef thetexbox@#(expr category, name, z) =
    save p ; picture p ; p := rawtexbox(category,name) ;
    p
        if (mfun_labtype@# >= 10) :
            shifted (0,ypart center p)
        fi
        shifted (z + textextoffset*mfun_laboff@# - mfun_labshift@#(p))
enddef ;

vardef texbox@#(expr category, name) = % no draw here
    thetexbox@#(category,name,origin)
enddef ;

permanent rawfmttext, thefmttext, fmttext, onetimefmttext, thetexbox, texbox ;

% vardef thelabel@#(expr p,z) =
%     if string p :
%         thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
%     else :
%         p shifted (z + labeloffset*mfun_laboff@# - (mfun_labxf@#*lrcorner p + mfun_labyf@#*ulcorner p + (1-mfun_labxf@#-mfun_labyf@#)*llcorner p))
%     fi
% enddef;

vardef theoffset@#(expr z) =
    if pair z :
        z
    elseif path z :
        if mfun_laboff@# = origin :
            center z
        else :
            ((center z)-- mfun_picshift@#(z)) intersectionpoint (z if not cycle z: --cycle fi)
        fi
    else : % picture
        mfun_picshift@#(z)
    fi
enddef;

vardef thelabel@#(expr p,z) =
    if string p :
        thelabel@#(rawtextext("\definedfont[" & defaultfont & "]" & p) scaled defaultscale,z)
    elseif numeric p :
        thelabel@#(decimal p,z)
    elseif pair p :
        thelabel@#("(" & decimal(xpart p) & "," & decimal(ypart p) & ")",z)
    else :
        p shifted (theoffset@#(z) + labeloffset*mfun_laboff@# - mfun_labshift@#(p))
    fi
enddef;

def label = % takes two arguments, contrary to textext that takes one
    normaldraw thelabel
enddef ;

vardef anchored@#(expr p, z) = % beware: no "+ mfun_laboff@#" here (never!)
    p
        if (mfun_labtype@# >= 10) :
            shifted (0,ypart center p)
        fi
        shifted (z + mfun_labshift@#(p))
enddef ;

let normalinfont = infont ;

primarydef s infont name = % nasty hack
    if name = "" :
        textext(s)
    else :
        textext("\definedfont[" & name & "]" & s)
    fi
enddef ;

permanent theoffset, thelabel, anchored ;
primitive infont ; % fake primitive

% Helper

string mfun_prescript_separator ; mfun_prescript_separator := char(13) ;

% Shades

% for while we had this:

newinternal shadefactor  ; shadefactor  := 1 ;      % currently obsolete
pair        shadeoffset  ; shadeoffset  := origin ; % currently obsolete
boolean     trace_shades ; trace_shades := false ;  % still there

permanent shadefactor, shadeoffset ;

% def withlinearshading (expr a, b) =
%     withprescript "sh_type=linear"
%     withprescript "sh_domain=0 1"
%     withprescript "sh_factor="   & decimal shadefactor
%     withprescript "sh_center_a=" & ddecimal (a shifted shadeoffset)
%     withprescript "sh_center_b=" & ddecimal (b shifted shadeoffset)
% enddef ;
%
% def withcircularshading (expr a, b, ra, rb) =
%     withprescript "sh_type=circular"
%     withprescript "sh_domain=0 1"
%     withprescript "sh_factor="   & decimal shadefactor
%     withprescript "sh_center_a=" & ddecimal (a shifted shadeoffset)
%     withprescript "sh_center_b=" & ddecimal (b shifted shadeoffset)
%     withprescript "sh_radius_a=" & decimal ra
%     withprescript "sh_radius_b=" & decimal rb
% enddef ;
%
% def withshading (expr how)(text rest) =
%     if how = "linear" :
%         withlinearshading(rest)
%     elseif how = "circular" :
%         withcircularshading(rest)
%     else :
%         % nothing
%     fi
% enddef ;
%
% def withfromshadecolor expr t =
%     withprescript "sh_color=into"
%     withprescript "sh_color_a=" & colordecimals t
% enddef ;

% def withtoshadecolor expr t =
%     withprescript "sh_color=into"
%     withprescript "sh_color_b=" & colordecimals t
% enddef ;

% but this is nicer

% fill fullcircle scaled 10cm
%     withshademethod "circular"
%     withshadevector (5cm,1cm)
%     withshadecenter (.1,.5)
%     withshadedomain (.2,.6)
%     withshadefactor 1.2
%     withshadecolors (red,green)
% ;

path    mfun_shade_path ;
numeric mfun_shade_step ; mfun_shade_step := 0 ;

def withshadestep =
    hide(mfun_shade_step := mfun_shade_step + 1 ;)
    mfun_withshadestep
enddef ;

def mfun_withshadestep (text t) =
    withprescript "sh_step=" & decimal mfun_shade_step
    t
    withnothing % otherwise we scan ahead and can unwantingly bump the step
enddef ;

numeric mfun_shade_fx, mfun_shade_fy ;
numeric mfun_shade_lx, mfun_shade_ly ;
numeric mfun_shade_nx, mfun_shade_ny ;
numeric mfun_shade_dx, mfun_shade_dy ;
numeric mfun_shade_tx, mfun_shade_ty ;
pair    mfun_shade_center ;
path    mfun_shade_bbox ;

numeric mfun_shade_height, mfun_shade_width;

% def mfun_with_shade_method_analyze(expr p) =
%     mfun_shade_path   := p ;
%     mfun_shade_bbox   := boundingbox p ;
%     mfun_shade_center := center p ;
%     mfun_shade_width  := bbwidth p ;
%     mfun_shade_height := bbheight p ;
%     mfun_shade_step   := 1 ;
%     mfun_shade_fx     := xpart point 0 of p ;
%     mfun_shade_fy     := ypart point 0 of p ;
%     mfun_shade_lx     := mfun_shade_fx ;
%     mfun_shade_ly     := mfun_shade_fy ;
%     mfun_shade_nx     := 0 ;
%     mfun_shade_ny     := 0 ;
%     mfun_shade_dx     := abs(mfun_shade_fx - mfun_shade_lx) ;
%     mfun_shade_dy     := abs(mfun_shade_fy - mfun_shade_ly) ;
%     for i=1 upto length(p) :
%         mfun_shade_tx := abs(mfun_shade_fx - xpart point i of p) ;
%         mfun_shade_ty := abs(mfun_shade_fy - ypart point i of p) ;
%         if mfun_shade_tx > mfun_shade_dx :
%             mfun_shade_nx := i + 1 ;
%             mfun_shade_lx := xpart point i of p ;
%             mfun_shade_dx := mfun_shade_tx ;
%         fi ;
%         if mfun_shade_ty > mfun_shade_dy :
%             mfun_shade_ny := i + 1 ;
%             mfun_shade_ly := ypart point i of p ;
%             mfun_shade_dy := mfun_shade_ty ;
%         fi ;
%     endfor ;
% enddef ;

def mfun_with_shade_method_analyze(expr p) =
    mfun_shade_path   := p ;
    mfun_shade_bbox   := boundingbox p ;
    mfun_shade_center := center mfun_shade_bbox ;
    mfun_shade_width  := bbwidth mfun_shade_bbox ;
    mfun_shade_height := bbheight mfun_shade_bbox ;
    mfun_shade_step   := 1 ;
    mfun_shade_fx     := xpart point 0 of p ;
    mfun_shade_fy     := ypart point 0 of p ;
    mfun_shade_lx     := mfun_shade_fx ;
    mfun_shade_ly     := mfun_shade_fy ;
    mfun_shade_nx     := 0 ;
    mfun_shade_ny     := 0 ;
    mfun_shade_dx     := abs(mfun_shade_fx - mfun_shade_lx) ;
    mfun_shade_dy     := abs(mfun_shade_fy - mfun_shade_ly) ;
    for i within p :
        mfun_shade_tx := abs(mfun_shade_fx - xpart pathpoint) ;
        mfun_shade_ty := abs(mfun_shade_fy - ypart pathpoint) ;
        if mfun_shade_tx > mfun_shade_dx :
            mfun_shade_nx := i + 1 ;
            mfun_shade_lx := xpart pathpoint ;
            mfun_shade_dx := mfun_shade_tx ;
        fi ;
        if mfun_shade_ty > mfun_shade_dy :
            mfun_shade_ny := i + 1 ;
            mfun_shade_ly := ypart pathpoint ;
            mfun_shade_dy := mfun_shade_ty ;
        fi ;
    endfor ;
enddef ;

% todo: native bbox

vardef mfun_shade_center_fraction_do expr a =
    ddecimal (
        (xpart llcorner mfun_shade_bbox) + (xpart a) * mfun_shade_width,
        (ypart llcorner mfun_shade_bbox) + (ypart a) * mfun_shade_height
    )
enddef ;

def withshadecenterfraction expr a =
    withprescript "sh_center_a=" & mfun_shade_center_fraction_do a
    withprescript "sh_center_b=" & mfun_shade_center_fraction_do a
enddef ;

def withshadecenteronefraction expr a =
    withprescript "sh_center_a=" & mfun_shade_center_fraction_do a
enddef ;

def withshadecentertwofraction expr a =
    withprescript "sh_center_b=" & mfun_shade_center_fraction_do a
enddef ;

def withshaderadiusfraction expr a =
    withprescript "sh_radius_a=0"
    withprescript "sh_radius_b=" & decimal (a * sqrt(mfun_shade_width*mfun_shade_width+mfun_shade_height*mfun_shade_height)/2)
enddef ;

vardef mfun_max_radius(expr p) =
    max (
        (xpart center   p - xpart llcorner p) ++ (ypart center   p - ypart llcorner p),
        (xpart center   p - xpart ulcorner p) ++ (ypart ulcorner p - ypart center   p),
        (xpart lrcorner p - xpart center   p) ++ (ypart center   p - ypart lrcorner p),
        (xpart urcorner p - xpart center   p) ++ (ypart urcorner p - ypart center   p)
    )
enddef ;

vardef mfun_min_radius(expr p) =
    min (
        (xpart center   p - xpart llcorner p) ++ (ypart center   p - ypart llcorner p),
        (xpart center   p - xpart ulcorner p) ++ (ypart ulcorner p - ypart center   p),
        (xpart lrcorner p - xpart center   p) ++ (ypart center   p - ypart lrcorner p),
        (xpart urcorner p - xpart center   p) ++ (ypart urcorner p - ypart center   p)
    )
enddef ;

primarydef p withshademethod m =
    hide(mfun_with_shade_method_analyze(p))
    p
    withprescript "sh_domain=0 1"
    withprescript "sh_transform=yes"
    withprescript "sh_color=into"
    withprescript "sh_color_a=" & colordecimals white
    withprescript "sh_color_b=" & colordecimals black
    withprescript "sh_first=" & ddecimal point 0 of p % used for support scaling
    withprescript "sh_set_x=" & ddecimal (mfun_shade_nx,mfun_shade_lx) %
    withprescript "sh_set_y=" & ddecimal (mfun_shade_ny,mfun_shade_ly) %
    if m = "linear" :
        withprescript "sh_type=linear"
        withprescript "sh_factor=1"
        withprescript "sh_center_a=" & ddecimal llcorner p
        withprescript "sh_center_b=" & ddecimal urcorner p
    else :
        withprescript "sh_type=circular"
        withprescript "sh_factor=1.2"
        withprescript "sh_center_a=" & ddecimal center p
        withprescript "sh_center_b=" & ddecimal center p
        withprescript "sh_radius_a=" & decimal 0
        withprescript "sh_radius_b=" & decimal mfun_max_radius(p)
    fi
enddef ;

def withshaderadius expr a =
    withprescript "sh_radius_a=" & decimal (xpart a)
    withprescript "sh_radius_b=" & decimal (ypart a)
enddef ;

def withshadeorigin expr a =
    withprescript "sh_center_a=" & ddecimal a
    withprescript "sh_center_b=" & ddecimal a
enddef ;

def withshadecenterone expr a =
    withprescript "sh_center_a=" & ddecimal a
enddef ;

def withshadecentertwo expr a =
    withprescript "sh_center_b=" & ddecimal a
enddef ;

def withshadevector expr a =
    withprescript "sh_center_a=" & ddecimal (point xpart a of mfun_shade_path)
    withprescript "sh_center_b=" & ddecimal (point ypart a of mfun_shade_path)
enddef ;

def withshadedirection expr a =
    withprescript "sh_center_a=" & ddecimal (point xpart a of boundingbox(mfun_shade_path))
    withprescript "sh_center_b=" & ddecimal (point ypart a of boundingbox(mfun_shade_path))
enddef ;

def withshadetransform expr a = % yes | no
    withprescript "sh_transform=" & a
enddef ;

def withshadetransformation expr a =
    withprescript "sh_transformation=" &
        decimal (xxpart a) & " " &
        decimal (yxpart a) & " " &
        decimal (xypart a) & " " &
        decimal (yypart a) & " " &
        decimal (xpart  a) & " " &
        decimal (ypart  a)
enddef ;

pair shadedup    ; shadedup    := (0.5,2.5) ;
pair shadeddown  ; shadeddown  := (2.5,0.5) ;
pair shadedleft  ; shadedleft  := (1.5,3.5) ;
pair shadedright ; shadedright := (3.5,1.5) ;

def withshadecenter expr a =
    withprescript "sh_center_a=" & ddecimal (
        center mfun_shade_path shifted (
            xpart a * bbwidth (mfun_shade_path)/2,
            ypart a * bbheight(mfun_shade_path)/2
        )
    )
enddef ;

def withshadedomain expr d =
    withprescript "sh_domain=" & ddecimal d
enddef ;

def withshadefactor expr f =
    withprescript "sh_factor=" & decimal f
enddef ;

% def withshadebound (expr a) =
%     if mfun_shade_step > 0 :
%         withprescript "sh_bound_" & decimal mfun_shade_step & "=" & decimal a
%     fi
% enddef ;

def withshadefraction expr a =
    if mfun_shade_step > 0 :
        withprescript "sh_fraction_" & decimal mfun_shade_step & "=" & decimal a
    fi
enddef ;

% def withshadeopacity expr a =
%     if mfun_shade_step > 0 :
%         withprescript "sh_opacity_" & decimal mfun_shade_step & "=" & decimal a
%         % withtransparency(3,1)
%     fi
% enddef ;

def withshadecolors (expr a, b) =
    if mfun_shade_step > 0 :
        withprescript "sh_color=into"
        withprescript "sh_color_a_" & decimal mfun_shade_step & "=" & colordecimals a
        withprescript "sh_color_b_" & decimal mfun_shade_step & "=" & colordecimals b
    else :
        withprescript "sh_color=into"
        withprescript "sh_color_a=" & colordecimals a
        withprescript "sh_color_b=" & colordecimals b
    fi
enddef ;

primarydef a shadedinto b = % withcolor red shadedinto green
    1 % does not work with transparency
    withprescript "sh_color=into"
    withprescript "sh_color_a=" & colordecimals a
    withprescript "sh_color_b=" & colordecimals b
enddef ;

primarydef p withshade sc =
    p withprescript mfun_defined_cs_pre[sc]
enddef ;

def defineshade suffix s =
    mfun_defineshade(str s)
enddef ;

def mfun_defineshade (expr s) text t =
    expandafter def scantokens s = t enddef ;
enddef ;

def shaded text s =
    s
enddef ;


% For me.

primarydef p shownshadevector v =
    image (
        drawarrow (point xpart v of p) -- (point ypart v of p) ;
        fill fullcircle scaled 2 shifted point xpart v of p ;
        setbounds currentpicture to center currentpicture -- cycle ;
    )
enddef ;

primarydef p shownshadedirection v =
    image (
        drawarrow (point xpart v of boundingbox p) -- (point ypart v of boundingbox p) ;
        fill fullcircle scaled 2 shifted (point xpart v of boundingbox p) ;
        setbounds currentpicture to center currentpicture -- cycle ;
    )
enddef ;

primarydef p shownshadecenter v =
    image (
        fill fullcircle scaled 2
            shifted center p shifted (
            xpart v * bbwidth (p)/2,
            ypart v * bbheight(p)/2
        ) ;
        setbounds currentpicture to center currentpicture -- cycle ;
    )
enddef ;

primarydef p shownshadeorigin v =
    image (
        fill fullcircle scaled 2 shifted v ;
        setbounds currentpicture to center currentpicture -- cycle ;
    )
enddef ;

permanent withshademethod, withshaderadius, withshadeorigin, withshadevector, withshadedirection,
    withshadetransform, withshadedomain, withshadefactor, withshadecenter, withshadefraction, withshadestep,
    withshadecolors, shadedinto, withshade, shaded, shadedup, shadeddown, shadedleft, shadedright,
    shownshadevector, shownshadedirection, shownshadecenter, shownshadeorigin ;

% Old macros:

def withcircularshade (expr a, b, ra, rb, ca, cb) =
    withprescript "sh_type=circular"
    withprescript "sh_transform=yes"
    withprescript "sh_domain=0 1"
    withprescript "sh_factor=1"
    withprescript "sh_color_a="  & colordecimals ca
    withprescript "sh_color_b="  & colordecimals cb
    withprescript "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
    withprescript "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
    withprescript "sh_radius_a=" & decimal ra
    withprescript "sh_radius_b=" & decimal rb
enddef ;

def withlinearshade (expr a, b, ca, cb) =
    withprescript "sh_type=linear"
    withprescript "sh_transform=yes"
    withprescript "sh_domain=0 1"
    withprescript "sh_factor=1"
    withprescript "sh_color_a="  & colordecimals ca
    withprescript "sh_color_b="  & colordecimals cb
    withprescript "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
    withprescript "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
enddef ;

permanent withcircularshade, withlinearshade ;

% replaced (obsolete):

def set_linear_vector (suffix a,b)(expr p,n) =
    if     (n=1) : a := llcorner p ; b := urcorner p ;
    elseif (n=2) : a := lrcorner p ; b := ulcorner p ;
    elseif (n=3) : a := urcorner p ; b := llcorner p ;
    elseif (n=4) : a := ulcorner p ; b := lrcorner p ;
    elseif (n=5) : a := .5[ulcorner p,llcorner p] ; b := .5[urcorner p,lrcorner p] ;
    elseif (n=6) : a := .5[llcorner p,lrcorner p] ; b := .5[ulcorner p,urcorner p] ;
    elseif (n=7) : a := .5[lrcorner p,urcorner p] ; b := .5[llcorner p,ulcorner p] ;
    elseif (n=8) : a := .5[urcorner p,ulcorner p] ; b := .5[lrcorner p,llcorner p] ;
    else         : a := .5[ulcorner p,llcorner p] ; b := .5[urcorner p,lrcorner p] ;
    fi ;
enddef ;

def set_circular_vector (suffix ab,r)(expr p,n) =
    if     (n=1) : ab := llcorner p ;
    elseif (n=2) : ab := lrcorner p ;
    elseif (n=3) : ab := urcorner p ;
    elseif (n=4) : ab := ulcorner p ;
    else         : ab := center   p ; r := .5r ;
    fi ;
enddef ;

def circular_shade (expr p, n, ca, cb) =
    begingroup ;
        save ab, r ; pair ab ; numeric r ;
        r := (xpart lrcorner p - xpart llcorner p) ++ (ypart urcorner p - ypart lrcorner p) ;
        set_circular_vector(ab,r)(p,n) ;
        fill p withcircularshade(ab,ab,0,r,ca,cb) ;
        if trace_shades :
            drawarrow ab -- ab shifted (0,r) withpen pencircle scaled 1pt withcolor .5white ;
        fi ;
    endgroup ;
enddef ;

def linear_shade (expr p, n, ca, cb) =
    begingroup ;
        save a, b ; pair a, b ;
        set_linear_vector(a,b)(p,n) ;
        fill p withlinearshade(a,b,ca,cb) ;
        if trace_shades :
            drawarrow a -- b withpen pencircle scaled 1pt withcolor .5white ;
        fi ;
    endgroup ;
enddef ;

string mfun_defined_cs_pre[] ; numeric mfun_defined_cs ; mfun_defined_cs := 0 ;

vardef define_circular_shade (expr a, b, ra, rb, ca, cb) =
    mfun_defined_cs := mfun_defined_cs + 1 ;
    mfun_defined_cs_pre[mfun_defined_cs] := "sh_type=circular"
    & mfun_prescript_separator & "sh_domain=0 1"
    & mfun_prescript_separator & "sh_factor=1"
    & mfun_prescript_separator & "sh_color_a="  & colordecimals ca
    & mfun_prescript_separator & "sh_color_b="  & colordecimals cb
    & mfun_prescript_separator & "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
    & mfun_prescript_separator & "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
    & mfun_prescript_separator & "sh_radius_a=" & decimal ra
    & mfun_prescript_separator & "sh_radius_b=" & decimal rb
    ;
    mfun_defined_cs
enddef ;

vardef define_linear_shade (expr a, b, ca, cb) =
    mfun_defined_cs := mfun_defined_cs + 1 ;
    mfun_defined_cs_pre[mfun_defined_cs] := "sh_type=linear"
    & mfun_prescript_separator & "sh_domain=0 1"
    & mfun_prescript_separator & "sh_factor=1"
    & mfun_prescript_separator & "sh_color_a=" & colordecimals ca
    & mfun_prescript_separator & "sh_color_b=" & colordecimals cb
    & mfun_prescript_separator & "sh_center_a=" & ddecimal a % (a shifted shadeoffset)
    & mfun_prescript_separator & "sh_center_b=" & ddecimal b % (b shifted shadeoffset)
    ;
    mfun_defined_cs
enddef ;

% I lost the example code that uses this:
%
% vardef define_sampled_linear_shade(expr a,b,n)(text t) =
%     mfun_defined_cs := mfun_defined_cs + 1 ;
%     mfun_defined_cs_pre[mfun_defined_cs] := "ssh_type=linear"
%     & mfun_prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
%     & mfun_prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
%     & mfun_prescript_separator & "ssh_nofcolors=" & decimal n
%     & mfun_prescript_separator & "ssh_domain=" & domstr
%     & mfun_prescript_separator & "ssh_extend=" & extstr
%     & mfun_prescript_separator & "ssh_colors=" & colstr
%     & mfun_prescript_separator & "ssh_bounds=" & bndstr
%     & mfun_prescript_separator & "ssh_ranges=" & ranstr
%     ;
%     mfun_defined_cs
% enddef ;
%
% vardef define_sampled_circular_shade(expr a,b,ra,rb,n)(text t) =
%     mfun_defined_cs := mfun_defined_cs + 1 ;
%     mfun_defined_cs_pre[mfun_defined_cs] := "ssh_type=circular"
%     & mfun_prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
%     & mfun_prescript_separator & "ssh_radius_a=" & decimal ra
%     & mfun_prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
%     & mfun_prescript_separator & "ssh_radius_b=" & decimal rb
%     & mfun_prescript_separator & "ssh_nofcolors=" & decimal n
%     & mfun_prescript_separator & "ssh_domain=" & domstr
%     & mfun_prescript_separator & "ssh_extend=" & extstr
%     & mfun_prescript_separator & "ssh_colors=" & colstr
%     & mfun_prescript_separator & "ssh_bounds=" & bndstr
%     & mfun_prescript_separator & "ssh_ranges=" & ranstr
%     ;
%     mfun_defined_cs
% enddef ;

% vardef predefined_linear_shade (expr p, n, ca, cb) =
%     save a, b, sh ; pair a, b ;
%     set_linear_vector(a,b)(p,n) ;
%     define_linear_shade (a,b,ca,cb)
% enddef ;
%
% vardef predefined_circular_shade (expr p, n, ca, cb) =
%     save ab, r ; pair ab ; numeric r ;
%     r := (xpart lrcorner p - xpart llcorner p) ++ (ypart urcorner p - ypart lrcorner p) ;
%     set_circular_vector(ab,r)(p,n) ;
%     define_circular_shade(ab,ab,0,r,ca,cb)
% enddef ;

% Layers

def onlayer primary name =
    withprescript "la_name=" & name
enddef ;

permanent onlayer ;

% Figures

% def externalfigure primary filename =
%     doexternalfigure (filename)
% enddef ;
%
% def doexternalfigure (expr filename) text transformation =
%     if true : % a bit incompatible esp scaled 1cm now scaled the natural size
%         draw rawtextext("\externalfigure[" & filename & "]") transformation ;
%     else :
%         draw unitsquare transformation withprescript "fg_name=" & filename ;
%     fi ;
% enddef ;

def withmask primary filename =
    withprescript "fg_mask=" & filename
enddef ;

vardef externalfigure primary filename =
    mfun_tt_c := nullpicture ;
    mfun_tt_r := lua.mp.mf_external_figure(filename) ;
    addto mfun_tt_c doublepath unitsquare
        xscaled wdpart mfun_tt_r
        yscaled htpart mfun_tt_r
        withprescript "mf_object=figure"
        withprescript "fg_name=" & filename ;
    ;
    mfun_tt_c
enddef ;

def figure primary filename =
    rawtextext("\externalfigure[" & filename & "]")
enddef ;

vardef svgembeddedfigure primary index =
%     mfun_onetime_textext := true ;
    rawtextext("\svgembeddedfigure{" & decimal index & "}")
enddef ;

permanent withmask, externalfigure, figure ;

% Positions

def register (expr tag, width, height, offset) =
%     draw image (
        addto currentpicture doublepath unitsquare xscaled width yscaled height shifted offset
            withprescript "ps_label=" & tag ;
%     ) ; % no transformations
enddef ;

permanent register ;

% outlines (todo: pass around less arguments)

numeric currentoutlinetext ; currentoutlinetext := 0 ;

vardef mfun_do_outline_text_flush (expr kind, n, x, y, c) (text t) =
    if kind = "f" :
        mfun_do_outline_text_f (n, x, y, c) (t)
    elseif kind = "d" :
        mfun_do_outline_text_d (n, x, y, c) (t)
    elseif kind = "b" :
        mfun_do_outline_text_b (n, x, y, c) (t)
    elseif kind = "r" :
        mfun_do_outline_text_r (n, x, y, c) (t)
    elseif kind = "p" :
        mfun_do_outline_text_p (n, x, y, c) (t)
    elseif kind = "u" :
        mfun_do_outline_text_u (n, x, y, c) (t)
    else :
        mfun_do_outline_text_n (n, x, y, c) (t)
    fi ;
enddef ;

vardef mfun_do_outline_rule_flush (expr kind, x, y, w, h) =
  % mfun_do_outline_text_flush (kind, 1, x, y, "") (fullsquare xyscaled(w,h))
    mfun_do_outline_text_flush (kind, 1, x, y, "") (unitsquare xyscaled(w,h))
enddef ;

numeric mfun_do_outline_n ; mfun_do_outline_n := 0 ;

vardef mfun_do_outline_text_f (expr n, x, y, c) (text t) =
    mfun_do_outline_n := 0 ;
    for i=t :
        mfun_do_outline_n := mfun_do_outline_n + 1 ;
        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f withpen pencircle scaled 0 withprescript c ;
    endfor ;
enddef ;

vardef mfun_do_outline_text_u (expr n, x, y, c) (text t) =
    mfun_do_outline_n := 0 ;
    for i=t :
        mfun_do_outline_n := mfun_do_outline_n + 1 ;
        if mfun_do_outline_n = n : fillup else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f withprescript c ;
    endfor ;
enddef ;

vardef mfun_do_outline_text_d (expr n, x, y, c) (text t) =
    for i=t :
        draw i shifted(x,y) mfun_do_outline_options_d ;
    endfor ;
enddef ;

vardef mfun_do_outline_text_p (expr n, x, y, c) (text t) =
    for i=t :
        draw i shifted(x,y) withprescript c withpostscript decimal n;
    endfor ;
enddef ;

vardef mfun_do_outline_text_b (expr n, x, y, c) (text t) =
    mfun_do_outline_n := 0 ;
    for i=t :
        mfun_do_outline_n := mfun_do_outline_n + 1 ;
        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f ;
    endfor ;
    for i=t :
        draw i shifted(x,y) mfun_do_outline_options_d ;
    endfor ;
enddef ;

vardef mfun_do_outline_text_r (expr n, x, y, c) (text t) =
    mfun_do_outline_n := 0 ;
    for i=t :
        draw i shifted(x,y) mfun_do_outline_options_d ;
    endfor ;
    for i=t :
        mfun_do_outline_n := mfun_do_outline_n + 1 ;
        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) mfun_do_outline_options_f;
    endfor ;
enddef ;

vardef mfun_do_outline_text_n (expr n, x, y, c) (text t) =
    mfun_do_outline_n := 0 ;
    for i=t :
        mfun_do_outline_n := mfun_do_outline_n + 1 ;
        if mfun_do_outline_n = n : fill else : nofill fi (i shifted(x,y)) ;
    endfor ;
enddef ;

vardef mfun_do_outline_text_set_f (text f) text r =
    def mfun_do_outline_options_f = f enddef ;
    def mfun_do_outline_options_r = r enddef ;
enddef ;

vardef mfun_do_outline_text_set_u (text f) text r =
    def mfun_do_outline_options_f = f enddef ;
enddef ;

vardef mfun_do_outline_text_set_d (text d) text r =
    def mfun_do_outline_options_d = d enddef ;
    def mfun_do_outline_options_r = r enddef ;
enddef ;

vardef mfun_do_outline_text_set_b (text f) (text d) text r =
    def mfun_do_outline_options_f = f enddef ;
    def mfun_do_outline_options_d = d enddef ;
    def mfun_do_outline_options_r = r enddef ;
enddef ;

vardef mfun_do_outline_text_set_r (text d) (text f) text r =
    def mfun_do_outline_options_d = d enddef ;
    def mfun_do_outline_options_f = f enddef ;
    def mfun_do_outline_options_r = r enddef ;
enddef ;

vardef mfun_do_outline_text_set_n text r =
    def mfun_do_outline_options_r = r enddef ;
enddef ;

vardef mfun_do_outline_text_set_p =
enddef ;

def mfun_do_outline_options_d = enddef ;
def mfun_do_outline_options_f = enddef ;
def mfun_do_outline_options_r = enddef ;

def outlinetexttopath (text o, p, n) =
    scantokens("numeric " & str n &   ";") ;
    scantokens("path "    & str p & "[];") ;
    n := 0 ;
    for i within o : p[incr(n)] := pathpart i ; endfor ;
enddef ;

def filloutlinetext (expr o) =
    draw image (
        save n, m ; numeric n, m ; n := m := 0 ;
        for i within o :
            n := n + 1 ;
        endfor ;
        for i within o :
            m := m + 1 ;
            if n = m :
                eofill
            else :
                nofill
            fi pathpart i ;
        endfor ;
    )
enddef ;

def drawoutlinetext (expr o) =
    draw image (
        % nicer for properties
        for i within o :
            draw pathpart i ;
        endfor ;
    )
enddef ;

vardef outlinetext@# (expr t) text rest =
    save kind ; string kind ; kind := str @# ;
    currentoutlinetext := currentoutlinetext + 1 ;
    def mfun_do_outline_options_d = enddef ;
    def mfun_do_outline_options_f = enddef ;
    def mfun_do_outline_options_r = enddef ;
    image ( normaldraw image (
      % lua.mp.report("set outline text",currentoutlinetext);
        lua.mp.mf_outline_text(currentoutlinetext,t,kind) ;
      % lua.mp.report("get outline text",currentoutlinetext);
        if kind = "f" :
            mfun_do_outline_text_set_f rest ;
        elseif kind = "d" :
            mfun_do_outline_text_set_d rest ;
        elseif kind = "b" :
            mfun_do_outline_text_set_b rest ;
        elseif kind = "u" :
            mfun_do_outline_text_set_f rest ;
        elseif kind = "r" :
            mfun_do_outline_text_set_r rest ;
        elseif kind = "p" :
            mfun_do_outline_text_set_p ;
        else :
            mfun_do_outline_text_set_n rest ;
        fi ;
        lua.mp.mf_get_outline_text(currentoutlinetext) ;
    ) mfun_do_outline_options_r ; )
enddef ;


permanent outlinetexttopath, filloutlinetext, drawoutlinetext, outlinetext ;

% A few helpers:

numeric mfun_c_b_llx, mfun_c_b_h, mfun_c_b_w, mfun_c_b_l ;

vardef checkedbounds(expr llx,lly,urx,ury) =
    mfun_c_b_llx := min(xpart llcorner currentpicture,llx) ;
    mfun_c_b_urx := max(xpart urcorner currentpicture,urx) ;
    mfun_c_b_lly := min(ypart llcorner currentpicture,lly) ;
    mfun_c_b_ury := max(ypart urcorner currentpicture,ury) ;
    (mfun_c_b_llx,mfun_c_b_lly) --
    (mfun_c_b_urx,mfun_c_b_lly) --
    (mfun_c_b_urx,mfun_c_b_ury) --
    (mfun_c_b_llx,mfun_c_b_ury) -- cycle
enddef ;

vardef checkbounds(expr llx,lly,urx,ury) =
    setbounds currentpicture to checkedbounds(llx,lly,urx,ury) ;
enddef ;

vardef strut(expr ht,dp) =
    setbounds currentpicture to checkedbounds(0,0,ht,dp) ;
enddef ;

vardef rule(expr wd,ht,dp) =
    image (fill (0,-dp)--(wd,-dp)--(wd,ht)--(0,ht)--cycle)
enddef ;

permanent checkedbounds, checkbounds, strut, rule ;

% Housekeeping

extra_beginfig := extra_beginfig & "currentgraphictext := 0 ; " ;
extra_beginfig := extra_beginfig & "currentoutlinetext := 0 ; " ;
extra_endfig   := extra_endfig   & "finishsavingdata ; " ;
extra_endfig   := extra_endfig   & "mfun_reset_tex_texts ; " ;

% Bonus

vardef verbatim(expr s) =
    ditto & "\detokenize{" & s & "}" & ditto
enddef ;

permanent verbatim ;

% New

% def bitmapimage(expr xresolution, yresolution, data) =
%     image (
%         addto currentpicture doublepath unitsquare
%             withprescript  "bm_xresolution=" & decimal xresolution
%             withprescript  "bm_yresolution=" & decimal yresolution
%             withpostscript data ;
%     )
% enddef ;

vardef bitmapimage(expr xresolution, yresolution, data) =
    save p ; picture p ; p := nullpicture ;
    addto p doublepath unitsquare
%         xscaled xresolution
%         yscaled yresolution
        withprescript  "bm_xresolution=" & decimal xresolution
        withprescript  "bm_yresolution=" & decimal yresolution
        withpostscript data
    ;
    p
enddef ;

permanent bitmapimage ;

% Experimental:
%
% property p ; p = properties(withcolor (1,1,0,0)) ;
% fill fullcircle scaled 20cm withproperties p ;

let property = picture ; permanent property ;

vardef properties(text t) =
    image(draw unitcircle t)
enddef ;

def withproperties expr p =
    if colormodel p = graycolormodel :
        withcolor greypart p
    elseif colormodel p = rgbcolormodel :
        withcolor (redpart p,greenpart p,bluepart p)
    elseif colormodel p = cmykcolormodel :
        withcolor (cyanpart p,magentapart p,yellowpart p,blackpart p)
    fi
    withpen penpart p
    if length (dashpart p) > 0 :
        dashed dashpart p
    fi
    if stackingpart p <> 0 :
        withstacking stackingpart p
    fi
    withprescript prescriptpart p
    withpostscript postscriptpart p
enddef ;

permanent properties, withproperties ;

% The experimental nasty shifting to remain in the positive quadrant was not
% okay. Test a change also on groups-001.tex in the test suite!

primarydef t asgroup s = % s = isolated|knockout
    begingroup
    save temp_p, temp_q, temp_r ;
    picture temp_p, temp_q ; path temp_r ;
    temp_p := if picture t : t else : image(draw t) fi ;
    temp_r := boundingbox temp_p ;
    temp_q := nullpicture ;
    addto temp_q contour temp_r
        withprescript "gr_state=start"
        withprescript "gr_type=" & s
    ;
    addto temp_q also temp_p ;
    addto temp_q contour temp_r
        withprescript "gr_state=stop"
    ;
    temp_q
    endgroup
enddef ;

permanent asgroup ;

% Even more experimental:

pair    mfun_pattern_s ; mfun_pattern_s := origin ; % auto scale to fraction of shape (svg)
boolean mfun_pattern_f ; mfun_pattern_f := false  ; % anchor or not (normally we do that)

def withpatternscale primary s = hide (mfun_pattern_s := paired s ;) enddef ;
def withpatternfloat primary s = hide (mfun_pattern_f := s ;) enddef ;

primarydef t withpattern p =
    begingroup
    %
    save temp_q, temp_r ;
    picture temp_q ; path temp_r ;
    % the combination
    temp_q:= nullpicture ;
    % the pattern
    temp_r := boundingbox p ;
    if mfun_pattern_s <> origin :
        sx := (xpart mfun_pattern_s) * bbwidth (t) ;
        sy := (ypart mfun_pattern_s) * bbheight(t) ;
        temp_r := temp_r xysized (sx,sy) ;
        addto temp_q contour temp_r
            withprescript "pt_state=start"
            withprescript "pt_action=set"
            withprescript "pt_float=" & tostring(mfun_pattern_f)
        ;
        addto temp_q also (p xysized (sx,sy));
    else :
        addto temp_q contour temp_r
            withprescript "pt_state=start"
            withprescript "pt_action=set"
            withprescript "pt_float=" & tostring(mfun_pattern_f)
        ;
        addto temp_q also p ;
    fi ;
    addto temp_q contour temp_r
        withprescript "pt_state=stop"
        withprescript "pt_action=set" ;
    % the path
    temp_r := boundingbox t ;
    addto temp_q contour temp_r
        withprescript "pt_state=start"
        withprescript "pt_action=get"
    ;
    addto temp_q contour temp_r
        withprescript "pt_state=stop"
        withprescript "pt_action=get" ;
    % make sure we fill only t
    clip temp_q to t ;
    % reset
    mfun_pattern_s := origin ;
    mfun_pattern_f := false ;
    % the path
    temp_q
    endgroup
enddef ;

% Also experimental ... needs to be made better ... so it can change!

string mfun_auto_align[] ;

mfun_auto_align[0] := "rt" ;
mfun_auto_align[1] := "urt" ;
mfun_auto_align[2] := "top" ;
mfun_auto_align[3] := "ulft" ;
mfun_auto_align[4] := "lft" ;
mfun_auto_align[5] := "llft" ;
mfun_auto_align[6] := "bot" ;
mfun_auto_align[7] := "lrt" ;
mfun_auto_align[8] := "rt" ;

def autoalign(expr n) =
    scantokens mfun_auto_align[round((n mod 360)/45)]
enddef ;

% draw textext.autoalign(60) ("\strut oeps 1") ;
% draw textext.autoalign(160)("\strut oeps 2") ;
% draw textext.autoalign(260)("\strut oeps 3") ;
% draw textext.autoalign(360)("\strut oeps 4") ;

% new
%
% passvariable("version","1.0") ;
% passvariable("number",123) ;
% passvariable("string","whatever") ;
% passvariable("point",(1,2)) ;
% passvariable("triplet",(1,2,3)) ;
% passvariable("quad",(1,2,3,4)) ;
% passvariable("boolean",false) ;
% passvariable("path",fullcircle scaled 1cm) ;

% we could use the new lua interface but there is not that much gain i.e.
% we still need to serialize

vardef mfun_point_to_string(expr p,i) =
    decimal xpart (point       i of p) & " " &
    decimal ypart (point       i of p) & " " &
    decimal xpart (precontrol  i of p) & " " &
    decimal ypart (precontrol  i of p) & " " &
    decimal xpart (postcontrol i of p) & " " &
    decimal ypart (postcontrol i of p)
enddef ;

vardef mfun_transform_to_string(expr t) =
    decimal xxpart t & " " &   % rx
    decimal xypart t & " " &   % sx
    decimal yxpart t & " " &   % sy
    decimal yypart t & " " &   % ry
    decimal xpart  t & " " &   % tx
    decimal ypart  t           % ty
enddef ;

vardef mfun_numeric_to_string(expr n) =
    decimal n
enddef ;

vardef mfun_pair_to_string(expr p) =
    decimal xpart p & " " &
    decimal ypart p
enddef ;

vardef mfun_rgbcolor_to_string(expr c) =
    decimal redpart   c & " " &
    decimal greenpart c & " " &
    decimal bluepart  c
enddef ;

vardef mfun_cmykcolor_to_string(expr c) =
    decimal cyanpart    c & " " &
    decimal magentapart c & " " &
    decimal yellowpart  c & " " &
    decimal blackpart   c
enddef ;

vardef mfun_pair_to_table(expr p) =
    "{" & decimal xpart p &
    "," & decimal ypart p &
    "}"
enddef ;

vardef mfun_point_to_table(expr p,i) =
    "{" & decimal xpart (point       i of p) &
    "," & decimal ypart (point       i of p) &
    "," & decimal xpart (precontrol  i of p) &
    "," & decimal ypart (precontrol  i of p) &
    "," & decimal xpart (postcontrol i of p) &
    "," & decimal ypart (postcontrol i of p) &
    "}"
enddef ;

vardef mfun_path_to_table(expr p) =
    "{" & mfun_point_to_table(p,0) for i=1 upto length(p) : & "," & mfun_point_to_table(p,i) endfor & "}"
enddef ;

vardef mfun_rgb_to_table(expr c) =
    "{" & decimal redpart   c &
    "," & decimal greenpart c &
    "," & decimal bluepart  c &
    "}"
enddef ;

vardef mfun_cmyk_to_table(expr c) =
    "{" & decimal cyanpart    c &
    "," & decimal magentapart c &
    "," & decimal yellowpart  c &
    "," & decimal blackpart   c &
    "}"
enddef ;

vardef mfun_grey_to_string(expr n) =
    decimal n
enddef ;

vardef mfun_path_to_string(expr p) =
    mfun_point_to_string(p,0) for i=1 upto length(p) : & " " & mfun_point_to_string(p,i) endfor
enddef ;

vardef mfun_boolean_to_string(expr b) =
    if b : "true" else : "false" fi
enddef ;

vardef tostring primary v =
    if     numeric   v : mfun_numeric_to_string(v)
    elseif pair      v : mfun_pair_to_string(v)
    elseif rgbcolor  v : mfun_rgbcolor_to_string(v)
    elseif cmykcolor v : mfun_cmykcolor_to_string(v)
    elseif greycolor v : mfun_greycolor_to_string(v)
    elseif boolean   v : mfun_boolean_to_string(v)
    elseif path      v : mfun_path_to_string(v)
    elseif transform v : mfun_transform_to_string(v)
    else               : v
    fi
enddef ;

vardef topair primary p =
    if     pair    p : "(" & decimal xpart p & "," & decimal ypart p & ")"
    elseif numeric p : "(" & decimal       p & "," & decimal       p & ")"
    else             : "" fi
enddef ;

string dq ; dq := char 92 & char 34 ;
string sq ; sq := char 92 & char 39 ;

permanent dq, sq ;

vardef quote     primary s = sq & tostring(s) & sq enddef;
vardef quotation primary s = dq & tostring(s) & dq enddef;

vardef mfun_tagged_string(expr value) =
    if     numeric   value : "1:" & mfun_numeric_to_string(value)
    elseif pair      value : "4:" & mfun_pair_to_string(value)
    elseif rgbcolor  value : "5:" & mfun_rgbcolor_to_string(value)
    elseif cmykcolor value : "6:" & mfun_cmykcolor_to_string(value)
    elseif boolean   value : "3:" & mfun_boolean_to_string(value)
    elseif path      value : "7:" & mfun_path_to_string(value)
    elseif transform value : "8:" & mfun_transform_to_string(value)
    else                   : "2:" & value
    fi
enddef ;

permanent tostring, topair, quote, quotation ;

% A more flexible variant for passing data to context. We used to construct strings
% but running lua is fast enough so we can gain on string construction in metapost
% which is also not that efficient.

newscriptindex mfid_passvariable ; mfid_passvariable := scriptindex("passvariable") ;
newscriptindex mfid_pushvariable ; mfid_pushvariable := scriptindex("pushvariable") ;
newscriptindex mfid_popvariable  ; mfid_popvariable  := scriptindex("popvariable") ;

def passvariable        (expr key, value) = runscript mfid_passvariable key value ; enddef ;
def startpassingvariable(expr key)        = runscript mfid_pushvariable key ; enddef ;
def stoppassingvariable                   = runscript mfid_popvariable ; enddef ;

def passarrayvariable(expr key)(suffix values)(expr first, last, stp) =
    startpassingvariable(key) ;
    for i=first step stp until last :
        passvariable(i, values[i]) ;
    endfor
    stoppassingvariable ;
enddef ;

permanent passvariable, passarrayvariable, startpassingvariable, stoppassingvariable ;

% moved here from mp-grap.mpiv

% vardef escaped_format(expr s) =
%     "" for n=0 upto length(s) : &
%         if ASCII substring (n,n+1) of s = 37 :
%             "@"
%         else :
%             substring (n,n+1) of s
%         fi
%     endfor
% enddef ;

numeric mfun_esc_b ; % begin
numeric mfun_esc_l ; % length
string  mfun_esc_s ; % character

mfun_esc_s := "%" ; % or: char(37)

% this one is the fastest when we have a match

% vardef escaped_format(expr s) =
%     "" for n=0 upto length(s)-1 : &
%       % if ASCII substring (n,n+1) of s = 37 :
%         if substring (n,n+1) of s = mfun_esc_s :
%             "@"
%         else :
%             substring (n,n+1) of s
%         fi
%     endfor
% enddef ;

% this one wins when we have no match

vardef escaped_format(expr s) =
    mfun_esc_b := 0 ;
    mfun_esc_l := length(s) ;
    for n=0 upto mfun_esc_l-1 :
      % if ASCII substring (n,n+1) of s = 37 :
        if substring (n,n+1) of s = mfun_esc_s :
            if mfun_esc_b = 0 :
                ""
            fi
            if n >= mfun_esc_b :
                & (substring (mfun_esc_b,n) of s)
                exitif numeric begingroup mfun_esc_b := n+1 endgroup ; % hide
            fi
            & "@"
        fi
    endfor
    if mfun_esc_b = 0 :
        s
  % elseif mfun_esc_b > 0 :
    elseif mfun_esc_b < mfun_esc_l :
        & (substring (mfun_esc_b,mfun_esc_l) of s)
    fi
enddef ;

vardef strfmt(expr f, x) = "\MPgraphformat{" & escaped_format(f) & "}{" & mfun_tagged_string(x) & "}" enddef ;
vardef varfmt(expr f, x) = "\MPformatted{"   & escaped_format(f) & "}{" & mfun_tagged_string(x) & "}" enddef ;

vardef format@#   (expr f, x) = textext@#(strfmt(f, x)) enddef ;
vardef formatted@#(expr f, x) = textext@#(varfmt(f, x)) enddef ;

permanent format, formatted ;

% could be this (something to discuss with alan as it involves graph):
%
% vardef format   (expr f,x) = lua.mp.graphformat(f,mfun_tagged_string(x) enddef ;
% vardef formatted(expr f,x) = lua.mp.format     (f,                   x) enddef ;
%
% def strfmt = format    enddef ; % old
% def varfmt = formatted enddef ; % old

% def fmttext = lua.mp.formatted enddef ;

% new

def fillup   text t = draw t withpostscript "both"     enddef ; % we use draw because we need the proper boundingbox
def eofillup text t = draw t withpostscript "eoboth"   enddef ; % we use draw because we need the proper boundingbox
def eofill   text t = fill t withpostscript "evenodd"  enddef ;
def nofill   text t = fill t withpostscript "collect"  enddef ;
def nodraw   text t = draw t withpostscript "collect"  enddef ;
def dodraw   text t = draw t withpostscript "flush"    enddef ;
%   eodraw   text t = draw t withpostscript "evenodd"  enddef ;
def dofill   text t = fill t withpostscript "flush"    enddef ;
def eoclip   text t = clip t withpostscript "evenodd"  enddef ;
def enfill   text t = fill t withpostscript "envelope" enddef ;

permanent fillup, eofillup, eofill, nofill, nodraw, dodraw, dofill, eoclip ;

% maybe (saves a bogus path but the problem is that it can influence the dimensions):

% def dodraw text t = draw center currentpicture         withpostscript "flush" enddef ;
% def dofill text t = fill center currentpicture --cycle withpostscript "flush" enddef ;

% def withrule expr r =
%     if (t = "even-odd") or (t = "evenodd") : withpostscript "evenodd" fi
% enddef ;

% A comment will end up on top of the graphic in the output. This can be handy for
% locating a graphic: comment("test graphic").

% This can be a prescript to currentpicture ... we can actually make
%
% setprescript  str to picture/path ;
% setpostscript str to picture/path ;

def special text t = enddef ;

def comment expr str =
    special "metapost.comment[[" & str & "]]" ;
enddef ;

vardef report(text t) =
    lua.mp.report(t)
enddef ;

permanent comment, report ;

% This nechanism is not really promoted and more an experiment. It scales better than
% \METAPOST\ own hash.

% todo: use mfid_* cum suis

newscriptindex mfid_hash_new     ; mfid_hash_new     := scriptindex("lmt_hash_new") ;     % mkiv compatible
newscriptindex mfid_hash_dispose ; mfid_hash_dispose := scriptindex("lmt_hash_dispose") ; % mkiv compatible

newscriptindex mfid_hash_reset   ; mfid_hash_dispose := scriptindex("lmt_hash_reset") ;
newscriptindex mfid_hash_in      ; mfid_hash_in      := scriptindex("lmt_hash_in") ;
newscriptindex mfid_hash_from    ; mfid_hash_from    := scriptindex("lmt_hash_from") ;
newscriptindex mfid_hash_to      ; mfid_hash_to      := scriptindex("lmt_hash_to") ;

def newhash                          = runscript mfid_hash_new                 enddef ; % optional, returns index
def disposehash (expr n)             = runscript mfid_hash_dispose n           enddef ;

def resethash   (expr n)             = runscript mfid_hash_reset   n           enddef ;
def inhash      (expr n, key)        = runscript mfid_hash_in      n key       enddef ;
def fromhash    (expr n, key)        = runscript mfid_hash_from    n key       enddef ;
def tohash      (expr n, key, value) = runscript mfid_hash_to      n key value enddef ;

string mfun_u_l_h ; mfun_u_l_h := "mfun_u_l_h" ;

vardef uniquelist(suffix list) =
    % this can be optimized by passing all values at once and returning
    % a result but for now this is ok .. we need an undef foo
    save i, j ;
    if known lis[0] :
        i := 0 ;
        j := -1 ;
    else :
        i := 1 ;
        j := 0 ;
    fi ;
  % mfun_u_l_h := runscript mfid_hash_new ; % here mfun_u_l_h has to be a numeric
    forever :
        exitif unknown list[i] ;
        if not (runscript mfid_hash_in (mfun_u_l_h) list[i]) :
            j := j + 1 ;
            list[j] := list[i] ;
            runscript mfid_hash_to (mfun_u_l_h) (j) list[i] ;
        fi ;
        i := i + 1 ;
    endfor ;
    for n = j + 1 step 1 until i - 1 :
        dispose(list[n])
    endfor ;
    runscript mfid_hash_dispose mfun_u_l_h ;
enddef ;

permanent uniquelist ;

% This influences the decision for a curve or path segment; 1/4096 is the default but
% 10/2048 works quite well.

def withtolerance expr n =
    withprescript ("tolerance=" & decimal n)
enddef ;

% fun stuff: randomseed := repeatablerandom("default") ;

newscriptindex mfid_repeatablerandom ; mfid_repeatablerandom := scriptindex("repeatablerandom") ;

def repeatablerandom = runscript mfid_repeatablerandom enddef ;

% somewhat esoteric

picture mfun_luminosity_picture ;

def registerluminositygroup (expr name) (text t) =
    begingroup ;
    save  mfun_luminosity_picture ;
    picture  mfun_luminosity_picture ;
    mfun_luminosity_picture := image ( t ) ;
    setgroup mfun_luminosity_picture to boundingbox mfun_luminosity_picture ;
    draw mfun_luminosity_picture
        withprescript "gs_type=luminosity"
        withprescript "gs_action=register"
        withprescript "gs_name=" & name
    ;
    endgroup ;
enddef ;

def applyluminositygroup (expr name) (text t) =
    begingroup ;
    save  mfun_luminosity_picture ;
    picture  mfun_luminosity_picture ;
    mfun_luminosity_picture := image ( t ) ;
    setgroup  mfun_luminosity_picture to boundingbox mfun_luminosity_picture ;
    draw mfun_luminosity_picture
        withprescript "gs_type=luminosity"
        withprescript "gs_action=apply"
        withprescript "gs_name=" & name
    ;
    endgroup ;
enddef ;

def luminositygroup (text a) (text b) =
    image (
        registerluminositygroup ("default") (a) ;
        applyluminositygroup    ("default") (b) ;
    )
enddef ;

def luminosityshade (expr p) (text a) (text b) =
    image (
        registerluminositygroup ("default") (fill p a) ;
        applyluminositygroup    ("default") (fill p b) ;
    )
enddef ;

permanent registerluminositygroup, applyluminositygroup, luminositygroup, luminosityshade ;

% message(subpath(2,3) of fullcircle scaled 10cm hascurvature 0.02);
% message(subpath(2,3) of fullsquare scaled 10cm hascurvature 0.02);

newscriptindex mfid_hascurvature ; mfid_hascurvature := scriptindex("hascurvature") ;

primarydef p hascurvature c = runscript mfid_hascurvature (p) (c) enddef ;

permanent hascurvature ;

newscriptindex mfid_setbackendoption ; mfid_setbackendoption := scriptindex("setbackendoption") ;

def setbackendoption = runscript mfid_setbackendoption enddef ;

permanent setbackendoption ;

newscriptindex mfid_namedstacking ; mfid_namedstacking := scriptindex("namedstacking") ;

def namedstacking expr str = runscript mfid_namedstacking str enddef ;

def withnamedstacking expr s  =
    withstacking if numeric s :
        s
    elseif string s :
        namedstacking s
    else :
        0
    fi
enddef ;

permanent namedstacking, withnamedstacking ;

% \enabledirectives[metapost.annotations=actual]      % default
% \enabledirectives[metapost.annotations=alternative]
%
% fill fullcircle scaled 4cm withannotation "Oh, a circle." ;

def withannotation expr txt =
    withprescript ("an_text=" & txt)
enddef ;

permanent withannotation ;

% experimental

% every_after_shipout := every_after_shipout & " resetbytemaps ; " ;
%     % withmaskmap maybe too but then the number is a bytemap so we need to pass it too

def withbytemask expr n =
    withprescript "bytemask=" & decimal n
enddef ;

def withbyteexpansion expr n =
    withprescript "byteexpansion=" & decimal n
enddef ;

permanent withbytemask, withbyteexpansion ;

vardef loadbytemapfromfile(expr index, filename) =
    lua.mp.bytemap_load_from_file(index, filename)
enddef ;

vardef loadbytemap(expr index, filename) =
    lua.mp.loadbytemap(index, filename)
enddef ;

permanent loadbytemapfromfile, loadbytemap ;

% kind of fundamental, therefore here

newscriptindex mfid_meshcontour ; mfid_meshcontour := scriptindex("meshcontour")  ;

def meshcontour(expr name, kind) = runscript mfid_meshcontour name kind ; enddef ; % just combine with the next one

vardef meshexperiment(expr name, kind) =
    image (
        save p ; path p ; p := meshcontour(name,kind) ;
        addto currentpicture doublepath p
            withprescript "ms_name=" & name
            withprescript "ms_kind=" & kind
        ;
    )
enddef ;

permanent mesh;

% This was the original longer version, watch the withcurvature trickery but in the
% end we decided not to go this route as we never really mess with these paths in
% mp apart from placement and decorating.
%
% meshstart("mikaelfun") ;
%     numeric n ; path p ; numeric c, cc ;
%     pickup pencircle scaled .05 ;
%     n := meshcount ;
%     for i=1 upto n :
%         c := meshvalue ;
%         p := meshpath scaled 30 ;
%         fill p
%             withcolor (c,.3,.3)
%             withcurvature  2 % simple list and also stores
%         ;
%         draw p
%             withcurvature  3 % repeats last one
%         ;
%     endfor ;
%     draw meshbounds scaled 30 withpen pencircle scaled 1 ;
%   % meshreset ;
% meshstop ;
