(*:Title: PLTPROGS.m *)

(*:Author: Alfred Gray *)

(* Copyright 1994  by Alfred Gray *)

(*:Package Version: 1.0 *)

(*:Mathematica Version: 2.2 *)

(*:Summary: 
	This package consists of several plotting enhancements useful for 
plotting curves and surfaces.
*)

(*:Keywords:
centerlines, dip, elrot, filledcurve, graphics2dtosurfrev, lathe, linetolines, 
orth4d, paramcurveplot1, paramcurveplot2, plotpatch2d, selectcolgraphics3d, 
selectgraphics3d, surfacecurveplot, stereo4d, wireframe
*)

Print["For a list of plotting enhancements type pltprogs."]


BeginPackage["PLTPROGS`"]

    pltprogs:=Print[Select[Names["PLTPROGS`*"],#!="pltprogs"&]]

     centerlines::usage="centerlines has the same syntax as
ParametricPlot3D. It plots a parametric patch in R^3, but adds lines
connecting the center of each quadrilateral to its vertices."

    elrot::usage="elrot[p,q][theta][aa_List] is the elementary rotation
by an angle theta of pth and qth elements of the list aa."

    dip::usage="DisplayFunction->dip[ins] inserts a Graphics3D primitive
at the beginning of a Graphics3D list when the list is displayed.
For example, DisplayFunction->dip[EdgeForm[]] displays polygons with
no edges."

    filledcurve::usage="filledcurve parametrically plots a plane curve and
fills it in.  It has the same syntax as ParametricPlot."

    graphics2dtosurfrev::usage="graphics2dtosurfrev[r,n][list] constructs a
surface of revolution of radius r from a Graphics list of lines.
Each circle of latitude is approximated by a regular polygon with
n vertices."

    lathe::usage="lathe[dots] creates a surface of revolution with
no edges from a list of points in the plane."

    linetolines::usage="linetolines[Line[{pt1,...,ptn}]] converts
a broken line segment Line[{pt1,...,ptn}] into a list of line segments
connecting consecutive pairs of the points pt1,...,ptn."

    orth4d::usage="orth4d[surf,{u,umin,umax},{v,vmin,vmax},opts] uses
GraphicsArray to plot a surface in R^4 via the four
orthogonal projections from R^4 to R^3."

    paramcurveplot1::usage="paramcurveplot1 has the same syntax as
ParametricPlot3D. It plots the parameter lines u->x[u,v0] of a
parametric patch surface:U->R^3."

    paramcurveplot2::usage="paramcurveplot2 has the same syntax as
ParametricPlot3D. It plots the parameter lines v->x[u0,v] of a
parametric patch surface:U->R^3."

    plotpatch2d::usage="plotpatch2d has the same syntax as
ParametricPlot. It plots the images of horizontal and vertical
lines under the function f:U->R^2. plotpatch2d has the same
functionality as Maeder's CartesianMap and PolarMap, but draws
curved instead of straight lines."

    selectgraphics3d::usage="selectgraphics3d[graphics3dobj,bound,opts]
selects from a list of polygons those whose vertices have their
coordinates bounded by bound."

    selectcolgraphics3d::usage="selectcolgraphics3d[graphics3dobj,bound,opts]
selects from a list of colored polygons those whose vertices have their
coordinates bounded by bound."

    stereo4d::usage="stereo4d[{a,b,c,d},surf,{u,umin,umax},{v,vmin,vmax},opts]
uses GraphicsArray to plot a surface in R^4 via the four
stereographic projections from R^4 to R^3 with respect to the point
{a,b,c,d} in R^4."

    surfacecurveplot::usage="surfacecurveplot[surface,{u,u0,u1},{v,v0,v1},
PlotLines->{ulines,vlines},PlotPoints->{upoints,vpoints},opts] plots both the
u- and v-parameter curves of a patch x:U->R^3. The number of curves
is specified with PlotLines, and the resolution of the lines is specified with
PlotPoints."

    wireframe::usage="wireframe has the same syntax as ParametricPlot3D.
It plots a wireframe of a parametric patch in R^3."

Begin["`Private`"]
    centerlines[surface_,{u_,u0_,u1_},{v_,v0_,v1_},
        opts___]:=
        Module[{plottmp,grtmp},
                plottmp = ParametricPlot3D[
                surface//Evaluate,{u,u0,u1},{v,v0,v1},
                DisplayFunction->Identity,opts];
                grtmp = plottmp /.
     (Polygon[pts_]:>
     {Polygon[Append[pts[[{1,2}]],Plus@@pts/4]],
      Polygon[Append[pts[[{2,3}]],Plus@@pts/4]],
      Polygon[Append[pts[[{3,4}]],Plus@@pts/4]],
      Polygon[Append[pts[[{4,1}]],Plus@@pts/4]]});
        Show[grtmp,DisplayFunction->$DisplayFunction]]

    dip[ins_][g_]:= $DisplayFunction[Insert[g,ins,{1,1}]]

    elrot[p_,q_][theta_][aa_List]:=ReplacePart[ReplacePart[
        aa,aa[[p]]*Cos[theta] + aa[[q]]*Sin[theta],p],
        -aa[[p]]*Sin[theta] + aa[[q]]*Cos[theta],q]

    filledcurve[curve_,{u_,u0_,u1_},opts___]:=
        Module[{plottmp,grtmp},
            plottmp = ParametricPlot[
            curve//Evaluate,{u,u0,u1},AspectRatio->Automatic,
            DisplayFunction->Identity,opts];
            grtmp = plottmp /.(Line[pts_]:> Polygon[pts]);
        Show[grtmp,DisplayFunction->$DisplayFunction]]
    
    graphics2dtosurfrev[r_,n_][Line[{{a_,b_},{c_,d_}}]]:=
        Table[Polygon[{
        {r*a*Cos[2*Pi*(k - 1)/n],r*a*Sin[2*Pi*(k - 1)/n],b},
        {r*a*Cos[2*Pi*k/n],r*a*Sin[2*Pi*k/n],b},
        {r*c*Cos[2*Pi*k/n],r*c*Sin[2*Pi*k/n],d},
        {r*c*Cos[2*Pi*(k - 1)/n],
                r*c*Sin[2*Pi*(k - 1)/n],d}}],{k,n}]

   lathe[dots_]:=Show[Graphics3D[
      Map[graphics2dtosurfrev[0.5,60],
      linetolines[Line[dots]]]],Boxed->False,
      DisplayFunction->dip[EdgeForm[]]]

   linetolines[Line[pts_]]:=Table[Line[{pts[[i]],
             pts[[i + 1]]}],{i,Length[pts] - 1}]

    orth4d[surf_,{u_,umin_,umax_},{v_,vmin_,vmax_},opts___]:=
        Module[{g1,g2,g3,g4},
        g1=ParametricPlot3D[Evaluate[
                Drop[surf,{1}]],{u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g2=ParametricPlot3D[Evaluate[
                Drop[surf,{2}]],{u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g3=ParametricPlot3D[Evaluate[
                Drop[surf,{3}]],{u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g4=ParametricPlot3D[Evaluate[
                Drop[surf,{4}]],{u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        Show[GraphicsArray[{{g1,g2},{g3,g4}}],
                GraphicsSpacing->{0.2,0},
                DisplayFunction->$DisplayFunction]]

    paramcurveplot1[surface_,{u_,u0_,u1_},{v_,v0_,v1_},
        PlotPoints->{upoints_,vpoints_},opts___]:=
        ParametricPlot3D[Table[
        surface,{v,v0,v1,(v1-v0)/(vpoints - 1)}]//Evaluate,
        {u,u0,u1},PlotPoints->upoints,opts]

    paramcurveplot2[surface_,{u_,u0_,u1_},{v_,v0_,v1_},
        PlotPoints->{upoints_,vpoints_},opts___]:=
        ParametricPlot3D[Table[
        surface,{u,u0,u1,(u1-u0)/(upoints - 1)}]//Evaluate,
        {v,v0,v1},PlotPoints->vpoints,opts]

    plotpatch2d[expr_,{x_,xmin_,xmax_},{y_,ymin_,ymax_},
        PlotPoints->{xpoints_,ypoints_},opts___]:=
        Show[ParametricPlot[Evaluate[
        Table[ComplexExpand[
        {Re[expr],Im[expr]}],
        {y,ymin,ymax,(ymax - ymin)/(ypoints - 1)}]],
        {x,xmin,xmax},PlotPoints->xpoints,
        DisplayFunction->Identity],
        ParametricPlot[Evaluate[
        Table[ComplexExpand[
        {Re[expr],Im[expr]}],
        {x,xmin,xmax,(xmax - xmin)/(xpoints -1)}]],
        {y,ymin,ymax},PlotPoints->ypoints,
        DisplayFunction->Identity],
        AspectRatio->Automatic,
        DisplayFunction->$DisplayFunction,opts]

    selectgraphics3d[graphics3dobj_,bound_,opts___]:=
        Show[Graphics3D[Select[graphics3dobj,
        (Abs[#[[1,1,1]]]<bound && Abs[#[[1,1,2]]]<bound &&
         Abs[#[[1,1,3]]]<bound && Abs[#[[1,2,1]]]<bound &&
         Abs[#[[1,2,2]]]<bound && Abs[#[[1,2,3]]]<bound &&
         Abs[#[[1,3,1]]]<bound && Abs[#[[1,3,2]]]<bound &&
         Abs[#[[1,3,3]]]<bound && Abs[#[[1,4,1]]]<bound &&
         Abs[#[[1,4,2]]]<bound && Abs[#[[1,4,2]]]<bound
         )&]],opts]

    selectcolgraphics3d[graphics3dobj_,bound_,opts___]:=
        Show[Graphics3D[Select[graphics3dobj,
        (Abs[#[[2,1,1,1]]]<bound && Abs[#[[2,1,1,2]]]<bound &&
        Abs[#[[2,1,1,3]]]<bound && Abs[#[[2,1,2,1]]]<bound &&
        Abs[#[[2,1,2,2]]]<bound && Abs[#[[2,1,2,3]]]<bound &&
        Abs[#[[2,1,3,1]]]<bound && Abs[#[[2,1,3,2]]]<bound &&
        Abs[#[[2,1,3,3]]]<bound && Abs[#[[2,1,4,1]]]<bound &&
        Abs[#[[2,1,4,2]]]<bound && Abs[#[[2,1,4,2]]]<bound
         )&]],opts]

    stereo4d[{a_,b_,c_,d_},surf_,
        {u_,umin_,umax_},{v_,vmin_,vmax_},opts___]:=
        Module[{g1,g2,g3,g4},
        g1=ParametricPlot3D[Evaluate[
                Drop[surf,{1}]/(a-surf[[1]])],
                {u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g2=ParametricPlot3D[Evaluate[
                Drop[surf,{2}]/(b-surf[[2]])],
                {u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g3=ParametricPlot3D[Evaluate[
                Drop[surf,{3}]/(c-surf[[3]])],
                {u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        g4=ParametricPlot3D[Evaluate[
                Drop[surf,{4}]/(d-surf[[4]])],
                {u,umin,umax},{v,vmin,vmax},
                DisplayFunction->Identity,opts];
        Show[GraphicsArray[{{g1,g2},{g3,g4}}],
                GraphicsSpacing->{0.2,0},
                DisplayFunction->$DisplayFunction]]

    surfacecurveplot[surface_,{u_,u0_,u1_},{v_,v0_,v1_},
        PlotLines->{ulines_,vlines_},
        PlotPoints->{upoints_,vpoints_},opts___]:=
            Show[paramcurveplot1[surface,{u,u0,u1},{v,v0,v1},
                PlotPoints->{upoints,ulines},
                DisplayFunction->Identity,opts],
                paramcurveplot2[surface,{u,u0,u1},{v,v0,v1},
                PlotPoints->{vlines,vpoints},
                DisplayFunction->Identity,opts],
                DisplayFunction->$DisplayFunction]

    wireframe[surface_,{u_,u0_,u1_},{v_,v0_,v1_},opts___]:=
        Module[{plottmp,grtmp},
                plottmp = ParametricPlot3D[
                surface,{u,u0,u1},{v,v0,v1},
                DisplayFunction->Identity,opts];
                grtmp = plottmp /.(Polygon[pts_]:> 
                Line[Append[pts,First[pts]]]);
        Show[grtmp,DisplayFunction->$DisplayFunction]]


End[]

EndPackage[]

