2
$\begingroup$

I have a set of curved planes that intersect each other. I only want all the parts of all planes displayed that are above the intersecting traces. Further, I would like to highlight the intersecting traces. It sounds like a simple enough problem (maybe it is), but I couldn't finde any routine to do this. So, any help is welcome. Here is an example:

    inputData = {
       {{0, .5, .5, 1200}, {0, 1, 0, 1500}, {.5, .5, 0, 1150}, {1/3, 1/3, 
         1/3, 1100}}
       , {{0, 0, 0, 1650}, {0, .5, .5, 1200}, {1/3, 1/3, 1/3, 1100}, {.5, 
         0, .5, 1300}}
       , {{1, 0, 0, 1650}, {1/3, 1/3, 1/3, 1100}, {.5, 0, .5, 
         1300}, {.5, .5, 0, 1150}}
       };

coords[{A_, B_, C_}] := {A/2 + B, A Tan[Pi/3]/2};
newCoordinates[data_] := Table[
   Join[coords[{data[[i, #, 1]], data[[i, #, 2]], 
        data[[i, #, 3]]}], {data[[i, #, 4]]}] & /@ 
    Range@Length@data[[i]]
   , {i, 1, Length[inputData]}
   ];
    data = newCoordinates[inputData];
    quad = Fit[data[[#]], {1, x, y, x^2, x y, y^2}, {x, y}] & /@ 
       Range@Length@data;

    Plot3D[quad, {x, 0, 1}, {y, 0, 1}
     , MeshFunctions -> {#3 &}
     , RegionFunction -> 
      Function[{x, y, z}, 
       0 < Sqrt[3] x - y && 1.72 > Sqrt[3] x + y && z > 1100]
     , PlotStyle -> {Directive[Orange, Opacity[.5]], 
       Directive[Green, Opacity[.5]]}
     , PlotRange -> {{0, 1}, {0, 1}, {0, 2000}}
     , BoundaryStyle -> Thick
     , BoxRatios -> {1.2, 1.2, 2}
     , Boxed -> False
     , Axes -> None
     , ImageSize -> 500
     ]
$\endgroup$
10
  • 1
    $\begingroup$ Adding a definition of your newCoordinates function might help. $\endgroup$ Jan 6, 2014 at 16:40
  • $\begingroup$ My apologies! I added the required definitions. This are to make a ternary plot. $\endgroup$ Jan 6, 2014 at 18:38
  • $\begingroup$ Do you really mean (flat) planes? These seem to be quadrics. Which is fine, just a bit confusing. $\endgroup$ Jan 6, 2014 at 19:09
  • $\begingroup$ You are right, I mean curved planes. I now state this differently in the question. $\endgroup$ Jan 6, 2014 at 19:20
  • 1
    $\begingroup$ This may do what you want.Plot3D[Evaluate[ Map[Piecewise[{{#, # >= Apply[Max, quad]}}] &, quad]], {x, 0, 1}, {y, 0, 1}, MeshFunctions -> {#3 &}, RegionFunction -> Function[{x, y, z}, 0 < Sqrt[3] x - y && 1.72 > Sqrt[3] x + y && z > 1100], PlotStyle -> {Directive[Orange, Opacity[.5]], Directive[Green, Opacity[.5]]}, PlotRange -> {{0, 1}, {0, 1}, {0, 2000}}, BoundaryStyle -> Thick, BoxRatios -> {1.2, 1.2, 2}, Boxed -> False, Axes -> None, ImageSize -> 500] $\endgroup$ Jan 7, 2014 at 4:03

1 Answer 1

3
$\begingroup$

(This is Daniel's answer from comments; it is interesting, it answers OP's question, and it generates pretty graphics, so it seems worth preserving)


Plot3D[
 quad, {x, 0, 1}, {y, 0, 1},
 MeshFunctions -> {#3 &},
 RegionFunction ->
   Function[{x, y, z}, 0 < Sqrt[3] x - y && 1.72 > Sqrt[3] x + y && z > 1100],
 PlotStyle -> {Directive[Orange, Opacity[.5]], Directive[Green, Opacity[.5]]},
 PlotRange -> {{0, 1}, {0, 1}, {0, 2000}},
 BoundaryStyle -> Thick, BoxRatios -> {1.2, 1.2, 2},
 Boxed -> False, Axes -> None, ImageSize -> 500
]

enter image description here

Plot3D[
 Evaluate[Map[Piecewise[{{#, # >= Apply[Max, quad]}}] &, quad]],
 {x, 0, 1}, {y, 0, 1},
 MeshFunctions -> {#3 &},
 RegionFunction ->
   Function[{x, y, z}, 0 < Sqrt[3] x - y && 1.72 > Sqrt[3] x + y && z > 1100],
 PlotStyle -> {Directive[Orange, Opacity[.5]], Directive[Green, Opacity[.5]]},
 PlotRange -> {{0, 1}, {0, 1}, {0, 2000}},
 BoundaryStyle -> Thick, BoxRatios -> {1.2, 1.2, 2},
 Boxed -> False, Axes -> None, ImageSize -> 500
]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.