# Is there a better way to get the eight points of intersection?

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


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}] Using MeshFunctions:

ContourPlot[{2 Abs[x] + Abs[y] == 1, Abs[x] + 2 Abs[y] == 1}, {x, -1, 1}, {y, -1, 1},
MeshFunctions -> {ConditionalExpression[#2, Abs[#] < 1] &,
ConditionalExpression[#, Abs[#2] < 1] &, Abs[#2] - Abs[#] &},
Mesh -> {{0}, {0}, {0}}, MeshStyle -> Directive[Red, PointSize[Large]]] 