unit1.~pas

本程序是图形的设计

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    Splitter1: TSplitter;
    Image1: TImage;
    Panel2: TPanel;
    Splitter2: TSplitter;
    Label1: TLabel;
    Edit1: TEdit;
    procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure save_default();
    procedure load_default();
    procedure save_back();
    procedure pickup(x,y:integer;c1:Tcolor);
    procedure depickup(x,y:integer);
    procedure movepickup(x,y:integer;c1:Tcolor);
    procedure onmove(x,y:integer);
    procedure moveto(x,y:integer);
    procedure cirpickup(x,y:integer;c1:Tcolor);
    procedure oncir(x,y:integer);
    procedure cirto(x,y:integer);
    procedure line_save(i,x1,y1,x2,y2:integer;color:Tcolor);
    procedure circle_save(i,x1,y1,x2,y2:integer;color:Tcolor);
    procedure ellipse_save(i,x1,y1,x2,y2:integer;color:Tcolor);
    procedure paintagain();
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Image1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations}
  end;

type
   linerecord=record
   A:integer;
   B:integer;
   C:integer;
   x1:integer;
   x2:integer;
   y1:integer;
   y2:integer;
   color:Tcolor;
   fag:boolean;
end;
   linearray=array[1..50]of linerecord;

type
   circlerecord=record
   a:integer;
   b:integer;
   r:integer;
   color:Tcolor;
   fag:boolean;
end;
   circlearray=array[1..50]of circlerecord;
type
   ellipserecord=record
   a:integer;
   b:integer;
   ca:integer;
   cb:integer;
   color:Tcolor;
   fag:boolean;
end;
   ellipsearray=array[1..50]of ellipserecord;

var
  Form1: TForm1;
  com_sel,x0,y0:integer;
  x1,y1,x2,y2,xc,yc:integer;
  c_line:string;
  bmp1:Array[1..50] of tbitmap;
  rb,ud:integer;
  bmp:tbitmap;
  rect1:Trect;
  cl:tcolor;
  st:integer;
  linecount,circlecount,ellipsecount:integer;
  line_array:linearray;
  circle_array:circlearray;
  ellipse_array:ellipsearray;
  movestart_x,movestart_y:integer;

implementation

uses Unit2;


function com_select():integer;
begin
   with form1 do
   begin
      if edit1.Text='r' then com_select:=1
      else if edit1.Text='line' then com_select:=2
      else if edit1.Text='circle' then com_select:=3
      else if edit1.Text='ellipse' then com_select:=4
      else com_select:=0;
   end;
end;

function checkcursor_x(X: Integer):integer;
begin
  checkcursor_x:=x-x0;
end;

function checkcursor_y(Y: Integer):integer;
begin
  checkcursor_y:=-y+y0;
end;


procedure tform1.save_default();
begin
  bmp.Width:=form1.Image1.Width;
  bmp.Height:=form1.Image1.Height;
  bmp.Canvas.CopyRect(image1.Canvas.ClipRect,form1.image1.Canvas,image1.Canvas.ClipRect);
end;

procedure tform1.save_back();
begin
 rb:=rb+1;
 if rb=51 then rb:=1;
 st:=rb;
 bmp1[rb].Width:=form1.Image1.Width;
 bmp1[rb].Height:=form1.Image1.Height;
 bmp1[rb].Canvas.CopyRect(image1.Canvas.ClipRect,form1.image1.Canvas,image1.Canvas.ClipRect);
end;

procedure tform1.load_default();
begin
    form1.Image1.Canvas.CopyRect(image1.Canvas.ClipRect,bmp.Canvas,image1.Canvas.ClipRect);
end;

procedure change_curson();
begin
  with form1 do
  begin
    if label1.Caption='请输入命令：' then
       begin
         label1.Caption:='请输入原点横坐标：';
         edit1.Text:='';
         edit1.SetFocus;
       end
    else
      begin
       if label1.Caption= '请输入原点横坐标：' then
          begin
             x0:=strtoint(edit1.Text);
             label1.Caption:='请输入原点纵坐标：';
             edit1.Text:='';
             edit1.SetFocus;
          end
       else
          begin
             if label1.Caption='请输入原点纵坐标：'  then
              begin
               y0:=strtoint(edit1.Text);
               label1.Caption:='请输入命令：';
               edit1.Text:='';
               edit1.SetFocus;
              end;
          end;
      end;
  end;
end;

procedure ddaline(x1,y1,x2,y2:integer;color:Tcolor);
var dx,dy,epsl,k,xi,yi:integer;
    xt,yt,xincre,yincre:single;
begin
   dx:=x2-x1;
   dy:=y2-y1;
   xt:=x1;
   yt:=y1;
   if abs(dx)>abs(dy)  then epsl:=abs(dx)
   else epsl:=abs(dy);
   if epsl=0 then form1.Image1.Canvas.Pixels[x1+x0,y0-y1]:=color
   else begin
   xincre:=dx/epsl;
   yincre:=dy/epsl;
   for k:=0 to epsl do
     begin
       xi:=round(xt+0.5)+x0;
       yi:=0-(round(yt+0.5)-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       xt:=xt+xincre;
       yt:=yt+yincre;
     end;
  end;
end;

procedure midbresenhamline(x1,y1,x2,y2:integer;color:Tcolor);
var dx,dy,d,upincre,downincre,xt,yt,xi,yi:integer;
begin
  if x1>x2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
  xt:=x1;yt:=y1;
  dx:=x2-x1;dy:=y2-y1;
  d:=dx-2*dy;
  upincre:=2*dx-2*dy;downincre:=-2*dy;
  while xt<=x2 do
  begin
       xi:=xt+x0;
       yi:=-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       xt:=xt+1;
       if d<0 then
       begin
         yt:=yt+1;
         d:=d+upincre;
       end
       else  d:=d+downincre;
  end;
end;

procedure midbresenhamline_2(x1,y1,x2,y2:integer;color:Tcolor);
var dx,dy,d,upincre,downincre,xt,yt,xi,yi:integer;
begin
  if y1>y2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
  yt:=y1;xt:=x1;
  dx:=x2-x1;dy:=y2-y1;
  d:=dy-2*dx;
  upincre:=2*dy-2*dx;downincre:=-2*dx;
  while yt<=y2 do
  begin
       xi:=xt+x0;
       yi:=-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       yt:=yt+1;
       if d<0 then
       begin
         xt:=xt+1;
         d:=d+upincre;
       end
       else  d:=d+downincre;
  end;
end;

procedure midbresenhamline_3(x1,y1,x2,y2:integer;color:Tcolor);
var dx,dy,d,upincre,downincre,xt,yt,xi,yi:integer;
begin
  if x2>x1  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
  xt:=x1;yt:=y1;
  dx:=x1-x2;dy:=y2-y1;
  d:=dx-2*dy;
  upincre:=2*dx-2*dy;downincre:=-2*dy;
  while xt>=x2 do
  begin
       xi:=xt+x0;
       yi:=-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       xt:=xt-1;
       if d<0 then
       begin
         yt:=yt+1;
         d:=d+upincre;
       end
       else  d:=d+downincre;
  end;
end;

procedure midbresenhamline_4(x1,y1,x2,y2:integer;color:Tcolor);
var dx,dy,d,upincre,downincre,xt,yt,xi,yi:integer;
begin
  if y1>y2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
  yt:=y1;xt:=x1;
  dx:=x1-x2;dy:=y2-y1;
  d:=dy-2*dx;
  upincre:=2*dy-2*dx;downincre:=-2*dx;
  while yt<=y2 do
  begin
       xi:=xt+x0;
       yi:=-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       yt:=yt+1;
       if d<0 then
       begin
         xt:=xt-1;
         d:=d+upincre;
       end
       else  d:=d+downincre;
  end;
end;


procedure bresenhmaline(x1,y1,x2,y2:integer;color:Tcolor);
var xt,yt,dx,dy,e,xi,yi:integer;
begin
  if x1>x2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
 dx:=x2-x1;
 dy:=y2-y1;
 e:=-dx;xt:=x1;yt:=y1;
 while xt<=x2 do
    begin
       xi:=xt+x0;
       yi:=0-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       xt:=xt+1;
       e:=e+2*dy;
       if e>0 then
         begin
           yt:=yt+1;
           e:=e-2*dx;
         end;
    end;
end;

procedure bresenhmaline_2(x1,y1,x2,y2:integer;color:Tcolor);
var xt,yt,dx,dy,e,xi,yi:integer;
begin
  if x1>x2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
 dx:=x2-x1;
 dy:=y2-y1;
 e:=-dy;xt:=x1;yt:=y1;
 while yt<=y2 do
    begin
       xi:=xt+x0;
       yi:=0-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       yt:=yt+1;
       e:=e+2*dx;
       if e>0 then
         begin
           xt:=xt+1;
           e:=e-2*dy;
         end;
    end;
end;

procedure bresenhmaline_3(x1,y1,x2,y2:integer;color:Tcolor);
var xt,yt,dx,dy,e,xi,yi:integer;
begin
  if x2>x1  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
 dx:=x1-x2;
 dy:=y2-y1;
 e:=-dx;xt:=x1;yt:=y1;
 while xt>=x2 do
    begin
       xi:=xt+x0;
       yi:=0-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       xt:=xt-1;
       e:=e+2*dy;
       if e>0 then
         begin
           yt:=yt+1;
           e:=e-2*dx;
         end;
    end;
end;

procedure bresenhmaline_4(x1,y1,x2,y2:integer;color:Tcolor);
var xt,yt,dx,dy,e,xi,yi:integer;
begin
  if y1>y2  then
     begin
       xt:=x2;x2:=x1;x1:=xt;
       yt:=y2;y2:=y1;y1:=yt;
     end;
 dx:=x1-x2;
 dy:=y2-y1;
 e:=-dy;xt:=x1;yt:=y1;
 while yt<=y2 do
    begin
       xi:=xt+x0;
       yi:=0-(yt-y0);
       form1.Image1.Canvas.Pixels[xi,yi]:=color;
       yt:=yt+1;
       e:=e+2*dx;
       if e>0 then
         begin
           xt:=xt-1;
           e:=e-2*dy;
         end;
    end;
end;

procedure paint_line(x1,y1,x2,y2:integer;color:Tcolor);
var k:single;
begin
 if c_line= 'd' then  ddaline(x1,y1,x2,y2,color);
              if c_line= 'b' then
                  begin
                     if x2-x1<>0 then
                      begin
                       k:=(y2-y1)/(x2-x1);
                       if (k>=0)and(k<=1) then midbresenhamline(x1,y1,x2,y2,color);
                       if (k>1) then midbresenhamline_2(x1,y1,x2,y2,color);
                       if (k>-1)and(k<0)then midbresenhamline_3(x1,y1,x2,y2,color);
                       if k<-1 then midbresenhamline_4(x1,y1,x2,y2,color);
                     end
                     else
                       midbresenhamline_2(x1,y1,x2,y2,color);
                  end;
              if c_line= 'g' then
                   begin
                     if x2-x1<>0 then
                      begin
                       k:=(y2-y1)/(x2-x1);
                       if (k>=0)and(k<=1) then  bresenhmaline(x1,y1,x2,y2,color);
                       if (k>1) then  bresenhmaline_2(x1,y1,x2,y2,color);
                       if (k>-1)and(k<0)then bresenhmaline_3(x1,y1,x2,y2,color);
                       if k<-1 then bresenhmaline_4(x1,y1,x2,y2,color);
                      end
                     else
                       bresenhmaline_2(x1,y1,x2,y2,color);
                   end;
end;

procedure draw_line();
begin
   with form1 do
   begin
      if label1.Caption='请输入命令：' then
      begin
         label1.Caption:='直线（d\b\g）:';
         edit1.Text:='';
         edit1.SetFocus;
      end
      else
       if label1.Caption='直线（d\b\g）:' then
        begin
         save_back();
         save_default();
         label1.Caption:='请输入第一点的横坐标：';
         c_line:=edit1.Text;
         edit1.Text:='';
         edit1.SetFocus;
        end
       else
        if label1.Caption='请输入第一点的横坐标：' then
        begin
          label1.Caption:='请输入第一点的纵坐标：';
          x1:=strtoint(edit1.Text);
          edit1.Text:='';
          edit1.SetFocus;
        end
        else
          if label1.Caption='请输入第一点的纵坐标：'  then
          begin
            label1.Caption:='请输入第二点的横坐标：';
            y1:=strtoint(edit1.Text);