#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'Examples/BookPictures.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XNeeds["RMPackages`ComplexMap`"] XNeeds["RMPackages`NewParametricPlot3D`"] XNeeds["Graphics`Shapes`"] XNeeds["Graphics`Polyhedra`"] XNeeds["RMPackages`RungeKutta`"] XNeeds["RMPackages`RandomWalk`"] X X(* fix bug with FaceForm[GrayLevel[...]] in V1.2 *) XUnprotect[GrayLevel]; XGrayLevel[lev_] := RGBColor[lev, lev, lev]; XProtect[GrayLevel]; X X X(* Moebius transform *) X Xchapter1 := PolarMap[ (2#-I)/(#-1)&, {0.001, 5.001, 0.25}, {0, 2Pi, Pi/15}, X Framed->True ] X X(* Minimal surface *) X Xchapter2 := X ParametricPlot3D[{r*Cos[phi] - (r^2*Cos[2*phi])/2, X -(r*Sin[phi]) - (r^2*Sin[2*phi])/2, (4*r^(3/2)*Cos[(3*phi)/2])/3}, X {r, 0.0001, 1, 0.9999/8}, {phi, 0, 4Pi, Pi/12}] X X(* rotaionally symmetric parametric surface *) X Xchapter3 := X ParametricPlot3D[ X {r Cos[Cos[r]] Cos[psi], r Cos[Cos[r]] Sin[psi], r Sin[Cos[r]]}, X {r, 0.001, 9Pi/2 + 0.001, Pi/16}, {psi, 0, 3Pi/2, Pi/16}] X X(* Fractal tile *) X Xiterations = 5; Xom7 = N[-1+Sqrt[-3]]/2; l7=om7-2 Xr7 = {0, 1,-1,om7,-om7,om7+1,-om7-1} Xg7[x_] := Flatten[Outer[Plus, r7 , l7 x]] X Xchapter4 := ( X points = Point[{Re[#],Im[#]}]& /@ Nest[g7, {0.}, iterations]; X graph4 = Graphics[Prepend[points, PointSize[0.003]]]; X Show[graph4, AspectRatio->1, Axes->None, Framed->True] X ) X X(* Sphere with random holes *) X Xchapter5 := Show[ Graphics3D[Select[Sphere[][[1]], Random[]>0.5&]] ] X X(* Saddle surface *) X Xchapter6 := CylindricalPlot3D[r^2 Cos[2 phi], X {r, 0, 1/2, 1/16}, {phi, 0, 2Pi, 2Pi/24}] X X(* Van-der-Pol equation *) X Xchapter7 := X Block[{vdp, eps = 1.5, x, xdot}, X vdp = RungeKutta[{xdot, eps (1 - x^2) xdot - x}, {x, xdot}, X {2, 0}, {4Pi, 0.05}]; X ListPlot[vdp, PlotJoined->True, AspectRatio -> Automatic] X ] X X X(* Fourier approximations of saw-tooth *) X Xl5 = Table[ Sum[Sin[i x]/i, {i, n}], {n, 5} ]; X Xchapter9 := Plot[ Release[l5], {x, -0.3, 2Pi+0.3}, Framed->True ] X X(* spiral with varying radius *) X Xchapter10 := X ParametricPlot3D[{r (1 + phi/2) Cos[phi], r (1 + phi/2) Sin[phi], -phi/2}, X {r, 0.1, 1.1, 0.125}, {phi, 0, 11Pi/2, Pi/12}] X X(* diagonally shaded surface *) X Xchapter11 := X SphericalPlot3D[ {Sin[theta], X FaceForm[GrayLevel[0.05 + 0.9 Sin[2theta + phi]^2], X GrayLevel[0.05 + 0.9 Sin[2theta - phi]^2]]}, X {theta, 0, Pi, Pi/24}, {phi, 0, 3Pi/2, Pi/12}, X Lighting->False ] X X(* Random walk *) X XappendixA := RandomWalk[5000] X X(* Great icosahedron, vertices computed from icosahedron *) X XAdjacentTo[face_, flist_] := Select[flist, Length[Intersection[face, #]] == 2&] X XOpposite[face_, flist_] := X Block[ {adjacent, next}, X adjacent = AdjacentTo[ face, flist ]; X next = AdjacentTo[#, flist]& /@ adjacent; X next = Complement[#, {face}]& /@ next; X Flatten[ Intersection @@ #& /@ next ] X ] X XAppendTo[Polyhedra, GreatIcosahedron] X XGreatIcosahedron/: Vertices[GreatIcosahedron] = Vertices[Icosahedron]; X XGreatIcosahedron/: Faces[GreatIcosahedron] = X Opposite[#, Faces[Icosahedron]]& /@ Faces[Icosahedron]; X XappendixB := Show[ Polyhedron[GreatIcosahedron] ] END_OF_FILE if test 3574 -ne `wc -c <'Examples/BookPictures.m'`; then echo shar: \"'Examples/BookPictures.m'\" unpacked with wrong size! fi # end of 'Examples/BookPictures.m' fi if test -f 'Examples/ComplexMap.ex' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Examples/ComplexMap.ex'\" else echo shar: Extracting \"'Examples/ComplexMap.ex'\" \(1900 characters\) sed "s/^X//" >'Examples/ComplexMap.ex' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XNeeds["RMPackages`ComplexMap`"] X X(* Cartesian coordinate lines *) X Xb004in7 := CartesianMap[ Identity, {-Pi/2, Pi/2, Pi/14}, {-1, 1, 2/10} ] X X(* Sin[] *) X Xb005in4 := CartesianMap[ Sin, {-Pi/2, Pi/2, Pi/14}, {-1, 1, 2/10} ] X X(* Cos[] *) X Xb007in2 := CartesianMap[ Cos, {0.2, Pi-0.2, (Pi-0.4)/19}, {-2, 2, 4/16} ] X X(* Exp[] *) X Xb011in4 := CartesianMap[ Exp, {-1, 1, 0.2}, {-2, 2, 0.2} ] X X(* polar coordinate lines *) X Xb012in5 := PolarMap[ Identity, {0, 1, 0.1}, {0, 2Pi, 2Pi/24} ] X X(* Log[] *) X Xb014in2 := PolarMap[ Log, {0.1, 10, 0.5}, {-3, 3, 0.15} ] X X(* complex conjugate *) X Xb014in3 := PolarMap[ 1/Conjugate[#]&, {0.1, 5.1, 0.5}, {-Pi, Pi, 2Pi/24} ] X X(* Zeta[] *) X Xb017in4 := CartesianMap[ Zeta, {0.1, 0.9}, {0, 20}, PlotPoints -> 25 ] X X(* Sqrt[] *) X Xb018in5 := PolarMap[ Sqrt, {1}, {-Pi - 0.0001, Pi}, PlotPoints -> 25 ] X X(* test examples from Section 1.7 *) X X(* some PostScript interpreters might croak on these *) X X<< Examples/ComplexTest.m X Xb028in3 := CartesianMap[ f, {-2, 2, 1/3}, {-2, 2, 1/3}, Axes->None ] X Xb028in4 := CartesianMap[ 1/Conjugate[#]&, {-2, 2, 0.2}, {-2, 2, 0.2} ] X X X(* Moebius transform *) X Xb059in3 := PolarMap[ (# - I)/(2# - 2)&, {4}, {-Pi, Pi, 2Pi/25} ] X X(* Exp[] *) X Xb066in9 := PolarMap[Exp, {1}, {-Pi, Pi}, X PlotPoints->25, Axes->None, Framed->True] END_OF_FILE if test 1900 -ne `wc -c <'Examples/ComplexMap.ex'`; then echo shar: \"'Examples/ComplexMap.ex'\" unpacked with wrong size! fi # end of 'Examples/ComplexMap.ex' fi if test -f 'RMPackages/ComplexMap.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/ComplexMap.m'\" else echo shar: Extracting \"'RMPackages/ComplexMap.m'\" \(3727 characters\) sed "s/^X//" >'RMPackages/ComplexMap.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`ComplexMap`"] X XCartesianMap::usage = "CartesianMap[f, {x0, x1, (dx)}, {y0, y1, (dy)}, options...] plots X the image of the cartesian coordinate lines under the function f. X The default values of dx and dy are chosen so that the number of lines X is equal to the value of the option PlotPoints of Plot3D[]" X XPolarMap::usage = "PolarMap[f, {r0:0, r1, (dr)}, {phi0, phi1, (dphi)}, options...] plots X the image of the polar coordinate lines under the function f. X The default values of dr and dphi are chosen so that the number of lines X is equal to the value of the option PlotPoints of Plot3D[]. X The default for the phi range is {0, 2Pi}." X XBegin["`Private`"] X Xhuge = 10.0^6 X XSplitLine[vl_] := X Block[{vll, pos, linelist = {}, low, high}, X vll = If[NumberQ[#], #, Indeterminate]& /@ vl; X pos = Flatten[ Position[vll, Indeterminate] ]; X pos = Union[ pos, {0, Length[vll]+1} ]; X Do[ low = pos[[i]]+1; X high = pos[[i+1]]-1; X If[ low < high, AppendTo[linelist, Take[vll, {low, high}]] ], X {i, 1, Length[pos]-1}]; X linelist X ] X XMakeLines[points_] := X Block[{lines, newpoints}, X newpoints = points /. X { z_?NumberQ :> huge z/Abs[z] /; Abs[z] > huge, X z_?NumberQ :> 0.0 /; Abs[z] < 1/huge, X DirectedInfinity[z_] :> huge z/Abs[z] }; X lines = Join[ newpoints, Transpose[newpoints] ]; X lines = Flatten[ SplitLine /@ lines, 1 ]; X lines = Map[ {Re[#], Im[#]}&, lines, {2} ]; X lines = Map[ Line, lines ]; X Graphics[lines] X ] X XFilterOptions[ command_Symbol, opts___ ] := X Block[{keywords = First /@ Options[command]}, X Sequence @@ Select[ {opts}, MemberQ[keywords, First[#]]& ] X ] X XCartesianMap[ f_, {x0_, x1_, dx_:Automatic}, {y0_, y1_, dy_:Automatic}, opts___ ] := X Block[ {x, y, points, plotpoints, ndx=N[dx], ndy=N[dy]}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X If[ dx === Automatic, ndx = N[(x1-x0)/(plotpoints-1)] ]; X If[ dy === Automatic, ndy = N[(y1-y0)/(plotpoints-1)] ]; X points = Table[ N[f[x + I y]], X {x, x0, x1, ndx}, {y, y0, y1, ndy} ]; X Show[ MakeLines[points], FilterOptions[Graphics, opts], X AspectRatio->Automatic, Axes->Automatic ] X ] /; NumberQ[N[x0]] && NumberQ[N[x1]] && NumberQ[N[y0]] && NumberQ[N[y1]] X (NumberQ[N[dx]] || dx === Automatic) && X (NumberQ[N[dy]] || dy === Automatic) X XPolarMap[ f_, {r0_:0, r1_, dr_:Automatic}, {phi0_, phi1_, dphi_:Automatic}, opts___ ] := X Block[ {r, phi, points, plotpoints, ndr=dr, ndphi=dphi}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X If[ dr === Automatic, ndr = N[(r1-r0)/(plotpoints-1)] ]; X If[ dphi === Automatic, ndphi = N[(phi1-phi0)/(plotpoints-1)] ]; X points = Table[ N[f[r Exp[I phi]]], X {r, r0, r1, ndr}, {phi, phi0, phi1, ndphi} ]; X Show[ MakeLines[points], FilterOptions[Graphics, opts], X AspectRatio->Automatic, Axes->Automatic ] X ] /; NumberQ[N[r0]] && NumberQ[N[r1]] && NumberQ[N[phi0]] && NumberQ[N[phi1]] X (NumberQ[N[dr]] || dr === Automatic) && X (NumberQ[N[dphi]] || dphi === Automatic) X XPolarMap[ f_, rRange_List, opts___Rule ] := X PolarMap[ f, rRange, {0, 2Pi}, opts ] X XEnd[ ] X XProtect[CartesianMap, PolarMap] X XEndPackage[ ] END_OF_FILE if test 3727 -ne `wc -c <'RMPackages/ComplexMap.m'`; then echo shar: \"'RMPackages/ComplexMap.m'\" unpacked with wrong size! fi # end of 'RMPackages/ComplexMap.m' fi if test -f 'RMPackages/MakeFunctions.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/MakeFunctions.m'\" else echo shar: Extracting \"'RMPackages/MakeFunctions.m'\" \(1942 characters\) sed "s/^X//" >'RMPackages/MakeFunctions.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`MakeFunctions`"] X XStepFunction::usage = "StepFunction[f, a, x0, b] defines rules for f X such that f[x] = a for x <= x0, f[x] = b for x > x0." X XLinearFunction::usage = "LinearFunction[f, a, x0, x1, b] defines rules for f X such that f[x] = a for x <= x0, f[x] = b for x >= x1 and X f increases linearly from a to b between x0 and x1." X XMakeRule::usage = "MakeRule[f, x, rhs] X globally defines the rule f[x_] := rhs." X XMakeRuleConditional::usage = "MakeRuleConditional[f, x, rhs, cond] X globally defines the rule f[x_] := rhs /; cond." X X XBegin["`Private`"] X X`x (* used for the dummy variable in the functions defined *) X XSetAttributes[MakeRule, HoldAll] X XMakeRule[f_Symbol, var_Symbol, rhs_] := X f[var_] := rhs X XSetAttributes[MakeRuleConditional, HoldAll] X XMakeRuleConditional[f_Symbol, var_Symbol, rhs_, condition_] := X (f[var_] := rhs /; condition) X X XStepFunction[f_Symbol, a_, x0_, b_] := ( X MakeRuleConditional[f, x, a, x <= x0]; X MakeRuleConditional[f, x, b, x > x0] X ) X XLinearFunction[f_Symbol, a_, x0_, x1_, b_] := X Block[{slope = (b-a)/(x1-x0)}, X MakeRuleConditional[f, x, a, x <= x0]; X MakeRuleConditional[f, x, Release[a + (x-x0) slope], x0 < x < x1]; X MakeRuleConditional[f, x, b, x >= x1] X ] X XEnd[] X XProtect[StepFunction, LinearFunction, MakeRule, MakeRuleConditional] X XEndPackage[] END_OF_FILE if test 1942 -ne `wc -c <'RMPackages/MakeFunctions.m'`; then echo shar: \"'RMPackages/MakeFunctions.m'\" unpacked with wrong size! fi # end of 'RMPackages/MakeFunctions.m' fi if test -f 'RMPackages/NewParametricPlot3D.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/NewParametricPlot3D.m'\" else echo shar: Extracting \"'RMPackages/NewParametricPlot3D.m'\" \(5894 characters\) sed "s/^X//" >'RMPackages/NewParametricPlot3D.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`NewParametricPlot3D`"] X XParametricPlot3D::usage = X "ParametricPlot3D[{x,y,z,(style)}, {u,u0,u1,(du)}, {v,v0,v1,(dv)}, (options..)] X plots a 3D parametric surface. Options are passed to Show[]" X XPointParametricPlot3D::usage = X "PointParametricPlot3D[{x,y,z}, {u,u0,u1,(du)}, {v,v0,v1,(dv)}, (options..)] X plots a two-parameter set of points in space. Options are passed to Show[]." X XSpaceCurve::usage = "SpaceCurve[{x,y,z}, {u,u0,u1,(du)}, (options..)] X plots a 3D parametric curve. Options are passed to Show[]." X XPointSpaceCurve::usage = "PointSpaceCurve[{x,y,z}, {u,u0,u1,(du)}, (options..)] X plots a one-parameter set of points in space. Options are passed to Show[]" X XSphericalPlot3D::usage = "SphericalPlot3D[r, {theta-range}, {phi-range}, (options...)] X plots r as a function of the angles theta and phi. X SphericalPlot3D[{r, style}, ...] uses style to render each surface patch" X XCylindricalPlot3D::usage = "CylindricalPlot3D[z, {r-range}, {phi-range}, (options...)] X plots z as a function of r and phi. X CylindricalPlot3D[{z, style}, ...] uses style to render each surface patch" X XBegin["`Private`"] X XMakePolygons[vl_List] := X Block[{l = vl, l1 = Map[RotateLeft, vl], mesh}, X mesh = {l, RotateLeft[l], RotateLeft[l1], l1}; X mesh = Map[Drop[#, -1]&, mesh, {1}]; X mesh = Map[Drop[#, -1]&, mesh, {2}]; X Polygon /@ Transpose[ Map[Flatten[#, 1]&, mesh] ] X ] /; TensorRank[vl] == 3 && Dimensions[vl][[3]] == 3 X XMakePolygons[vl_List] := X Block[{l, l1, mesh, cols}, X l = Map[Take[#, 3]&, vl, {2}]; (* the coords *) X l1 = Map[RotateLeft, l]; X cols = Map[#[[4]]&, vl, {2}]; (* the colors *) X mesh = {l, RotateLeft[l], RotateLeft[l1], l1}; X mesh = Map[Drop[#, -1]&, mesh, {1}]; X mesh = Map[Drop[#, -1]&, mesh, {2}]; X cols = Drop[cols, -1]; X cols = Map[Drop[#, -1]&, cols, {1}]; X mesh = Polygon /@ Transpose[ Map[Flatten[#, 1]&, mesh] ]; X Flatten[Transpose[{Flatten[cols], mesh}]] X ] /; TensorRank[vl] == 3 && Dimensions[vl][[3]] == 4 X X XFilterOptions[ command_Symbol, opts___ ] := X Block[{keywords = First /@ Options[command]}, X Sequence @@ Select[ {opts}, MemberQ[keywords, First[#]]& ] X ] X XAttributes[ParametricPlot3D] = {HoldFirst} X XParametricPlot3D[ fun_, X {u_, u0_, u1_, du_:Automatic}, {v_, v0_, v1_, dv_:Automatic}, opts___ ] := X Block[{plotpoints, ndu = N[du], ndv = N[dv]}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X If[ du === Automatic, ndu = N[(u1-u0)/(plotpoints-1)] ]; X If[ dv === Automatic, ndv = N[(v1-v0)/(plotpoints-1)] ]; X Show[ Graphics3D[MakePolygons[Table[ N[fun], X {u, u0, u1, ndu}, {v, v0, v1, ndv}] ]], X FilterOptions[Graphics3D, opts] ] X ] /; NumberQ[N[u0]] && NumberQ[N[u1]] && NumberQ[N[v0]] && NumberQ[N[v1]] X X XAttributes[PointParametricPlot3D] = {HoldFirst} X XPointParametricPlot3D[ fun_, X {u_, u0_, u1_, du_:Automatic}, {v_, v0_, v1_, dv_:Automatic}, opts___ ] := X Block[{plotpoints, ndu = N[du], ndv = N[dv]}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X If[ du === Automatic, ndu = N[(u1-u0)/(plotpoints-1)] ]; X If[ dv === Automatic, ndv = N[(v1-v0)/(plotpoints-1)] ]; X Show[ Graphics3D[Table[ Point[N[fun]], {u, u0, u1, ndu}, {v, v0, v1, ndv} ]], X FilterOptions[Graphics3D, opts] ] X ] /; NumberQ[N[u0]] && NumberQ[N[u1]] && NumberQ[N[v0]] && NumberQ[N[v1]] X X XAttributes[SpaceCurve] = {HoldFirst} X XSpaceCurve[ fun_, ul:{_, u0_, u1_, du_}, opts___ ] := X Show[ Graphics3D[Line[Table[ N[fun], ul ]]], FilterOptions[Graphics3D, opts] ] /; X NumberQ[N[u0]] && NumberQ[N[u1]] && NumberQ[N[du]] X XSpaceCurve[ fun_, {u_, u0_, u1_}, opts___ ] := X Block[{plotpoints}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X SpaceCurve[ fun, {u, u0, u1, (u1-u0)/(plotpoints-1)}, opts ] X ] X X XAttributes[PointSpaceCurve] = {HoldFirst} X XPointSpaceCurve[ fun_, ul:{_, u0_, u1_, du_}, opts___ ] := X Show[ Graphics3D[Table[ Point[N[fun]], ul ]], FilterOptions[Graphics3D, opts] ] /; X NumberQ[N[u0]] && NumberQ[N[u1]] && NumberQ[N[du]] X XPointSpaceCurve[ fun_, {u_, u0_, u1_}, opts___ ] := X Block[{plotpoints}, X plotpoints = PlotPoints /. {opts} /. Options[Plot3D]; X PointSpaceCurve[ fun, {u, u0, u1, (u1-u0)/(plotpoints-1)}, opts ] X ] X X XAttributes[SphericalPlot3D] = {HoldFirst} X XSphericalPlot3D[ {r_, style_}, tlist:{theta_, __}, plist:{phi_, __}, opts___ ] := X Block[{rs}, X ParametricPlot3D[ {(rs = r) Sin[theta] Cos[phi], X rs Sin[theta] Sin[phi], X rs Cos[theta], X style}, X tlist, plist, opts ] X ] X XSphericalPlot3D[ r_, tlist:{theta_, __}, plist:{phi_, __}, opts___ ] := X ParametricPlot3D[ r{Sin[theta] Cos[phi], X Sin[theta] Sin[phi], X Cos[theta]}, X tlist, plist, opts ] X X XAttributes[CylindricalPlot3D] = {HoldFirst} X XCylindricalPlot3D[ {z_, style_}, rlist:{r_, __}, plist:{phi_, __}, opts___ ] := X ParametricPlot3D[{r Cos[phi], r Sin[phi], z, style}, rlist, plist, opts] X XCylindricalPlot3D[ z_, rlist:{r_, __}, plist:{phi_, __}, opts___ ] := X ParametricPlot3D[{r Cos[phi], r Sin[phi], z}, rlist, plist, opts] X XEnd[] X XProtect[ParametricPlot3D, PointParametricPlot3D, SpaceCurve, X PointSpaceCurve, SphericalPlot3D, CylindricalPlot3D] X XEndPackage[] END_OF_FILE if test 5894 -ne `wc -c <'RMPackages/NewParametricPlot3D.m'`; then echo shar: \"'RMPackages/NewParametricPlot3D.m'\" unpacked with wrong size! fi # end of 'RMPackages/NewParametricPlot3D.m' fi if test -f 'RMPackages/ReIm.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/ReIm.m'\" else echo shar: Extracting \"'RMPackages/ReIm.m'\" \(2889 characters\) sed "s/^X//" >'RMPackages/ReIm.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`ReIm`"] X X(* to declare a variable x to be real, define x/: Im[x] = 0 *) X X(* no exports *) X XBegin["`Private`"] X Xprotected = Unprotect[Re,Im, Abs, Conjugate, Arg] X X(* fundamental rules, Im[x]==0 serves as our test for 'reality' *) X XRe[x_] := x /; Im[x] == 0 XConjugate[x_] := x /; Im[x] == 0 XConjugate[x_] := -x /; Re[x] == 0 X X(* there must not be a rule for Im[x] in terms of Re[x] !! *) X X(* things known to be real *) X XIm[Re[ _ ]] := 0 XIm[Im[ _ ]] := 0 XIm[Abs[ _ ]] := 0 XIm[Arg[ _ ]] := 0 X X(* arithmetic *) X XRe[x_ + y_] := Re[x] + Re[y] XIm[x_ + y_] := Im[x] + Im[y] X XRe[x_ y_] := Re[x] Re[y] - Im[x] Im[y] XIm[x_ y_] := Re[x] Im[y] + Im[x] Re[y] X XRe[ 1/x_ ] := Re[x] / (Re[x]^2 + Im[x]^2) XIm[ 1/x_ ] := -Im[x] / (Re[x]^2 + Im[x]^2) X XRe[E^x_] := Cos[Im[x]] Exp[Re[x]] XIm[E^x_] := Sin[Im[x]] Exp[Re[x]] X XIm[x_^2] := 2 Re[x] Im[x] X XRe[ x_^n_Integer ] := X Block[{a, b}, X a = Round[n/2]; b = n-a; X Re[x^a] Re[x^b] - Im[x^a] Im[x^b] X ] X XIm[ x_^n_Integer ] := X Block[{a, b}, X a = Round[n/2]; b = n-a; X Re[x^a] Im[x^b] + Im[x^a] Re[x^b] X ] X XRe[x_Integer^n_Rational] := 0 /; IntegerQ[2n] && x<0 XIm[x_Integer^n_Rational] := X (-x)^n (-1)^((Numerator[n]-1)/2) /; IntegerQ[2n] && x<0 X XRe[x_Integer^n_Rational] := x^n /; OddQ[Denominator[n]] || x>0 XIm[x_Integer^n_Rational] := 0 /; OddQ[Denominator[n]] || x>0 X XRe[(-1)^n_Rational] := Cos[n Pi] XIm[(-1)^n_Rational] := Sin[n Pi] X X(* functions *) X XRe[Sin[x_]] := Sin[Re[x]] Cosh[Im[x]] XIm[Sin[x_]] := Cos[Re[x]] Sinh[Im[x]] X XRe[Cos[x_]] := Cos[Re[x]] Cosh[Im[x]] XIm[Cos[x_]] := -Sin[Re[x]] Sinh[Im[x]] X XRe[Log[r_?Positive]] := Log[r] XIm[Log[r_?Positive]] := 0 XRe[Log[r_?Negative]] := Log[-r] XIm[Log[r_?Negative]] := Pi X XRe[Log[z_]] := (1/2) Log[Re[z]^2 + Im[z]^2] XIm[Log[z_]] := Arg[z] X XRe[Log[a_ b_]] := Re[Log[a] + Log[b]] XIm[Log[a_ b_]] := Im[Log[a] + Log[b]] XRe[Log[a_^c_]] := Re[c Log[a]] XIm[Log[a_^c_]] := Im[c Log[a]] X XRe[Tan[x_]] := Re[Sin[x]/Cos[x]] XIm[Tan[x_]] := Im[Sin[x]/Cos[x]] X X(* conjugates *) X XRe[Conjugate[z_]] := Re[z] XIm[Conjugate[z_]] := -Im[z] X XConjugate[x_+y_]:= Conjugate[x]+Conjugate[y] XConjugate[x_ y_]:= Conjugate[x] Conjugate[y] XConjugate[x_^n_Integer]:= Conjugate[x]^n XConjugate[Conjugate[x_]]:= x X XProtect[Release[protected]] X XEnd[] XEndPackage[] END_OF_FILE if test 2889 -ne `wc -c <'RMPackages/ReIm.m'`; then echo shar: \"'RMPackages/ReIm.m'\" unpacked with wrong size! fi # end of 'RMPackages/ReIm.m' fi if test -f 'RMPackages/RungeKutta.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/RungeKutta.m'\" else echo shar: Extracting \"'RMPackages/RungeKutta.m'\" \(1689 characters\) sed "s/^X//" >'RMPackages/RungeKutta.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`RungeKutta`"] X XRungeKutta::usage = "RungeKutta[{e1,e2,..}, {y1,y2,..}, {a1,a2,..}, {t1, dt}] X numerically integrates the ei as functions of the yi with inital values ai. X The integration proceeds in steps of dt from 0 to t1. X RungeKutta[{e1,e2,..}, {y1,y2,..}, {a1,a2,..}, {t, t0, t1, dt}] integrates X a time-dependent system from t0 to t1." X XBegin["`Private`"] X XRKStep[f_, y_, y0_, dt_] := X Block[{ k1, k2, k3, k4 }, X k1 = dt N[ f /. Thread[y -> y0] ]; X k2 = dt N[ f /. Thread[y -> y0 + k1/2] ]; X k3 = dt N[ f /. Thread[y -> y0 + k2/2] ]; X k4 = dt N[ f /. Thread[y -> y0 + k3] ]; X y0 + (k1 + 2 k2 + 2 k3 + k4)/6 X ] X XRungeKutta[f_List, y_List, y0_List, {t1_, dt_}] := X NestList[ RKStep[f, y, #, N[dt]]&, N[y0], Round[N[t1/dt]] ] /; X Length[f] == Length[y] == Length[y0] X XRungeKutta[f_List, y_List, y0_List, {t_, t0_, t1_, dt_}] := X Block[{res}, X res = RungeKutta[ Append[f, 1], Append[y, t], Append[y0, t0], {t1 - t0, dt} ]; X Drop[#, -1]& /@ res X ] /; Length[f] == Length[y] == Length[y0] X XEnd[] X XProtect[RungeKutta] X XEndPackage[] END_OF_FILE if test 1689 -ne `wc -c <'RMPackages/RungeKutta.m'`; then echo shar: \"'RMPackages/RungeKutta.m'\" unpacked with wrong size! fi # end of 'RMPackages/RungeKutta.m' fi if test -f 'RMPackages/Skeleton.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/Skeleton.m'\" else echo shar: Extracting \"'RMPackages/Skeleton.m'\" \(1963 characters\) sed "s/^X//" >'RMPackages/Skeleton.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X X(* Skeleton.m -- a skeletal package *) X X(* set up the package context, included any imports *) X XBeginPackage["RMPackages`Skeleton`", "RMPackages`Package1`", "RMPackages`Package2`"] X XNeeds["RMPackages`Package3`"] (* read in any hidden imports *) X X X(* usage messages for the exported functions and the context itself *) X XSkeleton::usage = "Skeleton.m is a package that does nothing." X XFunction1::usage = "Function1[n] does nothing." X XFunction2::usage = "Function2[n, (m:17)] does even more nothing." X X XBegin["`Private`"] (* begin the private context *) X X X(* unprotect any system functions for which rules will be defined *) X Xprotected = Unprotect[ Sin, Cos ] X X X(* definition of auxiliary functions and local (static) variables *) X XAux[f_] := Do[something] X Xstaticvar = 0 X X X(* error messages for the exported objects *) X XSkeleton::badarg = "You twit, you called `1` with argument `2`!" X X X(* definition of the exported functions *) X XFunction1[n_] := n X XFunction2[n_, m_:17] := n m /; n < 5 || Message[Skeleton::badarg, Function2, n] X X X(* rules for system functions *) X XSin/: Sin[x_]^2 := 1 - Cos[x]^2 X X XProtect[ Release[protected] ] (* restore protection of system symbols *) X XEnd[] (* end the private context *) X XProtect[ Function1, Function2 ] (* protect exported symbols *) X XEndPackage[] (* end the package context *) END_OF_FILE if test 1963 -ne `wc -c <'RMPackages/Skeleton.m'`; then echo shar: \"'RMPackages/Skeleton.m'\" unpacked with wrong size! fi # end of 'RMPackages/Skeleton.m' fi if test -f 'RMPackages/Struve.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/Struve.m'\" else echo shar: Extracting \"'RMPackages/Struve.m'\" \(1819 characters\) sed "s/^X//" >'RMPackages/Struve.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`Struve`"] X XStruveH::usage "StruveH[nu, z] gives the Struve function." X XBegin["`Private`"] X XAttributes[StruveH] = {Listable} X X(* special values *) X XStruveH[r_Rational?Positive, z_] := X BesselY[r, z] + X Sum[Gamma[m + 1/2] (z/2)^(-2m + r - 1)/Gamma[r + 1/2 - m], {m, 0, r-1/2}]/Pi /; X Denominator[r] == 2 X XStruveH[r_Rational?Negative, z_] := X (-1)^(-r-1/2) BesselJ[-r, z] /; Denominator[r] == 2 X X(* Series expansion *) X XStruveH/: Series[StruveH[nu_?NumberQ, z_], {z_, 0, ord_Integer}] := X (z/2)^(nu + 1) Sum[ (-1)^m (z/2)^(2m)/Gamma[m + 3/2]/Gamma[m + nu + 3/2], X {m, 0, (ord-nu-1)/2} ] + O[z]^(ord+1) X X(* numerical evaluation *) X XStruveH[nu_?NumberQ, z_?NumberQ] := X Block[{s=0, so=-1, m=0, prec = Precision[z], X z2 = -(z/2)^2,k1 = 3/2, k2 = nu + 3/2, g1, g2, zf}, X zf = (z/2)^(nu+1); g1 = Gamma[k1]; g2 = Gamma[k2]; X While[so != s, X so = s; s += N[zf/g1/g2, prec]; X g1 *= k1; g2 *= k2; zf *= z2; X k1++; k2++; m++ X ]; X s X ] X X(* derivatives *) X XDerivative[0, n_Integer?Positive][StruveH][nu_, z_] := X D[ (StruveH[nu-1, z] - StruveH[nu+1, z] + (z/2)^nu/Sqrt[Pi]/Gamma[nu + 3/2])/2, X {z, n-1} ] X XEnd[] X XProtect[StruveH] X XEndPackage[] END_OF_FILE if test 1819 -ne `wc -c <'RMPackages/Struve.m'`; then echo shar: \"'RMPackages/Struve.m'\" unpacked with wrong size! fi # end of 'RMPackages/Struve.m' fi if test -f 'RMPackages/TrigSimplification.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'RMPackages/TrigSimplification.m'\" else echo shar: Extracting \"'RMPackages/TrigSimplification.m'\" \(2811 characters\) sed "s/^X//" >'RMPackages/TrigSimplification.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["RMPackages`TrigSimplification`"] X XTrigNormal::usage = "TrigNormal[e] puts expressions with trigonometric X functions into normal form." X XTrigLinear::usage = "TrigLinear[e] expands products and powers of trigonometric X functions." X XTrigArgument::usage = "TrigArgument[e] writes trigonometric functions of multiple X angles as products of functions of that angle." X XBegin["`Private`"] X XTrigCanonicalRules = { X Sin[n_?Negative x_.] :> -Sin[-n x], X Cos[n_?Negative x_.] :> Cos[-n x], X Tan[n_?Negative x_.] :> -Tan[-n x], X Sin[n_?Negative x_ + y_] :> - Sin[-n x - y] /; OrderedQ[{x, y}], X Cos[n_?Negative x_ + y_] :> Cos[-n x - y] /; OrderedQ[{x, y}], X Tan[n_?Negative x_ + y_] :> - Tan[-n x - y] /; OrderedQ[{x, y}] X} X XTrigLinearRules = { X Sin[x_] Sin[y_] :> Cos[x-y]/2 - Cos[x+y]/2, X Cos[x_] Cos[y_] :> Cos[x+y]/2 + Cos[x-y]/2, X Sin[x_] Cos[y_] :> Sin[x+y]/2 + Sin[x-y]/2, X Sin[x_]^(m1_Integer?EvenQ) :> Block[{m=Abs[m1]}, X (2^(-m+1) X (Sum[(-1)^(m/2-k) Binomial[m,k] Cos[(m-2k)x], {k, 0, m/2-1}]+ X Binomial[m,m/2]/2))^Sign[m1] ], X X Cos[x_]^(m1_Integer?EvenQ) :> Block[{m=Abs[m1]}, X (2^(-m+1) X (Sum[Binomial[m,k] Cos[(m-2k)x], {k, 0, m/2-1}] + X Binomial[m,m/2]/2))^Sign[m1] ], X X Sin[x_]^(m1_Integer?OddQ) :> Block[{m=Abs[m1]}, X (2^(-m+1) X Sum[(-1)^((m-1)/2-k) X Binomial[m,k] Sin[(m-2k)x], {k, 0, (m-1)/2}])^Sign[m1] ], X X Cos[x_]^(m1_Integer?OddQ) :> Block[{m=Abs[m1]}, X (2^(-m+1) X Sum[Binomial[m,k] Cos[(m-2k)x], {k, 0, (m-1)/2}])^Sign[m1] ] X} X XTrigArgumentRules = { X Sin[x_ + y_] :> Sin[x] Cos[y] + Sin[y] Cos[x], X Cos[x_ + y_] :> Cos[x] Cos[y] - Sin[x] Sin[y], X Sin[n_Integer?Positive x_.] :> X Sum[ (-1)^((i-1)/2) Binomial[n, i] Cos[x]^(n-i) Sin[x]^i, X {i, 1, n, 2} ], X Cos[n_Integer?Positive x_.] :> X Sum[ (-1)^(i/2) Binomial[n, i] Cos[x]^(n-i) Sin[x]^i, X {i, 0, n, 2} ] X} X XSetAttributes[{TrigNormal, TrigLinear, TrigArgument}, Listable] X XTrigNormal[e_] := e /. TrigCanonicalRules X XTrigLinear[e_] := X FixedPoint[ Expand[# //. TrigLinearRules /. TrigCanonicalRules]&, e ] X XTrigArgument[e_] := X Together[ FixedPoint[ (# //. TrigArgumentRules /. TrigCanonicalRules)&, e ] ] X XEnd[] X XProtect[TrigNormal, TrigLinear, TrigArgument] X XEndPackage[] END_OF_FILE if test 2811 -ne `wc -c <'RMPackages/TrigSimplification.m'`; then echo shar: \"'RMPackages/TrigSimplification.m'\" unpacked with wrong size! fi # end of 'RMPackages/TrigSimplification.m' fi if test -f 'Utilities/PlotUtilities.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Utilities/PlotUtilities.m'\" else echo shar: Extracting \"'Utilities/PlotUtilities.m'\" \(1901 characters\) sed "s/^X//" >'Utilities/PlotUtilities.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XBeginPackage["Utilities`PlotUtilities`", "Graphics`Colors`"] X XArgColor::usage = "ArgColor[z] gives a color value whose hue is proportional X to the argument of the complex number z." XArgShade::usage = "ArgShade[z] gives a gray level proportional X to the argument of the complex number z." X XColorCircle::usage = "ColorCircle[r, (light:1)] gives a color value whose hue X is proportional to r (mod 2Pi) with lightness light." X XBegin["`Private`"] X XArgColor[z_] := RGBColor[1,1,1] /; z == 0.0 XArgColor[z_] := HSBColor[ N[(Pi + Arg[z])/(2Pi)], 1, 1 ] X XArgShade[z_] := GrayLevel[1] /; z == 0.0 XArgShade[z_] := GrayLevel[N[(Pi + Arg[z])/(2Pi)] ] X XColorCircle[arg_, light_:1.0] := X Block[{ mh = 3.0 Mod[N[arg / Pi], 2.0], ind, frac, frac1, scale }, X ind = Floor[mh]; frac = mh - ind; X scale = Max[ Min[light, 1.0], 0.0 ]; X frac1 = scale(1.0-frac); frac *= scale; X Switch[ind, X 0, RGBColor[scale, frac, 0.0], X 1, RGBColor[frac1, scale, 0.0], X 2, RGBColor[0.0, scale, frac], X 3, RGBColor[0.0, frac1, scale], X 4, RGBColor[frac, 0.0, scale], X 5, RGBColor[scale, 0.0, frac1], X 6, RGBColor[scale, frac, 0.0] X ] X ] /; NumberQ[N[arg]] X XColorCircle[_, light_:1.0] := RGBColor[light, light, light] X XEnd[] X XProtect[ArgColor, ArgShade, ColorCircle] X XEndPackage[] END_OF_FILE if test 1901 -ne `wc -c <'Utilities/PlotUtilities.m'`; then echo shar: \"'Utilities/PlotUtilities.m'\" unpacked with wrong size! fi # end of 'Utilities/PlotUtilities.m' fi if test -f 'Utilities/Transcript.m' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Utilities/Transcript.m'\" else echo shar: Extracting \"'Utilities/Transcript.m'\" \(1683 characters\) sed "s/^X//" >'Utilities/Transcript.m' <<'END_OF_FILE' X(********************************************************************* X X Copyright 1989 by Roman E. Maeder X X Adapted from X Roman E. Maeder: Programming in Mathematica, Addison-Wesley, 1989. X X Permission is hereby granted to make copies of this file for X any purpose other than direct profit, or as part of a X commercial product, provided this copyright notice is left X intact. Sale, other than for the cost of media, is prohibited. X X Permission is hereby granted to reproduce part or all of X this file, provided that the source is acknowledged. X X *********************************************************************) X X XTranscript::usage = "Transcript[filename] opens filename for a transcript X of the current session. It clobbers $Post" XEndTranscript::usage = "EndTranscript[] closes the transcript opened with Transcript[]." X XBegin["`Private`"] X X`transcript="" X XTranscript[filename_String] := ( X transcript = OpenWrite[filename]; X If[ Head[transcript] =!= String, Return[transcript] ]; X $Post := ($Post := MakeTranscript; Identity); X transcript X ) X XEndTranscript[] := ( X MakeTranscript; X $Post =. ; X Close[transcript] X ) X XGetInputForm[v_ValueList] := X Block[{input}, X input = MapAt[HoldForm, v, {1, 2}] [[1,2]]; X input = Characters[ToString[InputForm[input]]]; X input = Drop[input, {1, 9}]; (* HoldForm[ *) X input = Drop[input, -1]; (* ] *) X StringJoin @@ input X ] X XMakeTranscript := X Block[{input, output}, X input = GetInputForm[Take[DownValue[In], {-2}]]; X output = GetInputForm[Take[DownValue[Out], {-1}]]; X WriteString[transcript, "(* In[", $Line-1, "]=\n", input, "\n*)\n"]; X WriteString[transcript, "\n", output, "\n\n"]; X Identity X ] X XEnd[] XNull END_OF_FILE if test 1683 -ne `wc -c <'Utilities/Transcript.m'`; then echo shar: \"'Utilities/Transcript.m'\" unpacked with wrong size! fi # end of 'Utilities/Transcript.m' fi echo shar: End of archive 2 \(of 2\). cp /dev/null ark2isdone MISSING="" for I in 1 2 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked both archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0