
Straight line merging to profile
By:
Matthen on Jan 18th, 2012 | syntax:
None | size: 1.39 KB | hits: 118 | expires: Never
pts={{0.146, -0.422}, {0.13, -0.406}, {0.118, -0.378}, {0.098, -0.35}, \
{0.086, -0.318}, {0.058, -0.31}, {0.01, -0.306}, {-0.03, -0.294}, \
{-0.058, -0.278}, {-0.078, -0.258}, {-0.07, -0.234}, {-0.074, \
-0.222}, {-0.082, -0.21}, {-0.086, -0.194}, {-0.07, -0.178}, {-0.086, \
-0.17}, {-0.094, -0.142}, {-0.094, -0.118}, {-0.098, -0.106}, \
{-0.118, -0.09}, {-0.134, -0.074}, {-0.118, -0.042}, {-0.106, \
-0.014}, {-0.09, 0.002}, {-0.09, 0.014}, {-0.094, 0.038}, {-0.106,
0.05}, {-0.102, 0.074}, {-0.098, 0.094}, {-0.094, 0.122}, {-0.098,
0.146}, {-0.094, 0.166}, {-0.098, 0.19}, {-0.086, 0.218}, {-0.07,
0.238}, {-0.05, 0.254}, {-0.026, 0.27}, {0.002, 0.278}, {0.034,
0.278}, {0.07, 0.286}, {0.098, 0.278}};
Clear[line];
line[0] =
Table[{0, i}, {i, -0.422, 0.286, (0.286 + 0.422)/41 + 0.0001}];
line[n_] :=
line[n] =
SortBy[Map[# + {0.01, 0} &, line[n - 1]] +
RandomReal[NormalDistribution[0, 0.002], Dimensions[line[0]]],
Last];
Clear[prof];
prof[0] = Map[{1.5, 0} + # &, pts];
prof[n_] :=
prof[n] =
SortBy[Map[# - {0.01, 0} &, prof[n - 1]] +
RandomReal[NormalDistribution[0, 0.002], Dimensions[prof[0]]],
Last];
merge[n_] := (1 - n/140) line[n] + n/140 prof[140 - n];
frame[n_] := Graphics[{
Table[BezierCurve@MovingAverage[merge[i], 2], {i, 0, Floor[n]}]
}, PlotRange -> {{0, 1.7}, {-0.43, 0.3}}];
Manipulate[frame[n],{n,1,140,1}]