Identifying the intersection between a ConditionalExpression and a parametric curve

Question

I'm trying to determine the intersection of lines over a surface (if they exist). My problem is that one of the lines is defined as a conditional expression and for the others I only have a parametric description. In particular, I have two surfaces and I've represented their intersection as the red line. This is the conditional expression

{{q[2] -> ConditionalExpression[Sqrt[8 - 3 q[1]^2]/Sqrt[2], 0 < q[1] < 2 Sqrt[2/3]], 
q[3] -> ConditionalExpression[Sqrt[1 + q[1]^2]/Sqrt[2], 0 < q[1] < 2 Sqrt[2/3]]}}

What I'd like to do is to identify the points where the blue and the green lines cross the red line. Both the blue and the green lines go through those points on the surface where one of the slopes is -1 and I've probably gone through too much of a hassle to draw them. Be it as it may, the best I've been able to do is a parametric plot, so I'm not sure how to proceed to obtain their intersections with the red line.

My code is

ClearAll["Global`*"]
X = {{1, 4}, {2, 4}, {4, 4}};
qVec = Array[q, 3];
kVec = {10, 18};
a = 1/2;
needs = Transpose[X].qVec^(1/a);
max = Table[(Min[kVec[[1]]/X[[i, 1]], kVec[[2]]/X[[i, 2]]])^a, {i, 1, 3}];

(*This defines the surfaces*)
con = Table[ContourPlot3D[needs[[i]] == kVec[[i]], {q[1], 0, (kVec[[i]]/X[[1, i]])^a}, {q[2], 0, (kVec[[i]]/X[[2, i]])^a}, {q[3], 0, (kVec[[i]]/X[[3, i]])^a}, Mesh -> None], {i, 1, 2}];

(* This defines the intersection of the surfaces (red line)*)
inter = ParametricPlot3D[qVec /. Solve[Flatten[{needs == kVec, Thread[qVec >= 0]}], 
  Rest@qVec, Reals] // Evaluate, {q[1], 0, max[[1]]}, PlotStyle -> Red];

(* This defines the green and blue lines*)
lines = Table[
  sol = Solve[D[needs[[j]], q[3]] == D[needs[[j]], q[i]], q[3]][[1]];
  f3 = (q[3] /. sol) /. {q[1] -> x, q[2] -> x};
  f2 = If[i == 1, ((q[3 - i] /. SortBy[Re@*Last]@Solve[needs[[j]] == kVec[[j]], q[3 - i]][[2]]) /. sol) /. q[1] -> x, x];
  f1 = If[i == 1, x, ((q[3 - i] /. SortBy[Re@*Last]@Solve[needs[[j]] == kVec[[j]], q[3 - i]][[2]]) /. sol) /. q[2] -> x];
  Solve[If[i == 1, f2 == 0, f1 == 0]];
  m = x /. SortBy[Re@*Last]@Solve[If[i == 1, f2 == 0, f1 == 0]][[2]];
  ParametricPlot3D[{f1, f2, f3}, {x, 0, m}, PlotStyle -> If[j == 1, Blue, Green]], {j, 1, 2}, {i, 1, 2}];

 (*This shows the image I've included above*)
  Table[Show[{con[[i]], lines[[i, All]], inter}], {i, 1, 2}]

Feel free to comment on any other aspect of the code. Thanks

Answer 1

By creating parametric regions instead of parametric plots, you can use Solve to find the intersection points.

The conditional expression for the red line is valid for q[1] up to 2 Sqrt[2/3], so use that value as the upper range of q[1] in the parametric region, using quantities defined in your code:

 redLine = 
 ParametricRegion[
  First[Normal /@ (qVec /. 
      Solve[Flatten[{needs == kVec, Thread[qVec >= 0]}], Rest@qVec, 
       Reals])], {{q[1], 0, 2 Sqrt[2/3]}}]

Similarly modify your code to use ParametricRegion instead of ParametricPlot3D to make the blue and green lines into regions:

{blueLines, greenLines} = 
 Table[sol = 
   Solve[D[needs[[j]], q[3]] == D[needs[[j]], q[i]], q[3]][[1]];
  f3 = (q[3] /. sol) /. {q[1] -> x, q[2] -> x};
  f2 = If[
    i == 
     1, ((q[3 - i] /. 
         SortBy[Re@*Last]@
          Solve[needs[[j]] == kVec[[j]], q[3 - i]][[2]]) /. sol) /. 
     q[1] -> x, x];
  f1 = If[i == 1, 
    x, ((q[3 - i] /. 
         SortBy[Re@*Last]@
          Solve[needs[[j]] == kVec[[j]], q[3 - i]][[2]]) /. sol) /. 
     q[2] -> x];
  Solve[If[i == 1, f2 == 0, f1 == 0]];
  m = x /. SortBy[Re@*Last]@Solve[If[i == 1, f2 == 0, f1 == 0]][[2]];
  ParametricRegion[{f1, f2, f3}, {{x, 0, m}}], {j, 1, 2}, {i, 1, 2}]

Intersection of red and blue lines:

  bluePts = Solve[pt \[Element] RegionUnion @@ blueLines \[And] 
  pt \[Element] redLine, pt]

which gives

{{pt -> {2/Sqrt[7], Sqrt[22/7], Sqrt[11/14]}}}

Visualize the lines and their intersection:

Show[Region[Style[RegionUnion @@ blueLines, Blue, Thick]], 
 Region[Style[redLine, Red, Thick]],
 Graphics3D[
  Style[Point[pt /. # & /@ bluePts], PointSize[Large], Black]]
 ]

Similarly for intersection with the green lines:

greenPts = 
 Solve[pt \[Element] RegionUnion @@ greenLines \[And] 
   pt \[Element] redLine, pt]

which gives

{{pt -> {1, Sqrt[5/2], 1}}, {pt -> {Sqrt[7]/2, Sqrt[11/2]/2, Sqrt[11/
    2]/2}}}

with visualization

Show[Region[Style[RegionUnion @@ greenLines, Green, Thick]], 
 Region[Style[redLine, Red, Thick]],
 Graphics3D[
  Style[Point[pt /. # & /@ greenPts], PointSize[Large], Black]]
 ]