Note

This Mathematica notebook is from the WWW project A Visual Dictionary of Special Plane Curves. Copyright © 1995-2000 by Xah Lee. (http://xahlee.org/)

Packages and Initializations

Needs["Transform2DPlot`"]
Needs["InvertCircle`"]

Clear[grid, symmetricGrid]

grid::usage = "
grid[ {xMin, xMax, xStep}, {yMin, yMax}, angle]
will return a list of vertical lines from xMin, xMax in increment of xStep,
with height from yMin to yMax, and the final image is rotated angle radians.
Example: Show[ Graphics@ grid[{1,2,.2}, {0,1}, 0] ]";

grid[ {xMin_, xMax_, xStep_}, {yMin_, yMax_}, angle_] :=
	Line /@ Transpose[
	(N@ Table[ {Cos@angle, Sin@angle} i +#, {i,xMin,xMax,xStep}]&) /@
		({yMin #,yMax #}&)@ (N@{Cos@#,Sin@#}&)@ (angle+Pi/2)
	]

symmetricGrid::usage = "
symmetricGrid[ {xMin, xMax, xStep}, {yMin, yMax}, n]
returns a symmetric design that is equivalent to rotating
grid[ {xMin, xMax, xStep}, {yMin, yMax}, 0]
n times. Example:
Show[ Graphics@ symmetricGrid[{ -2, 10, 1}, {0,5}, 5] ]";

symmetricGrid[ {xMin_, xMax_, xStep_}, {yMin_, yMax_}, symmetry_] :=
	Transpose[
		(grid[ {xMin, xMax, xStep}, {yMin, yMax}, #]&) /@
		Range[0, 2 Pi- (2 Pi/symmetry/2), 2 Pi/symmetry]
	]

Note: Mathematica Large Circle Graphics bug

Note: A bug in Mathematica version 2.2 will cause plotting of large circle with small PlotRange to generate a PostScript error. To see whether this bug is on your version, evaluate the following cell.

Show[
	Graphics[
		Circle[{0,0},100]
	],
	PlotRange->{{99,101},{-1,1}},
	Axes->True
]

If the bug is not in your version, you should see an arc of a circle of radius 100. This bug will sometimes crash your machine for extremely large circles such as Circle[{10^15,0}, 10^15].

To get around this bug, the BEST solution is to increase PlotRange to include all parts of the circle.

Otherwise, you may break the circle into arcs by replacing any of Circle[{x,y},r] with several of Circle[{x,y},r,{tMin,tMax}], or by replacing
it with Line[...] that represents the same circle. To replace circles by arcs, use BreakCircle defined below. To replace circles by Lines, use BreakCircle2. However, both of these methods cannot deal with very large circles. With extremely larg circles, it is necessary to break it into many arcs or line segments that will result insufficient memory.

Clear[BreakCircle]

BreakCircle::usage = "
BreakCircle[ graphics1, (r:50), (n:10)]
will return graphics1 with any Circle[{x_,y_},r1_] primitive
whose radius r1 is greater than r
replaced by a list of n arcs that represents the same circle.
It is used as a
work around of a Mathematica v.2.2 bug of displaying Circle with large
radius.
Usage Example:
BreakCircle[ Circle[{0,0}, 100], 1, 4]";

BreakCircle[ gra_ , r_:50, n_:10] :=
Module[{},
	gra /. Circle[{x_,y_}, radius_] :>
		N@ If[ N@ radius > r,
			Table[
				Circle[{x,y}, radius, {th, th+ 2 Pi/n}],
				{th, 0, 2 Pi-2 Pi/n, 2 Pi/n}
			],
			Circle[{x,y}, radius]
		]
]

Clear[BreakCircle2]

BreakCircle2::usage = "
BreakCircle[ graphics1, maxArcLength ]
will return modified graphics1 with any Circle
whoes circumference is greater than maxArcLength
replaced by a Line that represents the circle,
such that any line segment is less than maxArcLength.
Disk is similarly replaced by Polygon.
It is used as a
work around of a Mathematica v.2.2 bug of displaying Circle with large
radius.
Usage Example: BreakCircle[ Circle[{0,0}, 2], 1]";

BreakCircle2[ gra_, maxLength_ ]:=
Module[{ml = N[maxLength]},
	(N[gra] /. { (Circle|Disk)[{c1_, c2_}, 0|0., ___] -> Point[{c1,c2}],
			Circle[{c1_, c2_}, r_?NumberQ] :> 
				With[{iStep = N[2 Pi/Ceiling[2 r Pi/ml]]},
		 			Line@ Table[ r {Cos@ t, Sin@ t}+{c1,c2},
						{t, 0, 2 Pi, iStep}
					]
				],
			Circle[{c1_, c2_}, {a_, b_}] :>
				With[{iStep = N[2 Pi/Ceiling[2 Pi Max[a,b]/ml]]},
						Line@ Table[ {a Cos@ t, b Sin@ t}+{c1,c2},
					{t, 0, 2 Pi, iStep}
					]
				],
			Circle[{c1_, c2_}, r_, {a_, b_}] :>
				With[{iStep = N[ (b-a)/Ceiling[2 r Pi/ml]]},
					Line@ Table[ r {Cos@ t, Sin@ t}+{c1,c2},
						{t, a, b, iStep}
					]
				],
			Disk[{c1_, c2_}, r_?NumberQ] :> 
				With[{iStep = N[2 Pi/Ceiling[2 r Pi/ml]]},
		 			Polygon@ Table[ r {Cos@ t, Sin@ t}+{c1,c2},
						{t, 0, 2 Pi, iStep}
					]
				],
			Disk[{c1_, c2_}, {a_, b_}] :>
				With[{iStep = N[2 Pi/Ceiling[2 Pi Max[a,b]/ml]]},
						Polygon@ Table[ {a Cos@ t, b Sin@ t}+{c1,c2},
					{t, 0, 2 Pi, iStep}
					]
				],
			Disk[{c1_, c2_}, r_, {a_, b_}] :>
				With[{iStep = N[ (b-a)/Ceiling[2 r Pi/ml]]},
					Polygon@ Table[ r {Cos@ t, Sin@ t}+{c1,c2},
						{t, a, b, iStep}
					]
				]
		}
	)
]

Show[
	BreakCircle[ Graphics[Circle[{0,0},100] ], 2, 30 ],
	PlotRange->{{99,101},{-1,1}},
	Axes->True
]

Inversion Graphics Gallery

This notebook contain codes that generates various artistic images using the idea of inversion.

Inversion of a set of identical circles lying on a line.

Clear[cir1, cir2, li1]
cir1 = 
        N[Table[{Circle[{-(i^2), 1}, 1], Circle[{(i^2), 1}, 1]}, {i,  .2, 
              10, (10/49)}]];

Show[Graphics@cir1, AspectRatio -> Automatic, 
      PlotRange -> {{-1, 1} 10, {-2, 5}}, 
      Axes -> True]

cir2 = N[{Circle[{0, -1.5}, 3]}];

Show[Graphics@cir2, AspectRatio -> Automatic, 
      Axes -> True]

li1 = N[Table[Hue[i], {i, 0, 1, (1/48)}]];
Show[
        Graphics[{Hue[ .7,  .2, 1], cir1, Hue[ .18], cir2, Thickness[ .007], 
            Transpose[{li1, InvertCircle[cir1, cir2]}]}], 
        AspectRatio -> Automatic, Axes -> False, 
        PlotRange -> {{-1, 1} 3.5, {-2, 5}}];

Inversion of parallel lines.

Clear[n, r, symmetry, gp1, gp2, maxR, minR, usingDisk]

n = 30; (* number of grid lines per symmetry *)
symmetry = 4;

colorMethod = 1; (* choose an integer from 1 to 3 *)
usingDisk = False; (* choose True or False *)

r = 7; (* do not change. *)
gp1 = symmetricGrid[{r/n/2,r, r/n}, {-1,1}r, symmetry];

gp2 = InvertCircle[ Flatten@ gp1, {Circle[{0,0}, r/4]} ];

{maxR,minR} =
	{Max@#,Min@#}&@ (ReplaceAll[#, circ_Circle :> circ[[2]] ]&)@
	DeleteCases[
		Flatten@ gp2,
		PatternTest[ _, Not@(Head@# === Circle)&],
		1];
Print[ "largest circle has radius ", maxR ]
Print[ "smallest circle has radius ", minR ]

Show[Graphics[gp1], AspectRatio -> Automatic, Axes -> True, 
        PlotRange -> (1/2) {{-1, 1}, {-1, 1}} r 1.05, 
        Background -> GrayLevel[0]];
Show[Graphics[(BreakCircle[#1, (maxR/2), 5] &)[
                DeleteCases[
                  gp2, _Circle?(N[#1[[2]] > 100] &), ∞]]] /. Which[
              colorMethod === 1, 
              circ : Circle[{a_, b_}, rad_] -> 
                N[{Hue[ArcTan[a, b]/(2 π), 1, 1], circ}], 
              colorMethod === 2, 
              circ : Circle[{a_, b_}, rad_] -> 
                N[{Hue[((((rad/maxR)))^(1/4))], circ}], colorMethod === 3, 
              circ : Circle[{a_, b_}, rad_] -> 
                N[{Hue[(rad/maxR)], circ}]] /. If[
            usingDisk, Circle -> Disk, 0 -> 0], 
        AspectRatio -> Automatic, Axes -> False, 
        PlotRange -> (1/4) {{-1, 1}, {-1, 1}} r 1.05, 
        Background -> GrayLevel[0]];

Successive inversion of n circles evenly distributed around a center.

Clear[n, circleScale, nestLevel, li, maxR,minR]

n = 4; (* n is the number of circles. Try 2, 3, 5, 6*)
circleScale = .98; (* try .98, 1.2 *)
nestLevel = 2; (* greater than 2 may take a long time *)

(* this generate n circles distributed around a center *)
li = N@ Table[ Circle[{Sin@t, Cos@t}, circleScale Sin[(2 Pi/n)/2]],
	{t, 0, 2 Pi -(2 Pi/n /2), 2 Pi/n}];

(* this addes a center circle *)
li = N@ Join[li, {Circle[{0,0}, 1- Sin[(2 Pi/n)/2] ]}];

(* This generates successive inverse *)
li = Transpose[{ Rest@ Table[Hue[i], {i,0,1,1/(Length@li)}],
	Nest[ InvertCircle[ #, li]&, li, nestLevel]
}];

{maxR,minR} =
	{Max@#,Min@#}&@ (ReplaceAll[#, circ_Circle :> circ[[2]] ]&)@
	DeleteCases[
		Flatten@ li,
		PatternTest[ _, Not@(Head@# === Circle)&],
		1];
Print[ "largest circle has radius ", maxR ]
Print[ "smallest circle has radius ", minR ]

(* Circles with radius smaller than .01 are deleted for aesthetic reasons.
Circles with radius larger than 100 are deleted, to prevent possible
crash caused by a Mathematica v.2 bug.

You may adjust these values in the PatternTest code below
*)

Show[
	Graphics@ (BreakCircle[#,4,10]&) @
		DeleteCases[
			li,
			PatternTest[ _Circle, ( N@ (#[[2]]) < .01 || N@ (#[[2]]) > 100)&],
			Infinity
		],
	AspectRatio->Automatic,
	Axes->True,
	PlotRange->{{-1,1},{-1,1}} 1.1,
	Ticks->{Range[-5,5], Range[-5,5]},
	Background->GrayLevel[0]
];

Successive inversion of n+1 circles.

Clear[n, circleScale, nestLevel, circleList, circleList2, gra, maxR, minR]

n = 4; (* try 2, 3, 4 *)
circleScale = 1; (* Try .9, 1 *)
nestLevel = 2; (* try 0 to 3 *)

circleList = N@ Table[
		Circle[{Sin@t, Cos@t}, 1 circleScale],
		{t, 0, 2 Pi -(2 Pi/n /2), 2 Pi/n}
	];

circleList2 = N@ Join[ {Circle[{0,0},2]}, circleList];

gra = InvertCircleNest[ circleList2, circleList2, nestLevel];

{maxR,minR} =
	{Max@#,Min@#}&@ (ReplaceAll[#, circ_Circle :> circ[[2]] ]&)@
	DeleteCases[
		Flatten@ gra,
		PatternTest[ _, Not@(Head@# === Circle)&],
		1];
Print[ "largest circle has radius ", maxR ]
Print[ "smallest circle has radius ", minR ]

(* Circles with radius smaller than .1 are deleted, for aesthetic reasons.
Circles with radius larger than 100 are deleted, to prevent possible
crash caused by a Mathematica v.2 bug.

You may adjust these values in the PatternTest code below
*)

Show[
	Graphics@ (BreakCircle[#,4,5]&) @
		DeleteCases[
			gra,
			PatternTest[ _Circle, ( N@ (#[[2]]) < .1 || N@ (#[[2]]) > 100)&],
			Infinity
		],
	AspectRatio->Automatic,
	Axes->True,
	Ticks->{Range[-5,5], Range[-5,5]},
	PlotRange->{{-1,1},{-1,1}} 4,
	Background->GrayLevel[0]
];