Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Общие вопросы Delphi
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 08.07.2016, 23:33   #1
Bucknall
 
Регистрация: 29.05.2014
Сообщений: 8
По умолчанию массив координат точек составляющих кривую Безье

Здравствуйте, уважаемые эксперты. Мне нужна функция, на входе получающая 4 координаты в TPoint, а на выходе дающая массив координат всех точек, составляющих кривую Безье, которая стандартными алгоритмами Canvas построена на этих четырех входных точках. Если я прошу слишком многого и "на блюдечке" - подскажите, в каком направлении копать? Спасибо

Последний раз редактировалось Bucknall; 09.07.2016 в 08:40.
Bucknall вне форума Ответить с цитированием
Старый 09.07.2016, 13:33   #2
Pavia
Лис
Старожил
 
Аватар для Pavia
 
Регистрация: 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.
Pavia вне форума Ответить с цитированием
Старый 09.07.2016, 23:33   #3
Bucknall
 
Регистрация: 29.05.2014
Сообщений: 8
По умолчанию

...
прихожу домой и с удивлением обнаруживаю такой, совсем не маленький, кусок кода в ответ на свой скромный вопрос..) пока нет возможности испытать, но, тем не менее, огромное спасибо, Pavia!)
Bucknall вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Среди N точек, заданных своими координатами на плоскости, определить самую дальнюю точку от начала координат. zaira001002 Общие вопросы C/C++ 10 30.09.2013 10:26
Определение координат точек на окружности DDiKey Помощь студентам 5 23.03.2012 21:11
Определить какая из двух точек - М1(х1,у1) или М2(х2,у2) - распаложенна ближе к началу координат. vano_18_RUS Помощь студентам 8 18.10.2010 23:53
Определить какая из точек находится ближе к началу координат(алгоритм ветвления). Rakfeller Паскаль, Turbo Pascal, PascalABC.NET 16 25.01.2009 02:01
Получение координат точек касательной к окружности Stilet Помощь студентам 2 01.08.2008 15:12