Creating a certain image (3D shadows, highlighted intersections)

Question

I would like to learn how to code within Mathematica the following picture:

I tried using

planarShadow[x_, direction_, normal_, darkShadow_: True] := 
 Module[{d, n}, d = Normalize[direction];
  n = Normalize[normal];
  x /. Graphics3D[gr_, opts___] :> 
    Graphics3D[{If[darkShadow, Black], 
      GeometricTransformation[
       If[darkShadow, 
        gr /. {Glow[_] -> Glow[], 
          r_?(MemberQ[{RGBColor, Hue, CMYKColor, GrayLevel}, 
               Head[#]] &) -> Black}, gr], 
       Composition[TranslationTransform[direction], 
        Quiet[RotationTransform[{d, n}], {RotationMatrix::degen, 
          RotationTransform::spln}], ScalingTransform[10^-3, d], 
        Quiet@Check[ScalingTransform[1./(n.d), n - (n.d) d], 
          Identity]]]}, opts]]

With[{cp3d = 
   ParametricPlot3D[{{u - 2, u^2, u^3}, {-u + 1, (1/2) u - 4, 
       u^2}, {Sin[u - 0.5], 2 u - 2, (1/10) u^3}, {u - 5, u, u}, {-u, 
       u + 2.5, -u}}, {u, -4, 4}, 
     PlotStyle -> {Orange, Green, Yellow, Blue, Purple}, 
     PlotRange -> {-4, 4}] /. 
    Line[pts_, rest___] :> Tube[pts, 0.4, rest]},
 Show[cp3d, planarShadow[cp3d, {0, 0, -4.97}, {0, 0, -1}, True], 
  PlotRange -> {-5, 5}]]

and got a fairly inadequate comparison.

Any help would be appreciated.

Answer 1

Let us draw some random smooth curves:

pts = 4;
curves = 3;
SeedRandom[9];
f = Table[
   Interpolation[Table[{t, RandomReal[1, {3}]}, {t, 0, 1, 1/pts}], 
    Method -> "Spline"], {curves}];
plot = ParametricPlot3D[
  Evaluate@Table[f[[i]][t], {i, curves}], {t, 0, 1}, 
  PlotPoints -> 300, MaxRecursion -> 0, PlotRange -> All, 
  PlotRangePadding -> 0.05]

After post-processing:

r = 0.020;
r2 = 1.3 r;
range = {{x1, x2}, {y1, y2}, {z1, z2}} = Charting`get3DPlotRange@plot;
shadows = Show[plot /. Line[pts_] :> {Black, Opacity[0.1], Tube[pts, r]}, 
  Lighting -> {{"Ambient", White}}, ViewPoint -> {0, 0, ∞}, 
  Boxed -> False, Axes -> False, PlotRange -> range];
img = ImageResize[Colorize[Rasterize[shadows, ImageSize -> 900], 
    ColorFunction -> (Hue[-# - 1/3, 1 - #^2] &)], Scaled[1/3]];
res = Show[Graphics3D[{EdgeForm[], Opacity[0.75], Texture[img], 
     Polygon[{{x1, y1, z2}, {x1, y2, z2}, {x2, y2, z2}, {x2, y1, z2}},
       VertexTextureCoordinates -> {{0, 0}, {0, 1}, {1, 1}, {1, 0}}]}], plot /. 
    Line[pts_] :> {Tube[pts, r], FaceForm[Opacity[0], Glow[White]], 
      Tube[pts, r2]}, Lighting -> {{"Ambient", White}}, PlotRange -> range];
Style[Row@{img, res}, ImageSizeMultipliers -> {1, 1}]

Post-processing consists of two separate parts:

2D shadows

The main idea is to render gray curves with opacity and colorize the result with appropriate color function. For better quality I generate a big raster and scale it down to increase antialisaing. The shadow looks strange near sharp turns, but it is not possible to avoid this if you highlight self-intersections.

3D curves

White outlines is a thicker copy of curves, which is transparent outside and white inside (see Rahul's answer here or my answer here). Curves are flattened with Lighting -> {{"Ambient", White}}. I also use Charting`get3DPlotRange to automatically obtain plot range (see here). You can put some fixed values there.