Dank einer Anregung von Gunter Woysch konnte ich die Abwicklungen
beiliebiger parametrischer Flächen lösen. Er hat eine sehr praktische
Idee gehabt: Wenn man eine Fläche in Mathematica berechnet und
zeichnet, wird sie ja in Vierecke zerlegt; diese sind normalerweise
nicht planar und werden implizit in zwei Dreiecke zerlegt. Dreiecke
sind nun aber in jedem Fall planar. Ich kann also einfach diese
Dreiecke in der Ebene neu ausbreiten, und schon habe ich eine
(angenäherte) Abwicklung. Das ganze ist eine hübsche Programmierübung.
Hier ist das Programm:
norm[v_]:=Sqrt[norm2[v]]
norm2[v_]:=Plus@@(v^2)
place[{n1_,n2_},{a_,b_,c_},dir_:1] :=
Module[{ba=b-a,cb=c-b,ba1,cb1,w},
ba1=ba/norm[ba];cb1=cb/norm[cb];
e=norm[cb];
w=dir ArcCos[-ba1.cb1];
n2 + ((n1-n2)/norm[n1-n2]).{{Cos[w],Sin[w]},{-Sin[w],Cos[w]}} e
]
Planarize[MathProg`SurfaceGraphics3D`SurfaceGraphics3D[ar_,___]] :=
Planarize[ar]
Planarize[net_List]:= Composition[strip,Transpose] /@ Partition[net,2,1]
strip[streifen_List]/;Dimensions[streifen][[2]]==2 :=
Module[{p,trs,res={},dir=1,n1,n2,n3,d,i},
p=Flatten[#,1]&/@Partition[streifen,2,1];
trs=Flatten[Apply[{{#2,#1,#3},{#3,#2,#4}}&,p,{1}],1];
With[{tr=trs[[1]]},d=norm[tr[[2]]-tr[[1]]]];
{n1,n2}={{0,0},{0,d}};
Do[
n3=place[{n1,n2},trs[[i]],dir];
AppendTo[res,{n1,n2,n3}];
{n1,n2}={n3,n1};dir=-1dir,
{i,1,Length[trs]}];
res
]
PolyLine[points_List]:=Line[Append[points,First[points]]]
Die Eingabe von Planarize[] ist eine Matrix von 3D-Punkten. Solche
bekommt man als Resultat von ParametricPlot3D, wenn man vorher mein
Paket MathProg`SurfaceGraphics3D` lädt (es ist auf der CD zu "The
Mathematica Programmer II"). Man kann aber auch einfach Table verwenden.
Hier wiederum die Formel für das verdrehte Dreieck.
torus[R_,r_,phi_,psi_]:=
With[{x=R+r Cos[phi],z=r Sin[phi]},
{x Cos[psi],x Sin[psi],z}
]
Da sich eine Abwicklung der ganzen Fläche (dreimal rundherum) in der
Ebene selber überlappt, erzeuge ich drei Streifen, jeweils einmal
herum. Wicht ist dabei, daß der erste Iterator nur wenige Schritte
ausführt, denn jeder Schritt ergibt schließlich einen zusammenhängenden
Teil der Abwicklung. Wenn man ParametricPlot3D verwendet, muß man die
Reihenfolge der Iteratoren umkehren.
sg3=With[{w=1/3,R=3,r=1.2,n=24},
Table[Evaluate[torus[R, r, s 2Pi/3 + psi w, psi]],
{s,0,3,1}, {psi,0,2Pi,2Pi/n}]];
Das Resultat enthält vier Reihen von je 25 Punkten.
Dimensions[sg3]
{4,25,3}
Das Resultat der Abwicklung sind drei Listen von Dreiecken. Diese
sollten normalerweise wohl separat gezeichnet werden, um Überlappungen
zu vermeiden (Achtung auf natürliche AspectRatio).
resultate=Planarize[sg3];
SetOptions[Graphics,AspectRatio->Automatic];
Die Hilfsfunktion PolyLine erzeugt aus den Punktlisten geschlossene
Polygonzüge. Die Graphiken sind auf meinem WWW-Server zu finden.
Hier erwähne ich lediglich die entsprechenden URLs.
Show[Graphics[PolyLine/@#]]&/@resultate;
{ http://www.mathconsult.ch/math/stuff/abw1a.gif,
http://www.mathconsult.ch/math/stuff/abw1b.gif,
http://www.mathconsult.ch/math/stuff/abw1c.gif }
In diesem Bildern sind die Maßstäbe noch verschieden. Das müsste noch
korrigiert werden. Man kann dann die Graphiken ausdrucken, die
Abwicklungen ausschneiden, evtl. falzen und zusammenkleben.
Noch ein einfacheres Beispiel: das gewöhnliche Möbiusband.
Needs["MathProg`SurfaceGraphics3D`"]
Needs["Graphics`ParametricPlot3D`"]
mb=With[{w=1/2,R=3,r=1,n=24},
ParametricPlot3D[Evaluate[torus[R,r,s Pi + psi w,psi]],
{psi,0,2Pi,2Pi/n}, {s,0,1,1}]]
"-SurfaceGraphics3D-"
Show[mb];
http://www.mathconsult.ch/math/stuff/abw2.gif
Hier ergibt sich nur ein Streifen.
mbstrip=Planarize[mb][[1]];
Show[Graphics[PolyLine/@mbstrip]];
http://www.mathconsult.ch/math/stuff/abw3.gif
Vielleicht überraschend! Das Möbiusband wird ja meist aus einem
rechteckingen dünnen Streifen Papier hergestellt. Ein solches
Möbiusband hat aber eine andere Parametrisierung; die hier verwendete
ist einfacher, liefert aber eine kompliziertere Abwicklung. Je mehr
Punkte man rechnet, umso genauer wird es. Man kann obige Figur aber gut
zu einem Möbiusband zusammensetzen, ich habe es ausprobiert.
Roman Mäder
-----------------------------------------------------------------------
MathConsult Dr. R. Mäder Samstagernstrasse 58a
Mathematik- und Informatik-Beratung CH-8832 Wollerau
T: +41-1-687 4050 mailto:maeder@XXXXXXX.ch
F: +41-1-687 4054 http://www.mathconsult.ch/
-----------------------------------------------------------------------
|
