28

You'll be interested in the (undocumented!) functions Graphics`Mesh`IntersectQ[] (for checking the intersections) and Graphics`Mesh`FindIntersections[] (for actually finding them). As a sample: BlockRandom[SeedRandom[42, Method -> "MersenneTwister"]; (* for reproducibility *) lins = Table[{Line[RandomReal[1, {2, 2}]]}, {42}];] Graphics`Mesh`...


28

We couldn't be really pleased if we didn't exploit existing Mathematica functionality to get exact solutions. Here we provide them with Reduce rewriting the given system to an exact one and using a trick by adding another variable x because one can see that any solutions are described by two different arguments t and t + x. Now we can realize that one can ...


28

Fixed (see below) Here's an approach: r1 = Exp[-x^3 - y] - 1 == z; r2 = y == z; We create ImplicitRegions: reg1 = ImplicitRegion[r1, {x, y, z}]; reg2 = ImplicitRegion[r2, {x, y, z}]; The intersection of these regions is the line you seek: reg = RegionIntersection[reg1, reg2]; And here is the length (note the inclusion of the range of values in ...


26

p1 = Partition[{{243.8, 77.}, {467.4, 12.}, {291.8, 130.}, {476., 210.5}, {103.2, 327.}, {245.2, 110.5}, {47.4, 343.}, {87.4, 108.5}, {371., 506.5}, {384.6, 277.}, {264.6, 525.5}, {353.8, 294.5}, {113.2, 484.5}, {296., 304.5}, {459.6, 604.5}, {320.2, 466.5}, {288.2, 630.5}, {199.6, 446.5}, {138.8, 615.5}, {81.8, 410.}, {232.4, 795.}, ...


18

From the Mathematica documentation for PolyhedronData (see Coordinate-related properties under "More information") RegionFunction – pure function giving True in the interior of the polyhedron. PolyhedronData["PentagonalDipyramid", "RegionFunction"] As I was playing around with this I noticed the Select part was very slow when running on lots of points, ...


18

Can be done as follows. (1) Find implicit form from parametric. (2) Solve for pts $(x,y)$ where implicit eqn and gradient simultaneously vanish. (3) Discard those solutions that correspond to cusps. The rest correspond to crossings. The code below handles steps (1) and (2). I found it useful to rationalize because we eventually get an overdetermined system ...


18

Update for v10 I used MeshRegion and MeshPrimitives for intersected points. linePoly[v1_, v2_, f_] := Module[{fC = Append[#, #[[1]]] & /@ f}, {x, y, z} /. NSolve[ Or@@ ({x, y, z}\[Element]# & /@ MeshPrimitives[MeshRegion[v1, Line /@ fC], 1]) && Or@@ ({x, y, z}\[Element]# & /@ MeshPrimitives[MeshRegion[v2, ...


17

Third solution A slightly simpler and more geometric approach leads to a third form for the solution (including Artes' and my second) -- don't you just love trigonometric functions! By symmetry, two points starting from a vertex of the hypocycloid (star) and going in opposite directions at the same speed will meet at one of the desired crossings. If the ...


17

Turning my comment into an answer per (now deleted?) comment which requested it. This is documented to work only in Wolfram Language at this point (specifically Wolfram Programming Cloud). Interestingly enough, it does work also with Mathematica 9.0.1., although documentation has no indication of Line or Solve supporting geometric regions. p1 = {{243.8, 77....


17

Since another answer provides misleading results I'm motivated to explain what's wrong there and suggest a correct solution. One can guess that the error there has been produced by DiscretizeRegion or by an improper parametrization of the curve with RegionIntersection (more likely the former reason). Let's start from the begining defining the following ...


17

This is a motivating post. I have made no effort to deal with intersection <4 pts. I post only illustrative examples. The centre of the circle is the intersection of perpendicular bisectors of chords. f[a_, b_, c_, d_] := Module[{e1 = a x^2 + b, e2 = c y^2 + d, s, p, l, ln, ctr}, s = Solve[{x, e1} == {e2, y}, {x, y}, Reals]; p = {#, a #^2 + b} &...


16

Here is a direct vector calculation that verifies the segments (not just the infinite lines) intersect. segsegintersection[ lines_ ] := Module[{ md = Subtract @@ (Plus @@ # & /@ lines), sub = Subtract @@ # & /@ lines, det}, det = -Det[sub]; If[And @@ (Abs[#] <= 1 & /@ #) , (Plus @@ #[[1]] - Subtract @@ #[[...


16

Here is a graph theory approach: ids = obj2[[All, 1]]; idToRectangleRules = #1 -> Rectangle[#2 - #3/2, #2 + #3/2] & @@@ obj2; intersectingIdPairs = Select[ Subsets[ids, {2}], Area @ RegionIntersection[# /. idToRectangleRules] > 0 & ]; overlappingIdGroups = ConnectedComponents @ Graph[ids, intersectingIdPairs] {{1, 2, 4}, {5, 6}, {3}} ...


15

Solve can be used directly pts = {x, y} /. Solve[{y^2 == 4 - 4 x^2, (1 - (x/2))^2 + (y - 1)^2 == 1}, {x, y}, Reals] // FullSimplify (* {{Root[144 - 160*#1 - 328*#1^2 + 120*#1^3 + 225*#1^4 & , 1, 0], Root[144 - 1280*#1 + 1688*#1^2 - 960*#1^3 + 225*#1^4 & , 2, 0]}, {Root[144 - 160*#1 - 328*#1^2 ...


14

This is a standard connectivity problem. Here is a graph-based solution: ClearAll[listToGraph]; listToGraph[list_List]:= Graph @ Union[ Sort /@ Flatten[Apply[UndirectedEdge,(Partition[#1,2,1]&) /@ list,{2}]] ]; ClearAll[getConnectivityRules]; getConnectivityRules[graph_Graph]:= (Dispatch[Flatten[Thread /@ Thread[#1 -> Range[Length[#...


14

Alright, I managed to borrow a computer. Here's an implementation of my suggestion: ellipseIntersections[mat1_?MatrixQ, mat2_?MatrixQ] /; Dimensions[mat1] == Dimensions[mat2] == {2, 3} := {\[FormalX], \[FormalY]} /. RootReduce[Solve[Flatten[Map[ GroebnerBasis[Append[Thread[{\[FormalX], \[FormalY]} == #], \[FormalC]^...


13

list = Tuples[Table[i, {i, -2, 2}], 3]; smallspheres = Sphere[#, 1/10] & /@ list; bigsphere = Sphere[{0, 0, 0}, 3]; MemberBigSphereQ = RegionIntersection[bigsphere, #] =!= EmptyRegion[3] & surfacespheres = Select[smallspheres, MemberBigSphereQ] Graphics3D[Join[{bigsphere}, surfacespheres]] By packing the spheres more densely it gets more ...


13

Update: Disjoint regions corresponding to the intersection of exactly k disks for k = 1, 2, 3, 4. Computation of 7-by-7 example is too large for free Wolfram Cloud, so I use a smaller example with 16 disks. Using Carl's method for identifying the neighbors of each disk tuples = Tuples[Range @ 4, 2]; disks = Disk[#, 9/10] & /@ tuples; circles = Circle[...


13

You can (1) use Cases to extract the Lines from ContourPlot output, and (2) use RegionIntersection to find the intersections: cp = ContourPlot[{(y^2 == 4 - 4*x^2), ((1 - x/2)^2 + (y - 1)^2 == 1)}, {x, -5, 5}, {y, -5, 5}, Frame -> False, Axes -> True]; intersections = RegionIntersection @@ Cases[Normal @ cp, _Line, All] Point[{{0.992916, 0....


12

Let's first convert the input data to rectangles: ToRectangle[{id_, center_, dimensions_}] := {{id}, Rectangle[center - dimensions/2, center + dimensions/2]}; rectangles = ToRectangle /@ obj2; Check if we have two groups and one isolated rectangle: Graphics @ { {Text @@@ obj2}, {Red, Opacity[1/4], Rest /@ rectangles} } Ok, good. Let's combine the ...


12

EDIT: As @nikie noted, using FindArgMin (a variant of FindMinimum) instead of (N)ArgMin can improve the speed of finding a solution. Since in the case of this problem only one minimum exists, this should actually produce the global minimum in an efficient manner. How about this? Module[{n, lines, sol}, n = 10; lines = HalfLine[# + RandomPoint@Ball[], -2 #...


12

Maybe this produces does what you want (it is basically what Manuel --Moe-- G suggested). f[a1_?MatrixQ, a2_?MatrixQ] := Thread /@ List @@@ Normal[ Select[ Merge[{ AssociationThread @@ Transpose[a1], AssociationThread @@ Transpose[a2] }, Identity ], Length[#] >= 2 & ] ] f[a1, a2] {{{2., 4.}, ...


11

Brute force approach: g[y0_] := x /. FindRoot[ Exp[-(x^3 + y)] - 1 == y /. y -> y0 , {x, -4, 4}] line = Table[{g[y], y, y}, {y, -1, 4, .0001}]; Graphics3D[Line@line] Total[Norm@(Subtract @@ #) & /@ Partition[line, 2, 1]] 10.9513


10

Thanks to Artes for helping me sort out bugs in this answer. Solve[E^(-x^3 - y) - 1 - y == 0, y] {{y -> -1 + ProductLog[E^(1 - x^3)]}} To account for that fact that $-4 < y = z < 4$ we need to find the range of allowed $x$ values. FindRoot[-1 + ProductLog[E^(1 - x^3)] == 4, {x, 1}] {x -> -1.77681} FindRoot[-1 + ProductLog[E^(1 - x^3)] ==...


10

A more geometrical approach based on CP3D surface-surface intersections boundary style... inter = ContourPlot3D[{h == 0, g == 0}, {x, -4, 4}, {y, -4, 4}, {t, -4, 4}, Mesh -> None, ContourStyle -> Directive[Orange, Opacity[0.3], Specularity[White, 30]], BoundaryStyle -> {1 -> None, 2 -> None, {1, 2} -> Blue}] reg = ...


10

Using your data plot1 = ListLinePlot[data, PlotStyle -> {Thick, Black}]; f = Function[t, a*t^n] /. FindFit[data, a*t^n, {a, n}, t, MaxIterations -> 1000] plot2 = Plot[f[t], {t, 2, 60}, PlotStyle -> Red]; and then Show[ plot1, plot2, ImageSize -> 400 ] The same technique used here can be applied to this problem: pts=Graphics`Mesh`...


10

Here's another way to implement kirma's solution: With[{n = 15}, BlockRandom[SeedRandom["many lines"]; (* for reproducibility *) lines = HalfLine[# + RandomPoint @ Ball[], -2 # + RandomPoint @ Ball[]] & /@ RandomPoint[Sphere[{0, 0, 0}, 10], n]]]; sol = LeastSquares @@ Total[ With[{m = IdentityMatrix[3] - (Outer[Times, #, #] &[...


10

Update Here is a revised version of my answer that is much faster. First, I define the function RegionPieces which takes a region and its neighbors, and creates the disjoint pieces when adding each neighbor and its complement: RegionPieces[r_, neighbors_List] := Fold[iRegionPieces, {r}, neighbors] iRegionPieces[r_, next_] := With[ { new = Flatten[ ...


9

Another graph-based solution: Sort@Cases[#, _List] & /@ ConnectedComponents@ Graph@Flatten[Thread@UndirectedEdge[ConstantArray[#, Length[#]], #] & /@ list] {{{a, b}, {b, c}, {c, d}}, {{e, f}, {f, g, h}}} Here I construct the following graph Graph[Thread@UndirectedEdge[ConstantArray[#, Length[#]], #] & /@ list // Flatten, VertexLabels -&...


9

As I noted in this answer, there is a built-in, but undocumented function that can do this: p1 = Partition[{{243.8, 77.}, {467.4, 12.}, {291.8, 130.}, {476., 210.5}, {103.2, 327.}, {245.2, 110.5}, {47.4, 343.}, {87.4, 108.5}, {371., 506.5}, {384.6, 277.}, {264.6, 525.5}, {353.8, 294.5}, {113.2, 484.5}, {296., 304.5}, ...


Only top voted, non community-wiki answers of a minimum length are eligible