beta 2011.09.05 22:21

1 files changed, 585 insertions, 0 deletions

diff --git a/metapost/context/base/mp-mlib.mpiv b/metapost/context/base/mp-mlib.mpiv
new file mode 100644
index 000000000..5b88c3159
--- /dev/null
+++ b/metapost/context/base/mp-mlib.mpiv
@@ -0,0 +1,585 @@
+%D \module
+%D   [       file=mp-mlib.mp,
+%D        version=2008.03.21,
+%D          title=\CONTEXT\ \METAPOST\ graphics,
+%D       subtitle=plugins,
+%D         author=Hans Hagen,
+%D           date=\currentdate,
+%D      copyright={PRAGMA / Hans Hagen \& Ton Otten}]
+%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, v) =
+%     1
+%     withprescript "sp_type=named"
+%     withprescript "sp_name="  & n
+%     withprescript "sp_value=" & v
+% 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 ;
+
+def withtransparency(expr alternative, transparency) =
+    withprescript "tr_alternative="  & decimal transparency_alternative_to_number(alternative)
+    withprescript "tr_transparency=" & decimal transparency
+enddef ;
+
+def cmyk(expr c, m, y, k) =
+    (c,m,y,k)
+enddef ;
+
+% Texts
+
+numeric _tt_w_[], _tt_h_[], _tt_d_[] ;
+numeric _tt_n_ ; _tt_n_ := 0 ;
+picture _tt_p_ ; _tt_p_ := nullpicture ;
+boolean _trial_run_ ; _trial_run_ := false ;
+
+def resettextexts =
+    _tt_n_ := 0 ;
+    _tt_p_ := nullpicture ;
+enddef ;
+
+def flushtextexts =
+    addto currentpicture also _tt_p_
+enddef ;
+
+extra_endfig   := "flushtextexts;" & extra_endfig;
+extra_beginfig := extra_beginfig & "resettextexts;";
+
+% 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 _trial_run_ :
+        _tt_n_ := _tt_n_ + 1 ;
+        addto _tt_p_ doublepath unitsquare
+            withprescript "tx_number=" & decimal _tt_n_
+            withprescript "tx_stage=extra"
+            withpostscript str ;
+        image (
+            addto currentpicture doublepath unitsquare
+                withprescript "tx_number=" & decimal _tt_n_
+                withprescript "tx_stage=trial"
+                withpostscript str
+        )
+    else :
+        _tt_n_ := _tt_n_ + 1 ;
+        if known _tt_d_[_tt_n_] :
+            image (
+                addto currentpicture doublepath unitsquare
+                    xscaled _tt_w_[_tt_n_]
+                    yscaled (_tt_h_[_tt_n_] + _tt_d_[_tt_n_])
+                    withprescript "tx_number=" & decimal _tt_n_
+                    withprescript "tx_stage=final"
+                    ; % withpostscript str ;
+            ) shifted (0,-_tt_d_[_tt_n_])
+        else :
+            image (
+                addto currentpicture doublepath unitsquare ;
+            )
+        fi
+    fi
+enddef ;
+
+% More text
+
+pair laboff.d, laboff.dlft, laboff.drt ; % new positional suffixes
+pair laboff.origin, laboff.raw         ; % graph mess
+
+laboff.d    := laboff     ; labxf.d    := labxf     ; labyf.d    := labyf     ;
+laboff.dlft := laboff.lft ; labxf.dlft := labxf.lft ; labyf.dlft := labyf.lft ;
+laboff.drt  := laboff.rt  ; labxf.drt  := labxf.rt  ; labyf.drt  := labyf.rt  ;
+
+labtype        :=  0 ; labtype.lft  :=  1 ; labtype.rt   :=  2 ;
+labtype.bot    :=  3 ; labtype.top  :=  4 ; labtype.ulft :=  5 ;
+labtype.urt    :=  6 ; labtype.llft :=  7 ; labtype.lrt  :=  8 ;
+labtype.d      := 10 ; labtype.dlft := 11 ; labtype.drt  := 12 ;
+labtype.origin :=  0 ; labtype.raw  :=  0 ;
+
+% laboff.origin = (infinity,infinity) ; labxf.origin := 0 ; labyf.origin := 0 ;
+% laboff.raw    = (infinity,infinity) ; labxf.raw    := 0 ; labyf.raw    := 0 ;
+
+% todo: thelabel.origin("xxxx",origin) (overflows)
+
+laboff.origin = (0,0) ; labxf.origin := 0 ; labyf.origin := 0 ;
+laboff.raw    = (0,0) ; labxf.raw    := 0 ; labyf.raw    := 0 ;
+
+pair laboff.l   ; laboff.l  = laboff.lft  ;
+pair laboff.r   ; laboff.r  = laboff.rt   ;
+pair laboff.b   ; laboff.b  = laboff.bot  ;
+pair laboff.t   ; laboff.t  = laboff.top  ;
+pair laboff.l_t ; laboff.l_t = laboff.ulft ;
+pair laboff.r_t ; laboff.r_t = laboff.urt  ;
+pair laboff.l_b ; laboff.l_b = laboff.llft ;
+pair laboff.r_b ; laboff.r_b = laboff.lrt  ;
+pair laboff.t_l ; laboff.t_l = laboff.ulft ;
+pair laboff.t_r ; laboff.t_r = laboff.urt  ;
+pair laboff.b_l ; laboff.b_l = laboff.llft ;
+pair laboff.b_r ; laboff.b_r = laboff.lrt  ;
+
+numeric labxf.l   ; labxf.l  = labxf.lft  ;
+numeric labxf.r   ; labxf.r  = labxf.rt   ;
+numeric labxf.b   ; labxf.b  = labxf.bot  ;
+numeric labxf.t   ; labxf.t  = labxf.top  ;
+numeric labxf.l_t ; labxf.l_t = labxf.ulft ;
+numeric labxf.r_t ; labxf.r_t = labxf.urt  ;
+numeric labxf.l_b ; labxf.l_b = labxf.llft ;
+numeric labxf.r_b ; labxf.r_b = labxf.lrt  ;
+numeric labxf.t_l ; labxf.t_l = labxf.ulft ;
+numeric labxf.t_r ; labxf.t_r = labxf.urt  ;
+numeric labxf.b_l ; labxf.b_l = labxf.llft ;
+numeric labxf.b_r ; labxf.b_r = labxf.lrt  ;
+
+numeric labyf.l   ; labyf.l  = labyf.lft  ;
+numeric labyf.r   ; labyf.r  = labyf.rt   ;
+numeric labyf.b   ; labyf.b  = labyf.bot  ;
+numeric labyf.t   ; labyf.t  = labyf.top  ;
+numeric labyf.l_t ; labyf.l_t = labyf.ulft ;
+numeric labyf.r_t ; labyf.r_t = labyf.urt  ;
+numeric labyf.l_b ; labyf.l_b = labyf.llft ;
+numeric labyf.r_b ; labyf.r_b = labyf.lrt  ;
+numeric labyf.t_l ; labyf.t_l = labyf.ulft ;
+numeric labyf.t_r ; labyf.t_r = labyf.urt  ;
+numeric labyf.b_l ; labyf.b_l = labyf.llft ;
+numeric labyf.b_r ; labyf.b_r = labyf.lrt  ;
+
+numeric labtype.l   ; labtype.l   = labtype.lft  ;
+numeric labtype.r   ; labtype.r   = labtype.rt   ;
+numeric labtype.b   ; labtype.b   = labtype.bot  ;
+numeric labtype.t   ; labtype.t   = labtype.top  ;
+numeric labtype.l_t ; labtype.l_t = labtype.ulft ;
+numeric labtype.r_t ; labtype.r_t = labtype.urt  ;
+numeric labtype.l_b ; labtype.l_b = labtype.llft ;
+numeric labtype.r_b ; labtype.r_b = labtype.lrt  ;
+numeric labtype.t_l ; labtype.t_l = labtype.ulft ;
+numeric labtype.t_r ; labtype.t_r = labtype.urt  ;
+numeric labtype.b_l ; labtype.b_l = labtype.llft ;
+numeric labtype.b_r ; labtype.b_r = labtype.lrt  ;
+
+vardef thetextext@#(expr p,z) = % adapted copy of thelabel@
+    if string p :
+        thetextext@#(rawtextext(p),z)
+    else :
+        p
+            if (labtype@# >= 10) : shifted (0,ypart center p) fi
+            shifted (z + labeloffset*laboff@# - (labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p))
+    fi
+enddef ;
+
+vardef textext@#(expr txt) =
+    interim labeloffset := textextoffset ;
+    if string txt :
+        thetextext@#(rawtextext(txt),origin)
+    else :
+        thetextext@#(txt,origin)
+    fi
+enddef ;
+
+% \starttext
+%   \startMPpage
+%     numeric value ; value = 123 ;
+%     label.lft(decimal value,origin) ;
+%     draw "oeps" infont defaultfont ;
+%   \stopMPpage
+% \stoptext
+
+vardef thelabel@#(expr s, z) =
+    save p ; picture p ;
+    if picture s :
+        p = s ;
+    else :
+        p = textext("\definedfont[" & defaultfont & "]" & s) scaled defaultscale ;
+    fi ;
+    p shifted (z + labeloffset*laboff@# - (labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p))
+enddef;
+
+let normalinfont = infont ;
+
+primarydef str infont name = % very naughty !
+    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 _defined_cs_pre_[] ; numeric _defined_cs_ ; _defined_cs_:= 0 ;
+string prescript_separator ; prescript_separator := char(13) ;
+
+vardef define_circular_shade (expr a, b, ra, rb, ca, cb) =
+    _defined_cs_ := _defined_cs_ + 1 ;
+    _defined_cs_pre_ [_defined_cs_] := "sh_type=circular"
+      & prescript_separator & "sh_domain=0 1"
+      & prescript_separator & "sh_factor="   & decimal shadefactor
+      & prescript_separator & "sh_color_a="  & colordecimals ca
+      & prescript_separator & "sh_color_b="  & colordecimals cb
+      & prescript_separator & "sh_center_a=" & ddecimal (a shifted shadeoffset)
+      & prescript_separator & "sh_center_b=" & ddecimal (b shifted shadeoffset)
+      & prescript_separator & "sh_radius_a=" & decimal ra
+      & prescript_separator & "sh_radius_b=" & decimal rb
+    ;
+    _defined_cs_
+enddef ;
+
+vardef define_linear_shade (expr a, b, ca, cb) =
+    _defined_cs_ := _defined_cs_ + 1 ;
+    _defined_cs_pre_ [_defined_cs_] := "sh_type=linear"
+      & prescript_separator & "sh_domain=0 1"
+      & prescript_separator & "sh_factor=" & decimal shadefactor
+      & prescript_separator & "sh_color_a=" & colordecimals ca
+      & prescript_separator & "sh_color_b=" & colordecimals cb
+      & prescript_separator & "sh_center_a=" & ddecimal (a shifted shadeoffset)
+      & prescript_separator & "sh_center_b=" & ddecimal (b shifted shadeoffset)
+    ;
+    _defined_cs_
+enddef ;
+
+primarydef p withshade sc =
+    p withprescript _defined_cs_pre_[sc]
+enddef ;
+
+
+vardef define_sampled_linear_shade(expr a,b,n)(text t) =
+    _defined_cs_ := _defined_cs_ + 1 ;
+    _defined_cs_pre_ [_defined_cs_] := "ssh_type=linear"
+      & prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
+      & prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
+      & prescript_separator & "ssh_nofcolors=" & decimal n
+      & prescript_separator & "ssh_domain=" & domstr
+      & prescript_separator & "ssh_extend=" & extstr
+      & prescript_separator & "ssh_colors=" & colstr
+      & prescript_separator & "ssh_bounds=" & bndstr
+      & prescript_separator & "ssh_ranges=" & ranstr
+    ;
+    _defined_cs_
+enddef ;
+
+vardef define_sampled_circular_shade(expr a,b,ra,rb,n)(text t) =
+    _defined_cs_ := _defined_cs_ + 1 ;
+    _defined_cs_pre_ [_defined_cs_] := "ssh_type=circular"
+      & prescript_separator & "ssh_center_a=" & ddecimal (a shifted shadeoffset)
+      & prescript_separator & "ssh_radius_a=" & decimal ra
+      & prescript_separator & "ssh_center_b=" & ddecimal (b shifted shadeoffset)
+      & prescript_separator & "ssh_radius_b=" & decimal rb
+      & prescript_separator & "ssh_nofcolors=" & decimal n
+      & prescript_separator & "ssh_domain=" & domstr
+      & prescript_separator & "ssh_extend=" & extstr
+      & prescript_separator & "ssh_colors=" & colstr
+      & prescript_separator & "ssh_bounds=" & bndstr
+      & prescript_separator & "ssh_ranges=" & ranstr
+    ;
+    _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 ;
+
+% END OF NEW
+
+% Graphic text (we will move code here)
+
+def graphictext primary t =
+    if _trial_run_ :
+        let dographictextindeed = nographictext ;
+    else :
+        let dographictextindeed = dographictext ;
+    fi
+    dographictextindeed(t)
+enddef ;
+
+def dographictext (expr t) =
+    % withprescript "gt_stage=final"
+    begingroup ;
+    save figurepicture ; picture figurepicture ;
+    figurepicture := currentpicture ; currentpicture := nullpicture ;
+    currentgraphictext := currentgraphictext + 1 ;
+    dofinishgraphictext
+enddef ;
+
+def nographictext (expr t) text rest =
+    draw unitsquare withprescript "gt_stage=trial" withpostscript t
+enddef ;
+
+% def savegraphictext (expr str) =
+% enddef ;
+
+% def erasegraphictextfile =
+% 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) =
+    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   & "resettextexts ; " ;
+
+boolean cmykcolors ; cmykcolors := true ;
+boolean spotcolors ; spotcolors := true ;
+
+% 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 ;