How to find alignments of interlocking shapes?

Question

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]
]

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

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?

Hmm, maybe not the best choice of the second region if you are looking for rotations too :) — Kuba, Dec 04 '15 at 15:40

score 5 · Answer 1 · answered Dec 04 '15 at 09:48

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

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

score 4 · Answer 2 · answered Dec 04 '15 at 09:40

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
]

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

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

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
 ]

How to find alignments of interlocking shapes?

2 Answers2

Linked