7
$\begingroup$

Problem

I'm interested in an efficient way to render a scaled segment of a Line[pts], for given t ( (0,1] ).

'Show some effort'

So something like GraphUtilities`LineScaledCoordinate but instead of point I'd like to draw a line from the line beginning up to that point:

Needs["GraphUtilities`"]

vertices = {{0, 0}, {1, 0}, {1, 3}, {2, 3}};

LabeledSlider[Dynamic@t]

Graphics[
  { Thick, Line@vertices
  , AbsolutePointSize@12, Blue, Dynamic[Point[LineScaledCoordinate[N@vertices, t]]]
  }
, Frame -> True
]

enter image description here

I am aware of Generating evenly spaced points on a curve but I want precise solution. Interpolation from equally spaced points can miss original pts.

Requirements

  • efficient, e.g. example above for ~1k points with LineScaledSegment can't be laggy

  • exact segment, not a fine mesh of equally spaced points, it will scale badly and miss original vertices anyway


This does not sound like a very hard problem but I'd like to spend time on something else, the more that I feel it is solved internally and it would be nice not to reinvent the wheel.

$\endgroup$
2
$\begingroup$

Modifying Kuba's code using Interpolation it seems maybe (??) to work faster...

coord=RandomReal[10,{10^3,2}];
dist=Map[Norm,Drop[coord+-RotateLeft[coord],-1]];
total=Total@dist;
DivideBy[dist,total];
dist2=FoldList[Plus,0,dist];
ff=Interpolation[Thread@{dist2,Range@Length@dist2},InterpolationOrder->0];
fxy=Interpolation[Thread@{dist2,coord},InterpolationOrder->1];

then

LabeledSlider[Dynamic@t]

Graphics[{Line@coord, Thick, Red, 
  Line@Dynamic@Append[coord[[;; IntegerPart[ff[t]] - 1]], fxy[t]]}, 
 PlotRange -> {{0, 10}, {0, 10}}]

Blockquote

$\endgroup$
2
$\begingroup$

Method 1, old code tweak

LineScaledCoordinate is not ReadProtected so I took and changed two lines:

LineScaledSegment[coord_?MatrixQ, rr0_] := Module[
      {dist, dist2, sta, sto, newpos, total, rr = rr0}
    , If[SameQ[coord, {}], Return[{}]]
    ; If[Equal[Length @ coord, 1], Return[coord[[1]]]]
    ; If[Greater[rr, 1], rr = 1]
    ; If[Less[rr, 0], rr = 0]
    ; dist = Map[Norm, Drop[coord + -RotateLeft[coord], -1]]
    ; total = Total @ dist
    ; If[LessEqual[total, $MachineEpsilon], Return[coord[[1]]]]
    ; DivideBy[dist, total]
    ; dist2 = FoldList[Plus, 0, dist]
    ; Part[dist2, Length[dist2]] = 1.
    ; sto = Part[
        Flatten[
          Position[dist2, PatternTest[_, GreaterEqual[#, rr] &]]
         ]
       , 1
       ]
    ; If[Equal[sto, 1], Return[ coord[[{1, 1}]]]] (*1 -> {1,1}*)
    ; sta = sto - 1
    ; newpos = Plus[coord[[sta]]
       , Divide[
          (rr + -Part[dist2, sta]) * (Part[coord, 
         sto] + -Part[coord, sta])
         , Part[dist2, sto] + -Part[dist2, sta]
         ]
       ]
    ; Append[coord[[;; sto - 1]], newpos] (*previously just newpos*)
    ]

path2 = RandomReal[10, {10^3, 2}];

t = 0;
LabeledSlider@Dynamic@t
Graphics[{
  Line@path2, Thick, Red,
  Line@Dynamic@LineScaledSegment[path2, t]
  }, ImageSize -> 500]

enter image description here

$\endgroup$
1
$\begingroup$

I hope I didn't misunderstand your question. As I see it, you have the arc length directly accessible because you have points with lines in between. This means the Norm between two points gives you the length of this section.

Here an example with increasing line lengths between the points

vertices = Table[{x, x*Sin[Pi x/2]}, {x, 0, 10}];
ListLinePlot[vertices]

Mathematica graphics

Using Accumulate, Partition, and Norm, you can create a list of the total so-far length in each point, where we prepend a zero at the front. Since we are not interested in the total length, we can divide this by the Total to get a list that starts with 0 and ends with 1 and all other values in the list represents the fraction of the "curve"-length we have already visited:

accum = Accumulate[#]/Total[#] &@
  Prepend[Norm[Subtract @@ #] & /@ Partition[vertices, 2, 1] , 0]

Funny enough, for this discrete list, this is already our arc length parametrization and we only need to feed it into a linear interpolation, where accum is our s(t) in the usual sense

ipp = Interpolation[Transpose[{accum, vertices}], InterpolationOrder -> 1]

I hope I didn't make some stupid mistake, but that be all you need

Manipulate[
 Graphics[{
   Line[vertices],
   Blue, PointSize[0.03],
   Point[ipp[t]],
   PointSize[0.01],
   Red,
   Point@Table[ipp[tt], {tt, 0, t, .02}]
   }],
 {t, 0, 1}
 ]

Mathematica graphics

Since all you need is one linear interpolating function, this works reasonably fast even for many points.

Appendix

As explained in the comments, you can create a function that gives you the points for drawing the lines for an arbitrary t. Count how many entries in accum are <t. You simply want to include those first n points from your vertices. The last point, which is in the middle of two vertices can be calculated using the interpolating function.

vertices = Table[{x, x*Sin[Pi x/2]}, {x, 0, 10}];
create[points_] := With[{
   pts = N[points], 
   accum = Accumulate[#]/Total[#] &[Prepend[Norm /@ Differences[N[points]], 0]]
  },
  With[{ip = Interpolation[Transpose[{accum, pts}], InterpolationOrder -> 1]},
   Function[t, Module[{p = pts, acc = accum},
     Which[
      t <= 0,
      p[[{1}]],
      t >= 1,
      p,
      True,
      Append[Pick[p, Negative[acc - t]], ip[t]]
      ]
     ]
    ]
   ]
  ]

Then you can use

f = create[vertices];

Manipulate[
 Graphics[
  {Line[vertices],
   Red, Thick,
   Line[f[t]]
   }],
 {t, 0, 1}
]
$\endgroup$
  • $\begingroup$ But how to quickly draw the line too? Feeding tthis to ParametricPlot should probably be avoided. $\endgroup$ – Kuba Oct 12 '17 at 6:06
  • $\begingroup$ @Kuba If you want to draw it to t1: Select from accum the first position p which is >t1. You simply want to include all points but the last vertices up to p. Then, you need to make one small function drawing the fraction of vertices[[{p-1, p}]] regarding what's left using accum[[p]]-t1. It comes down to render a line with p points. Should I give an example? $\endgroup$ – halirutan Oct 12 '17 at 13:25
  • $\begingroup$ I know, it is not a rocket science but that was the question :) how to render this segment. So my point was, the answer is incomplete. $\endgroup$ – Kuba Oct 12 '17 at 15:54
  • $\begingroup$ I only see the interesting parts: "Line Scaled Segment or Arc length parametrization for Line" :) I see if I find some minutes tonight to clear this up and provide a function for everything. $\endgroup$ – halirutan Oct 12 '17 at 16:05
  • $\begingroup$ So 'segment' not a point :) arc length parametrized position is given by LineScaledCoordinate anyway. Thanks and no hurry of course. $\endgroup$ – Kuba Oct 12 '17 at 17:31
0
$\begingroup$

I don't know the reason, it not very sync with your blue point

vertices = {{0, 0}, {1, 0}, {1, 3}, {2, 3}};

LabeledSlider[Dynamic@t]

Dynamic[Show[
  Graphics[{Thick, Line@vertices, AbsolutePointSize@12, Blue, 
    Point[LineScaledCoordinate[N@vertices, t]]}, Frame -> True], 
  ParametricPlot[
   BSplineFunction[vertices, SplineDegree -> 1][pos], {pos, 0, t}, 
   PlotStyle -> Directive[Thickness[.02], Red]]]]

enter image description here

$\endgroup$
  • $\begingroup$ because each segment in bsf takes 1/numberOfSegments instead of being rescaled by its length. $\endgroup$ – Kuba Oct 11 '17 at 19:49
  • $\begingroup$ @Kuba So it is not your after? $\endgroup$ – yode Oct 11 '17 at 19:49
  • $\begingroup$ nope, it is not. I need arc length parametrization $\endgroup$ – Kuba Oct 11 '17 at 19:51

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.