Group Abstract

Message Boards

WOLFRAM COMMUNITY

7.7K Views

4 Replies

0 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Find optimal match of points in 3-Dimensional space?

Haobo Xia

Posted 6 years ago

POSTED BY: Haobo Xia

4 Replies

Sort By:

Henrik Schachner

Henrik Schachner, Radiation Therapy Center, Weilheim, Germany

Posted 6 years ago

Hello Haobo Xia, my idea here is to use `FindShortestTour` - and to prohibit any direct step between points of the same set: aPts = RandomReal[{-1, 0}, {10, 3}]; bPts = RandomReal[{0, 1}, {10, 3}]; pts = Join[aPts, bPts]; sameListQ[a_, b_] := (MemberQ[aPts, a] && MemberQ[aPts, b]) \|\| (MemberQ[bPts, a] && MemberQ[bPts, b]) {length, order} = FindShortestTour[pts, DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)]; Graphics3D[{Black, Dashed, Line[pts[[order]]], PointSize[Large], Red, Point[aPts], Green, Point[bPts]}] Well, so much for this idea. The problem now seems to be that with this kind of `DistanceFunction` the function `FindShortestTour` does not work for more than about 20 points - at least on my system ("12.1.0 for Linux x86 (64-bit) (March 14, 2020)"). Does that help, anyway? Regards -- Henrik

Hello Haobo Xia,

my idea here is to use FindShortestTour - and to prohibit any direct step between points of the same set:

aPts = RandomReal[{-1, 0}, {10, 3}];
bPts = RandomReal[{0, 1}, {10, 3}];
pts = Join[aPts, bPts];

sameListQ[a_, b_] := (MemberQ[aPts, a] && MemberQ[aPts, b]) || (MemberQ[bPts, a] && MemberQ[bPts, b])

{length, order} = 
  FindShortestTour[pts, 
   DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)];

Graphics3D[{Black, Dashed, Line[pts[[order]]], PointSize[Large], Red, Point[aPts], Green, Point[bPts]}]

enter image description here

Well, so much for this idea. The problem now seems to be that with this kind of DistanceFunction the function FindShortestTour does not work for more than about 20 points - at least on my system ("12.1.0 for Linux x86 (64-bit) (March 14, 2020)"). Does that help, anyway?

Regards -- Henrik

POSTED BY: Henrik Schachner

Haobo Xia

Posted 6 years ago

POSTED BY: Haobo Xia

Daniel Lichtblau

Daniel Lichtblau, Wolfram Research

Posted 6 years ago

POSTED BY: Daniel Lichtblau

Haobo Xia

Posted 6 years ago

Thank you, It does work, but if it is guaranteed to be optimal, it has to enumerate n! cases. So it is slower than FindMinimumCostFlow. Thanks anyway. (My Function) ca[n_] := ca[n] = ConstantArray[0, {n, n}] PointsMatch[s1_, s2_] := If[s1 == s2, {IdentityMatrix[#], 0}, Extract[FindMinimumCostFlow[ ArrayFlatten[{{0, 1., 0, 0}, {0, 0, DistanceMatrix[s1, s2, DistanceFunction -> EuclideanDistance], 0}, {0, ca[#], 0, -1.}, {0, 0, 0, 0}}], 1, 2# + 2, "OptimumFlowData"][{"FlowMatrix", "CostValue"}], {{1, Range[2, 1 + #], Range[# + 2, 2# + 1]}, {2}}]] &@Length[s1] aPts = RandomReal[{-10, 10}, {8, 3}]; bPts = RandomReal[{-10, 10}, {8, 3}]; pts = Join[aPts, bPts]; (By MaximizeOverPermutations) AbsoluteTiming[ MaximizeOverPermutations[-Plus @@ MapThread[EuclideanDistance, {aPts, bPts[[#]]}] &, 8]] (By FindShortestTour) AbsoluteTiming[{length, order} = FindShortestTour[pts, DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)]; MinimalBy[{Plus @@ (EuclideanDistance@(Sequence @@ pts[[#]]) & /@ #), #} & /@ (Partition[#, 2] & /@ {Rest[ order], order}), First]] (By FindMinimumCostFlow) AbsoluteTiming[MatrixForm /@ PointsMatch[aPts, bPts]]

Thank you,

It does work, but if it is guaranteed to be optimal, it has to enumerate n! cases. So it is slower than FindMinimumCostFlow. Thanks anyway.

(*My Function*)
ca[n_] := ca[n] = ConstantArray[0, {n, n}]
PointsMatch[s1_, s2_] := 
 If[s1 == s2, {IdentityMatrix[#], 0}, 
    Extract[FindMinimumCostFlow[
       ArrayFlatten[{{0, 1., 0, 0}, {0, 0, 
          DistanceMatrix[s1, s2, 
           DistanceFunction -> EuclideanDistance], 0}, {0, ca[#], 
          0, -1.}, {0, 0, 0, 0}}], 1, 2*# + 2, 
       "OptimumFlowData"][{"FlowMatrix", "CostValue"}], {{1, 
       Range[2, 1 + #], Range[# + 2, 2*# + 1]}, {2}}]] &@Length[s1]
aPts = RandomReal[{-10, 10}, {8, 3}];
bPts = RandomReal[{-10, 10}, {8, 3}];
pts = Join[aPts, bPts];
(*By MaximizeOverPermutations*)
AbsoluteTiming[
 MaximizeOverPermutations[-Plus @@ 
     MapThread[EuclideanDistance, {aPts, bPts[[#]]}] &, 8]]
(*By FindShortestTour*)
AbsoluteTiming[{length, order} = 
  FindShortestTour[pts, 
   DistanceFunction -> (If[sameListQ[#1, #2], Infinity, 
       EuclideanDistance[#1, #2]] &)];
 MinimalBy[{Plus @@ (EuclideanDistance@(Sequence @@ 
            pts[[#]]) & /@ #), #} & /@ (Partition[#, 2] & /@ {Rest[
       order], order}), First]]
(*By FindMinimumCostFlow*)
AbsoluteTiming[MatrixForm /@ PointsMatch[aPts, bPts]]

enter image description here

POSTED BY: Haobo Xia

Reply to this discussion

Reply Preview

Attachments

Remove Add a file to this post

Follow this discussion

or Discard

Feedback