Finding the possible rotations of set of 3D points?

Questions
1

Hi,

I have two sets of 3D points. I want rotate data2 while keeping data1 constant. And I want to find out what are all the possible rotations data2 can have while keeping its geometry horizontal and parallel to data1 (i.e. facing each other). Can you help me to accomplish that? TIA

data1 = {{-0.76605542, -0.17686675, -0.82332146},
   {-1.45292042, -1.37163375, -0.66183746},
   {-2.86933942, -1.22490575, -0.71900646},
   {-3.26481042, 0.07793225, -0.92173846},
   {-1.90144942, 1.14801825, -1.06179046},
   { 0.66067858 , 0.06673325, -0.82324246},
    {1.34752258 , 1.26152125, -0.66182246},
    {1.79610558, -1.25817975, -1.06139746},
    {2.76394858 , 1.11478725, -0.71878046},
    {3.15944758, -0.18807775, -0.92128646}};


data2 = {{-0.52739887, 0.07259519, 3.16175217},
   {-1.21426387, -1.12217181 , 3.32323617},
   {-2.63068287, -0.97544381 , 3.26606717},
   {-3.02615387, 0.32739419 , 3.06333517},
   {-1.66279287, 1.39748019, 2.92328317},
   { 0.89933513 , 0.31619519 , 3.16183117},
   { 1.58617913, 1.51098319, 3.32325117},
   { 2.03476213, -1.00871781 , 2.92367617},
   { 3.00260513, 1.36424919 , 3.26629317},
   { 3.39810413, 0.06138419 , 3.06378717}};


Show[ListPointPlot3D[{data1, data2}, 
  PlotStyle -> {Directive[PointSize[Large], Red], 
    Directive[PointSize[Large], Green]}], SphericalRegion -> True, 
 BoxRatios -> 1, PlotRange -> 4, ImageSize -> 500]

rotation1.jpg
rotation1.jpg500×500 15.7 KB

 rot1data2 = RotationTransform[Pi, {1, 0, 0}][data2];

Show[ListPointPlot3D[{data1, rot1data2}, 
  PlotStyle -> {Directive[PointSize[Large], Red], 
    Directive[PointSize[Large], Green]}], SphericalRegion -> True, 
 BoxRatios -> 1, PlotRange -> 4, ImageSize -> 500]


rot2data2 = RotationTransform[Pi, {0, 1, 0}][data2];


Show[ListPointPlot3D[{data1, rot2data2}, 
  PlotStyle -> {Directive[PointSize[Large], Red], 
    Directive[PointSize[Large], Green]}], SphericalRegion -> True, 
 BoxRatios -> 1, PlotRange -> 4, ImageSize -> 500]
2

Manipulate may help:

Manipulate[
 Show[ListPointPlot3D[{data1, RotationTransform[t, {a, b, c}][data2]},
    PlotStyle -> {Directive[PointSize[Large], Red], 
     Directive[PointSize[Large], Green]}], SphericalRegion -> True, 
  BoxRatios -> 1, PlotRange -> 4, ImageSize -> 500],
 {t, 0, 2 Pi}, {{a, 1}, -1, 1}, {{b, 0}, -1, 1}, {{c, 0}, -1, 1}]
3

Manipulate may help:

Manipulate[
 Show[ListPointPlot3D[{data1, RotationTransform[t, {a, b, c}][data2]},
    PlotStyle -> {Directive[PointSize[Large], Red], 
     Directive[PointSize[Large], Green]}], SphericalRegion -> True, 
  BoxRatios -> 1, PlotRange -> 4, ImageSize -> 500],
 {t, 0, 2 Pi}, {{a, 1}, -1, 1}, {{b, 0}, -1, 1}, {{c, 0}, -1, 1}]
4

Hi, I am not sure whether I understand your problem correctly, but maybe you need Nearest. The idea is simple:

Manipulate[
 rdata2 = RotationTransform[\[Phi], {0, 0, 1}][data2];
 Graphics3D[{PointSize[.03], Red, Point[data1], Green, Point[rdata2],
   Black, Line[{#, First@Nearest[rdata2, #]} & /@ data1]}, 
  PlotRange -> {{-4, 4}, {-4, 4}, Automatic}], {\[Phi], 0, 2 Pi}]

giving:

nearest.gif

So if all those Nearest-distances are summed up:

totalDist[\[Phi]_] := 
 Total[EuclideanDistance @@@ ({#, 
       First@Nearest[
         RotationTransform[\[Phi], {0, 0, 1}][data2], #]} & /@ data1)]

one has a function to be minimized:

totalDist.png
totalDist.png360×245 8.9 KB

Hope that helps, regards – Henrik