computergraphicstest.~pas

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

  end;
end;

procedure TComputerGrapicsMainForm.Clip1Click(Sender: TObject);
var
    I,J,Outside,Clip:Integer;
    XYString:string;
    Label Tryagain,NextLine;
begin  //窗口的坐标
  WLeft:=90;WRight:=270;WBottom:=40;WTop:=160;
   //x坐标                    y坐标
  XY_Lines[1,1,1]:=110;  XY_Lines[1,1,2]:=10;
  XY_Lines[1,2,1]:=290;  XY_Lines[1,2,2]:=70;
  XY_Lines[2,1,1]:=160;  XY_Lines[2,1,2]:=10;
  XY_Lines[2,2,1]:=160;  XY_Lines[2,2,2]:=180;
  XY_Lines[3,1,1]:=110;  XY_Lines[3,1,2]:=50;
  XY_Lines[3,2,1]:=220;  XY_Lines[3,2,2]:=100;
  XY_Lines[4,1,1]:=80;   XY_Lines[4,1,2]:=50;
  XY_Lines[4,2,1]:=60;   XY_Lines[4,2,2]:=100;
  Canvas.Pen.Color := clRed;// //用红色画待裁剪的线段
  For I:=1 to 4 do
  begin
  Canvas.MoveTo(10+XY_Lines[i,1,1],400-XY_Lines[i,1,2]);
  Canvas.LineTo(10+XY_Lines[i,2,1],400-XY_Lines[i,2,2]);
  end;
  Canvas.Pen.Color := clYellow;//用黄色画窗口边界
  Canvas.MoveTo(10+WLeft,400-WBottom);  Canvas.LineTo(10+WRight,400-WBottom);
  Canvas.MoveTo(10+WRight,400-WBottom); Canvas.LineTo(10+WRight,400-WTop);
  Canvas.MoveTo(10+WRight,400-WTop);Canvas.LineTo(10+WLeft,400-WTop);
  Canvas.MoveTo(10+WLeft,400-WTop); Canvas.LineTo(10+WLeft,400-WBottom);
  for I:=1 to 4 do
  begin
  for J:=1 to 2 do
  begin
   X[J]:=XY_Lines[I,J,1];Y[J]:=XY_Lines[I,J,2];
   GetCodes(Sender,X[j],Y[j],j);//检查线段的段点是否在窗口外
   XYString:=IntToStr(L[j])+','+IntToStr(R[J])+ ','
             +IntToStr(B[J])+','+IntToStr(T[j]);
        ShowMemo.Lines.add(XYString);//显示X，Y坐标
   end;
   for J:=1 to 2 do
   begin
   Tryagain:
   Outside:=L[1]*L[2]+R[1]*R[2]+B[1]*B[2]+T[1]*T[2];
   if Outside<>0 then goto NextLine;
   if Outside=0 then    //线段在窗口内
     begin
    Clip:=L[J]+R[J]+B[J]+T[J];
    if Clip<>0 then    //获得线段被裁剪的新坐标
          begin
   ClipSubProgram(Sender,J);goto tryagain;
          end;
      end;
    end;
    Canvas.Pen.Color:=clBlue; //用蓝色画窗口内的线段
    Canvas.MoveTo(10+Trunc(X[1]),400-Trunc(Y[1]));
    Canvas.LineTo(10+Trunc(X[2]),400-Trunc(Y[2]));
   NextLine:
   end;
end;

procedure TComputerGrapicsMainForm.ImageCompression1Click(Sender: TObject);
 var W,H,oldw,OldColorValue,NewColorValue,Runlength,i,index:Integer;
 CompressionArray : Array [1..200000,1..3] of Integer;
 XYString:string;
 begin
  I:=0;  RunLength:=1;
  for W:=0 to ImageOriginal.Width do
      for H:=0 to ImageOriginal.Height do
   begin
    NewColorValue:=ImageOriginal.Canvas.Pixels[H,W];
    if (OldColorValue<>NewColorValue) and (h<>0)  then
    begin
     I:=I+1;
     CompressionArray[I,1]:=W;
     CompressionArray[I,2]:=Runlength;
     CompressionArray[I,3]:=oldColorValue;
     Runlength:=1;
     end else  runlength:=RunLength+1;
      if h=0 then runlength:=1;
      if h=ImageOriginal.Width then //不要忘记最后一点
      begin   //将图像压入数组
     I:=I+1;
     CompressionArray[I,1]:=W;// Y值
     CompressionArray[I,2]:=Runlength;//行程值
     CompressionArray[I,3]:=NewColorValue;// 颜色值
     RunLength:=1;
      end;
       OldColorValue:=NewColorValue;
      end;
   //显示Y，行程和颜色值
     for Index:=1 to I do
       begin
       XYString:=IntToStr(CompressionArray[Index,1])
       +','+IntToStr(CompressionArray[Index,2])+
       ','+IntToStr(CompressionArray[Index,3]);//
       ShowMemo.Lines.add(XYString);//显示Y，行程和颜色值
       end;
       H:=0;
    for index:=1 to I do //从压缩数组中弹出数组并显示图像
        begin
        w:=CompressionArray[Index,1];//Y coordinates
        if oldw<>w then h:=0; //新的扫描线
       for i:=h to h+CompressionArray[Index,2] do
       ImageChanged.Canvas.Pixels[i,W]:= CompressionArray[Index,3];
       h:=h+CompressionArray[Index,2]; //增加X坐标
       oldw:=w; //记老的扫描线坐标
     end;
end;

procedure TComputerGrapicsMainForm.RedUpDownClick(Sender: TObject;
  Button: TUDBtnType);
begin
   Changaimagescolor1Click(Sender);
end;
procedure TComputerGrapicsMainForm.GetCodes(Sender: TObject;X:single;
y:single;j:Integer);
begin
   L[j]:=0;R[j]:=0;B[j]:=0;T[j]:=0;
   if  x<WLeft then L[j]:=1;
   if  x>WRight then R[j]:=1;
   if  y<WBottom then B[j]:=1;
   if  Y>WTop then T[j]:=1;
end;
procedure TComputerGrapicsMainForm.ClipSubProgram(Sender: TObject;j:Integer);
begin
if L[j]=1 then
begin
  y[j]:=y[1]+((y[2]-y[1])*(WLeft-x[1]))/(x[2]-x[1]);x[j]:=WLeft;
  GetCodes(Sender,x[j],y[j],j);
  end;
  if R[j]=1 then
begin
  y[j]:=y[1]+((y[2]-y[1])*(WRight-x[1]))/(x[2]-x[1]);x[j]:=WRight;
  GetCodes(Sender,x[j],y[j],j);
  end;
  if B[j]=1 then
begin
  X[j]:=X[1]+((X[2]-X[1])*(WBottom-Y[1]))/(Y[2]-Y[1]);Y[j]:=WBottom;
  GetCodes(Sender,x[j],y[j],j);
  end;
  if T[j]=1 then
begin
  X[j]:=X[1]+((X[2]-X[1])*(WTop-Y[1]))/(Y[2]-Y[1]);Y[j]:=WTop;
  GetCodes(Sender,x[j],y[j],j);
end;
end;

procedure TComputerGrapicsMainForm.SimpleParitypolygonscanconversionalgorithm1Click(
  Sender: TObject);
var i,K,L,Parity,x,y,xmin,xmax,ymin,ymax,OldColorValue,
ColorValue1,ColorValue2,ColorValue3,ColorValue4,
ColorValue5,ColorValue6,ColorValue:Integer;
begin
 //x 坐标                 y  坐标
  XY_Lines[1,1,1]:=10;  XY_Lines[1,1,2]:=10;
  XY_Lines[1,2,1]:=80;  XY_Lines[1,2,2]:=10;
  XY_Lines[2,1,1]:=80;  XY_Lines[2,1,2]:=10;
  XY_Lines[2,2,1]:=80;  XY_Lines[2,2,2]:=60;
  XY_Lines[3,1,1]:=80;  XY_Lines[3,1,2]:=60;
  XY_Lines[3,2,1]:=50;  XY_Lines[3,2,2]:=30;
  XY_Lines[4,1,1]:=50;  XY_Lines[4,1,2]:=30;
  XY_Lines[4,2,1]:=10;  XY_Lines[4,2,2]:=70;
  XY_Lines[5,1,1]:=10;  XY_Lines[5,1,2]:=70;
  XY_Lines[5,2,1]:=10;  XY_Lines[5,2,2]:=10;
  Canvas.Pen.Color:=255;
  For i:=1 to 5 do
  begin
  Canvas.MoveTo(10+XY_Lines[i,1,1],400-XY_Lines[i,1,2]);
  Canvas.LineTo(10+XY_Lines[i,2,1],400-XY_Lines[i,2,2]);
  end;
  //get xmin,xmax,ymin,ymax
  xmin:=10;xmax:=80;ymin:=10;ymax:=70;
  Parity:=0;
  for y:=ymin+1 to ymax-1 do
   begin
    Parity:=0;
  for x:=xmin to xmax do
  begin
  K:=0;L:=0;
  ColorValue:=Canvas.Pixels[10+x,400-y];
  ColorValue1:=Canvas.Pixels[10+x+1,400-y+1];
  ColorValue2:=Canvas.Pixels[10+x-1,400-y+1];
 ColorValue3:=Canvas.Pixels[10+x,400-y+1];
  ////////////////////////////////////////
  ColorValue4:=Canvas.Pixels[10+x+1,400-y-1];
  ColorValue5:=Canvas.Pixels[10+x-1,400-y-1];
  ColorValue6:=Canvas.Pixels[10+x,400-y-1];
  if (ColorValue1=255) AND (ColorValue2=255) then K:=K+1;
  if (ColorValue2=255) AND (ColorValue3=255) then K:=K+1;
  if (ColorValue3=255) AND (ColorValue1=255) then K:=K+1;
  /////////////////////////
  if (ColorValue4=255) AND (ColorValue5=255) then L:=L+1;
  if (ColorValue5=255) AND (ColorValue6=255) then L:=L+1;
  if (ColorValue6=255) AND (ColorValue4=255) then L:=L+1;
 if ColorValue=255 then parity:=parity+1;
  IF (K=0) AND  (L<>0) THEN Parity:=1;
  IF (L=0) AND  (K<>0) THEN Parity:=1;
   if parity>1 then parity:=0;
     if (parity=1) and (ColorValue<>255) then
  begin
   Canvas.Pixels[10+x,400-y]:=clYellow;
  end;
   OldColorValue:=ColorValue;K:=0;L:=0;
  end;
  end;
end;

procedure TComputerGrapicsMainForm.SimpleParitypolygonscanconversionalgorithm2Click(
  Sender: TObject);
var  I,UpperMax,DownMin,Parity,x,y,xmin,xmax,ymin,ymax,
     ColorValue1,ColorValue2,ColorValue3,ColorValue4, ColorValue5,ColorValue6,
     ColorValue,CurrentPointRightColorvalue,SX,SY:Integer;
     XColorChangeNum,XScanMax:Array [1..100] of Integer;
begin
   SX:=10;SY:=400; //世界坐标与屏幕坐标的转换
 //多边形的x 坐标          y 坐标
  XY_Lines[1,1,1]:=10;  XY_Lines[1,1,2]:=10;
  XY_Lines[1,2,1]:=80;  XY_Lines[1,2,2]:=20;
  XY_Lines[2,1,1]:=80;  XY_Lines[2,1,2]:=20;
  XY_Lines[2,2,1]:=75;  XY_Lines[2,2,2]:=60;
  XY_Lines[3,1,1]:=75;  XY_Lines[3,1,2]:=60;
  XY_Lines[3,2,1]:=50;  XY_Lines[3,2,2]:=30;
  XY_Lines[4,1,1]:=50;  XY_Lines[4,1,2]:=30;
  XY_Lines[4,2,1]:=15;  XY_Lines[4,2,2]:=70;
  XY_Lines[5,1,1]:=15;  XY_Lines[5,1,2]:=70;
  XY_Lines[5,2,1]:=10;  XY_Lines[5,2,2]:=10;
  Canvas.Pen.Color:=255;//用红色画多边形
  For I:=1 to 5 do //多边形共5条边
  begin
  Canvas.MoveTo(SX+XY_Lines[i,1,1],SY-XY_Lines[i,1,2]);
  Canvas.LineTo(SX+XY_Lines[i,2,1],SY-XY_Lines[i,2,2]);
  end;  //获得多边形的最大最小边界
  xmin:=8;xmax:=90;ymin:=5;ymax:=90;
   for Y:=Ymin+1 to Ymax-1 do
      begin
         Parity:=0; XColorChangeNum[Y]:=0;XScanMax[Y]:=0;
     for x:=xmin to xmax do
    begin
    ColorValue:=Canvas.Pixels[SX+X,SY-Y];
    If (ColorValue=255) AND (Canvas.Pixels[SX+X+1,SY-Y]<>255) then
      begin
    XColorChangeNum[Y]:=XColorChangeNum[Y]+1;XScanMax[Y]:=SX+X;
     end;
    end;
     for X:=Xmin to Xmax do
  begin
     UpperMax:=0;DownMin:=0;ColorValue:=Canvas.Pixels[SX+x,(SY-y)];
     //记录和判断可能的谷值
     ColorValue1:=Canvas.Pixels[SX+x+1,SY-(y+1)];
     ColorValue2:=Canvas.Pixels[SX+x-1,SY-(y+1)];
     ColorValue3:=Canvas.Pixels[SX+x,SY-(y+1)];
     //记录和判断可能的峰值
     ColorValue4:=Canvas.Pixels[SX+x+1,SY-(y-1)];
     ColorValue5:=Canvas.Pixels[SX+x-1,SY-(y-1)];
     ColorValue6:=Canvas.Pixels[SX+x,SY-(y-1)];
     CurrentPointRightColorvalue:=Canvas.Pixels[SX+x+1,SY-y];
  if (ColorValue1=255) AND (ColorValue2=255)and (ColorValue=255)  then UpperMax:=UpperMax+1 ;
  if (ColorValue2=255) AND (ColorValue3=255) and (ColorValue=255) then UpperMax:=UpperMax+1;
  If (ColorValue3=255) AND (ColorValue1=255) and (ColorValue=255) then UpperMax:=UpperMax+1;
  if (ColorValue4=255) AND (ColorValue5=255)and (ColorValue=255)  then DownMin:=DownMin+1;
  if (ColorValue5=255) AND (ColorValue6=255)and (ColorValue=255)  then DownMin:=DownMin+1;
  if (ColorValue6=255) AND (ColorValue4=255)and (ColorValue=255)  then DownMin:=DownMin+1;
 if (ColorValue=255) and (CurrentPointRightColorvalue<>255)  then Parity:=Parity+1;
 if  (DownMin>0) and (CurrentPointRightColorvalue<>255) and (ColorValue1<>255) and (ColorValue2<>255) and (ColorValue3<>255)THEN Parity:=Parity+1;
 if  (UpperMax>0) and (CurrentPointRightColorvalue<>255) and (ColorValue4<>255) and (ColorValue5<>255) and (ColorValue6<>255) THEN Parity:=Parity+1;
     if (Odd(parity)) and (XColorChangeNum[Y]>1) and (ColorValue<>255)and ((SX+X)<=XScanMax[Y]) then
   Canvas.Pixels[SX+x,SY-y]:=clYellow; UpperMax:=0;DownMin:=0;
     end;
  end;
end;

procedure TComputerGrapicsMainForm.FractalChaos1Click(Sender: TObject);
begin
 // Fractalimage1.active:=true;
  // Fractalimage1.visible:=true;
end;

procedure TComputerGrapicsMainForm.FloatHorizonAlgorithm1Click(
  Sender: TObject);
var Xcenter,Ycenter,Lastpoint,
  Element,I,J,XScreen,YScreen,X,XFirst,XLast,PenChanged:Integer;
  BiggestY,SmallestY: Array [1..1000] of Single;
  Height,XscreenAdjust,YscreenAdjust,Y,Z,Frequency:Double;
  Label XFinish,DrawSubprgram;
 begin
  Height:=20.0;Frequency:=0.03;XFirst:=-100;XLast:=240;Lastpoint:=1;
  XCenter:=350;YCenter:=300;
  //初始化记录最大和最小Y值的数组
  for Element:=1 to 800 do
  begin
  BiggestY[Element]:=0;SmallestY[Element]:=1000;
  end;
  for I:=-25 to 25   do
  begin
  Z:=I*5;
  XScreenAdjust:=XCenter+0.75*Z;     //产生轴测图的效果
  YScreenAdjust:=480-(YCenter+0.5*Z);//将计算的结果投影到屏幕的X，Y坐标上
for x:=XFirst to  XLast do
     begin
      Y:=Height*sin(Frequency*(0.02*X*X+0.01*Z*Z));
      Xscreen:=Trunc(XScreenAdjust+x);
      Yscreen:=Trunc(YScreenAdjust-y);
  if (YScreen>=SmallestY[XScreen]) and (YScreen<=BiggestY[XScreen])  then
  begin Lastpoint:=0;  goto XFinish;  end;
     if Lastpoint=0 then PenChanged:=1;
       LastPoint:=1;
  if YScreen<SmallestY[XScreen]  then  SmallestY[XScreen]:=YScreen;
          if BiggestY[XScreen]=0 then
  begin BiggestY[XScreen]:=YScreen;goto DrawSubprgram;end;
        if yscreen>BiggestY[XScreen] then BiggestY[XScreen]:=YScreen;
          Drawsubprgram:
   if (X=XFirst) or (PenChanged=1) then    //移笔到新的位置
        begin  Canvas.MoveTo(XScreen,YScreen);PenChanged:=0;end Else
        Canvas.LineTo(XScreen,YScreen);  //由上一点画线到这一点
  XFinish:
    end;
 end;
end;

procedure TComputerGrapicsMainForm.HideFractalandChaos1Click(
  Sender: TObject);
begin
   //Fractalimage1.active:=false;
   //Fractalimage1.visible:=false;
end;

procedure TComputerGrapicsMainForm.DrawSurfaceshowhideline1Click(
  Sender: TObject);
var Xcenter,Ycenter,Lastpoint,
  Element,I,J,XScreen,YScreen,X,XFirst,XLast,PenChanged:Integer;
  BiggestY,SmallestY: Array [1..1000] of Single;
  Height,XscreenAdjust,YscreenAdjust,Y,Z,Frequency:Double;
  Label XFinish,DrawSubprgram;