(*********************************************************************** This file was generated automatically by the Mathematica front end. It contains Initialization cells from a Notebook file, which typically will have the same name as this file except ending in ".nb" instead of ".m". This file is intended to be loaded into the Mathematica kernel using the package loading commands Get or Needs. Doing so is equivalent to using the Evaluate Initialization Cells menu command in the front end. DO NOT EDIT THIS FILE. This entire file is regenerated automatically each time the parent Notebook file is saved in the Mathematica front end. Any changes you make to this file will be overwritten. ***********************************************************************) (* :Title: ArrowExtended.m *) (* :Context: ArrowExtended` *) (* :Author: David Reiss *) (* :Summary: Extends some of the functionality of the Graphics`Arrow` Package so \ that HeadShape can include Splines and Polygons with Splines *) (* :Copyright: \[Copyright] Package Copyright 1999,David Reiss, Scientific Arts. All rights reserved. *) (* :Package Version: 1.0 *) (* :Mathematica Version: 4 *) (* :History: 1.0 derived from consulting work for Marcel Richter. *) (* :Keywords: *) (* :Sources: Various *) (* :Warnings: *) (* :Limitations: *) (* :Discussion: *) (* :Requirements: Graphics`Arrow`, Graphics`Spline` *) (* :Examples: *) BeginPackage["ArrowExtended`","Graphics`Arrow`","Graphics`Spline`"] ArrowExtended::usage="ArrowExtended.m extends some of the functionality of \ the Graphics`Arrow` Package so that HeadShape can include Splines, and \ Polygons with Splines, Plot, and ParametricPlot. In each case these may be \ multiplied by an arbitrary numerical scaling factor.\nExecute the function \ ArrowExtendedExamples[] to generate a notebook that contains some examples of \ the use of this package.\n" ArrowExtended::load = "The ArrowExtended.m package is loading." ArrowExtended::done="The ArrowExtended.m package has finished loading. The \ Graphics`Arrow`, Graphics`Spline`, and NumericalMath`SplineFit` packages have \ also been loaded.\n\nThis package, its code and all associated documentation \ are Copyright \[Copyright] 1999, David Reiss. All rights reserved. \n\nThe \ author, David Reiss, can be reached by email at dreiss@scientificarts.com.\n\n\ Scientific Arts provides Creative Services and Consultation for the Applied \ and Pure Sciences. We specialize in solving problems with Mathematica: \ modeling, simulation, and software development that gets results. This \ package may be used for non commercial purposes and may be redistributed only \ along with this notice. Contact Scientific Arts for commercial license \ arrangements."; $SymmetricalArrow::usage="$SymmetricalArrow determines whether in the \ specification of the HeadShape of an Arrow in terms of Plot or ParametricPlot \ the arrow should be rendered symmetrically. If $SymmetricalArrow=True then \ the Plot or ParametricPlot will be reflected across the x-axis: if \ $SymmetricalArrow=False it will not. The default value is \ $SymmetricalArrow=True." ArrowExtendedExamples::usage="ArrowExtendedExamples[] creates a notebook with \ some examples of the use of the ArrowExtended package."; Message[ArrowExtended::load ]; Begin["`Private`"] $internalSplinePoints=False; SetAttributes[Arrow, ReadProtected]; If[$internalSplinePoints, (Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts}, Spline])&&(!FreeQ[{opts}, Polygon]):= Module[{options,z,w,fun}, options= Flatten[{opts}]/.Spline[ z___]\[RuleDelayed](fun@@(Graphics`Spline`Private`\ splinepoints[z])); options=options/.w_ fun[z___]\[RuleDelayed]fun[Sequence@@(w{ z})]; Arrow[start,finish,Sequence@@Flatten[{options/.fun\[Rule]Sequence}]] ]; Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts}, Spline])&&(FreeQ[{opts}, Polygon]):= Module[{options,z,w,fun}, options= Flatten[{opts}]/.Spline[ z___]\[RuleDelayed](fun[ Graphics`Spline`Private`splinepoints[z]]); options=options/.w_ fun[z___]\[RuleDelayed]fun[Sequence@@(w{ z})]; Arrow[start,finish,Sequence@@Flatten[{options/.fun\[Rule]Polygon}]] ]; ), Null,Null]; SplinePoints[spline_Spline]:= Module[{splineFunction,tmin, tmax,t,lines,z}, splineFunction=spline[[3]]; {tmin, tmax}=splineFunction[[2]]; Off[ParametricPlot::"ppcom"]; lines= ParametricPlot[splineFunction[t], {t, tmin, tmax}, DisplayFunction\[Rule]Identity][[1,1]]; On[ParametricPlot::"ppcom"]; lines/.Line[{z___}]\[RuleDelayed]z ]; If[!$internalSplinePoints, (Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts}, Spline])&&(!FreeQ[{opts}, Polygon]):= Module[{options,z,w,fun}, options= Flatten[{opts}]/.Spline[ z___]\[RuleDelayed](fun@@(SplinePoints[Spline[z]])); options=options/.w_ fun[z___]\[RuleDelayed]fun[Sequence@@(w{ z})]; Arrow[start,finish,Sequence@@Flatten[{options/.fun\[Rule]Sequence}]] ]; Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts}, Spline])&&(FreeQ[{opts}, Polygon]):= Module[{options,z,w,fun}, options= Flatten[{opts}]/.Spline[ z___]\[RuleDelayed](fun[SplinePoints[Spline[z]]]); options=options/.w_ fun[z___]\[RuleDelayed]fun[Sequence@@(w{ z})]; Arrow[start,finish,Sequence@@Flatten[{options/.fun\[Rule]Polygon}]] ]; ), Null, Null]; $SymmetricalArrow=True; Arrow::delayrule="To use the HeadShape option with a Plot or ParametricPlot \ you must give it in the form of a delayed rule."; Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts},( HeadShape\[RuleDelayed] Plot[___])|(HeadShape\[RuleDelayed]_ Plot[___])|( HeadShape\[RuleDelayed] ParametricPlot[___])|(HeadShape\[RuleDelayed]_ \ ParametricPlot[___])]):= Module[{options,z,w,p,fun,plotArgs,plotFactor,plotType,plotPoints}, (* Print[{opts}]; *) plotArgs= Cases[Flatten[{opts}],(HeadShape\[RuleDelayed] Plot[z___])|(HeadShape\[RuleDelayed] w_ Plot[z___])|(HeadShape\[RuleDelayed] ParametricPlot[z___])|(HeadShape\[RuleDelayed] w_ ParametricPlot[z___])\[Rule]z]; plotType= Cases[Flatten[{opts}],(HeadShape\[RuleDelayed](z: Plot|ParametricPlot)[___])|(HeadShape\[RuleDelayed]_ \ (z:Plot|ParametricPlot)[___])\[Rule]z][[1]]; plotFactor= With[{tem= Cases[Flatten[{opts}],(HeadShape\[RuleDelayed] w_ Plot[z___])|(HeadShape\[RuleDelayed] w_ ParametricPlot[z___])\[Rule]w]}, Switch[tem, {}, 1, _, tem[[1]] ] ]; plotPoints= Block[{$DisplayFunction=Identity}, (plotType@@plotArgs)[[1,1]] ]/.Line[{z___}]\[RuleDelayed]z; If[$SymmetricalArrow, plotPoints= Flatten[ {plotPoints, Reverse[plotPoints/.{x_?AtomQ,y_?AtomQ}\[RuleDelayed]{x,-y}]}, 1], Null,Null]; options= Flatten[{HeadShape\[Rule]Polygon[plotFactor plotPoints], DeleteCases[Flatten[{opts}],( HeadShape\[RuleDelayed]_)]}]; Arrow[start,finish,Sequence@@options] ]; Arrow[start_,finish_, opts___?OptionQ]/;(!FreeQ[{opts},( HeadShape\[Rule]Graphics[___])|( HeadShape\[Rule]_ Graphics[___])])&& Message[Arrow::delayrule]:=(Message[Arrow::delayrule];$Failed); ArrowExtendedExamples[]:= NotebookPut[ Notebook[{Cell[ BoxData[{RowBox[{RowBox[{RowBox[{"scale","=","20"}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape","->", RowBox[{"Polygon","[", RowBox[{"scale"," ", RowBox[{"{",RowBox[{"Spline","[", RowBox[{RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",", "0"}],"}"}],",",RowBox[{"{", RowBox[{RowBox[{"-",FractionBox["1", "2"]}],",",RowBox[{"-","1"}]}],"}"}], ",",RowBox[{"{",RowBox[{FractionBox[ "1","8"],",",RowBox[{"-",FractionBox[ "1","12"]}]}],"}"}],",",RowBox[{"{", RowBox[{"4",",","0"}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "8"],",",FractionBox["1","12"]}], "}"}],",",RowBox[{"{", RowBox[{RowBox[{"-",FractionBox["1", "2"]}],",","1"}],"}"}],",", RowBox[{"{",RowBox[{"0",",","0"}], "}"}]}],"}"}],",","Bezier"}],"]"}], "}"}]}],"]"}]}],",", RowBox[{"HeadScaling","->", "Absolute"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","10"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"], Cell[BoxData[{RowBox[{RowBox[{RowBox[{"scale","=", FractionBox["1","5"]}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape","->", RowBox[{"Polygon","[", RowBox[{"scale"," ", RowBox[{"{",RowBox[{"Spline","[", RowBox[{RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",", "0"}],"}"}],",",RowBox[{"{", RowBox[{RowBox[{"-",FractionBox["1", "2"]}],",",RowBox[{"-","1"}]}],"}"}], ",",RowBox[{"{",RowBox[{FractionBox[ "1","8"],",",RowBox[{"-",FractionBox[ "1","12"]}]}],"}"}],",",RowBox[{"{", RowBox[{"4",",","0"}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "8"],",",FractionBox["1","12"]}], "}"}],",",RowBox[{"{", RowBox[{RowBox[{"-",FractionBox["1", "2"]}],",","1"}],"}"}],",", RowBox[{"{",RowBox[{"0",",","0"}], "}"}]}],"}"}],",","Bezier"}],"]"}], "}"}]}],"]"}]}],",", RowBox[{"HeadScaling","->", "Relative"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","15"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"], Cell[BoxData[{RowBox[{RowBox[{RowBox[{"scale","=","20"}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape","->", RowBox[{"Polygon","[", RowBox[{"scale"," ", RowBox[{"{",RowBox[{RowBox[{"Spline", "[",RowBox[{RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",", RowBox[{"-","1"}]}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "10"],",",RowBox[{"-",FractionBox["1", "12"]}]}],"}"}],",",RowBox[{"{", RowBox[{"4",",","0"}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "10"],",",FractionBox["1","12"]}], "}"}],",",RowBox[{"{",RowBox[{"0",",", "1"}],"}"}]}],"}"}],",","Bezier"}], "]"}],",",RowBox[{"{",RowBox[{"0",",", "0"}],"}"}]}],"}"}]}],"]"}]}],",", RowBox[{"HeadScaling","->", "Absolute"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","15"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"], Cell[BoxData[{RowBox[{RowBox[{RowBox[{"scale","=", FractionBox["1","5"]}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape","->", RowBox[{"Polygon","[", RowBox[{"scale"," ", RowBox[{"{",RowBox[{RowBox[{"Spline", "[",RowBox[{RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",", RowBox[{"-","1"}]}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "10"],",",RowBox[{"-",FractionBox["1", "12"]}]}],"}"}],",",RowBox[{"{", RowBox[{"4",",","0"}],"}"}],",", RowBox[{"{",RowBox[{FractionBox["1", "10"],",",FractionBox["1","12"]}], "}"}],",",RowBox[{"{",RowBox[{"0",",", "1"}],"}"}]}],"}"}],",","Bezier"}], "]"}],",",RowBox[{"{",RowBox[{"0",",", "0"}],"}"}]}],"}"}]}],"]"}]}],",", RowBox[{"HeadScaling","->", "Relative"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","15"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"], Cell[ TextData[{"To use the HeadShape option with a Plot or \ ParametricPlot you must give it in the form of a ", StyleBox["delayed",FontSlant\[Rule]"Italic"]," rule."}],"Text"], Cell[BoxData[{RowBox[{RowBox[{RowBox[{"scale","=", FractionBox["1","6"]}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape",":>", RowBox[{"scale"," ", RowBox[{"Plot","[", RowBox[{RowBox[{"Cos","[","x","]"}], ",",RowBox[{"{",RowBox[{"x",",","0", ",",FractionBox["\[Pi]","2"]}], "}"}]}],"]"}]}]}],",", RowBox[{"HeadScaling","->", "Relative"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","15"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"], Cell[BoxData[{RowBox[{RowBox[{RowBox[{"scale","=", FractionBox["1","10"]}],";"}]," "}],"\n", RowBox[{RowBox[{"Show","[", RowBox[{RowBox[{"Graphics","[", RowBox[{"{", RowBox[{"Arrow","[", RowBox[{RowBox[{"{", RowBox[{"0",",","0"}],"}"}],",", RowBox[{"{",RowBox[{"4",",","0"}], "}"}],",", RowBox[{"HeadShape",":>", RowBox[{"scale"," ", RowBox[{"ParametricPlot","[", RowBox[{RowBox[{"{", RowBox[{RowBox[{"Sin","[",RowBox[{"t", "-","\[Pi]"}],"]"}],",", RowBox[{RowBox[{"-",RowBox[{"(", RowBox[{"t","-",FractionBox[ RowBox[{"3"," ","\[Pi]"}],"2"]}], ")"}]}]," ",RowBox[{"Sin","[", RowBox[{"\[Pi]","-",FractionBox["t", "2"]}],"]"}]}]}],"}"}],",", RowBox[{"{",RowBox[{"t",",","0",",", FractionBox[RowBox[{"3"," ","\[Pi]"}], "2"]}],"}"}]}],"]"}]}]}],",", RowBox[{"HeadScaling","->", "Relative"}]}],"]"}],"}"}],"]"}],",", RowBox[{"PlotRange","->", RowBox[{"{", RowBox[{RowBox[{"{",RowBox[{"0",",","15"}], "}"}],",", RowBox[{"{", RowBox[{RowBox[{"-","10"}],",","12"}], "}"}]}],"}"}]}]}],"]"}],";"}]}], "Input"]}] ]; SetAttributes[ScientificArtsSplashScreen, ReadProtected]; ScientificArtsSplashScreen[text_String]:= NotebookPut@Notebook[ {Cell[CellGroupData[{ Cell[TextData[{StyleBox["Sc",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0.700008,0,0]], StyleBox["ie",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0.8,0.4,0]], StyleBox["nt",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[1,0.6,0]], StyleBox["if",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0.2,0.4,0.2]], StyleBox["ic",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0,0,0.6]], StyleBox[" ",FontSlant\[Rule]"Italic"], StyleBox["Ar",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0.4,0,0.6]], StyleBox["ts",FontSlant\[Rule]"Italic", FontColor\[Rule]RGBColor[0.500008,0.2,0.500008]]}], "Title",TextAlignment\[Rule]Center,TextJustification\[Rule]1, CellMargins\[Rule]{{44,34},{8,Inherited}}, FontFamily\[Rule]"Times New Roman", CellFrame\[Rule]{{0,0},{0,2}}], Cell["Creative Services and Consultation for the Applied and \ Pure Sciences",CellMargins\[Rule]{{44,34},{Inherited,Inherited}}, TextAlignment\[Rule]Center,TextJustification\[Rule]1, FontColor\[Rule]RGBColor[0,0.2,0.4]], Cell[TextData[ ButtonBox["http://www.scientificarts.com/", ButtonData\[RuleDelayed]{URL[ "http://www.scientificarts.com/"],None}, ButtonStyle\[Rule]"Hyperlink"]], CellMargins\[Rule]{{44,34},{Inherited,Inherited}}, TextAlignment\[Rule]Center,TextJustification\[Rule]1, FontSize\[Rule]10], Cell[text,CellMargins\[Rule]{{44,34},{Inherited,Inherited}}, TextJustification\[Rule]1], Cell[TextData[{"This ", StyleBox["Mathematica",FontSlant\[Rule]"Italic"], " package (ArrowExtended.m) and all associated \ documentation\nCopyright \[Copyright] 1999, David Reiss. All rights \ reserved."}],"Text",CellFrame\[Rule]{{0,0},{0,1}}, CellMargins\[Rule]{{44,34},{Inherited,Inherited}}, TextAlignment\[Rule]Center,TextJustification\[Rule]1, FontColor\[Rule]RGBColor[0.4,0,0.2]], Cell[ BoxData[ ButtonBox[ StyleBox["Done",FontColor\[Rule]RGBColor[0.4,0,0.2]], ButtonFunction\[RuleDelayed](NotebookClose[ SelectedNotebook[]]&), ButtonEvaluator\[Rule]Automatic,Active\[Rule]True]], "Text",CellFrame\[Rule]{{0,0},{1,0}}, CellMargins\[Rule]{{44,34},{Inherited,Inherited}}, TextAlignment\[Rule]Center,TextJustification\[Rule]1]}, Open]]},ScreenRectangle\[Rule]{{0,1024},{0,748}}, WindowToolbars\[Rule]{},WindowSize\[Rule]{530,380}, WindowMargins\[Rule]{{88,Automatic},{Automatic,60}}, WindowFrame\[Rule]"Palette",WindowElements\[Rule]{}, WindowTitle\[Rule]"Scientific Arts",ShowCellBracket\[Rule]False, Magnification\[Rule]1,StyleDefinitions\[Rule]"Report.nb"]; ScientificArtsSplashScreen["\nExecute the function ArrowExtendedExamples[] to \ generate a notebook that contains some examples of the use of this package.\n\ \nThe author, David Reiss, can be reached by email at \ dreiss@scientificarts.com.\n\nScientific Arts specializes in solving problems \ with Mathematica: modeling, simulation, and software development that gets \ results. This package may be used for non commercial purposes and may be \ redistributed only along with this notice. Contact Scientific Arts for \ commercial license arrangements."]; End[ ] Protect[Evaluate[$Context<>"*"]] Unprotect[$SymmetricalArrow]; EndPackage[ ] Message[ArrowExtended::done ]; (* Execute the function ArrowExtendedExamples[] to generate a notebook that \ contains some examples of the use of this package. *)