Лабораторная работа 1 4 часа Тема

Работа добавлена на сайт samzan.net:

Лабораторная работа 1

(4 часа)

Тема. Разработка растрового редактора в среде Delphi.

Ход выполнения:

1.  Создаем новый проект Project1 (сохранить не забудьте).
2.  Форма Form1 будет служить своего рода холстом для нанесения изображения, поэтому будет логично, если мы назовем нашу форму «Холст».
3.  Для необходимого выполнения работы формы нам необходимо создать:

•  Обработчик события OnMouseDown для формы «Холст».

(В этой процедуре выполняется установка флага рисования 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;

•  Обработчик события OnMouseMove для формы «Холст».

(Процедура 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;

•  Обработчик события OnMouseUp для формы «Холст».

( Обработка события 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;

•  Очистка холста с помощью процедуры ClearCanvas.

procedure TFormMain.ClearCanvas;

begin

 with Canvas do

   FillRect(Rect(0,0,Width,Height));

end;

1.  Наш холст готов. Теперь создадим примитивы для рисования.

Для этого создадим еще одну форму: Файл_Создать_Форма и назовем ее «Инструменты». Поместим на нее последовательно 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;

•  Задаем Shape1 – цвет карандаша и Shape2 – цвет кисти при открытие формы:

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;

•  Для задания цвета заливки Shape1 и Shape2:

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.

1. 200 г
2. ВВЕДЕНИЕ [4] ЧТО ТАКОЕ ЯЗЫК [5] ЗАЧЕМ МЫ ИЗУЧАЕМ ЯЗЫКИПОЧЕМУ МЫ ЯЗЫКИ ИЗУЧАЕМКОГДА НАМ ИХ ИЗУЧАТ
3. Жалпы ережелер 1
4. Экспертиза как основная форма использования специальных познаний в уголовном процессе
5. . Служба тыла 2.
6. Тема- Загальне вчення про державу
7. Эрнст Ренан
8. сосудистой системы Приготовленное масло из зеленого кофе с успехом применяется в косметологии для проведе
9. х гг. XIX в. возникает рабочее движение за демократическую конституцию чартизм
10. Принцип права Правовая доктрина
11. Содержание трудового договор
12. ЭКОНОМИКО-МАТЕМАТИЧЕСКИЕ МОДЕЛИ
13. Шпаргалка к экзамену по информатике Visual Basic 1 курс
14. Вероятность случайного события
15. НА ТЕМУ- ФУНКЦИЯ СТИМУЛИРОВАНИЯ В МЕНЕДЖМЕНТЕ
16. I ВВЕДЕНИЕ Состояние дореформенной армии определялось социальноэкономической обстановкой сложившей
17.  Золотой век Екатерины II 1
18. Корпорация Я и создает одно из первых PRагентств в России
19. правова відповідальність
20. МЕТОДИЧЕСКИЕ РЕКОМЕНДАЦИИ К ИЗУЧЕНИЮ ТЕМЫ

Материалы собраны группой SamZan и находятся в свободном доступе