Если у вас возникли сложности с курсовой, контрольной, дипломной, рефератом, отчетом по практике, научно-исследовательской и любой другой работой - мы готовы помочь.
Предоплата всего
Подписываем
Лабораторная работа 1
(4 часа)
Тема. Разработка растрового редактора в среде Delphi.
Ход выполнения:
(В этой процедуре выполняется установка флага рисования drawing, инициализируются значения переменных direct, x1, y1, x2, y2, используемых при построении фокусного прямоугольника. В зависимости от выбранной пользователем функции выполняются следующие действия:
- вызов процедуры FillElps для функции «Закрасить эллипс (сектор эллипса)
- инициализация построения отрезка прямой для функции «Нарисовать отрезок прямой»
- вызов функции FindPoint для нахождения нового положения одной из концевых точек дуги эллипса).
procedure TFormMain.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
with Canvas do
case fl_tools of
0: MyFloodFill(x,y,clWhite,Canvas{, fsSurface fsBorder});
1: begin
drawing:=true;
x1:=x; y1:=y; x2:=x; y2:=y;
Pen.Mode:=pmNotXor;
MoveTo(x1,y1); LineTo(x2,y2);
end;
2: begin
drawing:=true;
x1:=x; y1:=y; x2:=x; y2:=y;
DrawFocusRect(Rect(x1,y1,x2,y2));
end;
3: begin
drawing:=true;
x1:=x; y1:=y; x2:=x; y2:=y;
DrawFocusRect(Rect(x1,y1,x2,y2));
end;
4: if Length(Points)=2 then begin
IndexPoint:=FindPoint(x,y);
drawing:=true;
end;
end;
end;
(Процедура FormMouseMove содержит операторы, обеспечивающие прорисовку фокусных прямоугольников при построении эллипса и дуги: Rect – задание прямоугольника, DrawFocusRect – фиксирует положение мыши, DrawArc – перерисовывает дугу после перемещение точки, MoveTo – перемещает точку в указанную координату, LineTo – рисует линию).
procedure TFormMain.FormMouseMove(Sender: TObject;
Shift: TShiftState; X,Y: Integer);
begin
if drawing then
with Canvas do
case fl_tools of
1: begin
MoveTo(x1,y1); LineTo(x2,y2);
x2:=x; y2:=y;
MoveTo(x1,y1); LineTo(x2,y2);
end;
2: begin
DrawFocusRect(Rect(x1,y1,x2,y2));
x2:=x; y2:=y;
DrawFocusRect(Rect(x1,y1,x2,y2));
end;
3: begin
DrawFocusRect(Rect(x1,y1,x2,y2));
x2:=x; y2:=y;
DrawFocusRect(Rect(x1,y1,x2,y2));
end;
4: begin
Points[IndexPoint].x:=x; Points[IndexPoint].y:=y;
ClearCanvas;
DrawArc(Canvas);
end;
end;
end;
( Обработка события FormMouseUp включает:
- вызов процедуры MyLine, реализует алгоритм Брезенхейма для отрезка прямой
- обращение к процедуре DrawArc реализует прорисовку дуги).
procedure TFormMain.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
drawing:=false;
with Canvas do
case fl_tools of
1: begin
SetLength(Points,0);
MoveTo(x1,y1); LineTo(x2,y2);
Pen.Mode:=pmCopy;
MyLine(x1,y1,x2,y2,Canvas);
end;
2: begin
SetLength(Points,0);
DrawFocusRect(Rect(x1,y1,x2,y2));
MyArc(x1,y1,x2,y2,0,0,0,0,Canvas);
end;
3: begin
SetLength(Points,2);
DrawFocusRect(Rect(x1,y1,x2,y2));
x0:=(x1+x2) div 2; y0:=(y1+y2) div 2;
Points[0].x:=x0+Abs((x1-x2) div 2); Points[0].y:=y0;
Points[1].x:=x0; Points[1].y:=y0-Abs((y1-y2) div 2);
ClearCanvas;
DrawArc(Canvas);
end;
end;
end;
procedure TFormMain.ClearCanvas;
begin
with Canvas do
FillRect(Rect(0,0,Width,Height));
end;
Для этого создадим еще одну форму: Файл_Создать_Форма и назовем ее «Инструменты». Поместим на нее последовательно Button1, Button2(Стандартные), ColorDialog1(Диалоги), PageControl1(Win32). Button1 назовем «Очистить», Button2 – «Завершить». На компоненте PageControl1 создаем новую страницу (в контекстном меню_новая страница). Первую страницу назовем Выбор, а вторую – Шаблоны. На страницу Выбор поместим компоненты RadioGroup1(Стандартные), Shape1 и Shape2(Дополнительно). С помощью свойства Items компонента RadioGroup1 задаем список примитивов:
Заливка эллипса
Отрезок прямой
Эллипс
Дуга эллипса
Переместить точки дуги
А в свойстве Caption пишем «Примитивы».
На страницу Шаблоны разместим компоненты Label1, Label2(Стандартные), StringGrig1, StringGrig2(Дополнительно). Label1 назовем «Стиль линии», Label2 – «Стиль кисти».
5. Ну а теперь напишем программный код формы «Инструменты»: для этого мы создадим новый модуль (Файл_Создать_Модуль).
procedure TForm2.Button1Click(Sender: TObject);
begin
Form1.ClearCanvas;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Form1.Close;
end;
procedure TForm2.RadioGroup1Click(Sender: TObject);
begin
fl_tools:=RadioGroup1.ItemIndex;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
Shape2.Brush.Color:=PenColor;
Shape1.Brush.Color:=BrushColor;
end;
procedure TForm2.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
with StringGrid1.Canvas do begin
if wb[ARow] and (1 shl ACol)<>0 then Brush.Color:=0 else Brush.Color:=clWhite; FillRect(Rect);
end;
end;
procedure TFormTools.StringGrid1DblClick(Sender: TObject);
begin
with StringGrid1 do begin
if wb[Row] and (1 shl Col)=0 then wb[Row]:=wb[Row] or (1 shl Col)
else wb[Row]:=wb[Row] and not (1 shl Col);
Refresh;
end;
end;
procedure TForm2.Shape2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if ColorDialog1.Execute then begin
Shape2.Brush.Color:=ColorDialog1.Color;
PenColor:=ColorDialog1.Color;
end;
end;
procedure TForm2.Shape1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if ColorDialog1.Execute then begin
Shape1.Brush.Color:=ColorDialog1.Color;
BrushColor:=ColorDialog1.Color;
end;
end;
procedure TForm2.StringGrid2DblClick(Sender: TObject);
begin
with StringGrid2 do begin
if w and (1 shl Col)=0 then w:=w or (1 shl Col)
else w:=w and not (1 shl Col);
Refresh;
end;
end;
procedure TForm2.StringGrid2DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
with StringGrid2.Canvas do begin
if w and (1 shl ACol)<>0 then Brush.Color:=0 else Brush.Color:=clWhite;
FillRect(Rect);
end;
end;
6. Процедуры же, реализующие основные алгоритмы построения изображений, мы разместим в так называемом библиотечном модуле (создадим новый модуль (п. 5)).
В type запишем:
PNode = ^TNode;
TNode = record
Info: TPoint;
Next: PNode;
В глобальные переменные запишем:
fl_tools : byte;
Points : array of TPoint;
x1,y1,x2,y2: Integer; // границы охватывающего прямоугольника
x0,y0 : Integer; // координаты центра эллипса
IndexPoint : integer;
w : word=$FF00; // шаблон линии
wb : array[0..7] of byte=($FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF);
Stack : PNode;
PenColor : TColor=0;
BrushColor : TColor=$0000FF;
procedure InitStack(var s: PNode); // инициализация стека
begin
s:=Nil;
end;
function StackIsEmpty(s: PNode): Boolean; // проверка стека на пустоту
begin
StackIsEmpty:=s=Nil;
end;
function PopStack(var s: PNode): TPoint; // взять из стека
var p: PNode;
begin
Result:=s^.Info;
p:=s; s:=s^.Next;
dispose(p);
end;
procedure PushStack(var s: PNode; x:TPoint); // положить в стек
var p: PNode;
begin
new(p);
with p^ do begin
Info:=x;
Next:=s;
end;
s:=p;
end;
procedure MyFloodFill(x,y: integer; Color: TColor; Canvas: TCanvas);
var
P: TPoint;
XL,XR,i,x1,x2: integer;
procedure ShiftLeft(var x: integer; y: integer); // сдвиг левой границы до последней белой
begin
with Canvas do
if Pixels[x,y]<>Color then // если x Black
while (Pixels[x,y]<>Color) and (x<1200) do Inc(x) // x=White
else begin // если x белая
while (Pixels[x,y]=Color) and (x>0) do Dec(x); // x=Black
Inc(x); // x=White
end;
end;
procedure ShiftRight(var x: integer; y: integer); // сдвиг правой границы до первой черной
begin
with Canvas do
if Pixels[x,y]=Color then // если x белая
while (Pixels[x,y]=Color) and (x<1200) do Inc(x) // x=Black
else begin // если x Black
while (Pixels[x,y]<>Color) and (x>0) do Dec(x); // x=White
Inc(x); // x=Black
end;
end;
begin
InitStack(Stack);
PushStack(Stack,Point(x,y));
with Canvas do
while not StackIsEmpty(Stack) do begin
P:=PopStack(Stack);
XL:=P.X;
while Pixels[XL,P.Y]=Color do begin
if wb[P.Y mod 8] and (1 shl (XL mod 8))<>0 then
Pixels[XL,P.Y]:=BrushColor
else Pixels[XL,P.Y]:=clSilver;
Dec(XL);
end; // XL - Black
XR:=P.X+1;
while Pixels[XR,P.Y]=Color do begin
if wb[P.Y mod 8] and (1 shl (XR mod 8))<>0 then
Pixels[XR,P.Y]:=BrushColor
else Pixels[XR,P.Y]:=clSilver;
Inc(XR);
end; // XR - Black
x1:=XL+1; x2:=XR-1; // нижняя строка
ShiftLeft(x1,P.Y+1);
ShiftRight(x2,P.Y+1);
for i:=x1 to x2-1 do
if (Pixels[i,P.Y+1]=Color) and (Pixels[i+1,P.Y+1]<>Color) then
PushStack(Stack,Point(i,P.Y+1));
x1:=XL+1; x2:=XR-1; // верхняя строка
ShiftLeft(x1,P.Y-1);
ShiftRight(x2,P.Y-1);
for i:=x1 to x2-1 do
if (Pixels[i,P.Y-1]=Color) and (Pixels[i+1,P.Y-1]<>Color) then
PushStack(Stack,Point(i,P.Y-1));
end;
end;
function FindPoint(u,v: integer): integer;
var D0,D1: integer;
begin
D0:=Sqr(Points[0].x-u)+Sqr(Points[0].y-v);
D1:=Sqr(Points[1].x-u)+Sqr(Points[1].y-v);
if D0<D1 then Result:=0 else Result:=1;
end;
procedure MyLine(x1,y1,x2,y2: Integer; Canvas: TCanvas); // построение отрезка прямой
var
i,j,dj,dx,dy,k: Integer;
d1,d2: Integer;
begin
k:=-1;
if x2<x1 then begin
i:=x1; x1:=x2; x2:=i;
i:=y1; y1:=y2; y2:=i;
end;
dx:=x2-x1; // x1<x2
dy:=y2-y1;
if dy>0 then dj:=1
else
if dy<0 then dj:=-1
else dj:=0;
dy:=abs(dy);
d1:=2*y2-y1; //d1:=1;
j:=y1; i:=x1;
if (dx<>0) and (dy<=dx) or (dy=0) then
while i<=x2 do begin
if d1<0
then d2:=d1+2*dy // без смещения по вертикали
else begin
d2:=d1+2*(dy-dx); // со смещением по вертикали
if (y2-j)*dj>0 then j:=j+dj
end;
Inc(k);
if w and (1 shl (k mod 16))<>0 then
Canvas.Pixels[i,j]:=PenColor;
d1:=d2;
i:=i+1;
end
else
while (y2-j)*dj>=0 do begin
if d1<0
then d2:=d1+2*dx // без смещения по горизонтали
else begin
d2:=d1+2*(dx-dy); // со смещением по горизонтали
if i<x2 then i:=i+1
end;
Inc(k);
if w and (1 shl (k mod 16))<>0 then
Canvas.Pixels[i,j]:=PenColor;
d1:=d2;
j:=j+dj;
end;
end;
procedure MyArc(x1,y1,x2,y2,x3,y3,x4,y4: Integer; Canvas: TCanvas); // постоение дуги эллипса
var
i,imin,j,d1,d2,n: Integer;
rx,ry,r2x,r2y: Integer;
e,ca,cb: Real;
function Varnt(xa,ya,xb,yb: Integer): Integer;
var
n1,n2: Integer;
function Quadrant(x,y: Integer): Integer;
begin
if (x-x0>0) and (y-y0<=0)
then Result:=0
else
if (x-x0<=0) and (y-y0<0)
then Result:=1
else
if (x-x0<0) and (y-y0>=0)
then Result:=2
else Result:=3;
end;
begin
n1:=Quadrant(xa,ya);
n2:=Quadrant(xb,yb);
if n1>n2 then n1:=n1-4;
Result:=n2+4*(n2-n1);
end;
procedure Symmetry(x,y: Integer);
var f: Real;
begin
f:=x/Sqrt(x*x+Sqr(ry-y));
with Canvas do
case n of
0: if (f<ca) and (f>cb) // 0 0
then Pixels[x+x0,y+y1]:=PenColor;
1: if (f>ca) and (f<cb) // 1 1
then Pixels[x0-x,y+y1]:=PenColor;
2: if (f<ca) and (f>cb) // 2 2
then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
3: if (f>ca) and (f<cb) // 3 3
then Pixels[x+x0,2*ry-y+y1]:=PenColor;
4: begin // -1 0
if f>ca then Pixels[x+x0,2*ry-y+y1]:=PenColor;
if f>cb then Pixels[x+x0,y+y1]:=PenColor;
end;
5: begin // 0 1
if f<ca
then Pixels[x0+x,y+y1]:=PenColor;
if f<cb
then Pixels[x0-x,y+y1]:=PenColor;
end;
6: begin // 1 2
if f>ca then Pixels[-x+x0,y+y1]:=PenColor;
if f>cb then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
end;
7: begin // 2 3
if f<ca then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
if f<cb then Pixels[x+x0,2*ry-y+y1]:=PenColor;
end;
8: begin // -2 -1 0
if f<ca then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
if f>cb then Pixels[x+x0,y+y1]:=PenColor;
Pixels[x+x0,2*ry-y+y1]:=PenColor;
end;
9: begin // -1 0 1
if f>ca then Pixels[x+x0,2*ry-y+y1]:=PenColor;
if f<cb then Pixels[-x+x0,y+y1]:=PenColor;
Pixels[x+x0,y+y1]:=PenColor;
end;
10: begin // 0 1 2
if f<ca then Pixels[x+x0,y+y1]:=PenColor;
if f>cb then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
Pixels[-x+x0,y+y1]:=PenColor;
end;
11: begin // 1 2 3
if f>ca then Pixels[-x+x0,y+y1]:=PenColor;
if f<cb then Pixels[x+x0,2*ry-y+y1]:=PenColor;
Pixels[-x+x0,2*ry-y+y1]:=PenColor;
end;
12: begin // -3 -2 -1 0
if f>ca then Pixels[-x+x0,y+y1]:=PenColor;
if f>cb then Pixels[x+x0,y+y1]:=PenColor;
Pixels[-x+x0,2*ry-y+y1]:=PenColor;
Pixels[x+x0,2*ry-y+y1]:=PenColor;
end;
13: begin // -2 -1 0 1
if f<ca then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
if f<cb then Pixels[-x+x0,y+y1]:=PenColor;
Pixels[x+x0,2*ry-y+y1]:=PenColor;
Pixels[x+x0,y+y1]:=PenColor;
end;
14: begin // -1 0 1 2
if f>ca then Pixels[x+x0,2*ry-y+y1]:=PenColor;
if f>cb then Pixels[-x+x0,2*ry-y+y1]:=PenColor;
Pixels[x+x0,y+y1]:=PenColor;
Pixels[-x+x0,y+y1]:=PenColor;
end;
15: begin // 0 1 2 3
if f<ca then Pixels[x+x0,y+y1]:=PenColor;
if f<cb then Pixels[x+x0,2*ry-y+y1]:=PenColor;
Pixels[-x+x0,y+y1]:=PenColor;
Pixels[-x+x0,2*ry-y+y1]:=PenColor;
end;
16: begin // -4 -3 -2 -1 0
if f<=ca then Pixels[x+x0,y+y1]:=PenColor;
if f>=cb then Pixels[x+x0,y+y1]:=PenColor;
Pixels[-x+x0,y+y1]:=PenColor;
Pixels[-x+x0,2*ry-y+y1]:=PenColor;
Pixels[x+x0,2*ry-y+y1]:=PenColor;
end;
end; // case
end;
begin
PenColor:=PenColor;
if x2<x1 then begin
i:=x1; x1:=x2; x2:=i;
end;
if y2<y1 then begin
i:=y1; y1:=y2; y2:=i;
end;
rx:=abs(x2-x1) div 2;
ry:=abs(y2-y1) div 2;
x0:=(x1+x2) div 2;
y0:=(y1+y2) div 2;
if (x3=x4) and (y3=y4) then n:=16
else n:=Varnt(x3,y3,x4,y4);
r2x:=Sqr(rx); r2y:=Sqr(ry);
e:=ry/rx; // эксцентриситет эллипса
ca:=Abs(x3-x0)/Sqrt(sqr(x3-x0)+sqr(y3-y0));
cb:=Abs(x4-x0)/Sqrt(sqr(x4-x0)+sqr(y4-y0));
imin:=Trunc(rx/Sqrt(1+Sqr(e)));
d1:=ry*(ry-r2x);
j:=0; i:=0;
while i<=imin do begin
if d1<0
then d2:=d1+(2*i+3)*r2y // без смещения по вертикали
else begin
d2:=d1+(2*i+3)*r2y-2*(ry-j-1)*r2x; // со смещением по вертикали
j:=j+1
end;
Symmetry(i,j);
d1:=d2; i:=i+1;
end;
d1:=rx*(rx-r2y);
j:=ry; i:=rx;
while i>imin do begin
if d1<0
then d2:=d1+(2*(ry-j)+3)*r2x // без смещения по горизонтали
else begin
d2:=d1+(2*(ry-j)+3)*r2x-2*(i-1)*r2y; // со смещением по горизонтали
i:=i-1
end;
Symmetry(i,j);
d1:=d2; j:=j-1;
end;
end;
procedure DrawArc(Canvas: TCanvas);
var i: integer;
begin
with Canvas do begin
DrawFocusRect(Rect(x1,y1,x2,y2));
for i:=0 to 1 do
with Points[i] do begin
Pen.Color:=clSilver;
MoveTo(x0,y0); LineTo(Points[i].x,Points[i].y);
Pen.Color:=clBlack;
RectAngle(x-2,y-2,x+2,y+2);
end;
end;
MyArc(x1,y1,x2,y2,Points[0].x,Points[0].y,Points[1].x,Points[1].y,Canvas);
end;
initialization
fl_tools:=0;
end.
7. В конечном итоге вы должны получить проект растрового редактора, который представлен на рис 3.