%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 metafun_loaded_tool : endinput ; fi ; newinternal boolean metafun_loaded_tool ; metafun_loaded_tool := true ; immutable metafun_loaded_tool ; let @## = @# ; let noexpand = quote ; permanent @##, noexpand ; %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 := 3.0 ; permanent metapostversion ; %D We always want \EPS\ conforming output, so we say: warningcheck := 0 ; %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 ; permanent space, percent, crlf, dquote ; % %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 ; permanent triplet, quadruplet ; %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 ; permanent image ; %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 ; permanent dispose ; %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 temp_p ; picture temp_p ; forsuffixes i=v : temp_p := image(draw origin withcolor c ;) ; % intercept pre and postscripts if (colormodel temp_p = cmykcolormodel) : cmykcolor i ; elseif (colormodel temp_p = rgbcolormodel) : rgbcolor i ; else : greycolor i ; fi ; endfor ; enddef ; permanent nocolormodel, greycolormodel, graycolormodel, rgbcolormodel, cmykcolormodel, greyscale, grayscale, colorpart, colorlike ; %D Also multiple d's: handy (when we flush colors): vardef ddecimal primary p = decimal xpart p & " " & decimal ypart p enddef ; 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 ; permanent decimal, ddecimal, dddecimal, ddddecimal, colordecimals, colordecimalslist ; % 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 Because \METAPOST\ has a hard coded limit of 4~datafiles, we need some trickery %D when we have multiple files. This will 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 sequence, you can use the \quote %D {new} alternatives to save and allocate in one command. %D Are these used? def newcolor text v = forsuffixes i=v : save i ; color i ; endfor ; enddef ; def newrgbcolor text v = forsuffixes i=v : save i ; rgbcolor i ; endfor ; enddef ; def newcmykcolor text v = forsuffixes i=v : save i ; cmykcolor 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 ; permanent newcolor, newrgbcolor, newcmykcolor, newnumeric, newboolean, newtransform, newpath, newpicture, newstring, newpair ; %D Sometimes we don't want parts of the graphics add to the bounding box. One way of %D doing this is to save the bounding box, draw the graphics that may not count, and %D restore the 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 the graphic in a document %D that is clipped to the bounding 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 boundingbox primary p = % if (path p) or (picture p) : % save a, b ; pair a, b ; a := llcorner p ; b:= urcorner p ; % a -- (xpart b, ypart a) -- b -- (xpart a, ypart b) % 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; let boundingbox = corners ; vardef innerboundingbox primary p = save b ; path b ; b := corners p ; top rt point 0 of b -- top lft point 1 of b -- bot lft point 2 of b -- bot rt point 3 of b -- cycle enddef; vardef outerboundingbox primary p = save b ; path b ; b := corners p ; bot lft point 0 of b -- bot rt point 1 of b -- top rt point 2 of b -- top lft point 3 of b -- 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 : pair c ; c := -center p; max( abs((llcorner p) shifted c), abs((lrcorner p) shifted c), abs((urcorner p) shifted c), abs((ulcorner p) shifted c) ) 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 ; permanent pushboundingbox, popboundingbox, boundingbox, innerboundingbox, outerboundingbox, boundingradius, boundingcircle, boundingpoint ; %D Whatever: def mirrored primary a = a scaled -1 enddef ; primarydef a mirroredabout b = (a shifted -b) scaled -1 shifted b enddef ; permanent mirrored, mirroredabout ; %D Some missing functions can be implemented rather straightforward (thanks to Taco %D and others): % oldpi := 3.14159265358979323846 ; % from pi := 3.14159265358979323846264338327950288419716939937510 ; % 50 digits radian := 180/pi ; % 2pi*radian = 360 ; permanent pi, radian ; % 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 ; % sin primary x = sind(x*radian) enddef ; % cos primary x = cosd(x*radian) enddef ; % tan primary x = sin(x)/cos(x) enddef ; vardef cot primary x = cos(x)/sin(x) enddef ; % asin primary x = angle((1+-+x,x)) enddef ; % acos primary x = angle((x,1+-+x)) enddef ; % atan primary x = angle(1,x) enddef ; % invsin primary x = (asin(x))/radian enddef ; % invcos primary x = (acos(x))/radian enddef ; % invtan primary x = (atan(x))/radian enddef ; % acosh primary x = ln(x+(x+-+1)) enddef ; % asinh primary x = ln(x+(x++1)) enddef ; % sinh primary x = save xx ; xx = exp x ; (xx-1/xx)/2 enddef ; % cosh primary x = save xx ; xx = exp x ; (xx+1/xx)/2 enddef ; % 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 ; permanent sqr, log, ln, exp, inv, pow, tand, cotd, cot, zmod ; %D Sometimes this is handy: def undashed = dashed nullpicture enddef ; permanent undashed ; %D We provide two macros for drawing stripes across a shape. The first method (with the %D n suffix) uses another method, slower in calculation, but more efficient when drawn. %D The first macro divides the sides into n equal parts. The first argument specifies the %D way the lines are drawn, while the second argument identifier the way the shape is to %D be 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 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 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, isdrawn ; boolean isinner, swapped, isdrawn ; if option = 0 : isdrawn := true; isinner := true ; swapped := false ; elseif option = 1 : isdrawn := false ; isinner := false ; swapped := false ; elseif option = 2 : isdrawn := false ; isinner := true ; swapped := false ; elseif option = 3 : isdrawn := false ; isinner := false ; swapped := true ; elseif option = 4 : isdrawn := false ; isinner := true ; swapped := true ; else : isdrawn := false ; isinner := false ; swapped := false ; fi ; enddef ; vardef mfun_tool_striped_number(expr option, p, asked_n, asked_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 asked_slot = 0 : stripe_slot else : asked_slot fi ; used_n := if asked_n = 0 : stripe_n else : asked_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 isdrawn : addto currentpicture also pattern ; elseif 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 ; def mfun_tool_striped_angle_action text extra = for i = minimum -.5used_gap step used_gap until maximum : nodraw (minimum,i) -- (maximum,i) extra ; endfor ; dodraw origin ; currentpicture := currentpicture rotated used_angle ; enddef ; vardef mfun_tool_striped_angle(expr option, p, asked_angle, asked_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 asked_angle = 0 : stripe_angle else : asked_angle fi ; used_gap := if asked_gap = 0 : stripe_gap else : asked_gap fi ; shape := image(draw p) ; % centrum := center shape ; centrum := llcorner 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) ; % a hack: maximum := maximum + max(xpart urcorner shape, ypart urcorner shape); minimum := minimum - max(xpart urcorner shape, ypart urcorner shape); % 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 isdrawn : addto currentpicture also pattern ; elseif 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 asked_spec) (text asked_draw) expr asked_path = do_stripe_path_n (asked_spec) (asked_draw) (asked_path) enddef; def do_stripe_path_n (text asked_spec) (text asked_draw) (expr asked_path) text asked_text = draw image(asked_draw asked_path asked_text) numberstriped(3,0,0) asked_spec ; enddef ; def stripe_path_a (text asked_spec) (text asked_draw) expr asked_path = do_stripe_path_a (asked_spec) (asked_draw) (asked_path) enddef; def do_stripe_path_a (text asked_spec) (text asked_draw) (expr asked_path) text asked_text = draw image(asked_draw asked_path asked_text) anglestriped(3,0,0) asked_spec ; enddef ; %D A more efficient variant by Mikael: % path p ; p := fullcircle scaled 3cm && (unitsquare scaled 2cm shifted (4cm,4cm)) && cycle ; % draw hatch(p,30,0.2cm) ; draw p ; vardef hatch(expr p, a, d) = save thestripe, diag, b ; picture thestripe ; numeric diag ; path b ; b := boundingbox p; diag := 0.55 * ( abs((urcorner b) - (llcorner b)) ) ; thestripe := image ( draw (-diag,0) -- (diag, 0) && for i = d step d until diag: (-diag, i) -- (diag, i) && (-diag,-i) -- (diag,-i) && endfor nocycle withpen currentpen ; ) ; thestripe := thestripe shifted center b ; thestripe := thestripe rotatedaround(center b, a) ; clip thestripe to p ; thestripe 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 xsized w = % begingroup % save b, l ; path b; % b := corners p ; % l := xpart point 1 of b - xpart point 0 of b ; % (p if (l > 0) and (w > 0) : scaled (w/l) fi) % endgroup % enddef ; primarydef p xsized w = begingroup save r, l ; pair r; r := xrange p ; l := ypart r - xpart r ; (p if (l > 0) and (w > 0) : scaled (w/l) fi) endgroup enddef ; % primarydef p ysized h = % (p if (bbheight(p) > 0) and (h > 0) : scaled (h/bbheight(p)) fi) % enddef ; % primarydef p ysized h = % begingroup % save b, l ; path b; % b := corners p ; % l := ypart point 2 of b - ypart point 1 of b ; % (p if (l > 0) and (h > 0) : scaled (h/l) fi) % endgroup % enddef ; primarydef p ysized h = begingroup save r, l ; pair r ; r := yrange p ; l := ypart r - xpart r ; (p if (l > 0) and (h > 0) : scaled (h/l) fi) endgroup enddef ; % primarydef p xysized s = % a one step transform might be faster % 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 ; primarydef p xysized s = % a one step transform might be faster begingroup save wh, w, h, b ; pair wh ; path b; b := corners p ; w := xpart point 1 of b - xpart point 0 of b ; h := ypart point 2 of b - ypart point 1 of b ; wh := paired (s) ; 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 ; % to be tested % % primarydef p xysized s = % begingroup % save wh, w, h ; pair wh ; numeric w, h ; % wh := paired (s) ; w := bbwidth(p) ; h := bbheight(p) ; % if (w > 0) and (h > 0) : % transform t ; t := identity if xpart wh > 0 : xscaled (xpart wh/w) fi if ypart wh > 0 : yscaled (ypart wh/h) % fi ; % p if (w > 0) and (h > 0) : transformed t fi % endgroup % enddef ; let sized = xysized ; permanent xsized, ysized, xysized, sized ; % primarydef p xynormalized s = % begingroup % save w, h ; numeric w, h ; % w := bbwidth(p) ; % h := bbheight(p) ; % if (w > 0) and (h > 0) : % save t, wh ; transform t ; pair wh ; % wh := paired (s) ; % t := identity % shifted - llcorner p % if xpart wh > 0 : xscaled (xpart wh/w) fi % if ypart wh > 0 : yscaled (ypart wh/h) fi % ; % p transformed t % else : % p % fi % endgroup % enddef ; primarydef p xynormalized s = begingroup save w, h, b ; path b; b := corners p ; w := xpart point 1 of b - xpart point 0 of b ; h := ypart point 2 of b - ypart point 1 of b ; if (w > 0) and (h > 0) : save t, wh ; transform t ; pair wh ; wh := paired (s) ; t := identity shifted - llcorner p if xpart wh > 0 : xscaled (xpart wh/w) fi if ypart wh > 0 : yscaled (ypart wh/h) fi ; p transformed t else : p fi endgroup enddef ; % primarydef p xnormalized s = % begingroup % save w ; numeric w ; % w := bbwidth(p) ; % if (w > 0) : % save t ; transform t ; % t := identity % shifted - llcorner p % if s > 0 : xscaled (s/w) fi % ; % p transformed t % else : % p % fi % endgroup % enddef ; primarydef p xnormalized s = begingroup save h, r ; pair r ; r := xrange p ; w := ypart r - xpart r ; if (w > 0) : save t ; transform t ; t := identity shifted - llcorner p if s > 0 : xscaled (s/w) fi ; p transformed t else : p fi endgroup enddef ; % primarydef p ynormalized s = % begingroup % save h ; numeric h ; % h := bbheight(p) ; % if (h > 0) : % save t ; transform t ; % t := identity % shifted - llcorner p % if s > 0 : yscaled (s/h) fi % ; % p transformed t % else : % p % fi % endgroup % enddef ; primarydef p ynormalized s = begingroup save h, r ; pair r ; r := yrange p ; h := ypart r - xpart r ; if (h > 0) : save t ; transform t ; t := identity shifted - llcorner p if s > 0 : yscaled (s/h) fi ; p transformed t else : p fi endgroup enddef ; permanent xnormalized, ynormalized, xynormalized ; % 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 is located in the first %D quadrant. Now guess what kind of 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 ; path unitoctagon, fulloctagon ; unitoctagon := for i within (unitcircle rotated 45/2) : pathpoint -- endfor cycle ; fulloctagon := unitoctagon shifted - center unitoctagon ; path unithexagon, fullhexagon ; %%%%hexagon := for i = 0 upto 5 : .5dir (60i) -- endfor cycle ; fullhexagon := for i = 0 step 60 until 360 : .5 dir(i) -- endfor cycle ; unithexagon := fullhexagon shifted (.5,.5) ; permanent fullsquare, unitcircle, urcircle, ulcircle, llcircle, lrcircle, tcircle, bcircle, lcircle, rcircle, urtriangle, ultriangle, lltriangle, lrtriangle, triangle, uptriangle, downtriangle, lefttriangle, righttriangle, unitdiamond, fulldiamond, unitoctagon, fulloctagon, unithexagon, fullhexagon ; %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 endgroup enddef ; permanent xyscaled ; %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 grid_dx, grid_dy) = dx := grid_dx ; dy := grid_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 \startMPcode %D fill (fullsquare scaled 200) withcolor red ; %D path p ; p := (fullcircle scaled 100) ; bboxmargin := 0 ; %D fill p peepholed bbox p ; %D \stopMPcode 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 ; newinternal boolean intersection_found ; secondarydef p intersection_point q = begingroup save temp_x, temp_y ; (temp_x,temp_y) = p intersectiontimes q ; if temp_x < 0 : intersection_found := false ; center p % origin else : intersection_found := true ; .5[point temp_x of p, point temp_y of q] fi endgroup enddef ; permanent intersection_found, intersection_point ; %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 ; permanent tensecircle, roundedsquare, roundedsquarexy ; %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 ; permanent resolvedcolor, normalwithcolor, withcolor ; % 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 ; permanent colortype, whitecolor, blackcolor, complementary, complemented ; %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 be a function. Attributes %D must not be randomized. def drawfill expr c = path temp_c ; temp_c := c ; mfun_do_drawfill enddef ; def mfun_do_drawfill text t = draw temp_c t ; fill temp_c t ; enddef; def undrawfill expr c = drawfill c withcolor background % rather useless enddef ; permanent drawfill, undrawfill ; %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 ; permanent paired, tripled ; % 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 ; permanent enlarged, llenlarged, lrenlarged, urenlarged, ulenlarged, llmoved, lrmoved, urmoved, ulmoved, leftenlarged, rightenlarged, topenlarged, bottomenlarged ; %D Handy as stepper: vardef rotation(expr i, n) = if (n == 0) : 0 else : i * 360 / n fi enddef ; permanent rotation ; %D Handy for testing/debugging; the ladders are for math: 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 ; % 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 ; vardef laddered primary p = % was expr save a; pair a ; a := point 0 of p ; a -- for i within p : if i > 0 : (xpart pathpoint, ypart a) -- pathpoint -- fi hide(a := pathpoint) endfor if cycle p : (xpart point 0 of p, ypart a) -- point 0 of p -- cycle else : nocycle fi enddef ; permanent crossed, laddered ; %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 ; permanent bottomboundary, rightboundary, topboundary, leftboundary ; %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; % % Here is a Mikael Sundqvist improved version. This time we also use % some new functionality. vardef mfun_randomized_path(expr p,s) = save r, oldr, newr, firstr, l ; pair r, oldr, newr, firstr ; r := paired(s) ; l := length(p) ; newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ; firstr := newr ; for i within p : hide ( oldr := newr ; newr := (-1/2+uniformdeviate(1),-1/2+uniformdeviate(1)) xyscaled r ; ) pathpoint .. controls (pathpostcontrol shifted oldr ) and ((deltaprecontrol 1) shifted if (i <> l - 1) : - newr else : - firstr fi) .. endfor if cycle p : cycle else : nocycle fi enddef ; vardef mfun_randomrotated_path(expr p, s) = save r, oldr, newr, firstr, l ; l := length(p) ; newr := (-1/2+uniformdeviate(1))*s ; firstr := newr ; for i within p : hide ( oldr := newr ; newr := (-1/2+uniformdeviate(1)) * s ; ) pathpoint .. controls (pathpostcontrol rotatedaround(pathpoint, oldr) ) and ((deltaprecontrol 1) rotatedaround(deltapoint 1, if (i <> l - 1) : newr else : firstr fi)) .. endfor if cycle p : cycle else : nocycle 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 randomrotatedcontrols s = ( if path p : mfun_randomrotated_path(p,s) elseif picture p : mfun_randomized_picture(p,s)(randomrotatedcontrols) 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 ; permanent superellipsed, squeezed, randomshifted, randomized, randomizedcontrols, randomrotatedcontrols ; %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 ; permanent interpolated ; %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 ; %D Alan came up with an improved version and stepwise we ended up with (or might up %D with a variant of): def istextext(expr p) = (picture p and ((substring(0,3) of prescriptpart p) = "tx_")) enddef ; vardef perpendicular expr t of p = unitvector((direction t of p) rotated 90) 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 temp_p ; path temp_p ; temp_p := p xysized (bbwidth(p)+2(xpart paired(s)),bbheight(p)+2(ypart paired(s))) ; (temp_p shifted (center p - center temp_p)) endgroup enddef ; permanent perpendicular, istextext, paralleled, punked, curved, blownup ; %D Rather fundamental. % not yet ok vardef mfun_left_right_path(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 = mfun_left_right_path(p,true ) enddef ; vardef rightpath expr p = mfun_left_right_path(p,false) enddef ; permanent leftpath, rightpath ; %D Drawoptions def saveoptions = save base_draw_options ; def base_draw_options = enddef ; enddef ; permanent saveoptions ; %D Tracing. (not yet in lexer) let normaldraw = draw ; let normalfill = fill ; % bugged in mplib so ... def normalfill expr c = addto currentpicture contour c base_draw_options enddef ; def normaldraw expr p = addto currentpicture if picture p: also p else: doublepath p withpen currentpen fi base_draw_options enddef ; def drawlineoptions (text t) = def mfun_opt_lin = t enddef ; enddef ; def drawpointoptions (text t) = def mfun_opt_pnt = t enddef ; enddef ; def drawcontroloptions(text t) = def mfun_opt_ctr = t enddef ; enddef ; def drawlabeloptions (text t) = def mfun_opt_lab = t enddef ; enddef ; def draworiginoptions (text t) = def mfun_opt_ori = t enddef ; enddef ; def drawboundoptions (text t) = def mfun_opt_bnd = t enddef ; enddef ; def drawpathoptions (text t) = def mfun_opt_pth = 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 mfun_opt_ori) ; drawpathoptions (withpen pencircle scaled 5.0 drawoptionsfactor withcolor .8white) ; enddef ; resetdrawoptions ; %D Path. def drawpath expr p = normaldraw p mfun_opt_pth enddef ; permanent drawlineoptions, drawpointoptions, drawcontroloptions, drawlabeloptions, draworiginoptions, drawboundoptions, drawpathoptions, drawpath, normaldraw ; %D Arrow. newinternal ahvariant ; ahvariant := 0 ; newinternal ahdimple ; ahdimple := 1/5 ; newinternal ahscale ; ahscale := 3/4 ; permanent ahvariant, ahdimple, ahscale ; 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 ; interim autoarrows := true ; drawarrow p mfun_opt_pth 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 ; interim 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 ; permanent arrowhead, drawarrowpath, midarrowhead, arrowheadonpath ; %D Points. vardef dotlabel@#(expr s,z) text t = label@#(s,z) t ; interim linecap := rounded ; normaldraw z withpen pencircle scaled dotlabeldiam t ; enddef ; def drawpoint expr c = if string c : string temp_c ; temp_c := "(" & c & ")" ; dotlabel.urt(temp_c, scantokens temp_c) ; drawdot scantokens temp_c else : dotlabel.urt("(" & decimal xpart c & "," & decimal ypart c & ")", c) ; drawdot c fi mfun_opt_pnt enddef ; %D PathPoints. def drawpoints expr c = path temp_c ; temp_c := c ; mfun_draw_points enddef ; def drawcontrolpoints expr c = path temp_c ; temp_c := c ; mfun_draw_controlpoints enddef ; def drawcontrollines expr c = path temp_c ; temp_c := c ; mfun_draw_controllines enddef ; def drawpointlabels expr c = path temp_c ; temp_c := c ; mfun_draw_pointlabels enddef ; def mfun_draw_points text t = % for i=0 upto length(temp_c) if cycle temp_c : -1 fi : % normaldraw point i of temp_c mfun_opt_pnt t ; % endfor ; for i within temp_c : normaldraw pathpoint mfun_opt_pnt t ; endfor ; enddef; def mfun_draw_controlpoints text t = % for i=0 upto length(temp_c) : % normaldraw precontrol i of temp_c mfun_opt_ctr t ; % normaldraw postcontrol i of temp_c mfun_opt_ctr t ; % endfor ; for i within temp_c : normaldraw pathprecontrol t mfun_opt_ctr t ; normaldraw pathpostcontrol t mfun_opt_ctr t ; endfor ; enddef; def mfun_draw_controllines text t = % for i=0 upto length(temp_c) : % normaldraw point i of temp_c -- precontrol i of temp_c mfun_opt_lin t ; % normaldraw point i of temp_c -- postcontrol i of temp_c mfun_opt_lin t ; % endfor ; for i within temp_c : normaldraw pathpoint -- pathprecontrol t mfun_opt_lin t ; normaldraw pathpoint -- pathpostcontrol t mfun_opt_lin t ; endfor ; enddef; boolean swappointlabels ; swappointlabels := false ; numeric pointlabelscale ; pointlabelscale := 0 ; string pointlabelfont ; pointlabelfont := "" ; def mfun_draw_pointlabels text asked_options = % todo: for i within temp_c : pathdirection for i=0 upto length(temp_c) if cycle temp_c : -1 fi : pair temp_u ; temp_u := unitvector(direction i of temp_c) rotated if swappointlabels : - fi 90 ; pair temp_p ; temp_p := (point i of temp_c) ; begingroup ; if pointlabelscale > 0 : save defaultscale ; numeric defaultscale ; defaultscale := pointlabelscale ; fi ; if pointlabelfont <> "" : save defaultfont ; string defaultfont ; defaultfont := pointlabelfont ; fi ; temp_u := 10 * drawoptionsfactor * defaultscale * temp_u ; normaldraw thelabel ( decimal i, temp_p shifted if cycle temp_c and (i=0) : - fi temp_u ) mfun_opt_lab asked_options ; endgroup ; endfor ; enddef; %D Bounding box. def drawboundingbox expr p = normaldraw boundingbox p mfun_opt_bnd enddef ; %D Origin. numeric originlength ; originlength := .5cm ; def draworigin text t = normaldraw (origin shifted (0, originlength) -- origin shifted (0,-originlength)) mfun_opt_ori t ; normaldraw (origin shifted ( originlength,0) -- origin shifted (-originlength,0)) mfun_opt_ori t ; enddef; permanent dotlabel, swappointlabels, pointlabelscale, pointlabelfont ; permanent drawboundingbox, drawpoints, drawcontrolpoints, drawcontrollines, drawpointlabels, draworigin ; %D Axis. numeric tickstep ; tickstep := 5mm ; numeric ticklength ; ticklength := 2mm ; def drawxticks expr c = path temp_c ; temp_c := c ; mfun_draw_xticks enddef ; def drawyticks expr c = path temp_c ; temp_c := c ; mfun_draw_yticks enddef ; def drawticks expr c = path temp_c ; temp_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 temp_c - eps : if (i<=xpart lrcorner temp_c) : normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ; fi ; endfor ; for i=0 step tickstep until xpart lrcorner temp_c + eps : if (i>=xpart llcorner temp_c) : normaldraw (i,-ticklength)--(i,ticklength) mfun_opt_ori t ; fi ; endfor ; normaldraw (llcorner temp_c -- ulcorner temp_c) shifted (-xpart llcorner temp_c,0) mfun_opt_ori t ; enddef ; def mfun_draw_yticks text t = for i=0 step -tickstep until ypart llcorner temp_c - eps : if (i<=ypart ulcorner temp_c) : normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ; fi ; endfor ; for i=0 step tickstep until ypart ulcorner temp_c + eps : if (i>=ypart llcorner temp_c) : normaldraw (-ticklength,i)--(ticklength,i) mfun_opt_ori t ; fi ; endfor ; normaldraw (llcorner temp_c -- lrcorner temp_c) shifted (0,-ypart llcorner temp_c) mfun_opt_ori t ; enddef ; def mfun_draw_ticks text t = drawxticks temp_c t ; drawyticks temp_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 temp_c ; temp_c := c ; do_visualizeddraw fi enddef ; def visualizedfill expr c = if picture c : normalfill c else : path temp_c ; temp_c := c ; do_visualizedfill fi enddef ; def do_visualizeddraw text t = draworigin ; drawpath temp_c t ; drawcontrollines temp_c ; drawcontrolpoints temp_c ; drawpoints temp_c ; drawboundingbox temp_c ; drawpointlabels temp_c ; enddef ; def do_visualizedfill text t = if cycle temp_c : normalfill temp_c t fi ; draworigin ; drawcontrollines temp_c ; drawcontrolpoints temp_c ; drawpoints temp_c ; drawboundingbox temp_c ; drawpointlabels temp_c ; enddef ; def detaileddraw expr c = if picture c : normaldraw c else : path temp_c ; temp_c := c ; do_detaileddraw fi enddef ; def do_detaileddraw text t = drawpath temp_c t ; drawcontrollines temp_c ; drawcontrolpoints temp_c ; drawpoints temp_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 temp_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 ; " ; permanent visualizeddraw, detaileddraw, visualizedfill, visualizepaths, detailpaths, 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 ; permanent drawboundary ; %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 ; % todo: newinternal boolean autoarrows ; numeric ahfactor ; ahfactor := 2.5 ; % todo: newinternal ahfactor ; newinternal boolean autoarrows ; permanent ahfactor, ahlength, autoarrows ; def set_ahlength (text t) = % called to often % ahlength := (ahfactor*pen_size(base_draw_options t)) ; % base_draw_options added % problem: base_draw_options 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; permanent arrowpath ; % 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 ; %D We could collapse all in one helper but in context we nowaways don't want the added %D 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 ; %D The path is shortened so that the arrow head extends it to the original length. In %D 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 ; %D The picture variant is not treating each path but only the first and last path. This %D can be somewhat counterintuitive but is needed for Alan's macros. So here the last %D and in case of a double path first paths in a icture 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: let drawdoublearrow = drawdblarrow ; 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 ; permanent drawarrow, drawdblarrow, drawdoublearrows, drawdoublearrow, pointarrow, rightarrow, leftarrow, centerarrow ; %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 ; permanent along, on, cutends ; %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 asked_text, asked_location, asked_origin) = save s, p, q, l ; picture s ; path p, q ; pair l ; interim labeloffset := freelabeloffset ; s := if string asked_text : thelabel(asked_text,asked_location) else : asked_text shifted -center asked_text shifted asked_location fi ; setbounds s to boundingbox s enlarged freelabeloffset ; p := fullcircle scaled (2*length(asked_location-asked_origin)) shifted asked_origin ; q := freesquare xyscaled (urcorner s - llcorner s) ; l := point xpart (p intersectiontimes (asked_origin--asked_location shifted (asked_location-asked_origin))) 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 asked_text, asked_location, asked_origin) = draw thefreelabel(asked_text,asked_location,asked_origin) ; enddef ; vardef freedotlabel (expr asked_text, asked_location, asked_origin) = interim linecap := rounded ; draw asked_location withpen pencircle scaled freedotlabelsize ; draw thefreelabel(asked_text,asked_location,asked_origin) ; enddef ; immutable freesquare ; permanent freelabeloffset, freedotlabelsize, thefreelabel, freelabel, freedotlabel ; %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, s) = % 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(s, middle, common) ; % withcolor black ; curve enddef ; permanent anglebetween, angleoffset, anglelength, anglemethod ; % 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 ; permanent pushcurrentpicture, popcurrentpicture ; % 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 ; permanent penpoint ; %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 ; % 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 ; permanent colorcircle, uncolored, inverted, grayed, greyed, hsvtorgb ; % 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 ; permanent condition ; % 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 ; permanent stretched, enlonged, shortened, xshifted, yshifted ; % 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 ; permanent readfile ; % todo: lmtx % 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 ; % still neeeded? def g_color primary c = greenpart c enddef ; % still neeeded? def b_color primary c = bluepart c enddef ; % still neeeded? 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 := mfun_repathed (0,p) enddef ; def refill suffix p = p := mfun_repathed (1,p) enddef ; def redraw suffix p = p := mfun_repathed (2,p) enddef ; def retext suffix p = p := mfun_repathed (3,p) enddef ; def untext suffix p = p := mfun_repathed (4,p) enddef ; % primarydef p recolored t = mfun_repathed(0,p) t enddef ; % primarydef p refilled t = mfun_repathed(1,p) t enddef ; % primarydef p redrawn t = mfun_repathed(2,p) t enddef ; % primarydef p retexted t = mfun_repathed(3,p) t enddef ; % primarydef p untexted t = mfun_repathed(4,p) t enddef ; color refillbackground ; refillbackground := (1,1,1) ; def restroke suffix p = p := mfun_repathed (21,p) enddef ; % keep attributes def reprocess suffix p = p := mfun_repathed (22,p) enddef ; % no attributes permanent recolor, refill, redraw, retext, untext, restroke, reprocess, refillbackground ; % also 11 and 12 vardef mfun_repathed (expr mode, p) text t = begingroup ; if mode = 0 : save normalwithcolor ; remapcolors ; fi ; save temp_p, temp_q, temp_r, temp_f, temp_b ; picture temp_p, temp_q, temp_r ; color temp_f ; path temp_b ; temp_b := boundingbox p ; temp_p := nullpicture ; for i within p : temp_f := (redpart i, greenpart i, bluepart i) ; if bounded i : temp_q := mfun_repathed(mode,i) t ; setbounds temp_q to pathpart i ; addto temp_p also temp_q ; elseif clipped i : temp_q := mfun_repathed(mode,i) t ; clip temp_q to pathpart i ; addto temp_p also temp_q ; elseif stroked i : if mode=21 : temp_r := i ; % indirectness is needed addto temp_p also image(scantokens(t & " pathpart temp_r") dashed dashpart i withpen penpart i withcolor temp_f ; ) ; elseif mode=22 : temp_r := i ; % indirectness is needed addto temp_p also image(scantokens(t & " pathpart temp_r")) ; else : addto temp_p doublepath pathpart i dashed dashpart i withpen penpart i withcolor temp_f % (redpart i, greenpart i, bluepart i) if mode = 2 : t fi ; fi ; elseif filled i : if mode=11 : temp_r := i ; % indirectness is needed addto temp_p also image(scantokens(t & " pathpart temp_r") withcolor temp_f ; ) ; elseif mode=12 : temp_r := i ; % indirectness is needed addto temp_p also image(scantokens(t & " pathpart temp_r")) ; else : addto temp_p contour pathpart i withcolor temp_f if (mode=1) and (temp_f<>refillbackground) : t fi ; fi ; else : addto temp_p also i ; fi ; endfor ; setbounds temp_p to temp_b ; temp_p endgroup enddef ; %D After a question of Denis on how to erase a z variable, Jacko suggested to assign %D 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 ; permanent clearxy ; % 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 ; permanent smoothed, cornered, smoothcornered ; % 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 bbwidth primary p = % if unknown p : % 0 % elseif path p or picture p : % save b ; path b; b := corners p ; % xpart point 0 of b - xpart point 1 of b % else : % 0 % fi % enddef ; vardef bbwidth primary p = if unknown p : 0 elseif path p or picture p : save r ; pair r ; r := xrange p ; ypart r - xpart r 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 ; % vardef bbheight primary p = % if unknown p : % 0 % elseif path p or picture p : % save b ; path b; b := corners p ; % ypart point 2 of b - ypart point 1 of b % else : % 0 % fi % enddef ; vardef bbheight primary p = if unknown p : 0 elseif path p or picture p : save r ; pair r ; r := yrange p ; ypart r - xpart r else : 0 fi enddef ; permanent bbwidth, bbheight ; 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 ; % already: def [[ = [ [ enddef ; def ]]] = ] ] ] enddef ; % already: def ]] = ] ] enddef ; let == = = ; % magic permanent [[[, ]]], ==; % 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 temp_p, temp_q ; path temp_p, temp_q ; temp_p := p ; forever : temp_q := mfun_do_straightened(sign, temp_p) ; exitif length(temp_p) = length(temp_q) ; temp_p := temp_q ; endfor ; temp_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 ; permanent simplified, unspiked ; % 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; vardef epsed (expr e) = % epsed(1.2345) e if e>0 : + eps elseif e < 0 : - eps fi enddef ; immutable originpath ; permanent unitvector, epsed ; % handy def withgray primary g = withcolor g enddef ; 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 ; permanent withgray ; % an improved plain mp macro % vardef center primary p = % if pair p : % p % else : % .5[llcorner p, urcorner p] % fi % enddef; % % permanent center ; vardef center primary p = centerof p 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 ; permanent straightpath ; % 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 ; permanent addbackground ; % 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 ; permanent infinite ; % obscure macros: create var from string and replace - and : % (needed for process color id's) .. will go away % this will become a lua helper % 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 temp_p ; temp_p := image(t) ; addto temp_p also currentpicture ; setbounds currentpicture to boundingbox temp_p ; enddef ; vardef c_phantom (expr b) (text t) = if b : save temp_p; picture temp_p ; temp_p := image(t) ; addto temp_p also currentpicture ; setbounds currentpicture to boundingbox temp_p ; else : t ; fi ; enddef ; permanent phantom ; %D Handy: def break = exitif true ; % fi enddef ; permanent break ; %D New too: % primarydef p xstretched w = ( % p if (bbwidth (p)>0) and (w>0) : xscaled (w/bbwidth (p)) fi % ) enddef ; primarydef p xstretched w = ( begingroup save l, r ; pair r; r := xrange p ; l := ypart r - xpart r ; p if (l > 0) and (w > 0) : xscaled (w/l (p)) fi endgroup ) enddef ; % primarydef p ystretched h = ( % p if (bbheight(p)>0) and (h>0) : yscaled (h/bbheight(p)) fi % ) enddef ; primarydef p ystretched h = ( begingroup save l, r ; pair r; r := yrange p ; l := ypart r - xpart r ; p if (l > 0) and (h > 0) : yscaled (h/l (p)) fi endgroup ) enddef ; permanent xstretched, ystretched ; %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 ; permanent rcomponent, gcomponent, bcomponent, ccomponent, mcomponent, ycomponent, kcomponent ; % 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 t) text decoration = save currentpicture ; picture currentpicture ; currentpicture := nullpicture ; t ; currentpicture enddef ; 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 ; 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 ; permanent decorated, undecorated, redecorated ; % 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 ; permanent snapped ; %D Take a look at mp-tool.mpiv for the old implementation if the next code. We only provide %D this for old times sake. We assume that the lmt_ commands are defined by the time this %D is used: % beginfont("demo-symbols"); % beginglyph(9754,2,4,0) ; % high voltage % interim ahlength := 1 ; % drawarrow (1,4) -- (0,2) -- (2,3) -- (1,0) withcolor darkred ; % endglyph ; % endfont; picture font_glyph[][] ; numeric font_count ; font_count := 0; def beginfont(expr n) = begingroup ; save name ; string name; name := n; font_count := font_count + 1 ; lmt_registerglyphs [ name = name, units = 10, width = 10, height = 8, depth = 2, ] ; enddef ; def endfont = endgroup; enddef ; def beginglyph(expr u, w, h, d) = save unicode ; unicode := u; lmt_registerglyph [ category = name, unicode = u, code = "draw font_glyph[" & decimal font_count & "][" & decimal u & "];" width = w, height = h, depth = d, ] ; currentpicture := nullpicture ; enddef ; def endglyph = font_glyph[font_count][unicode] := currentpicture ; enddef ; permanent beginfont, endfont, beginglyph, endglyph ; %D Dimensions have never been an issue as traditional MP can't make that large pictures, %D 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 ; immutable unittriangle, fulltriangle ; %D Kind of special and undocumented. On Wikipedia one can find examples of quick sort %D routines. Here we have a variant that permits a 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 asked_min, asked_max)(text what) = save l, r, m ; numeric l ; l := asked_min ; numeric r ; r := asked_max ; numeric m ; m := floor(.5[asked_min,asked_max]) ; asked_mid := what list[m] ; forever : exitif l >= r ; forever : exitif l > asked_max ; % exitif (what list[l]) >= (what list[m]) ; exitif (what list[l]) >= asked_mid ; l := l + 1 ; endfor ; forever : exitif r < asked_min ; % exitif (what list[m]) >= (what list[r]) ; exitif asked_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 asked_min < r : mfun_quick_sort(list)(asked_min,r)(what) ; fi ; if l < asked_max : mfun_quick_sort(list)(l,asked_max)(what) ; fi ; enddef ; vardef sortlist(suffix list)(text what) = save asked_max ; numeric asked_max ; save asked_mid ; numeric asked_mid ; save temp ; % asked_max := listsize(list) ; asked_max := listlast(list) ; if pair list[asked_max] : pair temp ; else : numeric temp ; fi ; if pair what list[asked_max] : pair asked_mid ; else : numeric asked_mid ; fi ; if asked_max > 1 : % mfun_quick_sort(list)(1,asked_max)(what) ; mfun_quick_sort(list)(if known list[0] : 0 else : 1 fi,asked_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 ; permanent listsize, listlast, sortlist, uniquelist, copylist, listtolines, listtocurves, shapedlist ; %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 := "input " & ditto & "mp-" & name & ditto & ";" ; expandafter scantokens expandafter s fi ; enddef ; def loadfile (expr filename) = scantokens("input " & filename) enddef ; def loadimage (expr filename) = image(scantokens("input " & filename);) enddef ; permanent loadmodule, loadfile, loadimage ; %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 temp_c ; path temp_c ; save temp_p; picture temp_p ; temp_p := image ( temp_c := if cycle p : fullsquare else : fullcircle fi scaled 6pt ; for i=0 upto length(p) if cycle p : -1 fi : fill temp_c shifted point i of p withcolor white ; draw temp_c shifted point i of p withcolor white/2 withpen pencircle scaled .5pt ; if (i = 0) and cycle p : temp_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 temp_p to boundingbox p ; draw temp_p ; fi ; enddef ; %D These new helpers are by Alan and are used in for instance the mp-node 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 ; permanent crossingdebug, crossingscale, crossingnumbermax, infotext, crossingunder, insideof, outsideof ; %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 ; permanent circularpath, squarepath, linearpath ; %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 ; permanent pensilled, pensilcolor, pensilstep ; %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 ; permanent tolist, topath, tocycle ; % reimplemented to support paths and pictures def drawdot expr p = if pair p : addto currentpicture doublepath p withpen currentpen base_draw_options elseif path p : draw image ( for i=0 upto length p : addto currentpicture doublepath point i of p withpen currentpen base_draw_options ; 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 base_draw_options ; endfor ; fi ; endfor ; ) fi enddef ; permanent drawdot ; % 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 ; % vardef bytopdownmatrix(expr rx, sx, sy, ry, tx, ty) = % save t ; transform t ; % xxpart t = rx ; yypart t = ry ; % xypart t = -sy ; yxpart t = -sx ; % xpart t = tx ; ypart t = ty ; % t % enddef ; vardef closedcurve primary p = p if (path p and not cycle p) or (pair p) : .. cycle fi enddef ; vardef closedlines primary p = p if (path p and not cycle p) or (pair p) : -- cycle fi enddef ; permanent totransform, bymatrix, closedcurve, closedlines ; 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 ; permanent xslanted, yslanted ; vardef processpath (expr p) (text pp) = if path p : for i=0 upto length(p)-1 : pp(point i of p) .. controls pp(postcontrol i of p) and pp(precontrol (i+1) of p) .. endfor if cycle p : cycle else : pp(point length(p) of p) fi elseif pair p : pp(p) else : p fi enddef ; permanent processpath ; % 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; permanent hatched ; % By Mikael Sundqvist, with a little evolution: numeric mfun_dash_on, mfun_dash_off ; % primarydef p withdashes len = % hide ( % save l, t, n, m ; pair t ; % l := arclength p ; % t := paired(len) ; % m := xpart t + ypart t ; % n := l / (l div m) / m ; % mfun_dash_on := n * xpart t ; % mfun_dash_off := n * ypart t ; % ) % p dashed dashpattern (on mfun_dash_on off mfun_dash_off) % enddef ; 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 ; permanent withdashes ; %D For Mikael: path mfun_b ; pair mfun_k ; path mfun_nullpath ; tertiarydef p sortedintersectiontimes q = sortedpath (p intersectiontimeslist q) enddef ; tertiarydef p intersectionpath q = begingroup ; save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ; save mfun_k ; pair mfun_k ; mfun_k := point 0 of mfun_b; if mfun_k <> (-1,-1) : .5[point xpart mfun_k of p, point ypart mfun_k of q] for i = 1 upto length(mfun_b) : hide(mfun_k := point i of mfun_b;) -- .5[point xpart mfun_k of p, point ypart mfun_k of q] endfor else : mfun_nullpath fi endgroup enddef ; tertiarydef p firstintersectionpath q = begingroup ; save mfun_b ; path mfun_b ; mfun_b := sortedpath (p intersectiontimeslist q) ; if (point 0 of mfun_b) <> (-1,-1) : point xpart (point 0 of mfun_b) of p for i = 1 upto length(mfun_b) : -- point xpart (point i of mfun_b) of p endfor else : mfun_nullpath fi endgroup enddef ; tertiarydef p secondintersectionpath q = q firstintersectionpath p enddef; vardef intersectionsfound expr p = (point 0 of p) <> (-1,-1) enddef ; %D As part of our intersection journey MS came up with: tertiarydef p cutbeforefirst q = begingroup ; save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ; if (point 0 of mfun_b) <> (-1,-1) : mfun_p := subpath(xpart point 0 of mfun_b, length p) of p; else : mfun_p := p ; fi ; mfun_p endgroup enddef ; tertiarydef p cutafterfirst q = begingroup ; save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ; if (point 0 of mfun_b) <> (-1,-1) : mfun_p := subpath(0, xpart point 0 of mfun_b) of p; else : mfun_p := p ; fi ; mfun_p endgroup enddef ; tertiarydef p cutbeforelast q = begingroup ; save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ; if (point 0 of mfun_b) <> (-1,-1) : mfun_p := subpath(xpart point (length mfun_b) of mfun_b, length p) of p; else : mfun_p := p ; fi ; mfun_p endgroup enddef ; tertiarydef p cutafterlast q = begingroup ; save mfun_b, mfun_p ; path mfun_b, mfun_p ; mfun_b := sortedpath (p intersectiontimeslist q) ; if (point 0 of mfun_b) <> (-1,-1) : mfun_p := subpath(0, xpart point (length mfun_b) of mfun_b) of p; else : mfun_p := p ; fi ; mfun_p endgroup enddef ; % I don't want to define this path every time I make a demo: vardef starring(expr e) = save a, b, c, d ; pair a, b, c, d ; a := (-1,-1) ; b := ( 1,-1) ; c := ( 1, 1) ; d := (-1, 1) ; a -- (.5[a,b] shifted (0,-e)) -- b -- (.5[b,c] shifted (e, 0)) -- c -- (.5[c,d] shifted (0, e)) -- d -- (.5[d,a] shifted (-e,0)) -- cycle enddef ; vardef dashing (expr pth, shp, stp) = for i within arcpointlist stp of pth : shp rotated angle(pathdirection) shifted pathpoint && endfor nocycle enddef ; % like center, mod and div this is a candidate for a primitive % vardef centerofmass primary p = % (origin for i within p : + pathpoint endfor) / length(p) % enddef ;