6
$\begingroup$

A new feature added in Mathematica 11.2 gives the ability to easily plot region intersection (see this post, scroll down to 3D Computational Geometry). enter image description here

However, I can't seem to understand how to find the intersection of following objects:

contourRegionPlot3D[region_, {x_, x0_, x1_}, {y_, y0_, y1_}, {z_, z0_, z1_}, 
    opts : OptionsPattern[]] := Module[{reg, preds},
    reg = LogicalExpand[region && x0 <= x <= x1 && y0 <= y <= y1 && z0 <= z <= z1];
    preds = Union@Cases[reg, _Greater | _GreaterEqual | _Less | _LessEqual, -1];
    Show @ Table[ContourPlot3D[
        Evaluate[Equal @@ p], {x, x0, x1}, {y, y0, y1}, {z, z0, z1}, 
        RegionFunction -> Function @@ {{x, y, z}, Refine[reg, p] && Refine[! reg, ! p]},
        opts], {p, preds}]]

shift = {1.2, 1, 1};
heart = ImplicitRegion[((y - shift[[1]])^2 + (9 (x - shift[[2]])^2)/ 4 + (z -
    shift[[3]])^2 - 1)^3 - (y - shift[[1]])^2 (z - shift[[3]])^3 - (9 (x -
    shift[[2]])^2 (z - shift[[3]])^3)/80 < 0, {x, y, z}];
heartPlot = RegionPlot3D[
    heart,
    PlotRange -> {{-0.5, 2.5}, {-2.5, 2.5}, {-0.5, 2.5}},
    PlotPoints -> 30,
    PlotStyle -> Directive[lightBlue, Opacity[0.4]]
];
arcRegion = 1.4 < x^2 + y^2 < 1.6 && 1.4 < z < 1.6 && 1 \[Pi]/64 < ArcTan[x, y] < 27 \[Pi]/64;
arcRegionPlot =  contourRegionPlot3D[arcRegion, {x, 0.1, 2}, {y, 0.1, 2}, {z, 1.2, 1.8}];

RegionIntersection[
    heartPlot // DiscretizeGraphics,
    arcRegionPlot // DiscretizeGraphics
]

And here's what I get as an output: enter image description here

What am I doing wrong here? I know that those 2 regions for sure intersect: enter image description here

$\endgroup$
  • 1
    $\begingroup$ Without going into details, I suspect problems with the dimensionality of regions (surface vs. volume). Do you want to treat them as volumes? $\endgroup$ – Szabolcs Oct 16 '17 at 12:46
  • $\begingroup$ @Szabolcs, Frankly, I'm not sure. What I want is to have a nice annular tunnel cut through the heart. $\endgroup$ – arslancharyev31 Oct 16 '17 at 12:48
  • 1
    $\begingroup$ I wouldn't expect much consistency in dimensionality from DiscretizeGraphics. Graphics are just for looks. When you do an intersection then a surface and a volume are very different. I would try RegionIntersection or RegionDifference on the ImplicitRegion objects, then use BoundaryDiscretizeRegion with explicit bounds on the result. $\endgroup$ – Szabolcs Oct 16 '17 at 12:55
  • $\begingroup$ @Szabolcs, I've updated my question according to your suggestion. It works but produces some unwanted visual artifacts. Any ideas how to get rid of them? $\endgroup$ – arslancharyev31 Oct 16 '17 at 13:41
  • 1
    $\begingroup$ Decrease MaxCellMeasure? Try different Method values? $\endgroup$ – Szabolcs Oct 16 '17 at 13:45
3
$\begingroup$

Following @Szabolcs's advice, here's what I could accomplish:

lightBlue = RGBColor[0.593454, 0.888609, 0.918547];
shift = {1.2, 1, 1};
heart = ImplicitRegion[((y - shift[[1]])^2 + (9 (x - shift[[2]])^2)/ 4 + (z -
    shift[[3]])^2 - 1)^3 - (y - shift[[1]])^2 (z - shift[[3]])^3 - (9 (x -
    shift[[2]])^2 (z - shift[[3]])^3)/80 < 0, {x, y, z}];
heartPlot = RegionPlot3D[
    heart,
    PlotRange -> {{-0.5, 2.5}, {-2.5, 2.5}, {-0.5, 2.5}},
    PlotPoints -> 100,
    PlotStyle -> Directive[lightBlue, Opacity[0.4]]
];
arcRegionImplicit = ImplicitRegion[1.4^2 < x^2 + y^2 < 1.6^2 && 1.4 < z < 1.6 && 0 < ArcTan[x, y] < \[Pi]/2, {x, y, z}];

Show[
    heartPlot,
    RegionPlot3D[BoundaryDiscretizeRegion[RegionIntersection[heart, arcRegionImplicit], MaxCellMeasure -> 0.001]]
]

With the following result: enter image description here 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.