%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.

if unknown mplib        : endinput ; fi ;
if known   context_mlib : endinput ; fi ;

boolean context_mlib ; context_mlib := true ;

%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 ;

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
    withprescript "sp_type=named"
    withprescript "sp_name=" & n
enddef ;

def spotcolor(expr n, v) =
    1
    withprescript "sp_type=spot"
    withprescript "sp_name="  & n
    withprescript "sp_value=" & v
enddef ;

def multitonecolor(expr name, fractions, components, value) =
    1
    withprescript "sp_type=multitone"
    withprescript "sp_name="       & name
    withprescript "sp_fractions="  & decimal fractions
    withprescript "sp_components=" & components
    withprescript "sp_value="      & value
enddef ;

% def transparent(expr alternative, transparency)(text c) =
%     1 % this permits withcolor x intoshade y
%     withprescript "tr_alternative="  & decimal transparency_alternative_to_number(alternative)
%     withprescript "tr_transparency=" & decimal transparency
%     withcolor c
% enddef ;

let transparency = pair ;

def transparent(expr t)(text c) =
    1 % this permits withcolor x intoshade y
    withprescript "tr_alternative="  & decimal transparency_alternative_to_number(xpart t)
    withprescript "tr_transparency=" & decimal ypart t
    withcolor c
enddef ;

% def withtransparency(expr alternative, transparency) =
%     withprescript "tr_alternative="  & decimal transparency_alternative_to_number(alternative)
%     withprescript "tr_transparency=" & decimal transparency
% enddef ;

def withtransparency expr t =
    withprescript "tr_alternative="  & decimal transparency_alternative_to_number(xpart t)
    withprescript "tr_transparency=" & decimal ypart t
enddef ;

def cmyk(expr c, m, y, k) = % provided for downward compability
    (c,m,y,k)
enddef ;

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

newinternal textextoffset ; textextoffset := 0 ;

numeric mfun_tt_w[], mfun_tt_h[], mfun_tt_d[] ; % we can consider using colors (less hash space)
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 ;

if unknown mfun_first_run :
    boolean mfun_first_run ;
    mfun_first_run := true ;
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.

% vardef rawtextext(expr str) =
%     if str = "" :
%         nullpicture
%     elseif mfun_trial_run :
%         mfun_tt_n := mfun_tt_n + 1 ;
%         mfun_tt_o := image(draw origin) ; % save drawoptions
%         addto mfun_tt_p doublepath unitsquare
%             withprescript "tx_number=" & decimal mfun_tt_n
%             withprescript "tx_stage=extra"
%             withpostscript str ;
%         image (
%             addto currentpicture doublepath unitsquare
%                 withprescript "tx_number=" & decimal mfun_tt_n
%                 withprescript "tx_stage=trial"
%                 withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
%                 withpostscript str
%         ; )
%     else :
%         mfun_tt_n := mfun_tt_n + 1 ;
%         if known mfun_tt_d[mfun_tt_n] :
%             image (
%                 addto currentpicture doublepath unitsquare
%                     xscaled mfun_tt_w[mfun_tt_n]
%                     yscaled (mfun_tt_h[mfun_tt_n] + mfun_tt_d[mfun_tt_n])
%                     withprescript "tx_number=" & decimal mfun_tt_n
%                     withprescript "tx_stage=final"
%                   % withpostscript str ; % for tracing
%             ; ) shifted (0,-mfun_tt_d[mfun_tt_n])
%         else :
%             image (
%                 addto currentpicture doublepath unitsquare
%             ; )
%         fi
%     fi
% enddef ;

% vardef rawtextext(expr str) = % todo: avoid currentpicture
%     if str = "" :
%         nullpicture
%     else :
%         mfun_tt_n := mfun_tt_n + 1 ;
%         mfun_tt_c := nullpicture ;
%         if mfun_trial_run :
%             mfun_tt_o := nullpicture ;
%             addto mfun_tt_o doublepath origin _op_ ; % save drawoptions
%             addto mfun_tt_p doublepath unitsquare
%                 withprescript "tx_number=" & decimal mfun_tt_n
%                 withprescript "tx_stage=extra"
%                 withpostscript str ;
%             addto mfun_tt_c doublepath unitsquare
%                 withprescript "tx_number=" & decimal mfun_tt_n
%                 withprescript "tx_stage=trial"
%                 withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
%                 withpostscript str ;
%         elseif known mfun_tt_d[mfun_tt_n] :
%             addto mfun_tt_c doublepath unitsquare
%                 xscaled mfun_tt_w[mfun_tt_n]
%                 yscaled (mfun_tt_h[mfun_tt_n] + mfun_tt_d[mfun_tt_n])
%                 shifted (0,-mfun_tt_d[mfun_tt_n])
%                 withprescript "tx_number=" & decimal mfun_tt_n
%                 withprescript "tx_stage=final" ;
%         else :
%             addto mfun_tt_c doublepath unitsquare ; % unitpicture
%         fi ;
%         mfun_tt_c
%     fi
% enddef ;

vardef rawtextext(expr str) = % todo: avoid currentpicture
    if str = "" :
        nullpicture
    else :
        mfun_tt_n := mfun_tt_n + 1 ;
        mfun_tt_c := nullpicture ;
        if mfun_trial_run :
            mfun_tt_o := nullpicture ;
            addto mfun_tt_o doublepath origin _op_ ; % save drawoptions
            addto mfun_tt_c doublepath unitsquare
                withprescript "tx_number=" & decimal mfun_tt_n
                withprescript "tx_stage=trial"
                withprescript "tx_color=" & colordecimals colorpart mfun_tt_o
                withpostscript str ;
            addto mfun_tt_p also mfun_tt_c ;
        elseif known mfun_tt_d[mfun_tt_n] :
            addto mfun_tt_c doublepath unitsquare
                xscaled mfun_tt_w[mfun_tt_n]
                yscaled (mfun_tt_h[mfun_tt_n] + mfun_tt_d[mfun_tt_n])
                shifted (0,-mfun_tt_d[mfun_tt_n])
                withprescript "tx_number=" & decimal mfun_tt_n
                withprescript "tx_stage=final" ;
        else :
            addto mfun_tt_c doublepath unitsquare ; % unitpicture
        fi ;
        mfun_tt_c
    fi
enddef ;

% More text

defaultfont := "Mono" ; % was cmr10, could be lmmono10-regular, but is fed into context anyway

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

pair mfun_laboff        ; mfun_laboff        := (0,0)            ;
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 := origin           ;
pair mfun_laboff.raw    ; mfun_laboff.raw    := origin           ;

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 ;

% installlabel.foo ( 0, 1, 1, (.5,-1) ) ;

vardef installlabel@# (expr type, x, y, offset) =
    numeric labtype@# ; labtype@# := type ;
    pair    laboff @# ; laboff @# := offset ;
    numeric labxf  @# ; labxf  @# := x ;
    numeric labyf  @# ; labyf  @# := y ;
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@# - (labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p))
    fi
enddef;

def plain_label = % takes two arguments, contrary to textext that takes one
    draw 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 ;" ;

% next comes own own:

vardef thetextext@#(expr p,z) =
  % interim labeloffset := textextoffset ;
    if string p :
        thetextext@#(rawtextext(p),z)
    elseif numeric p :
        thetextext@#(rawtextext(decimal p),z)
    else :
        p
            if (mfun_labtype@# >= 10) :
                shifted (0,ypart center p)
            fi
            shifted (z + textextoffset*mfun_laboff@# - (mfun_labxf@#*lrcorner p + mfun_labyf@#*ulcorner p + (1-mfun_labxf@#-mfun_labyf@#)*llcorner p))
    fi
enddef ;

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

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;

def label = % takes two arguments, contrary to textext that takes one
    draw 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_labxf@#*lrcorner p + mfun_labyf@#*ulcorner p + (1-mfun_labxf@#-mfun_labyf@#)*llcorner p))
enddef ;

let normalinfont = infont ;

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

% Shades

newinternal shadefactor  ; shadefactor  := 1 ;
pair        shadeoffset  ; shadeoffset  := origin ;
boolean     trace_shades ; trace_shades := false ;

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, sh ; 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 ;

def withcircularshade (expr a, b, ra, rb, ca, cb) =
    withprescript "sh_type=circular"
    withprescript "sh_domain=0 1"
    withprescript "sh_factor="   & decimal shadefactor
    withprescript "sh_color_a="  & colordecimals ca
    withprescript "sh_color_b="  & colordecimals cb
    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 withlinearshade (expr a, b, ca, cb) =
    withprescript "sh_type=linear"
    withprescript "sh_domain=0 1"
    withprescript "sh_factor="   & decimal shadefactor
    withprescript "sh_color_a="  & colordecimals ca
    withprescript "sh_color_b="  & colordecimals cb
    withprescript "sh_center_a=" & ddecimal (a shifted shadeoffset)
    withprescript "sh_center_b=" & ddecimal (b shifted shadeoffset)
enddef ;

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

string mfun_prescript_separator ; mfun_prescript_separator := char(13) ;

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="   & decimal shadefactor
      & mfun_prescript_separator & "sh_color_a="  & colordecimals ca
      & mfun_prescript_separator & "sh_color_b="  & colordecimals cb
      & mfun_prescript_separator & "sh_center_a=" & ddecimal (a shifted shadeoffset)
      & mfun_prescript_separator & "sh_center_b=" & ddecimal (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=" & decimal shadefactor
      & mfun_prescript_separator & "sh_color_a=" & colordecimals ca
      & mfun_prescript_separator & "sh_color_b=" & colordecimals cb
      & mfun_prescript_separator & "sh_center_a=" & ddecimal (a shifted shadeoffset)
      & mfun_prescript_separator & "sh_center_b=" & ddecimal (b shifted shadeoffset)
    ;
    mfun_defined_cs
enddef ;

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


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 ;

% NEW EXPERIMENTAL CODE

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 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 ;

def withshading (expr how)(text rest) =
    if how = "linear" :
        withlinearshading(rest)
    elseif how = "circular" :
        withcircularshading(rest)
    else :
        % nothing
    fi
enddef ;

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

% Layers

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

% 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 ;

def externalfigure primary filename =
    if false :
        rawtextext("\externalfigure[" & filename & "]")
    else :
        image (
            addto currentpicture doublepath unitsquare
                withprescript "fg_name=" & filename ;
        )
%             unitsquare
%                 withpen pencircle scaled 0
%                 withprescript "fg_name=" & filename
    fi
enddef ;

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

% Positions

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

% Housekeeping

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

% Bonus

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

% 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 ;

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

let property = picture ;

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

if metapostversion < 1.770  :

    def withproperties expr p =
        if colormodel p = 3 :
            withcolor greypart p
        elseif colormodel p = 5 :
            withcolor (redpart p,greenpart p,bluepart p)
        elseif colormodel p = 7 :
            withcolor (cyanpart p,magentapart p,yellowpart p,blackpart p)
        fi
    enddef ;

else :

    def withproperties expr p =
        if colormodel p = 3 :
            withcolor greypart p
        elseif colormodel p = 5 :
            withcolor (redpart p,greenpart p,bluepart p)
        elseif colormodel p = 7 :
            withcolor (cyanpart p,magentapart p,yellowpart p,blackpart p)
        fi
        withprescript prescriptpart p
        withpostscript postscriptpart p
    enddef ;

fi ;

% Experimental:

primarydef t asgroup s = % s = isolated|knockout
    begingroup
    save grouppicture, wrappedpicture, groupbounds ;
    picture grouppicture, wrappedpicture ; path groupbounds ;
    grouppicture := if picture t : t else : image(draw t) fi ;
    groupbounds := boundingbox grouppicture ;
    wrappedpicture:= nullpicture ;
    addto wrappedpicture contour groupbounds
        withprescript "gr_state=start"
        withprescript "gr_type=" & s
        withprescript "gr_llx=" & decimal xpart llcorner groupbounds
        withprescript "gr_lly=" & decimal ypart llcorner groupbounds
        withprescript "gr_urx=" & decimal xpart urcorner groupbounds
        withprescript "gr_ury=" & decimal ypart urcorner groupbounds ;
    addto wrappedpicture also grouppicture ;
    addto wrappedpicture contour groupbounds
        withprescript "gr_state=stop" ;
    wrappedpicture
    endgroup
enddef ;

% Also experimental

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_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 ;

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

vardef tostring(expr value) =
    if     numeric   value : mfun_numeric_to_string(value)
    elseif pair      value : mfun_pair_to_string(value)
    elseif rgbcolor  value : mfun_rgbcolor_to_string(value)
    elseif cmykcolor value : mfun_cmykcolor_to_string(value)
    elseif boolean   value : mfun_boolean_to_string(value)
    elseif path      value : mfun_path_to_string(value)
    elseif transform value : mfun_transform_to_string(value)
    else                   : value
    fi
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 ;

% amore flexible variant for passing data to context

vardef mfun_point_to_lua(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_lua(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_lua(expr n) =
    decimal n
enddef ;

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

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

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

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

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

vardef mfun_string_to_lua(expr s) =
   "[==[" & s & "]==]"
enddef ;

def mfun_to_lua(expr key)(expr value)(text t) =
    special "metapost.variables['" & key & "']=" & t(value) ;
enddef ;

def mfun_array_to_lua(expr key)(suffix value)(expr first, last, stp)(text t) =
    special
        "metapost.variables['" & key & "']={"
            for i=first step stp until last :
                & "[" & decimal i & "]=" & t(value[i]) & ","
            endfor
        & "}" ;
enddef ;

def passvariable(expr key, value) =
    if     numeric   value : mfun_to_lua(key,value,mfun_numeric_to_lua)
    elseif pair      value : mfun_to_lua(key,value,mfun_pair_to_lua)
    elseif string    value : mfun_to_lua(key,value,mfun_string_to_lua)
    elseif boolean   value : mfun_to_lua(key,value,mfun_boolean_to_lua)
    elseif path      value : mfun_to_lua(key,value,mfun_path_to_lua)
    elseif rgbcolor  value : mfun_to_lua(key,value,mfun_rgbcolor_to_lua)
    elseif cmykcolor value : mfun_to_lua(key,value,mfun_cmykcolor_to_lua)
    elseif transform value : mfun_to_lua(key,value,mfun_transform_to_lua)
    fi ;
enddef ;

def passarrayvariable(expr key)(suffix values)(expr first, last, stp) =
    if     numeric   values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_numeric_to_lua)
    elseif pair      values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_pair_to_lua)
    elseif string    values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_string_to_lua)
    elseif boolean   values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_boolean_to_lua)
    elseif path      values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_path_to_lua)
    elseif rgbcolor  values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_rgbcolor_to_lua)
    elseif cmykcolor values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_cmykcolor_to_lua)
    elseif transform values[first] : mfun_array_to_lua(key,values,first,last,stp,mfun_transform_to_lua)
    fi ;
enddef ;

def startpassingvariable(expr k) =
    begingroup ;
    save stoppassingvariable, startarray, stoparray, starthash, stophash, index, key, value, slot, entry ;
    let stoppassingvariable = mfun_stop_lua_variable ;
    let startarray = mfun_start_lua_array ;
    let stoparray = mfun_stop_lua_array ;
    let starthash = mfun_start_lua_hash ;
    let stophash = mfun_stop_lua_hash ;
    let index = mfun_lua_index ;
    let key = mfun_lua_key ;
    let value = mfun_lua_value ;
    let slot = mfun_lua_slot ;
    let entry = mfun_lua_entry ;
    save s ; string s ;
    s := "metapost.variables['" & k & "']="
enddef ;

def mfun_stop_lua_variable =
    ;
    special substring(0,length(s)-1) of s ;
    endgroup ;
enddef ;

% currently there is no difference between array and hash

def mfun_start_lua_array =
    & "{"
enddef ;

def mfun_stop_lua_array =
    & "},"
enddef ;

def mfun_start_lua_hash =
    & "{"
enddef ;

def mfun_stop_lua_hash =
    & "},"
enddef ;

def mfun_lua_key(expr k) =
    & "['" & k & "']="
enddef ;

def mfun_lua_index(expr k) =
    & "[" & decimal k & "]="
enddef ;

def mfun_lua_value(expr v) =
    if     numeric   v : & mfun_numeric_to_lua(v) & ","
    elseif pair      v : & mfun_pair_to_lua(v) & ","
    elseif string    v : & mfun_string_to_lua(v) & ","
    elseif boolean   v : & mfun_boolean_to_lua(v) & ","
    elseif path      v : & mfun_path_to_lua(v) & ","
    elseif rgbcolor  v : & mfun_rgbcolor_to_lua(v) & ","
    elseif cmykcolor v : & mfun_cmykcolor_to_lua(v) & ","
    elseif transform v : & mfun_transform_to_lua(v) & ","
    fi
enddef ;

def mfun_lua_entry(expr k, v) =
    mfun_lua_key(k)
    mfun_lua_value(v)
enddef ;

def mfun_lua_slot(expr k, v) =
    mfun_lua_index(k)
    mfun_lua_value(v)
enddef ;

% 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 ;

vardef strfmt(expr f, x) = % maybe use mfun_ namespace
    "\MPgraphformat{" & escaped_format(f) & "}{" & mfun_tagged_string(x) & "}"
enddef ;

vardef varfmt(expr f, x) = % maybe use mfun_ namespace
    "\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 ;