多角形から曲線(円弧補間(4点))を生成するスクリプトの修正版です。
設定した誤差以下になるか、頂点数が16000を超えるまで最大20回２分割を繰り返します。10回程度なら一瞬ですが、１回ごとに頂点数が倍々で増えて行くので20回繰り返すと最大十数秒かかります（VW2015デモ版にて）。
注意：このスクリプトにはバグがあります。
procedure PolyToCurve;
{ 選択した多角形から曲線を作る(放物線補間(4点、2等分法)) }
{$ DEBUG}
label
999, 1000;
const
MaxN = 16000;
PolygonObj = 5;
nL = 20;
type
PointImfo = structure
dir :integer;
p, pc :vector;
rad :real;
hasArc, isArc :boolean;
end;
var
pt :dynArray[] of PointImfo;
i, iL, n, np :integer;
d0, maxR :real;
p :vector;
hp, h, tmp :handle;
closed :boolean;
{$INCLUDE :vs_subroutins:If.vss}
{$INCLUDE :vs_subroutins:Basic.vss}
{$INCLUDE :vs_subroutins:Add_Inc_Dec.vss}
{$INCLUDE :vs_subroutins:KSSErrMsg.vss}
{$INCLUDE :vs_subroutins:Calc.vss}
{$INCLUDE :vs_subroutins:Small.vss}
{$INCLUDE :vs_subroutins:Large.vss}
{$INCLUDE :vs_subroutins:Swap.vss}
{$INCLUDE :vs_subroutins:SwapByOrder.vss}
{$INCLUDE :vs_subroutins:compound_type.vss}
{$INCLUDE :vs_subroutins:GetDefault.vss}
{$INCLUDE :vs_subroutins:Interpolation.vss}
{$INCLUDE :vs_subroutins:Math.vss}
{$INCLUDE :vs_subroutins:Math-Arc.vss}
{$INCLUDE :vs_subroutins:Drawing.vss}
{$INCLUDE :vs_subroutins:Drawing-New.vss}
{$INCLUDE :vs_subroutins:3d-Drawing.vss}
function GetPoints(h :handle): integer;
var
i, n :integer;
begin
closed:= IsPolyClosed(h);
n:= GetVertNum(h);
if MaxN < n then begin
Message(Concat('多角形の頂点が', MaxN, '個を超えています。(', iL, '回で打ち切り)'));
n:= 0;
end
else begin
Allocate pt[-1..n + 2];
for i:= 1 to n do begin{ 点座標の取得 }
GetPolyPt(h, i, pt[i].p.x, pt[i].p.y);
pt[i].p.z:= 0;
pt[i].hasArc:= closed | ((1 < i) & (i < n));
end;
if closed then begin
pt[n+1]:= pt[1]; pt[n+2]:= pt[2];
pt[-1]:= pt[n-1]; pt[0]:= pt[n];
end;
end;
GetPoints:= n;
end;{GetPoints}
function GetArcCenterAndDir(p9, p0, p1 :vector; var cnt :vector; var dir :integer): boolean;
var
ang, r :real;
v0, v1 :vector;
result :boolean;
begin
dir:= 0;
result:= SME2ArcCenterV(p9, p0, p1, cnt);
if result then begin
r:= Vec2Dist(p0 - cnt);
if r < maxR then begin
v0:= p0 - p9;
v1:= p1 - p0;
ang:= AzimuthByVecs(v0, v1);
dir:= Sign(ang);
end
else
result:= false;
end;
GetArcCenterAndDir:= result;
end;{GetArcCenterAndDir}
function GetNewPt(i :integer; var p :vector): boolean;
var
ang, rad, d, dst :real;
p0, p1, p2, p9, pc, pm :vector;
v, v0, v1, v2, v9, vc, vcc, vv :vector;
result :boolean;
begin
p0:= pt[i].p; p1:= pt[i+1].p;
pm:= (p0 + p1) / 2;
dst:= Vec2Dist(p1 - p0);
if pt[i].hasArc then begin
if pt[i].isArc then begin
v0:= pt[i].pc - p0;
v0:= RotVec(v0, -pt[i].dir * 90);
end
else
v0:= p1 - p0;
end;
if pt[i+1].hasArc then begin
if pt[i+1].isArc then
v1:= RotVec(pt[i+1].pc - p0, -pt[i+1].dir * 90)
else
v1:= p1 - p0;
end;
if pt[i].hasArc then
if pt[i+1].hasArc then
v:= VecVec2MidAzimuthVec(v0, v1)
else
v:= v0
else if pt[i+1].hasArc then
v:= v1;
if SVE2ArcCenterV(p0, v, p1, pc) then begin
rad:= Vec2Dist(p0 - pc);
if rad > maxR then
p:= pm
else begin
ang:= Vec2Ang(p1 - p0);
vc:= UnitVec(pc - pm);
vcc:= RotVec(vc, -ang);
vv:= RotVec(v, -ang);
p:= pc + Sign(vcc.y) * Sign(vv.y) * vc * rad;
end;
end
else
p:= pm;
d:= Vec2Dist(p - pm);
result:= (d0 < d);
if not result then begin
v2:= RotVec(p1 - pt[i+1].pc, 90);
if IntersectLLV(pc, pm, p1, p1 + v2, p2) then begin
if Vec2Dist(p2 - pm) > (2 * d0) then
result:= true
else begin
v9:= RotVec(p0 - pt[i].pc, 90);
if IntersectLLV(pc, pm, p0, p0 + v9, p9) then
result:= (Vec2Dist(p9 - pm) > (2 * d0));
end;
end;
end;
GetNewPt:= result;
end;{GetNewPt}
begin {main}
hp:= FSActLayer;
h:= hp;
if (h = Nil) | (GetTypeN(h) <> PolygonObj) then GoTo 1000;
MaxR:= LargeR(HWidth(h), HHeight(h)) / PrecFactor;
d0:= 4/9 * GetDefaultWS('曲線', '誤差', 1.0, true);
iL:= 0;
while (iL < nL) do begin
n:= GetPoints(h);
if n < 3 then GoTo 999;
iL:= iL + 1;
for i:= 1 to n do begin
if pt[i].hasArc then begin{ 円弧の中心と回転方向を取得 }
pt[i].isArc:= GetArcCenterAndDir(pt[i-1].p, pt[i].p, pt[i+1].p, pt[i].pc, pt[i].dir);
if pt[i].isArc then begin
pt[i].rad:= Vec2Dist(pt[i-1].p - pt[i].pc);
end;
end;
end;
if closed then begin
pt[n+1]:= pt[1]; pt[n+2]:= pt[2];
pt[-1]:= pt[n-1]; pt[0]:= pt[n];
end;
if closed then
ClosePoly
else
OpenPoly;
Message(Concat(iL, '回目'));
np:= 0;
BeginPoly;
for i:= 1 to n do begin
AddPointV(pt[i].p);
if closed | (i < n) then begin
if GetNewPt(i, p) then begin
AddPointV(p);
np:= np + 1;
end;
end;
end;
EndPoly;
if h <> hp then
DelObject(h);
h:= LNewObj;
ReDrawAll;
if np = 0 then begin
iL:= nL + iL;
end;
end;
if iL <= nL then
if np = 0 then
Message(Concat('分割回数 = ', iL-1))
else
Message(Concat('分割回数 = ', iL, ' (打ち切り)'))
else
Message(Concat('分割回数 = ', iL-nL-1));
999:
SetDSelect(hp);
ReDrawAll;
1000:
end; {main}
Run(PolyToCurve);
頂点４個のたすき掛け図形から曲線を生成しました。
