Лис
Старожил
Регистрация: 18.09.2015
Сообщений: 2,409
|
Код:
type
P4Point=^T4Point;
T4Point= array [0..3] of TPoint;
const fpPointBits=4; // Число бит до фиксированной точки
fpOnePixel=1 shl fpPointBits;
fpHalfPixel=fpOnePixel shr 1;
Type
TFixPoint=Integer;
P4Point_FixPoint=^T4Point_FixPoint;
T4Point_FixPoint= T4Point;
TPoints=array of TPoint;
TPolyLine=TPoints;
// Проверка кривой на гладкость. Возмоность заменить прямой.
function BezierCheck(Points:P4Point_FixPoint):boolean;
var
dx,dy:TFixPoint;
_dx,_dy:Integer;
begin
Result:=False;
dx:=Points[3].X-Points[0].X;
dy:=Points[3].Y-Points[0].Y;
if (abs(dy)<=abs(dx)) then //x Line
begin
if Points[1].X<Points[0].X then
begin
if Points[1].X<Points[3].X then
exit;
end else if Points[1].X>Points[3].X then exit;
if Points[2].X<Points[0].X then
begin
if Points[2].X<Points[3].X then
exit;
end else if Points[2].X>Points[3].X then exit;
_dx:=(dx+1) shr fpPointBits;
if (_dx=0) then
begin
result:=True; Exit;
end;
if (abs(Points[1].Y-Points[0].Y-(dy div _dx)*
((Points[1].X-Points[0].X+1) shr fpPointBits))>fpOnePixel) or
(abs(Points[3].Y-Points[2].Y-(dy div _dx)*
((Points[3].X-Points[2].X+1) shr fpPointBits))>fpOnePixel) then
begin exit; end
else
begin
result:=True; Exit;
end;
end else //y line
begin
if Points[1].Y<Points[0].Y then
begin
if Points[1].Y<Points[3].Y then
exit;
end else if Points[1].Y>Points[3].Y then exit;
if Points[2].Y<Points[0].Y then
begin
if Points[2].Y<Points[3].Y then
exit;
end else if Points[2].Y>Points[3].Y then exit;
_dy:=(dy+1) shr fpPointBits;
if (_dy=0) then
begin
result:=True; Exit;
end;
if (abs(Points[1].X-Points[0].X-(dx div _dy)*
((Points[1].Y-Points[0].Y+1) shr fpPointBits))>fpOnePixel) or
(abs(Points[3].X-Points[2].X-(dx div _dy)*
((Points[3].Y-Points[2].Y+1) shr fpPointBits))>fpOnePixel) then
begin exit; end
else
begin
result:=True; Exit;
end;
end;
end;
// Рекурсивное разбиение кривой.
procedure BezierIncrement(Points:P4Point_FixPoint;var PolyLine:TPolyLine; Level:Integer);
var
Points2:T4Point_FixPoint;
Pos:Integer;
begin
if (Level=0) or BezierCheck(Points) then
begin
pos:=Length(PolyLine);
SetLength(PolyLine,pos+1);
PolyLine[Pos].X:=(Points[3].X+fpHalfPixel) shr fpPointBits; //+8 это смещение на пол пикселя для вывода
PolyLine[Pos].Y:=(Points[3].Y+fpHalfPixel) shr fpPointBits;
end else
begin
// Разбиваем кривую на две. Опорные точки интерполируются
Points2[3]:=Points[3];
Points2[2].X:=(Points[2].X+Points[3].X+1)shr 1;
Points2[2].Y:=(Points[2].Y+Points[3].Y+1)shr 1;
Points2[0].X:=(Points[1].X+Points[2].X+1)shr 1;
Points2[0].Y:=(Points[1].Y+Points[2].Y+1)shr 1;
Points2[1].X:=(Points2[0].X+Points2[2].X+1)shr 1;
Points2[1].Y:=(Points2[0].Y+Points2[2].Y+1)shr 1;
Points[1].X:=(Points[0].X+Points[1].X+1)shr 1;
Points[1].Y:=(Points[0].Y+Points[1].Y+1)shr 1;
Points[2].X:=(Points[1].X+Points2[0].X+1)shr 1;
Points[2].Y:=(Points[1].Y+Points2[0].Y+1)shr 1;
Points[3].X:=(Points[2].X+Points2[1].X+1)shr 1;
Points[3].Y:=(Points[2].Y+Points2[1].Y+1)shr 1;
Points2[0]:=Points[3];
BezierIncrement(Points,PolyLine,Level-1);
BezierIncrement(@Points2,PolyLine,Level-1);
end;
end;
// Преобразование кривой Безье 4 точечной в поллинию
function PathBezier(Points:T4Point):TPolyLine;
var Count,i:Integer;
fpPoints:T4Point_FixPoint;
PolyLine:TPolyLine;
begin
for i:=0 to 3 do
begin
fpPoints[i].X:=Points[i].X shl fpPointBits; // Переводим из целых в числа с фиксиованной точкой
fpPoints[i].Y:=Points[i].Y shl fpPointBits;
end;
SetLength(PolyLine,1);
PolyLine[0].X:=(fpPoints[0].X+fpHalfPixel) shr fpPointBits;
PolyLine[0].Y:=(fpPoints[0].Y+fpHalfPixel) shr fpPointBits;
BezierIncrement(@fpPoints[0],PolyLine,8); // Максимальное разбиение ставим 8 - уровней. Больше для вывода нет смысла.
Result:=PolyLine;
end;
Type
TFuncSetPixel=procedure (x,y:Integer; Data:Pointer);
function Sign3(x:Integer):Integer;
begin
if x<0 then Result:=-1
else if x>0 then Result:=+1
else Result:=0;
end;
// Последний пиксель не дорисовываем.
Procedure LineDDA (x1, y1, x2, y2: Integer; SetPixel:TFuncSetPixel; Data: Pointer );
Var e,i,x,y,dx,dy,sx,sy: Integer;
Begin
x := x1;
y := y1;
dx := Abs(x2 - x1);
dy := Abs(y2 - y1);
sx := Sign3(x2 - x1);
sy := Sign3(y2 - y1);
If (dx = 0) And (dy = 0) Then
Exit;
If dy < dx Then
Begin
e := 2*dy - dx;
i := 1;
Repeat
SetPixel(x, y, Data);
While e >= 0 Do
Begin
inc(y, sy);
dec(e, 2*dx)
End;
inc(x, sx);
inc(e, 2*dy);
inc(i);
Until i > dx;
End
Else
Begin
e := 2*dx - dy;
i := 1;
Repeat
SetPixel(x, y, Data);
While e >= 0 Do
Begin
inc(x, sx);
dec(e, 2*dy)
End;
inc(y, sy);
inc(e, 2*dx);
inc(i);
Until i > dy;
End;
End;
// Преобразуем Кривую Безье в точки.
function BezierToPoints(BasePoints:T4Point):TPoints;
type
PPoints=^TPoints;
var
Points:TPoints;
procedure AddPixel(x,y:Integer; Points:PPoints);
var
Pos:Integer;
begin
Pos:=Length(Points^);
SetLength(Points^,Pos+1);
Points^[pos]:=Point(x,y);
end;
var
BesierPolyLine:TPolyLine;
P0,P1:TPoint;
i:Integer;
begin
Points:=Nil;
BesierPolyLine:=PathBezier(BasePoints);
if Length(BesierPolyLine)>2 then
begin
P0:=BesierPolyLine[0];
for i:=1 to Length(BesierPolyLine)-1 do
begin
P1:=BesierPolyLine[i];
LineDDA(P0.X,P0.Y,P1.X,P1.Y,@AddPixel, @Points);
P0:=P1;
end;
AddPixel(P0.X,P0.Y, @Points);
end else if Length(BesierPolyLine)=1 then
AddPixel(BesierPolyLine[0].X,BesierPolyLine[0].Y, @Points);
Result:=Points;
end;
// Пример использования
procedure CalcRotatedEllipse(CX, CY, A, B: Integer; Alpha: Double; var BezPts: array of TPoint);
const
MP = 0.55228475;
var
CA, SA, ACA, ASA, BCA, BSA: Double;
i, CX2, CY2: Integer;
function TransformPoint(X, Y: Double): TPoint;
begin
Result.X := Round(CX + X * ACA + Y * BSA);
Result.Y := Round(CY - X * ASA + Y * BCA);
end;
begin
Assert(Length(BezPts) = 13);
CA:= Cos(Alpha); SA := Sin(Alpha);
ACA := A * CA; ASA := A * SA;
BCA := B * CA; BSA := B * SA;
CX2 := 2 * CX; CY2 := 2 * CY;
BezPts[0] := TransformPoint(1, 0);
BezPts[1] := TransformPoint(1, MP);
BezPts[2] := TransformPoint(MP, 1);
BezPts[3] := TransformPoint(0, 1);
BezPts[4] := TransformPoint(- MP, 1);
BezPts[5] := TransformPoint(-1, MP);
for i := 0 to 5 do
BezPts[i + 6] := Point(CX2 - BezPts[i].X, CY2 - BezPts[i].Y);
BezPts[12] := BezPts[0];
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Points:TPoints;
i,j:Integer;
BasePoints:T4Point;
EllipsePath:TPoints;
begin
SetLength(EllipsePath,13);
CalcRotatedEllipse(200, 200, 200, 70, Pi/6, EllipsePath);
for j:=0 to 3 do
begin
for i:=0 to 3 do
begin
BasePoints[i].x:=EllipsePath[i+j*3].x;
BasePoints[i].y:=EllipsePath[i+j*3].y;
end;
Points:=BezierToPoints(BasePoints);
for i:=0 to Length(Points)-1 do
begin
Canvas.Pixels[Points[i].X, Points[i].Y]:=clRed;
end;
end;
end;
Хорошо поставленный вопрос это уже половина ответа. | Каков вопрос, таков ответ.
У дзен программиста программа делает то что он хотел, а не то что он написал .
Последний раз редактировалось Pavia; 09.07.2016 в 13:40.
|