Re: Are there Arrow-like objects in 3D
- To: mathgroup at smc.vnet.net
- Subject: [mg98456] Re: Are there Arrow-like objects in 3D
- From: dr DanW <dmaxwarren at gmail.com>
- Date: Fri, 10 Apr 2009 04:53:31 -0400 (EDT)
- References: <grhp9g$mjf$1@smc.vnet.net>
Below is code I wrote for a 3D arrowhead in version 6 (don't know how
many times I have written a handy utility just to have it obsoleted
with the next revision of Mathematica...) Some of the techniques are
borrowed from a package by John Novak of Wolfram Research, ca. 1997,
but the package has been essentially rewritten to bring it up to
Mathematica 6 standards.
If you are wondering, there is a lot of extra code here because the
line part would sometimes show through the cone part of the arrow.
Code follows
----------------
BeginPackage["Arrow3D`"]
ArbitraryOrthonormal::usage = "ArbitraryOrthonormal [ vec ] returns \
an arbitrary unit vector normal to the vector vec.";
Cone::usage = "Cone[ { base, tip }, width, polys ] return the graphics
\
primitives to draw a cone on the axis from base to tip. Optional \
parameter width gives the diameter of the base relative to the height
\
of the cone, and polys gives the number of polygons used to draw \
the surface.";
Arrow3D::usage = "Arrow3D [ { start, end }, opts ] returns the
graphics \
primitives to draw a 3D arrow from points start to end. \n \
Arrow3D[ Line [...] , opts ] also works. \n \
Arrow3D[ opts ] returns a pure function that can be applied to a Line
[...].";
Clipping::usage = "Clipping is an option for Arrow3D. If true, the \
arrow line is clipped within the arrowhead, preventing the glitch \
that can allow the line to show through.";
HeadLength::usage = "HeadLength is an option for Arrow3D which
controls \
the length of the head, given in units of the plot or relative to the
\
line length as given by the option HeadLengthRelative. When a
negative, \
value is given, the head is reversed.";
HeadLengthRelative::usage = "HeadLengthRelative is an option for \
Arrow3D. When True, the option Headlength defines the length of the \
head as a fraction of the length of the whole arrow. When False, \
HeadLength defines the length of the head in the units of the rest \
of the graphic.";
TipLocation::usage = "TipLocation is an option for Arrow3D which sets
\
the fractional distance along the length of the arrow line at which
the \
tip of the arrowhead is drawn.";
HeadWidth::usage = "HeadWidth is an option for Arrow3D, which defines
\
the width of the base of the arrowhead cone relative to its length.";
Polygons::usage = "Polygons is an option for Arrow3D, defining the
number \
of polygons used to form the sides of the arrowhead cone.";
HeadStyle::usage = "HeadStyle is an option for Arrow3D, defining the \
graphics directives to be applied to the arrowhead. Enclose \
multiple directives in Directive[...]. Warning: as with all graphics
\
directives, settings will effect graphics downstream.";
Begin["`Private`"]
(* Implementation of the package *)
ArbitraryOrthonormal[v:{_,_,_}] :=
Module[ {a,b,c},
{a,b,c} = Ordering[If[ VectorQ[v,NumericQ],
Abs[v],
v
]];
Normalize[
ReplacePart[{0,0,0}, {c->-v[[ b ]], b->v[[ c ]]} ]
]
]
Cone[{base_, tip_}, width_:1/GoldenRatio, polys_:10] :=
Module[ {axis, ortho, rt, init, verts, gcd},
axis = tip-base;
ortho = ArbitraryOrthonormal[axis];
rt = RotationTransform[ N[(2\[Pi])/polys ], axis, tip ];
init = N[ base+width Norm[axis] ortho/2 ];
verts = Join[ {tip}, NestList[rt, init, polys-1] ];
gcd = Flatten[ {Polygon[Flatten[{1, #}] ]&
/@ Partition[ Mod[ Range[0, polys], polys ]+2, 2, 1],
Polygon[ Range[polys] + 1] } ];
GraphicsComplex[verts, gcd]
]
arrowPrimitive[start_,end_,hl_,width_,tl_,polys_,clip_,hstyle_] :=
Module[ {axis,tip,base,head,line},
axis = end - start;
tip = start + tl*axis;
base = tip - hl*axis;
head = Cone[{base,tip},width,polys];
line = If[ clip===True,
Switch[Ordering[{0, 1, tl-hl, tl}],
{1,3,4,2},{Line[{start,base}],Line[{end,tip}]},
{3,1,2,4},{},
{1,2,3,4}|{3,4,1,2},{Line[{start,end}]},
{1,3,2,4},{Line[{start,base}]},
{3,1,4,2},{Line[{tip,end}]}
],
{Line[{start,end}]}
];
Flatten[{line,hstyle,head}]
]
Options[Arrow3D] = {
Clipping->True,
HeadLength->0.1,
HeadLengthRelative->True,
TipLocation->1,
HeadWidth->1/GoldenRatio,
Polygons->10,
HeadStyle->{}
};
Arrow3D[ { start:{ _, _, _ }, end:{ _, _, _ } }, ___ ] :=
Point[start]/;start===end
Arrow3D[ Line[ { start_, end_ } ], opts:OptionsPattern[] ] :=
Arrow3D[ { start, end }, opts ]
Arrow3D[opts:OptionsPattern[] ] :=
Arrow3D[ #, opts ]&
Arrow3D[
{start:{_?NumericQ,_?NumericQ,_?NumericQ},
end:{_?NumericQ,_?NumericQ,_?NumericQ}},
OptionsPattern[]] :=
Module
[ {clipping,headlength,headlengthrelative,tiplocation,headwidth,polygons,headstyle,s,e},
{clipping,headlength,headlengthrelative,tiplocation,headwidth,polygons,headstyle}
=
OptionValue
[{Clipping,HeadLength,HeadLengthRelative,TipLocation,HeadWidth,Polygons,HeadStyle}];
If[ headlengthrelative =!= True,
headlength /= N[ Norm[end-start] ]
];
If[ headlength > 0,
{s,e} = {start,end},
(* Else *)
{s,e} = {end,start};
headlength *= -1;
tiplocation = 1-tiplocation
];
arrowPrimitive
[s,e,headlength,headwidth,tiplocation,polygons,clipping,headstyle]
]
End[]
Protect[ Evaluate[ Context[] <> "*" ] ]
EndPackage[]
----------
end code
Example of use:
SetOptions[Arrow3D, HeadLength -> 2, HeadLengthRelative -> False,
HeadStyle -> Directive[Yellow, EdgeForm[]], Clipping -> True]
Graphics3D[{
Arrow3D[{{4, 5, 6}, {2, -6, 1}}],
Arrow3D[{{-7, 3, 4}, {1, 3, 4}}, Polygons -> 50]
}]
Enjoy.
Daniel W