graphs and networks – Connecting simple lines from (large) unsorted list of points defining crossing curves


As a Follow up of this question and both nice answers
given there, I am after an algorithm which could trace the two curves
as they cross

enter image description here

We are trying to predict the formation of discs of intermediate mass black hole orbiting super massive black holes in galactic centres.
This involves finding calorific curves in energy and angular momentum space.


I am trying to identify sets of curves from a (very large) sets of points in order to produce a lighter figure.

For instance I want to be able to redo such figure, but with less points (without loosing the poorly sampled lines).

enter image description here

The challenge is that these points are found by some complex optimisation routine
and are over-numerous in places. So by lighter figure, I mean remove sets of point very close to each other while keeping more sparsely sampled points in order to draw curves
through them. Note importantly that the curves cross.


How can one achieve this simultaneous downsampling and curve matching procedure?


Let me define a toy problem as follows: let me produce two curves:

data = Flatten({Table({x, Sin(x^2/15)}, {x, 0, 20, 0.01}),
    Table({x, 1 + Cos(x)}, {x, 0, 20, 0.1})}, 1);

and draw random points from those. Note that the offset is now 1 not 2!

pts = RandomChoice(data, Length(data));


enter image description here

Note again that on purpose the sampling is not the same for the two curves.

Following this (otherwise excellent) answer I can get a good resampling as follows:

tour = Last(FindShortestTour(pts));
tourPts = Extract(pts, List /@ tour);
peaks = Ordering(EuclideanDistance @@@ Partition(tourPts, 2, 1), -2);
{firstCurve, secondCurve} = 
  TakeDrop(RotateLeft(tourPts, peaks((1))), Abs(Subtract @@ peaks));

np(f_)(u_, dt_) := u + dt/Norm(f'(u))
equallySpacedPts(pts_, dt_) := 
 With({bsf = BSplineFunction(pts)}, 
  bsf /@ Most(NestWhileList(np(bsf)(#, dt) &, 0, # < 1 &)))

equallySpacedPts(#, 0.25) & /@ {firstCurve, secondCurve} // ListLinePlot

BUT It is clear that the two curves are not (always) properly matched, e.g. near x=10.

enter image description here

I understand that this is not a trivial matter, but it should be of general interest for mathematica to be able to stand up to this challenge (?).