computergraphicstest.~pas

计算机图形图像学基础算法实验软件包

//Designer: Jiang Xiangang    2004.8
unit ComputerGraphicsTest;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, StdCtrls, ExtCtrls,Math, ComCtrls, FractalImage, ExtDlgs;
const
   MaxPixelCount = 65536;
 type
   TReal = Single;
   pRGBTripleArray = ^TRGBTripleArray;
   TRGBTripleArray = array[0..MaxPixelCount - 1] of TRGBTriple;

type
  TComputerGrapicsMainForm = class(TForm)
    MainMenu1: TMainMenu;
    FileMain: TMenuItem;
    Chapter2: TMenuItem;
    Bresenhamslineforthefirstoctant1: TMenuItem;
    Label1: TLabel;
    DDA: TMenuItem;
    IntegerBresenhamsAlgorithm1: TMenuItem;
    Setapointincolor1: TMenuItem;
    ImageOriginal: TImage;
    ImageChanged: TImage;
    Changaimagescolor1: TMenuItem;
    GeneralizedIntegerBresenhamsAlgorithm1: TMenuItem;
    Simpleseedfillalgorithm: TMenuItem;
    Chaper3: TMenuItem;
    Clip1: TMenuItem;
    ImageCompression1: TMenuItem;
    Label2: TLabel;
    Label3: TLabel;
    RedUpDown: TUpDown;
    Label4: TLabel;
    Label5: TLabel;
    GreenUpDown: TUpDown;
    BlueUpDown: TUpDown;
    Label6: TLabel;
    SimpleParitypolygonscanconversionalgorithm2: TMenuItem;
    Chapter4: TMenuItem;
    FloatHorizonAlgorithm1: TMenuItem;
    ClearScreen: TMenuItem;
    Chaptyer5: TMenuItem;
    SimpleTrangleFractal1: TMenuItem;
    MappingTwodimensionalprojectivemapping1: TMenuItem;
    MappingCylindermapping1: TMenuItem;
    ZBuffer1: TMenuItem;
    ClearChangedImage1: TMenuItem;
    OpenPictureDialog1: TOpenPictureDialog;
    OpenOrignalImage1: TMenuItem;
    BreifImageCompression1: TMenuItem;
    ImageAmplication1: TMenuItem;
    IncreasePicturesLights1: TMenuItem;
    IncreaseLightbyRGB1: TMenuItem;
    IncreasePicturesLightSbyRGB1: TMenuItem;
    DecreasePicturesLightsbyHSL1: TMenuItem;
    Maskarangeofcolor1: TMenuItem;
    DrawLinesandCircleinRandomcolors1: TMenuItem;
    MaskarangeofcolorinRGB1: TMenuItem;
    helpMenu: TMenuItem;
    ClearImage: TMenuItem;
    ShowMemo: TMemo;
    Atialias: TMenuItem;
    TestImage1: TImage;
    TestImage2: TImage;
    PhongRender: TMenuItem;
    About: TMenuItem;

    procedure Bresenhamslineforthefirstoctant1Click(Sender: TObject);
    procedure RGBtoHSL(R, G, B: Integer; var H, S, L: Integer);
    procedure HSLtoRGB(H, S, L: Integer; var R, G, B: Integer);
    procedure DDAClick(Sender: TObject);
    procedure IntegerBresenhamsAlgorithm1Click(Sender: TObject);
    procedure Setapointincolor1Click(Sender: TObject);
    procedure Changaimagescolor1Click(Sender: TObject);
    procedure GeneralizedIntegerBresenhamsAlgorithm1Click(Sender: TObject);
    procedure SimpleseedfillalgorithmClick(Sender: TObject);
    procedure Clip1Click(Sender: TObject);
    procedure ImageCompression1Click(Sender: TObject);
    procedure RedUpDownClick(Sender: TObject; Button: TUDBtnType);
    procedure GetCodes(Sender: TObject;X:single;Y:single;j:Integer);
    procedure TriangleFractal(Sender: TObject;xa:Integer;
    ya:Integer;xb:Integer;yb:Integer;xc:Integer;yc:Integer;n:Integer);
    procedure ClipSubProgram(Sender: TObject;j:Integer);
    procedure SimpleParitypolygonscanconversionalgorithm1Click(
      Sender: TObject);
    procedure SimpleParitypolygonscanconversionalgorithm2Click(
      Sender: TObject);
    procedure FractalChaos1Click(Sender: TObject);
    procedure FloatHorizonAlgorithm1Click(Sender: TObject);
    procedure HideFractalandChaos1Click(Sender: TObject);
    procedure DrawSurfaceshowhideline1Click(Sender: TObject);
    procedure ClearScreenClick(Sender: TObject);
    procedure SimpleTrangleFractal1Click(Sender: TObject);
    procedure MappingTwodimensionalprojectivemapping1Click(
      Sender: TObject);
    procedure MappingCylindermapping1Click(Sender: TObject);
    procedure ZBuffer1Click(Sender: TObject);
    procedure ClearChangedImage1Click(Sender: TObject);
    procedure OpenOrignalImage1Click(Sender: TObject);
    procedure BreifImageCompression1Click(Sender: TObject);
    procedure ImageAmplication1Click(Sender: TObject);
    procedure DrawPointIndifferentcolor1Click(Sender: TObject);
    procedure IncreasePicturesLights1Click(Sender: TObject);
    procedure IncreaseLightbyRGB1Click(Sender: TObject);
    procedure IncreasePicturesLightSbyRGB1Click(Sender: TObject);
    procedure DecreasePicturesLightsbyHSL1Click(Sender: TObject);
    procedure Maskarangeofcolor1Click(Sender: TObject);
    procedure DrawLinesandCircleinRandomcolors1Click(Sender: TObject);
    procedure MaskarangeofcolorinRGB1Click(Sender: TObject);
    procedure ClearImageClick(Sender: TObject);
    procedure AtialiasClick(Sender: TObject);
    procedure PhongRenderClick(Sender: TObject);
    procedure AboutClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
   WLeft,WRight,WBottom,WTop:Integer;
   X,Y : Array [1..2] of Single;
   L : Array [1..2] of Integer;
   R : Array [1..2] of Integer;
   B : Array [1..2] of Integer;
   T : Array [1..2] of Integer;
   XY_Lines : Array [1..10,1..2,1..2] of Integer;

  ComputerGrapicsMainForm: TComputerGrapicsMainForm;

implementation

uses About;

{$R *.dfm}

procedure TComputerGrapicsMainForm.Bresenhamslineforthefirstoctant1Click(Sender: TObject);
var x,y,x1,y1,x2,y2,dx,dy,i:Integer;
    m,e:Single;
    xystring:string;
begin
   x1:=0;y1:=0;x2:=15;y2:=15;
   x:=x1;
   y:=y1;
   dx:=x2-x1;
   dy:=y2-y1;
   m:=dy/dx;
   e:=m-0.5;
   for i:=1 to dx do
   begin
   Canvas.Pixels [x,y]:= clRed;//用红线画图
   xystring:=inttostr(x)+','+inttostr(y);//
   ShowMemo.Lines.add(xystring);//显示X，Y坐标
   if e>0 then
      begin
       y:=y+1;
       e:=e-1;
      end;
          x:=x+1;
          e:=e+m;
    end;
end;
procedure TComputerGrapicsMainForm.DDAClick(Sender: TObject);
var X1,Y1,X2,Y2,Length,I:Integer;
    X,Y,Dx,Dy,SX,SY:Single;
    XYString:string;
begin
   X1:=0;Y1:=0;X2:=50;Y2:=50;SX:=20;SY:=400;
   if (Abs(X2-X1)>=Abs(Y2-Y1)) then
   Length:=Abs(x2-x1)
   else Length:=Abs(Y2-Y1);
   Dx:=(X2-X1)/length; Dy:=(Y2-Y1)/length;
   X:=X1+0.5; Y:=Y1+0.5;
   for I:=1 to Length do
       begin
   Canvas.Pixels [Trunc(SX+X),Trunc(SY-Y)]:= clRed;//用红色画线段
   XYString:=inttostr(Trunc(X))+','+IntToStr(Trunc(Y));
   ShowMemo.Lines.add(xystring);//显示X，Y坐标
   X:=X+Dx; Y:=Y+Dy;
       end;
end;

procedure TComputerGrapicsMainForm.IntegerBresenhamsAlgorithm1Click(
  Sender: TObject);
var X,Y,X1,Y1,X2,Y2,Dx,Dy,e_bar,I,SX,SY:Integer;
    XYString:string;
begin
   X1:=0;Y1:=0;X2:=30;Y2:=20;SX:=20;SY:=400;
   X:=X1; Y:=Y1;
   Dx:=X2-X1; Dy:=Y2-Y1;
   e_bar:=2*Dy-Dx;
   for I:=1 to Dx do
   begin
   Canvas.Pixels [SX+X,SY-Y]:= clRed;//用红色画线段
   XYString:=IntToStr(X)+','+IntToStr(Y);//
   ShowMemo.Lines.Add(XYString);//显示X，Y坐标
   if e_bar>0 then
      begin
       Y:=Y+1; e_bar:=e_bar-2*Dx;
      end;
       X:=X+1; e_bar:=e_bar+2*Dy;
    end;
end;

procedure TComputerGrapicsMainForm.Setapointincolor1Click(Sender: TObject);
var
 w,RedColorValue:Integer;
 ColorValue:TColor;
 ColorString:string;
begin
  for w:=0 to 15 do
  Canvas.Pixels[w,10]:=clRed;
  for w:=0 to 18 do
  begin
   ColorValue:=Canvas.Pixels[w,10]; //得到颜色值
   RedColorValue:=GetRvalue(ColorValue);//得到红色颜色值
   ColorString:=IntToStr(ColorToRGB(ColorValue))+','+IntToStr(RedColorValue);
   ShowMemo.Lines.add(ColorString)
  end;
end;

procedure TComputerGrapicsMainForm.Changaimagescolor1Click(
  Sender: TObject);
  var
 w,h,RedColorValue,GreenColorValue,
 ColorValue,BlueColorValue:Integer;
 ColorString:string;
begin
  for w:=0 to ImageOriginal.width do
      for h:=0 to ImageOriginal.Height do
  begin
   ColorValue:=ImageOriginal.Canvas.Pixels[w,h];
   RedColorValue:=GetRvalue(ImageOriginal.Canvas.Pixels[w,h]);//得到红色颜色值
   GreenColorValue:=GetGvalue(ImageOriginal.Canvas.Pixels[w,h]);//得到绿色颜色值
   BlueColorValue:=GetBvalue(ImageOriginal.Canvas.Pixels[w,h]);//得到兰色颜色值
   ImageChanged.Canvas.Pixels[w,h]:=
   RGB(RedColorValue+RedUpdown.Position,GreenColorValue+GreenUpdown.Position,BlueColorValue+BlueUpdown.Position);
  end;
end;

procedure TComputerGrapicsMainForm.GeneralizedIntegerBresenhamsAlgorithm1Click(
  Sender: TObject);
var X,Y,X1,Y1,X2,Y2,Dx,Dy,e_bar,I,SX,SY,
    Temp,Interchange,S1,S2:Integer;
    XYString:string;
begin
   X1:=0;Y1:=0;X2:=-30;Y2:=-20;SX:=200;SY:=400;
   X:=X1;  Y:=Y1;
   Dx:=abs(X2-X1);  Dy:=Abs(Y2-Y1);
   S1:=Sign(X2-X1); S2:=Sign(Y2-Y1);
   if Dy>Dx then
   begin
   Temp:=Dx; Dx:=Dy;Dy:=Temp;
   Interchange:=1;
   end else  Interchange:=0;
    e_bar:=2*dy-dx;
     for i:=1 to dx do
   begin
   Canvas.Pixels [SX+X,SY-Y]:= clRed;//用红色画线段
   XYString:=IntToStr(X)+','+IntToStr(Y);
   ShowMemo.Lines.Add(XYString);//显示X，Y坐标
   if e_bar>0 then
          begin
       if Interchange=1 then
       X:=X+S1 else Y:=Y+S2;
       e_bar:=e_bar-2*Dx;
          end;
     if Interchange=1 then
         Y:=Y+S2 else X:=X+S1;
         e_bar:=e_bar+2*Dy;
    end;
end;

procedure TComputerGrapicsMainForm.SimpleSeedFillAlgorithmClick(
  Sender: TObject);
var i,x,y,FillingColor,BoundaryColor:Integer;
  StackPixel : Array [1..10000,1..3] of Integer;
  xystring:string;
  begin
  //画边界线条
  Canvas.MoveTo(10,10); Canvas.LineTo(80,10);
  Canvas.LineTo(80,40); Canvas.LineTo(60,60);
  Canvas.LineTo(10,60); Canvas.LineTo(10,10);
  Canvas.Ellipse(15,15,25,45);
  FillingColor:=clRed;          //填充颜色为红色
  BoundaryColor:=clBlack;  //边界颜色为黑色
  i:=1;
  x:=40;y:=30;         //种子点坐标
  StackPixel[i,1]:=x; // 堆栈中压入填充种子点
  StackPixel[i,2]:=y;
  while i>0  do
  begin
   //x,y弹出堆栈;
    x:=Stackpixel[i,1];y:=Stackpixel[i,2];
    xystring:=inttostr(x)+','+inttostr(y)+'   i='+inttostr(i);//
    ShowMemo.Lines.add(xystring);//显示出栈的x,y坐标
    Canvas.Pixels[Stackpixel[i,1],Stackpixel[i,2]]:=FillingColor;
    i:=i-1;
  // 填充点向右移动
  if (Canvas.Pixels[x+1,y]<>FillingColor) and
     (Canvas.Pixels[x+1,y]<>BoundaryColor) then
     begin
      i:=i+1;
      Stackpixel[i,1]:=x+1;
      Stackpixel[i,2]:=y;
     end;
  // 填充点向上移动
   if (Canvas.Pixels[x,y+1]<>FillingColor) and
     (Canvas.Pixels[x,y+1]<>BoundaryColor) then
     begin
      i:=i+1;
      Stackpixel[i,1]:=x;
      Stackpixel[i,2]:=y+1;
     end;
  //填充点向左移动
  if (Canvas.Pixels[x-1,y]<>FillingColor) and
     (Canvas.Pixels[x-1,y]<>BoundaryColor) then
     begin
      i:=i+1;
      Stackpixel[i,1]:=x-1;
      Stackpixel[i,2]:=y;
     end;
 // 填充点向下移动
  if (Canvas.Pixels[x,y-1]<>FillingColor) and
     (Canvas.Pixels[x,y-1]<>BoundaryColor) then
      begin
      i:=i+1;
      Stackpixel[i,1]:=x;
      Stackpixel[i,2]:=y-1;
      end;