Graphics Gallery 2.0

This file contains the code for producing some of the images in the Graphics Gallery from Mathematica: A System for Doing Mathematics by Computer, 2nd edition. (Collected in  August 1993.)

$Version

General Notes

Mathematica has changed since the images for the book were produced.
Sometimes it has not possible to have code that is "up to date" and still produce the correct image. This notebook provides code that works in Mathematica 2.2. In some cases
the images are not identical to those in the Mathematica Book, but they are close.

Copyright

All images are copyright Wolfram Research, Inc., 1991-1994. All rights reserved. These images and the Mathematica programs that make them may be redistributed free of charge for informational purposes. Please keep credits intact. 

Contact WRI for permission to reprint any of these images or programs in a publication. Send publication permission requests to Permissions Editor, Wolfram Research, Inc., 100 Trade Center Drive, Champaign, IL 61820. Or send email to permissions@wri.com.

PAGE 20, Miscellaneous

Region Satisfied by a Non-linear Inequality (T. Gray, J. Glynn)

<<Graphics`FilledPlot`

FilledPlot[{4 Sin[4 x], x^2 - 1}, {x, -Pi, Pi}]

Density Plot of sin(Re(Gamma(x + iy))) (P. Abbott)

DensityPlot[Sin[Re[Gamma[x+I y]]], {x,3,7},	
	{y, 0, 5}, PlotPoints->200, Mesh->False,
	ColorFunction->
(RGBColor[Sin[(#+1)/2], Sin[(1-#^2)/2], Abs[(1-(#+.2)/1)]]&)]

PAGE 21, Miscellaneous

Recursively Constructed Tree (T. Gray, J. Glynn)

Needs["Geometry`Rotations`"]

BeautifulTree[nestingDepth_, rotation_, 
			shrinkage_, thicknessShrinkage_, 
			originalThickness_, 
			colors_, options___] :=
Block[{twinLine, doTwins, rotateLine, colorCounter},
	rotateLine[Line[{start_, end_}], angle_] :=
			Line[{
				end, 
				end + shrinkage *
					Rotate2D[
						end - start,  
						angle Random[Real, {0.5, 1.5}]
					]
			}];
	twinLine[Line[points_]] :=
		{
			rotateLine[Line[points], rotation],
			rotateLine[Line[points], -rotation]
		};
	twinLine[Thickness[th_]] :=
		Thickness[th thicknessShrinkage];	
	twinLine[RGBColor[r_, g_, b_]] :=
		{};	
	
	colorCounter = 1;
	doTwins[lines_] :=
		Flatten[{
			colors[[
				1 + Mod[colorCounter++, Length[colors]]
			]],
			Map[twinLine, lines]
		}];
	
	Show[
		Graphics[
			NestList[
				doTwins, 
				{
					colors[[1]],
					Thickness[originalThickness],
					Line[
						{{0, 0}, 
						 {0, 1}}
					]
				}, 
				nestingDepth
			]
		],
		options,
		AspectRatio -> Automatic,
		PlotRange -> All
	]
]

BeautifulTree[10, 0.65, 0.75, 0.7, 0.07, 
	{
	RGBColor[0.430, 0.185, 0.064],
	RGBColor[0.465, 0.201, 0.069],
	RGBColor[0.535, 0.231, 0.080],
	RGBColor[0.590, 0.255, 0.088],
	RGBColor[0.219, 0.465, 0.000],
	RGBColor[0.245, 0.520, 0.000],
	RGBColor[0.275, 0.582, 0.000],
	RGBColor[0.322, 0.684, 0.000],
	RGBColor[0.332, 0.714, 0.000],
	RGBColor[0.346, 0.734, 0.000],
	RGBColor[0.984, 0.731, 0.024]
}]

Complex Polynomial Vector Field (C. Smith, P. Boyland)

a=N[Table[ {Re[((x + I y)^3 - 1/3)(x + I y +2/3)],
Im[((x + I y)^3- 1/3)(x + I y + 2/3)]},
         {x,-1, 1,.1},{y,-1, 1,.1}]];

dir[ {x_,y_} ] := (ArcTan[y/x]+Pi/2)/Pi

b=N[Map[dir,a,{2}]];

c=Map[Hue[#,.6,.73]&,b,{2}];

Norm[vec_] := Sqrt[vec.vec]

Unit[vec_] := vec/Norm[vec]

t=Map[(.065Unit[#])&,a,{2}];

p=Table[ {x,y},{x,-1, 1,.1},{y,-1, 1,.1}];

q=Transpose[{p,t+p},{3,1,2,4}];

Arrowize[ Line[e:{f:{a_,b_},g:{c_,d_}}] ] :=
  Block[{v=f-g},{Line[e],Line[{g,g+({{1,-1},{1,1}}.v/(3.Sqrt[2.]))}],
  Line[{g,g+({{1,1},{-1,1}}.v/(5N[Sqrt[2]]))}]}];

r=Map[Arrowize[Line[#]]&,q,{2}];

z=Transpose[{c,r},{3,1,2}];

Show[Graphics[z], Background->GrayLevel[0], AspectRatio->Automatic]

Robinson Projection World Map  (J. Novak)

<< Miscellaneous`WorldPlot`;

WorldPlot[{World,RandomColors},Projection->Sinusoidal]

PAGE 22, Miscellaneous

Graph of an Iterated Transcendental Function (T. Gray, J. Glynn)

maxZ = N[10^30];
nPi = N[Pi];
ntPi = N[2Pi];
nE = N[E];

complexToLogLogZandColor[z_] := Block[{nz = N[z], az = Abs[nz]},
	{
		Log[Log[az + nE]],
		Hue[(nPi + If[nz == 0, 0, Arg[nz / az]])/(ntPi), 1., 1.]
	}
	]

f[x_] := Sin[Sin[Sin[x]]]

Plot3D[
	complexToLogLogZandColor[f[x + I y]],
	{x, -Pi, Pi}, 
	{y, -Pi, Pi},
	PlotPoints->46,
	PlotRange->All
]

Part of Scherk's Second Minimal Surface (S. Dickson)

ParametricPlot3D[
{Re[2*(-Log[1 - E^(I*th)*r] + Log[1 + E^(I*th)*r])], 
  Re[4*I*ArcTan[E^(I*th)*r]], 
  Re[2*I*(-Log[1 - E^(2*I*th)*r^2] + Log[1 + E^(2*I*th)*r^2])]},
{th, 0, 2 Pi}, {r, .01, .98}, PlotPoints->{60,19},
 ViewPoint->{1.3, -2.4, 2.0}, 
        Boxed->False, Axes-> False, PlotRange->All ]

PAGE 23, Miscellaneous

Three-dimensional Bar Chart (M. Chan)

<<Graphics`Graphics3D`

BarChart3D[Table[1/x + y, {x,5},{y,5}], XSpacing -> .5,
 YSpacing -> .5, Background->GrayLevel[0]]

Five Tetrahedra Making a Stellated Icosahedron (S. Kim)

Off[General::spell1]

Needs["Graphics`Polyhedra`"]

vertices = Vertices[Dodecahedron];

Triangles[{f1_,f2_,f3_,f4_}] := 
   {{f1, f2, f3},
	{f1, f3, f4},
	{f1, f4, f2},
	{f4, f3, f2}}

tetrapoints = {{1, 9, 12, 20}, {2, 10, 13, 16},
         {3, 6, 14, 17}, {4, 7, 15, 18}, {5, 8, 11, 19}};

poly = 
 (vertices[[#]]&) /@ Flatten[ Triangles /@ tetrapoints, 1];

linearcombination[r_, a_, b_] := (1-r)*a + (r)*b

HollowTriangle[t_] :=
	Block[{a=t[[1]], b=t[[2]], c=t[[3]], aa, bb, cc},
		aa = linearcombination[1/8, a, (b+c)/2];
		bb = linearcombination[1/8, b, (c+a)/2];
		cc = linearcombination[1/8, c, (a+b)/2];
		{{a,b,bb,aa}, {b,c,cc,bb}, {c,a,aa,cc}} ]

On[General::spell1]

tetrapict =
 Show[Graphics3D[ Polygon /@ 
              Flatten[ HollowTriangle /@ poly , 1]], 
              ViewVertical -> {.52, .38, .85}, Boxed -> False]

Strange Attractor in the Equations for an Electric Circuit (P. Boyland)

<</Pubs/pix/plb/gs1;

(*Hue[x_] := HSBColor[- 1.2 x + .2,1,1]*)
(*Hue[x_] := GrayLevel[-4 x + .8]; *)

ViewPoint -> {4.1, 1.53, -.03},

hue[x_] := Hue[5 x, 1, 1]

hue[x_] := Hue[- 1.2 x + .2, 1, 1]

Show[goodscroll,  
    Axes -> False, 
    Lighting -> False]

PAGES 26-27, Enneper Surfaces

View of Enneper's Surface page 27  (S. Dickson)

ParametricPlot3D[{Re[E^(I*th)*r - (E^(3*I*th)*r^3)/3],
   Re[I*E^(I*th)*r + I/3*E^(3*I*th)*r^3], Re[E^(2*I*th)*r^2]},
                                     {th, 0, 2 Pi}, {r, 0, 3},
        ViewPoint -> {2.8, -1.9, 0.1}, Boxed->False,
        PlotPoints -> {100, 30}, Axes -> False, 
        PlotRange -> All,
   LightSources ->
    {{{0.7071, 0, 0.7071}, RGBColor[0.9481, 0, 0]},
     {{0.5773, 0.5773, 0.5773}, RGBColor[0, 0.8888, 0]},
     {{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}}]

Local Structure of an Immersed Minimal Surface (R. Maeder)

ParametricPlot3D[ {Re[E^(I*phi)*r - (E^(3*I*phi)*r^3)/3], 
   Re[I*E^(I*phi)*r + I/3*E^(3*I*phi)*r^3], Re[E^(2*I*phi)*r^2]},
{r, 0, 1}, {phi, -Pi, Pi}, PlotPoints-> {10, 40},
        PlotRange -> All,
Axes-> False, Boxed -> False]

Local Structure of an Immersed Minimal Surface (R. Maeder)

ParametricPlot3D[{-(r^2 Cos[2phi])/2 + Log[r],
	- phi - (r^2 Sin[2phi])/2, 2r Cos[phi]},
	    {r, 0.1, 3.5}, {phi, -3.1, 1.5},
	      PlotPoints-> {10,40}, 
	      Axes->False, Boxed->False, PlotRange->All,
	      ViewPoint->{0.5906, -1.9715, -2.6871},
    LightSources -> 
      {{{0.5901, -0.1296, 0.7968}, RGBColor[1, 0, 0]}, 
       {{0.7299, 0.6626, 0.1677}, RGBColor[0, 1, 0.0081]}, 
       {{-0.2038, 0.724, 0.6589}, RGBColor[0, 0, 1]}}]

PAGES 28-29, Conchoids

Upright Conical Spiral (S. Dickson)

X = 2*(1 - E^(u/(6*Pi)))*Cos[u]*Cos[v/2]^2;

Y = 2*(-1 + E^(u/(6*Pi)))*Cos[v/2]^2*Sin[u];

Z = 1 - E^(u/(3*Pi)) - Sin[v] + E^(u/(6*Pi))*Sin[v];

ParametricPlot3D[{X, Y, Z}, {u, 0, 6 Pi}, 
	{v, 0, 2 Pi}, 
	PlotPoints -> {96, 20},
	ViewPoint -> {1.0992, 3.2001, 0.0255}, Boxed->False,
	PlotRange -> All, Axes -> False,
   LightSources -> 
    {{{0.7071, 0, 0.7071}, RGBColor[1, 0, 0]}, 
     {{0.5773, 0.5773, 0.5773}, RGBColor[0, 1, 0]}, 
     {{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}},
     RenderAll->False
]

Upright Conical Spiral with Gradual Slope (S. Dickson)

X =  2*(-1 + E^(u/(6*Pi)))*Cos[u]*Cos[v/2]^2;

Y =  2*(-1 + E^(u/(6*Pi)))*Cos[v/2]^2*Sin[u];

Z = 1/2 - E^(u/(3*Pi))/2 - Sin[v] + E^(u/(6*Pi))*Sin[v];

ParametricPlot3D[{X, Y, Z}, {u, 0, 6 Pi},
                {v, 0, 2 Pi},
           PlotPoints -> {100, 20},
           PlotRange -> All, Axes -> False, 
        Boxed->False];

Cross-section of Flat Conical Spiral (S. Dickson)

X =  2*(-1 + E^(u/(6*Pi)))*Cos[v/2]^2*
   (Cos[u]*Cos[Sin[2*v]/2] + Sin[u]*Sin[Sin[2*v]/2]);

Y =  2*I*(-1 + E^(u/(6*Pi)))*Cos[v/2]^2*
   (-I*Cos[Sin[2*v]/2]*Sin[u] + I*Cos[u]*Sin[Sin[2*v]/2]);

Z = (-1 + E^(u/(6*Pi)))*Sin[v];

ParametricPlot3D[{X, Y, Z},
        {u, 0, 6 Pi}, {v, -Pi, 0},
        Axes ->False, Boxed->False,
        ViewPoint -> {3.6305, -0.2046, 1.8322},
        PlotPoints -> {108, 14},
        PlotRange->All];

PAGES 30-31, Trinoids

A view of a trinoid minimal surface (S. Dickson)

ParametricPlot3D[
{Re[(E^(I*th)*r)/(3*(1 + E^(I*th)*r + E^(2*I*th)*r^2)) - 
     (4*Log[1 - E^(I*th)*r])/9 + (2*Log[1 + E^(I*th)*r + E^(2*I*th)*r^2])/9], 
   Re[((-2*I)/9*Pi)/3^(1/2) - (I/3*(E^(I*th)*r + E^(2*I*th)*r^2))/
      (-1 + E^(3*I*th)*r^3) + ((4*I)/3*ArcTan[(1 + 2*E^(I*th)*r)/3^(1/2)])/
      3^(1/2)], Re[-2/3 - 2/(3*(-1 + E^(3*I*th)*r^3))]},
 {th, 0, 2 Pi}, {r, 0, 2}, PlotPoints -> {15, 20},
        ViewPoint->{-0.081, -0.003, 1.618},
        PlotRange -> All,
        Boxed->False, Axes->False]

Another view of a trinoid minimal surface (S. Dickson)

MakePolygons[vl_List] :=
    Block[{l = vl,
           l1 = Map[RotateLeft, vl],
           mesh},
        mesh = {l, RotateLeft[l], RotateLeft[l1], l1};
        mesh = Map[Drop[#, -1]&, mesh, {1}];
        mesh = Map[Drop[#, -1]&, mesh, {2}];
        Polygon /@ Transpose[ Map[Flatten[#, 1]&, mesh] ]
    ]

Show[Graphics3D[ MakePolygons[Table[N[
{Re[(E^(I*th)*r)/(3*(1 + E^(I*th)*r + E^(2*I*th)*r^2)) - 
     (4*Log[1 - E^(I*th)*r])/9 + (2*Log[1 + E^(I*th)*r + E^(2*I*th)*r^2])/9], 
   Re[((-2*I)/9*Pi)/3^(1/2) - (I/3*(E^(I*th)*r + E^(2*I*th)*r^2))/
      (-1 + E^(3*I*th)*r^3) + ((4*I)/3*ArcTan[(1 + 2*E^(I*th)*r)/3^(1/2)])/
      3^(1/2)], Re[-2/3 - 2/(3*(-1 + E^(3*I*th)*r^3))]}],
       {th, 0, 2 Pi, N[Pi/15]},{r, 0, 2.0,N[ 1 / 10.15]}]] ,
       LightSources -> {{{0.7071, 0, 0.7071}, RGBColor[0.9481, 0, 0]}, 
     {{0.5773, 0.5773, 0.5773}, RGBColor[0, 0.8888, 0]}, 
     {{0, 0.7071, 0.7071}, RGBColor[0, 0, 1]}},
      Background->RGBColor[0, 0, 0],
     ViewPoint->{0.7654, -0.9924, 1.5831},
        PlotRange -> All,
        Boxed->False, Axes->False]]

PAGES 32-33, Knots

Tubes package: This must be evaluated first!

Off[General::spell1]

tube::usage =
 "tube[function, {t, tmin, tmax, tnum}, circnum, radius, options]
 generates a tube with given radius about the curve defined by the 
 given function of t. The mesh of the tube has circum vertices in
 the meridian direction and tnum vertices in the longitudinal 
 direction."; 
Unitize[a_] := N[a / Sqrt[a.a]]
Angle[A_List, B_List] :=
	ArcCos[Unitize[A] . Unitize[B]]
Cross[v1_?VectorQ, v2_?VectorQ] :=
        Module[{m=Minors[{v1,v2},2][[1]]},
                {m[[3]], -m[[2]], m[[1]]}
        ]       /; Length[v1]==Length[v2]==3
MakePolygons[vl_List] :=
    Block[{l = vl,
           l1 = Map[RotateLeft, vl],
           numesh},
        numesh = {l, RotateLeft[l], RotateLeft[l1], l1};
        numesh = Map[Drop[#, -1]&, numesh, {1}];
        numesh = Map[Drop[#, -1]&, numesh, {2}];
        Polygon /@ Transpose[ Map[Flatten[#, 1]&, numesh] ]
    ]
tube[function_, {t_, tmin_, tmax_, tnum_}, cnum_, radius_, options___] := 
      Block[
    {tpoints, npoints, gvec = N[(1/Sqrt[3]) {1.0, 1.0, 1.0}], 
    vpoints, xpoints, error, scpoints, mesh},
    tpoints = Table[N[function], {t, tmin, tmax, (tmax - tmin)/tnum}];
    If[closed,
    tpoints[[-1]] = tpoints[[1]]];
    npoints = Map[Unitize,
        Table[Evaluate[D[function, t]],
        {t, tmin, tmax, (tmax - tmin)/tnum}]//N ];
    If[closed,
    npoints[[-1]] = npoints[[1]]];
    vpoints = Map[Unitize,
        Map[
		(gvec -= (gvec . #) #)&,
		npoints
	    ] ];
    xpoints = Map[Unitize,
        Map[
		Apply[Cross, #]&,
		Transpose[{npoints, vpoints}]
	    ] ];
    error = Angle[vpoints[[1]], vpoints[[-1]]];
    Do[
	{vpoints[[i]], xpoints[[i]]} =
		N[
			({{#1,#2},{-#2,#1}} . {vpoints[[i]], xpoints[[i]]})&
				[Cos[error(i-1)/tnum], Sin[error(i-1)/tnum]]
		],
	{i, 1, tnum+1}
    ];
    If[closed,
    vpoints[[-1]] = vpoints[[1]];
    xpoints[[-1]] = xpoints[[1]]];
    scpoints = Table[N[{Cos[t], Sin[t]} radius],
		{t, 0, 2Pi, 2Pi/cnum}];
    mesh = Table[
		tpoints[[i]] + scpoints[[j]] . {vpoints[[i]], xpoints[[i]]},
		{j, 1, cnum+1},
		{i, 1, tnum+1}
	];
    shape = MakePolygons[mesh] //Graphics3D ]
Options[tube] = {closed->True};

Trefoil knot (H. Cejtin after R. W. Gosper)

Show[tube[
		{
			-10 Cos[t] - 2 Cos[5 t] + 15 Sin[2 t], 
			-15 Cos[2 t] + 10 Sin[t] - 2 Sin[5 t],
			10 Cos[3 t]
		},
		{t, 0, 2 Pi, 75}, 9,
		4.],Boxed->False]

Figure-eight knot (S. Dickson)

Show[tube[
         {10 (Cos[t] + Cos[3 t]) + Cos[2 t] + Cos[4 t],
          6 Sin[t] + 10 Sin[3 t],
          4 Sin[3 t] Sin[5 t/2] + 4 Sin[4 t] - 2 Sin[6 t]},
                {t, 0, 2 Pi, 90}, 8, 2.5], Boxed->False]

Closed 3 braid (S. Dickson)

Show[tube[
		{
		Cos[3 t] (25 + 5 Sin[10 t]),
		Sin[3 t] (25 + 5 Sin[10 t]),
		10 Sin[5 t]
	    },
		{t, 0, 2 Pi, 200}, 10,
		3.],Boxed->False]

(3, 4)-torus knot (S. Dickson)

Show[tube[
      {4 Cos[t + N[Pi]] / 3 + 2 Cos[3 t],
       4 Sin[t] / 3 + 2 Sin[3 t],
       Sin[4 t] + Sin[2 t] / 2}, 
              {t, 0, 2 Pi, 90}, 9, .25],
                              Boxed->False]

PAGES 36-37, Symmetric Quasitilings

Package--This must be evaluated first!

Off[General::spell1]

om=Exp[2 I / 3 Pi]; mo = om^2; halfhex={1, -mo, om, -1};

polify[l_List]:= Polygon[reim/@#]&/@l

reim[z_]:= {Re[z], Im[z]}

triple[l_List]:= Join@@Outer[Times, N[{1, om, mo}], l]

base2fill[n_Integer]:= Block[{arm=3/2+I/3 Im[om]-halfhex, 
ans, glue=N[mo halfhex], gluv= 4 N[2+om]/3, 
om6=N[Sqrt[om]]/2}, 
ans = N[{2 I{1, om, mo}/Sqrt[3], arm, om arm, mo arm}];
Do[ans = Join[ans, triple[Prepend[4+ans, glue+gluv]]]/2;
glue=Conjugate[glue] om6;
gluv=4-gluv, {n}];
ans-gluv]

shogons[l_List, h_]:= 
   Show[Graphics[Prepend[polify[N[l]], Hue[h]]], 
                 AspectRatio->Automatic]

sixaround[n_, c1_, c2_, c3_]:=
	Block[{fil=triple[base2fill[n]], g1, g2, g3},
			g1 = {c1, polify[fil]};
			g2 ={c2,  polify[N[Sqrt[om]] fil]};
			g3 ={c3, 
			polify[N[{halfhex, -halfhex}/2^(n+1)]]};
			Show[Graphics[{g1, g2, g3}, 
			AspectRatio->Automatic]]]

Recursively defined partial tilings of the plane (R. W. Gosper)

The colors may not be exactly the same as those in the book.  If altering the second argument to shogons doesn't produce the colors you want, try changing the hue in the definition of shogons.

shogons[base2fill[2], .18]

shogons[base2fill[3], .3]

shogons[base2fill[4], .7]

Symmetric quasitiling on page 37

sixaround[3, RGBColor[1, .2, 0], RGBColor[0, .2, 1], 
			RGBColor[1, 1, 0]]

PAGES 40-41, Color and Specularity

Pg 40: Color Models 
	 Charts of typical colors generated by Mathematica graphics directives.

$DefaultFont = {"Courier", 6}

DensityPlot[ x, {x,0,1}, {y,0,1},
            AspectRatio -> .2, FrameTicks -> {Automatic, None},
            PlotPoints -> {80,2}, ColorFunction -> Hue,
            PlotRange -> {{-0.01,1.01}, {-.05,1.05}, Automatic},
            Mesh-> False, FrameLabel -> {"h", "Hue[h]"},
            RotateLabel -> False]

DensityPlot[ x, {x,0,1}, {y,0,1},
            AspectRatio -> .2, FrameTicks -> {Automatic, None},
            PlotPoints -> {80,2}, ColorFunction -> GrayLevel,
            PlotRange -> {{-0.01,1.01}, {-.05,1.05}, Automatic},
            Mesh-> False, FrameLabel -> {"g", "GrayLevel[g]"},
            RotateLabel -> False]

rgb[n_, b_] :=
Show[ Graphics[
{ RasterArray[ Table[ RGBColor[r,g,b],{g,0,1,1/n},{r,0,1,1/n}],
                                      {{0,0},{1,1}}],
Thickness[0.002],
Table[ {Line[{{i,0},{i,1}}], Line[{{0,i},{1,i}}]}, {i,0,1,1/(n+1)}] }],
AspectRatio -> 1, PlotRange -> {{-0.02,1.02},{-0.02, 1.02}},
Frame -> True, FrameLabel -> {"r", "g"},
PlotLabel -> StringForm[ "RGBColor[ r, g, `1`]", b],
RotateLabel -> False]

rgb[10,0]

rgb[10,.5]

rgb[10,1]

hsb[n_, b_] :=
Show[ Graphics[
{ RasterArray[ Table[ Hue[r,g,b],{g,0,1,1/n},{r,0,1,1/n}],
                                      {{0,0},{1,1}}],
Thickness[0.002],
Table[ {Line[{{i,0},{i,1}}], Line[{{0,i},{1,i}}]}, {i,0,1,1/(n+1)}] }],
AspectRatio -> 1, PlotRange -> {{-0.02,1.02},{-0.02, 1.02}},
Frame -> True, FrameLabel -> {"h", "s"},
PlotLabel -> StringForm[ "Hue[ h, s, `1`]", b],
RotateLabel -> False]

hsb[10,.5]

hsb[10,1]

PAGE 41, Lighting Models

bx = 6  Cos[u] (1 + Sin[u]);
by = 16  Sin[u];
rad = 4 (1 - Cos[u] / 2);
X = If[Pi < u <= 2 Pi, bx + rad Cos[v + Pi], 
                            bx + rad Cos[u] Cos[v]];
Y = If[Pi < u <= 2 Pi, by, by + rad Sin[u] Cos[v]];
Z = rad Sin[v];
ParametricPlot3D[{X, Y, Z}, {u, 0, 2 Pi}, {v, 0, 2 Pi}, 
        PlotPoints -> {48,12}, Axes -> False, Boxed -> False, 
                 ViewPoint-> {1.4, -2.6, -1.7}]

bx = 6  Cos[u] (1 + Sin[u]);
by = 16  Sin[u];
rad = 4 (1 - Cos[u] / 2);
X = If[Pi < u <= 2 Pi, bx + rad Cos[v + Pi], 
                            bx + rad Cos[u] Cos[v]];
Y = If[Pi < u <= 2 Pi, by, by + rad Sin[u] Cos[v]];
Z = rad Sin[v];
ParametricPlot3D[{X, Y, Z}, {u, 0, 2 Pi}, {v, 0, 2 Pi}, 
        PlotPoints -> {48,12}, Axes -> False, Boxed -> False, 
                 ViewPoint-> {1.4, -2.6, -1.7},
                 LightSources-> 
                   {{{.6,.6,.6}, RGBColor[1,0,0]},
                    {{-.8,.1,.6},RGBColor[0,1,0]},
                    {{.3,-.3,.9},RGBColor[0,0,1]}}]

bx = 6  Cos[u] (1 + Sin[u]);
by = 16  Sin[u];
rad = 4 (1 - Cos[u] / 2);
X = If[Pi < u <= 2 Pi, bx + rad Cos[v + Pi], 
                            bx + rad Cos[u] Cos[v]];
Y = If[Pi < u <= 2 Pi, by, by + rad Sin[u] Cos[v]];
Z = rad Sin[v];
ParametricPlot3D[{X, Y, Z}, {u, 0, 2 Pi}, {v, 0, 2 Pi}, 
        PlotPoints -> {48,12}, Axes -> False, Boxed -> False, 
                 ViewPoint-> {1.4, -2.6, -1.7},
                 LightSources-> 
                   {{{-.2,-.5,.8}, RGBColor[1,0,0]},
                    {{.5,.8,.4},RGBColor[0,1,0]},
                    {{.4,.7,.7},RGBColor[0,0,1]}}]