11
$\begingroup$

Say I have a series of points that make a straight line... (Fig 1)

points = {{0, 0, 0}, {1, 0, 0}, {2, 0, 0}, {3, 0, 0}, {4, 0, 0}, {5, 0, 0}}

I can rotate these points about the Z axis using a RotationTransform. (Fig 2)

r = RotationTransform[10 Degree, {0, 0, 1}]
r[points]

However, if I wanted to make the line curl, with each point rotating by a relative 10 Degrees to the point next to it, how would I map the RotationTransform across the list please? (Fig 3)

enter image description here

EDIT: An important thing to note is that the relative distance between each segments should remain constant at 1 unit after the rotations. I could have made this clearer above apologies.

$\endgroup$
  • 1
    $\begingroup$ An aside: instead of typing out a list of regularly spaced vectors along the x-axis, consider pts = Array[{#, 0, 0} &, 5]; $\endgroup$ – m_goldberg Oct 24 '14 at 3:19
  • $\begingroup$ Thanks for the suggestion, I normally use table so good to see a neater way of doing this... $\endgroup$ – ASBO Allstar Oct 24 '14 at 13:43
13
$\begingroup$

Rotation about the origin

MapIndexed[N@Nest[r, #1, First[#2-1]] &, points]
{{0., 0., 0.}, {0.984808, 0.173648, 0.}, {1.87939, 0.68404, 0.}, {2.59808, 1.5, 0.}, {3.06418, 2.57115, 0.}, {3.21394, 3.83022, 0.}}
ListPlot[%[[All, {1, 2}]]]

Mathematica graphics

the norm of the vectors is conserved.

Rotation about the last point

Ok, with the new request, rotating with respect of the last point

Accumulate@Prepend[MapIndexed[N@Nest[r, #1, First[#2]] &, Differences@points],First[points]]
{{0, 0, 0}, {0.984808, 0.173648, 0.}, {1.9245, 0.515668, 0.}, {2.79053, 1.01567, 0.}, {3.55657, 1.65846, 0.}, {4.19936, 2.4245, 0.}}
ListPlot[Accumulate@
  Prepend[MapIndexed[N@Nest[r, #1, First[#2]] &, Differences@points], 
    First[points]][[All, {1, 2}]], AspectRatio -> 1, 
 PlotRange -> {{0, 5}, {0, 5}}, Frame -> True]

Mathematica graphics

the norm of the difference between consecutive vectors is conserved.

Some fun

points2 = Array[{#, 0} &, 100];
anim = Table[
   ListLinePlot[
    Accumulate@
     Prepend[MapIndexed[
       N@Nest[RotationTransform[x Degree], #1, First[#2]] &, 
       Differences@points2], First[points2]]
    , AspectRatio -> 1
    , PlotRange -> {{-50, 100}, {-50, 100}}
    ], {x, 0, 4, 0.1}];
Export["curl.GIF", anim]

enter image description here

$\endgroup$
  • $\begingroup$ +1, but will say Nest makes it a (exp?) slow algorithm. For 30 points, it's been (still) running for a few minutes. Also, seems to trace a spiral, is that expected from constant angle? $\endgroup$ – alancalvitti Oct 25 '14 at 17:22
  • $\begingroup$ @alancalvitti, Definitely Nest is not an efficient way, I was just trying to build from the already defined r function using small and simple code. The shape is not a spiral, but the arc of a circle. $\endgroup$ – rhermans Oct 25 '14 at 17:35
  • $\begingroup$ Have you tried your method on 20 points or so? Looks like a spiral. N and accumulating error? $\endgroup$ – alancalvitti Oct 25 '14 at 17:53
  • $\begingroup$ @alancalvitti The animation is with 100 points. If it looks like a spiral to you, please post a link to an image. $\endgroup$ – rhermans Oct 25 '14 at 19:12
  • $\begingroup$ @rhermans: You have animated Euler-Bernoulli Law. An elastic line curvature in proportion to the bending moment M. However my output shows all frames but no continuous action. Ctrl-Y on the group does not work. $\endgroup$ – Narasimham Feb 12 '15 at 12:32
7
$\begingroup$

The easiest way to think about it is to iteratively bend the "line" of points as the program "moves" down the list. "Moves" is accomplished with Rest. The result regrettably has extra data that needs to be discarded, which is done with the ...[[All, 1]] bit of code.

rot = N@NestList[
    Rest@RotationTransform[10 Degree, {0, 0, 1}, #1[[1]]][#1] &, 
    points, Length[points] - 1][[All, 1]]
(* {{0., 0., 0.}, {0.984808, 0.173648, 0.}, {1.9245, 0.515668, 0.},
    {2.79053, 1.01567, 0.}, {3.55657, 1.65846, 0.}, {4.19936, 2.4245, 0.}} *)

Check the output:

VectorAngle @@@ Partition[Differences[rot], 2, 1]
EuclideanDistance @@@ Partition[Differences[rot], 2, 1]
(* {0.174533, 0.174533, 0.174533, 0.174533}
   {0.174311, 0.174311, 0.174311, 0.174311} *)

10. Degree
(* 0.174533 *)

Update: Same idea, but with TranslationTransform serving to move the position down the line of points and no extra data:

N@FoldList[
  Composition[
     RotationTransform[10 Degree, {0, 0, 1}],
     TranslationTransform[#2]][#1] &,
  First[points],
  Differences[points]]
$\endgroup$
4
$\begingroup$

Some days ago,I look at a python's module called turtle.And I think weather we can simulate the behavier of some functions in turtle.

First,I define some pre-function:

initial[position_, th_] :=  
Module[{θ = th, pos = position}, 
left := Function[theta, θ = θ + theta];
right := Function[theta, θ = θ - theta];
forward := 
Function[r, pos = pos + r*{Cos[θ], Sin[θ]}; 
Sow[pos];]];  

Or use the faster version for pre-function:

initial[position_, th_] := 
Module[{θ = th, pos = position}, 
left  :=  θ += # &;
right :=  θ -= # &;
forward := (pos += #*{Cos[θ], Sin[θ]};
Sow[pos];) &];

And then,I use the following code:

points = {{0, 0}, {1, 0}, {2, 0}, {3, 0}, {4, 0}, {5, 0}};
(* calculate the distance between these points *)
pre = Norm /@ Differences[points];
pos = First@points; θ = 0;       (*  initial conditions  *)
initial[pos, θ];(* use the initial function to set the conditions *)
point = Reap[Do[forward[pre[[i]]]; left[10 Degree], {i, 1, Length@pre}]][[2, 1]];
ListLinePlot[point /. {a__} -> {pos, a}, Mesh -> All]

enter image description here

Ok! Done...

Using this code to draw Koch curve maybe easy: (the mechanism can look at the site Recursion about Drawing Fractals)

Koch[order_, size_] := 
If[order == 0, forward[size], Koch[order - 1, size/3]; left[Pi/3];
Koch[order - 1, size/3]; right[2 Pi/3];
Koch[order - 1, size/3]; left[Pi/3]; Koch[order - 1, size/3];];
(*if order is 6,the graphics can be draw like this*)
initial[{0, 0}, 0]; (*  initial conditions  *)
point = Reap[Koch[6, 3]][[2, 1]];
Graphics[Line[point /. {a__} -> {{0, 0}, a}]]

enter image description here

$\endgroup$
  • 1
    $\begingroup$ AppendTo becomes increasingly slow as the length of l increases. For performance you should consider refactoring this to use Sow and Reap or at least linked lists instead. +1 nevertheless. $\endgroup$ – Mr.Wizard Feb 12 '15 at 7:11
  • $\begingroup$ @Mr.Wizard Thank you for your suggestions.Now,well done!I use Sow and Reap instead of AppendTo and I use local variables instead of globe variables. $\endgroup$ – partida Feb 12 '15 at 9:06
3
$\begingroup$

if you want to maintain the original distances between points I would also suggest the following:

points1 = 
  points = Most /@ {{0, 0, 0}, {1, 0, 0}, {2, 0, 0}, {3, 0, 0}, {4, 0,
       0}, {5, 0, 0}};
l = Length[points]; n = 1; While[n++; n <= l ,
 points[[n ;;]] = 
  RotationTransform[10 Degree, points[[n - 1]]][#] & /@ points[[n ;;]]];
ListPlot[{points1, points}]

enter image description here

$\endgroup$
  • $\begingroup$ Yes maintaining the same distance between the points is important as this shows how a series of straight links curls and is closer to what I wanted to achieve. Thanks. $\endgroup$ – ASBO Allstar Oct 24 '14 at 13:47
2
$\begingroup$

Here is another approach (to simplify i give a 2D solution - your problem is in 2D - but it can be easily extended in 3D) :

(* the coordinates of the first point *)
ori = {0, 0};

(* the initial angles between the succesive points *)
angles = {0, 0, 0, 0}

(* the function to build the coordinates from the angles *)
mkpts[ang_] := FoldList[(#1 + {Cos@#2, Sin@#2}) &, ori, Rest@FoldList[Plus, 0, ang]];

Some examples:

1/The initial straight line :

ListPlot[mkpts[angles], AspectRatio -> Automatic]

2/ 10 degrees relative rotation

ListPlot[mkpts[angles + 10. Degree], AspectRatio -> Automatic]

3/ For anything else you just define the angles :

ListPlot[mkpts[angles + {45, -45, -90, 90} Degree], AspectRatio -> Automatic]
$\endgroup$
0
$\begingroup$

Since AnglePath[] is now built-in, here's a rather compact Manipulate[] for curling points:

Manipulate[Graphics[Line[AnglePath[N[ConstantArray[ϕ, n]]]], 
                    Frame -> True, PlotRange -> n],
           {{n, 2, "segments:"}, 2, 10, 1},
           {{ϕ, 0, "angle:"}, Experimental`AngularSlider[Dynamic[ϕ]] &}, 
           ControlPlacement -> Right]

curling points

$\endgroup$

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.