Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I want to get the eight points of intersection from the equations 2 Abs[x] + Abs[y] == 1 and Abs[x] + 2 Abs[y] == 1. To solve these equations, I tried

Solve[{2 Abs[x] + Abs[y] == 1, Abs[x] + 2 Abs[y] == 1}, {x, y}]

but could only get the four points. I then tried

y /. Quiet@Solve[#, y] /. 
   Abs[x_] -> {x, -x} & /@ {2 Abs[x] + Abs[y] == 1,  Abs[x] + 2 Abs[y] == 1}

p = ({x, y} /. Solve[y == #] & /@ {{1 - 2 x, (1 - x)/2}, {(1 - x)/2, (
      1 + x)/2}, {(1 + x)/2, 1 + 2 x}, {1 + 2 x, -1 - 2 x}, {-1 - 2 x,
       1/2 (-1 - x)}, {1/2 (-1 - x), 
      1/2 (-1 + x)}, {1/2 (-1 + x), -1 + 2 x}, {-1 + 2 x, 1 - 2 x}})~
  Flatten~1

{{1/3, 1/3}, {0, 1/2}, {-(1/3), 1/3}, {-(1/2), 0}, {-(1/3), -(1/3)}, {0, -(1/2)}, {1/3, -(1/3)}, {1/2, 0}}

It works, but I don't like it. Could you recommend a better method?

enter image description here

share|improve this question
add comment

2 Answers

up vote 6 down vote accepted

Actually, the way I interpret your ContourPlot, there are only 4 points of intersection (red/blue curves). So I do interpret your question such that you want to include intersection with the coord axes as well. I hope this helps:

eq1 = 2 Abs[x] + Abs[y] == 1;
eq2 = Abs[x] + 2 Abs[y] == 1;

p = {x, y} /.
(Solve[#, {x, y}] & /@
 {{eq1, eq2},
  {x == 0, eq2},
  {eq1, y == 0}})~Flatten~1
share|improve this answer
add comment

Your equations only have 4 points of intersections, not 8, so Solve is returning the correct result. To get the remaining 4, as you have indicated in the figure, you'll also have to consider the x and y axes. You can manually solve each curve with the appropriate axes (it seems like you don't care for the farthest points of intersection with the axes). The following code will solve for all of them, and only filter those that fall within a certain distance from the center (which seems to be your intent).

eqns = {2 Abs[x] + Abs[y] == 1, Abs[x] + 2 Abs[y] == 1, x == 0, y == 0};
pts = Flatten[Solve[#, {x, y}] & /@ Subsets[eqns, {2}], 1] /. Rule[_, x_] :> x;
filtPts = Select[pts, 0 < EuclideanDistance[{0, 0}, #] <= 0.5 &];
ContourPlot[{2 Abs[x] + Abs[y] == 1, Abs[x] + 2 Abs[y] == 1}, 
    {x, -1, 1}, {y, -1, 1}, Epilog -> {Red, PointSize@Large, Point@filtPts}]

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.