FAQ VCL
Графика

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как нарисовать эллипс под углом?

// Способ первый
// CX, CY: кооординаты центра эллипса
// A, B: полуоси
// Angle: угол поворота в радианах
procedure EllipseAngle(Canvas: TCanvas; CX, CY, A, B: Integer; Angle: Double);
const
  DXY = 0.55228475;
var
  X, Y: array[0..12] of Single;
  DX, DY: Single;
  CF, SF: Single;
  Pts: array[0..12] of TPoint;
  i: Integer;
begin
   DX := A * DXY;
   DY := B * DXY;
   X[0] := A;    Y[0] := 0;
   X[1] := A;    Y[1] := DY;
   X[2] := DX;   Y[2] := B;
   X[3] := 0;    Y[3] := B;
   X[4] := -DX;  Y[4] := B;
   X[5] := -A;   Y[5] := DY;
   X[6] := -A;   Y[6] := 0;
   X[7] := -A;   Y[7] := -DY;
   X[8] := -DX;  Y[8] := -B;
   X[9] := 0;    Y[9] := -B;
   X[10] := DX;  Y[10] := -B;
   X[11] := A;   Y[11] := -DY;
   X[12] := A;   Y[12] := 0;
   CF := Cos(Angle);
   SF := Sin(Angle);
   for i := 0 to 12 do
   begin
      Pts[i].X := Round(X[i] * CF - Y[i] * SF + CX);
      Pts[i].Y := Round(X[i] * SF + Y[i] * CF + CY);
   end;
   Canvas.PolyBezier(Pts);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   EllipseAngle(Canvas, 200, 200, 200, 100, - Pi/4);
end;

// Способ второй
// CX, CY: кооординаты центра эллипса
// A, B : полуоси
// Angle - угол поворота в радианах
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
  Pts: array[0..12] of TPoint;
begin
   CalcRotatedEllipse(200, 200, 200, 70, Pi/6, Pts);
   Canvas.PolyBezier(Pts);
end;


Как начертить круг?

uses
  {...,} Math;

procedure DrawCircle(CenterX, CenterY, Radius: Integer; Canvas: TCanvas;
  Color: TColor);

   procedure PlotCircle(x, y, x1, y1: Integer);
   begin
     Canvas.Pixels[x + x1, y + y1] := Color;
     Canvas.Pixels[x - x1, y + y1] := Color;
     Canvas.Pixels[x + x1, y - y1] := Color;
     Canvas.Pixels[x - x1, y - y1] := Color;
     Canvas.Pixels[x + y1, y + x1] := Color;
     Canvas.Pixels[x - y1, y + x1] := Color;
     Canvas.Pixels[x + y1, y - x1] := Color;
     Canvas.Pixels[x - y1, y - x1] := Color;
   end;

var
  x, y, r: Integer;
  x1, y1, p: Integer;
begin
   x := CenterX;
   y := CenterY;
   r := Radius;
   x1 := 0;
   y1 := r;
   p := 3 - 2 * r;
   while (x1 < y1) do
   begin
      PlotCircle(x, y, x1, y1);
      if (p < 0) then
         p := p + 4 * x1 + 6
      else
      begin
         p := p + 4 * (x1 - y1) + 10;
         y1 := y1 - 1;
      end;
      x1 := x1 + 1;
   end;
   if (x1 = y1) then
      PlotCircle(x, y, x1, y1);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   DrawCircle(ClientWidth div 2, ClientHeight div 2, Min(ClientWidth div 2,
      ClientHeight div 2), Canvas, clBlack);
end;


Как изменить размеры полигона?

type 
   TPolygon = array of TPoint; 

procedure ZoomPolygon(var Polygon: TPolygon; const Center: TPoint; const Scale: Double); 
var 
   i: Integer; 
begin 
   for i := 0 to High(Polygon) do 
   begin 
     Polygon[i].X := Round(Scale * (Polygon[i].X - Center.X) + Center.X); 
     Polygon[i].Y := Round(Scale * (Polygon[i].Y - Center.Y) + Center.Y); 
   end; 
end;


Как нарисовать сетку из Hexagon'ов?

uses
  {...,} Math;

procedure PlotPolygon(const Canvas: TCanvas; const N: Integer; const R: Single;
   const XC: Integer; const YC: Integer);
type
  TPolygon = array of TPoint;
var
  Polygon: TPolygon;
  i: Integer;
  c: Extended;
  s: Extended;
  a: Single;
begin
   SetLength(Polygon, N);
   a := 2 * Pi / N;
   for i := 0 to (N - 1) do
   begin
      SinCos(i * a, s, c);
      Polygon[i].X := XC + Round(R * c);
      Polygon[i].Y := YC + Round(R * s);
   end;
   Canvas.Polygon(Polygon);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  w: Single;
  h: Single;
  x: Integer;
  y: Integer;
const
  N = 6;
  R = 10; // Размен Hexagon'а
begin
   w := 1.5 * R;
   h := R * Sqrt(3);
   for x := 0 to Round(ClientWidth / w) do
      for y := 0 to Round(ClientHeight / h) do
         if Odd(x) then
            PlotPolygon(Canvas, N, R, Round(x * w), Round((y + 0.5) * h))
         else
            PlotPolygon(Canvas, N, R, Round(x * w), Round(y * h));
end;

При использовании материала - ссылка на сайт обязательна