Return to Answer

added 2282 characters in body

edited Jun 8, 2015 at 1:26

67.8k
3
66
164

Also works for second set of vertices (but no efficient):

enter image description here

with points:

{Point[{-1, 0, 0}], Point[{-(1/2), -(1/2) + Sqrt[2], -1}], Point[{-(1/2), -(1/2) + Sqrt[2], 1}], Point[{0, -1, 0}], Point[{1, 1 - Sqrt[2], -1}], Point[{1, 1 - Sqrt[2], 1 - Sqrt[2] - (3 - 2 Sqrt[2])/Sqrt[2] + 1/2 (-4 + 5 Sqrt[2])}], Point[{1, 2 - Sqrt[2], -1}], Point[{1, 2 - Sqrt[2], 1}], Point[{1 - Sqrt[2], 1, 1 - 3/Sqrt[2] - Sqrt[2] + 1/2 (-4 + 5 Sqrt[2])}], Point[{-(1/2) + Sqrt[2], -(1/2), -1}], Point[{-(1/2) + 1/2 (3 - 2 Sqrt[2]), -(1/2) + Sqrt[2] + 1/2 (3 - 2 Sqrt[2]), 1}], Point[{1/2 + (2 - Sqrt[2])/Sqrt[2], -(3/2) + Sqrt[2] - (2 - Sqrt[2])/ Sqrt[2], 1}], Point[{1/2 (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), 1/Sqrt[2] - Sqrt[2]}], Point[{1/2 (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), -(1/Sqrt[2]) + Sqrt[2]}], Point[{1/2 (2 - Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (2 - Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), Sqrt[2] - (2 - Sqrt[2])/Sqrt[2]}], Point[{1/2 (2 - Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (2 - Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[ 2]), -Sqrt[2] + (2 - Sqrt[2])/Sqrt[2]}], Point[{1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[ 2]), -1 + 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), -((-1 + Sqrt[2])/Sqrt[2])}], Point[{1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[ 2]), -1 + 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), (-1 + Sqrt[2])/Sqrt[2]}], Point[{-1 + 1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 - Sqrt[2])/Sqrt[2]), 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 - Sqrt[2])/Sqrt[2]), -((-1 + Sqrt[2])/Sqrt[2])}], Point[{-1 + 1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 - Sqrt[2])/Sqrt[2]), 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 - Sqrt[2])/Sqrt[2]), (-1 + Sqrt[2])/Sqrt[2]}]}

Also works for second set of vertices (but no efficient):

enter image description here

with points:

{Point[{-1, 0, 0}], Point[{-(1/2), -(1/2) + Sqrt[2], -1}], Point[{-(1/2), -(1/2) + Sqrt[2], 1}], Point[{0, -1, 0}], Point[{1, 1 - Sqrt[2], -1}], Point[{1, 1 - Sqrt[2], 1 - Sqrt[2] - (3 - 2 Sqrt[2])/Sqrt[2] + 1/2 (-4 + 5 Sqrt[2])}], Point[{1, 2 - Sqrt[2], -1}], Point[{1, 2 - Sqrt[2], 1}], Point[{1 - Sqrt[2], 1, 1 - 3/Sqrt[2] - Sqrt[2] + 1/2 (-4 + 5 Sqrt[2])}], Point[{-(1/2) + Sqrt[2], -(1/2), -1}], Point[{-(1/2) + 1/2 (3 - 2 Sqrt[2]), -(1/2) + Sqrt[2] + 1/2 (3 - 2 Sqrt[2]), 1}], Point[{1/2 + (2 - Sqrt[2])/Sqrt[2], -(3/2) + Sqrt[2] - (2 - Sqrt[2])/ Sqrt[2], 1}], Point[{1/2 (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), 1/Sqrt[2] - Sqrt[2]}], Point[{1/2 (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), -(1/Sqrt[2]) + Sqrt[2]}], Point[{1/2 (2 - Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (2 - Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), Sqrt[2] - (2 - Sqrt[2])/Sqrt[2]}], Point[{1/2 (2 - Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[2]), 1 + 1/2 (2 - Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[ 2]), -Sqrt[2] + (2 - Sqrt[2])/Sqrt[2]}], Point[{1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[ 2]), -1 + 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), -((-1 + Sqrt[2])/Sqrt[2])}], Point[{1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 + Sqrt[2])/Sqrt[ 2]), -1 + 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 + Sqrt[2])/Sqrt[2]), (-1 + Sqrt[2])/Sqrt[2]}], Point[{-1 + 1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 - Sqrt[2])/Sqrt[2]), 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 - Sqrt[2])/Sqrt[2]), -((-1 + Sqrt[2])/Sqrt[2])}], Point[{-1 + 1/2 (-1 + Sqrt[2]) (1 + Sqrt[2] + (-2 - Sqrt[2])/Sqrt[2]), 1/2 (-1 + Sqrt[2]) (1 - Sqrt[2] - (-2 - Sqrt[2])/Sqrt[2]), (-1 + Sqrt[2])/Sqrt[2]}]}

deleted 6 characters in body

Source Link

edited Jun 8, 2015 at 1:11

ubpdqn

67.8k
3
66
164

pts = Part[vertices1, #] & /@ faces; pts2 = Part[vertices2, #] & /@ faces; ip1 = InfinitePlane[#[[1 ;; 3]]] & /@ pts; ip2 = InfinitePlane[#[[1 ;; 3]]] & /@ pts2; ans = Cases[   RegionIntersection @@@   Tuples[RegionIntersection @@@ Tuples[{ip1, ip2}], 2], Point[x_]]Point[x_]]; rmfun[x_]rmfun1[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts))[x]] rmfun2[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts2))[x]] rmf[x_] := And[rmfun1[x], rmfun2[x]] pck = Union[Pick[ans, rmfunrmf /@ ans[[All, 1]]]]; Graphics3D[{Red, PointSize[0.02], pck, , Blue, Opacity[0.5], Polygon /@ pts, Yellow, Polygon /@ pts2}]

There are 3 extraneous points related to extensions of infinite planes that lie on polygon faces. Do not have time to improve.

enter image description here

pts = Part[vertices1, #] & /@ faces; pts2 = Part[vertices2, #] & /@ faces; ip1 = InfinitePlane[#[[1 ;; 3]]] & /@ pts; ip2 = InfinitePlane[#[[1 ;; 3]]] & /@ pts2; ans = Cases[ RegionIntersection @@@ Tuples[RegionIntersection @@@ Tuples[{ip1, ip2}], 2], Point[x_]] rmfun[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts))[x]] pck = Union[Pick[ans, rmfun /@ ans[[All, 1]]]]; Graphics3D[{Red, PointSize[0.02], pck, , Blue, Opacity[0.5], Polygon /@ pts, Yellow, Polygon /@ pts2}]

There are 3 extraneous points related to extensions of infinite planes that lie on polygon faces. Do not have time to improve.

enter image description here

pts = Part[vertices1, #] & /@ faces; pts2 = Part[vertices2, #] & /@ faces; ip1 = InfinitePlane[#[[1 ;; 3]]] & /@ pts; ip2 = InfinitePlane[#[[1 ;; 3]]] & /@ pts2; ans = Cases[   RegionIntersection @@@   Tuples[RegionIntersection @@@ Tuples[{ip1, ip2}], 2], Point[x_]]; rmfun1[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts))[x]] rmfun2[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts2))[x]] rmf[x_] := And[rmfun1[x], rmfun2[x]] pck = Union[Pick[ans, rmf /@ ans[[All, 1]]]]; Graphics3D[{Red, PointSize[0.02], pck, , Blue, Opacity[0.5], Polygon /@ pts, Yellow, Polygon /@ pts2}]

enter image description here

added 806 characters in body

Source Link

edited Jun 7, 2015 at 14:57

ubpdqn

67.8k
3
66
164

Update

To find points of intersection:

pts = Part[vertices1, #] & /@ faces; pts2 = Part[vertices2, #] & /@ faces; ip1 = InfinitePlane[#[[1 ;; 3]]] & /@ pts; ip2 = InfinitePlane[#[[1 ;; 3]]] & /@ pts2; ans = Cases[ RegionIntersection @@@ Tuples[RegionIntersection @@@ Tuples[{ip1, ip2}], 2], Point[x_]] rmfun[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts))[x]] pck = Union[Pick[ans, rmfun /@ ans[[All, 1]]]]; Graphics3D[{Red, PointSize[0.02], pck, , Blue, Opacity[0.5], Polygon /@ pts, Yellow, Polygon /@ pts2}]

There are 3 extraneous points related to extensions of infinite planes that lie on polygon faces. Do not have time to improve.

enter image description here

Update

To find points of intersection:

pts = Part[vertices1, #] & /@ faces; pts2 = Part[vertices2, #] & /@ faces; ip1 = InfinitePlane[#[[1 ;; 3]]] & /@ pts; ip2 = InfinitePlane[#[[1 ;; 3]]] & /@ pts2; ans = Cases[ RegionIntersection @@@ Tuples[RegionIntersection @@@ Tuples[{ip1, ip2}], 2], Point[x_]] rmfun[x_] := Or @@ Through[(RegionMember /@ (Polygon /@ pts))[x]] pck = Union[Pick[ans, rmfun /@ ans[[All, 1]]]]; Graphics3D[{Red, PointSize[0.02], pck, , Blue, Opacity[0.5], Polygon /@ pts, Yellow, Polygon /@ pts2}]

There are 3 extraneous points related to extensions of infinite planes that lie on polygon faces. Do not have time to improve.

enter image description here

Source Link

answered Jun 7, 2015 at 12:46

ubpdqn

67.8k
3
66
164