computergraphicstest.pas

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

   L := Round(Lum * 100);
end;
procedure TComputerGrapicsMainForm.HSLtoRGB(H, S, L: Integer; var R, G, B: Integer);
var
   Sat, Lum: Double;
begin
   R := 0;
   G := 0;
   B := 0;
   if (H < 360) and (H >= 0) and (S <= 100) and (S >= 0) and (L <= 100) and (L
      >=
      0) then
      begin
         if H <= 60 then
            begin
               R := 255;
               G := Round((255 / 60) * H);
               B := 0;
            end
         else if H <= 120 then
            begin
               R := Round(255 - (255 / 60) * (H - 60));
               G := 255;
               B := 0;
            end
         else if H <= 180 then
            begin
               R := 0;
               G := 255;
               B := Round((255 / 60) * (H - 120));
            end
         else if H <= 240 then
            begin
               R := 0;
               G := Round(255 - (255 / 60) * (H - 180));
               B := 255;
            end
         else if H <= 300 then
            begin
               R := Round((255 / 60) * (H - 240));
               G := 0;
               B := 255;
            end
         else if H < 360 then
            begin
               R := 255;
               G := 0;
               B := Round(255 - (255 / 60) * (H - 300));
            end;

         Sat := Abs((S - 100) / 100);
         R := Round(R - ((R - 128) * Sat));
         G := Round(G - ((G - 128) * Sat));
         B := Round(B - ((B - 128) * Sat));

         Lum := (L - 50) / 50;
         if Lum > 0 then
            begin
               R := Round(R + ((255 - R) * Lum));
               G := Round(G + ((255 - G) * Lum));
               B := Round(B + ((255 - B) * Lum));
            end
         else if Lum < 0 then
            begin
               R := Round(R + (R * Lum));
               G := Round(G + (G * Lum));
               B := Round(B + (B * Lum));
            end;
      end;
end;

procedure TComputerGrapicsMainForm.IncreaseLightbyRGB1Click(
  Sender: TObject);
begin
    RedUpdown.Position:=RedUpdown.Position+5;
    GreenUpdown.Position:=RedUpdown.Position+5;
    BlueUpdown.Position:=RedUpdown.Position+5;
    Changaimagescolor1Click(Sender); 
end;

procedure TComputerGrapicsMainForm.IncreasePicturesLightSbyRGB1Click(
  Sender: TObject);
begin
     RedUpdown.Position:=RedUpdown.Position-5;
     GreenUpdown.Position:=RedUpdown.Position-5;
     BlueUpdown.Position:=RedUpdown.Position-5;
     Changaimagescolor1Click(Sender);
end;

procedure TComputerGrapicsMainForm.DecreasePicturesLightsbyHSL1Click(
  Sender: TObject);
var
   bmp: TBITMAP;
   x, y, ScanlineBytes: Integer;
   p: prgbtriplearray;
   RVALUE, bvalue, gvalue: Integer;
   hVALUE, sVALUE, lVALUE: Integer;
begin
   self.DoubleBuffered := true; //设置双缓冲
   bmp := TBITMAP.Create;
   bmp.Assign(ImageOriginal.Picture.Bitmap);//加载位图
   bmp.PixelFormat := pf24bit; //指定为24位
   p := bmp.ScanLine[0];
   ScanlineBytes := Integer(bmp.ScanLine[1]) - Integer(bmp.ScanLine[0]);
   //获取两行间距，此法只需执行Scanline两次，速度快，是优化的
   for y := 0 to bmp.Height - 1 do
      begin
         for x := 0 to bmp.Width - 1 do
            begin
               //获取RGB的三个分量值，并进行赋值
               RVALUE := p[x].rgbtRed;
               gVALUE := p[x].rgbtGreen;
               bVALUE := p[x].rgbtBlue;
               // 调用前面的RGB转HSL过程，获取HSL三个分量值
               RGBtoHSL(RVALUE, gVALUE, bVALUE, hVALUE, sVALUE, lVALUE);
               //亮度值进行线性调节。
               lVALUE := lVALUE - 20;
               lVALUE := min(100, lVALUE);
           //调用前面的HSL空间转RGB颜色空间的过程，获得RGB三个分量
               HSLtoRGB(hVALUE, sVALUE, lVALUE, rVALUE, gVALUE, bVALUE);
               p[x].rgbtRed := RVALUE;
               p[x].rgbtGreen := gVALUE;
               p[x].rgbtBlue := bVALUE;
            end;
         inc(Integer(p), ScanlineBytes);   //指针递增
      end;
    ImageChanged.Picture.Bitmap.Assign(bmp);
   Bmp.Free;
end;

procedure TComputerGrapicsMainForm.Maskarangeofcolor1Click(
  Sender: TObject);
var
   bmp: TBITMAP;
   x, y, ScanlineBytes: Integer;
   p: prgbtriplearray;
   RVALUE, bvalue, gvalue: Integer;
   hVALUE, sVALUE, lVALUE: Integer;
begin
   self.DoubleBuffered := true;  //设置双缓冲
   bmp := TBITMAP.Create;
   bmp.Assign(ImageOriginal.Picture.Bitmap); //加载位图
   bmp.PixelFormat := pf24bit;   //指定为24位
   p := bmp.ScanLine[0];
   ScanlineBytes := Integer(bmp.ScanLine[1]) - Integer(bmp.ScanLine[0]);
   //获取两行间距，此法只需执行Scanline两次，速度快，是优化的
   for y := 0 to bmp.Height - 1 do
      begin
         for x := 0 to bmp.Width - 1 do
            begin
               //获取RGB的三个分量值，并进行赋值
               RVALUE := p[x].rgbtRed;
               gVALUE := p[x].rgbtGreen;
               bVALUE := p[x].rgbtBlue;
               // 调用前面的RGB转HSL过程，获取HSL三个分量值
               RGBtoHSL(RVALUE, gVALUE, bVALUE, hVALUE, sVALUE, lVALUE);
             //调用前面的HSL空间转RGB颜色空间的过程，获得RGB三个分量
              if ((hVALUE>=0) and (hVALUE<=120)) then   hVALUE:=hVALUE
              else hVALUE:=360;
               HSLtoRGB(hVALUE, sVALUE, lVALUE, rVALUE, gVALUE, bVALUE);
               p[x].rgbtRed := RVALUE;
               p[x].rgbtGreen := gVALUE;
               p[x].rgbtBlue := bVALUE;
            end;
         inc(Integer(p), ScanlineBytes);   //指针递增
      end;
    ImageChanged.Picture.Bitmap.Assign(bmp);
   Bmp.Free;
end;

procedure TComputerGrapicsMainForm.DrawLinesAndCircleInRandomColors1Click(
  Sender: TObject);
var
 Number,X1,Y1,X2,Y2,R:Integer;
begin
  for number:=0 to 1000 do
  begin
     X1:=Random(800);
     Y1:=Random(600);
     X2:=Random(800);
     Y2:=Random(600);
  Canvas.Pen.Color:= RGB(Random(255),Random(255),Random(255));
  Canvas.Moveto(x1,y1);
  Canvas.Lineto(x2,y2);
  End;
  for number:=0 to 500 do
    begin
     R:=Random(40);
     X1:=Random(800);
     Y1:=Random(600);
    X2:=x1+R;
     Y2:=y1+R;
  Canvas.Pen.Color:= RGB(Random(255),Random(255),Random(255));
  Canvas.Ellipse(x1,y1,x2,y2);
  end;
end;
procedure TComputerGrapicsMainForm.MaskarangeofcolorinRGB1Click(
  Sender: TObject);
 var
 w,h,RedColorValue,GreenColorValue,
 ColorValue,BlueColorValue:Integer;
 ColorString:string;
begin
  for w:=0 to 150 do
      for h:=0 to 150 do
  begin
   ColorValue:=ImageOriginal.Canvas.Pixels[w,h];//得到红色颜色值
   GreenColorValue:=GetGvalue(ImageOriginal.Canvas.Pixels[w,h]);//得到绿色颜色值
   BlueColorValue:=GetBvalue(ImageOriginal.Canvas.Pixels[w,h]);//得到蓝色颜色值
   if  (RedColorValue>10) and (RedColorValue<200) then RedColorValue:=0;
   ImageChanged.Canvas.Pixels[w,h]:=
   RGB(RedColorValue,GreenColorValue,BlueColorValue);
  end;

end;

procedure TComputerGrapicsMainForm.ClearImageClick(Sender: TObject);
begin
    ImageOriginal.picture:=nil;
end;

procedure TComputerGrapicsMainForm.AtialiasClick(Sender: TObject);
var
  X,Y,I,J,ColorValue,Scale:Integer;
  SubAreaTotalR, SubAreaTotalG, SubAreaTotalB, R,G,B : Integer;
begin
  Scale:=3; //虚拟放大倍数
with TestImage1.Canvas do
   begin   //以实际尺寸画图
    Pen.Width:=3;
    Brush.Color:=clYellow;
    Ellipse(30,30,80,80);
    MoveTo(20,20);Lineto(80,90);
end;
    with TestImage2.Canvas do
    begin   //以虚拟放大尺寸画图
     Pen.Width:=3*Scale;
     Brush.Color:=clYellow;
     Ellipse(30*Scale,30*Scale,80*Scale,80*Scale);
     MoveTo(20*Scale,20*Scale);Lineto(80*Scale,90*Scale);
end;
     for Y := 0 to TestImage1.Height - 1 do
  begin
      for X := 0 to TestImage1.Width - 1 do
    begin
      SubAreaTotalR := 0;SubAreaTotalG := 0; SubAreaTotalB := 0;
       for I := 0 to Scale-1 do
      begin
        for J := 0 to Scale-1 do
        begin
          ColorValue:=TestImage2.Canvas.Pixels[(X*Scale) + J, (Y*Scale) + I];
          R := Byte(ColorValue); G := Byte(ColorValue Shr 8);
          B := Byte(ColorValue Shr 16);
          SubAreaTotalR := SubAreaTotalR + R;
          SubAreaTotalG := SubAreaTotalG + G;
          SubAreaTotalB := SubAreaTotalB + B;
        end;
      end;
    ImageChanged.Canvas.Pixels[X,Y] := RGB(SubAreaTotalr div (Scale*Scale),
    SubAreaTotalg div (Scale*Scale), SubAreaTotalb div (Scale*Scale));
    end;
  end;
end;

procedure TComputerGrapicsMainForm.PhongRenderClick(Sender: TObject);
const
  xs=350; ys=100; zs=800;  xe=350; ye=500;  ze=900;
  kd=0.01; ks=1-kd; ka=1.0;n=3;Rc=100;//球的半径
var
  x,y,z,LightIntensity,Intensity_XY : Double;
  x_1,y_1,z_1,xsr,ysr,zsr : Double	;
  Nr,NN,Nsr,Ne : array[0..2] of Double;
  NrN,NsrNe,absN,absNr,absNsr,absNe : Double;
  Costheta,Cosalpha : Double;
  xc,yc,zc,xb,yb : Double;
  DistToCenter : Double;
  M,XX,YY,Intensity: Integer;
begin
  LightIntensity:=round(255.0/2.5);
  Zc:=0; Xc:=150; Yc:=150;//球的中心坐标
    begin
      Xb:=Xc-Rc; //X向逐点计算
      while Xb<(Xc+Rc) do
      begin
        Yb:=Yc-Rc; //Y向逐点计算
        while Yb<(Yc+Rc) do
        begin  //计算点到球心的距离
          DistToCenter:=Sqrt(power((Xb-Xc),2)+Power((Yb-Yc),2));
          if DistToCenter<=Rc then
          begin
            X:=Xb;Y:=Yb;Z:=sqrt(power(Rc,2)-power(DistToCenter,2));
            Nr[0]:=Xs-X;Nr[1]:=Ys-y;Nr[2]:=Zs-z;
	          NN[0]:=X-Xc;NN[1]:=Y-yc;NN[2]:=Z-zc;
	          Ne[0]:=Xe-X;Ne[1]:=Ye-y;Ne[2]:=Ze-z;
            NrN:=0;
	    for m:=0 to 2 do  //计算法线向量
          NrN:=NrN+Nr[m]*NN[m];
	        absNr:=Sqrt(power(Nr[0],2)+Power(Nr[1],2)+Power(Nr[2],2));
	        absN:=Sqrt(power(NN[0],2) +Power(NN[1],2) +Power(NN[2],2));
          costheta:=NrN/(absNr*absN); //计算法线的角度
            Y_1:=NrN*(Y-yc)/Power(absN,2)+Y;
	          X_1:=NrN*(x-xc)/power(absN,2)+X;
	          Z_1:=NrN*(z-zc)/power(absN,2)+Z;
	          Xsr:=2*x_1-xs;ysr:=2*y_1-ys;
            Zsr:=2*z_1-zs;
	    Nsr[0]:=xsr-x;Nsr[1]:=ysr-x;Nsr[2]:=zsr-z;
	    NsrNe:=0;
            for m:=0 to 2 do
   	        NsrNe:=NsrNe+Nsr[m]*Ne[m];
            absNsr:=sqrt(power(Nsr[0],2)+power(Nsr[1],2)+power(Nsr[2],2));
            absNe:=sqrt(power(Ne[0],2) +power(Ne[1],2)+power(Ne[2],2));
	    cosalpha:=NsrNe/(absNsr*absNe); //计算光线的角度
	    Intensity_XY:=LightIntensity*(ka+kd*costheta+ks*power(cosalpha,n));
            XX:=round(x);YY:=round(y); //投影点的X，Y坐标
            Intensity:=round(Intensity_XY); //以计算得到的点的亮度画图
            ImageChanged.Canvas.pixels[XX,YY]:=RGB(Intensity,Intensity,Intensity);
          end;
          Yb:=Yb+1; //X向逐点计算
        end;
          Xb:=Xb+1; //Y向逐点计算
      end;
    end;
end;
procedure TComputerGrapicsMainForm.AboutClick(Sender: TObject);
begin
 AboutForm.Show;
end;

end.