%D \module %D [ file=mp-tool.mpiv, %D version=1998.02.15, %D title=\CONTEXT\ \METAPOST\ graphics, %D subtitle=auxiliary macros, %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 mreadme.pdf for %C details. if known context_tool : endinput ; fi ; boolean context_tool ; context_tool := true ; let @## = @# ; let noexpand = quote ; %D New, version number testing: %D %D \starttyping %D fill fullcircle scaled 2cm withcolor if mpversiongt("0.6") : red else : green fi ; %D fill fullcircle scaled 1cm withcolor if mpversionlt(0.6) : blue else : white fi ; %D \stoptyping if not known mpversion : string mpversion ; mpversion := "0.641" ; fi ; % newinternal metapostversion ; metapostversion := scantokens(mpversion) ; newinternal metapostversion ; metapostversion := 2.0 ; %D We always want \EPS\ conforming output, so we say: prologues := 1 ; warningcheck := 0 ; mpprocset := 1 ; %D Handy: def nothing = enddef ; %D Namespace handling: % let exclamationmark = ! ; % let questionmark = ? ; % % def unprotect = % let ! = relax ; % let ? = relax ; % enddef ; % % def protect = % let ! = exclamationmark ; % let ? = questionmark ; % enddef ; % % unprotect ; % % mp!some!module = 10 ; show mp!some!module ; show somemodule ; % % protect ; string space ; space := char 32 ; string percent ; percent := char 37 ; string crlf ; crlf := char 10 & char 13 ; string dquote ; dquote := char 34 ; let SPACE = space ; let CRLF = crlf ; let DQUOTE = dquote ; let PERCENT = percent ; vardef ddecimal primary p = decimal xpart p & " " & decimal ypart p enddef ; %D Plain compatibility: string plain_compatibility_data ; plain_compatibility_data := "" ; def startplaincompatibility = begingroup ; scantokens plain_compatibility_data ; enddef ; def stopplaincompatibility = endgroup ; enddef ; %D More neutral: let triplet = rgbcolor ; let quadruplet = cmykcolor ; %D Image redefined, for Alan: vardef image@#(text t) = save currentpicture ; picture currentpicture ; currentpicture := nullpicture ; t ; currentpicture if str @# <> "" : shifted ( mfun_labxf@# * lrcorner p + mfun_labyf@# * ulcorner p + (1-mfun_labxf@#-mfun_labyf@#) * llcorner p ) fi enddef ; %D Variables def dispose suffix s = if known s : begingroup ; save ss ; if numeric s : numeric ss elseif boolean s : boolean ss elseif pair s : pair ss elseif path s : path ss elseif picture s : picture ss elseif string s : string ss elseif transform s : transform ss elseif color s : color ss elseif rgbcolor s : rgbcolor ss elseif cmykcolor s : cmykcolor ss elseif pen s : pen ss else s : numeric ss fi ; s := ss ; endgroup ; fi ; enddef ; %D Colors: let grayscale = graycolor ; let greyscale = greycolor ; vardef colorpart expr c = if not picture c : 0 elseif colormodel c = greycolormodel : greypart c elseif colormodel c = rgbcolormodel : (redpart c,greenpart c,bluepart c) elseif colormodel c = cmykcolormodel : (cyanpart c,magentapart c,yellowpart c,blackpart c) else : 0 % black fi enddef ; vardef colorlike(text c) text v = % colorlike(a) b, c, d ; save _p_ ; picture _p_ ; forsuffixes i=v : _p_ := image(draw origin withcolor c ;) ; % intercept pre and postscripts if (colormodel _p_ = cmykcolormodel) : cmykcolor i ; elseif (colormodel _p_ = rgbcolormodel) : rgbcolor i ; else : greycolor i ; fi ; endfor ; enddef ; %D Also handy (when we flush colors): vardef dddecimal primary c = decimal redpart c & " " & decimal greenpart c & " " & decimal bluepart c enddef ; vardef ddddecimal primary c = decimal cyanpart c & " " & decimal magentapart c & " " & decimal yellowpart c & " " & decimal blackpart c enddef ; vardef colordecimals primary c = if cmykcolor c : decimal cyanpart c & ":" & decimal magentapart c & ":" & decimal yellowpart c & ":" & decimal blackpart c elseif rgbcolor c : decimal redpart c & ":" & decimal greenpart c & ":" & decimal bluepart c elseif string c: colordecimals resolvedcolor(c) else : decimal c fi enddef ; vardef colordecimalslist(text t) = save b ; boolean b ; b := false ; for s=t : if b : & " " & fi colordecimals(s) hide(b := true ;) endfor enddef ; % vardef _ctx_color_spec_ primary c = % if cmykcolor c : % "c=" & decimal cyanpart c & % ",m=" & decimal magentapart c & % ",y=" & decimal yellowpart c & % ",k=" & decimal blackpart c % elseif rgbcolor c : % "r=" & decimal redpart c & % ",g=" & decimal greenpart c & % ",b=" & decimal bluepart c % else : % "s=" & decimal c % fi % enddef ; % % vardef _ctx_color_spec_list_(text t) = % save b ; boolean b ; b := false ; % for s=t : % if b : & " " & fi % _ctx_color_spec_(s) % hide(b := true ;) % endfor % enddef ; %D We have standardized data file names: def job_name = jobname enddef ; %D Because \METAPOST\ has a hard coded limit of 4~datafiles, %D we need some trickery when we have multiple files. This will %D be redone (via \LUA). boolean savingdata ; savingdata := false ; boolean savingdatadone ; savingdatadone := false ; def savedata expr txt = lua.mp.mf_save_data(txt); enddef ; def startsavingdata = lua.mp.mf_start_saving_data(); enddef ; def stopsavingdata = lua.mp.mf_stop_saving_data() ; enddef ; def finishsavingdata = lua.mp.mf_finish_saving_data() ; enddef ; %D Instead of a keystroke eating save and allocation %D sequence, you can use the \citeer {new} alternatives to %D save and allocate in one command. def newcolor text v = forsuffixes i=v : save i ; color i ; endfor ; enddef ; def newnumeric text v = forsuffixes i=v : save i ; numeric i ; endfor ; enddef ; def newboolean text v = forsuffixes i=v : save i ; boolean i ; endfor ; enddef ; def newtransform text v = forsuffixes i=v : save i ; transform i ; endfor ; enddef ; def newpath text v = forsuffixes i=v : save i ; path i ; endfor ; enddef ; def newpicture text v = forsuffixes i=v : save i ; picture i ; endfor ; enddef ; def newstring text v = forsuffixes i=v : save i ; string i ; endfor ; enddef ; def newpair text v = forsuffixes i=v : save i ; pair i ; endfor ; enddef ; %D Sometimes we don't want parts of the graphics add to the %D bounding box. One way of doing this is to save the bounding %D box, draw the graphics that may not count, and restore the %D bounding box. %D %D \starttyping %D push_boundingbox currentpicture; %D pop_boundingbox currentpicture; %D \stoptyping %D %D The bounding box can be called with: %D %D \starttyping %D boundingbox currentpicture %D inner_boundingbox currentpicture %D outer_boundingbox currentpicture %D \stoptyping %D %D Especially the latter one can be of use when we include %D the graphic in a document that is clipped to the bounding %D box. In such occasions one can use: %D %D \starttyping %D set_outer_boundingbox currentpicture; %D \stoptyping %D %D Its counterpart is: %D %D \starttyping %D set_inner_boundingbox p %D \stoptyping path mfun_boundingbox_stack[] ; numeric mfun_boundingbox_stack_depth ; mfun_boundingbox_stack_depth := 0 ; def pushboundingbox text p = mfun_boundingbox_stack_depth := mfun_boundingbox_stack_depth + 1 ; mfun_boundingbox_stack[mfun_boundingbox_stack_depth] := boundingbox p ; enddef ; def popboundingbox text p = setbounds p to mfun_boundingbox_stack[mfun_boundingbox_stack_depth] ; mfun_boundingbox_stack[mfun_boundingbox_stack_depth] := origin -- cycle ; mfun_boundingbox_stack_depth := mfun_boundingbox_stack_depth - 1 ; enddef ; let push_boundingbox = pushboundingbox ; % downward compatible let pop_boundingbox = popboundingbox ; % downward compatible vardef boundingbox primary p = if (path p) or (picture p) : llcorner p -- lrcorner p -- urcorner p -- ulcorner p else : origin fi -- cycle enddef; vardef innerboundingbox primary p = top rt llcorner p -- top lft lrcorner p -- bot lft urcorner p -- bot rt ulcorner p -- cycle enddef; vardef outerboundingbox primary p = bot lft llcorner p -- bot rt lrcorner p -- top rt urcorner p -- top lft ulcorner p -- cycle enddef; def inner_boundingbox = innerboundingbox enddef ; def outer_boundingbox = outerboundingbox enddef ; vardef set_inner_boundingbox text q = % obsolete setbounds q to innerboundingbox q; enddef; vardef set_outer_boundingbox text q = % obsolete setbounds q to outerboundingbox q; enddef; % secondarydef a boundedto b = % will this cleanup ? % hide(picture mfun_a_b ; mfun_a_b := a ; setbounds mfun_a_b to b;) % mfun_a_b % enddef ; %D Here are some special ones, cooked up in the process of Alan's mp-node %D module: vardef boundingradius primary p = if picture p : max( abs((llcorner p) shifted -center p), abs((lrcorner p) shifted -center p), abs((urcorner p) shifted -center p), abs((ulcorner p) shifted -center p) ) elseif pen p : boundingradius image(draw makepath p ;) elseif path p : boundingradius image(draw p ;) fi enddef ; vardef boundingcircle primary p = fullcircle scaled 2boundingradius p shifted center p enddef ; vardef boundingpoint@#(expr p) = if picture p : % pen? ( mfun_labxf@# *ulcorner p + mfun_labyf@# *lrcorner p +(1-mfun_labxf@#-mfun_labyf@#)*urcorner p) elseif path p : boundingpoint@#(image(draw p ;)) %elseif pair p : % p %else : % origin fi enddef ; def mirrored primary a = a scaled -1 enddef ; primarydef a mirroredabout b = (a shifted -b) scaled -1 shifted b enddef ; %D Some missing functions can be implemented rather straightforward (thanks to %D Taco and others): % oldpi := 3.14159265358979323846 ; % from pi := 3.14159265358979323846264338327950288419716939937510 ; % 50 digits radian := 180/pi ; % 2pi*radian = 360 ; % let +++ = ++ ; vardef sqr primary x = x*x enddef ; vardef log primary x = if x=0: 0 else: mlog(x)/mlog(10) fi enddef ; vardef ln primary x = if x=0: 0 else: mlog(x)/256 fi enddef ; vardef exp primary x = (mexp 256)**x enddef ; vardef inv primary x = if x=0: 0 else: x**-1 fi enddef ; vardef pow (expr x,p) = x**p enddef ; vardef tand primary x = sind(x)/cosd(x) enddef ; vardef cotd primary x = cosd(x)/sind(x) enddef ; vardef sin primary x = sind(x*radian) enddef ; vardef cos primary x = cosd(x*radian) enddef ; vardef tan primary x = sin(x)/cos(x) enddef ; vardef cot primary x = cos(x)/sin(x) enddef ; vardef asin primary x = angle((1+-+x,x)) enddef ; vardef acos primary x = angle((x,1+-+x)) enddef ; vardef atan primary x = angle(1,x) enddef ; vardef invsin primary x = (asin(x))/radian enddef ; vardef invcos primary x = (acos(x))/radian enddef ; vardef invtan primary x = (atan(x))/radian enddef ; vardef acosh primary x = ln(x+(x+-+1)) enddef ; vardef asinh primary x = ln(x+(x++1)) enddef ; vardef sinh primary x = save xx ; xx = exp x ; (xx-1/xx)/2 enddef ; vardef cosh primary x = save xx ; xx = exp x ; (xx+1/xx)/2 enddef ; vardef tanh primary x = save xx ; xx = exp x ; (xx-1/xx)/(xx+1/xx) enddef ; %D Like mod, but useful for angles, it returns (-.5d,+.5d] and is used %D in for instance mp-chem. primarydef a zmod b = (-((b/2 - a) mod b) + b/2) enddef ; %D Sometimes this is handy: def undashed = dashed nullpicture enddef ; %D We provide two macros for drawing stripes across a shape. %D The first method (with the n suffix) uses another method, %D slower in calculation, but more efficient when drawn. The %D first macro divides the sides into n equal parts. The %D first argument specifies the way the lines are drawn, while %D the second argument identifier the way the shape is to be %D drawn. %D %D \starttyping %D stripe_path_n %D (dashed evenly withcolor blue) %D (filldraw) %D fullcircle xscaled 100 yscaled 40 shifted (50,50) withpen pencircle scaled 4; %D \stoptyping %D %D The a (or angle) alternative supports arbitrary angles and %D is therefore more versatile. %D %D \starttyping %D stripe_path_a %D (withpen pencircle scaled 2 withcolor red) %D (draw) %D fullcircle xscaled 100 yscaled 40 withcolor blue; %D \stoptyping %D %D We have two alternatives, controlled by arguments or defaults (when arguments %D are zero). %D %D The newer and nicer interface is used as follows (triggered by a question by Mari): %D %D \starttyping %D draw image (draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green) numberstriped (1,10,3) withcolor red ; %D draw image (draw fullcircle scaled 3cm shifted (3cm,0cm) withcolor green) numberstriped (2,20,3) withcolor green ; %D draw image (draw fullcircle scaled 3cm shifted (3cm,3cm) withcolor green) numberstriped (3,10,5) withcolor blue ; %D draw image (draw fullcircle scaled 3cm shifted (0cm,3cm) withcolor green) numberstriped (4,20,5) withcolor yellow ; %D %D draw image (draw fullcircle scaled 3cm shifted (6cm,0cm) withcolor green) anglestriped (1,20,2) withcolor red ; %D draw image (draw fullcircle scaled 3cm shifted (9cm,0cm) withcolor green) anglestriped (2,40,2) withcolor green ; %D draw image (draw fullcircle scaled 3cm shifted (9cm,3cm) withcolor green) anglestriped (3,60,2) withcolor blue ; %D draw image (draw fullcircle scaled 3cm shifted (6cm,3cm) withcolor green) anglestriped (4,80,2) withcolor yellow ; %D %D draw image ( %D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ; %D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ; %D ) shifted (9cm,0cm) numberstriped (1,10,3) withcolor red ; %D %D draw image ( %D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ; %D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ; %D ) shifted (12cm,0cm) numberstriped (2,10,3) withcolor red ; %D %D draw image ( %D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ; %D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ; %D ) shifted (9cm,5cm) numberstriped (3,10,3) withcolor red ; %D %D draw image ( %D draw fullcircle scaled 3cm shifted (0cm,0cm) withcolor green withpen pencircle scaled 2mm ; %D draw fullcircle scaled 2cm shifted (0cm,1cm) withcolor blue withpen pencircle scaled 3mm ; %D ) shifted (12cm,5cm) numberstriped (4,10,3) withcolor red ; %D \stoptyping stripe_n := 10; stripe_slot := 3; stripe_gap := 5; stripe_angle := 45; def mfun_tool_striped_number_action text extra = for i = 1/used_n step 1/used_n until 1 : draw point (1+i) of bounds -- point (3-i) of bounds withpen pencircle scaled penwidth extra ; endfor ; for i = 0 step 1/used_n until 1 : draw point (3+i) of bounds -- point (1-i) of bounds withpen pencircle scaled penwidth extra ; endfor ; enddef ; def mfun_tool_striped_set_options(expr option) = save isinner, swapped ; boolean isinner, swapped ; if option = 1 : isinner := false ; swapped := false ; elseif option = 2 : isinner := true ; swapped := false ; elseif option = 3 : isinner := false ; swapped := true ; elseif option = 4 : isinner := true ; swapped := true ; else : isinner := false ; swapped := false ; fi ; enddef ; vardef mfun_tool_striped_number(expr option, p, s_n, s_slot) text extra = % image ( begingroup ; save pattern, shape, bounds, penwidth, used_n, used_slot ; picture pattern, shape ; path bounds ; numeric used_s, used_slot ; mfun_tool_striped_set_options(option) ; used_slot := if s_slot = 0 : stripe_slot else : s_slot fi ; used_n := if s_n = 0 : stripe_n else : s_n fi ; shape := image(draw p) ; bounds := boundingbox shape ; penwidth := min(ypart urcorner shape - ypart llcorner shape, xpart urcorner shape - xpart llcorner shape) / (used_slot * used_n) ; pattern := image ( if isinner : mfun_tool_striped_number_action extra ; for s within shape : if stroked s or filled s : clip currentpicture to pathpart s ; fi endfor ; else : for s within shape : if stroked s or filled s : draw image ( mfun_tool_striped_number_action extra ; clip currentpicture to pathpart s ; ) ; fi ; endfor ; fi ; ) ; if swapped : addto currentpicture also shape ; addto currentpicture also pattern ; else : addto currentpicture also pattern ; addto currentpicture also shape ; fi ; endgroup ; % ) enddef ; def mfun_tool_striped_angle_action text extra = for i = minimum -.5used_gap step used_gap until maximum : draw (minimum,i) -- (maximum,i) extra ; endfor ; currentpicture := currentpicture rotated used_angle ; enddef ; vardef mfun_tool_striped_angle(expr option, p, s_angle, s_gap) text extra = % image ( begingroup ; save pattern, shape, mask, maximum, minimum, centrum, used_angle, used_gap ; picture pattern, shape, mask ; numeric maximum, minimum ; pair centrum ; numeric used_angle, used_gap ; mfun_tool_striped_set_options(option) ; used_angle := if s_angle = 0 : stripe_angle else : s_angle fi ; used_gap := if s_gap = 0 : stripe_gap else : s_gap fi ; shape := image(draw p) ; centrum := center shape ; shape := shape shifted - centrum ; mask := shape rotated used_angle ; maximum := max (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ; minimum := min (xpart llcorner mask, xpart urcorner mask, ypart llcorner mask, ypart urcorner mask) ; pattern := image ( if isinner : mfun_tool_striped_angle_action extra ; for s within shape : if stroked s or filled s : clip currentpicture to pathpart s ; fi endfor ; else : for s within shape : if stroked s or filled s : draw image ( mfun_tool_striped_angle_action extra ; clip currentpicture to pathpart s ; ) ; fi ; endfor ; fi ; ) ; if swapped : addto currentpicture also shape ; addto currentpicture also pattern ; else : addto currentpicture also pattern ; addto currentpicture also shape ; fi ; currentpicture := currentpicture shifted centrum ; endgroup ; % ) enddef; newinternal striped_normal_inner ; striped_normal_inner := 1 ; newinternal striped_reverse_inner ; striped_reverse_inner := 2 ; newinternal striped_normal_outer ; striped_normal_outer := 3 ; newinternal striped_reverse_outer ; striped_reverse_outer := 4 ; secondarydef p anglestriped s = % mfun_tool_striped_angle(redpart s,p,greenpart s,bluepart s) image(mfun_tool_striped_angle(redpart s,p,greenpart s,bluepart s)) % for 'withcolor' enddef ; secondarydef p numberstriped s = % mfun_tool_striped_number(redpart s,p,greenpart s,bluepart s) image(mfun_tool_striped_number(redpart s,p,greenpart s,bluepart s)) % for 'withcolor' enddef ; % for old times sake: def stripe_path_n (text s_spec) (text s_draw) expr s_path = do_stripe_path_n (s_spec) (s_draw) (s_path) enddef; def do_stripe_path_n (text s_spec) (text s_draw) (expr s_path) text s_text = draw image(s_draw s_path s_text) numberstriped(3,0,0) s_spec ; enddef ; def stripe_path_a (text s_spec) (text s_draw) expr s_path = do_stripe_path_a (s_spec) (s_draw) (s_path) enddef; def do_stripe_path_a (text s_spec) (text s_draw) (expr s_path) text s_text = draw image(s_draw s_path s_text) anglestriped(3,0,0) s_spec ; enddef ; %D A few normalizing macros: primarydef p xsized w = (p if (bbwidth (p)>0) and (w>0) : scaled (w/bbwidth (p)) fi) enddef ; primarydef p ysized h = (p if (bbheight(p)>0) and (h>0) : scaled (h/bbheight(p)) fi) enddef ; primarydef p xysized s = begingroup save wh, w, h ; pair wh ; numeric w, h ; wh := paired (s) ; w := bbwidth(p) ; h := bbheight(p) ; p if (w>0) and (h>0) : if xpart wh > 0 : xscaled (xpart wh/w) fi if ypart wh > 0 : yscaled (ypart wh/h) fi fi endgroup enddef ; let sized = xysized ; def xscale_currentpicture(expr w) = % obsolete currentpicture := currentpicture xsized w ; enddef; def yscale_currentpicture(expr h) = % obsolete currentpicture := currentpicture ysized h ; enddef; def xyscale_currentpicture(expr w, h) = % obsolete currentpicture := currentpicture xysized (w,h) ; enddef; def scale_currentpicture(expr w, h) = % obsolete currentpicture := currentpicture xsized w ; currentpicture := currentpicture ysized h ; enddef; %D A full circle is centered at the origin, while a unitsquare %D is located in the first quadrant. Now guess what kind of %D path fullsquare and unitcircle do return. path fullsquare, unitcircle ; fullsquare := unitsquare shifted - center unitsquare ; unitcircle := fullcircle shifted urcorner fullcircle ; %D Some more paths: path urcircle, ulcircle, llcircle, lrcircle ; urcircle := origin -- (+.5,0) & (+.5,0){up} .. (0,+.5) & (0,+.5) -- cycle ; ulcircle := origin -- (0,+.5) & (0,+.5){left} .. (-.5,0) & (-.5,0) -- cycle ; llcircle := origin -- (-.5,0) & (-.5,0){down} .. (0,-.5) & (0,-.5) -- cycle ; lrcircle := origin -- (0,-.5) & (0,-.5){right} .. (+.5,0) & (+.5,0) -- cycle ; path tcircle, bcircle, lcircle, rcircle ; tcircle = origin -- (+.5,0) & (+.5,0) {up} .. (0,+.5) .. {down} (-.5,0) -- cycle ; bcircle = origin -- (-.5,0) & (-.5,0) {down} .. (0,-.5) .. {up} (+.5,0) -- cycle ; lcircle = origin -- (0,+.5) & (0,+.5) {left} .. (-.5,0) .. {right} (0,-.5) -- cycle ; rcircle = origin -- (0,-.5) & (0,-.5) {right} .. (+.5,0) .. {left} (0,+.5) -- cycle ; path urtriangle, ultriangle, lltriangle, lrtriangle ; % watch out: it's contrary to what you expect and starts in the origin urtriangle := origin -- (+.5,0) -- (0,+.5) -- cycle ; ultriangle := origin -- (0,+.5) -- (-.5,0) -- cycle ; lltriangle := origin -- (-.5,0) -- (0,-.5) -- cycle ; lrtriangle := origin -- (0,-.5) -- (+.5,0) -- cycle ; path triangle, uptriangle, downtriangle, lefttriangle, righttriangle ; triangle := (1,0) -- (1,0) rotated 120 -- (1,0) rotated -120 -- cycle ; uptriangle := triangle rotated 90 ; downtriangle := triangle rotated -90 ; lefttriangle := triangle rotated 180 ; righttriangle := triangle ; path unitdiamond, fulldiamond ; unitdiamond := (.5,0) -- (1,.5) -- (.5,1) -- (0,.5) -- cycle ; fulldiamond := unitdiamond shifted - center unitdiamond ; %D More robust: % let normalscaled = scaled ; % let normalxscaled = xscaled ; % let normalyscaled = yscaled ; % % def scaled expr s = normalscaled (s) enddef ; % def xscaled expr s = normalxscaled (s) enddef ; % def yscaled expr s = normalyscaled (s) enddef ; %D Shorter primarydef p xyscaled q = % secundarydef does not work out well begingroup save qq ; pair qq ; qq = paired(q) ; p % if xpart qq <> 0 : xscaled (xpart qq) fi % if ypart qq <> 0 : yscaled (ypart qq) fi xscaled (xpart qq) yscaled (ypart qq) endgroup enddef ; %D Some personal code that might move to another module (todo: save). def set_grid(expr w, h, nx, ny) = boolean grid[][] ; boolean grid_full ; numeric grid_w, grid_h, grid_nx, grid_ny, grid_x, grid_y, grid_left ; grid_w := w ; grid_h := h ; grid_nx := nx ; grid_ny := ny ; grid_x := round(w/grid_nx) ; % +.5) ; grid_y := round(h/grid_ny) ; % +.5) ; grid_left := (1+grid_x)*(1+grid_y) ; grid_full := false ; for i=0 upto grid_x : for j=0 upto grid_y : grid[i][j] := false ; endfor ; endfor ; enddef ; vardef new_on_grid(expr _dx_, _dy_) = dx := _dx_ ; dy := _dy_ ; ddx := min(round(dx/grid_nx),grid_x) ; % +.5),grid_x) ; ddy := min(round(dy/grid_ny),grid_y) ; % +.5),grid_y) ; if not grid_full and not grid[ddx][ddy] : grid[ddx][ddy] := true ; grid_left := grid_left-1 ; grid_full := (grid_left=0) ; true else : false fi enddef ; %D usage: \type{innerpath peepholed outerpath}. %D %D beginfig(1); %D def fullsquare = (unitsquare shifted -center unitsquare) enddef ; %D fill (fullsquare scaled 200) withcolor red ; %D path p ; p := (fullcircle scaled 100) ; bboxmargin := 0 ; %D fill p peepholed bbox p ; %D endfig; secondarydef p peepholed q = begingroup save start ; pair start ; start := point 0 of p ; if xpart start >= xpart center p : if ypart start >= ypart center p : urcorner q -- ulcorner q -- llcorner q -- lrcorner q -- reverse p -- lrcorner q -- cycle else : lrcorner q -- urcorner q -- ulcorner q -- llcorner q -- reverse p -- llcorner q -- cycle fi else : if ypart start > ypart center p : ulcorner q -- llcorner q -- lrcorner q -- urcorner q -- reverse p -- urcorner q -- cycle else : llcorner q -- lrcorner q -- urcorner q -- ulcorner q -- reverse p -- ulcorner q -- cycle fi fi endgroup enddef ; boolean intersection_found ; secondarydef p intersection_point q = begingroup save x_, y_ ; (x_,y_) = p intersectiontimes q ; if x_< 0 : intersection_found := false ; center p % origin else : intersection_found := true ; .5[point x_ of p, point y_ of q] fi endgroup enddef ; %D New, undocumented, experimental: vardef tensecircle (expr width, height, offset) = (-width/2,-height/2) ... (0,-height/2-offset) ... (+width/2,-height/2) ... (+width/2+offset,0) ... (+width/2,+height/2) ... (0,+height/2+offset) ... (-width/2,+height/2) ... (-width/2-offset,0) ... cycle enddef ; vardef roundedsquare (expr width, height, offset) = (offset,0) -- (width-offset,0) {right} .. (width,offset) -- (width,height-offset) {up} .. (width-offset,height) -- (offset,height) {left} .. (0,height-offset) -- (0,offset) {down} .. cycle enddef ; vardef roundedsquarexy (expr width, height, dx, dy) = (dx,0) -- (width-dx,0) {right} .. (width,dy) -- (width,height-dy) {up} .. (width-dx,height) -- (dx,height) {left} .. (0,height-dy) -- (0,dy) {down} .. cycle enddef ; %D Some colors. def resolvedcolor(expr s) = .5white enddef ; let normalwithcolor = withcolor ; def withcolor expr c = normalwithcolor if string c : resolvedcolor(c) else : c fi enddef ; % I don't want a "withcolor black" in case of an empty string ... who knows % how that can interfere with outer colors. Somehow the next one doesn't % always work out ok, but why ... must be some parsing issue. Anyway, when % we cannot do that, we need to fix some chem macros instead as empty strings % now lead to black while everywhere else in context empty means: leave color % untouched. % def withcolor expr c = % if not string c : % normalwithcolor c % elseif c <> "" : % normalwithcolor resolvedcolor(c) % fi % enddef ; % So why does this work better than the above: % % def withcolor expr c = % if string c : % if c <> "" : % normalwithcolor resolvedcolor(c) % fi % else : % normalwithcolor c % fi % enddef ; vardef colortype expr c = if cmykcolor c : cmykcolor elseif rgbcolor c : rgbcolor elseif numeric c : grayscale fi enddef ; vardef whitecolor expr c = if cmykcolor c : (0,0,0,0) elseif rgbcolor c : (1,1,1) elseif numeric c : 1 elseif string c : whitecolor resolvedcolor(c) fi enddef ; vardef blackcolor expr c = if cmykcolor c : (0,0,0,1) elseif rgbcolor c : (0,0,0) elseif numeric c : 0 elseif string c : blackcolor resolvedcolor(c) fi enddef ; vardef complementary expr c = if cmykcolor c : (1,1,1,1) - c elseif rgbcolor c : (1,1,1) - c elseif pair c : (1,1) - c elseif numeric c : 1 - c elseif string c : complementary resolvedcolor(c) fi enddef ; vardef complemented expr c = save m ; if cmykcolor c : m := max(cyanpart c, magentapart c, yellowpart c, blackpart c) ; (m,m,m,m) - c elseif rgbcolor c : m := max(redpart c, greenpart c, bluepart c) ; (m,m,m) - c elseif pair c : m := max(xpart c, ypart c) ; (m,m) - c elseif numeric c : m - c elseif string c : complemented resolvedcolor(c) fi enddef ; %D Well, this is the dangerous and naive version: def drawfill text t = fill t ; draw t ; enddef; %D This two step approach saves the path first, since it can %D be a function. Attributes must not be randomized. def drawfill expr c = path _c_ ; _c_ := c ; mfun_do_drawfill enddef ; def mfun_do_drawfill text t = draw _c_ t ; fill _c_ t ; enddef; def undrawfill expr c = drawfill c withcolor background % rather useless enddef ; %D Moved from mp-char.mp vardef paired primary d = if pair d : d else : (d,d) fi enddef ; vardef tripled primary d = if color d : d else : (d,d,d) fi enddef ; % maybe secondaries: primarydef p enlarged d = ( p llmoved d -- p lrmoved d -- p urmoved d -- p ulmoved d -- cycle ) enddef ; primarydef p llenlarged d = ( p llmoved d -- lrcorner p -- urcorner p -- ulcorner p -- cycle ) enddef ; primarydef p lrenlarged d = ( llcorner p -- p lrmoved d -- urcorner p -- ulcorner p -- cycle ) enddef ; primarydef p urenlarged d = ( llcorner p -- lrcorner p -- p urmoved d -- ulcorner p -- cycle ) enddef ; primarydef p ulenlarged d = ( llcorner p -- lrcorner p -- urcorner p -- p ulmoved d -- cycle ) enddef ; primarydef p llmoved d = ( (llcorner p) shifted (-xpart paired(d),-ypart paired(d)) ) enddef ; primarydef p lrmoved d = ( (lrcorner p) shifted (+xpart paired(d),-ypart paired(d)) ) enddef ; primarydef p urmoved d = ( (urcorner p) shifted (+xpart paired(d),+ypart paired(d)) ) enddef ; primarydef p ulmoved d = ( (ulcorner p) shifted (-xpart paired(d),+ypart paired(d)) ) enddef ; primarydef p leftenlarged d = ( (llcorner p) shifted (-d,0) -- lrcorner p -- urcorner p -- (ulcorner p) shifted (-d,0) -- cycle ) enddef ; primarydef p rightenlarged d = ( llcorner p -- (lrcorner p) shifted (d,0) -- (urcorner p) shifted (d,0) -- ulcorner p -- cycle ) enddef ; primarydef p topenlarged d = ( llcorner p -- lrcorner p -- (urcorner p) shifted (0,d) -- (ulcorner p) shifted (0,d) -- cycle ) enddef ; primarydef p bottomenlarged d = ( llcorner p shifted (0,-d) -- lrcorner p shifted (0,-d) -- urcorner p -- ulcorner p -- cycle ) enddef ; %D Handy as stepper: vardef rotation(expr i, n) = if (n == 0) : 0 else : i * 360 / n fi enddef ; %D Handy for testing/debugging: primarydef p crossed d = ( if pair p : p shifted (-d, 0) -- p -- p shifted ( 0,-d) -- p -- p shifted (+d, 0) -- p -- p shifted ( 0,+d) -- p -- cycle else : center p shifted (-d, 0) -- llcorner p -- center p shifted ( 0,-d) -- lrcorner p -- center p shifted (+d, 0) -- urcorner p -- center p shifted ( 0,+d) -- ulcorner p -- cycle fi ) enddef ; %D Also handy (math ladders): vardef laddered primary p = % was expr point 0 of p for i=1 upto length(p) : -- (xpart (point i of p), ypart (point (i-1) of p)) -- (point i of p) endfor enddef ; %D Saves typing: % vardef bottomboundary primary p = (llcorner p -- lrcorner p) enddef ; % vardef rightboundary primary p = (lrcorner p -- urcorner p) enddef ; % vardef topboundary primary p = (urcorner p -- ulcorner p) enddef ; % vardef leftboundary primary p = (ulcorner p -- llcorner p) enddef ; vardef bottomboundary primary p = if pair p : p else : (llcorner p -- lrcorner p) fi enddef ; vardef rightboundary primary p = if pair p : p else : (lrcorner p -- urcorner p) fi enddef ; vardef topboundary primary p = if pair p : p else : (urcorner p -- ulcorner p) fi enddef ; vardef leftboundary primary p = if pair p : p else : (ulcorner p -- llcorner p) fi enddef ; %D Nice too: primarydef p superellipsed s = superellipse ( .5[lrcorner p,urcorner p], .5[urcorner p,ulcorner p], .5[ulcorner p,llcorner p], .5[llcorner p,lrcorner p], s ) enddef ; primarydef p squeezed s = ( (llcorner p .. .5[llcorner p,lrcorner p] shifted ( 0, ypart paired(s)) .. lrcorner p) & (lrcorner p .. .5[lrcorner p,urcorner p] shifted (-xpart paired(s), 0) .. urcorner p) & (urcorner p .. .5[urcorner p,ulcorner p] shifted ( 0,-ypart paired(s)) .. ulcorner p) & (ulcorner p .. .5[ulcorner p,llcorner p] shifted ( xpart paired(s), 0) .. llcorner p) & cycle ) enddef ; primarydef p randomshifted s = begingroup ; save ss ; pair ss ; ss := paired(s) ; p shifted (-.5xpart ss + uniformdeviate xpart ss,-.5ypart ss + uniformdeviate ypart ss) endgroup enddef ; vardef mfun_randomized_path(expr p,s) = for i=0 upto length(p)-1 : (point i of p) .. controls ((postcontrol i of p) randomshifted s) and ((precontrol (i+1) of p) randomshifted s) .. endfor if cycle p : cycle else : (point length(p) of p) fi enddef; vardef mfun_randomized_picture(expr p,s)(text rnd) = save currentpicture ; picture currentpicture ; currentpicture := nullpicture ; for i within p : addto currentpicture if stroked i : doublepath pathpart i rnd s dashed dashpart i withpen penpart i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i elseif filled i : contour pathpart i rnd s withpen penpart i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i else : also i fi ; endfor ; currentpicture enddef ; primarydef p randomizedcontrols s = ( if path p : mfun_randomized_path(p,s) elseif picture p : mfun_randomized_picture(p,s)(randomizedcontrols) else : p randomized s fi ) enddef ; primarydef p randomized s = ( if path p : for i=0 upto length(p)-1 : ((point i of p) randomshifted s) .. controls ((postcontrol i of p) randomshifted s) and ((precontrol (i+1) of p) randomshifted s) .. endfor if cycle p : cycle else : ((point length(p) of p) randomshifted s) fi elseif pair p : p randomshifted s elseif cmykcolor p : if cmykcolor s : ((uniformdeviate cyanpart s) * cyanpart p, (uniformdeviate magentapart s) * magentapart p, (uniformdeviate yellowpart s) * yellowpart p, (uniformdeviate blackpart s) * blackpart p) elseif pair s : ((xpart s + (uniformdeviate (ypart s - xpart s))) * p) else : ((uniformdeviate s) * p) fi elseif rgbcolor p : if rgbcolor s : ((uniformdeviate redpart s) * redpart p, (uniformdeviate greenpart s) * greenpart p, (uniformdeviate bluepart s) * bluepart p) elseif pair s : ((xpart s + (uniformdeviate (ypart s - xpart s))) * p) else : ((uniformdeviate s) * p) fi elseif color p : if color s : ((uniformdeviate greypart s) * greypart p) elseif pair s : ((xpart s + (uniformdeviate (ypart s - xpart s))) * p) else : ((uniformdeviate s) * p) fi elseif string p : (resolvedcolor(p)) randomized s elseif picture p : mfun_randomized_picture(p,s)(randomized) else : % p - s/2 + uniformdeviate s % would have been better but we want to be positive p + uniformdeviate s fi ) enddef ; %D Not perfect (alternative for interpath) vardef interpolated(expr s, p, q) = save m ; numeric m ; m := max(length(p),length(q)) ; if path p : for i=0 upto m-1 : s[point (i /m) along p,point (i /m) along q] .. controls s[postcontrol (i /m) along p,postcontrol (i /m) along q] and s[precontrol ((i+1)/m) along p,precontrol ((i+1)/m) along q] .. endfor if cycle p : cycle else : s[point infinity of p,point infinity of q] fi else : a[p,q] fi enddef ; %D Interesting too: % primarydef p paralleled d = ( % p shifted if d < 0 : - fi ((point abs(d) on (p rotatedaround(point 0 of p,90))) - point 0 of p) % ) enddef ; % % primarydef p paralleled d = ( % p shifted ((d*unitvector(direction 0 of p) - point 0 of p) rotated 90) % ) enddef ; % % Alan came up with an improved version and stepwise we ended up with (or % might up with a variant of): vardef perpendicular expr t of p = unitvector((direction t of p) rotated 90) enddef ; def istextext(expr p) = (picture p and ((substring(0,3) of prescriptpart p) = "tx_")) enddef ; primarydef p paralleled d = ( if path p : begingroup ; save dp ; pair dp ; for i=0 upto length p if cycle p : -1 fi : hide(dp := d * perpendicular i of p) if i > 0 : .. fi (point i of p + dp) if i < length p : .. controls (postcontrol i of p + dp) and (precontrol (i+1) of p + dp) fi endfor if cycle p : .. cycle fi endgroup elseif picture p : image( for i within p : draw (pathpart i) if not istextext(i) : % dirty trick paralleled d fi mfun_decoration_i i ; endfor ; ) elseif pair p : p fi ) enddef ; vardef punked primary p = point 0 of p for i=1 upto length(p)-1 : -- point i of p endfor if cycle p : -- cycle else : -- point length(p) of p fi enddef ; vardef curved primary p = point 0 of p for i=1 upto length(p)-1 : .. point i of p endfor if cycle p : .. cycle else : .. point length(p) of p fi enddef ; primarydef p blownup s = begingroup save _p_ ; path _p_ ; _p_ := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ; (_p_ shifted (center p - center _p_)) endgroup enddef ; %D Rather fundamental. % not yet ok vardef leftrightpath(expr p, l) = % used in s-pre-19 save q, r, t, b ; path q, r ; pair t, b ; t := (ulcorner p -- urcorner p) intersection_point p ; b := (llcorner p -- lrcorner p) intersection_point p ; r := if xpart directionpoint t of p < 0 : reverse p else : p fi ; % r is needed, else problems when reverse is fed q := r cutbefore if l: t else: b fi ; q := q if xpart point 0 of r > 0 : & r fi cutafter if l: b else: t fi ; q enddef ; vardef leftpath expr p = leftrightpath(p,true ) enddef ; vardef rightpath expr p = leftrightpath(p,false) enddef ; %D Drawoptions def saveoptions = save _op_ ; def _op_ = enddef ; enddef ; %D Tracing. (not yet in lexer) let normaldraw = draw ; let normalfill = fill ; % bugged in mplib so ... def normalfill expr c = addto currentpicture contour c _op_ enddef ; def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi _op_ enddef ; def drawlineoptions (text t) = def _lin_opt_ = t enddef ; enddef ; def drawpointoptions (text t) = def _pnt_opt_ = t enddef ; enddef ; def drawcontroloptions(text t) = def _ctr_opt_ = t enddef ; enddef ; def drawlabeloptions (text t) = def _lab_opt_ = t enddef ; enddef ; def draworiginoptions (text t) = def _ori_opt_ = t enddef ; enddef ; def drawboundoptions (text t) = def _bnd_opt_ = t enddef ; enddef ; def drawpathoptions (text t) = def _pth_opt_ = t enddef ; enddef ; numeric drawoptionsfactor ; drawoptionsfactor := pt ; def resetdrawoptions = drawlineoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ; drawpointoptions (withpen pencircle scaled 4.0 drawoptionsfactor withcolor black) ; drawcontroloptions(withpen pencircle scaled 2.5 drawoptionsfactor withcolor black) ; drawlabeloptions () ; draworiginoptions (withpen pencircle scaled 1.0 drawoptionsfactor withcolor .5white) ; drawboundoptions (dashed evenly _ori_opt_) ; drawpathoptions (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ; enddef ; resetdrawoptions ; %D Path. def drawpath expr p = normaldraw p _pth_opt_ enddef ; %D Arrow. newinternal ahvariant ; ahvariant := 0 ; newinternal ahdimple ; ahdimple := 1/5 ; newinternal ahscale ; ahscale := 3/4 ; vardef arrowhead expr p = save q, e, r ; pair e ; e = point length p of p ; path q ; q = gobble(p shifted -e cutafter makepath(pencircle scaled (2ahlength))) cuttings ; if ahvariant > 0: path r ; r = gobble(p shifted -e cutafter makepath(pencircle scaled ((1-ahdimple)*2ahlength))) cuttings ; fi (q rotated (ahangle/2) & reverse q rotated -(ahangle/2) if ahvariant = 1 : -- point 0 of r -- elseif ahvariant = 2 : ... point 0 of r ... else : -- fi cycle ) shifted e enddef ; vardef drawarrowpath expr p = save autoarrows ; boolean autoarrows ; autoarrows := true ; drawarrow p _pth_opt_ enddef ; def midarrowhead expr p = arrowhead p cutafter (point length(p cutafter point .5 along p) + ahlength on p) enddef ; vardef arrowheadonpath (expr p, s) = save autoarrows ; boolean autoarrows ; autoarrows := true ; set_ahlength(scaled ahfactor) ; % added arrowhead p if s < 1 : cutafter (point (s*arclength(p) + (ahlength/2)) on p) fi enddef ; def resetarrows = hide ( ahlength := 4 ; ahangle := 45 ; ahvariant := 0 ; ahdimple := 1/5 ; ahscale := 3/4 ; ) enddef ; %D Points. def drawpoint expr c = if string c : string _c_ ; _c_ := "(" & c & ")" ; dotlabel.urt(_c_, scantokens _c_) ; drawdot scantokens _c_ else : dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ; drawdot c fi _pnt_opt_ enddef ; %D PathPoints. def drawpoints expr c = path _c_ ; _c_ := c ; mfun_draw_points enddef ; def drawcontrolpoints expr c = path _c_ ; _c_ := c ; mfun_draw_controlpoints enddef ; def drawcontrollines expr c = path _c_ ; _c_ := c ; mfun_draw_controllines enddef ; def drawpointlabels expr c = path _c_ ; _c_ := c ; mfun_draw_pointlabels enddef ; def mfun_draw_points text t = for _i_=0 upto length(_c_) if cycle _c_ : -1 fi : normaldraw point _i_ of _c_ _pnt_opt_ t ; endfor ; enddef; def mfun_draw_controlpoints text t = for _i_=0 upto length(_c_) : normaldraw precontrol _i_ of _c_ _ctr_opt_ t ; normaldraw postcontrol _i_ of _c_ _ctr_opt_ t ; endfor ; enddef; def mfun_draw_controllines text t = for _i_=0 upto length(_c_) : normaldraw point _i_ of _c_ -- precontrol _i_ of _c_ _lin_opt_ t ; normaldraw point _i_ of _c_ -- postcontrol _i_ of _c_ _lin_opt_ t ; endfor ; enddef; boolean swappointlabels ; swappointlabels := false ; numeric pointlabelscale ; pointlabelscale := 0 ; string pointlabelfont ; pointlabelfont := "" ; def mfun_draw_pointlabels text t = for _i_=0 upto length(_c_) if cycle _c_ : -1 fi : pair _u_ ; _u_ := unitvector(direction _i_ of _c_) rotated if swappointlabels : - fi 90 ; pair _p_ ; _p_ := (point _i_ of _c_) ; begingroup ; if pointlabelscale > 0 : save defaultscale ; numeric defaultscale ; defaultscale := pointlabelscale ; fi ; if pointlabelfont <> "" : save defaultfont ; string defaultfont ; defaultfont := pointlabelfont ; fi ; _u_ := 10 * drawoptionsfactor * defaultscale * _u_ ; normaldraw thelabel ( decimal _i_, _p_ shifted if cycle _c_ and (_i_=0) : - fi _u_ ) _lab_opt_ t ; endgroup ; endfor ; enddef; %D Bounding box. def drawboundingbox expr p = normaldraw boundingbox p _bnd_opt_ enddef ; %D Origin. numeric originlength ; originlength := .5cm ; def draworigin text t = normaldraw (origin shifted (0, originlength) -- origin shifted (0,-originlength)) _ori_opt_ t ; normaldraw (origin shifted ( originlength,0) -- origin shifted (-originlength,0)) _ori_opt_ t ; enddef; %D Axis. numeric tickstep ; tickstep := 5mm ; numeric ticklength ; ticklength := 2mm ; def drawxticks expr c = path _c_ ; _c_ := c ; mfun_draw_xticks enddef ; def drawyticks expr c = path _c_ ; _c_ := c ; mfun_draw_yticks enddef ; def drawticks expr c = path _c_ ; _c_ := c ; mfun_draw_ticks enddef ; % Adding eps prevents disappearance due to rounding errors. def mfun_draw_xticks text t = for i=0 step -tickstep until xpart llcorner _c_ - eps : if (i<=xpart lrcorner _c_) : normaldraw (i,-ticklength)--(i,ticklength) _ori_opt_ t ; fi ; endfor ; for i=0 step tickstep until xpart lrcorner _c_ + eps : if (i>=xpart llcorner _c_) : normaldraw (i,-ticklength)--(i,ticklength) _ori_opt_ t ; fi ; endfor ; normaldraw (llcorner _c_ -- ulcorner _c_) shifted (-xpart llcorner _c_,0) _ori_opt_ t ; enddef ; def mfun_draw_yticks text t = for i=0 step -tickstep until ypart llcorner _c_ - eps : if (i<=ypart ulcorner _c_) : normaldraw (-ticklength,i)--(ticklength,i) _ori_opt_ t ; fi ; endfor ; for i=0 step tickstep until ypart ulcorner _c_ + eps : if (i>=ypart llcorner _c_) : normaldraw (-ticklength,i)--(ticklength,i) _ori_opt_ t ; fi ; endfor ; normaldraw (llcorner _c_ -- lrcorner _c_) shifted (0,-ypart llcorner _c_) _ori_opt_ t ; enddef ; def mfun_draw_ticks text t = drawxticks _c_ t ; drawyticks _c_ t ; enddef ; %D All of it except axis. def drawwholepath expr p = draworigin ; drawpath p ; drawcontrollines p ; drawcontrolpoints p ; drawpoints p ; drawboundingbox p ; drawpointlabels p ; enddef ; def drawpathonly expr p = drawpath p ; drawcontrollines p ; drawcontrolpoints p ; drawpoints p ; drawpointlabels p ; enddef ; %D Tracing. def visualizeddraw expr c = if picture c : normaldraw c else : path _c_ ; _c_ := c ; do_visualizeddraw fi enddef ; def visualizedfill expr c = if picture c : normalfill c else : path _c_ ; _c_ := c ; do_visualizedfill fi enddef ; def do_visualizeddraw text t = draworigin ; drawpath _c_ t ; drawcontrollines _c_ ; drawcontrolpoints _c_ ; drawpoints _c_ ; drawboundingbox _c_ ; drawpointlabels _c_ ; enddef ; def do_visualizedfill text t = if cycle _c_ : normalfill _c_ t fi ; draworigin ; drawcontrollines _c_ ; drawcontrolpoints _c_ ; drawpoints _c_ ; drawboundingbox _c_ ; drawpointlabels _c_ ; enddef ; def detaileddraw expr c = if picture c : normaldraw c else : path _c_ ; _c_ := c ; do_detaileddraw fi enddef ; def do_detaileddraw text t = drawpath _c_ t ; drawcontrollines _c_ ; drawcontrolpoints _c_ ; drawpoints _c_ ; % % for labels we need an third run (as the second will mark the numbers); i could preroll them % % but then the hash needs to handle that as well (as now we keep numbering) % drawpointlabels _c_ ; enddef ; def visualizepaths = let fill = visualizedfill ; let draw = visualizeddraw ; enddef ; def detailpaths = let draw = detaileddraw ; enddef ; def naturalizepaths = let fill = normalfill ; let draw = normaldraw ; enddef ; extra_endfig := extra_endfig & " naturalizepaths ; " ; %D Nice tracer: def drawboundary primary p = draw p dashed evenly withcolor white ; draw p dashed oddly withcolor black ; draw (- llcorner p) withpen pencircle scaled 3 withcolor white ; draw (- llcorner p) withpen pencircle scaled 1.5 withcolor black ; enddef ; %D Also handy: extra_beginfig := extra_beginfig & " truecorners := 0 ; " ; % restores extra_beginfig := extra_beginfig & " miterlimit := 10 ; " ; % restores extra_beginfig := extra_beginfig & " linejoin := rounded ; " ; % restores extra_beginfig := extra_beginfig & " linecap := rounded ; " ; % restores %D Normally, arrowheads don't scale well. So we provide a hack. boolean autoarrows ; autoarrows := false ; numeric ahfactor ; ahfactor := 2.5 ; def set_ahlength (text t) = % called to often % ahlength := (ahfactor*pen_size(_op_ t)) ; % _op_ added % problem: _op_ can contain color so a no-go, we could apply the transform % but i need to figure out the best way (fakepicture and take components). ahlength := (ahfactor*pen_size(t)) ; enddef ; vardef pen_size (text t) = save p ; picture p ; p := nullpicture ; addto p doublepath (top origin -- bot origin) t ; (ypart urcorner p - ypart lrcorner p) enddef ; %D The next two macros are adapted versions of plain %D \METAPOST\ definitions. vardef arrowpath expr p = % patch by Peter Rolf: supports squared pen and shifting (hh: maybe just use center of head as first) (p cutafter makepath(pencircle scaled (if ahvariant > 0 : (1-ahdimple)* fi 2ahlength*cosd(ahangle/2)) shifted point length p of p )) enddef; % New experimental extension: also handling pictures: % % drawarrow fullsquare scaled 2cm withcolor green ; % drawarrow fullcircle scaled 3cm withcolor green ; % drawarrow image ( % draw fullsquare scaled 4cm withcolor red ; % draw fullcircle scaled 5cm withcolor blue ; % ) ; % currentpicture := currentpicture shifted (-bbwidth(currentpicture)-1cm,0) ; % drawdblarrow fullsquare scaled 2cm withcolor green ; % drawdblarrow fullcircle scaled 3cm withcolor green ; % drawdblarrow image ( % draw fullsquare scaled 4cm withcolor red ; % draw fullcircle scaled 5cm withcolor blue ; % ) ; vardef stroked_paths(expr p) = save n ; numeric n ; n := 0 ; for i within p : if stroked i : n := n + 1 ; fi endfor ; n enddef ; def mfun_decoration_i expr i = withpen penpart i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i enddef ; % We could collapse all in one helper but in context we nowaways don't want % the added obscurity. Tokens come cheap. numeric mfun_arrow_snippets ; numeric mfun_arrow_count ; def drawarrow expr p = begingroup ; save mfun_arrow_path ; path mfun_arrow_path ; if path p : mfun_arrow_path := p ; expandafter mfun_draw_arrow_path elseif picture p : save mfun_arrow_picture ; picture mfun_arrow_picture ; mfun_arrow_picture := p ; expandafter mfun_draw_arrow_picture else : expandafter mfun_draw_arrow_nothing fi enddef ; def drawdblarrow expr p = begingroup ; save mfun_arrow_path ; path mfun_arrow_path ; if path p : mfun_arrow_path := p ; expandafter mfun_draw_arrow_path_double elseif picture p : save mfun_arrow_picture ; picture mfun_arrow_picture ; mfun_arrow_picture := p ; expandafter mfun_draw_arrow_picture_double else : expandafter mfun_draw_arrow_nothing fi enddef ; def mfun_draw_arrow_nothing text t = enddef ; % The path is shortened so that the arrow head extends it to the original % length. In case of a double arrow the path gets shortened twice. def mfun_draw_arrow_path text t = if autoarrows : set_ahlength(t) ; fi draw arrowpath mfun_arrow_path t ; fillup arrowhead mfun_arrow_path t ; endgroup ; enddef ; def mfun_draw_arrow_path_double text t = if autoarrows : set_ahlength(t) ; fi draw arrowpath (reverse arrowpath mfun_arrow_path) t ; fillup arrowhead mfun_arrow_path t ; fillup arrowhead reverse mfun_arrow_path t ; endgroup ; enddef ; % The picture variant is not treating each path but only the first and % last path. This can be somewhat counterintuitive but is needed for Alan's % macros. So here the last and in case of a double path first paths in a % picture get the shortening. def mfun_with_arrow_picture (text t) = mfun_arrow_count := 0 ; mfun_arrow_snippets := stroked_paths(mfun_arrow_picture) ; for i within mfun_arrow_picture : if istextext(i) : draw i else : mfun_arrow_count := mfun_arrow_count + 1 ; mfun_arrow_path := pathpart i ; t fi ; endfor ; enddef ; def mfun_draw_arrow_picture text t = if autoarrows : set_ahlength(t) ; fi mfun_with_arrow_picture ( if mfun_arrow_count = mfun_arrow_snippets : draw arrowpath mfun_arrow_path mfun_decoration_i i t ; fillup arrowhead mfun_arrow_path mfun_decoration_i i t ; else : draw mfun_arrow_path mfun_decoration_i i t ; fi ; ) endgroup ; enddef ; def mfun_draw_arrow_picture_double text t = if autoarrows : set_ahlength(t) ; fi mfun_with_arrow_picture ( draw if mfun_arrow_count = 1 : arrowpath reverse elseif mfun_arrow_count = mfun_arrow_snippets : arrowpath fi mfun_arrow_path mfun_decoration_i i t ; if mfun_arrow_count = 1 : fillup arrowhead reverse mfun_arrow_path mfun_decoration_i i t ; fi if mfun_arrow_count = mfun_arrow_snippets : fillup arrowhead mfun_arrow_path mfun_decoration_i i t ; fi ) endgroup ; enddef ; %D Some more arrow magic, by Alan: def drawdoublearrows expr p = begingroup ; save mfun_arrow_path ; path mfun_arrow_path ; save mfun_arrow_path_parallel ; path mfun_arrow_path_parallel ; if path p : mfun_arrow_path := p ; expandafter mfun_draw_arrow_paths elseif picture p : save mfun_arrow_picture ; picture mfun_arrow_picture ; mfun_arrow_picture := p ; expandafter mfun_draw_arrow_pictures else : expandafter mfun_draw_arrow_nothing fi enddef ; def mfun_draw_arrow_paths text t = if autoarrows : set_ahlength(t) ; fi save d ; d := ahscale*ahlength*sind(ahangle/2) ; mfun_arrow_path_parallel := mfun_arrow_path paralleled d ; draw arrowpath mfun_arrow_path_parallel t ; fillup arrowhead mfun_arrow_path_parallel t ; mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ; draw arrowpath mfun_arrow_path_parallel t ; fillup arrowhead mfun_arrow_path_parallel t ; endgroup ; enddef ; def mfun_draw_arrow_pictures text t = if autoarrows : set_ahlength(t) ; fi save d ; d := ahscale*ahlength*sind(ahangle/2) ; mfun_with_arrow_picture( if mfun_arrow_count = 1 : draw (mfun_arrow_path paralleled d) mfun_decoration_i i t ; mfun_arrow_path_parallel := (reverse mfun_arrow_path) paralleled d ; draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ; fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ; elseif mfun_arrow_count = mfun_arrow_snippets : draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ; mfun_arrow_path_parallel := mfun_arrow_path paralleled d ; draw arrowpath mfun_arrow_path_parallel mfun_decoration_i i t ; fillup arrowhead mfun_arrow_path_parallel mfun_decoration_i i t ; else : draw ( mfun_arrow_path paralleled d) mfun_decoration_i i t ; draw ((reverse mfun_arrow_path) paralleled d) mfun_decoration_i i t ; fi ) endgroup ; enddef ; %D Handy too ...... vardef pointarrow (expr pat, loc, len, off) = save l, r, s, t ; path l, r ; numeric s ; pair t ; t := if pair loc : loc else : point loc along pat fi ; s := len/2 - off ; if s<=0 : s := 0 elseif s>len : s := len fi ; r := pat cutbefore t ; r := (r cutafter point (arctime s of r) of r) ; s := len/2 + off ; if s<=0 : s := 0 elseif s>len : s := len fi ; l := reverse (pat cutafter t) ; l := (reverse (l cutafter point (arctime s of l) of l)) ; (l..r) enddef ; def rightarrow (expr pat,tim,len) = pointarrow(pat,tim,len,-len) enddef ; def leftarrow (expr pat,tim,len) = pointarrow(pat,tim,len,+len) enddef ; def centerarrow (expr pat,tim,len) = pointarrow(pat,tim,len, 0) enddef ; %D The \type {along} and \type {on} operators can be used as follows: %D %D \starttyping %D drawdot point .5 along somepath ; %D drawdot point 3cm on somepath ; %D \stoptyping %D %D The number denotes a percentage (fraction). primarydef pct along pat = % also negative (arctime (pct * (arclength pat)) of pat) of pat enddef ; primarydef len on pat = % no outer ( ) .. somehow fails (arctime if len>=0 : len else : (arclength(pat)+len) fi of pat) of pat enddef ; % this cuts of a piece from both ends tertiarydef pat cutends len = begingroup save tap ; path tap ; tap := pat cutbefore (point (xpart paired(len)) on pat) ; (tap cutafter (point -(ypart paired(len)) on tap)) endgroup enddef ; %D To be documented. path freesquare ; freesquare := ( (-1,0) -- (-1,-1) -- (0,-1) -- (+1,-1) -- (+1,0) -- (+1,+1) -- (0,+1) -- (-1,+1) -- cycle ) scaled .5 ; numeric freelabeloffset ; freelabeloffset := 3pt ; numeric freedotlabelsize ; freedotlabelsize := 3pt ; vardef thefreelabel (expr str, loc, ori) = save s, p, q, l ; picture s ; path p, q ; pair l ; interim labeloffset := freelabeloffset ; s := if string str : thelabel(str,loc) else : str shifted -center str shifted loc fi ; setbounds s to boundingbox s enlarged freelabeloffset ; p := fullcircle scaled (2*length(loc-ori)) shifted ori ; q := freesquare xyscaled (urcorner s - llcorner s) ; l := point xpart (p intersectiontimes (ori--loc shifted (loc-ori))) of q ; setbounds s to boundingbox s enlarged -freelabeloffset ; % new % draw boundingbox s shifted -l withpen pencircle scaled .5pt withcolor red ; (s shifted -l) enddef ; vardef freelabel (expr str, loc, ori) = draw thefreelabel(str,loc,ori) ; enddef ; vardef freedotlabel (expr str, loc, ori) = interim linecap := rounded ; draw loc withpen pencircle scaled freedotlabelsize ; draw thefreelabel(str,loc,ori) ; enddef ; %D \starttyping %D drawarrow anglebetween(line_a,line_b,somelabel) ; %D \stoptyping newinternal angleoffset ; angleoffset := 0pt ; newinternal anglelength ; anglelength := 20pt ; newinternal anglemethod ; anglemethod := 1 ; vardef anglebetween (expr a, b, str) = % path path string save pointa, pointb, common, middle, offset ; pair pointa, pointb, common, middle, offset ; save curve ; path curve ; save where ; numeric where ; if round point 0 of a = round point 0 of b : common := point 0 of a ; else : common := a intersectionpoint b ; fi ; pointa := point anglelength on a ; pointb := point anglelength on b ; where := turningnumber (common--pointa--pointb--cycle) ; middle := (reverse(common--pointa) rotatedaround (pointa,-where*90)) intersection_point (reverse(common--pointb) rotatedaround (pointb, where*90)) ; if not intersection_found : middle := point .5 along ((reverse(common--pointa) rotatedaround (pointa,-where*90)) -- ( (common--pointb) rotatedaround (pointb, where*90))) ; fi ; if anglemethod = 0 : curve := pointa{unitvector(middle-pointa)}.. pointb; middle := point .5 along curve ; curve := common ; elseif anglemethod = 1 : curve := pointa{unitvector(middle-pointa)}.. pointb; middle := point .5 along curve ; elseif anglemethod = 2 : middle := common rotatedaround(.5[pointa,pointb],180) ; curve := pointa--middle--pointb ; elseif anglemethod = 3 : curve := pointa--middle--pointb ; elseif anglemethod = 4 : curve := pointa..controls middle..pointb ; middle := point .5 along curve ; fi ; draw thefreelabel(str, middle, common) ; % withcolor black ; curve enddef ; % Stack picture mfun_current_picture_stack[] ; numeric mfun_current_picture_depth ; mfun_current_picture_depth := 0 ; def pushcurrentpicture = mfun_current_picture_depth := mfun_current_picture_depth + 1 ; mfun_current_picture_stack[mfun_current_picture_depth] := currentpicture ; currentpicture := nullpicture ; enddef ; def popcurrentpicture text t = % optional text if mfun_current_picture_depth > 0 : addto mfun_current_picture_stack[mfun_current_picture_depth] also currentpicture t ; currentpicture := mfun_current_picture_stack[mfun_current_picture_depth] ; mfun_current_picture_stack[mfun_current_picture_depth] := nullpicture ; mfun_current_picture_depth := mfun_current_picture_depth - 1 ; fi ; enddef ; %D colorcircle(size, red, green, blue) ; vardef colorcircle (expr size, red, green, blue) = % might move save r, g, b, c, m, y, w ; save radius ; path r, g, b, c, m, y, w ; numeric radius ; radius := 5cm ; pickup pencircle scaled (radius/25) ; transform t ; t := identity rotatedaround(origin,120) ; r := fullcircle rotated 90 scaled radius shifted (0,radius/4) rotatedaround(origin,135) ; b := r transformed t ; g := b transformed t ; c := buildcycle(subpath(1,7) of g,subpath(1,7) of b) ; y := c transformed t ; m := y transformed t ; w := buildcycle(subpath(3,5) of r, subpath(3,5) of g,subpath(3,5) of b) ; pushcurrentpicture ; fill r withcolor red ; fill g withcolor green ; fill b withcolor blue ; fill c withcolor white - red ; fill m withcolor white - green ; fill y withcolor white - blue ; fill w withcolor white ; for i = r,g,b,c,m,y : draw i withcolor .5white ; endfor ; currentpicture := currentpicture xsized size ; popcurrentpicture ; enddef ; % penpoint (i,2) of somepath -> inner / outer point vardef penpoint expr pnt of p = save n, d ; numeric n, d ; (n,d) = if pair pnt : pnt else : (pnt,1) fi ; (point n of p shifted ((penoffset direction n of p of currentpen) scaled d)) enddef ; % nice: currentpicture := inverted currentpicture ; primarydef p uncolored c = % not complete ... needs text and scripts and ... if color p : c - p else : image ( for i within p : addto currentpicture if stroked i or filled i : if filled i : contour else : doublepath fi pathpart i dashed dashpart i withpen penpart i else : also i fi withcolor c-(redpart i, greenpart i, bluepart i) ; endfor ; ) fi enddef ; vardef inverted primary p = p uncolored white enddef ; primarydef p softened c = begingroup save cc ; color cc ; cc := tripled(c) ; if color p : (redpart cc * redpart p,greenpart cc * greenpart p, bluepart cc * bluepart p) else : image ( for i within p : addto currentpicture if stroked i or filled i : if filled i : contour else : doublepath fi pathpart i dashed dashpart i withpen penpart i else : also i fi withcolor (redpart cc * redpart i, greenpart cc * greenpart i, bluepart cc * bluepart i) ; endfor ; ) fi endgroup enddef ; vardef grayed primary p = if rgbcolor p : tripled(.30redpart p+.59greenpart p+.11bluepart p) elseif cmykcolor p : tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i) elseif greycolor p : p elseif string p : grayed resolvedcolor(p) elseif picture p : image ( for i within p : addto currentpicture if stroked i or filled i : if filled i : contour else : doublepath fi pathpart i dashed dashpart i withpen penpart i else : also i fi if unknown colorpart i : % nothing elseif rgbcolor colorpart i : withcolor tripled(.30redpart i+.59greenpart i+.11bluepart i) ; elseif cmykcolor colorpart i : withcolor tripled(.30*(1-cyanpart i)+.59*(1-magentapart i)+.11*(1-yellowpart i)+blackpart i) ; else : withcolor colorpart i ; fi endfor ; ) else : p fi enddef ; let greyed = grayed ; vardef hsvtorgb(expr h,s,v) = save H, S, V, x ; H = h mod 360 ; S = if s < 0 : 0 elseif s > 1 : 1 else: s fi ; V = if v < 0 : 0 elseif v > 1 : 1 else: v fi ; x = 1 - abs(H mod 120 - 60)/60 ; V * ( (1-S) * (1,1,1) + S * if H < 60 : (1,x,0) elseif H < 120 : (x,1,0) elseif H < 180 : (0,1,x) elseif H < 240 : (0,x,1) elseif H < 300 : (x,0,1) else : (1,0,x) fi ) enddef ; % yes or no: "text" infont "cmr12" at 24pt ; % let normalinfont = infont ; % % numeric lastfontsize ; lastfontsize = fontsize defaultfont ; % % def infont primary name = % no vardef, no expr % hide(lastfontsize := fontsize name) % no ; % normalinfont name % enddef ; % % def scaledat expr size = % scaled (size/lastfontsize) % enddef ; % % let at = scaledat ; % like decimal def condition primary b = if b : "true" else : "false" fi enddef ; % undocumented primarydef p stretched s = begingroup save pp ; path pp ; pp := p xyscaled s ; (pp shifted ((point 0 of p) - (point 0 of pp))) endgroup enddef ; primarydef p enlonged len = begingroup if len == 0 : p elseif pair p : save q ; path q ; q := origin -- p ; save al ; al := arclength(q) ; if al > 0 : point 1 of (q stretched ((al+len)/al)) else : p fi else : save al ; al := arclength(p) ; if al > 0 : p stretched ((al+len)/al) else : p fi fi endgroup enddef ; % path p ; p := (0,0) -- (10cm,5cm) ; % drawarrow p withcolor red ; % drawarrow p shortened 1cm withcolor green ; % primarydef p shortened d = % reverse ( ( reverse (p enlonged -d) ) enlonged -d ) % enddef ; primarydef p shortened d = reverse ( ( reverse (p enlonged -xpart paired(d)) ) enlonged -ypart paired(d) ) enddef ; % yes or no, untested -) def xshifted expr dx = shifted(dx,0) enddef ; def yshifted expr dy = shifted(0,dy) enddef ; % also handy % right: str = readfrom ("abc" & ".def" ) ; % wrong: str = readfrom "abc" & ".def" ; % Every 62th read fails so we need to try again! % def readfile (expr name) = % if (readfrom (name) <> EOF) : % scantokens("input " & name & ";") ; % elseif (readfrom (name) <> EOF) : % scantokens("input " & name & ";") ; % fi ; % closefrom (name) ; % enddef ; % % this sometimes fails on the elseif, so : % def readfile (expr name) = begingroup ; save ok ; boolean ok ; if (readfrom (name) <> EOF) : ok := false ; elseif (readfrom (name) <> EOF) : ok := false ; else : ok := true ; fi ; if not ok : scantokens("input " & name & " ") ; fi ; closefrom (name) ; endgroup ; enddef ; % permits redefinition of end in macro inner end ; % this will be redone (when needed) using scripts and backend handling let mfun_remap_colors_normalwithcolor = normalwithcolor ; def remapcolors = def normalwithcolor primary c = mfun_remap_colors_normalwithcolor remappedcolor(c) enddef ; enddef ; def normalcolors = let normalwithcolor = mfun_remap_colors_normalwithcolor ; enddef ; def resetcolormap = color color_map[][][] ; normalcolors ; enddef ; resetcolormap ; def r_color primary c = redpart c enddef ; def g_color primary c = greenpart c enddef ; def b_color primary c = bluepart c enddef ; def remapcolor(expr old, new) = color_map[redpart old][greenpart old][bluepart old] := new ; enddef ; def remappedcolor(expr c) = if known color_map[redpart c][greenpart c][bluepart c] : color_map[redpart c][greenpart c][bluepart c] else : c fi enddef ; % Thanks to Jens-Uwe Morawski for pointing out that we need % to treat bounded and clipped components as local pictures. def recolor suffix p = p := repathed (0,p) enddef ; def refill suffix p = p := repathed (1,p) enddef ; def redraw suffix p = p := repathed (2,p) enddef ; def retext suffix p = p := repathed (3,p) enddef ; def untext suffix p = p := repathed (4,p) enddef ; % primarydef p recolored t = repathed(0,p) t enddef ; % primarydef p refilled t = repathed(1,p) t enddef ; % primarydef p redrawn t = repathed(2,p) t enddef ; % primarydef p retexted t = repathed(3,p) t enddef ; % primarydef p untexted t = repathed(4,p) t enddef ; color refillbackground ; refillbackground := (1,1,1) ; def restroke suffix p = p := repathed (21,p) enddef ; % keep attributes def reprocess suffix p = p := repathed (22,p) enddef ; % no attributes % also 11 and 12 vardef repathed (expr mode, p) text t = begingroup ; if mode = 0 : save normalwithcolor ; remapcolors ; fi ; save _p_, _pp_, _ppp_, _f_, _b_, _t_ ; picture _p_, _pp_, _ppp_ ; color _f_ ; path _b_ ; transform _t_ ; _b_ := boundingbox p ; _p_ := nullpicture ; for i within p : _f_ := (redpart i, greenpart i, bluepart i) ; if bounded i : _pp_ := repathed(mode,i) t ; setbounds _pp_ to pathpart i ; addto _p_ also _pp_ ; elseif clipped i : _pp_ := repathed(mode,i) t ; clip _pp_ to pathpart i ; addto _p_ also _pp_ ; elseif stroked i : if mode=21 : _ppp_ := i ; % indirectness is needed addto _p_ also image(scantokens(t & " pathpart _ppp_") dashed dashpart i withpen penpart i withcolor _f_ ; ) ; elseif mode=22 : _ppp_ := i ; % indirectness is needed addto _p_ also image(scantokens(t & " pathpart _ppp_")) ; else : addto _p_ doublepath pathpart i dashed dashpart i withpen penpart i withcolor _f_ % (redpart i, greenpart i, bluepart i) if mode = 2 : t fi ; fi ; elseif filled i : if mode=11 : _ppp_ := i ; % indirectness is needed addto _p_ also image(scantokens(t & " pathpart _ppp_") withcolor _f_ ; ) ; elseif mode=12 : _ppp_ := i ; % indirectness is needed addto _p_ also image(scantokens(t & " pathpart _ppp_")) ; else : addto _p_ contour pathpart i withcolor _f_ if (mode=1) and (_f_<>refillbackground) : t fi ; fi ; elseif textual i : % textpart i <> "" : if mode <> 4 : % transform _t_ ; % (xpart _t_, xxpart _t_, xypart _t_) = (xpart i, xxpart i, xypart i) ; % (ypart _t_, yypart _t_, yxpart _t_) = (ypart i, yypart i, yxpart i) ; % addto _p_ also % textpart i infont fontpart i % todo : other font % transformed _t_ % withpen penpart i % withcolor _f_ % if mode=3 : t fi ; addto _p_ also i if mode=3 : t fi ; fi ; else : addto _p_ also i ; fi ; endfor ; setbounds _p_ to _b_ ; _p_ endgroup enddef ; % After a question of Denis on how to erase a z variable, Jacko % suggested to assign whatever to x and y. So a clearz % variable can be defined as: % % vardef clearz@# = % x@# := whatever ; % y@# := whatever ; % enddef ; % % but Jacko suggested a redefinition of clearxy: % % def clearxy text s = % clearxy_index_:=0; % for $:=s: % clearxy_index_:=clearxy_index_+1; endfor; % if clearxy_index_=0: % save x,y; % else: % forsuffixes $:=s: x$:=whatever; y$:=whatever; endfor; % fi % enddef; % % which i decided to simplify to: def clearxy text s = if false for $ := s : or true endfor : forsuffixes $ := s : x$ := whatever ; y$ := whatever ; endfor ; else : save x, y ; fi enddef ; % so now we can say: clearxy ; as well as clearxy 1, 2, 3 ; % show x0 ; z0 = (10,10) ; % show x0 ; x0 := whatever ; y0 := whatever ; % show x0 ; z0 = (20,20) ; % show x0 ; clearxy 0 ; % show x0 ; z0 = (30,30) ; primarydef p smoothed d = (p llmoved (-xpart paired(d),0) -- p lrmoved (-xpart paired(d),0) {right} .. p lrmoved (0,-ypart paired(d)) -- p urmoved (0,-ypart paired(d)) {up} .. p urmoved (-xpart paired(d),0) -- p ulmoved (-xpart paired(d),0) {left} .. p ulmoved (0,-ypart paired(d)) -- p llmoved (0,-ypart paired(d)) {down} .. cycle) enddef ; primarydef p cornered c = ((point 0 of p) shifted (c*(unitvector(point 1 of p - point 0 of p))) -- for i=1 upto length(p) : (point i-1 of p) shifted (c*(unitvector(point i of p - point i-1 of p))) -- (point i of p) shifted (c*(unitvector(point i-1 of p - point i of p))) .. controls point i of p .. endfor cycle) enddef ; % Mikael Sundqvist came up with this one. We made it robust for points being too close % for smoothing. primarydef p smoothcornered c = ( begingroup ; save cc ; if not cycle p: (point 0 of p) -- fi for i=1 upto length(p) : hide (cc := min(c,arclength (subpath(i-1,i) of p)/2);) (point i-1 of p) shifted (cc*(unitvector(point i of p - point i-1 of p))) -- (point i of p) shifted (cc*(unitvector(point i-1 of p - point i of p))) .. controls point i of p .. endfor if cycle p : cycle else : point 1 along p fi endgroup ) enddef ; % cmyk color support % vardef cmyk(expr c,m,y,k) = % elsewhere % (1-c-k,1-m-k,1-y-k) % enddef ; % handy % vardef bbwidth (expr p) = % vardef width_of primary p = % if known p : % if path p or picture p : % xpart (lrcorner p - llcorner p) % else : % 0 % fi % else : % 0 % fi % enddef ; vardef bbwidth primary p = if unknown p : 0 elseif path p or picture p : xpart (lrcorner p - llcorner p) else : 0 fi enddef ; % vardef bbheight (expr p) = % vardef heigth_of primary p = % if known p : % if path p or picture p : % ypart (urcorner p - lrcorner p) % else : % 0 % fi % else : % 0 % fi % enddef ; vardef bbheight primary p = if unknown p : 0 elseif path p or picture p : ypart (urcorner p - lrcorner p) else : 0 fi enddef ; color nocolor ; numeric noline ; % both unknown signals def dowithpath (expr p, lw, lc, bc) = if known p : if known bc : fill p withcolor bc ; fi ; if known lw and known lc : draw p withpen pencircle scaled lw withcolor lc ; elseif known lw : draw p withpen pencircle scaled lw ; elseif known lc : draw p withcolor lc ; fi ; fi ; enddef ; % result from metafont discussion list (denisr/boguslawj) def [[ = [ [ enddef ; def [[[ = [ [ [ enddef ; def ]] = ] ] enddef ; def ]]] = ] ] ] enddef ; let == = = ; % added picture oddly ; % evenly already defined evenly := dashpattern(on 3 off 3) ; oddly := dashpattern(off 3 on 3) ; % not perfect, but useful since it removes redundant points. vardef mfun_straightened(expr sign, p) = save _p_, _q_ ; path _p_, _q_ ; _p_ := p ; forever : _q_ := mfun_do_straightened(sign, _p_) ; exitif length(_p_) = length(_q_) ; _p_ := _q_ ; endfor ; _q_ enddef ; % vardef mfun_straightened(expr sign, p) = % save lp, lq, q ; path q ; q := p ; % lp := length(p) ; % forever : % q := mfun_do_straightened(sign,q) ; % lq := length(q) ; % exitif lp = lq ; % lp := lq ; % endfor ; % q % enddef ; % can be optimized: vardef mfun_do_straightened(expr sign, p) = if length(p) > 2 : % was 1, but straight lines are ok save pp ; path pp ; pp := point 0 of p ; for i=1 upto length(p)-1 : if round(point i of p) <> round(point length(pp) of pp) : pp := pp -- point i of p ; fi ; endfor ; save n, ok ; numeric n ; boolean ok ; n := length(pp) ; ok := false ; if n > 2 : for i=0 upto n : if unitvector(round(point i of pp - point if i=0 : n else : i-1 fi of pp)) <> sign * unitvector(round(point if i=n : 0 else : i+1 fi of pp - point i of pp)) : if ok : -- else : ok := true ; fi point i of pp fi endfor if ok and (cycle p) : -- cycle fi else : pp fi else : p fi enddef ; vardef simplified expr p = ( reverse mfun_straightened(+1,mfun_straightened(+1,reverse p)) ) enddef ; vardef unspiked expr p = ( reverse mfun_straightened(-1,mfun_straightened(-1,reverse p)) ) enddef ; % path p ; % p := (2cm,1cm) -- (2cm,1cm) -- (2cm,1cm) -- (3cm,1cm) -- % (4cm,1cm) -- (4cm,2cm) -- (4cm,2.5cm) -- (4cm,3cm) -- % (3cm,3cm) -- (2cm,3cm) -- (1cm,3cm) -- (-1cm,3cm) -- % .5[(-1cm,3cm),(1cm,1cm)] -- (1cm,1cm) -- cycle ; % % p := unitcircle scaled 4cm ; % % drawpath p ; drawpoints p ; drawpointlabels p ; % p := p shifted (4cm,0) ; p := straightened p ; % drawpath p ; drawpoints p ; drawpointlabels p ; % p := p shifted (4cm,0) ; p := straightened p ; % drawpath p ; drawpoints p ; drawpointlabels p ; % new path originpath ; originpath := origin -- cycle ; vardef unitvector primary z = if abs z = abs origin : z else : z/abs z fi % hm, abs origin is just origin enddef; % also new % vardef anchored@#(expr p, z) = % maybe use the textext variant % p shifted (z + (labxf@#*lrcorner p + labyf@#*ulcorner p + (1-labxf@#-labyf@#)*llcorner p)) % enddef ; % epsed(1.2345) vardef epsed (expr e) = e if e>0 : + eps elseif e<0 : - eps fi enddef ; % handy def withgray primary g = withcolor g enddef ; % for metafun if unknown darkred : color darkred ; darkred := .625(1,0,0) fi ; if unknown darkgreen : color darkgreen ; darkgreen := .625(0,1,0) fi ; if unknown darkblue : color darkblue ; darkblue := .625(0,0,1) fi ; if unknown darkcyan : color darkcyan ; darkcyan := .625(0,1,1) fi ; if unknown darkmagenta : color darkmagenta ; darkmagenta := .625(1,0,1) fi ; if unknown darkyellow : color darkyellow ; darkyellow := .625(1,1,0) fi ; if unknown darkgray : color darkgray ; darkgray := .625(1,1,1) fi ; if unknown lightgray : color lightgray ; lightgray := .850(1,1,1) fi ; % an improved plain mp macro vardef center primary p = if pair p : p else : .5[llcorner p, urcorner p] fi enddef; % new, yet undocumented vardef rangepath (expr p, d, a) = if length p>0 : (d*unitvector(direction 0 of p) rotated a) shifted point 0 of p -- p -- (d*unitvector(direction length(p) of p) rotated a) shifted point length(p) of p else : p fi enddef ; % under construction vardef straightpath (expr a, b, method) = if (method<1) or (method>6) : (a--b) elseif method = 1 : (a -- if xpart a > xpart b : if ypart a > ypart b : (xpart b,ypart a) -- elseif ypart a < ypart b : (xpart a,ypart b) -- fi elseif xpart a < xpart b : if ypart a > ypart b : (xpart a,ypart b) -- elseif ypart a < ypart b : (xpart b,ypart a) -- fi fi b) elseif method = 3 : (a -- if xpart a > xpart b : (xpart b,ypart a) -- elseif xpart a < xpart b : (xpart a,ypart b) -- fi b) elseif method = 5 : (a -- if ypart a > ypart b : (xpart b,ypart a) -- elseif ypart a < ypart b : (xpart a,ypart b) -- fi b) else : (reverse straightpath(b,a,method-1)) fi enddef ; % handy for myself def addbackground text t = begingroup ; save p, b ; picture p ; path b ; b := boundingbox currentpicture ; p := currentpicture ; currentpicture := nullpicture ; fill b t ; setbounds currentpicture to b ; addto currentpicture also p ; endgroup ; enddef ; % makes a (line) into an infinite one (handy for calculating % intersection points vardef infinite expr p = (-infinity*unitvector(direction 0 of p) shifted point 0 of p -- p -- +infinity*unitvector(direction length(p) of p) shifted point length(p) of p) enddef ; % obscure macros: create var from string and replace - and : % (needed for process color id's) .. will go away string mfun_clean_ascii[] ; def register_dirty_chars(expr str) = for i = 0 upto length(str)-1 : mfun_clean_ascii[ASCII substring(i,i+1) of str] := "_" ; endfor ; enddef ; register_dirty_chars("+-*/:;., ") ; vardef cleanstring (expr s) = save ss ; string ss, si ; ss = "" ; save i ; for i=0 upto length(s) : si := substring(i,i+1) of s ; ss := ss & if known mfun_clean_ascii[ASCII si] : mfun_clean_ascii[ASCII si] else : si fi ; endfor ; ss enddef ; vardef asciistring (expr s) = save ss ; string ss, si ; ss = "" ; save i ; for i=0 upto length(s) : si := substring(i,i+1) of s ; if (ASCII si >= ASCII "0") and (ASCII si <= ASCII "9") : ss := ss & char(scantokens(si) + ASCII "A") ; else : ss := ss & si ; fi ; endfor ; ss enddef ; vardef setunstringed (expr s, v) = scantokens(cleanstring(s)) := v ; enddef ; vardef getunstringed (expr s) = scantokens(cleanstring(s)) enddef ; vardef unstringed (expr s) = expandafter known scantokens(cleanstring(s)) enddef ; % for david arnold: % showgrid(-5,10,1cm,-10,10,1cm); def showgrid (expr MinX, MaxX, DeltaX, MinY, MaxY, DeltaY) = % will move begingroup save size ; numeric size ; size := 2pt ; for x=MinX upto MaxX : for y=MinY upto MaxY : draw (x*DeltaX, y*DeltaY) withpen pencircle scaled if (x mod 5 = 0) and (y mod 5 = 0) : 1.5size withcolor .50white else : size withcolor .75white fi ; endfor ; endfor ; for x=MinX upto MaxX: label.bot(textext("\infofont " & decimal x), (x*DeltaX,-size)) ; endfor ; for y=MinY upto MaxY: label.lft(textext("\infofont " & decimal y), (-size,y*DeltaY)) ; endfor ; endgroup enddef; % new, handy for: % % \startuseMPgraphic{map}{n} % \includeMPgraphic{map:germany} ; % c_phantom (\MPvar{n}<1) ( % fill map_germany withcolor \MPcolor{lightgray} ; % draw map_germany withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ; % ) ; % \includeMPgraphic{map:austria} ; % c_phantom (\MPvar{n}<2) ( % fill map_austria withcolor \MPcolor{lightgray} ; % draw map_austria withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ; % ) ; % c_phantom (\MPvar{n}<3) ( % \includeMPgraphic{map:swiss} ; % fill map_swiss withcolor \MPcolor{lightgray} ; % draw map_swiss withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ; % ) ; % c_phantom (\MPvar{n}<4) ( % \includeMPgraphic{map:luxembourg} ; % fill map_luxembourg withcolor \MPcolor{lightgray} ; % draw map_luxembourg withpen pencircle scaled 1pt withcolor \MPcolor{darkgray} ; % ) ; % \stopuseMPgraphic % % \useMPgraphic{map}{n=3} vardef phantom (text t) = % to be checked picture _p_ ; _p_ := image(t) ; addto _p_ also currentpicture ; setbounds currentpicture to boundingbox _p_ ; enddef ; vardef c_phantom (expr b) (text t) = if b : picture _p_ ; _p_ := image(t) ; addto _p_ also currentpicture ; setbounds currentpicture to boundingbox _p_ ; else : t ; fi ; enddef ; %D Handy: def break = exitif true ; % fi enddef ; %D New too: primarydef p xstretched w = ( p if (bbwidth (p)>0) and (w>0) : xscaled (w/bbwidth (p)) fi ) enddef ; primarydef p ystretched h = ( p if (bbheight(p)>0) and (h>0) : yscaled (h/bbheight(p)) fi ) enddef ; %D Newer: vardef area expr p = % we could calculate the boundingbox once (xpart llcorner boundingbox p,0) -- p -- (xpart lrcorner boundingbox p,0) -- cycle enddef ; vardef basiccolors[] = if @ = 0 : white else : save n ; n := @ mod 7 ; if n = 1 : red elseif n = 2 : green elseif n = 3 : blue elseif n = 4 : cyan elseif n = 5 : magenta elseif n = 6 : yellow else : black fi fi enddef ; % vardef somecolor = (1,1,0,0) enddef ; % fill OverlayBox withcolor (rcomponent somecolor,gcomponent somecolor,bcomponent somecolor) ; % fill OverlayBox withcolor (ccomponent somecolor,mcomponent somecolor,ycomponent somecolor,bcomponent somecolor) ; % This could be standard mplib 2 behaviour: % vardef rcomponent expr p = if rgbcolor p : redpart elseif cmykcolor p : 1 - cyanpart fi p enddef ; vardef rcomponent expr p = if rgbcolor p : redpart p elseif cmykcolor p : 1 - cyanpart p else : p fi enddef ; vardef gcomponent expr p = if rgbcolor p : greenpart p elseif cmykcolor p : 1 - magentapart p else : p fi enddef ; vardef bcomponent expr p = if rgbcolor p : bluepart p elseif cmykcolor p : 1 - yellowpart p else : p fi enddef ; vardef ccomponent expr p = if cmykcolor p : cyanpart p elseif rgbcolor p : 1 - redpart p else : p fi enddef ; vardef mcomponent expr p = if cmykcolor p : magentapart p elseif rgbcolor p : 1 - greenpart p else : p fi enddef ; vardef ycomponent expr p = if cmykcolor p : yellowpart p elseif rgbcolor p : 1 - bluepart p else : p fi enddef ; vardef kcomponent expr p = if cmykcolor p : blackpart p elseif rgbcolor p : 0 else : p fi enddef ; % draw image (...) ... ; % prescripts prepended to first, postscripts appended to last % draw decorated (...) ... ; % prescripts prepended to each, postscripts appended to each % draw redecorated (...) ... ; % prescripts assigned to each, postscripts assigned to each % draw undecorated (...) ... ; % following properties are ignored, existing properties are kept % % draw decorated ( % draw fullcircle scaled 20cm withpen pencircle scaled 20mm withcolor red withtransparency (1,.40) ; % draw fullcircle scaled 15cm withpen pencircle scaled 15mm withcolor green withtransparency (1,.30) ; % draw fullcircle scaled 10cm withpen pencircle scaled 10mm withcolor blue withtransparency (1,.20) ; % ) % withcolor blue % withtransparency (1,.125) % selectively applied % withpen pencircle scaled 10mm % ; % vardef image (text imagedata) = % already defined % save currentpicture ; % picture currentpicture ; % currentpicture := nullpicture ; % imagedata ; % currentpicture % enddef ; vardef undecorated (text imagedata) text decoration = save currentpicture ; picture currentpicture ; currentpicture := nullpicture ; imagedata ; currentpicture enddef ; % if metapostversion < 1.770 : % % vardef decorated (text imagedata) text decoration = % save mfun_decorated_path, currentpicture ; % picture mfun_decorated_path, currentpicture ; % currentpicture := nullpicture ; % imagedata ; % mfun_decorated_path := currentpicture ; % currentpicture := nullpicture ; % for i within mfun_decorated_path : % addto currentpicture % if stroked i : % doublepath pathpart i % dashed dashpart i % withpen penpart i % withcolor colorpart i % decoration % elseif filled i : % contour pathpart i % withpen penpart i % withcolor colorpart i % decoration % elseif textual i : % also i % withcolor colorpart i % decoration % else : % also i % fi % ; % endfor ; % currentpicture % enddef ; % % else: vardef decorated (text imagedata) text decoration = save mfun_decorated_path, currentpicture ; picture mfun_decorated_path, currentpicture ; currentpicture := nullpicture ; imagedata ; mfun_decorated_path := currentpicture ; currentpicture := nullpicture ; for i within mfun_decorated_path : addto currentpicture if stroked i : doublepath pathpart i dashed dashpart i withpen penpart i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i decoration elseif filled i : contour pathpart i withpen penpart i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i decoration elseif textual i : also i withcolor colorpart i withprescript prescriptpart i withpostscript postscriptpart i decoration else : also i fi ; endfor ; currentpicture enddef ; % fi ; vardef redecorated (text imagedata) text decoration = save mfun_decorated_path, currentpicture ; picture mfun_decorated_path, currentpicture ; currentpicture := nullpicture ; imagedata ; mfun_decorated_path := currentpicture ; currentpicture := nullpicture ; for i within mfun_decorated_path : addto currentpicture if stroked i : doublepath pathpart i dashed dashpart i withpen penpart i decoration elseif filled i : contour pathpart i withpen penpart i decoration elseif textual i : also i decoration else : also i fi ; endfor ; currentpicture enddef ; % path mfun_bleed_box ; % primarydef p bleeded d = % image ( % mfun_bleed_box := boundingbox p ; % if pair d : % draw p xysized (bbwidth(p)+2*xpart d,bbheight(p)+2*ypart d) shifted -d ; % else : % draw p xysized (bbwidth(p)+2d,bbheight(p)+2d) shifted (-d,-d) ; % fi ; % setbounds currentpicture to mfun_bleed_box ; % ) % enddef ; vardef mfun_snapped(expr p, s) = if p < 0 : - ( - else : ( fi p div s) * s % the less tokens the better enddef ; vardef mfun_applied(expr p, s)(suffix a) = if path p : if pair s : for i=0 upto length(p)-1 : (a(xpart point i of p,xpart s),a(ypart point i of p,ypart s)) -- endfor if cycle p : cycle else : (a(xpart point length(p) of p,xpart s),a(ypart point length(p) of p,ypart s)) fi else : for i=0 upto length(p)-1 : (a(xpart point i of p,s),a(ypart point i of p,s)) -- endfor if cycle p : cycle else : (a(xpart point length(p) of p,s),a(ypart point length(p) of p,s)) fi fi elseif pair p : if pair s : (a(xpart p,xpart s),a(ypart p,ypart s)) else : (a(xpart p,s),a(ypart p,s)) fi elseif cmykcolor p : (a(cyanpart p,s),a(magentapart p,s),a(yellowpart p,s),a(blackpart p,s)) elseif rgbcolor p : (a(redpart p,s),a(greenpart p,s),a(bluepart p,s)) elseif graycolor p : a(p,s) elseif numeric p : a(p,s) else p fi enddef ; primarydef p snapped s = mfun_applied(p,s)(mfun_snapped) % so we can play with variants enddef ; %D New helpers: newinternal charscale ; charscale := 1 ; % persistent so one needs to 'reset' it to 0 or 1 def beginglyph(expr unicode, width, height, depth) = beginfig(unicode) ; % the number is irrelevant charcode := unicode ; charwd := width ; charht := height ; chardp := depth ; % charscale := 1 ; % can be set for a whole font, so no reset here enddef ; def endglyph = setbounds currentpicture to (boundingbox unitsquare xscaled charwd yscaled (charht + chardp) shifted (0,-chardp)) ; if known charscale : if (charscale > 0) and (charscale <> 1) : currentpicture := currentpicture scaled charscale ; fi ; fi ; endfig ; enddef ; def beginfont(expr name) = begingroup; passvariable("fontname",name) ; enddef ; def endfont = endgroup; enddef ; %D Dimensions have never been an issue as traditional MP can't make that large %D pictures, but with double mode we need a catch: newinternal maxdimensions ; maxdimensions := 14000 ; def mfun_apply_max_dimensions = % not a generic helper, we want to protect this one if bbwidth currentpicture > maxdimensions : currentpicture := currentpicture if bbheight currentpicture > bbwidth currentpicture : ysized else : xsized fi maxdimensions ; elseif bbheight currentpicture > maxdimensions : currentpicture := currentpicture ysized maxdimensions ; fi ; enddef; extra_endfig := extra_endfig & "mfun_apply_max_dimensions ;" ; %D Bonus shapes (need along): path unittriangle, fulltriangle ; % not really units but circle based unittriangle := point 0 along unitcircle -- point 1/3 along unitcircle -- point 2/3 along unitcircle -- cycle ; fulltriangle := point 0 along fullcircle -- point 1/3 along fullcircle -- point 2/3 along fullcircle -- cycle ; %D Kind of special and undocumented. On Wikipedia one can find examples %D of quick sort routines. Here we have a variant that permits a %D method. % vardef listsize(suffix list) = % numeric len ; len := 0 ; % forever : % exitif unknown list[len+1] ; % len := len + 1 ; % endfor ; % len % enddef ; vardef listsize(suffix list) = numeric len ; len := 1 ; forever : exitif unknown list[len] ; len := len + 1 ; endfor ; len if unknown list[0] : - 1 fi enddef ; vardef listlast(suffix list) = numeric len ; len := if known list[0] : 0 else : 1 fi ; forever : len := len + 1 ; exitif unknown list[len] ; endfor ; len - 1 enddef ; vardef mfun_quick_sort(suffix list)(expr _min_, _max_)(text what) = save l, r, m ; numeric l ; l := _min_ ; numeric r ; r := _max_ ; numeric m ; m := floor(.5[_min_,_max_]) ; _mid_ := what list[m] ; forever : exitif l >= r ; forever : exitif l > _max_ ; % exitif (what list[l]) >= (what list[m]) ; exitif (what list[l]) >= _mid_ ; l := l + 1 ; endfor ; forever : exitif r < _min_ ; % exitif (what list[m]) >= (what list[r]) ; exitif _mid_ >= (what list[r]) ; r := r - 1 ; endfor ; if l <= r : temp := list[l] ; list[l] := list[r] ; list[r] := temp ; l := l + 1 ; r := r - 1 ; fi ; endfor ; if _min_ < r : mfun_quick_sort(list)(_min_,r)(what) ; fi ; if l < _max_ : mfun_quick_sort(list)(l,_max_)(what) ; fi ; enddef ; vardef sortlist(suffix list)(text what) = save _max_ ; numeric _max_ ; save _mid_ ; numeric _mid_ ; save temp ; % _max_ := listsize(list) ; _max_ := listlast(list) ; if pair list[_max_] : pair temp ; else : numeric temp ; fi ; if pair what list[_max_] : pair _mid_ ; else : numeric _mid_ ; fi ; if _max_ > 1 : % mfun_quick_sort(list)(1,_max_)(what) ; mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,_max_)(what) ; fi ; enddef ; vardef uniquelist(suffix list) = % this one will be defined later enddef ; vardef copylist(suffix list, target) = save i ; i := 1 ; forever : exitif unknown list[i] ; target[i] := list[i] ; i := i + 1 ; endfor ; enddef ; vardef listtolines(suffix list) = list[1] for i=2 upto listsize(list) : -- list[i] endfor enddef ; vardef listtocurves(suffix list) = list[1] for i=2 upto listsize(list) : .. list[i] endfor enddef ; %D The sorter is used in: % not yet ok vardef shapedlist(suffix p) = % takes a list of paths save l ; pair l[] ; save r ; pair r[] ; save i ; i := 1 ; save n ; n := 0 ; forever : exitif unknown p[i] ; n := n + 1 ; l[n] := ulcorner p[i] ; r[n] := urcorner p[i] ; n := n + 1 ; l[n] := llcorner p[i] ; r[n] := lrcorner p[i] ; i := i + 1 ; endfor ; for i = 3 upto n : if xpart r[i] < xpart r[i-1] : r[i] := (xpart r[i],ypart r[i-1]) ; elseif xpart r[i] > xpart r[i-1] : r[i-1] := (xpart r[i-1],ypart r[i]) ; fi ; if xpart l[i] < xpart l[i-1] : l[i-1] := (xpart l[i-1],ypart l[i]) ; elseif xpart l[i] > xpart l[i-1] : l[i] := (xpart l[i],ypart l[i-1]) ; fi ; endfor ; if n > 0 : simplified ( for i = 1 upto n : r[i] -- endfor for i = n downto 1 : l[i] -- endfor cycle ) else : origin -- cycle fi enddef ; %D Dumping is fake anyway but let's keep this: let dump = relax ; %D Loading modules can be done with: def loadmodule expr name = % no vardef % input can't be used directly in a macro if (unknown scantokens("context_" & name)) and (unknown scantokens("metafun_loaded_" & name)) : save s ; string s ; % s := "mp-" & name & ".mpiv" ; % message("loading module",s) ; % s := "input " & s ; s := "input " & "mp-" & name & ".mpiv" ; expandafter scantokens expandafter s fi ; enddef ; def loadfile (expr filename) = scantokens("input " & filename) enddef ; def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ; %D Handy for backgrounds: def drawpathwithpoints expr p = do_drawpathwithpoints(p) enddef ; def do_drawpathwithpoints(expr p) text t = draw p t ; if length(p) > 2 : begingroup ; save _c_ ; path _c_ ; save _p_; picture _p_ ; _p_ := image ( _c_ := if cycle p : fullsquare else : fullcircle fi scaled 6pt ; for i=0 upto length(p) if cycle p : -1 fi : fill _c_ shifted point i of p withcolor white ; draw _c_ shifted point i of p withcolor white/2 withpen pencircle scaled .5pt ; if (i = 0) and cycle p : _c_ := fullcircle scaled 6pt ; fi ; endfor ; for i=0 upto length(p) if cycle p : -1 fi : draw textext("\infofont " & decimal i) ysized 2pt shifted point i of p ; endfor ; ) ; setbounds _p_ to boundingbox p ; draw _p_ ; fi ; enddef ; %D These new helpers are by Alan and are used in for instance the mp-node %D module. newinternal crossingdebug ; crossingdebug := 0 ; newinternal crossingscale ; crossingscale := 10 ; newinternal crossingnumbermax ; crossingnumbermax := 1000 ; % primary, secondary or tertiary? always hard to decide but primary makes sense vardef infotext@#(expr txt, ysize) = textext@#("\infofont " & if numeric txt : decimal fi txt) ysized ysize enddef ; primarydef p crossingunder q = begingroup save pic ; picture pic ; pic := nullpicture ; if picture p : for i within p : if stroked i : addto pic also image(draw pathpart i crossingunder q) ; fi endfor elseif path p : save n, t, a, b, c, r, bcuttings, hold ; numeric n, t[], hold ; path a, b, c, r, bcuttings, hold[] ; c := makepath(currentpen scaled crossingscale) ; r := if picture q : boundingbox fi q ; t[0] := n := hold := 0 ; a := p ; % The cutbefore/cutafter using c below prevents endless loops! %forever : % find all intersections for i=1 upto crossingnumbermax : % safeguard clearxy ; z = a intersectiontimes r ; if x < 0 : exitif hold < 1 ; a := hold[hold] ; hold := hold - 1 ; clearxy ; z = a intersectiontimes r ; fi (t[incr n], whatever) = p intersectiontimes point x of a ; if x = 0 : a := a cutbefore c shifted point x of a ; elseif x = length a : a := a cutafter c shifted point x of a ; else : % before or after? b := subpath (0,x) of a cutafter c shifted point x of a ; bcuttings := cuttings ; a := subpath (x,length a) of a cutbefore c shifted point x of a ; clearxy ; z = a intersectiontimes r ; if x < 0 : a := b ; cuttings := bcuttings ; else : if length bcuttings > 0 : clearxy ; z = b intersectiontimes r ; if x >= 0 : hold[incr hold] := b ; fi fi fi fi if length cuttings = 0 : % a single point: nothing cut exitif hold < 1 ; a := hold[hold] ; hold := hold - 1 ; fi if i = crossingnumbermax : message("crossingunder reached maximum " & decimal i & " intersections."); fi endfor if n = 0 : % No crossings, we return the PATH save pic ; path pic ; pic := p ; else : % n>0 sortlist(t,) ; % we add too much, maybe a test is needed t[incr n] = length p if cycle p : + t[1] fi ; % save tt[] ; numeric tt[] ; uniquelist(t,tt) ; t := tt ; % Now, n>1 ! % t[0] is the first point of the path and t[n] is the last point % (or the first intersection beyond the length if cyclic) save m ; m := 0 ; for i=if cycle p: 2 else: 1 fi upto n : % skip the first segment if cyclic % as it gets repeated (fully) at the end. if crossingdebug > 0 : if crossingdebug = 1 : addto pic doublepath c shifted point t[i] of p withpen currentpen withtransparency(1,.5) ; elseif crossingdebug = 2 : addto pic also infotext (incr m,crossingscale/5) shifted point t[i] of p ; fi fi a := subpath (t[i-1],t[i]) of p if i > 1 : cutbefore (c shifted point t[i-1] of p) fi if (i < n) or (cycle p) : cutafter (c shifted point t[i] of p) fi ; if (not picture q) or (a outsideof q) : addto pic doublepath a withpen currentpen ; fi endfor fi fi pic endgroup enddef ; primarydef p insideof q = begingroup save pth, pic, t ; path pth ; picture pic ; pic := if path q : image(draw q;) else : q fi ; pth := p -- center pic ; (t, whatever) = pth intersectiontimes boundingbox pic ; t < 0 endgroup enddef ; % primarydef p insideof q = % if (path q or picture q) : % if (path p or picture p) : % (xpart llcorner p > xpart llcorner q) and % (xpart urcorner p < xpart urcorner q) and % (ypart llcorner p > ypart llcorner q) and % (ypart urcorner p < ypart urcorner q) % elseif pair p : % (xpart p > xpart llcorner q) and % (xpart p < xpart urcorner q) and % (ypart p > ypart llcorner q) and % (ypart p < ypart urcorner q) % fi % elseif (numeric p and pair q) : % % range check % (p >= xpart q) and (p <= ypart q) % else : % maybe triplets and such % false % fi % enddef ; primarydef p outsideof q = not (p insideof q) enddef ; %D Also handy: vardef circularpath primary n = reverse (for i=0 step 2/n until 8-2/n+2eps: point i of fullcircle .. endfor cycle) rotated 90 enddef ; vardef squarepath primary n = for i=0 step 1/n until 4-1/n + 2eps: point i of fullsquare -- endfor cycle enddef ; vardef linearpath primary n = origin for i=1/n step 1/n until 1-1/n + 2eps: -- point i of (origin--(1,0)) endfor enddef ; %D A nice tracing helper: color pensilcolor ; pensilcolor := .5red ; newinternal pensilstep ; pensilstep := 1/25 ; vardef pensilled(expr p, q) = image ( draw p withcolor pensilcolor withpen q ; for i = 0 step pensilstep until length(p) + eps: draw point i of p withcolor white withtransparency (1,.5) withpen q ; endfor ; ) enddef ; %D Easy to forget but handy for manuals: vardef tolist(suffix l)(text t) = save n ; n := 1 ; for p = t : if numeric p : n := p ; dispose(l[n]) elseif pair p : l[n] := p ; n := n + 1 ; elseif path p : for i=0 step 1 until length(p) : l[n] := point i of p ; n := n + 1 ; endfor ; else : % ignore fi ; endfor ; forever : exitif unknown l[n] ; dispose(l[n]) n := n + 1 ; endfor ; enddef ; vardef topath(suffix p)(text t) = save i ; i := if known p[1] : 2 ; p[1] elseif known p[0] : 1 ; p[0] else : 0 ; origin fi forever : exitif unknown p[i] ; t p[i] hide(i := i + 1) endfor enddef ; vardef tocycle(suffix p)(text t) = topath(p,t) t cycle enddef ; % reimplemented to support paths and pictures def drawdot expr p = if pair p : addto currentpicture doublepath p withpen currentpen _op_ elseif path p : draw image ( for i=0 upto length p : addto currentpicture doublepath point i of p withpen currentpen _op_ ; endfor ; ) elseif picture p : draw image ( save pp ; path pp ; for i within p : if stroked i or filled i : pp := pathpart i ; for j=0 upto length pp : addto currentpicture doublepath point j of pp withpen currentpen _op_ ; endfor ; fi ; endfor ; ) fi enddef ; % vardef textlength(text t) = % save n ; n := 0 ; % for i = t : % n := n + 1 ; % endfor; % n % enddef; vardef mfun_timestamp = decimal year & "-" & decimal month & "-" & decimal day & " " & if ((time div 60) < 10) : "0" & fi decimal (time div 60) & ":" & if ((time-(time div 60)*60) < 10) : "0" & fi decimal (time-(time div 60)*60) enddef ; vardef totransform(expr x, y, xx, xy, yx, yy) = save t ; transform t ; xxpart t = xx ; yypart t = yy ; xypart t = xy ; yxpart t = yx ; xpart t = x ; ypart t = y ; t enddef ; vardef bymatrix(expr rx, sx, sy, ry, tx, ty) = save t ; transform t ; xxpart t = rx ; yypart t = ry ; xypart t = sx ; yxpart t = sy ; xpart t = tx ; ypart t = ty ; t enddef ; let xslanted = slanted ; def yslanted primary s = transformed begingroup save t ; transform t ; xxpart t = 1 ; yypart t = 1 ; xypart t = 0 ; yxpart t = s ; xpart t = 0 ; ypart t = 0 ; t endgroup enddef ; % By Bogluslaw Jackowski (public domain): % % draw hatched (fullcircle scaled 10cm) (45, 4, 1) withcolor "red" ; newinternal hatch_match; hatch_match := 1; vardef hatched(expr o) primary c = save a_, b_, d_, l_, i_, r_, za_, zb_, zc_, zd_; path b_; picture r_; pair za_, zb_, zc_, zd_; r_ := image ( a_ := redpart(c) mod 180 ; l_ := greenpart(c) ; d_ := -bluepart(c) ; b_ := o rotated -a_ ; b_ := if a_ >= 90 : (lrcorner b_ -- llcorner b_ -- ulcorner b_ -- urcorner b_ -- cycle) else : (llcorner b_ -- lrcorner b_ -- urcorner b_ -- ulcorner b_ -- cycle) fi rotated a_ ; za_ := point 0 of b_ ; zb_ := point 1 of b_ ; zc_ := point 2 of b_ ; zd_ := point 3 of b_ ; if hatch_match > 0 : n_ := round(length(zd_-za_) / l_) ; if n_ < 2: n_ := 2 ; fi ; l_ := length(zd_-za_) / n_ ; else : n_ := length(zd_-za_) / l_ ; fi save currentpen; pen currentpen ; pickup pencircle scaled d_; % we use a single path instead: for i_ := if hatch_match > 0 : 1 else : 0 fi upto ceiling n_ - 1 : nodraw (i_/n_)[zd_,za_] -- (i_/n_)[zc_,zb_] ; endfor dodraw origin ; ) ; clip r_ to o; r_ enddef; % By Mikael Sundqvist, with a little evolution: numeric mfun_dash_on, mfun_dash_off ; primarydef p withdashes len = hide ( save l, t, n, m, don, doff; pair t ; l := arclength p ; t := paired (len) ; m := xpart t + ypart t ; n := (l if not cycle p : - xpart t fi) div m ; (n if not cycle p : + 1 fi) * don + n * doff = l ; don*(ypart t) = doff*(xpart t) ; mfun_dash_on := don ; mfun_dash_off := doff ; ) p dashed dashpattern (on mfun_dash_on off mfun_dash_off) enddef ;