Форум: "Основная";
Текущий архив: 2007.02.25;
Скачать: [xml.tar.bz2];

Вниз

Полигоны   Найти похожие ветки 

← →
tio   (2007-01-01 10:42) [0]

С новым Годом!
Уважаемые мастера скажите, что надо сделать?:
Рисую 2 полигона с произвольными координатами,
и получается, что один частично закрывает другого.
Можно, чтобы полигон имел не один цвет, а при
наложении заливал ту область другим цветом.
Сделал через pixels, но очень долго.
Заранее спасибо.

---

← →
Vovan #2   (2007-01-01 14:13) [1]

>Сделал через pixels, но очень долго.

Надо бы через Scanline.

---

← →
Igor_Z   (2007-01-01 16:13) [2]

private
  procedure MAn;

var
 Form1: TForm1;

type
 TRGB = record
   b, g, r: byte;
 end;
 ARGB = array[0..1] of TRGB;
 PARGB = ^ARGB;

var
 b: TBitMap;
 p: PARGB;

implementation

{$R *.dfm}
function DotInRgn(TestPolygon : array of TPoint; const P : TPoint): boolean;
var
  ToTheLeftofPoint, ToTheRightofPoint : byte;
  np : integer;
  OpenPolygon : boolean;
  XIntersection : real;
begin
  ToTheLeftofPoint := 0;
  ToTheRightofPoint := 0;
  OpenPolygon := False;
  if not ((TestPolygon[0].X = TestPolygon[High(TestPolygon)].X) and
    (TestPolygon[0].Y = TestPolygon[High(TestPolygon)].Y)) then
    OpenPolygon := True;
  for np := 1 to High(TestPolygon) do
    if ((TestPolygon[np - 1].Y <= P.Y) and
      (TestPolygon[np].Y > P.Y)) or
      ((TestPolygon[np - 1].Y > P.Y) and
      (TestPolygon[np].Y <= P.Y))
      then
    begin
      XIntersection := TestPolygon[np - 1].X +
        ((TestPolygon[np].X - TestPolygon[np - 1].X) /
        (TestPolygon[np].Y - TestPolygon[np - 1].Y)) * (P.Y - TestPolygon[np - 1].Y);
     if XIntersection < P.X then Inc(ToTheLeftofPoint);
      if XIntersection > P.X then Inc(ToTheRightofPoint);
    end;
  if OpenPolygon then
  begin
    np := High(TestPolygon);
    if ((TestPolygon[np].Y <= P.Y) and
      (TestPolygon[0].Y > P.Y)) or
      ((TestPolygon[np].Y > P.Y) and
      (TestPolygon[0].Y <= P.Y)) then
    begin
      XIntersection := TestPolygon[np].X +
        ((TestPolygon[0].X - TestPolygon[np].X) /
        (TestPolygon[0].Y - TestPolygon[np].Y)) * (P.Y - TestPolygon[np].Y);
      if XIntersection < P.X then Inc(ToTheLeftofPoint);
      if XIntersection > P.X then Inc(ToTheRightofPoint);
    end;
  end;
  if (ToTheLeftofPoint mod 2 = 1) and (ToTheRightofPoint mod 2 = 1) then Result := True
  else
    Result := False;
end;

procedure TForm1.MAn;
var x,y:array[0..2] of TPoint;
i,j:integer;
begin
Canvas.Brush.Color:=clyellow;
x[0].X:=300;
x[1].X:=300;
x[2].X:=width;
x[0].Y:=500;
x[1].Y:=200;
x[2].Y:=0;
Canvas.Polygon(x);
y[0].X:=200;
y[1].X:=300;
y[2].X:=width;
y[0].Y:=550;
y[1].Y:=250;
y[2].Y:=100;
Canvas.Brush.Color:=cllime;
Canvas.Polygon(y);
b.TransparentColor:=clwhite;
b.Transparent:=true;
for j := 0 to b.height - 1 do
begin
if b.Canvas.Brush.Color = clwhite then
p := b.scanline[j];
for i:=0 to b.Width-1 do
if b.Canvas.Brush.Color = clwhite then
if (DotInRgn(x,Point(i,j))= true) and (DotInRgn(y,Point(i,j))= true) then
begin
p[i].r := random(125);
p[i].g := random(120);
p[i].b := random(100);
end;
end;
canvas.draw(0, 0, b);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
b := TBitMap.Create;
b.pixelformat := pf24bit;
b.width := Clientwidth;
b.height := Clientheight;
man;
b.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
refresh;
end;

Как-то все равно медленно.

---

← →
Vovan #2   (2007-01-01 18:39) [3]


unit unitMain;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs;

type
 TformMain = class(TForm)
   procedure FormPaint(Sender: TObject);
   procedure FormResize(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
 private
   { Private declarations }
 public
   procedure Man;
 end;

var
 formMain: TformMain;

type
TRGB = packed record
  b, g, r: byte;
end;

const
 PixelCountMax = 32768;

type
 pRGBArray = ^TRGBArray;
 TRGBArray = array[0..PixelCountMax-1] of TRGB;

var
b: TBitMap;

implementation

{$R *.dfm}

function DotInRgn(TestPolygon: array of TPoint; const P : TPoint): boolean;
var
 ToTheLeftofPoint, ToTheRightofPoint : byte;
 np : integer;
 OpenPolygon : boolean;
 XIntersection : real;
begin
 ToTheLeftofPoint := 0;
 ToTheRightofPoint := 0;
 OpenPolygon := False;
 if not ((TestPolygon[0].X = TestPolygon[High(TestPolygon)].X) and
   (TestPolygon[0].Y = TestPolygon[High(TestPolygon)].Y)) then
   OpenPolygon := True;
 for np := 1 to High(TestPolygon) do
   if ((TestPolygon[np - 1].Y <= P.Y) and
     (TestPolygon[np].Y > P.Y)) or
     ((TestPolygon[np - 1].Y > P.Y) and
     (TestPolygon[np].Y <= P.Y))
     then
   begin
     XIntersection := TestPolygon[np - 1].X +
       ((TestPolygon[np].X - TestPolygon[np - 1].X) /
       (TestPolygon[np].Y - TestPolygon[np - 1].Y)) * (P.Y - TestPolygon[np - 1].Y);
    if XIntersection < P.X then Inc(ToTheLeftofPoint);
     if XIntersection > P.X then Inc(ToTheRightofPoint);
   end;
 if OpenPolygon then
 begin
   np := High(TestPolygon);
   if ((TestPolygon[np].Y <= P.Y) and
     (TestPolygon[0].Y > P.Y)) or
     ((TestPolygon[np].Y > P.Y) and
     (TestPolygon[0].Y <= P.Y)) then
   begin
     XIntersection := TestPolygon[np].X +
       ((TestPolygon[0].X - TestPolygon[np].X) /
       (TestPolygon[0].Y - TestPolygon[np].Y)) * (P.Y - TestPolygon[np].Y);
     if XIntersection < P.X then Inc(ToTheLeftofPoint);
     if XIntersection > P.X then Inc(ToTheRightofPoint);
   end;
 end;
 if (ToTheLeftofPoint mod 2 = 1) and (ToTheRightofPoint mod 2 = 1) then Result := True
 else
   Result := False;
end;

procedure TformMain.Man;
var x,y: array [0..2] of TPoint;
   i,j: integer;
    p: PRGBArray;
begin
 b.Canvas.Brush.Color := clWhite;
 b.Canvas.FillRect(Rect(0, 0, b.Width, b.Height));

 x[0].X := 300;
 x[1].X := 300;
 x[2].X := b.Width-50;
 x[0].Y := 500;
 x[1].Y := 200;
 x[2].Y := 50;
 b.Canvas.Brush.Color := clYellow;
 b.Canvas.Polygon(x);

 y[0].X := 200;
 y[1].X := 300;
 y[2].X := b.Width - 50;
 y[0].Y := 550;
 y[1].Y := 250;
 y[2].Y := 100;
 b.Canvas.Brush.Color := clLime;
 b.Canvas.Polygon(y);

 b.TransparentColor := clwhite;
 b.Transparent := true;

 for j := 0 to b.Height-1 do
  begin
    p := b.scanline[j];
    for i:= 0 to b.Width-1 do
     begin
      if RGB(p[i].r, p[i].g, p[i].b) <> clWhite then
       if DotInRgn(x, Point(i,j)) and DotInRgn(y, Point(i,j)) then
        begin
         p[i].r := 128;
         p[i].g := 0;
         p[i].b := 0;
       end;
     end;
  end;

 Canvas.Draw(0, 0, b);
end;

procedure TformMain.FormPaint(Sender: TObject);
begin
 Man;
end;

procedure TformMain.FormResize(Sender: TObject);
begin
b.width := Clientwidth;
b.height := Clientheight;
Invalidate;
end;

procedure TformMain.FormCreate(Sender: TObject);
begin
 b := TBitMap.Create;
 b.pixelformat := pf24bit;
 b.width := Clientwidth;
 b.height := Clientheight;
 DoubleBuffered := True;
end;

procedure TformMain.FormDestroy(Sender: TObject);
begin
 b.Free;
end;

end.


Вроде бы нормальная скорость стала.

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2007.02.25;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.48 MB
Время: 0.037 c