1 files changed, 348 insertions, 0 deletions
diff --git a/metapost/context/base/mpiv/mp-grph.mpiv b/metapost/context/base/mpiv/mp-grph.mpiv
new file mode 100644
index 000000000..5938b9f02
--- /dev/null
+++ b/metapost/context/base/mpiv/mp-grph.mpiv
@@ -0,0 +1,348 @@
+%D \module
+%D   [       file=mp-grph.mpiv,
+%D        version=2000.12.14,
+%D          title=\CONTEXT\ \METAPOST\ graphics,
+%D       subtitle=graphic text support,
+%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.
+
+%D Under construction.
+
+if known context_grph : endinput ; fi ;
+
+boolean context_grph ; context_grph := true ;
+
+picture _currentpicture_ ;
+
+numeric _fig_nesting_ ; _fig_nesting_ := 0 ;
+
+def beginfig (expr c) =
+    _fig_nesting_ := _fig_nesting_ + 1 ;
+    if _fig_nesting_ = 1 :
+        begingroup
+        charcode := c ;
+        resetfig ;
+        scantokens extra_beginfig ;
+    fi ;
+enddef ;
+
+def endfig =
+    ; % safeguard
+    if _fig_nesting_ = 1 :
+        scantokens extra_endfig ;
+        shipit ;
+        endgroup ;
+    fi ;
+    _fig_nesting_ := _fig_nesting_ - 1 ;
+enddef;
+
+def resetfig =
+    clearxy ;
+    clearit ;
+    clearpen ;
+    pickup defaultpen ;
+    interim linecap := linecap ;
+    interim linejoin := linejoin ;
+    interim miterlimit := miterlimit ;
+    save _background_ ; color _background_ ; _background_ :=  background  ;
+    save  background  ; color  background  ;  background  := _background_ ;
+    drawoptions () ;
+enddef ;
+
+def protectgraphicmacros =
+    save showtext ;
+    save beginfig ; let beginfig = begingraphictextfig ;
+    save endfig   ; let endfig   = endgraphictextfig ;
+    save end      ; let end      = relax ;
+    interim prologues := prologues ;
+    resetfig ; % resets currentpicture
+enddef ;
+
+numeric currentgraphictext ; currentgraphictext := 0 ;
+
+def data_mpo_file = job_name & "-mpgraph.mpo" enddef ;
+def data_mpy_file = job_name & "-mpgraph.mpy" enddef ;
+
+def begingraphictextfig (expr n) =
+    foundpicture := n ;
+    scratchpicture := nullpicture ;
+enddef ;
+
+def endgraphictextfig =
+    if foundpicture = currentgraphictext :
+        expandafter endinput
+    else :
+        scratchpicture := nullpicture ;
+    fi ;
+enddef ;
+
+def loadfigure primary filename =
+    doloadfigure (filename)
+enddef ;
+
+def doloadfigure (expr filename) text figureattributes =
+    begingroup ;
+    save figurenumber, figurepicture, number, fixedplace ;
+    numeric figurenumber  ; figurenumber := 0 ;
+    boolean figureshift ; figureshift := true ;
+    picture figurepicture ; figurepicture := currentpicture ;
+    def number primary n = hide(figurenumber := n) enddef ;
+    def fixedplace = hide(figureshift := false) enddef ;
+    protectgraphicmacros ;
+    % defaults
+    interim linecap    := rounded ;
+    interim linejoin   := rounded ;
+    interim miterlimit := 10 ;
+    %
+    currentpicture := nullpicture ;
+    draw fullcircle figureattributes ; % expand number
+    currentpicture := nullpicture ;
+    def beginfig (expr n) =
+        currentpicture := nullpicture ;
+        if (figurenumber=n) or (figurenumber=0) :
+            let endfig = endinput ;
+        fi ;
+    enddef ;
+    let endfig = relax ;
+    readfile(filename) ;
+    if figureshift :
+        currentpicture := currentpicture shifted -llcorner currentpicture ;
+    fi ;
+    addto figurepicture also currentpicture figureattributes ;
+    currentpicture := figurepicture  ;
+    endgroup ;
+enddef ;
+
+% shared between old and new
+
+boolean mfun_gt_color_fill ;
+boolean mfun_gt_color_draw ;
+boolean mfun_gt_shade_fill ;
+boolean mfun_gt_reverse_fill ;
+boolean mfun_gt_outline_fill ;
+picture mfun_gt_picture ;
+
+% this is the old version:
+
+def old_graphictext primary t =
+    hide (
+        if mfun_trial_run :
+            let mfun_graphic_text = mfun_no_graphic_text ;
+        else :
+            let mfun_graphic_text = mfun_do_graphic_text ;
+        fi
+    )
+    mfun_graphic_text(t)
+enddef ;
+
+def mfun_do_graphic_text (expr t) =
+    % withprescript "gt_stage=final"
+    begingroup ;
+    save figurepicture ; picture figurepicture ;
+    figurepicture := currentpicture ; currentpicture := nullpicture ;
+    currentgraphictext := currentgraphictext + 1 ;
+    mfun_finish_graphic_text % picks up directives
+enddef ;
+
+def mfun_no_graphic_text (expr t) text rest =
+    currentgraphictext := currentgraphictext + 1 ;
+    draw unitsquare
+        withprescript "gt_stage=trial"
+        withprescript "gt_index=" & decimal currentgraphictext
+        withpostscript t
+enddef ;
+
+def mfun_finish_graphic_text text rest =
+    protectgraphicmacros ; % resets currentpicture
+    interim linecap    := butt ;     % normally rounded
+    interim linejoin   := mitered ;  % normally rounded
+    interim miterlimit := 10 ;       % todo
+    let normalwithshade = withshade ;
+    save foundpicture, scratchpicture, str ;
+    save fill, draw, withshade, reversefill, outlinefill ;
+    save withfillcolor, withdrawcolor ; % quite important
+    numeric foundpicture ; picture scratchpicture ; string str ;
+    def draw expr p =
+        % the first, naive implementation was:
+        %   addto scratchpicture doublepath p withpen currentpen ;
+        % but it is better to turn lines into fills
+        addto scratchpicture contour boundingbox
+            image (addto currentpicture doublepath p withpen currentpen) ;
+    enddef ;
+    def fill expr p =
+        addto scratchpicture contour p withpen currentpen ;
+    enddef ;
+    def mfun_gt_fill  = enddef ; boolean mfun_gt_color_fill ; mfun_gt_color_fill := false ;
+    def mfun_gt_draw  = enddef ; boolean mfun_gt_color_draw ; mfun_gt_color_draw := false ;
+    def mfun_gt_shade = enddef ; boolean mfun_gt_shade_fill ; mfun_gt_shade_fill := false ;
+    boolean mfun_gt_reverse_fill ; mfun_gt_reverse_fill := false ;
+    boolean mfun_gt_outline_fill ; mfun_gt_outline_fill := false ;
+    def reversefill =
+        hide(mfun_gt_reverse_fill := true )
+    enddef ;
+    def outlinefill =
+        hide(mfun_gt_outline_fill := true )
+    enddef ;
+    def withshade primary c =
+        hide(def mfun_gt_shade = normalwithshade c enddef ; mfun_gt_shade_fill := true )
+    enddef ;
+    def withfillcolor primary c =
+        hide(def mfun_gt_fill = withcolor c enddef ; mfun_gt_color_fill := true )
+    enddef ;
+    def withdrawcolor primary c =
+        hide(def mfun_gt_draw = withcolor c enddef ; mfun_gt_color_draw := true )
+    enddef ;
+    scratchpicture := nullpicture ;
+    addto scratchpicture doublepath origin rest ; % pre-roll
+    for i within scratchpicture : % Below here is a dirty tricky test!
+        if (urcorner dashpart i) = origin :
+            mfun_gt_outline_fill := false ;
+        fi ;
+    endfor ;
+    scratchpicture := nullpicture ;
+    readfile(data_mpy_file) ;
+    scratchpicture := (scratchpicture shifted -llcorner scratchpicture) scaled (1/10) ;
+    if not mfun_gt_color_draw and not mfun_gt_color_fill :
+        mfun_gt_color_draw := true ;
+    fi
+    if mfun_gt_shade_fill :
+        mfun_gt_color_draw := false ;
+        mfun_gt_color_fill := false ;
+    fi ;
+    currentpicture := figurepicture ;
+    if mfun_gt_shade_fill :
+        for i within scratchpicture :
+            if filled i :
+                addto currentpicture contour pathpart i _op_ rest mfun_gt_shade ;
+            fi ;
+        endfor ;
+    else :
+        if mfun_gt_color_draw and not mfun_gt_reverse_fill :
+            for i within scratchpicture :
+                if mfun_gt_color_fill and mfun_gt_outline_fill :
+                    addto currentpicture doublepath pathpart i _op_ rest mfun_gt_fill dashed nullpicture ;
+                fi ;
+                if filled i :
+                    addto currentpicture doublepath pathpart i _op_ rest mfun_gt_draw ;
+                fi ;
+            endfor ;
+        fi ;
+        if mfun_gt_color_fill :
+            for i within scratchpicture :
+                if filled i :
+                    addto currentpicture contour pathpart i _op_ rest mfun_gt_fill withpen pencircle scaled 0 ;
+                fi ;
+            endfor ;
+        fi ;
+        if mfun_gt_color_draw and mfun_gt_reverse_fill :
+            for i within scratchpicture :
+                if filled i :
+                    addto currentpicture doublepath pathpart i _op_ rest mfun_gt_draw ;
+                fi ;
+            endfor ;
+        fi ;
+        for i within scratchpicture :
+            if stroked i :
+                addto currentpicture doublepath pathpart i _op_ rest mfun_gt_draw ;
+            fi ;
+        endfor ;
+    fi ;
+    endgroup ;
+enddef ;
+
+% and this is the new one:
+
+% boolean mfun_gt_color_fill ;
+% boolean mfun_gt_color_draw ;
+% boolean mfun_gt_shade_fill ;
+% boolean mfun_gt_reverse_fill ;
+% picture mfun_gt_picture ;
+
+def mfun_gt_default = % somewhat compatible
+    scaled 11.5
+    withpen pencircle scaled .1
+enddef ;
+
+def new_graphictext primary t = % use outlinetext instead
+    begingroup ;
+    mfun_graphic_text_indeed(t)
+enddef ;
+
+def mfun_graphic_text_indeed(expr t) text rest =
+    interim linecap    := butt ;     % normally rounded
+    interim linejoin   := mitered ;  % normally rounded
+  % interim miterlimit := 10 ;       % todo
+    %
+    let normalwithshade = withshade ;
+    %
+    save reversefill, outlinefill, withshade, withfillcolor, withdrawcolor ;
+    %
+    def mfun_gt_fill  = enddef ;
+    def mfun_gt_draw  = enddef ;
+    def mfun_gt_shade = enddef ;
+    %
+    mfun_gt_color_fill   := false ;
+    mfun_gt_color_draw   := false ;
+    mfun_gt_shade_fill   := false ;
+    mfun_gt_reverse_fill := false ;
+    %
+    def reversefill = hide(mfun_gt_reverse_fill := true) enddef ;
+    def outlinefill = enddef ;
+    def withshade     primary c = hide(mfun_gt_shade_fill := true; def mfun_gt_shade = normalwithshade c enddef ;) enddef ;
+    def withfillcolor primary c = hide(mfun_gt_color_fill := true; def mfun_gt_fill  = withcolor c       enddef ;) enddef ;
+    def withdrawcolor primary c = hide(mfun_gt_color_draw := true; def mfun_gt_draw  = withcolor c       enddef ;) enddef ;
+    %
+    mfun_gt_picture := nullpicture ;
+    addto mfun_gt_picture doublepath origin rest ; % preroll
+    mfun_gt_picture := nullpicture ;
+    %
+    def reversefill = enddef ;
+    def outlinefill = enddef ;
+    def withshade     primary c = enddef ;
+    def withfillcolor primary c = enddef ;
+    def withdrawcolor primary c = enddef ;
+    %
+    if mfun_gt_shade_fill :
+        draw outlinetext.f(t)(mfun_gt_shade) rest;
+    elseif mfun_gt_color_fill and mfun_gt_color_draw :
+        if mfun_gt_reverse_fill :
+            draw outlinetext.r(t)(mfun_gt_default mfun_gt_fill rest)(mfun_gt_default mfun_gt_draw rest) ;
+        else :
+            draw outlinetext.b(t)(mfun_gt_default mfun_gt_draw rest)(mfun_gt_default mfun_gt_fill rest);
+        fi ;
+    elseif mfun_gt_color_fill :
+        draw outlinetext.f(t)(mfun_gt_default mfun_gt_fill rest) ;
+    elseif mfun_gt_color_draw :
+        draw outlinetext.d(t)(mfun_gt_default mfun_gt_draw rest) ;
+    else :
+        draw outlinetext.d(t)(mfun_gt_default rest) ;
+    fi ;
+    %
+    endgroup ;
+enddef ;
+
+let graphictext = old_graphictext ;
+%%% graphictext = new_graphictext ; % more than 10 times faster
+
+% example
+%
+% beginfig (1) ;
+%     graphictext
+%         "\vbox{\hsize10cm \input tufte }"
+%         scaled 8
+%         withdrawcolor blue
+%         withfillcolor red
+%         withpen pencircle scaled 2pt ;
+% endfig ;
+%
+% beginfig(1) ;
+%       loadfigure "gracht.mp" rotated 20 ;
+%       loadfigure "koe.mp" number 1 scaled 2 ;
+% endfig ;
+%
+% end