path: root/metapost/context/base/mpiv/mp-base.mpiv

% This is a reformatted copy of the plain.mp file. We use a copy
% because (1) we want to make sure that there are no unresolved
% dependencies, and (2) we may patch this file eventually.

% This file gives the macros for plain MetaPost It contains all the
% features of plain METAFONT except those specific to font-making.
% There are also a number of macros for labeling figures, etc.

% For practical reasons I have moved some new code here (and might
% remove some code as well). After all, there is no development in
% this format.

string base_name, base_version ;

base_name    := "plain" ;
base_version := "1.004 for metafun iv"  ;

message "loading metafun, including plain.mp version " & base_version ;

delimiters () ; % this makes parentheses behave like parentheses

def upto   = step  1 until enddef ;
def downto = step -1 until enddef ;

def exitunless expr c =
    exitif not c
enddef ;

let relax = \ ; % ignore the word relax, as in TeX
let \\    = \ ; % double relaxation is like single

def [[ = [ [ enddef ;
def ]] = ] ] enddef ;

def -- =
    {curl 1} .. {curl 1}
enddef ;

def --- =
    .. tension infinity ..
enddef ;

def ... =
    .. tension atleast 1 ..
enddef ;

def gobble primary g =
enddef ;

primarydef g gobbled gg =
enddef ;

def hide(text t) =
    exitif numeric begingroup t ; endgroup ;
enddef ;

def ??? =
    hide (
        interim showstopping := 1 ;
        showdependencies
    )
enddef ;

def stop expr s =
    message s ;
    gobble readstring
enddef ;

warningcheck     := 1 ;
tracinglostchars := 1 ;

def interact = % sets up to make "show" commands stop
    hide (
        showstopping  := 1 ;
        tracingonline := 1 ;
    )
enddef ;

def loggingall = % puts tracing info into the log
    tracingcommands  := 3 ;
    tracingtitles    := 1 ;
    tracingequations := 1 ;
    tracingcapsules  := 1 ;
    tracingspecs     := 2 ;
    tracingchoices   := 1 ;
    tracinglostchars := 1 ;
    tracingstats     := 1 ;
    tracingoutput    := 1 ;
    tracingmacros    := 1 ;
    tracingrestores  := 1 ;
enddef ;

def tracingall = % turns on every form of tracing
    tracingonline := 1 ;
    showstopping  := 1 ;
    loggingall ;
enddef ;

def tracingnone = % turns off every form of tracing
    tracingcommands  := 0 ;
    tracingtitles    := 0 ;
    tracingequations := 0 ;
    tracingcapsules  := 0 ;
    tracingspecs     := 0 ;
    tracingchoices   := 0 ;
    tracinglostchars := 0 ;
    tracingstats     := 0 ;
    tracingoutput    := 0 ;
    tracingmacros    := 0 ;
    tracingrestores  := 0 ;
enddef ;

%% dash patterns

vardef dashpattern(text t) =
    save on, off, w ;
    let on = _on_ ;
    let off = _off_ ;
    w = 0 ;
    nullpicture t
enddef ;

tertiarydef p _on_ d =
    begingroup save pic ;
        picture pic;
        pic = p ;
        addto pic doublepath (w,w) .. (w+d,w) ;
        w := w + d ;
        pic shifted (0,d)
    endgroup
enddef ;

tertiarydef p _off_ d =
    begingroup w := w + d ;
        p shifted (0,d)
    endgroup
enddef ;

%% basic constants and mathematical macros

% numeric constants

newinternal eps, epsilon, infinity, _ ;

eps      := .00049 ;      % this is a pretty small positive number
epsilon  := 1/256/256 ;   % but this is the smallest
infinity := 4095.99998 ;  % and this is the largest
_        := -1 ;          % internal constant to make macros unreadable but shorter

% linejoin and linecap types

newinternal mitered, rounded, beveled, butt, squared ;

mitered := 0 ; rounded := 1 ; beveled := 2 ;
butt    := 0 ; rounded := 1 ; squared := 2 ;

% pair constants

pair right, left, up, down, origin;

origin = (0,0) ;
up     = -down = (0,1) ;
right  = -left = (1,0) ;

% path constants

path quartercircle, halfcircle, fullcircle, unitsquare ;

fullcircle    = makepath pencircle ;
halfcircle    = subpath (0,4) of fullcircle ;
quartercircle = subpath (0,2) of fullcircle ;
unitsquare    = (0,0) -- (1,0) -- (1,1) -- (0,1) -- cycle ;

% transform constants

transform identity ;

for z=origin,right,up :
    z transformed identity = z ;
endfor

% color constants (all in rgb color space)

color black, white, red, green, blue, cyan, magenta, yellow, background;

black      := (0,0,0) ;
white      := (1,1,1) ;
red        := (1,0,0) ;
green      := (0,1,0) ;
blue       := (0,0,1) ;
cyan       := (0,1,1) ;
magenta    := (1,0,1) ;
yellow     := (1,1,0) ;

background := white ; % obsolete

let graypart  = greypart  ;
let greycolor = numeric ;
let graycolor = numeric ;

% color part (will be overloaded)

def colorpart primary t =
    if colormodel t = 7:
        (cyanpart t, magentapart t, yellowpart t, blackpart t)
    elseif colormodel t = 5 :
        (redpart t, greenpart t, bluepart t)
    elseif colormodel t = 3 :
        (greypart t)
    elseif colormodel t = 1 :
        false
    elseif defaultcolormodel = 7 :
        (0,0,0,1)
    elseif defaultcolormodel = 5 :
        black
    elseif defaultcolormodel = 3 :
        0
    else :
        false
    fi
enddef ;

% picture constants

picture blankpicture, evenly, withdots ;

blankpicture = nullpicture ;                       % display blankpicture...
evenly       = dashpattern(on 3 off 3) ;           % dashed evenly
withdots     = dashpattern(off 2.5 on 0 off 2.5) ; % dashed withdots

% string constants

string ditto, EOF ;

ditto = char 34 ; % ASCII double-quote mark
EOF   = char  0 ; % end-of-file for readfrom and write..to

% pen constants

pen pensquare, penrazor, penspeck ;

pensquare = makepen(unitsquare shifted -(.5,.5)) ;
penrazor  = makepen((-.5,0) -- (.5,0) -- cycle) ;
penspeck  = pensquare scaled eps ;

% nullary operators

vardef whatever =
    save ? ;
    ?
enddef ;

% unary operators (with patched round)

let abs = length ;

vardef round primary u =
    if numeric u :
        floor(u+.5)
    elseif pair u :
        (floor(xpart u+.5), floor(ypart u+.5))
    elseif path u :
        % added by HH
        for i=0 upto length u-1 :
            round(point i of u) ..
            controls round(postcontrol i of u) and round(precontrol i+1 of u) ..
        endfor
        if cycle u : cycle else : point infinity of u fi
    else :
        u
    fi
enddef ;

vardef ceiling primary x =
    -floor(-x)
enddef ;

vardef byte primary s =
    if string s :
        ASCII
    fi s
enddef ;

vardef dir primary d =
    right rotated d
enddef ;

vardef unitvector primary z =
    z/abs z
enddef ;

vardef inverse primary T =
    transform T_ ;
    T_ transformed T = identity ;
    T_
enddef ;

vardef counterclockwise primary c =
    if turningnumber c <= 0 :
        reverse
    fi c
enddef ;

vardef tensepath expr r =
    for k=0 upto length r - 1 :
        point k of r ---
    endfor
    if cycle r :
        cycle
    else :
        point infinity of r
    fi
enddef ;

vardef center primary p =
    .5[llcorner p, urcorner p]
enddef ;

% binary operators

primarydef x mod y =
    (x-y*floor(x/y))
enddef ;

primarydef x div y =
    floor(x/y)
enddef ;

primarydef w dotprod z =
    (xpart w * xpart z + ypart w * ypart z)
enddef ;

% primarydef x**y =
%     if y = 2 :
%         x*x
%     else :
%         takepower y of x
%     fi
% enddef ;
%
% def takepower expr y of x =
%     if x>0 :
%         mexp(y*mlog x)
%     elseif (x=0) and (y>0) :
%         0
%     else :
%         1
%         if y = floor y :
%             if y >= 0 :
%                 for n=1 upto y :
%                     *x
%                 endfor
%             else :
%                 for n=-1 downto y :
%                     /x
%                 endfor
%             fi
%         else :
%             hide(errmessage "Undefined power: " & decimal x & "**" & decimal y)
%         fi
%     fi
% enddef ;

% for big number systems:

primarydef x**y =
    if y = 0 :
        1
    elseif x = 0 :
        0
    elseif y < 0 :
        1/(x**-y)
    elseif y = 1 :
        x
    elseif y = 2 :
        x*x
    elseif y = 3 :
        x*x*x
    else :
        takepower y of x
    fi
enddef ;

def takepower expr y of x =
    if y=0 : % isn't x**0 = 1 even if x=0 ?
        1
    elseif x=0 :
        0
    else :
        if y = floor y :
            1
            if y >= 0 :
                for n=1 upto y :
                    *x
                endfor
            else :
                for n=-1 downto y :
                    /x
                endfor
            fi
        elseif x>0 :
            mexp(y*mlog x)
        else :
            -mexp(y*mlog -x)
        fi
    fi
enddef ;

vardef direction expr t of p =
    postcontrol t of p - precontrol t of p
enddef ;

vardef directionpoint expr z of p =
    a_ := directiontime z of p ;
    if a_ < 0 :
        errmessage("The direction doesn't occur") ;
    fi
    point a_ of p
enddef ;

secondarydef p intersectionpoint q =
    begingroup
    save x_, y_ ;
    (x_,y_) = p intersectiontimes q ;
    if x_ < 0 :
        errmessage("The paths don't intersect") ;
        origin
    else :
        .5[point x_ of p, point y_ of q]
    fi
    endgroup
enddef ;

tertiarydef p softjoin q =
    begingroup
    c_ := fullcircle scaled 2join_radius shifted point 0 of q ;
    a_ := ypart(c_ intersectiontimes p) ;
    b_ := ypart(c_ intersectiontimes q) ;
    if a_ < 0 :
        point 0 of p{direction 0 of p}
    else :
        subpath(0,a_) of p
    fi
    ...
    if b_ < 0 :
        {direction infinity of q} point infinity of q
    else :
        subpath(b_,infinity) of q
    fi
    endgroup
enddef ;

newinternal join_radius, a_, b_ ; path c_ ;

path cuttings ; % what got cut off

tertiarydef a cutbefore b =  % tries to cut as little as possible
    begingroup
    save t ;
    (t, whatever) = a intersectiontimes b ;
    if t < 0 :
        cuttings := point 0 of a ;
        a
    else :
        cuttings := subpath (0,t) of a ;
        subpath (t,length a) of a
    fi
    endgroup
enddef ;

tertiarydef a cutafter b =
    reverse (reverse a  cutbefore  b)
    hide(cuttings := reverse cuttings)
enddef ;

% special operators

vardef incr suffix $ = $ := $ + 1 ; $ enddef ;
vardef decr suffix $ = $ := $ - 1 ; $ enddef ;

def reflectedabout(expr w,z) = % reflects about the line w..z
    transformed
        begingroup
        transform T_ ;
        w transformed T_ = w ;
        z transformed T_ = z ;
        xxpart T_ = -yypart T_ ;
        xypart T_ =  yxpart T_ ; % T_ is a reflection
        T_
        endgroup
enddef ;

def rotatedaround(expr z, d) = % rotates d degrees around z
    shifted -z rotated d shifted z
enddef ;

let rotatedabout = rotatedaround ; % for roundabout people

vardef min(expr u)(text t) = % t is a list of numerics, pairs, or strings
    save u_ ;
    setu_ u ;
    for uu = t :
        if uu < u_ :
            u_ := uu ;
        fi
    endfor
    u_
enddef ;

vardef max(expr u)(text t) = % t is a list of numerics, pairs, or strings
    save u_ ;
    setu_ u ;
    for uu = t :
        if uu > u_ :
            u_ := uu ;
        fi
    endfor
    u_
enddef ;

def setu_ primary u =
    if pair u :
        pair u_
    elseif string u :
        string u_
    fi ;
    u_=u
enddef ;

def flex(text t) = % t is a list of pairs
    hide (
        n_ := 0 ;
        for z=t :
            z_[incr n_] := z ;
        endfor
        dz_ := z_[n_]-z_1
    )
    z_1 for k=2 upto n_-1 :
        ... z_[k]{dz_}
    endfor ... z_[n_]
enddef ;

newinternal n_; pair z_[],dz_;

def superellipse(expr r,t,l,b,s) =
    r { up    } ... (s[xpart t,xpart r],s[ypart r,ypart t]) { t-r } ...
    t { left  } ... (s[xpart t,xpart l],s[ypart l,ypart t]) { l-t } ...
    l { down  } ... (s[xpart b,xpart l],s[ypart l,ypart b]) { b-l } ...
    b { right } ... (s[xpart b,xpart r],s[ypart r,ypart b]) { r-b } ... cycle enddef ;

vardef interpath(expr a,p,q) =
    for t=0 upto length p-1 :
        a[point t of p, point t of q] .. controls a[postcontrol t of p, postcontrol t of q] and a[precontrol t+1 of p, precontrol t+1 of q] ..
    endfor
    if cycle p :
        cycle
    else :
        a[point infinity of p, point infinity of q]
    fi
enddef ;

vardef solve@#(expr true_x,false_x)= % @#(true_x)=true, @#(false_x)=false
    tx_:=true_x; fx_:=false_x;
    forever :
        x_ := .5[tx_,fx_] ;
        exitif abs(tx_-fx_) <= tolerance ;
        if @#(x_) :
            tx_
        else :
            fx_
        fi := x_ ;
    endfor
    x_  % now x_ is near where @# changes from true to false
enddef ;

newinternal tolerance, tx_, fx_, x_ ;

tolerance := .01 ;

vardef buildcycle(text ll) =
    save ta_, tb_, k_, i_, pp_ ; path pp_[] ;
    k_ = 0 ;
    for q=ll :
        pp_[incr k_] = q ;
    endfor
    i_ = k_ ;
    for i=1 upto k_ :
        (ta_[i], length pp_[i_]-tb_[i_]) = pp_[i] intersectiontimes reverse pp_[i_] ;
        if ta_[i]<0 :
          errmessage("Paths "& decimal i &" and "& decimal i_ &" don't intersect") ;
        fi
        i_ := i;
    endfor
    for i=1 upto k_ :
        subpath (ta_[i],tb_[i]) of pp_[i] ..
    endfor
    cycle
enddef ;

%% units of measure

mm :=  2.83464 ;
pt :=  0.99626 ;
dd :=  1.06601 ;
bp :=  1 ;
cm := 28.34645 ;
pc := 11.95517 ;
cc := 12.79213 ;
in := 72 ;

vardef magstep primary m = % obsolete
    mexp(46.67432m)
enddef ;

%% macros for drawing and filling

def drawoptions(text t) =
    def _op_ = t enddef
enddef ;

% parameters that effect drawing

linejoin   := rounded ;
linecap    := rounded ;
miterlimit := 10 ;

drawoptions() ;

pen currentpen ;
picture currentpicture ;

def fill expr c =
    addto currentpicture contour c _op_
enddef ;

def draw expr p =
    addto currentpicture
    if picture p :
        also p
    else :
        doublepath p withpen currentpen
    fi
    _op_
enddef ;

def filldraw expr c =
    addto currentpicture contour c withpen currentpen _op_
enddef ;

% def drawdot expr z =
%     addto currentpicture contour makepath currentpen shifted z _op_
% enddef ;
%
% testcase DEK:
%
% for j=1 upto 9 :
%     pickup pencircle xscaled .4 yscaled .2 ;
%     drawdot (10j,0) withpen pencircle xscaled .5j yscaled .25j rotated 45 ;
%     pickup pencircle xscaled .5j yscaled .25j rotated 45 ;
%     drawdot (10j,10);
% endfor ;
%
% or:
%
%\startMPpage
%
% def drawdot expr z =
%     addto currentpicture contour (makepath currentpen shifted z) _op_
% enddef;
%
% drawdot origin shifted (0,-3cm) withpen pencircle scaled 2cm ;
% pickup pencircle scaled 2cm ; drawdot origin withcolor red ;

def drawdot expr p =
    if pair p :
        addto currentpicture doublepath p withpen currentpen _op_
    else :
        errmessage("drawdot only accepts a pair expression")
    fi
enddef ;

def unfill     expr c = fill     c withcolor background enddef ;
def undraw     expr p = draw     p withcolor background enddef ;
def unfilldraw expr c = filldraw c withcolor background enddef ;
def undrawdot  expr z = drawdot  z withcolor background enddef ;

def erase text t =
    def _e_ =
        withcolor background hide(def _e_ = enddef ;)
    enddef ;
    t _e_
enddef ;

def _e_ = enddef ;

def cutdraw text t =
    begingroup
        interim linecap := butt ;
        draw t _e_ ;
    endgroup
enddef ;

vardef image(text t) =
    save currentpicture ;
    picture currentpicture ;
    currentpicture := nullpicture ;
    t ;
    currentpicture
enddef ;

def pickup secondary q =
    if numeric q :
        numeric_pickup_
    else :
        pen_pickup_
    fi q
enddef ;

def numeric_pickup_ primary q =
    if unknown pen_[q] :
        errmessage "Unknown pen" ;
        clearpen
    else :
        currentpen := pen_ [q] ;
        pen_lft := pen_lft_[q] ;
        pen_rt  := pen_rt_ [q] ;
        pen_top := pen_top_[q] ;
        pen_bot := pen_bot_[q] ;
        currentpen_path := pen_path_[q]
    fi ;
enddef ;

def pen_pickup_ primary q =
    currentpen := q ;
    pen_lft := xpart penoffset down  of currentpen ;
    pen_rt  := xpart penoffset up    of currentpen ;
    pen_top := ypart penoffset left  of currentpen ;
    pen_bot := ypart penoffset right of currentpen ;
    path currentpen_path ;
enddef ;

newinternal pen_lft, pen_rt, pen_top, pen_bot, pen_count_ ;

vardef savepen =
    pen_[incr pen_count_] = currentpen ;
    pen_lft_ [pen_count_] = pen_lft ;
    pen_rt_  [pen_count_] = pen_rt ;
    pen_top_ [pen_count_] = pen_top ;
    pen_bot_ [pen_count_] = pen_bot ;
    pen_path_[pen_count_] = currentpen_path ;
    pen_count_
enddef ;

def clearpen =
    currentpen := nullpen;
    pen_lft := pen_rt := pen_top := pen_bot := 0 ;
    path currentpen_path ;
enddef ;

def clear_pen_memory =
    pen_count_ := 0 ;
    numeric pen_lft_[], pen_rt_[], pen_top_[], pen_bot_[] ;
    pen currentpen, pen_[];
    path currentpen_path, pen_path_[] ;
enddef ;

vardef lft primary x = x + if pair x: (pen_lft,0) else: pen_lft fi enddef ;
vardef rt  primary x = x + if pair x: (pen_rt,0)  else: pen_rt  fi enddef ;
vardef top primary y = y + if pair y: (0,pen_top) else: pen_top fi enddef ;
vardef bot primary y = y + if pair y: (0,pen_bot) else: pen_bot fi enddef ;

vardef penpos@#(expr b,d) =
    (x@#r-x@#l,y@#r-y@#l) = (b,0) rotated d ;
    x@# = .5(x@#l+x@#r) ;
    y@# = .5(y@#l+y@#r) ; % ; added HH
enddef ;

path path_.l, path_.r ;

def penstroke text t =
    forsuffixes e = l, r :
        path_.e := t ;
    endfor
    fill path_.l -- reverse path_.r -- cycle
enddef ;

%% High level drawing commands

newinternal ahlength, ahangle ;

ahlength :=  4 ; % default arrowhead length 4bp
ahangle  := 45 ; % default head angle 45 degrees

vardef arrowhead expr p =
    save q, e ; path q ; pair e ;
    e = point length p of p ;
    q = gobble(p shifted -e cutafter makepath(pencircle scaled 2ahlength)) cuttings ;
    (q rotated .5ahangle & reverse q rotated -.5ahangle -- cycle) shifted e
enddef ;

path _apth ;

def drawarrow    expr p = _apth := p ; _finarr  enddef ;
def drawdblarrow expr p = _apth := p ; _findarr enddef ;

def _finarr text t =
    draw _apth t ;
    filldraw arrowhead _apth t
enddef ;

def _findarr text t = % this had fill in 0.63 (potential incompatibility)
    draw _apth t ;
    filldraw arrowhead         _apth withpen currentpen t ;
    filldraw arrowhead reverse _apth withpen currentpen t ; % ; added HH
enddef ;

%% macros for labels

newinternal bboxmargin ;

bboxmargin := 2bp ; % this can bite you

vardef bbox primary p =
    llcorner p - ( bboxmargin, bboxmargin) --
    lrcorner p + ( bboxmargin,-bboxmargin) --
    urcorner p + ( bboxmargin, bboxmargin) --
    ulcorner p + (-bboxmargin, bboxmargin) -- cycle
enddef ;

string defaultfont ; newinternal defaultscale, labeloffset ;

defaultfont  := "cmr10" ;
defaultscale := 1 ;
labeloffset  := 3bp ;

vardef thelabel@#(expr s,z) = % Position s near z
    save p ; picture p ;
    if picture s :
        p = s
    else :
        p = s infont defaultfont scaled defaultscale
    fi ;
    p shifted (z + labeloffset*laboff@# - ( labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p) )
enddef ;

def label =
    draw thelabel
enddef ;

newinternal dotlabeldiam ;

dotlabeldiam := 3bp ;

vardef dotlabel@#(expr s,z) text t_ =
    label@#(s,z) t_ ;
  % label@#(s,z) ;
    interim linecap := rounded ;
    draw z withpen pencircle scaled dotlabeldiam t_ ;
enddef ;

def makelabel =
    dotlabel
enddef ;

% this will be overloaded

pair laboff, laboff.lft, laboff.rt, laboff.top, laboff.bot ;
pair laboff.ulft, laboff.llft, laboff.urt, laboff.lrt ;

laboff      = (0,0)    ; labxf      = .5 ; labyf      = .5 ;
laboff.lft  = (-1,0)   ; labxf.lft  = 1  ; labyf.lft  = .5 ;
laboff.rt   = (1,0)    ; labxf.rt   = 0  ; labyf.rt   = .5 ;
laboff.bot  = (0,-1)   ; labxf.bot  = .5 ; labyf.bot  = 1  ;
laboff.top  = (0,1)    ; labxf.top  = .5 ; labyf.top  = 0  ;
laboff.ulft = (-.7,.7) ; labxf.ulft = 1  ; labyf.ulft = 0  ;
laboff.urt  = (.7,.7)  ; labxf.urt  = 0  ; labyf.urt  = 0  ;
laboff.llft = -(.7,.7) ; labxf.llft = 1  ; labyf.llft = 1  ;
laboff.lrt  = (.7,-.7) ; labxf.lrt  = 0  ; labyf.lrt  = 1  ;

vardef labels@#(text t) =
    forsuffixes $=t :
        label@#(str$,z$) ;
    endfor
enddef ;

% till lhere

vardef dotlabels@#(text t) =
    forsuffixes $=t:
        dotlabel@#(str$,z$) ;
    endfor
enddef ;

vardef penlabels@#(text t) =
    forsuffixes $$=l,,r :
        forsuffixes $=t :
            makelabel@#(str$.$$,z$.$$) ;
        endfor
    endfor
enddef ;

% range 4 thru 10

def range expr x =
    _numtok_[x]
enddef ;

def _numtok_ suffix x =
    x
enddef ;

tertiarydef m thru n =
    m for x=m+1 step 1 until n :
        , _numtok_[x]
    endfor
enddef ;

%% Overall administration

string extra_beginfig, extra_endfig ;

extra_beginfig := "" ;
extra_endfig   := "" ;

def beginfig(expr c) =
    begingroup
    charcode := c ;
    clearxy ;
    clearit ;
    clearpen ;
    pickup defaultpen ;
    drawoptions() ;
    scantokens extra_beginfig ;
enddef ;

def endfig =
    ; % added by HH
    scantokens extra_endfig ;
    shipit ;
    endgroup
enddef ;

%% last-minute items

vardef z@# =
    (x@#,y@#)
enddef ;

def clearxy =
    save x, y
enddef ;

def clearit =
    currentpicture := nullpicture
enddef ;

def shipit =
    shipout currentpicture
enddef ;

let bye = end ;
outer end, bye ;

clear_pen_memory ; % initialize the savepen mechanism
clearit ;

% set default line width

newinternal defaultpen ;

pickup pencircle scaled .5bp ;

defaultpen := savepen ;