# Tag Info

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 ...

27

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

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[#, #[]] & /@ 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} &...

17

Here we manual create the normal line of the three differentiable curves. f[x_] := x^x; g[x_] := Log[x]^Log[x] h[x_] := Log[x]^2 eq1 = {x1, f[x1]} + t*Normalize[{-f'[x1], 1}]; eq2 = {x2, g[x2]} + t*Normalize[{-g'[x2], 1}]; eq3 = {x3, h[x3]} - t*Normalize[{-h'[x3], 1}]; sol = NMinimize[{0, (eq1 - eq2)^2 + (eq2 - eq3)^2 + (eq3 - eq1)^2 == 0}, {x1, x2, x3, ...

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 @@ #[] - 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}} ...

16

f[x_] := x^x g[x_] := Log[x]^Log[x] h[x_] := Log[x]^2 plot = Plot[{f[x], g[x], h[x]}, {x, 0, E}, PlotRange -> {0, 1}] Extract the three lines from plot and use them to construct three RegionDistance functions: {linef, lineg, lineh} = Cases[plot, _Line, All]; {rdf, rdg, rdh} = RegionDistance /@ {linef, lineg, lineh}; ContourPlot to get the lines where ...

15

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]^...

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

A quick hack, essentially interpolating a point travelling at constant speed on polygon edge and averaging the position over a time interval: With[{coords = Append[#, #[]] &@RandomPolygon[{"Convex", 8}][]}, With[{ip = Interpolation[ Transpose@{Rescale@Accumulate@ Prepend[EuclideanDistance @@@ Partition[coords, 2, 1], 0], ...

13

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 #...

13

list = Tuples[Table[i, {i, -2, 2}], 3]; smallspheres = Sphere[#, 1/10] & /@ list; bigsphere = Sphere[{0, 0, 0}, 3]; MemberBigSphereQ = RegionIntersection[bigsphere, #] =!= EmptyRegion & 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

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

11

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 - (Outer[Times, #, #] &[...

11

Not an anwser, yet. This is how the curve shorthening flow would act on the cells: As you can see, the cells lose contact. So this is probably not what you are looking for, right? Something similar can be obtained by just subdividing the polygons a little (cutting off the corners) and then using BSplineCurve: polys = MeshPrimitives[mesh, 2][[All, 1]]; f[...

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=GraphicsMesh...

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[ ...

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