DeleteRotations[list_] :=
DeleteDuplicates[Map[Reverse[Sort[#]] &, list, 1]]
Toratopes[1] = {1};
Rotatopes[n_] := Rest[IntegerPartitions[n]]
ExpandRotatope[list_] := DeleteRotations[ Tuples[Map[Toratopes, list]]]
Toratopes[n_] := Reverse[Flatten[Map[ExpandRotatope, Rotatopes[n]], 1]]
TStringList[1] = "I";
TStringList[list_] :=
Flatten[{"(", Table[TStringList[i], {i, list}], ")"}, 1]
ClosedToratopeNotation[list_] := StringJoin[TStringList[list]]
OpenToratopeNotation[list_] :=
StringJoin[ TStringList[list] // Most // Rest]
ToratopeList[n_] :=
If[n === 1, {"I"},
Join[Map[OpenToratopeNotation, Toratopes[n]],
Map[ClosedToratopeNotation, Toratopes[n]]]] // TableForm
T[1, pos_] := ToExpression[ StringJoin["x", Map[ToString, pos, 1]]]
T[list_, pos_] :=
Tor[ToExpression[StringJoin["r", Map[ToString, pos, 1]]], list]
TorNotation[list_] := Tor[r, MapIndexed[T , list, Infinity]]
TorFunction[tor_] :=
If[tor[[0]] === Tor,
Sqrt[Total[(Table[TorFunction[subtor], {subtor, tor[[2]]}])^2]] -
tor[[1]], tor]
ToratopeFunction[tor_] := TorFunction[TorNotation[tor]]
In[125]:= ToratopeFunction[{{1, 1}, {1, 1}}]
Out[125]= -R + Sqrt[(-r1 + Sqrt[x11^2 + x12^2])^2 + (-r2 + Sqrt[
x21^2 + x22^2])^2]
RList[tor_] :=
Sort[ToExpression[StringJoin["r", Map[ToString, #, 1]]] & /@
Position[tor, _List]]
XList[tor_] :=
Sort[ToExpression[StringJoin["x", Map[ToString, #, 1]]] & /@
Position[tor, 1]]
ToratopeFunctionVar[list_] :=
Function[Evaluate[RList[list]],
Evaluate[Function[Evaluate[XList[list]],
Evaluate[ToratopeFunction[list]]]]]
In[134]:=
ToratopeFunctionVar[{{1, 1}, {1, 1}}][R, Subscript[r, a], Subscript[r,
b]][x, y, z, w]
Out[134]= -R + Sqrt[(Sqrt[x^2 + y^2] - Subscript[r, a])^2 + (Sqrt[
w^2 + z^2] - Subscript[r, b])^2]
In[133]:= Map[ToratopeFunction[#] == 0 & , Toratopes[5]] // TableForm
Out[133]=
-R+Sqrt[x1^2+x2^2+x3^2+x4^2+x5^2]==0
-R+Sqrt[(-r1+Sqrt[x11^2+x12^2])^2+x2^2+x3^2+x4^2]==0
-R+Sqrt[(-r1+Sqrt[x11^2+x12^2])^2+(-r2+Sqrt[x21^2+x22^2])^2+x3^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[x111^2+x112^2])^2+x12^2])^2+x2^2+x3^2]==0
-R+Sqrt[(-r1+Sqrt[x11^2+x12^2+x13^2])^2+x2^2+x3^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[x111^2+x112^2])^2+x12^2])^2+(-r2+Sqrt[x21^2+x22^2])^2]==0
-R+Sqrt[(-r1+Sqrt[x11^2+x12^2+x13^2])^2+(-r2+Sqrt[x21^2+x22^2])^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[x111^2+x112^2+x113^2])^2+x12^2])^2+x2^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[(-r111+Sqrt[x1111^2+x1112^2])^2+x112^2])^2+x12^2])^2+x2^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[x111^2+x112^2])^2+(-r12+Sqrt[x121^2+x122^2])^2])^2+x2^2]==0
-R+Sqrt[(-r1+Sqrt[(-r11+Sqrt[x111^2+x112^2])^2+x12^2+x13^2])^2+x2^2]==0
-R+Sqrt[(-r1+Sqrt[x11^2+x12^2+x13^2+x14^2])^2+x2^2]==0
Animate[
ContourPlot3D[
Evaluate[
ToratopeFunctionVar[{{1, 1}, {1, 1}}][1, 3, 4][x, y Cos[t], z ,
y Sin[t]] == 0], {x, -6, 6}, {y, -6, 6}, {z, -6, 6},
PlotPoints -> 30], {t, 0, 2 \[Pi], 0.1}]
Animate[ContourPlot3D[
ToratopeFunctionVar[{{1, 1}, {1, 1}}][1, 3, 4][x, y Cos[t], z ,
y Sin[t]] == 0, {x, -6, 6}, {y, -6, 6}, {z, -6, 6},
PlotPoints -> 30], {t, 0, 2 \[Pi], 0.1}]
Users browsing this forum: No registered users and 4 guests