Dismiss Notice
Join Physics Forums Today!
The friendliest, high quality science and math community on the planet! Everyone who loves science is here!

Mathematica: Gluing a torus

  1. May 13, 2017 #1
    Hi,

    I was wondering if someone could help me understand the grid command in the following Mathematica code that transforms a rectangle to a torus like in this video below. My problem is I want the blue rectangle in the Mathematica code to look like the four color rectangle in the plot below. Basically want to map the four color rectangle to a four color torus. I got the Mathematica code on line and I'm having problems understanding the code to change it to my color map.

    xietaplane.jpg




    Code (Text):
    DynamicModule[{x = 2., l = 100., x2 = 2., l2 = 100., grid, fast,
      slow}, Grid[{{Graphics3D[{Dynamic[
           Map[{Blue, Polygon[#[[{1, 2, 4, 3}]]]} &,
              Join @@@ (Join @@ Partition[#, {2, 2}, 1])] &[
            ControlActive[fast[l, l2], slow[l, l2]]]]},
         PlotRange -> {{-7, 7}, {-7, 7}, {-1, 2}}, ImageSize -> 600,
         Axes -> True, BaseStyle -> 18],
        Column[{Slider[Dynamic[x, (l = 10.^#; x = #) &], {.0001, 2.}],
          Slider[Dynamic[x2, (l2 = 10.^#; x2 = #) &], {.0001, 2.}]}]}}],
    Initialization :> (grid[l_, l2_, n_, m_] :=
        Outer[Compose,
         Array[RotationTransform[# Pi/l2, {0, 0, 1.}, {0, -l2, 0}] &,
          n, {-1, 1}],
         Array[RotationTransform[# Pi/l, {1., 0, 0}, {0, 2, l}][{0, 2,
             0}] &, m, {-1, 1}], 1];
       fast[l_, l2_] = grid[l, l2, 10, 10];
       slow[l_, l2_] = grid[l, l2, 50, 25];)]
    .




    Thanks for reading.


     
    Last edited: May 13, 2017
  2. jcsd
  3. May 15, 2017 #2
    Hi guys,

    Here is my solution to the problem:


    Code (Text):
    nMax=10;

    etaMax=1.8138
    grid[l_,l2_,n_,m_]:=Outer[Compose,Array[RotationTransform[# \[Pi]/l2,{0,1.,0},{0,0,l2+2}]&,n,{-1,1}],Array[RotationTransform[# etaMax/l,{1.,0,0},{0,0,l}][{0,0,0}]&,m,{-1,1}],1]

    gVal=Table[Lighter[Green,0.3],{nMax},{nMax}];
    rVal=Table[Lighter[Red,0.3],{nMax},{nMax}];
    yVal=Table[Lighter[Yellow,0.3],{nMax},{nMax}];
    bVal=Table[Lighter[Blue,0.3],{nMax},{nMax}];
    mt1=MapThread[{#1,#2}&,{bVal,yVal}];
    mt2=MapThread[{#1,#2}&,{rVal,gVal}];
    myColors2=Flatten[Join[mt1,mt2]];

    Manipulate[Show[{Graphics3D[MapThread[{#1,Polygon[#2[[{1,2,4,3}]]]}&,{myColors2,Join@@@(Join@@Partition[grid[10.^val1,10.^val2,2 nMax+1,2 nMax+1],{2,2},1])}]]},PlotRange->{{-6,6},{-6,6},{-6,6}},Axes->True,AxesLabel->{Style["X",16],Style["Y",16],Style["Z",16]}],{val1,\[Pi],-.235 },{val2,\[Pi],0.0001}]
     
    fourcolortorus.jpg
     
Know someone interested in this topic? Share this thread via Reddit, Google+, Twitter, or Facebook

Have something to add?
Draft saved Draft deleted



Similar Discussions: Mathematica: Gluing a torus
  1. In mathematica (Replies: 4)

  2. [Mathematica] Plot 3D (Replies: 1)

Loading...