Adding Fill to a ContourPlot

Question

I am trying to implement the kind of solution Bob Hanlon provided here, but on another equation. There are two problems. First, this time, the gap at the top-right is not fully closed by the method, and second, I would like to add a standard blue fill to the regions below zero in the contour plot, while the above zero region should remain white.

Can these things be achieved?

Here is my code:

Clear["Global`*"]

expr2 = 1/(32 (p1 - p2)^2 (-(-1 + p2) p2)^(3/2) (-1 + p1 + p2)^2) (-1 + p1)^2 p1^2 (-64 Sqrt[-(-1 + p1) p1] (-1 + p2)^2 p2^2 - 32 (-1 + p1) p1 (-(-1 + p2) p2)^(3/2) - 32 (-(-1 + p2) p2)^(5/2) + (32 (-(-1 + p2) p2)^(7/2))/((-1 + p1) p1) - (192 (p1 - p2)^2 (-1 + p1 + p2)^2)/Sqrt[1/(p2 - p2^2)] + (64 (-1 + p2)^3 p2^3 (-3 + 2 Sqrt[((-1 + p2) p2)/((-1 + p1) p1)]))/Sqrt[-(-1 + p1) p1] + 32 (1/(p1 - p1^2))^(3/2) (6 (-1 + p1) p1 (-1 + p2)^3 p2^3 - 2 (-1 + p2)^4 p2^4 + Sqrt[1/(p1 - p1^2)] (-(-1 + p2) p2)^(9/2) + (2 (-1 + p2)^4 p2^4)/(((-1 + p2) p2)/((-1 + p1) p1))^(3/2) + 6 (-1 + p1)^4 p1^4 Sqrt[((-1 + p2) p2)/((-1 + p1) p1)] - 12 (-1 + p1)^4 p1^4 (((-1 + p2) p2)/((-1 + p1) p1))^(3/2))) // Simplify;


fd = FunctionDomain[expr2, {p1, p2}]; expr3 = expr2 // FullSimplify[#, fd] &; ContourPlot[Numerator@expr3 == 0, {p1, 0.5, 1}, {p2, 0.5, 1}, MaxRecursion -> 5, FrameLabel -> {p1, p2}, WorkingPrecision -> 50] // Quiet

Answer 1

You may do the contour plot for expr3 (instead of expr3==0), then use a region function to pick out the zero line, using 1 contour to just draw the boundary. The fill color is done via ContourShading, like this:

b = Function[{p1, p2}, Numerator@expr3 // Evaluate];
ContourPlot[Numerator@expr3, {p1, 0.5, 1}, {p2, 0.5, 1}, 
  MaxRecursion -> 5, FrameLabel -> {p1, p2}, Contours -> 1, 
  RegionFunction -> Function[{x, y, z}, b[x, y] < 0]] // Quiet

To close off at the {1,1} point, you may try changing MaxRecursion or PlotPoints. To get a quick result, I've set MaxRecursion to 1:

ContourPlot[Numerator@expr3, {p1, 0.5, 1}, {p2, 0.5, 1}, 
  MaxRecursion -> 1, PlotPoints -> 60, FrameLabel -> {p1, p2}, 
  Contours -> 1, RegionFunction -> Function[{x, y, z}, b[x, y] < 0], 
  ContourShading -> {Blue}] // Quiet

To get a smoother boundary, try larger MaxRecursion or PlotPoints.

Edit

To change the contour fill/line style for this plot, one way to get around the contour lines being not smooth/easy to see, plot one without the outline, just the fill color; plot another that shows just the outline, then Show them together, like this:

p0 = ContourPlot[Numerator@expr3, {p1, 0.5, 1}, {p2, 0.5, 1}, 
   PlotPoints -> 50, FrameLabel -> {Subscript[p, 1], Subscript[p, 2]},
    Contours -> 1, RegionFunction -> Function[{x, y, z}, b[x, y] < 0],
    ContourShading -> {RGBColor[223/255, 230/255, 240/255]}, 
   ContourStyle -> None] // Quiet
p1 = ContourPlot[Numerator@expr3 == 0, {p1, 0.5, 1}, {p2, 0.5, 1}, 
   PlotPoints -> 50, 
   ContourStyle -> RGBColor[0.368417, 0.506779, 0.709798]] // Quiet
Show[p0, p1]