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

Improve this question
$\endgroup$
8
  • 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, 2017 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, 2017 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, 2017 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, 2017 at 13:41
  • 1
    $\begingroup$ Decrease MaxCellMeasure? Try different Method values? $\endgroup$
    – Szabolcs
    Oct 16, 2017 at 13:45

1 Answer 1

Reset to default
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

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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