(* :Title:  Arrow Graphics Primitives *)

(* :Context: Graphics`Arrow` *)

(* :Author: John M. Novak *)

(* :Summary:  
This package introduces the Arrow[start, finish] graphics
primitive and various style directives.
*)

(* :Package Version: 1.0.3 *)

(* :Mathematica Version: 2.2 *)

(* :Copyright: Copyright 1992-1999, Wolfram Research, Inc.*)

(* :History:
	V 0.9 June 1992 by John M. Novak.
	V 1.0 October 1992 by John M. Novak--substantial revisions.
    V 1.0.1 March 1994 by John M. Novak -- bug fixes, including zero check
		   in the PostScript.
    V 1.0.2 February 1997 by John M. Novak -- bug fix for DisplayString.
    V 1.0.3 February 1998 by John M. Novak -- fix to allow Arrow objects
           in Epilog or Prolog of any graphics object
*)

(* :Keywords:
	Arrow, Vector, PostScript, Graphics
*)

(* :Sources:
	PostScript Language Reference Manual, Adobe Systems
*)

(* :Limitations:  Size of arrowhead cannot be taken into account
	for autoscaling of plot ranges, since determination of
	plot ranges are done in Mathematica, and the arrow heads are
	generated in pure PostScript. *)

(* :Discussion: *)

BeginPackage["Graphics`Arrow`"]

Arrow::usage =
"Arrow[start, finish, (opts)] is a graphics primitive representing an
arrow starting at start and ending at finish.";

HeadShape::usage =
"HeadShape is an option to the Arrow primitive; it specifies
the shape of the arrow's head by Automatic, which specifies that the
shape is described by the parameters HeadLength, HeadCenter, and
HeadWidth, or it can be a list of a subset of the Mathematica graphics
primitives, drawn in the coordinate system scaled by HeadScaling.  The
coordinate system is centered at the head of the arrow, with the negative
direction moving towards the tail of the arrow.";

HeadScaling::usage =
"HeadScaling is an option to the Arrow primitive; it specifies
the scaling used in the coordinate system for drawing the
arrowhead.  Automatic scales the system to the graphic, where
{0,0} is at the head of the arrow, and the system is rotated along
the arrow, and the distance between 0 and 1 is equivalent to the width of
the graphic.  Relative scales the coordinates of the arrowhead so that {0,0}
is at the head of the arrow, {-1,0} at the tail. Absolute scales to
the same coordinate system used in the device coordinate
system, rotated along the arrow, with {0,0} at the head.";

ZeroShape::usage =
"ZeroShape is an option to the Arrow primitive; it specifies
the shape of an arrow with no length (and hence no direction) in a form
similar to that of the HeadShape option.  Note that the
parameterized form of HeadShape is not available. The coordinate system
is not rotated, but is scaled to HeadScaling.  Automatic sets
the default zero arrow (a point.)";

HeadLength::usage =
"HeadLength is an option to the Arrow primitive.  It is used when
HeadShape -> Automatic. It describes the length of the arrowhead, scaled
according to HeadScaling.";

HeadWidth::usage =
"HeadWidth is an option to the Arrow primitive.  It is used when
HeadShape -> Automatic.  It describes the width of the arrowhead, relative
to the length of the arrowhead (specified by HeadLength.)";

HeadCenter::usage =
"HeadCenter is an option to the Arrow primitive.  It is used when
HeadShape -> Automatic.  It describes the location of the center of the 
base of the arrowhead along the length of the arrow, as a factor of the 
length of the arrowhead.  That is, if HeadCenter -> 0, the arrow will be 
two lines; if HeadCenter -> 1, the arrowhead will be a perfect triangle; 
otherwise, the arrowhead will be four-sided.";

Relative::usage =
"Relative is a possible value for the HeadScaling option to Arrow.
It specifies that the coordinate system in which the arrowhead is rendered
should be scaled to the length of the arrow, where {0,0} is at the head
of the arrow and {-1,0} is at the tail of the arrow.";

Absolute::usage =
"Absolute is a possible value for the HeadScaling option to Arrow.
It specifies that the device scaling should be used for the
arrowhead.";

Begin["`Private`"]

(* some global (but in private context) variables for caching the  arrow 
styles. *)
{$$HeadDescriptions, $$HeadRoutines, $$ZeroDescriptions, $$ZeroRoutines};

(* A little utility function for checking numeric values. *)

numberQ[x_] := NumberQ[N[x]]

(* putting numbers in PostScript -
    To make it easy to put numbers into PostScript, this utility hacks the
    PostScript operator.  Any number followed by a string is joined to the
    string in the proper format; a number at the end is turned into a string.
*)

numtostring[num_] :=
    ToString[NumberForm[Chop[N[num]], ExponentFunction -> (Null &)]]

Unprotect[PostScript];

PostScript[x___, y_?numberQ] :=
    PostScript[x,
        numtostring[y]]

PostScript[a___, y_?numberQ, z_String, b___] :=
    PostScript[a,
        numtostring[y] <> " " <> z,
        b
    ]

Protect[PostScript]

(* define PostScript operators *)

(* math to ps coordinates; note that this implementation is
used in part because of the sparsity of Mathematica PostScript
(e.g., transform does not exist.)  The MBeginOrig/MEndOrig
transform needs to be done every time, because this can be
different in a subgraph (i.e., I can't cache the transform
matrix once at the beginning.)  Because the transform operator
doesn't exist, I use this moveto method; unfortunately, this
requires the gsave/grestore, which undoubtedly leads to some
performance hit. *)

mathtops =
	PostScript[
		"/mathtops {",   (* stack: mathx mathy *)
			"gsave",
			"MBeginOrig",
			"moveto",    (* stack: - *)
			"MEndOrig",
			"currentpoint", (* stack : psx psy *)
			"grestore",
		"} bind def"
	];

tocoords =
	PostScript[
		"/MAtocoords {",   (* stack: beginx beginy endx endy *)
			"mathtops 4 2 roll mathtops", (* x2 y2 x1 y1 *)
			"4 copy pop pop",    (* x2 y2 x1 y1 x2 y2 *)
			"3 -1 roll sub",     (* x2 y2 x1 x2 y2-y1 *)
			"/arry exch def",
			"exch sub",          (* x2 y2 x2-x1 *)
			"/arrx exch def",
			"arrx dup mul",    (* x2 y2 (x2-x1)^2 *)
			"arry dup mul",   (* x2 y2 (x2-x1)^2 (y2-y1)^2 *)
			"add sqrt",          (* x2 y2 (sqrt((x2-x1)^2+(y2-y1)^2) *)
			"/arrl exch def",   (* x2 y2 *)
			"translate",         (* - *)
		"} bind def"
	];

(* The following sets up the call to the doarrow routine. *)

Arrow::bad =
"Arguments `1` to Arrow are not valid.";

Options[Arrow] =
	{HeadScaling -> Automatic,
	HeadLength -> Automatic,
	HeadCenter -> 1,
	HeadWidth -> .5,
	HeadShape -> Automatic,
	ZeroShape -> Automatic};

evalarrow[{bx_?numberQ,by_?numberQ}, {ex_?numberQ,ey_?numberQ},
		opts:((_Rule | _RuleDelayed)...)] :=
	Module[{head, zero, scale, len, cent, width,
			nbx = N[bx], nby = N[by], nex = N[ex], ney = N[ey]},
		{head, zero, scale, len, cent, width} = {HeadShape, ZeroShape,
					HeadScaling, HeadLength, HeadCenter, HeadWidth}/.
			{opts}/.Options[Arrow];
		If[numtostring[nbx] === numtostring[nex] &&
		          numtostring[nby] === numtostring[ney],
			arrow = generatezero[zero, scale, nbx, nby],
			arrow = generatehead[head, scale, len, cent, width,
						nbx, nby, nex, ney]
		];
		{Line[{{bx,by},{ex,ey}}], arrow}
	 ]

evalarrow[args___] :=
	(Message[Arrow::bad, {args}]; {})

(* This routine checks whether the arguments correspond to a cached 
arrowhead; if so, it returns the PostScript call to the routine.  If not,
it build the PostScript string, caches the arrow description and the
PostScript, and returns the PostScript call to the cached routine.  Note
that the preparearrows[] routine is the one to emit the cached routines.
*)

generatehead[head_, scale_, len_, cent_, width_, bx_, by_, nex_, ney_] :=
	Module[{pos},
		If[(pos = Position[$$HeadDescriptions, {head, scale, len, cent, width},
							{1}, Heads -> False]) != {},
			PostScript[bx, by, nex, ney,
			    "MAarrowhead"<>ToString[ pos[[1,1]] ]],
		(* else *)
			buildhead[head, scale, len, cent, width];
			PostScript[bx, by, nex, ney,
			    "MAarrowhead"<>ToString[Length[$$HeadRoutines]]]
		]
	]

generatezero[zero_, scale_, bx_, by_] :=
	Module[{pos},
		If[(pos = Position[$$ZeroDescriptions, {zero, scale},
							{1}, Heads -> False]) != {},
			PostScript[bx, by, "MAarrowzero"<>ToString[ pos[[1,1]] ]],
		(* else *)
			buildzero[zero, scale];
			PostScript[bx, by, "MAarrowzero"<>ToString[Length[$$ZeroRoutines]]]
		]
	]

(* These build the PostScript descriptions, and add descriptions to the
proper caching variables. *)

buildhead[head_, scale_, len_, cent_, width_] :=
	Module[{routine, pshead},
		AppendTo[$$HeadDescriptions, {head, scale, len, cent, width}];
		If[head === Automatic,
			pshead = fromparams[scale, len, cent, width],
			pshead = fromdescription[head]
		];
		routine = {PostScript["gsave", "MAtocoords", "arrl 0. eq",
							  "{ 0 0 Mdot }", "{"], arrowscale[scale],
			rotatesystem, pshead, PostScript["} ifelse", "grestore"]};
		AppendTo[$$HeadRoutines, routine]
	]

buildzero[head_, scale_] :=
	Module[{routine, zhead, zscale},
		AppendTo[$$ZeroDescriptions, {head, scale}];
		If[head === Automatic,
			zhead = PostScript["0 0 Mdot"],
			zhead = fromdescription[head]
		];
		If[scale === Absolute,
			zscale = arrowscale[scale],
			zscale = {}
		];
		routine = {PostScript["gsave", "mathtops translate"], zscale,
			zhead, PostScript["grestore"]};
		AppendTo[$$ZeroRoutines, routine]
	]

(* PostScript for rotating coordinate system *)

rotatesystem =
	PostScript[
		"[ arrx arrl div",   (* [ cos(t) *)
		"arry arrl div",    (* [ cos(t) sin(t) *)
		"-1 arry mul arrl div",
		"arrx arrl div",
		"0 0 ]",             (* [cos(t) sin(t) -sin(t) cos(t) 0 0] *)
		"concat"             (* - *)
	];


(* This generate the primitives describing a parameterized arrowhead. *)
(* fromparams determines the default length parameter depending on scaling; it
	calls fromsparams *)

fromparams[Automatic, Automatic, c_, w_] :=
	fromsparams[.05, c, w]

fromparams[Relative, Automatic, c_, w_] :=
	fromsparams[.2, c, w]

fromparams[Absolute, Automatic, c_, w_] :=
	fromsparams[15, c, w]

fromparams[_, l_, c_, w_] := fromsparams[l,c,w]

fromsparams[l_, 0 | 0., w_] :=
	PostScript[
		-l, (w l)/2, " moveto 0 0 lineto ",
		-l, -(w l)/2, " lineto stroke"
	]

(* note that filled arrowheads are outlined by a line to hopefully cause a
	more graceful resizing... *)
fromsparams[l_, 1 | 1., w_] :=
	Module[{nls = -l, ws = (w l)/2, nws = -(w l)/2},
		PostScript[
			nls, ws, "moveto 0 0 lineto",
			nls, nws, "lineto fill",
			nls, ws, "moveto 0 0 lineto",
			nls, nws, "lineto",
			nls, ws, "lineto stroke"
		]
	]

fromsparams[l_, c_, w_] :=
	Module[{nls = -l, ncs = -c l, ws = (w l)/2, nws = -(w l)/2},
		PostScript[
			nls, ws, "moveto 0 0 lineto",
			nls, nws, "lineto",
			ncs, "0 lineto fill",
			nls, ws, "moveto 0 0 lineto",
			nls, nws, "lineto",
			ncs, "0 lineto",
			nls, ws, "lineto stroke"
		]
	]

(* Create PostScript from a Mathematica-like syntax for describing head *)

fromdescription[head_] := head/.{Polygon[g_] :> frompoly[g],
	Line[l_] :> fromline[l],
	Point[p_] :> frompoint[p],
	Thickness[t_] :> PostScript[t, "w"]}

frompoly[g_] :=
	Module[{str = listtostring[g]},
		PostScript[
			str,
			"fill"
		]
	]

fromline[g_] :=
	Module[{str = listtostring[g]},
		PostScript[
			str,
			"stroke"
		]
	]

frompoint[{x_,y_}] :=
	PostScript[
		x, y, "Mdot"
	]

listtostring[l_] :=
	With[{initial = numtostring[#1]<>" "<>numtostring[#2]<>
			" moveto " & @@ First[l]},
		Fold[#1<>numtostring[First[#2]]<>" "<>numtostring[Last[#2]]<>
				" lineto "&,initial, Rest[l]
		]
	]

(* PostScript for coordinate scaling for arrowhead *)

HeadScaling::bad =
"Arguments `1` to HeadScaling are not Automatic, Relative, or Absolute; using
default of Automatic.";

arrowscale[] := arrowscale[Automatic]

arrowscale[Automatic] := {}

arrowscale[Relative] :=
	PostScript[
		"arrl arrl scale"
	]

arrowscale[Absolute] :=
	PostScript[
		"currentlinewidth 1 Mabswid",
		"currentlinewidth dup scale setlinewidth"
	]

arrowscale[x___] :=
	(Message[HeadScaling::bad, {x}]; arrowscale[Automatic])

(* generate PostScript from cached descriptions, set up routines for preparing
to do arrows (This gets dumped into the start of the Prolog. *)

preparearrows[] := 
	Module[{heads, zeros},
		heads = MapIndexed[
			{PostScript["/MAarrowhead"<>ToString[First[#2]]<>" {"],
			 #1, PostScript["} def"]}&, $$HeadRoutines];
		zeros = MapIndexed[
			{PostScript["/MAarrowzero"<>ToString[First[#2]]<>" {"],
			 #1, PostScript["} def"]}&, $$ZeroRoutines];
		Flatten[{mathtops, tocoords, heads, zeros}]//.
			{x___, PostScript[a___], PostScript[b___], y___} :>
				{x,PostScript[a,b], y}
	]

(* remember that all the $$etc. are global... *)
(* was originally coded to only operate on Graphics objects, but it
   turns out that Arrow objects can work in Epilog or Prolog, so at
   cost of poorer error checking, the code was trivially modified to
   check anything being passed to Display for an Arrow. This may
   mean trouble for design of a 3D arrow, if it shares the head Arrow. *)
Unprotect[Display];

Display[stream_,
		((ghead_)[igarg_, igopts___])?
					(!FreeQ[#,Arrow]&),
		opts___] :=
	Module[{oldgropts, oldgaopt, prolog, p},
		$$HeadDescriptions = {}; $$HeadRoutines = {}; $$ZeroDescriptions ={};
		$$ZeroRoutines = {};
		Unprotect[Graphics,GraphicsArray];
		oldgropts = Options[Graphics];
		oldgaopts = Options[GraphicsArray];
		Options[Graphics] = Options[Graphics]/.
				Arrow[p___] :> evalarrow[p];
		Options[GraphicsArray] = Options[GraphicsArray]/.
				Arrow[p___] :> evalarrow[p];
		prolog = (Prolog/.Flatten[{igopts}]/.Options[ghead])/.
					Arrow[p___] :> evalarrow[p];
		garg = igarg/.Arrow[p___] :> evalarrow[p];
		gopts = {igopts}/.Arrow[p___] :> evalarrow[p];
		If[Head[prolog] === List,
			prolog = Join[preparearrows[],
				prolog],
			prolog = Append[preparearrows[], prolog]
		];
		Display[stream,
			ghead[garg, Flatten[{Prolog -> prolog, Sequence @@ gopts}]],
			opts
		];
		Unprotect[Graphics, GraphicsArray];
		Options[Graphics] = oldgropts;
		Options[GraphicsArray] = oldgaopts;
		Protect[Graphics, GraphicsArray];
		ghead[igarg,igopts]
	]

Protect[Display];

Unprotect[DisplayString];

DisplayString[
		((ghead_)[igarg_, igopts___])?
					(!FreeQ[#,Arrow]&),
		opts___] :=
	Module[{oldgropts, oldgaopt, prolog, p, grout},
		$$HeadDescriptions = {}; $$HeadRoutines = {}; $$ZeroDescriptions ={};
		$$ZeroRoutines = {};
		Unprotect[Graphics,GraphicsArray];
		oldgropts = Options[Graphics];
		oldgaopts = Options[GraphicsArray];
		Options[Graphics] = Options[Graphics]/.
				Arrow[p___] :> evalarrow[p];
		Options[GraphicsArray] = Options[GraphicsArray]/.
				Arrow[p___] :> evalarrow[p];
		prolog = (Prolog/.Flatten[{igopts}]/.Options[ghead])/.
					Arrow[p___] :> evalarrow[p];
		garg = igarg/.Arrow[p___] :> evalarrow[p];
		gopts = {igopts}/.Arrow[p___] :> evalarrow[p];
		If[Head[prolog] === List,
			prolog = Join[preparearrows[],
				prolog],
			prolog = Append[preparearrows[], prolog]
		];
		grout = DisplayString[
			ghead[garg, Flatten[{Prolog -> prolog, Sequence @@ gopts}]],
			opts
		];
		Unprotect[Graphics, GraphicsArray];
		Options[Graphics] = oldgropts;
		Options[GraphicsArray] = oldgaopts;
		Protect[Graphics, GraphicsArray];
		grout
	]

Protect[DisplayString];

(* OK, this is an ugly hack for several "graphic characteristic determination"
   functions (FullOptions, FullGraphics, FullAxes, PlotRange).
   This is not a complete solution, since it doesn't spot Arrows that are
   set in default options. Also, FullGraphics is (for the time being) not
   being handled, since that would involve generating the proper PostScript
   primitives. Hopefully, this will all be able to be supersceded by some
   kernel design, so I am only making this temporary fix. --JMN, 10.93
*)

Unprotect[FullAxes];

FullAxes[gr_?(!FreeQ[#,Arrow]&), rest___] :=
   FullAxes[gr/.Arrow[beg_, end_, ___] :> Line[{beg, end}], rest]

Protect[FullAxes];

Unprotect[PlotRange];

PlotRange[gr_?(!FreeQ[#,Arrow]&), rest___] :=
   PlotRange[gr/.Arrow[beg_, end_, ___] :> Line[{beg, end}], rest]

Protect[PlotRange];

Unprotect[FullOptions]

FullOptions[gr_?(!FreeQ[#,Arrow]&), rest___] :=
   FullOptions[gr/.Arrow[beg_, end_, ___] :> Line[{beg, end}], rest]

Protect[FullOptions];


End[]

EndPackage[]
