Services & Resources / Wolfram Forums / MathGroup Archive
-----

MathGroup Archive 2009

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: Re: UNDO and Mathematica - how useless is it?
  • Next by Date: Re: dynamic popupmenu help needed
  • Previous by thread: Re: Are there Arrow-like objects in 3D
  • Next by thread: PlotLegends bug?