Place a ContourPlot under a Plot3D?

Posted 6 months ago
1100 Views
|
6 Replies
|
3 Total Likes
|
 I would like to combine a 3-dimensional graph of a function with its 2-dimensional contour-plot underneath it in a professional way. But I have no idea how to start, I try this: W[s_, b_, q_, p_] := (1/\[Pi]) Exp[-(p^2) + I*Sqrt[2] p (b - Conjugate[s]) - (1/ 2)*((Abs[s])^2 + (Abs[b])^2) - (q^2) + Sqrt[2]*q*(b + Conjugate[s]) - (Conjugate[s]*b)] Wpsi[\[Alpha]_, q1_, p1_, q2_, p2_] := Np[\[Alpha]]^2 (W[\[Alpha], \[Alpha], q1, p1]* W[\[Alpha], \[Alpha], q2, p2] + W[\[Alpha], -\[Alpha], q1, p1]*W[\[Alpha], -\[Alpha], q2, p2] + W[-\[Alpha], \[Alpha], q1, p1]*W[-\[Alpha], \[Alpha], q2, p2] + W[-\[Alpha], -\[Alpha], q1, p1]*W[-\[Alpha], -\[Alpha], q2, p2]) plot3D = Plot3D[Wpsi[1, 0, p1, 0, p2], {p2, -2, 2}, {p1, -2, 2}, PlotTheme -> "Scientific", PlotPoints -> 60, PlotRange -> All, ColorFunction -> Hue, PlotLegends -> Automatic, Mesh -> None]; cntplot = ContourPlot[Wpsi[1, 0, p1, 0, p2], {p2, -2, 2}, {p1, -2, 2}, PlotRange -> All, Contours -> 20, Axes -> False, PlotPoints -> 30, PlotRangePadding -> 0, Frame -> False, ColorFunction -> Hue]; gr = Graphics3D[{Texture[cntplot], EdgeForm[], Polygon[{{-2, -2, -0.4}, {2, -2, -0.4}, {2, 2, -0.4}, {-2, 2, -0.4}}, VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}, Lighting -> "Naturel"]; Show[plot3D, gr, PlotRange -> All, BoxRatios -> {1, 1, .6}, FaceGrids -> {Back, Left}] that gives: it is not good for me, I want some think like this: Are i can do it by mathematica ?
6 Replies
Sort By:
Posted 6 months ago
 Function not defined Np[\[Alpha]]^2
Posted 6 months ago
 The function Np[\[Alpha]]^2 is not defined . I put Np[\[Alpha]]^2=1. We can use this code W[s_, b_, q_, p_] := (1/\[Pi]) Exp[-(p^2) + I*Sqrt[2] p (b - Conjugate[s]) - (1/ 2)*((Abs[s])^2 + (Abs[b])^2) - (q^2) + Sqrt[2]*q*(b + Conjugate[s]) - (Conjugate[s]*b)] Wpsi[\[Alpha]_, q1_, p1_, q2_, p2_] := (W[\[Alpha], \[Alpha], q1, p1]* W[\[Alpha], \[Alpha], q2, p2] + W[\[Alpha], -\[Alpha], q1, p1]*W[\[Alpha], -\[Alpha], q2, p2] + W[-\[Alpha], \[Alpha], q1, p1]*W[-\[Alpha], \[Alpha], q2, p2] + W[-\[Alpha], -\[Alpha], q1, p1]*W[-\[Alpha], -\[Alpha], q2, p2]) plot3D[x_] := Plot3D[Wpsi[x, 0, p1, 0, p2], {p2, -2, 2}, {p1, -2, 2}, PlotPoints -> 60, PlotRange -> All, ColorFunction -> Automatic, Mesh -> None, Axes -> False, Boxed -> False]; cntplot[x_] := ContourPlot[Wpsi[x, 0, p1, 0, p2], {p2, -2, 2}, {p1, -2, 2}, PlotRange -> All, Contours -> 20, Axes -> False, PlotPoints -> 30, PlotRangePadding -> 0, Frame -> False, ColorFunction -> Automatic]; gr[x_] := Graphics3D[{Texture[cntplot[x]], EdgeForm[], Polygon[{{-2, -2, -1}, {2, -2, -1}, {2, 2, -1}, {-2, 2, -1}}, VertexTextureCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}}]}, Lighting -> "Naturel", Boxed -> False]; s[x_] := Show[plot3D[x], gr[x], ViewPoint -> {2, -2, 1}, Boxed -> False, BoxRatios -> {1, 1, 1}] Table[s[x], {x, .5, 2, .5}] 
Posted 6 months ago
 A small variation on Alexander's solution: gr2[x_] := Graphics3D[ Cases[cntplot[x], GraphicsComplex[pts_, others___] :> GraphicsComplex[Map[Append[-1], pts], others], All]] This way the contour plot does not get rasterized. You can see the difference by enlarging: With[{r = .1}, {Show[gr[1], PlotRange -> {r + r {-1, 1}, r + r {-1, 1}, -1 + r {-1, 1}}], Show[gr2[1], PlotRange -> {r + r {-1, 1}, r + r {-1, 1}, -1 + r {-1, 1}}]}] 
Posted 6 months ago
 There's SliceContourPlot3D. Just set the slice to be the bottom plane (too bad Bottom does not work automatically since this is a common application!): ClearAll[myplot]; SetAttributes[myplot, HoldAll]; myplot[f_, x_List, y_List, z : {zsym_, z1_, z2_}, opts___?OptionQ] := Show[ SliceContourPlot3D[f, zsym == z1, x, y, z, Evaluate@FilterRules[{opts}, Options@SliceContourPlot3D]], Plot3D[f, x, y, Evaluate@FilterRules[{opts}, Options@Plot3D], PlotRange -> {z1, z2}] ]; myplot[Cos[2 (x + y)]/(2 + x^4 - x y + y^4), {x, -2, 2}, {y, -2, 2}, {z, -2, 1}, ColorFunction -> Hue]