%	Macros for inclusion in Metapost
% 	dr. Hans van der Meer
message "Loading file hvdm, version 29-03-2010";
% $Revision: 6 $ $Date: 2010-05-22 18:16:47 +0200 (Sat, 22 May 2010) $
% 2008-10-16: added pencircle around label drawing with textext - luatex failed
% 2010-03-29: removed transparent color from tihis code => error in LuaTeX

%	=========================== General macros ===========================

% Access to width (x) and height (y) of current pen
vardef penX = (xpart rt origin - xpart lft origin) enddef;
vardef penY = (ypart top origin - ypart bot origin) enddef;

% Get and reset pen; note that not nestable.
newinternal savepen_;
def getpen(expr p) =
	savepen_ := savepen;
	pickup p;
enddef;
def storepen = savepen_ := savepen; enddef;
def restorepen = pickup savepen_; enddef;

% Calculate point bisecting in triangle corner b-a-c.
def bisect(expr a, b, c) =
	whatever[b,c] = a + whatever * dir(0.5(angle(b-a)+angle(c-a)))
enddef;

% Add suffix and return correct data type for use in parameter calls.
%	counter = the string containing the counter involved
%	suffx   = the string to add
vardef addcounter_suffix(expr counter, suffx) =
	save ssuffx; string ssuffx; ssuffx := counter & suffx;
	scantokens ssuffx
enddef;

%	=========================== Arrows ===========================

%	Original arrow source:
%	David Salomon
%	Arrows for Technical Drawings
%	TUGboat, Volume 13 (1992), No.2, p. 146-149

% Construct path of arrowhead, placing the tip at the origin.
vardef arrowPath (expr arrowLength, insetRatio, tipAngle, wingCurve, tailCurve) =
	save zz, insetdir; pair zz[], insetdir;
	save swdir, ewdir, stdir, etdir;
	numeric swdir, ewdir, stdir, etdir;

	% calculate anchor points
	rt zz1 = origin;
	zz2 = (-arrowLength, arrowLength * sind 0.5 tipAngle / cosd 0.5 tipAngle);
	zz3 = (-insetRatio * arrowLength, 0);
	zz4 = (xpart zz2, -ypart zz2);

	% calculate outgoing and incoming wing and tail directions.
	swdir := angle(zz2 - zz1) + wingCurve;
	ewdir := angle(zz1 - zz4) - wingCurve;
	stdir := angle(zz3 - zz2) + tailCurve;
	etdir := angle(zz4 - zz3) - tailCurve;
	insetdir := if tailCurve = 0: (0,0); else: down; fi

	% return path of the arrow contour
	zz1{dir swdir} .. zz2 &
		zz2{dir stdir} .. {insetdir}zz3 &
		zz3{insetdir} .. {dir etdir}zz4 &
		zz4 .. {dir ewdir}cycle
enddef;

% administration for arrows.
newinternal arrowcounter_;		% by default initally zero
newinternal arrowdefault_;		% by default initally zero
picture arrowheads_[];
numeric arrowlengths_[];
color arrowlinecolors_[];
string arrownames_[];
def arrowsuffix = "_a" enddef;

% Convert between name of arrow and index into array
% for the mechanism see metafont book definition of mode_def
def arrowcount_ suffix $ =
	$ := incr arrowcounter_;
	arrownames_[$] := str$;
enddef;

% Define an arrowhead.
% Parameters:
% - arrowLength  = length from base to tip (0 takes ahlength)
% - insetRatio   = relative position of inset 1..0
% - tipAngle     = opening angle at tip (0 takes ahangle)
% - wingCurve    = curvature of flanks (+ inwards, - outwards)
% - tailCurve    = curvature of flanks (+ inwards, - outwards)
% - outline      = outlining true/false
% If an outline is drawn it has the linecolor and the interior the fillcolor.
% If an outline is not drawn the whole arrow has the linecolor.
% - name         = name of the arrowhead macro, must be "string"
vardef defineArrow (expr arrowLength, insetRatio, tipAngle, wingCurve,
		tailCurve, outline) expr name =
	% determine parameters for arrowhead
	save len, ang; numeric len, ang;
	len := if arrowLength = 0: ahlength else: arrowLength fi;
	ang := if tipAngle = 0: ahangle else: tipAngle fi;

	% increment counter and define name for indexed access to arrowhead
	save nname; string nname; nname := name & arrowsuffix;
	% note the necessary scantokens usage here.
	arrowcount_ scantokens nname;

	% determine path of arrowhead contour
	save arrowpath; path arrowpath;
	arrowpath := arrowPath(len, insetRatio, ang, wingCurve, tailCurve);

	% fill the arrowhead picture
	save arrowpicture; picture arrowpicture;
	arrowpicture := nullpicture;
	addto arrowpicture contour arrowpath
		if outline: withFillColor else: withFrameColor fi;
	if outline:
		addto arrowpicture doublepath arrowpath
			withpen currentpen withFrameColor;
	fi;
	arrowheads_[arrowcounter_] = arrowpicture;
	arrowlengths_[arrowcounter_] := insetRatio * len;
	arrowlinecolors_[arrowcounter_] := outlinecolor_;
enddef;

% Definition of default arrowhead
% The default arrows and lines are all drawn solid and in the current
% framecolor which may be overridden by the modifier.
def defineDefaultArrow (expr length, ratio, angle, wing, tail) =
	defineArrow(length, ratio, angle, wing, tail, false) "DEFAULT";
	% remember which is now the default.
	arrowdefault_ := arrowcounter_;
enddef;

% Drawing arrows and doublesided arrows with modifier on line and arrowhead
% Nota bene:	do not use 'draw' because then drawoptions will follow
% 				and possibly ruin modifier color settings
%	arrow = name of the arrow, given as "string".
def drawArrow (expr arrow) expr p =
	addto currentpicture also
		arrowline_(p, false, addcounter_suffix(arrow, arrowsuffix))
enddef;
def drawdblArrow (expr arrow) expr p =
	addto currentpicture also
		arrowline_(p, true, addcounter_suffix(arrow, arrowsuffix))
enddef;

% actual arrowline drawer into picture, modifier works on outlines only
%	line    = path variable containing the line
%	double  = true/false for double/single sided arrowline
%	index   = pointer into the arrows arrays.
% note that arrowline_ must be called with addcounter_suffix in order to
% get for index the right data structure as concatenated string capsule.
vardef arrowline_ (expr line, double, index) text modif =
	% pertinent data of the arrowhead.
	save arrow; picture arrow; arrow := arrowheads_[index];
	save leng; numeric leng; leng := arrowlengths_[index];

	% default arrows drawn differently.
	save dflt; boolean dflt;
	save clr; color clr;
	if index = arrowdefault_: dflt := true; clr := outlinecolor_;
	else: dflt:= false; clr := arrowlinecolors_[index];
	fi;

	% local variables.
	save arrowpic; picture arrowpic;
	save linepath; path linepath;
	save bpt, bbpt, ept, eept; pair bpt, bbpt, ept, eept;
	save brot, erot; numeric brot, erot;

	% manipulate path of connecting line in here
	linepath := line;

	% initialize picture
	arrowpic = nullpicture;

	% save original begin- and endpoints
	bpt := point 0 of linepath;
	ept := point length linepath of linepath;

	% clip endpoint of line against inset of arrowhead, calculate rotation
	linepath := cutarrowline_(linepath,leng);
	eept := point length linepath of linepath;
	erot := if ept = eept: 0; else: angle(ept - eept); fi

	% the same for beginpoint when doublesided arrows
	if double:
		linepath := reverse cutarrowline_(reverse linepath,leng);
		bbpt := point 0 of linepath;
		brot := if bpt = bbpt: 180; else: angle(bpt - bbpt); fi
	fi

	% draw connecting line with last modifying color surviving
	addto arrowpic doublepath linepath withpen currentpen withcolor clr modif;

	% draw arrowhead(s) at endpoint(s) in proper orientation.
	addto arrowpic also arrow rotated erot shifted ept
		% default arrow gets special treatment.
		if dflt: withcolor clr modif; fi;
	if double:
		addto arrowpic also arrow rotated brot shifted bpt
			% default arrow gets special treatment.
			if dflt: withcolor clr modif; fi;
	fi;

	% return the completed picture
	arrowpic
enddef;

% Cutoff arrowline at the endpoint at the inset of arrowhead
vardef cutarrowline_ (expr p, l) =
	p cutafter makepath pencircle
		scaled (2l) shifted (point length p of p)
enddef;

%	=========================== Colors ===========================

% administration for blocks.
newinternal colorcounter_;		% by default initally zero
string colornames_[];
color outlinecolors_[], insidecolors_[], textcolors_[], backgroundcolors_[];
color outlinecolor_, insidecolor_, textcolor_, backgroundcolor_;
def colorsuffix = "_c" enddef;

% Convert between name of block and index into array
% for the mechanism see metafont book definition of mode_def
def colorcount_ suffix $ =
	$ := incr colorcounter_;
	colornames_[$] := str$;
enddef;

% Macros to facilitate uniform color usage.
%	outlinecolor is used for frames of boxes etc.
%	textcolor is used for drawing texts, e.g. with textext
%	fillcolor is used for filling up blocks etc.
%	backgroundcolor is used for unfill and undraw

% set individual colors
def setFrameColor expr clr = outlinecolor_ := clr; enddef;
def setFillColor expr clr = insidecolor_ := clr; enddef;
def setTextColor expr clr = textcolor_ := clr; enddef;
def setBackgroundColor expr clr = backgroundcolor_ := clr; enddef;

% color application macros
def withFrameColor = withcolor outlinecolor_ enddef;
def withTextColor = withcolor textcolor_ enddef;
def withFillColor = withcolor insidecolor_ enddef;
def withBackgroundColor = withcolor backgroundcolor_ enddef;

% Parameter set definition for block drawing:
% - outlineColor    => outlinecolor_ = color of outline
% - insideColor     => insidecolor_ = color of interior
% - textColor       => textcolor_ = color of text
% - backgroundColor => backgroundcolor_ = color of background
% - name            => name of the standard block parameter macro
def defineColors (expr outlineColor, insideColor, textColor, backgroundColor) expr name =
	% increment counter and define name for indexed access
	save nname; string nname; nname := name & colorsuffix;
	% note the necessary scantokens usage here.
	colorcount_ scantokens nname;

	% remember colors
	outlinecolors_[colorcounter_] := outlineColor;
	insidecolors_[colorcounter_] := insideColor;
	textcolors_[colorcounter_] := textColor;
	backgroundcolors_[colorcounter_] := backgroundColor;
enddef;

% Save current colors under given name
def defineCurrentColors expr name =
	defineColors(outlinecolor_, insidecolor_, textcolor_, backgroundcolor_) name;
enddef;

% Define the default colors
def defineDefaultColors (expr outlineColor, insideColor, textColor, backgroundColor) =
	defineColors(outlineColor, insideColor, textColor, backgroundColor) "DEFAULT";
enddef;

% Set colors to named colorset
def setColors expr colorset =
	setColors_ addcounter_suffix(colorset,colorsuffix);
	% set color options for filling and drawing
	background := backgroundcolor_;
	drawoptions(withTextColor);
enddef;

% Wrapped color retrieval definition.
def setColors_ expr colors =
	outlinecolor_ := outlinecolors_[colors];
	insidecolor_ := insidecolors_[colors];
	textcolor_ := textcolors_[colors];
	backgroundcolor_ := backgroundcolors_[colors];
enddef;

% Set and save colors to named colorset
def setSaveColors expr colorset =
	saveColors;
	setColors colorset;
enddef;

% Set colors to default values
def setDefaultColors = setColors "DEFAULT"; enddef;

% Save and restore colorset -- note that not nestable
color outlinecolor_s, insidecolor_s, textcolor_s, backgroundcolor_s;
def saveColors =
	outlinecolor_s := outlinecolor_;
	insidecolor_s := insidecolor_;
	textcolor_s := textcolor_;
	backgroundcolor_s := backgroundcolor_;
enddef;
def restoreColors =
	outlinecolor_ := outlinecolor_s;
	insidecolor_ := insidecolor_s;
	textcolor_ := textcolor_s;
	backgroundcolor_ := backgroundcolor_s;
	background := backgroundcolor_;
	drawoptions(withTextColor);
enddef;

%	=========================== Blocks ===========================

% Draw filled frame with an outline as canvas for drawing.
% Frame is drawn with the framecolor, background with the backgroundcolor.
% For special coloring use named colorset and pen.
%	width = width of frame
%	height = height of frame
%	gap = slack space around the inside drawings
%	pn	= pen used for frame
def Framed (expr width, height, gap, pn) text modifier =
	Frame(width, height, gap);
	getpen(pn);
	draw block.rectangle(width+2gap,height+2gap)
		shifted (origin-(gap,gap)) withFrameColor modifier;
	restorepen;
enddef;
% Draw filled frame without an outline as canvas for drawing.
def Frame (expr width, height, gap) =
	storepen;
	clearpen;
	fill block.rectangle(width+2gap,height+2gap)
		shifted (origin-(gap,gap)) withBackgroundColor;
	restorepen;
enddef;

% Builtin possibilities for Block.form are:
%	round (superellipse 0.5 <= <factor>  <= 1.0, default 0.85)
%	oval (ellips)
%	rectangle (rectangle)
%	hexagon
%	diamond (rectangle rotated 45)
%	slant (slanted rectangle <slant> default 0.2)
%	roundrect (rounded left and rightside <roundness> default 0.08)
vardef Block@#(expr position, width, height, labeltext) text modifier =
	VarBlock@#(0, 0, position, width, height, labeltext, true) modifier
enddef;
% Open block, i.e. without an outline.
vardef OBlock@#(expr position, width, height, labeltext) text modifier =
	VarBlock@#(0, 0, position, width, height, labeltext, false) modifier
enddef;
vardef VarBlock@#(expr param, rotation, position, width, height, labeltext, outline) text modifier =
	Form(rotation, position, width, height, labeltext, outline,
		varcblock@#(param, width, height)) modifier;
enddef;

% Return path of various preprogrammed forms with block.variant
%	round (superellipse), oval (ellips), rectangle (rectangle), hexagon
vardef block@#(expr width, height) =
	varblock@#(0, width, height)
enddef;
vardef varblock@#(expr param, width, height) =
	% note: cannot simply define blockl.oval as "shifted (width/2,height/2)",
	% because width and height are not recognized as the formal parameters.
	% this is the reason for using local variables w and h.
	save w_, h_, p_; numeric w_, h_, p_; w_:= width; h_ := height; p_ := param;
	scantokens blockf@# xscaled w_ yscaled h_ scantokens blockl@#
enddef;

% Return path of various preprogrammed centered forms with cblock.variant
%	round (superellipse), oval (ellips), rectangle (rectangle), hexagon
vardef cblock@#(expr width, height) =
	varcblock@#(0, width, height)
enddef;
vardef varcblock@#(expr param, width, height) =
	varblock@#(param, width, height) shifted (-width/2,-height/2)
enddef;

% Form placed at given position.
%	rotation      = applied to form before placement
%	position      = origin where to place the form
%	width, height = dimensions of the form
%	labeltext     = text positioned at center with textext macro
%	outline       = true/false for do/don't draw the outline frame
%	form          = its outline path
%	modifier      = applied to outline, e.g. dashing, coloring
def Form(expr rotation, position, width, height, labeltext, outline, form) text modifier =
begingroup
	% get the outline of the frame
	save formpath; path formpath;
	formpath = form rotated rotation shifted position;

	% ensure that we have the text in a picture
	save labelpic; picture labelpic;
	labelpic =	if picture labeltext: labeltext;
				else: Lab(labeltext);
				fi

	% calculate label offset and vector from center to outline intersection
	save sect; pair sect;
	sect = (position -- (position +
		% must make path long enough to spot crossing
		(width ++ height) * (llcorner labelpic + urcorner labelpic)))
			intersectionpoint formpath;

	% fill inside, draw the label at designated place and draw the outline
	fill formpath withFillColor;
	draw labelpic shifted if sect = origin: position; else: sect; fi
	if outline:
		draw formpath withFrameColor modifier;
	fi
endgroup
enddef;

% Define path for hexagonal blocks.
vardef unithexagon =
	(1,1/2) -- (3/4,1) -- (1/4,1) -- (0,1/2) -- (1/4,0) -- (3/4,0) -- cycle
enddef;
vardef unitroundrect =
	(p_,0)--(1-p_,0)..(1,1/2)..(1-p_,1)--(p_,1)..(0,1/2)..cycle
enddef;

% Define strings for path constructions.
string blockf, blockf.rectangle, blockf.oval, blockf.round, blockf.hexagon,
	blockf.diamond, blockf.slant, blockf.roundrect;
string blockl, blockl.rectangle, blockl.oval, blockl.round, blockl.hexagon,
	blockl.diamond, blockl.slant, blockl.roundrect;
% prefix string
	blockf           := "unitsquare";
	blockf.rectangle := "unitsquare";
	blockf.oval      := "fullcircle shifted (0.5,0.5)";
	blockf.round     := "unitsquare";
	blockf.hexagon   := "unithexagon";
	blockf.diamond   := "unitsquare rotated 45 scaled (1/sqrt 2) shifted (0.5,0)";
	blockf.slant     := "if p_ = 0: p_ := 0.2 fi; unitsquare slanted p_ shifted (-p_/2,0)";
	blockf.roundrect := "if p_ = 0: p_ := 0.2 fi; p_ := min(1,max(0,p_*h_/w_))/2; unitroundrect";
% postfix string
	blockl           := "";
	blockl.rectangle := "";
	blockl.oval      := "";
	blockl.round     := "superellipsed if p_ = 0: 0.85 else: min(1.0,max(0.5,p_)) fi";
	blockl.hexagon   := "";
	blockl.diamond   := "";
	blockl.slant     := "";
	blockl.roundrect := "";

%	=========================== Labels ===========================

% Produce labels, shifted to their intended places, delivered as picture.
% Text at specific point possibly rotated, shifted, scaled, colored.
% In contrast to plain.mf we do not solely use fixed (3bp) labeloffset,
% but add half the width and/or height of the current pen.
% labeltext = Lab.xx(string) [scaled,shifted] or picture
% pos       = point where to place text
%
% Note on coloring through "withcolor":
% As of late both \textext and \sometxt work for producing the picture.
% With (the newer) \somtext currently the following mode should have been
% set in te TeX source in order to get withcolor working:
% \chardef\TeXtextcolormode\zerocount (see source in .../base/meta-tex.tex)

% Label(string/textext(string))
vardef Lab@#(expr labeltext) = theLabel@#(labeltext, origin) enddef;

% Label(string/textext(string), center)
def Label = draw theLabel enddef;

% Label with text and centerposition
vardef theLabel@#(expr labeltext, pos) =
	save pic; picture pic;

	if picture labeltext:
		pic := labeltext;
	else:
		if labeltext = "":
			pic := nullpicture;
		else:
			% other pens then pencircle draw nonsense
			getpen(pencircle);
			% prevent wobbling of text boxes with uneven depth
			pic := textext("\setbox0=\hbox{"&labeltext&"}\dp0=0pt\box0");
			restorepen;
		fi
	fi
	% calculate labelshift from suffix
	save shift; pair shift;
	shift = ((penX/2 + labeloffset) * xpart laboff@#,
				(penY/2 + labeloffset) * ypart laboff@#)
				- (labxf@# * lrcorner pic + labyf@# * ulcorner pic
				+ (1 - labxf@# - labyf@#) * llcorner pic);

	% deliver picture shifted in position
	pic shifted (pos + shift)
enddef;

%	====================== Reprogrammed plain macros ======================

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

%	=========================== Initializations ===========================

% Preprogrammed default colors
defineDefaultColors(black, white, black, white);
setDefaultColors;

% Preprogrammed default arrows
clearpen;
ahlength := 4mm;
ahangle := 32;
defineDefaultArrow(ahlength, 0.8, ahangle, 0, 0);

% Offset for labels
labeloffset := 4pt;

% alternative names for arrows
def arrowline =
	drawArrow("DEFAULT")
enddef;
def dblarrowline =
	drawdblArrow("DEFAULT")
enddef;

% if wanted use this to redefine arrow drawing and labeling.
def redefineArrowAndLabel =
	def drawarrow =  arrowline enddef;
	def drawdblarrow =  dblarrowline enddef;
	def label = Label enddef;
enddef;

\endinput