Constructing Mathlets Quickly using LiveGraphics3D
Accompanying Mathematica Code

Martin Kraus: Martin.Kraus@informatik.uni-stuttgart.de
Jonathan Rogness: rogness@math.umn.edu

This notebook contains Mathematica commands to create the more complicated examples in our article.  It is not meant to replace the article, and most of the sections are devoid of any comments or explanations.  See the article for more information.

Initialization Cells

The following commands are used throughout the notebook to convert Mathematica graphics into LiveGraphics3D input files.

\(LiveForm[graphics_, \ 
            animOpts___]\  := \ 
\ \ \ Module[{graphics3d\  = \ 
                Switch[graphics, \ _ContourGraphics, \ 
\ \ \ Graphics3D[
                      SurfaceGraphics[
                        graphics]], \ _DensityGraphics, \ 
\ \ \ Graphics3D[
                      SurfaceGraphics[
                        graphics]], \ _SurfaceGraphics, \ 
\ \ \ Graphics3D[
                      graphics], \ _, \ graphics] //. 
                  SequenceForm[x___] :> 
\ \ \ StringForm[
                      StringJoin[Table["``", \ {Length[{x}]}]], \ 
                      x]}, \ 
\ \ \ Switch[
              graphics3d, \ _List, \ \(HoldForm[ShowAnimation]\)[
\ \ \ Map[
                  LiveForm, \ graphics3d], \ 
                InputForm[N[Flatten[{animOpts}]]]], \ 
\ \ \ _, \ 
              InputForm[N[graphics3d]]]];\)
\(LiveForm[graphics_, \ {var_, \ from_, \ to_, \ step_}, \ 
          animOpts___]\  := \ 
\ \ \ \ Module[{}, \(HoldForm[Animate]\)[
            LiveForm[graphics], \ 
\ \ \ \ InputForm[
              N[{var, from, to, step}]], InputForm[N[Flatten[{animOpts}]]]]]; 
      WriteLiveForm[filename_, \ graphics_, \ 
          animOpts___]\  := \ 
\ \ \ \ Module[{ps, x}, \ 
          ps = Unprotect[Real]; \ 
          Format[x_Real, \ InputForm]\  := \ 
\ \ \ \ OutputForm[
              NumberForm[x, \ 5, \ 
                NumberFormat\  -> \ \((If[#3\  == \ "", \ #1, \ 
\ \ \ \ SequenceForm[#1, \ "*^", \ #3]]\  &)\)]]; \ 
          Protect @@ ps; 
\ \ \ \ WriteString[filename, \ 
            ToString[
              LiveForm[graphics, \ animOpts], 
\ \ \ \ CharacterEncoding -> 
                None]]; \ Close[filename]; 
\ \ \ \ ps = Unprotect[Real]; \ 
          Format[x_Real, \ InputForm]\  =. ; \ Protect @@ ps;];\)

The following code defines a three dimensional arrow primitive which is used in some of the more advanced examples.

(* :Title:  Three-Dimensional Arrow Graphics *)

(* :Context: Arrow3D` *)

(* :Author: Martin Kraus *)

(* :Summary:  
This package introduces the functions Arrow3D[start, finish] and
ArcArrow3D[center, axis1, axis2] to create three-dimensional
(curved) arrows with flat arrowheads.
*)

(* :Package Version: 1.1 (December 97) *)

(* :Mathematica Version: 3.0 *)

(* :Copyright: Copyright 1997, Martin Kraus*)

(* :History:
   November 1997 V 0.0
   12/14/1997 added HeadPointColor and TailPointColor (V 1.1)
*)

(* :Keywords:
	Arrow, Vector, Graphics
*)

(* :Sources:
	Arrow.m
*)

(* :Limitations: *)

(* :Discussion: *)

BeginPackage["Arrow3D`"]

Arrow3D::usage=
"Arrow3D[start, finish, (opts)] generates several graphics primitives
representing an arrow starting at start and ending at finish. 
There are arrowheads of length 0 by default, i.e. no arrowheads.";

ArcArrow3D::usage=
"ArcArrow3D[center, axis1, axis2, (opts)] generates several graphics
primitives representing an arc with arrowhead starting at center+axis1
and ending in the direction of center+axis2.
There are arrowheads of length 0 by default, i.e. no arrowheads.";

HeadLength::usage=
"HeadLength is an option to Arrow3D and ArcArrow3D. It describes the length
of the arrowhead.";

HeadWidth::usage=
"HeadWidth is an option to Arrow3D and ArcArrow3D. It describes the width
of the arrowhead, relative to the length of the arrowhead (specified by
HeadLength).";

HeadCenter::usage=
"HeadCenter is an option to Arrow3D and ArcArrow3D. It describes the
location of the center of the base of the arrowhead along the length of the
arrow, as a factor of the length of the arrowhead. That is, if HeadCenter ->
0, the arrow will be two lines; if HeadCenter -> 1, the arrowhead will be a
perfect triangle; otherwise, the arrowhead will be four-sided.";

HeadTop::usage=
"HeadTop is an option to Arrow3D and ArcArrow3D. It describes the location
of the top of the arrowhead along the length of the arrow. It may be used to
leave some space at the top for a point, specified by HeadPointSize.";

HeadPointSize::usage=
"HeadPointSize is an option to Arrow3D and ArcArrow3D. It describes the
size of a point at the top of the arrow, relative to the width of the whole
plot.";

HeadPointColor::usage=
"HeadPointColor is an option to Arrow3D and ArcArrow3D. It specifys the
color of a point at the top of the arrow. If set to Automatic the color of the arrow 
is used.";

HeadBlockWidth::usage=
"HeadBlockWidth is an option to Arrow3D and ArcArrow3D. It describes the
width of a line at the top of the arrowhead, perpendicular to the arrow.";

HeadNormal::usage=
"HeadNormal is an option to Arrow3D and ArcArrow3D. It describes the normal
direction of the arrowhead."; 

TailLength::usage=
"TailLength is an option to Arrow3D and ArcArrow3D. It works exactly like
HeadLength, but for the tail of the arrow";

TailWidth::usage=
"TailWidth is an option to Arrow3D and ArcArrow3D. It works exactly like
HeadWidth, but for the tail of the arrow";

TailCenter::usage=
"TailCenter is an option to Arrow3D and ArcArrow3D. It works exactly like
HeadCenter, but for the tail of the arrow";

TailTop::usage=
"TailTop is an option to Arrow3D It works exactly like HeadTop, but for the
tail of the arrow";

TailPointSize::usage=
"TailPointSize is an option to Arrow3D and ArcArrow3D. It works exactly
like HeadPointSize, but for the tail of the arrow";

TailPointColor::usage=
"TailPointColor is an option to Arrow3D and ArcArrow3D. It works exactly
like HeadPointColor, but for the tail of the arrow";

TailBlockWidth::usage=
"TailBlockWidth is an option to Arrow3D and ArcArrow3D. It works exactly
like HeadBlockWidth, but for the tail of the arrow";

TailNormal::usage=
"TailNormal is an option to Arrow3D and ArcArrow3D. It works exactly like
HeadNormal, but for the tail of the arrow";

GreaterPi::usage=
"GreaterPi is an option to ArcArrow3D. If set to True an angle greater than
Pi is drawn, otherwise an angle less than Pi.";

Begin["`Private`"]

(* The Arrow3D function *)

Options[Arrow3D]=
   {HeadBlockWidth->0,
   HeadCenter->1,
   HeadLength->0,
   HeadNormal->{0,0,1},
   HeadPointSize->0,
   HeadPointColor->Automatic,
   HeadTop->0,
   HeadWidth->0.5,
   TailBlockWidth->0,
   TailCenter->1,
   TailLength->0,
   TailNormal->{0,0,1},
   TailPointSize->0,
   TailPointColor->Automatic,
   TailTop->0,
   TailWidth->0.5};

Arrow3D[a_,b_,opts___]:=
  Module[{g={},headPoint,tailPoint,abLength=N[Sqrt[(b-a).(b-a)]],abUnit,
      headPerp,headPerpLength,tailPerp,tailPerpLength,headBlockWidth,
      headCenter,headLength,headNormal,headPointSize,headPointColor, 
      headTop,headWidth,
      tailBlockWidth,tailCenter,tailLength,tailNormal,tailPointSize,tailPointColor,
      tailTop,tailWidth},
      {headBlockWidth,headCenter,headLength,headNormal,
        headPointSize,headPointColor,headTop,headWidth,tailBlockWidth,tailCenter,
        tailLength,tailNormal,tailPointSize,tailPointColor,tailTop,
        tailWidth}={HeadBlockWidth,HeadCenter,HeadLength,HeadNormal,
            HeadPointSize,HeadPointColor,HeadTop,HeadWidth,TailBlockWidth,TailCenter,
            TailLength,TailNormal,TailPointSize,TailPointColor,TailTop,TailWidth}//.{
            opts}//.Options[Arrow3D];abUnit=(b-a)/abLength; 
    headPerp=Cross[abUnit, N[headNormal]];
    headPerpLength=Sqrt[N[headPerp.headPerp]];
    If[headPerpLength==0.,headPerp=Cross[abUnit,N[{0.005163,0.005363,0.005724}+headNormal]];
      headPerpLength=Sqrt[N[headPerp.headPerp]]];
    headPerp=headPerp/headPerpLength; tailPerp=Cross[abUnit, N[tailNormal]];
    tailPerpLength=Sqrt[N[tailPerp.tailPerp]];
    If[tailPerpLength==0.,tailPerp=Cross[abUnit,N[{0.005163,0.005363,0.005724}+tailNormal]];
      tailPerpLength=Sqrt[N[tailPerp.tailPerp]]];
    tailPerp=tailPerp/tailPerpLength;headPoint=N[b-abUnit*headTop];
    tailPoint=N[a+abUnit*tailTop];
    g=Append[g,Line[{tailPoint+abUnit*tailLength*tailCenter,
            headPoint-abUnit*headLength*headCenter}]];
    If[headPointSize>0.,g=Append[g,{If[headPointColor===Automatic,{},headPointColor],
            PointSize[headPointSize],Point[b]}]];
    If[tailPointSize>0.,g=Append[g,{If[tailPointColor===Automatic,{},tailPointColor],
            PointSize[tailPointSize],Point[a]}]];
    If[headBlockWidth>0.,
      g=Append[g,Line[{headPoint+headPerp*headBlockWidth/2.,
              headPoint-headPerp*headBlockWidth/2.}]]];
    If[tailBlockWidth>0.,
      g=Append[g,Line[{tailPoint+tailPerp*tailBlockWidth/2.,
              tailPoint-tailPerp*tailBlockWidth/2.}]]];
    If[headLength>0.,
      g=Append[g,Polygon[{headPoint,
              headPoint-abUnit*headLength+headPerp*headWidth/2*headLength,
              headPoint-abUnit*headCenter*headLength,
              headPoint-abUnit*headLength-headPerp*headWidth/2*headLength}]]];
    If[tailLength>0.,
      g=Append[g,Polygon[{tailPoint,
              tailPoint+abUnit*tailLength+tailPerp*tailWidth/2*tailLength,
              tailPoint+abUnit*tailCenter*tailLength,
              tailPoint+abUnit*tailLength-tailPerp*tailWidth/2*tailLength}]]];
    g];
    
    
(* The ArcArrow3D function *)

Options[ArcArrow3D]=
   {PlotPoints->20,
   GreaterPi->False,
   HeadBlockWidth->0,
   HeadCenter->1,
   HeadLength->0,
   HeadNormal->{0,0,1},
   HeadPointSize->0,
   HeadTop->0,
   HeadWidth->0.5,
   TailBlockWidth->0,
   TailCenter->1,
   TailLength->0,
   TailNormal->{0,0,1},
   TailPointSize->0,
   TailTop->0,
   TailWidth->0.5};

ArcArrow3D[c_,a_,b_,opts___]:=
  Module[{bUnit,bx,bLength,x,xLength,y,yLength,fullAlpha,minAlpha,maxAlpha,
      plotPoints,greaterPi,headBlockWidth,headCenter,headLength,headNormal,
      headPointSize,headPointColor,headTop,headWidth,tailBlockWidth,tailCenter,
      tailLength,tailNormal,tailPointSize,tailPointColor,tailTop,
      tailWidth},{plotPoints,greaterPi,headBlockWidth,headCenter,headLength,
        headNormal,headPointSize,headPointColor,headTop,headWidth,tailBlockWidth,
        tailCenter,tailLength,tailNormal,tailPointSize,tailPointColor,tailTop,
        tailWidth}={PlotPoints,GreaterPi,HeadBlockWidth,HeadCenter,HeadLength,
            HeadNormal,HeadPointSize,HeadPointColor,HeadTop,HeadWidth,TailBlockWidth,
            TailCenter,TailLength,TailNormal,TailPointSize,TailPointColor,TailTop,
            TailWidth}/.{opts}/.Options[ArcArrow3D];x=a;xLength=Sqrt[N[x.x]];
    bLength=Sqrt[N[b.b]];bUnit=b/bLength;y=N[Cross[Cross[x,bUnit],x]];
    If[Sqrt[y.y]==0.,y=N[Cross[headNormal,x]]];y=y/Sqrt[y.y]*xLength;
    fullAlpha=ArcCos[N[bUnit.x]/xLength];
    If[greaterPi===True,fullAlpha=2Pi-fullAlpha;y=-y];
    minAlpha=(tailLength*tailCenter+tailTop)/xLength;
    maxAlpha=fullAlpha-(headLength*headCenter+headTop)/xLength;{
      Line[Table[
          c+x Cos[minAlpha+(maxAlpha-minAlpha)*i/plotPoints]+
            y Sin[minAlpha+(maxAlpha-minAlpha)*i/plotPoints],{i,0,
            plotPoints}]],   
      If[minAlpha==0.,{}, 
        Arrow3D[c+x ,c+x Cos[minAlpha]+y Sin[minAlpha],HeadLength->0,
          HeadBlockWidth->0,HeadPointSize->0,
          HeadTop->0,TailBlockWidth->tailBlockWidth,TailCenter->tailCenter,
          TailLength->tailLength,TailNormal->tailNormal,
          TailPointSize->tailPointSize,TailPointColor->tailPointColor,
          TailTop->tailTop,TailWidth->tailWidth]],
      If[maxAlpha>=fullAlpha,{},
        Arrow3D[c+x Cos[maxAlpha]+y Sin[maxAlpha],
          c+x Cos[fullAlpha]+y Sin[fullAlpha],HeadBlockWidth->headBlockWidth,
          HeadCenter->headCenter,HeadLength->headLength,
          HeadNormal->headNormal,HeadPointSize->headPointSize,
          HeadPointColor->headPointColor,HeadTop->headTop,TailLength->0,
          TailBlockWidth->0,TailPointSize->0,TailTop->0]]}];

End[]

EndPackage[]

Mathematica Syntax Overview

Lists and Tables

Table[i, {i, 0, 5}]

Table[i, {i, 0, 5, 2.5}]

f[x_, y_] = x^2 - y^2
Table[{i, j, f[i, j]}, {i, -1, 1}, {j, -1, 1}]

Graphics3D Objects

Line Primitive

f[t_] = {Cos[t], Sin[t], t/2};
Line[Table[f[t], {t, 0, 2  Pi, 2  Pi/30. }]]

Show[Graphics3D[%]]

WriteLiveForm["sample_helix.lg3d", %]

Polygon Primitive

f[x_, y_] = x^2 - y^2
dx = 0.1
dy = 0.1
Table[
      Polygon[{{i, j, f[i, j]}, {i + dx, j, f[i + dx, j]}, {i + dx, j + dy, 
            f[i + dx, j + dy]}, {i, j + dy, f[i, j + dy]}}], {i, -1, 
        1 - dx/2, dx}, {j, -1, 1 - dy/2, dy}]

Show[Graphics3D[%]]

WriteLiveForm["sample_saddle.lg3d",  Graphics3D[%]]

Putting it all Together

{Point[{0, 0, 0}], {RGBColor[0, 1, 0], PointSize[0.05], 
        Point[{1, 2, 3}]}, 
      Polygon[{{1, 0, 0}, {1, 1, 0}, {1, 1, 1}, {1, 0, 1}}], {EdgeForm[], 
        FaceForm[RGBColor[1, 0, 0], RGBColor[0, 0, 1]], 
        Polygon[{{0, 1, 1}, {-1, 0, 1}, {-1, 1, 1}}]}, {RGBColor[0, 
          1, 1], Thickness[0.05], 
        Line[{{-1, 1, 2}, {1, 1, 2}}]}}

Show[Graphics3D[%]]

Learning Example (Original Code)

f[x_, y_] = 2  y*Exp[(-x^2 - y^2)];
xmin = -1; xmax = 3; ymin = -2; ymax = 1;
n = 20;
dx = (xmax - xmin)/n; dy = (ymax - ymin)/n;

surface = {Table[
            Polygon[{{i, j, f[i, j]}, {i + dx, j, f[i + dx, j]}, {i + dx, 
                  j + dy, f[i + dx, j + dy]}, {i, j + dy, 
                  f[i, j + dy]}}], {i, xmin, xmax - dx/2, dx}, {j, ymin, 
              ymax - dy/2, dy}]};
badmesh = {GrayLevel[0.7], 
          Table[Line[{{i, j, f[i, j]}, {i + dx, j, f[i + dx, j]}, {i + dx, 
                  j + dy, f[i + dx, j + dy]}, {i, j + dy, f[i, j + dy]}, {i, 
                  j, f[i, j]}}], {i, xmin, xmax - dx/2, dx}, {j, ymin, 
              ymax - dy/2, dy}]};
mesh = {GrayLevel[0.7], 
          Table[Table[
              Line[{{i, j, f[i, j]}, {i + dx, j, f[i + dx, j]}}], {i, xmin, 
                xmax - dx/2, dx}], {j, ymin, ymax, dy}], 
          Table[Table[
              Line[{{i, j, f[i, j]}, {i, j + dy, f[i, j + dy]}}], {j, ymin, 
                ymax - dy/2, dy}], {i, xmin, xmax, 
              dx}]};

    
xSection = {RGBColor[0, 1, 0], Thickness[0.005], 
          Table[Line[{{x, j, f[x, j]}, {x, j + dy, f[x, j + dy]}}], {j, ymin, 
              ymax - dy, dy}]};

    
ySection = {RGBColor[0, 0, 1], Thickness[0.005], 
          Table[Line[{{i, y, f[i, y]}, {i + dx, y, f[i + dx, y]}}], {i, xmin, 
              xmax - dx, dx}]};

    
point = {RGBColor[1, 0, 0], PointSize[0.02], 
          Point[{x, y, z}]};

Polygons

ShowLive[Graphics3D[surface, Boxed -> False]];

WriteLive["surface", 
        Graphics3D[surface, Boxed -> False]];

Mesh

mesh = {GrayLevel[0.7], 
          Table[Table[
              Line[{{i, j, f[i, j]}, {i + dx, j, f[i + dx, j]}}], {i, xmin, 
                xmax - dx/2, dx}], {j, ymin, ymax, dy}], 
          Table[Table[
              Line[{{i, j, f[i, j]}, {i, j + dy, f[i, j + dy]}}], {j, ymin, 
                ymax - dy/2, dy}], {i, xmin, xmax, dx}]};

ShowLive[Graphics3D[mesh, Boxed -> False]];

WriteLive["mesh", 
        Graphics3D[mesh, Boxed -> False]];

Polygons Plus point

ShowParametrized[Graphics3D[{surface, point}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{z -> 2y*Exp[-x^2-y^2]}"];

WriteParametrized["surfacePoint", 
        Graphics3D[{surface, point}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{z -> 2y*Exp[-x^2-y^2]}"];

Mesh plus point

ShowParametrized[Graphics3D[{mesh, point}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 1, 1, y]], z -> 2y*Exp[-x^2-y^2]}"];

WriteParametrized["meshPoint", 
        Graphics3D[{mesh, point}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 2, 2, y]], z -> 2y*Exp[-x^2-y^2]}"];

Mesh plus Sections

ShowParametrized[
        Graphics3D[{mesh, point, xSection, ySection}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 1, 1, y]], z -> 2y*Exp[-x^2-y^2]}"];

WriteParametrized["meshSections", 
        Graphics3D[{mesh, point, xSection, ySection}, Boxed -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 2, 2, y]], z -> 2y*Exp[-x^2-y^2]}"];

Tangent plane (plus mesh, sections and point)

(* 
      Create the tangent plane at the point {x, y, 
          f[x, y]}    *) 
 (* 
      First use the partial derivatives to find two vectors *) 
 (* 
      a and b for the parametrization *) 
fx[
        x_, y_] = D[f[x, y], x];  
    fy[x_, y_] = D[f[x, y], y];

    a[x_, y_] = {1, 0, fx[x, y]};

    b[x_, y_] = {0, 1, fy[x, y]};


    plane[s_, 
          t_] = ({x, y, z} + s*a[x, y] + t*b[x, y])*{1, 1, 
            1};

 (* 
      Now creat the polygons *) 

    smin = -1/2; smax = 1/2; tmin = -1/2; 
    tmax = 1/2;

    n = 10;  ds = (smax - smin)/n; 
    dt = (tmax - tmin)/n;

    tanplane = {FaceForm[GrayLevel[0.8]], 
          Table[Polygon[{plane[i, j], plane[i + ds, j], 
                plane[i + ds, j + dt], plane[i, j + dt]}], {i, smin, 
              smax - ds/2, ds}, {j, tmin, tmax - dt/2, 
              dt}]};

ShowParametrized[
        Graphics3D[{mesh, point, , xSection, ySection, tanplane}, 
          Boxed -> False, Lighting -> False, 
          BoxRatios -> {2, 2, 1}], IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 1, 1, y]], z -> 2y*Exp[-x^2-y^2]}"];

WriteParametrized["meshPlane", 
        Graphics3D[{mesh, point, , xSection, ySection, tanplane}, 
          Boxed -> False, Lighting -> False], 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> If[x < -1, -1, If[x > 3, 3, x]], y -> If[y < -2, \
-2, If[y > 2, 2, y]], z -> 2y*Exp[-x^2-y^2]}"];

Animated Version?  (Hmm....)

AnimateLive[
        Graphics3D[{mesh, point, , xSection, ySection, tanplane}, 
          Boxed -> False, Lighting -> False], {t, 0, 2  Pi}, 
        IndVars -> "{x -> 1, y -> 0}", 
        DepVars -> "{x -> Cos[t], x -> If[x < -1, -1, If[x > 3, 3, x]], y \
-> If[y < -2, -2, If[y > 2, 2, y]], z -> 2y*Exp[-x^2-y^2]}"];

Introductory Example

Construction of the wireframe mesh

f[x_, y_] = 2  y*Exp[-x^2 - y^2];
xmin = -1; xmax = 3;
ymin = -2; ymax = 1;

n = 20;
dx = (xmax - xmin)/n;
\(\(\(dy = \((ymax - ymin)\)/n;\)\(
\)
    \)\)
mesh = {GrayLevel[0.7],   

  
Table[  
Table[  
Line[{{i, j, 
                    f[i, j]}, {i + dx, j, 
                    f[i + dx, j]}}], 
{i, xmin, 
                xmax - dx/2, dx}], {j, ymin, ymax, 
              dy}], 

  
Table[  
Table[  
Line[{{i, j, 
                    f[i, j]}, {i, j + dy, 
                    f[i, j + dy]}}], 
{j, ymin, 
                ymax - dy/2, dy}], {i, xmin, xmax, dx}]};

example = Graphics3D[mesh, Boxed -> False];
WriteLiveForm["mesh.lg3d", example]

Adding the Point

\(\(\( (*"mesh"\ is\ the\ same\ as\ in\ the\ previous\ example*) \)\(\(point = {RGBColor[1, 0, 0], PointSize[0.02], 
          Point[{x, y, z}]};\)


    \(example = Graphics3D[{mesh, point}, Boxed -> False];\)

    WriteLiveForm["meshPoint.lg3d", example]\)\)\)

Adding the Cross Sections

\(\(\( (*\ \("mesh"\ and\ "point"\ are\ the\ same\ as\ in\ the\ previous\ example\)\(,\)\ *) \)\( (*\ 
      as\ are\ "f[x_,y_],"\ "xmin,"\ "xmax,"\ "dx"\ and\ so\ \(\(on\)\(.\)\)\ \ \ \ \ \ \ \ \ \ *) \)\(
\)\(
\)\(\(xSection = {RGBColor[0, 1, 0], Thickness[0.005], 
          Table[Line[{{x, j, f[x, j]}, {x, j + dy, f[x, j + dy]}}], {j, ymin, 
              ymax - dy, dy}]};\)


    \(ySection = {RGBColor[0, 0, 1], Thickness[0.005], 
          Table[Line[{{i, y, f[i, y]}, {i + dx, y, f[i + dx, y]}}], {i, xmin, 
              xmax - dx, dx}]};\)


    \(example = 
        Graphics3D[{mesh, point, xSection, ySection}, 
          Boxed -> False];\)

    WriteLiveForm["meshSections.lg3d", example]\)\)\)

Adding the Tangent Plane

\(\(\( (*\ "mesh,"\ "point,"\ "xSection"\ and\ \*""ySection are "*) \)\(
\)\( (*\ 
      the\ same\ as\ in\ the\ previous\ example, \ 
      as\ are\ \ \ *) \)\(
\)\( (*"xmin,"\ "xmax,"\ "dx"\ and\ so\ \(\(on\)\(.\)\)\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ *) \)\(
\)\(
\)\( (*\ 
      Create\ the\ tangent\ plane\ at\ the\ point\ {x, y, 
          f[x, y]}\ \ \ \ *) \)\( (*\ 
      First\ use\ the\ partial\ derivatives\ to\ find\ two\ vectors\ *) \)\(
\)\( (*\ 
      a\ and\ b\ for\ the\ parametrization\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ *) \)\(
\)\(
\)\(fx[x_, y_] = 
      D[f[x, y], x]; \ \ \ \  (*\ 
      Differentiate\ with\ respect\ to\ x\ *) 
fy[x_, y_] = 
      D[f[x, y], y]; \ \ \  (*\ 
      Differentiate\ with\ respect\ to\ y\ *) 
a[x_, 
        y_] = {1, 0, fx[x, y]};

    \(b[x_, y_] = {0, 1, 
          fy[x, y]};\)

 (*\ 
      Here\ is\ the\ parametric\ equation\ for\ the\ plane\ tangent\ \ *) 
 (*\ 
      to\ the\ surface\ at\ the\ point\ {x, y, f[x, y]} . \ 
          Recall\ that\ \ *) 
 (*\ 
      the\ value\ of\ z = 
        f[x, y]\ is\ automatically\ calculated\ by\ \ *) 
 (*\ \(LiveGraphics3D\)\(.\)\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ *) 

    \(plane[s_, t_] = {x, y, z} + s*a[x, y] + 
          t*b[x, y];\)

 (*Now\ create\ the\ polygons; 
      let\ s\ and\ t\ range\ from - 1/2\ to\ 1/2*) 

    smin = \(-1\)/2; smax = 1/2; tmin = \(-1\)/2; 
    tmax = 1/2;

 (*We' ll\ use\ a\ 10  
        x10\ grid\ for\ the\ parametrized\ plane*) 

    n = 10; ds = \((smax - smin)\)/n; 
    dt = \((tmax - tmin)\)/
        n;

 (*Use\ a\ Table\ to\ generate\ the\ list\ of\ 100\ polygons*) 

    \(tanplane = {FaceForm[GrayLevel[0.8]], 
          Table[Polygon[{plane[i, 
                  j],  (*4\ vertices\ for\ each*) 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ plane[i + ds, 
                  j], 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ plane[i + ds, 
                  j + dt], 
\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ plane[i, j + dt]}], 
{i, smin, 
              smax - ds/2, ds}, {j, tmin, tmax - dt/2, 
              dt}]};\)


    \(example = 
        Graphics3D[{mesh, point, xSection, ySection, tanplane}, 
          Boxed -> False, Lighting -> False];\)

    WriteLiveForm["meshPlane.lg3d", example]\)\)\)

Including Text

\(\(\( (*\ 
      all\ but\ the\ last\ two\ commands\ are\ the\ same\ as\ in\ the\ previous\ example\ *) \)\(\(labels = {Text["x = const.", {x, \(-2\), 
              0}, {1, 1}], 
          Text["y = const.", {3, y, 0}, {\(-1\), 
              1}]};\)


    example = 
      Graphics3D[{mesh, point, xSection, ySection, tanplane, labels}, 
        Boxed -> False]

    WriteLiveForm["meshPlaneText1.lg3d", example]\)\)\)

To use a different font family and font size:

labels = {Text[
            StyleForm["x = const.", FontFamily -> "Times", 
              FontSize -> 20], {x, -2, 0}, {1, 1}], 
          Text[StyleForm["y = const.", FontFamily -> "Times", 
              FontSize -> 20], {3, y, 0}, {-1, 1}]};

To use bold or italic text:

labels = {Text[
            StyleForm[
              StringForm["`1` = const.", 
                StyleForm["x", FontSlant -> "Italic"]], 
              FontFamily -> "Times", 
              FontSize -> 20], {x, -2, 0}, {1, 1}], 
          Text[StyleForm[
              StringForm["`1` = const.", 
                StyleForm["y", FontWeight -> "Bold"]], 
              FontFamily -> "Times", FontSize -> 20], {3, y, 
              0}, {-1, 1}]};

To display the current values of x and y:

labels = {Text[
            StyleForm[StringForm["`1` = `2`", "x", x], 
              FontFamily -> "Times", 
              FontSize -> 20], {x, -2, 0}, {1, 1}], 
          Text[StyleForm[StringForm["y = `1`", y], 
              FontFamily -> "Times", FontSize -> 20], {3, y, 
              0}, {-1, 1}]};

To truncate the number of digits displayed in the previous example.  (Requires new definitions for DEPENDENT_VARIABLES.)

labels = {Text[
            StyleForm[StringForm["`1` = `2`", "x", xDisplay], 
              FontFamily -> "Times", 
              FontSize -> 20], {x, -2, 0}, {1, 1}], 
          Text[StyleForm[StringForm["y = `1`", yDisplay], 
              FontFamily -> "Times", FontSize -> 20], {3, y, 
              0}, {-1, 1}]};

Labeling Axes and Plots

\(\(\( (*all\ but\ the\ last\ three\ commands\ are\ the\ same\ as\ in\ the\ previous\ example*) \)\(\(axeslabel = {StyleForm["x", 
            FontFamily -> "Times", FontSize -> 20], 
          StyleForm["y", FontFamily -> "Times", 
            FontSize -> 20], 
          StyleForm["z", FontFamily -> "Times", 
            FontSize -> 20]};\)


    example = 
      Graphics3D[{mesh, point, xSection, ySection, tanplane}, 
        Boxed -> True, Axes -> True, AxesLabel -> axeslabel]

    WriteLiveForm["meshPlaneText5.lg3d", example]\)\)\)

\(\(\( (*all\ but\ the\ last\ three\ commands\ are\ the\ same\ as\ in\ the\ previous\ example*) \)\(\(plotlabel = 
        StyleForm[StringForm["Plot of 2*y*Exp[-x^2-y^2] = `1`", z], 
          FontFamily -> "Times", 
          FontSize -> 20];\)


    example = 
      Graphics3D[{mesh, point, xSection, ySection, tanplane}, 
        Boxed -> False, PlotLabel -> plotlabel]

    WriteLiveForm["meshPlaneText6.lg3d", example]\)\)\)

\(\(\( (*all\ but\ the\ last\ three\ commands\ are\ the\ same\ as\ in\ the\ previous\ example*) \)\(\(plotlabel = 
        StyleForm[
          StringForm["Plot of 2 `1` `2` = `3`", 
            StyleForm["y", FontSlant -> "Italic"], 
            Superscript["e", 
              StringForm["-`1`-`2`", 
                Superscript[
                  StyleForm["x", 
                    FontSlant -> "Italic"], "2"], 
                Superscript[
                  StyleForm["y", 
                    FontSlant -> "Italic"], "2"]]], z], 
          FontFamily -> "Times", 
          FontSize -> 20];\)


    example = 
      Graphics3D[{mesh, point, xSection, ySection, tanplane}, 
        Boxed -> False, PlotLabel -> plotlabel]

    WriteLiveForm["meshPlaneText7.lg3d", example]\)\)\)

Occlusions of Objects

Sphere with goodRing and badRing

f[r_, t_, p_] = {r*Sin[p] Cos[t], r*Sin[p] Sin[t], 
          r*Cos[p]};

    
n = 20;
tmin = 0; tmax = 2  Pi;  
    dt = (tmax - tmin)/(2  n);
pmin = 0; 
    pmax = Pi;    dp  =  (pmax - pmin)/
        n;

sphere = {FaceForm[GrayLevel[0.7]], 
          Table[Polygon[{f[1, i, j], f[1, i + dt, j], f[1, i + dt, j + dp], 
                f[1, i, j + dp]}], {i, tmin, tmax - dt/2, dt}, {j, pmin, 
              pmax - dp/2, dp}]};

badRing  =  {Thickness[0.01], RGBColor[0, 0, 1], 
          Line[Table[
              f[1.1, i, Pi/2], {i, tmin, tmax, 
                dt}]]};
Show[
        Graphics3D[{sphere, badRing}, Lighting -> False, 
          Boxed -> False]];

goodRing  =  {Thickness[0.01], RGBColor[0, 0, 1], 
          Table[Line[{f[1.1, i, Pi/2], f[1.1, i + dt, Pi/2]}], {i, tmin, 
              tmax - dt/2, dt}]};
Show[
        Graphics3D[{sphere, goodRing}, Lighting -> False, 
          Boxed -> False]];

WriteLive["badRing", 
        Graphics3D[{sphere, badRing}, Lighting -> False, 
          Boxed -> False]];

WriteLive["goodRing", 
        Graphics3D[{sphere, goodRing}, Lighting -> False, 
          Boxed -> False]];

ByteCount[badRing]
ByteCount[goodRing]

Cyclic Occlusions with Lines

Graphics3D[{Thickness[
          0.05], RGBColor[1, 0, 0], 
        Line[{{-2, -1, -1}, {2, -1, 1}}], RGBColor[0, 1, 0], 
        Line[{{1, -2, -1}, {1, 2, 1}}], RGBColor[0, 0, 1], 
        Line[{{2, 1, -1}, {-2, 1, 1}}], RGBColor[1, 0, 1], 
        Line[{{-1, 2, -1}, {-1, -2, 1}}]}, 
      PlotRange -> {{-2, 2}, {-2, 2}, {-1, 1}}, 
      ViewPoint -> {0, 0, 4}, ViewVertical -> {0, 1, 0}, 
      Boxed -> False]

Show[%]

(*A Graphics3D object consisting of eight Lines which 
shows cyclic occlusions for certain view points*) 

Graphics3D[{Thickness[0.05], 
        RGBColor[1, 0, 0], Line[{{-2, -1, -1}, {0, -1, 0}}], 
        Line[{{0, -1, 0}, {2, -1, 1}}], RGBColor[0, 1, 0], 
        Line[{{1, -2, -1}, {1, 0, 0}}], Line[{{1, 0, 0}, {1, 2, 1}}], 
        RGBColor[0, 0, 1], Line[{{2, 1, -1}, {0, 1, 0}}], 
        Line[{{0, 1, 0}, {-2, 1, 1}}], RGBColor[1, 0, 1], 
        Line[{{-1, 2, -1}, {-1, 0, 0}}], 
        Line[{{-1, 0, 0}, {-1, -2, 1}}]}, 
      PlotRange -> {{-2, 2}, {-2, 2}, {-1, 1}}, 
      ViewPoint -> {0, 0, 4}, ViewVertical -> {0, 1, 0}, 
      Boxed -> False]

Show[%]

Overlapping Triangles

triangle1  =  {FaceForm[SurfaceColor[RGBColor[1, 0, 0]]], 
          Polygon[{{0, 1, 0}, {0, 2, 0}, {2, 2, 
                2}}]};
triangle2  =  {FaceForm[SurfaceColor[RGBColor[0, 1, 0]]], 
          Polygon[{{1, 2, 0}, {2, 2, 0}, {2, 0, 
                2}}]};
triangle3  =  {FaceForm[SurfaceColor[RGBColor[0, 0, 1]]], 
          Polygon[{{2, 1, 0}, {2, 0, 0}, {0, 0, 2}}]};

triangle1  =  {FaceForm[RGBColor[1, 0, 0]], 
          Polygon[{{0, 0, 0}, {0, 1, 0}, {1, 1, 
                1}}]};
triangle2  =  {FaceForm[RGBColor[0, 1, 0]], 
          Polygon[{{0, 1, 0}, {1, 1, 0}, {1, 0, 
                1}}]};
triangle3  =  {FaceForm[RGBColor[0, 0, 1]], 
          Polygon[{{1, 0, 0}, {1, 0, 0}, {0, 0, 1}}]};

triangle1  = 
        Polygon[{{0, 1, 0}, {0, 2, 0}, {2, 2, 
              2}}];
triangle2  = 
        Polygon[{{1, 2, 0}, {2, 2, 0}, {2, 0, 
              2}}];
triangle3  =  
        Polygon[{{2, 1, 0}, {2, 0, 0}, {0, 0, 2}}];

triangle1  = 
        Polygon[{{0, 1, 0}, {0, 3, 0}, {3, 3, 
              3}}];
triangle2  = 
        Polygon[{{1, 3, 0}, {3, 3, 0}, {3, 0, 
              3}}];
triangle3  =  
        Polygon[{{3, 2, 0}, {3, 0, 0}, {0, 0, 
              3}}];
triangle4  =  
        Polygon[{{0, 0, 0}, {2, 0, 0}, {0, 3, 3}}];

ShowLive[
        Graphics3D[{triangle1, triangle2, triangle3, 
            triangle4}]];

Stereo Images

Needs["Graphics`"]

Show[Polyhedron[Icosahedron], Boxed -> False, 
        ViewPoint -> { .9,  .65, 1.3}, 
        ViewVertical -> {- .25, -1, 0.5}];

Advanced Examples

Simson Line

\(\(\( (*\ {ax, ay}, \ {bx, 
        by}, \ {cx, cy}\ are\ the\ vertices\ of\ a\ triangle, \ {x, 
          y}\ is\ a\ input\ point\ that\ is\ projected\ onto\ the\ circum\ circle\ *) \)\(\ \)\(
\)\(independentVariables\  = \ {x\  -> \ 1.5, \ y\  -> \ 0.9, \ ax\  -> \ 0. , \ 
          ay\  -> \ 0. , \ 
\ \ \ bx\  -> \ 1. , \ by\  -> \  .7, \ 
          cx\  -> \ 1.6, \ cy\  -> \ \(-0.9\)};\)\)\)

\(\(\( (*\ 
      Circumcircle\ returns\ {{x, y}, 
          r}\ to\ specify\ the\ center\ and\ radius\ of\ the\ circum\ circle\ of\ the\ triangle\ specified\ by\ {x1, y1}, \ {x2, y2}, \ {x3, 
        y3}\ *) \)\(\ \)\(
\)\(Circumcircle[{{x1_, \ y1_}, \ {x2_, \ 
              y2_}, \ {x3_, \ y3_}}]\  := \ 
\ \ \ Module[{a\  = \ 
              Det[{{x1, \ y1, \ 1}, \ {x2, \ y2, \ 1}, \ {x3, \ y3, \ 
                    1}}], \ 
\ \ \ \ \ \ d\  = \ \(-1\)/
                  2\ Det[{{x1^2\  + \ y1^2, \ y1, \ 1}, \ {x2^2\  + \ y2^2, \ 
                      y2, \ 1}, \ 
\ \ \ \ \ \ \ \ \ {x3^2\  + \ y3^2, \ 
                      y3, \ 1}}], \ 
\ \ \ \ \ \ f\  = \ 
              1/2\ Det[{{x1^2\  + \ y1^2, \ x1, \ 1}, \ {x2^2\  + \ y2^2, \ 
                      x2, \ 1}, \ 
\ \ \ \ \ \ \ \ \ {x3^2\  + \ y3^2, \ 
                      x3, \ 1}}], \ 
\ \ \ \ \ \ g\  = \ \(-Det[{{x1^2\  + \ 
                        y1^2, \ x1, \ y1}, \ {x2^2\  + \ y2^2, \ x2, \ 
                      y2}, \ 
\ \ \ \ \ \ \ \ \ {x3^2\  + \ y3^2, \ x3, \ 
                      y3}}]\)}, \ 
\ \ \ \ \ \ {{\(-d\)/a, \ \(-f\)/a}, \ 
            Sqrt[\((f^2\  + \ d^2)\)/a^2\  - \ g/a]}];\)\)\)

\(\(\( (*\ 
      projectToLine\ returns\ the\ closest\ 2  
        D\ point\ to\ x\ on\ the\ line\ through\ a\ and\ b\ *) \)\(
\)\(projectToLine[x_, \ a_, \ 
          b_]\  := \ 
\ \ \ Module[{}, \ 
          a\  + \ \((b\  - \ 
                  a)\)*\((x\  - \ a)\) . \((b\  - \ 
                      a)\)/\((\((b\  - \ a)\) . \((b\  - \ 
                        a)\))\)];\)\)\)

pc  =  
      projectToLine[{px,  py,  0},  {ax,  ay,  0}, {bx,  by,  0}]; 
    pa  =  projectToLine[{px,  py,  0},  {bx,  by,  0}, {cx,  cy,  
          0}]; pb  =  
      projectToLine[{px,  py,  0},  {cx,  cy,  0}, {ax,  ay,  
          0}];

\(\(\( (*\ 
      circ\ is\ of\ the\ form\ {{x, y}, 
          r}\ specifying\ the\ circum\ circle\ of\ our\ triangle\ *) \)\(
\)\(circ\  = \ 
        Circumcircle[{{ax, \ ay}, \ {bx, \ by}, \ {cx, \ 
              cy}}];\)\)\)

\(dependentVariables\  = \ {ccx\  -> \ circ[\([1, \ 1]\)], \ 
              ccy\  -> \ circ[\([1, \ 2]\)], \ 
\ \ \ ccr\  -> \ 
                circ[\([2]\)], \ 
\ \ \ angle\  -> \ 
                ArcTan[x\  - \ ccx, \ y\  - \ ccy], \ 
\ \ \ px\  -> \ 
                ccx\  + \ ccr*Cos[angle], \ 
              py\  -> \ ccy\  + \ ccr*Sin[angle], 
\ \ \ x\  -> \ px, \ 
              y\  -> \ py, \ 
\ \ \ pax\  -> \ pa[\([1]\)], \ 
              pay\  -> \ pa[\([2]\)], \ 
\ \ \ pbx\  -> \ pb[\([1]\)], \ 
              pby\  -> \ pb[\([2]\)], \ 
\ \ \ pcx\  -> \ pc[\([1]\)], \ 
              pcy\  -> \ pc[\([2]\)], \ 
\ \ \ lab\  -> \ 
                Sqrt[\(({pax, \ pay, \ 0}\  - \ {pbx, \ pby, \ 
                          0})\) . 
\ \ \ \ \ \ \(({pax, \ pay, \ 
                          0}\  - \ {pbx, \ pby, \ 
                          0})\)], \ 
\ \ \ lac\  -> \ 
                Sqrt[\(({pax, \ pay, \ 0}\  - \ {pcx, \ pcy, \ 
                          0})\) . 
\ \ \ \ \ \ \(({pax, \ pay, \ 
                          0}\  - \ {pcx, \ pcy, \ 0})\)], 
\ \ \ lcb\  -> \ 
                Sqrt[\(({pcx, \ pcy, \ 0}\  - \ {pbx, \ pby, \ 
                          0})\) . 
\ \ \ \ \ \ \(({pcx, \ pcy, \ 
                          0}\  - \ {pbx, \ pby, \ 
                          0})\)], \ 
\ \ \ sax\  -> \ 
                If[lac\  > \ lcb, \ If[lac\  > \ lab, \ pax, \ pax], \ 
                  If[lcb\  > \ lab, \ pcx, \ pax]], \ 
\ \ \ say\  -> \ 
                If[lac\  > \ lcb, \ If[lac\  > \ lab, \ pay, \ pay], \ 
                  If[lcb\  > \ lab, \ pcy, \ pay]], \ 
\ \ \ sbx\  -> \ 
                If[lac\  > \ lcb, \ If[lac\  > \ lab, \ pcx, \ pbx], \ 
                  If[lcb\  > \ lab, \ pbx, \ pbx]], \ 
\ \ \ sby\  -> \ 
                If[lac\  > \ lcb, \ If[lac\  > \ lab, \ pcy, \ pby], \ 
                  If[lcb\  > \ lab, \ pby, \ pby]]};\)

dependentVariables // InputForm

triangle  = {{Thickness[0.01],  
            Line[{{ax,  ay,  0},  {bx,  by,  0},  {cx,  cy,  
                  0}, {ax,  ay,  0}}]}, {RGBColor[1, 0, 0], 
            PointSize[0.03],  Point[{x,  y,  0.1}], 
            Point[{ax,  ay,  0.1}],  Point[{bx,  by,  0.1}],  
            Point[{cx,  cy,  0.1}]}};

\(\(\( (*\ 
      projected\ points\ and\ lines\ between\ them\ and\ extrapolating\ the\ line\ *) \)\(
\)\(projectedPoints = {Thickness[0.005], 
          PointSize[0.03], \ 
\ \ \ Point[{pax, \ pay, \ 0}], \ 
          Point[{pbx, \ pby, \ 0}], \ 
\ \ \ Point[{pcx, \ pcy, \ 0}], \ 
          Line[{{px, \ py, \ 0}, \ {pax, \ pay, \ 
                0}}], \ 
\ \ \ Line[{{px, \ py, \ 0}, \ {pbx, \ pby, \ 
                0}}], \ 
\ \ \ Line[{{px, \ py, \ 0}, \ {pcx, \ pcy, \ 
                0}}], \ {Thickness[0.01], \ 
            Line[{{sax\  + \ 2*\((sax\  - \ sbx)\), \ 
                  say\  + \ 2*\((say\  - \ sby)\), \ 
                  0}, \ 
\ \ \ \ \ \ {sbx\  + \ 2*\((sbx\  - \ sax)\), \ 
                  sby\  + \ 2*\((sby\  - \ say)\), \ 0}}]}};\)\)\)

(* 
      circum circle *) 
circumcircle  = {Thickness[0.005], 
          Line[Table[{ccx,  ccy,  0}  + 
                ccr*{Cos[phi],  Sin[phi],  0}, {phi,  0. ,  
                2 Pi  +  0.00001,  2 Pi/64. }]]};

\(\(\( (*\ 
      assemble\ everything\ *) \)\(
\)\(\(simson\  = \ 
        Graphics3D[{triangle, \ projectedPoints, \ \ circumcircle}, \ 
          Boxed\  -> \ False, ViewPoint\  -> \ {0, \ 0, \ 1000}, 
          ViewVertical\  -> \ {0, \ 1, \ 0}, \ 
          PlotRange\  -> \ {{\(-0.5\), \ 2.0}, \ {\(-1.5\), \ 
                1}, \ {\(-1\), \ 1}}];\)\(
\)
    \)\)\)

Show[
        simson //.  Join[independentVariables,  
            dependentVariables]];

WriteLiveForm["simson.lg3d", simson];

Spirograph

(* 
      independent variables :  
          current time t;  
time of last time step;  coordinates of point on outer circle {xR, 
          yR}; 
center of inner circle {xr,  
          yr}; 
point on inner circle {xrho, 
          yrho} which is traced *)  
independentVariables  =  {t -> 0, 
          told -> 0, xR -> 10, yR -> 0, xr -> 8, 
          yr -> 0, xrho -> 9, yrho -> 0};

dependentVariables = {R -> 
            Sqrt[xR*xR + yR*yR], 
          r -> 
            6*R/Round[
                  6*R/Sqrt[(xR - xr)*(xR - xr) + (yR - 
                                yr)*(yR - yr)]], 
          xrh -> (R - r) Cos[told], 
          yrh -> (R - r) Sin[told], 
          rho -> 
            Sqrt[(xrh - xrho)*(xrh - xrho) + (yrh - 
                      yrho)*(yrh - yrho)], Rsubr -> R - r, 
          Rdivr -> R/r*Sign[r - R - 0.000000001], xR -> R Cos[t], 
          yR -> R Sin[t], xr -> (R - r) Cos[t], 
          yr -> (R - r) Sin[t], 
          xrho -> xr + rho Cos[Rdivr t], 
          yrho -> yr + rho Sin[Rdivr t], 
          told -> t};

dependentVariables // InputForm

skeleton = {Thickness[0.005], 
          Line[{{0, 0, 0}, {xR, yR, 0}}], 
          Line[{{xr, yr, 0}, {xrho, yrho, 0}}], PointSize[0.03], 
          Point[{0, 0, 0}], RGBColor[1, 0, 0], Point[{xR, yR, 0.1}], 
          Point[{xr, yr, 0.1}], Point[{xrho, yrho, 0.1}]};

circleR = 
        N[Line[Table[{R*Cos[i], R*Sin[i], 0}, {i, 0, 2  Pi, 
                2  Pi/64}]]];

circler = 
        N[Line[Table[{xr + r*Cos[i], yr + r*Sin[i], 0}, {i, 0, 2  Pi, 
                2  Pi/64}]]];

trace = {Thickness[0.01], 
          N[Line[Table[{Rsubr*Cos[i], Rsubr*Sin[i], 0} + {rho Cos[Rdivr i], 
                    rho Sin[Rdivr i], 0}, {i, 0, 6*2 Pi, 
                  2 Pi/64}]]]};

spiro =  
        Graphics3D[{skeleton, circleR, circler, trace},  Boxed  ->  False, 
          ViewPoint  ->  {0,  0,  1000}, 
          ViewVertical  ->  {0,  1,  0}];

Show[
        spiro //.  Join[independentVariables,  
            dependentVariables]];

WriteLiveForm["spiro.lg3d", 
        spiro, {t, 0, 6. *2 Pi, 0.1}];

Frenet-Serret formulas

\(\(\( (*\ functions\ to\ define\ a\ vector\ symbol, \ say\ "v", \ 
      as\ {vx, vy, vz}; \ 
      and\ to\ either\ define\ independent\ variables\ or\ dependent\ variables\ for\ these\ coordinates\ *) \)\(
\)\(\ \ \)\(
\)\(\(defineVector[name_String] := 
        Module[{}, 
          Evaluate[Symbol[name]] = {Symbol[name <> "x"], 
              Symbol[name <> "y"], 
              Symbol[name <> "z"]}];\)


    \(defineVector[list_List] := 
        Map[defineVector, list];\)


    \(independentVariablesForVector[name_String, 
          value_List] := {Symbol[name <> "x"] -> value[\([1]\)], 
          Symbol[name <> "y"] -> value[\([2]\)], 
          Symbol[name <> "z"] -> 
            value[\([3]\)]};\)


    \(dependentVariablesForVector[name_String, \ expr_] := 
        Module[{namex = Symbol[name <> "x"], 
            namey = Symbol[name <> "y"], 
            namez = Symbol[name <> "z"]}, {namex -> expr[\([1]\)], 
            namey -> expr[\([2]\)], 
            namez -> expr[\([3]\)]}];\)\)\)\)

SetOptions[Arrow3D, 
        HeadLength -> 0.2];

\(\(\( (*\ define\ control\ vertices\ of\ a\ cubic\ Bezier\ curve\ b0, \ 
      b1, \ b2, \ b3, \ point\ on\ the\ curve\ x, \ derivatives\ dxdt, \ 
      ddxddt, \ dddxdddt, \ tangent\ vector, \ curvature\ vector, \ 
      binormal\ vector, \ 
      and\ a\ temporary\ vector\ vb1 . \ 
          each\ vector\ is\ defined\ as\ a\ list\ of\ three\ coordinates, \ 
      e . g . \ b0\ as\ {b0x, \ b0y, \ 
          b0z}\ *) \)\(\ \ \)\(
\)\(defineVector[{"b0", "b1", "b2", "b3", "x", "dxdt", "ddxddt", "dddxdddt", "vt", "vm", "vb", "vb1"}]\)\)\)

bernstein[i_, n_, t_] := 
        Binomial[n, i] t^i (1 - t)^(n - i);

    b[t_] := 
      Sum[bernstein[i, 3, t]*Symbol["b" <> ToString[i]], {i, 0, 3}]; 
    db[t_] = D[b[t], t];

    ddb[t_] = D[b[t], {t, 2}];

    dddb[t_] = D[b[t], {t, 3}];

iMax = 64;

    bpoints = 
        Table[{0, 0, -0.001} + b[i/iMax + 0.0000001], {i, 0, 
            iMax}];

\(\(\( (*\ 
      define\ initial\ values\ for\ the\ control\ vertices\ *) \)\(
\)\(independentVariables = 
        Flatten[{independentVariablesForVector["b0", {\(-0.5\), 
                1.0, \(-0.5\)}], 
            independentVariablesForVector["b1", {\(-0.5\), 0.8, 0.0}], 
            independentVariablesForVector["b2", {1.5, 0.4, 0. }], 
            independentVariablesForVector["b3", {1.5, 1.0, \(-0.5\)}], 
            t -> 0.3}];\)\)\)

\(\(\( (*\ compute\ dependent\ variables, \ 
      in\ particular\ curvature\ kappa\ and\ torsion\ tau\ *) \)\(
\)\(dependentVariables = 
        Flatten[{t -> Max[0, Min[t, 1]], 
            dependentVariablesForVector["x", b[t]], 
            dependentVariablesForVector["dxdt", db[t]], 
            dependentVariablesForVector["ddxddt", ddb[t]], 
            dependentVariablesForVector["dddxdddt", dddb[t]], 
            dependentVariablesForVector["vt", dxdt/Sqrt[dxdt . dxdt]], 
            dependentVariablesForVector["vb1", Cross[dxdt, ddxddt]], 
            dependentVariablesForVector["vb", vb1/Sqrt[vb1 . vb1]], 
            dependentVariablesForVector["vm", Cross[vb, vt]], 
            kappa -> Sqrt[vb1 . vb1]/Sqrt[\((dxdt . dxdt)\)^3], 
            tau -> 
              Det[{dxdt, ddxddt, dddxdddt}]/\((vb1 . vb1)\)}];\)\)\)

itt := 
        StyleForm["t", 
          FontSlant -> "Italic"];

    bfb := 
        StyleForm["b", 
          FontWeight -> "Bold"];

    bfc := 
        StyleForm["c", 
          FontWeight -> "Bold"];

    bfm := 
        StyleForm["m", 
          FontWeight -> "Bold"];

    bfn := 
        StyleForm["n", 
          FontWeight -> "Bold"];

    bft :=  
        StyleForm["t", 
          FontWeight -> "Bold"];

    bfx :=  
        StyleForm["x", FontWeight -> "Bold"];

frenet := 
      Graphics3D[{{PointSize[0.04], RGBColor[0. , 1, 0. ], Point[b0], 
            Point[b1], Point[b2], Point[b3], Point[{t, 0, 0.01}], 
            GrayLevel[0], PointSize[0.02], Point[{0, 0, 0}], 
            Point[{1, 0, 0}], Point[x]}, {Thickness[0.01], GrayLevel[0], 
            Line[bpoints]}, {Thickness[0.005], GrayLevel[0. ], 
            Line[{b0 + {0, 0, -0.01}, b1 + {0, 0, -0.01}, 
                b2 + {0, 0, -0.01}, b3 + {0, 0, -0.01}}], 
            Thickness[0.005], GrayLevel[0], 
            Line[{{0, 0, 0}, {t - 0.01, 0, 0}}], 
            Line[{{t + 0.01, 0, 0}, {1, 0, 0}}]}, {Thickness[0.01], 
            EdgeForm[], GrayLevel[0], Arrow3D[x, x + vt], Arrow3D[x, x + vb], 
            Arrow3D[x, x + vm], GrayLevel[0.6], 
            Arrow3D[x + vt, x + vt + kappa vm], 
            Arrow3D[x + vb, x + vb - tau vm], 
            Arrow3D[x + vm, x + vm + tau vb], 
            Arrow3D[x + vm, x + vm - kappa vt], 
            Arrow3D[x + vm, x + vm + tau vb - kappa vt], Thickness[0.0025], 
            Line[{x + vm - kappa vt, x + vm + tau vb - kappa vt, 
                x + vm + tau vb}]}, {Text[itt, {t, 0, 0.01}, {0, 1.5}], 
            Text["0", {0, 0, 0}, {0, 1.5}], 
            Text["1", {1, 0, 0}, {0, 1.5}], 
            Text[StringForm["````````", bfx, "(", itt, ")"], 
              x, {0, 1.5}], Text[bft, x + vt, {-1.1, 1.5}], 
            Text[bfb, x + vb, {-1.2, -1.2}], 
            Text[bfm, x + vm, {-1.2, 0}], 
            Text[StringForm["````", "-τ ", bfm], 
              x + vb - tau vm, {1. , -1.3}], 
            Text[StringForm["````", "κ ", bfm], 
              x + vt + kappa vm, {0. , -1.3}], 
            Text[StringForm["````", "-κ ", bft], 
              x + vm - kappa vt, {1. , 0}], 
            Text[StringForm["````", "τ ", bfb], 
              x + vm + tau vb, {-0.9, -1.1}]}}, 
        ViewPoint -> {0, 0, 4}, ViewVertical -> {0, 1, 0}, 
        SphericalRegion -> True, 
        PlotRange -> {{-1, 2}, {-0.5, 1.5}, {-0.1, 0.1}}, 
        Boxed -> False, Axes -> False, Ticks -> Automatic, 
        Lighting -> False, 
        AxesLabel -> {"x", "y", "z"}, 
        TextStyle -> {FontFamily -> "Times", 
            FontSize -> 24}]

WriteLiveForm["frenet.lg3d", frenet]

Curvature of a Curve on a Surface

SetOptions[Arrow3D, HeadLength -> 0.15];

\(\(\( (*\ define\ vectors, \ 
      in\ particular\ control\ vertices\ for\ the\ Bezier\ patch, \ 
      and\ vectors\ characterizing\ a\ curve\ and\ a\ surface\ at\ a\ point\ *) \)\(
\)\(defineVector[{"b00", "b01", "b02", "b10", "b11", "b12", \ "b20", "b21", "b22", "x", "dxdt", "ddxddt", "dddxdddt", "vt", "vb1", "vb", "vm", "vc", "vcn", "normal", "xu", "xv"}];\)\)\)

bernstein[i_, 
          n_, t_] := 
        Binomial[n, i] t^i (1 - t)^(n - i);

    b[u_, v_] := 
        Sum[bernstein[i, 2, u]*bernstein[j, 2, v]*
            Symbol["b" <> ToString[i] <> ToString[j]], {i, 0, 2}, {j, 0, 
            2}];

    dbdu[u_, v_] = D[b[u, v], u];

    dbdv[u_, v_] = D[b[u, v], v];

u[t_] := 
        u*(1 - t)^2 + 2*udu*t (1 - t) + 
          uddu*t*t;

    v[t_] := 
        v*(1 - t)^2 + 2*vdv*t (1 - t) + 
          vddv*t*t;

    db[t_] = D[b[u[t], v[t]], t];

    ddb[t_] = D[b[u[t], v[t]], {t, 2}];

    dddb[t_] = D[b[u[t], v[t]], {t, 3}];

(* 
      define points of curves for the graphics *) 
iMax = 32;

    ba0points = 
        Table[b[i/iMax + 10. ^-10, 10. ^-10], {i, 0, 
            iMax}];

    ba1points = 
        Table[b[i/iMax + 10. ^-10, 1 + 10. ^-10], {i, 0, 
            iMax}];

    b0apoints = 
        Table[b[10. ^-10, i/iMax + 10. ^-10], {i, 0, 
            iMax}];

    b1apoints = 
        Table[b[1 + 10. ^-10, i/iMax + 10. ^-10], {i, 0, 
            iMax}];

    bavpoints = 
        Table[b[i/iMax + 10. ^-10, v], {i, 0, 
            iMax}];

    buapoints = 
        Table[b[u, i/iMax + 10. ^-10], {i, 0, 
            iMax}];

    upoints = 
        Table[{u[2 i/iMax + 10. ^-10], v[2 i/iMax + 10. ^-10], 
            0}, {i, -iMax/4, iMax/2}];

    btpoints = 
        Table[b[u[2 i/iMax + 10. ^-10], 
            v[2 i/iMax + 10. ^-10]], {i, -iMax/4, 
            iMax/2}];

iMax = 
        64;

    cpoints = 
        Table[N[vc + rho*Cos[2 Pi i/iMax]*vm + 
              rho*Sin[2 Pi i/iMax]*vt], {i, 0, iMax}];

    cnpoints = 
        Table[N[vcn + rhon*Cos[2 Pi i/iMax]*normal + 
              rhon*Sin[2 Pi i/iMax]*vt], {i, 0, iMax}];

\(\(\( (*\ 
      set\ independent\ variables; \ {u, 
        v}, {udu, vdv}\ and\ {uddu, 
          vddv}\ are\ control\ vertices\ of\ a\ Bezier\ curve\ in\ the\ u, 
      v\ parameter\ space\ \ *) \)\(
\)\(independentVariables = 
        Flatten[{u -> 0.2, v -> 0.5, uOld -> 0.2, 
            vOld -> 0.5, 
udu -> 0.35, 
            vdv -> 0.7, 
uddu -> 0.45, 
            vddv -> 
              0.9, 
independentVariablesForVector["b00", {\(-3\), 0.5, 0. }], 
            independentVariablesForVector["b10", {\(-2.5\), 0.5, 0.5}], 
            independentVariablesForVector["b20", {\(-2\), 0.2, 1}], 
            independentVariablesForVector["b01", {\(-2.7\), 
                0.9, \(-0.3\)}], 
            independentVariablesForVector["b11", {\(-2.1\), \(-1.5\), \(-0.5\)}], independentVariablesForVector["b21", {\(-1.5\), 0.3, 0.8}], 
            independentVariablesForVector["b02", {\(-2. \), 
                1.0, \(-1.5\)}], 
            independentVariablesForVector["b12", {\(-1.5\), 
                1.2, \(-1. \)}], 
            independentVariablesForVector["b22", {\(-0.5\), 
                0.6, \(-0.5\)}]}];\)\)\)

\(\(\( (*\ 
      set\ dependent\ variables\ *) \)\(
\)\(\((dependentVariables = 
          Flatten[{
u -> 
                Max[0, Min[1, u]], 
v -> 
                Max[0, Min[1, v]], 
udu -> 
                If[u == uOld, 
                  udu, \((u - uOld)\) + udu], 
vdv -> 
                If[v == vOld, 
                  vdv, \((v - vOld)\) + vdv], 
uddu -> 
                If[u == uOld, 
                  uddu, \((u - uOld)\) + 
                    uddu], 
vddv -> 
                If[v == vOld, 
                  vddv, \((v - vOld)\) + vddv], 
du -> 
                udu - u, 
dv -> 
                vdv - v, 
ddu -> 
                uddu - udu, 
ddv -> 
                vddv - vdv, 
uOld -> 
                u, 
vOld -> 
                v, 
dependentVariablesForVector["x", 
                b[u, v]], dependentVariablesForVector["xu", dbdu[u, v]], 
              dependentVariablesForVector["xv", dbdv[u, v]], 
              dependentVariablesForVector["normal", 
                Cross[xu, xv]/Sqrt[Cross[xu, xv] . Cross[xu, xv]]], 
              dependentVariablesForVector["dxdt", db[0]], 
              dependentVariablesForVector["ddxddt", ddb[0]], 
              dependentVariablesForVector["dddxdddt", dddb[0]], 
              dependentVariablesForVector["vt", dxdt/Sqrt[dxdt . dxdt]], 
              dependentVariablesForVector["vb1", Cross[dxdt, ddxddt]], 
              dependentVariablesForVector["vb", vb1/Sqrt[vb1 . vb1]], 
              dependentVariablesForVector["vm", Cross[vb, vt]], 
              kappa -> Sqrt[vb1 . vb1]/Sqrt[\((dxdt . dxdt)\)^3], 
              rho -> Sqrt[\((dxdt . dxdt)\)^3]/Sqrt[vb1 . vb1], 
              dependentVariablesForVector["vc", 
                x + rho\ vm], 
cosphi -> 
                vm . normal, 
rhon -> 
                rho/cosphi, 
dependentVariablesForVector["vcn", 
                x + rhon\ normal]}])\);\)\)\)

itt := 
        StyleForm["t", 
          FontSlant -> "Italic"];

    itu := 
        StyleForm["u", 
          FontSlant -> "Italic"];

    itv := 
        StyleForm["v", 
          FontSlant -> "Italic"];

    bfb := 
        StyleForm["b", 
          FontWeight -> "Bold"];

    bfc := 
        StyleForm["c", 
          FontWeight -> "Bold"];

    bfm := 
        StyleForm["m", 
          FontWeight -> "Bold"];

    bfn := 
        StyleForm["n", 
          FontWeight -> "Bold"];

    bfu :=  
        StyleForm["u", 
          FontWeight -> "Bold"];

    bft :=  
        StyleForm["t", 
          FontWeight -> "Bold"];

    bfx :=  
        StyleForm["x", FontWeight -> "Bold"];

curvature := 
      Graphics3D[{{PointSize[0.02], RGBColor[0. , 1, 0. ], Point[b00], 
            Point[b01], Point[b02], Point[b10], Point[b11], Point[b12], 
            Point[b20], Point[b21], Point[b22], PointSize[0.04], 
            Point[{u, v, 0.00001}], Point[{udu, vdv, 0.00001}], 
            Point[{uddu, vddv, 0.00001}], GrayLevel[0], PointSize[0.02], 
            Point[x]}, {Thickness[0.0025], GrayLevel[0], Line[ba0points], 
            Line[ba1points], Line[b0apoints], Line[b1apoints], 
            Line[bavpoints], Line[buapoints], Thickness[0.005], 
            Line[btpoints]}, {Thickness[0.0025], 
            Line[{{0, 0, 0}, {1, 0, 0}}], Line[{{0, 1, 0}, {1, 1, 0}}], 
            Line[{{0, 0, 0}, {0, 1, 0}}], Line[{{1, 0, 0}, {1, 1, 0}}], 
            Line[{{u, 0, 0}, {u, v, 0}}], Line[{{u, v, 0}, {u, 1, 0}}], 
            Line[{{0, v, 0}, {u, v, 0}}], Line[{{u, v, 0}, {1, v, 0}}], 
            Thickness[0.005], Line[upoints]}, {Thickness[0.0025], 
            Line[{b00, b01}], Line[{b01, b02}], Line[{b10, b11}], 
            Line[{b11, b12}], Line[{b20, b21}], Line[{b21, b22}], 
            Line[{b00, b10}], Line[{b10, b20}], Line[{b01, b11}], 
            Line[{b11, b21}], Line[{b02, b12}], 
            Line[{b12, b22}]}, {Thickness[0.01], EdgeForm[], GrayLevel[0], 
            Arrow3D[x, x + normal]}, {Thickness[0.005], EdgeForm[], 
            GrayLevel[0], 
            Arrow3D[b00 - 0.5 (b01 - b00), 
              b00 - 0.5 (b01 - b00) + 0.5 (b10 - b00)], 
            Text[itu, 
              b00 - 0.5 (b01 - b00) + 0.5 (b10 - b00), {-1.4, 
                0.5}], Arrow3D[b00 - 0.5 (b10 - b00), 
              b00 - 0.5 (b10 - b00) + 0.5 (b01 - b00)], 
            Text[itv, 
              b00 - 0.5 (b10 - b00) + 
                0.5 (b01 - b00), {-1.3, -1.3}]}, {Text[bfx, 
              x, {1.2, 0.9}], Text[bfn, x + normal, {-1.2, 1.1}], 
            Text[bfu, {u, v, 0}, {-1.3, 1.1}], 
            Text[StringForm["````-plane", itu, itv], {0.5, 0, 0}, {0, 
                1.2}]}, {Thickness[0.008], EdgeForm[], GrayLevel[0], 
            Arrow3D[x, x + vt], Text[bft, x + vt, {-1.1, 1.1}], 
            Arrow3D[x, x + vm], Text[bfm, x + vm, {2. , 0. }], GrayLevel[0], 
            PointSize[0.02], Point[vc], Thickness[0.005], Line[{x + vm, vc}], 
            Text[bfc, vc, {-1.2, -1.4}], Thickness[0.005], 
            GrayLevel[0.6], Line[cpoints], GrayLevel[0.6], PointSize[0.02], 
            Point[vcn], Thickness[0.005], Line[{x + normal, vcn}], 
            Text[Subscript[bfc, "n"], vcn, {-1. , -1.1}], 
            Thickness[0.005], GrayLevel[0.6], Line[cnpoints]}}, 
        ViewPoint -> {0, 0, 4}, ViewVertical -> {0, 1, 0}, 
        SphericalRegion -> True, 
        PlotRange -> {{-3. , 1.0}, {-0.1, 1.1}, {-1.1, 
              1.1}}, Boxed -> False, Axes -> False, 
        Lighting -> False, Ticks -> Automatic, 
        AxesLabel -> {"x", "y", "z"}, 
        TextStyle -> {FontFamily -> "Times", 
            FontSize -> 24}]

WriteLiveForm["curvature.lg3d", curvature]