7
$\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?

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

2 Answers 2

Reset to default
5
$\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

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

Improve this answer
$\endgroup$

Your Answer

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

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