programming competition
- To: mathgroup at smc.vnet.net
- Subject: [mg4847] programming competition
- From: Xah Lee <xah at best.com>
- Date: Thu, 26 Sep 1996 22:42:11 -0400
- Organization: Best Internet Communications
- Sender: owner-wri-mathgroup at wolfram.com
This is a programming problem I recently encountered. The problem has the
attraction of being a programming competition type. I post the problem and my
solution here and hope someone will enjoy and maybe come out with other solutions.
Problem:
Suppose you have a ordered list {p1, p2, ... , pn} where points has the form
{x,y}. You want to modify the list so any neighboring points will have a distance
less or equal to a given value maxLength. You do this by adding points in between
points. For example, suppose p3 and p4 has length greater than maxLength. Your new
list should then be
{p1, p2, p3, newP1, newP2,..., newPm, p4, p5, ... , pn} where
newP1, ...newPm lies on the line p3 p4.
linearInterpolate::usage = "
linearInterpolate[{p1,p2,...}, maxLength ] returns
{P1,P2,...} such that the length between neighboring points
P[i], P[i+1] is less or equal to maxLength.
Newly created points lies on a line between old points";
linearInterpolate[ li_List, maxLength_ ]:=
Module[{positions},
positions = Flatten@ Position[
N@ Sqrt[#.#]& /@ Rest[ li-RotateRight[li] ],
x_/; (x > maxLength), {1}
];
Partition[ Flatten@ (Fold[
Module[{p1 = li[[#2]], p2 = li[[#2+1]]},
Insert[
#1,
Drop[
Rest@ Table[ (p2-p1) i + p1,
{i, 0, 1, 1./Ceiling@ N[Sqrt[Plus@@((p2-p1)^2)]/maxLength] }
],-1
],
#2
]
]&,
li,
Reverse@ positions]), 2]
]
-----------------------
Example,
li = Join[ {{0,0},{1,1}},
Table[{i,1}, {i,1,2,1/5}],
{{2,1}, {3,3}}
];
Show[
Graphics[{
Hue[0], PointSize[.02], Point/@ li
}],
AspectRatio->Automatic,
Axes->True,
PlotRange->All
];0;
Show[
Graphics[{
Hue[0], PointSize[.02],
Point /@ linearInterpolate[ li, .3]
}],
AspectRatio->Automatic,
Axes->True,
PlotRange->All
];0;
----------------------
More example
In[15]:=
gp = First@ ParametricPlot[
t {Cos at t, Sin at t}, {t,0, 4 Pi},
PlotPoints->10,
MaxBend->10,
PlotDivision->5,
DisplayFunction->Identity
];0;
In[17]:=
Show[
Graphics[{ Point /@ gp[[1,1,1]]
}],
AspectRatio->Automatic,
Axes->True
];0;
In[18]:=
Show[
Graphics[{ Point /@ linearInterpolate[ gp[[1,1,1]], 1 ]
}],
AspectRatio->Automatic,
Axes->True
];0;
This program is used to increase resolution of arbitrary user generated graphics.
This gives me better resolution control of transformations applies to the original
image.
Xah
xah at best.com; 74631.731 at compuserve.com
http://www.best.com/~xah/SpecialPlaneCurves_dir/specialPlaneCurves.html
Mountain View, CA, USA
==== [MESSAGE SEPARATOR] ====