(*:Mathematica Version: 5.0 *) (*:Copyright: Copyright 2005, Carlo Teubner *) (*:Context: ComplexMapExt` *) (*:Title: CartesianMap and PolarMap *) (*:Author: Carlo Teubner *) (*:Keywords: Cartesian coordinates, polar coordinates, lines, mapping, \ ComplexMap *) (*:Requirements: None. *) (*:Warnings: None. *) (*:Sources: Inspired and influenced by Graphics`ComplexMap` *) (*:Summary: This package plots the images of a user-defined subset of Cartesian or polar coordinate lines under a user-defined function. *) BeginPackage["ComplexMapExt`"] Unprotect[ CartesianMap, PolarMap, Lines, ColorFunction ] CartesianMap::usage = "CartesianMap[region, func, z, {x0, x1, (dx)}, {y0, y1, \ (dy)}] plots the Cartesian coordinate grid in the given region (an inequality in z) under the \ map func (in z). You can give a list of functions; these will be combined into a \ GraphicsArray." PolarMap::usage = "PolarMap[region, func, z, {r0, r1, (dr)}, {\[Theta]0, \ \[Theta]1, (d\[Theta])}] plots the polar coordinate grid in the given region (an inequality in z) under the map \ func (in z). You can give a list of functions; these will be combined into a \ GraphicsArray. You may leave out the range specification for \[Theta]; it will then be \ assumed to be {0, 2\[Pi]}." Lines::usage = "An option for CartesianMap and PolarMap; the number of grid \ lines in each direction. Can be a number or a pair of numbers." $Lines::usage = "The default value for the Lines option." ColorFunction::usage = "A color function to be applied to the grid lines, \ before the transformation is applied. Takes the two coordinates (x and y or r and \[Theta], \ respectively), scaled down to lie between 0 and 1." Begin["`Private`"] Needs["Utilities`FilterOptions`"] $Lines = 40; Options[CartesianMap] = Options[PolarMap] = { Lines :> $Lines, ColorFunction \ :> None } vars = { s, t } makenum = { CartesianMap :> s+I*t, PolarMap :> s*Exp[I*t] } CartesianMap[region_, funcs_List, z_?AtomQ, {x0_, x1_, dx_:Automatic}, {y0_, y1_, dy_:Automatic}, \ opts___?OptionQ] := Show[GraphicsArray[Evaluate[Thread[ Unevaluated[genericMap[CartesianMap, \ region, funcs, z, {x0,x1,dx},{y0,y1,dy}, opts]], List, {3,3} ]]]] /; NumericQ[x0] && NumericQ[x1] && NumericQ[y0] && NumericQ[y1] && (NumericQ[dx] || dx === Automatic) && (NumericQ[dy] || dy === Automatic) CartesianMap[region_, func_, z_?AtomQ, {x0_, x1_, dx_:Automatic}, {y0_, y1_, dy_:Automatic}, \ opts___?OptionQ] := Show[genericMap[ CartesianMap, region, func, z, {x0,x1,dx},{y0,y1,dy}, opts \ ]] /; NumericQ[x0] && NumericQ[x1] && NumericQ[y0] && NumericQ[y1] && (NumericQ[dx] || dx === Automatic) && (NumericQ[dy] || dy === Automatic) PolarMap[region_, func_, z_, r_List, opts___?OptionQ] := PolarMap[region, func, z, r, {0, 2Pi}, opts] PolarMap[region_, funcs_List, z_?AtomQ, {r0_, r1_, dr_:Automatic}, {p0_, p1_, dp_:Automatic}, \ opts___?OptionQ] := Show[GraphicsArray[Thread[ Unevaluated[genericMap[PolarMap, region, funcs, \ z, {r0,r1,dr}, {p0,p1,dp}, opts]], List, {3,3} ]]] /; NumericQ[r0] && NumericQ[r1] && NumericQ[p0] && NumericQ[p1] && (NumericQ[dr] || dr === Automatic) && (NumericQ[dp] || dp === Automatic) PolarMap[region_, func_, z_?AtomQ, {r0_, r1_, dr_:Automatic}, {p0_, p1_, dp_:Automatic}, \ opts___?OptionQ] := Show[genericMap[ PolarMap, region, func, z, {r0,r1,dr}, {p0,p1,dp}, opts ]] \ /; NumericQ[r0] && NumericQ[r1] && NumericQ[p0] && NumericQ[p1] && (NumericQ[dr] || dr === Automatic) && (NumericQ[dp] || dp === Automatic) genericMap[cmd_, region_, func_, z_, {s0_, s1_, ds_}, {t0_, t1_, dt_}, opts___?OptionQ] := Module[ {tbl, lines, dss, drr, cfun, width=s1-s0, height=t1-t0, num = cmd /. \ makenum}, {lines, cfun} = {Lines, ColorFunction} /. {opts} /. Options[cmd]; If[ Head[lines] =!= List, lines = {lines, lines} ]; dss = N[ If[ ds === Automatic, width/lines[[1]], ds ] ]; dtt = N[ If[ dt === Automatic, height/lines[[2]], dt ] ]; tbl = Table[ If[ region /. z -> num, v[s,t] ], {s,s0,s1,dss}, \ {t,t0,t1,dtt} ]; curv = If[cfun === None, curve, colorcurve]; Graphics[ Function[{rowcol,fi}, \ curv[num,Function[z,func],#,fi[[1]],cfun,s0,width,t0,height]& /@ DeleteCases[ Flatten[ Split[#, Head[#1]==Head[#2]& ]& /@ rowcol, 1 ], \ {Null, ___} ] ] ~MapIndexed~ { tbl, Transpose[tbl] }, FilterOptions[Graphics, opts], AspectRatio->Automatic, Axes->True ] ] curve[num_, func_, vs_, fi_, ___] := Module[{min = First[vs], max = Last[vs], vi = Mod[fi+1, 2, 1], z}, z = num /. { vars[[fi]] -> min[[fi]], vars[[vi]] -> (1-a)*min[[vi]] + \ a*max[[vi]] }; ParametricPlot[Through[{Re,Im}[func[z]]], {a,0,1}, \ DisplayFunction->Identity][[1]] ] colorcurve[num_, func_, vs_, fi_, cfun_, s0_,w_,t0_,h_] := Module[{vi = Mod[fi+1, 2, 1], var, fix}, {var, fix} = vars[[{vi,fi}]]; Table[ ParametricPlot[Through[{Re,Im}[func[ num /. { fix -> vs[[i,fi]], var -> (1-a)*vs[[i,vi]] + a*vs[[i+1,vi]] } ] ]], {a,0,1}, DisplayFunction->Identity][[1]] ~ Prepend ~ cfun[ ((vs[[i,1]]+vs[[i+1,1]])/2-s0)/w, ((vs[[i,2]]+vs[[i+1,2]])/2-t0)/h \ ], (* cfun @@ ( (Total@vs[[{i,i+1}]]/2 - {s0,t0}) / {w,h} ), -- Perhaps \ more elegant, but slower! *) {i, 1, Length[vs]-1}] ] End[ ] Protect[ CartesianMap, PolarMap, Lines, ColorFunction ] EndPackage[ ] (*:Tests: *) (*:Examples: *)