(* :Title: Arrow 3D *)

(* :Context: Graphics`Arrow3D` *)

(* :Author: John M. Novak *)

(* :Summary: crude 3D arrow primitive *)

(* :Copyright: Copyright 1996 Wolfram Research, Inc. *)

(* :Package Version: 1.0 *)

(* :Mathematica Version: 3.0 *)

(* :History:
	V1.0 -- March 1996 by John M. Novak *)

(* :Keywords:
	arrow, Graphics3D
*)

(* :Sources:
	Tom Wickham-Jones, "Mathematica Graphics" *)

(* :Discussion:
	This is a package to add crude 3D arrows by using 3D graphics
primitives.
	The main problem with this approach is that arrows don't have an
optimal
	appearance, and distinction between (e.g.) arrows point toward vs. away
	from the user is difficult to make. On the other hand, it is readily
	implementable, which is far superior to any other approach available at
	this time. (The PostScript used in 2D arrows won't layer correctly in
	3D, nor would 2D primitives; placing 3D planar primitives with the
	correct orientation has problems with perspective transforms as well as
	design problems with things like arrows with a small angle w.r.t. the
	user.) Because of the essentially different approach from 2D arrows,
the
	package is being made independent of the 2D package for the time being.
*)

BeginPackage["Graphics`Arrow3D`"]

Arrow3D::usage =
"Arrow3D[start, end] is a 3D graphics primitive representing an arrow in
space. The start point and the end point are given as {x, y, z}
triplets.
Options controlling the length and width of the arrowhead are
available."

Begin["`Private`"]

(* The following routine is based on OrthogonalVectors from Tom
Wickham-Jones' Mathematica Graphics book. *)

anOrthogonalVector[ norm:{_,_,_}] :=
	Block[{pos, a, b, v1},
		pos = If[ VectorQ[ norm, NumberQ],
				Abs[N[ norm]], norm] ; 
		pos = Sort[ Transpose[ {pos, Range[ 3]}]] ;
		{pos, a,b} = Map[ Last, pos] ;
		v1 = ReplacePart[ {0,0,0}, -Part[ norm, a], b] ;
		ReplacePart[ v1, Part[ norm, b], a]
	]

normalize[vec_] := vec/Sqrt[vec . vec]

(* The following routine 'rotationmatrix' was borrowed from the standard
   package Graphics`SurfaceOfRevolution`. *)

rotationmatrix[axis_,theta_] :=
	Module[{n1,n2,n3},
		{n1,n2,n3} = normalize[axis]//N;
		{{n1^2 + (1 - n1^2) Cos[theta],
			n1 n2 (1 - Cos[theta]) + n3 Sin[theta],
			n1 n3 (1 - Cos[theta]) - n2 Sin[theta]},
		{n1 n2 (1 - Cos[theta]) - n3 Sin[theta],
			n2^2 + (1 - n2^2) Cos[theta],
			n2 n3 (1 - Cos[theta]) + n1 Sin[theta]},
		{n1 n3 (1 - Cos[theta]) + n2 Sin[theta],
			n2 n3 (1 - Cos[theta]) - n1 Sin[theta],
			n3^2 + (1 - n3^2) Cos[theta]}}//N
	]

Arrow3D[base:{_,_,_},tip:{_,_,_}, polys_:10, len_:0.8] :=
    {Line[{base, tip}],
        mycone[tip - base, base, tip, polys, len]}

Arrow3D[base:{_,_,_}, tip:{_, _, _}, ___] :=
    Point[base]/;base == tip

mycone[vec_, base_, tip_, polys_, len_] :=
    Block[{norm = anOrthogonalVector[vec], theta},
         Map[Polygon[Append[#, tip]]&,
               Partition[Table[base + len vec +
                         (1 - len)/2 norm . rotationmatrix[vec, theta],
                {theta, 0, 2 Pi, 2 Pi/polys}]//N, 2, 1]
         ]
    ]

End[]

EndPackage[]

