Skip to main content
Mathematica

Return to Answer

Post Timeline

added 1551 characters in body
Source Link
azerbajdzan
azerbajdzan
  • 36.4k
  • 2
  • 32
  • 81

Update:

@C.K wanted to see the thickness of the region (see his comment).

The thickness is depicted by slicing the region with planes c=1, c=0.9, ... c=0 for step s=0.1.

The first image is for s=1/10, the second image for s=1/100.

In the code we have to take care of special limit case c=1 - hence the Which and special limit case c=0 - hence the Append.

s = 1/10;
plots = Append[
   Table[ContourPlot[
     Which[c == 1, {v == (2 - 2 a)/(2 - a), v == 1 - a}, 
       True, {v == (
         a^2 - 2 a c - a^2 c + c^2 + c^3)/(-a c + c^2 + c^3), 
        v == Root[
          a^3 - 2 a^2 c - a^3 c + a c^2 + 2 a^2 c^2 - 
            a c^3 + (-2 a^3 + 5 a^2 c + a^3 c - 4 a c^2 - 2 a^2 c^2 + 
               c^3 + a c^3) #1 + (a^2 - a^3 - a c - 3 a^2 c + a^3 c + 
               5 a c^2 - 2 c^3) #1^2 + (-a^2 + a c + a^2 c - 2 a c^2 +
                c^3) #1^3 &, 2]}] // Evaluate, {v, 0, 1}, {a, 0, c}, 
     ContourStyle -> Blend[ColorData[97] /@ {1, 4}, c], 
     PlotPoints -> 50], {c, 1, s, -s}], 
   ContourPlot[a == 0, {v, 0, 1}, {a, -0.01, 1}, 
    ContourStyle -> Blend[ColorData[97] /@ {1, 4}, 0], 
    PlotPoints -> 50]];

Show@plots

Manipulate[
 Show[plots[[n]], PlotRange -> {0, 1}], {n, 1, Length[plots], 1}]

enter image description here

enter image description here

Update:

@C.K wanted to see the thickness of the region (see his comment).

The thickness is depicted by slicing the region with planes c=1, c=0.9, ... c=0 for step s=0.1.

The first image is for s=1/10, the second image for s=1/100.

In the code we have to take care of special limit case c=1 - hence the Which and special limit case c=0 - hence the Append.

s = 1/10;
plots = Append[
   Table[ContourPlot[
     Which[c == 1, {v == (2 - 2 a)/(2 - a), v == 1 - a}, 
       True, {v == (
         a^2 - 2 a c - a^2 c + c^2 + c^3)/(-a c + c^2 + c^3), 
        v == Root[
          a^3 - 2 a^2 c - a^3 c + a c^2 + 2 a^2 c^2 - 
            a c^3 + (-2 a^3 + 5 a^2 c + a^3 c - 4 a c^2 - 2 a^2 c^2 + 
               c^3 + a c^3) #1 + (a^2 - a^3 - a c - 3 a^2 c + a^3 c + 
               5 a c^2 - 2 c^3) #1^2 + (-a^2 + a c + a^2 c - 2 a c^2 +
                c^3) #1^3 &, 2]}] // Evaluate, {v, 0, 1}, {a, 0, c}, 
     ContourStyle -> Blend[ColorData[97] /@ {1, 4}, c], 
     PlotPoints -> 50], {c, 1, s, -s}], 
   ContourPlot[a == 0, {v, 0, 1}, {a, -0.01, 1}, 
    ContourStyle -> Blend[ColorData[97] /@ {1, 4}, 0], 
    PlotPoints -> 50]];

Show@plots

Manipulate[
 Show[plots[[n]], PlotRange -> {0, 1}], {n, 1, Length[plots], 1}]

enter image description here

enter image description here

Source Link
azerbajdzan
azerbajdzan
  • 36.4k
  • 2
  • 32
  • 81

A better equality plots.

Expression for eq and r are taken from OP code and then they are used to make equations in a slightly different form. The equations are used in ContourPlot3D instead of RegionPlot3D used in OP.

eq = v == (-a^2 + 2 a c + a^2 c - c^2 - c^3)/(a c - c^2 - c^3);

r = Root[a^2 - a c - a^2 c + 2 a c^2 - 
     c^3 + (-a^2 + a^3 + a c + 3 a^2 c - a^3 c - 5 a c^2 + 
        2 c^3) #1 + (2 a^3 - 5 a^2 c - a^3 c + 4 a c^2 + 2 a^2 c^2 - 
        c^3 - a c^3) #1^2 + (-a^3 + 2 a^2 c + a^3 c - a c^2 - 
        2 a^2 c^2 + a c^3) #1^3 &, 3];

nr = Root[r[[1]]@(1/x) // Factor // Numerator, x, 2];

eq1 = a == 
   SolveValues[
     v == (-a^2 + 2 a c + a^2 c - c^2 - c^3)/(a c - c^2 - c^3), 
     a][[2]];
eq2 = v == nr;

ContourPlot3D[Evaluate@eq1, {v, 0, 1}, {c, 0, 1}, {a, 0, 1}]
ContourPlot3D[Evaluate@eq2, {v, 0, 1}, {c, 0, 1}, {a, 0, 1}]
Show[%%, %]

enter image description here