I'm wondering if there's a simple way to create a diagram akin to this:
Basically, I have two figures, and I want to create a diagram where I have the two figures side by side and an arrow (denoting a morphism) connecting the two.
Answer
Inspiring by an old question I asked, here is a possible way to encode your graph
ClearAll[esF]
esF[setback_: .2,
as_: .1] := {Arrowheads[as],
Arrow[GraphElementData[{"CurvedArc", "Curvature" -> 0.5}][##],
setback]} &;
tor = Magnify[
ParametricPlot3D[{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]),
Sin[u]}, {t, 0, 2 Pi}, {u, 0, 2 Pi}, Boxed -> False,
Axes -> False], .35];
el = Magnify[Graphics[{Red, Thick, Circle[{0, 0}, {.5, .25}]}], .35];
sq1 = Magnify[
Graphics[{LightBlue, Thick,
Rectangle[{0, 0}, {.015, 0.015}]}], .25];
sq2 = Magnify[
Graphics[{LightRed, Thick, Rectangle[{0, 0}, {.4, .5}]}], .35];
g0 = Graph[{1 -> 2, 2 -> 3, 3 -> 2, 3 -> 4, 4 -> 1, 1 -> 4},
EdgeLabels -> {1 \[DirectedEdge] 2 -> Style["f", FontSize -> 16],
2 \[DirectedEdge] 3 -> Style["ψ", FontSize -> 16],
3 \[DirectedEdge] 2 ->
Style["\!\(\*SuperscriptBox[\(ψ\), \(-1\)]\)",
FontSize -> 16],
3 \[DirectedEdge] 4 ->
Style["\!\(\*SuperscriptBox[\(ψ°f°ϕ\),\
\(-1\)]\)", FontSize -> 16],
4 \[DirectedEdge] 1 ->
Style["\!\(\*SuperscriptBox[\(ϕ\), \(-1\)]\)",
FontSize -> 16],
1 \[DirectedEdge] 4 -> Style["ϕ", FontSize -> 16]},
VertexLabels -> { 1 -> Placed[el, Center],
2 -> Placed[tor, Center], 3 -> Placed[sq1, Center],
4 -> Placed[sq2, Center]}, VertexShape -> 0.1];
Show[SetProperty[g0, EdgeShapeFunction -> esF[]],
Graphics[Text["M", {0, 1}]], Graphics[Text["N", {1, 1}]],
Graphics[Text["\!\(\*SuperscriptBox[\(R\), \(m\)]\)", {0, 0}]],
Graphics[Text["\!\(\*SuperscriptBox[\(R\), \(n\)]\)", {1, 0.1}]]]
Here is the result.
It is not completely satisfacing. First, I dont know how to oblige MA to put the vertices where we think they must be. Second, I dont know how to cope with the negative curvature of the two horizontal arrows. Third, I have not found an other symbol for composition than [Degree]. Fourth, it would be nice eather to have an opaque box in the background of the text and perhaps an offset. To do this place blancks between cotes and letters before or after according to what you need.
You can finetune the position of $R^n$ inside the torus by increasing it a little and moving $ R^n$ to the right place. And, finally, you can change the fonts.
Last but not least, such a composition is recurrent. It would be nice to be able to do it easily in MA. Latex + Pstricks is far better to do such graphics.
25//11/16
Finally, I have found the way to have, according to the question the perfect graph
ClearAll[esF]
esF[setback_: .2,
as_: .05] := {Arrowheads[as],
Arrow[GraphElementData[{"CurvedArc", "Curvature" -> 0.5}][##],
setback]} &;
tor = Magnify[
ParametricPlot3D[{Cos[t] (3 + Cos[u]), Sin[t] (3 + Cos[u]),
Sin[u]}, {t, 0, 2 Pi}, {u, 0, 2 Pi}, Boxed -> False,
Axes -> False], .55];
el = Magnify[Graphics[{Red, Thick, Circle[{0, 0}, {.5, .25}]}], .35];
sq1 = Magnify[
Graphics[{LightBlue, Thick,
Rectangle[{0, 0}, {.015, 0.015}]}], .25];
sq2 = Magnify[
Graphics[{LightRed, Thick, Rectangle[{0, 0}, {.4, .5}]}], .35];
g0 = Graph[{1 -> 2, 2 -> 3, 3 -> 2, 3 -> 4, 4 -> 1, 1 -> 4},
VertexCoordinates -> {{0, 1}, {1, 1}, {1, 0}, {0, 0}},
EdgeLabels -> {1 \[DirectedEdge] 2 -> Style["f", FontSize -> 16],
2 \[DirectedEdge] 3 ->
Style["ψ", FontSize -> 16, Background -> White],
3 \[DirectedEdge] 2 ->
Style["\!\(\*SuperscriptBox[\(ψ\), \(-1\)]\)",
FontSize -> 16, Background -> White],
3 \[DirectedEdge] 4 ->
Style[
"\!\(\*SuperscriptBox[\(ψ∘f∘\
ϕ\), \(-1\)]\)", FontSize -> 16],
4 \[DirectedEdge] 1 ->
Style["\!\(\*SuperscriptBox[\(ϕ\), \(-1\)]\)",
FontSize -> 16, Background -> White],
1 \[DirectedEdge] 4 ->
Style["ϕ", FontSize -> 16, Background -> White]},
VertexLabels -> {1 -> Placed[el, Center], 2 -> Placed[tor, Center],
3 -> Placed[sq1, Center], 4 -> Placed[sq2, Center]},
VertexShape -> 0.1];
Show[SetProperty[g0, EdgeShapeFunction -> esF[]],
Graphics[Text["M", {0, 1}]], Graphics[Text["N", {1.015, 1.015}]],
Graphics[Text["\!\(\*SuperscriptBox[\(R\), \(m\)]\)", {0, 0}]],
Graphics[
Text["\!\(\*SuperscriptBox[\(R\), \(n\)]\)", {1.009, 0.009}]]]
Here is the result
Yes one can decide where will be the vertices --- VertexCoordinates --- and the composition character is [EmptyCircle]
Comments
Post a Comment