# How to find alignments of interlocking shapes?

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?

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

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} /. %[];
Show[{r1, TransformedRegion[r2, TranslationTransform[{xopt, yopt}]]}] • Thanks for your answer, how would you get tweak this to get all possible fits (there are 2 best)
– M.R.
Dec 4, 2015 at 18:57
• @M.R. You could try different seeds for the RandomSearch algorithm: Method -> {"RandomSearch", "RandomSeed" -> 123}
– shrx
Dec 4, 2015 at 19:35

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
] 