6
$\begingroup$

I'm searching for the ways to align interlocking shapes, that is, finding the locations and rotations that maximize the arc length at which they touch.

For simplicity, I'm assuming 'shapes' are one dimensional closed curves embedded in the two dimensional plane.

For example, consider these two shapes:

f = LaminaData["Salinon", "Region"];

Show[
  DiscretizeRegion[f[1, .5]], 
  DiscretizeRegion[Disk[{2, 0}, 0.25], MeshCellStyle -> Green]
]

enter image description here

There are two ways to position the circle so that it fits with this other shape:

enter image description here enter image description here

And of course any rotation of the circles will do.

I'd like to automate this in a general way and am not sure how to begin. Does Mathematica have a built-in functionality that I can leverage to implement this?

$\endgroup$
  • $\begingroup$ Ooops, my mistake, adding it now. $\endgroup$ – M.R. Dec 4 '15 at 8:40
  • $\begingroup$ Hmm, maybe not the best choice of the second region if you are looking for rotations too :) $\endgroup$ – Kuba Dec 4 '15 at 15:40
4
$\begingroup$

A different approach:

The goal is to minimize the combined region's boundary length while keeping the area maximized. We define the two initial regions

f = LaminaData["Salinon", "Region"];
r1 = DiscretizeRegion[f[1, .5]];
r2 = DiscretizeRegion[Disk[{0, 0}, 0.25], MeshCellStyle -> Green];

and calculate the normalization factors for area and boundary length:

ta = Total[Area /@ {r1, r2}];
tb = Total[ArcLength[RegionBoundary@#] & /@ {r1, r2}];

Then, we define the function to be minimized:

fun[x_?NumericQ, y_?NumericQ] := (
ArcLength[RegionBoundary@#]/tb - Area[#]/ta
) &@ RegionUnion[r1, TransformedRegion[r2, TranslationTransform[{x, y}]]]

and minimize it:

NMinimize[fun[x, y], {x, y}, Method -> "RandomSearch"];
{xopt, yopt} = {x, y} /. %[[2]];
Show[{r1, TransformedRegion[r2, TranslationTransform[{xopt, yopt}]]}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Thanks for your answer, how would you get tweak this to get all possible fits (there are 2 best) $\endgroup$ – M.R. Dec 4 '15 at 18:57
  • $\begingroup$ @M.R. You could try different seeds for the RandomSearch algorithm: Method -> {"RandomSearch", "RandomSeed" -> 123} $\endgroup$ – shrx Dec 4 '15 at 19:35
3
$\begingroup$

There are some topics about OCR, which I took as an inspiration:

ob1 = DiscretizeRegion[f[1, .5]];
ob2 = DiscretizeRegion[Disk[{2, 0}, 0.25], MeshCellStyle -> Green];

plotRangeMain = {{-2, 2}, {-2, 2}};

bn1 = ColorNegate @ Binarize @ Rasterize @ HighlightMesh[
   RegionBoundary[ob1], Style[1, Black, Thick], 
   PlotRange -> plotRangeMain
]

enter image description here

bn2 = ImageCrop @ Binarize @ Rasterize @ HighlightMesh[
  RegionBoundary[ob2], Style[1, Black, Thick], 
  PlotRange -> {{0, 4}, {-2, 2}}
]

enter image description here

x = ImageAdjust @  ImageCorrelate[ 
  bn1, bn2, NormalizedSquaredEuclideanDistance
]

enter image description here

possIm = Thinning[Binarize[x, .6], 5] // PixelValuePositions[#, 1] & //
  Round[#, 2] & // DeleteDuplicates
{{114, 180}, {248, 180}}
possGr = MapThread[
  Rescale[#, {#2, #3}, {##4}] &,
  {#, {0, 0}, ImageDimensions @ bn1, Sequence @@ Transpose @ plotRangeMain }
] & /@ possIm
{{-(11/15), 0}, {34/45, 0}}
Show[
   ob1,
   Table[
      TransformedRegion[
         ob2,
         TranslationTransform[tra]@*TranslationTransform[-RegionCentroid[ob2]]
      ],
   {tra, possGr}
   ],
 PlotRange -> 2
 ]

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.