Обработка и визуализация объектов на космических изображениях средствами пакета Contour

var

FormMain: TFormMain; CurDir: string; p: TPoint; conty: array [1.1000] of TBitmapLayer; id: word; points: word; colg,rowg: integer; mm: boolean;

scrollfill: boolean; xt,yt: array [0.1000] of integer; dlina: array [1.1000] of real;

square: array [1.1000] of real; prozra: array [1.1000] of integer; // dot: array [1.10000,1.10000] of integer; dot: array of array of array of integer; x_g,y_g: integer; col,colP: TColor32; StopperSlayer: boolean;

procedure Area; var i: Integer; begin xt [0]: = xt [points]; yt [0]: = yt [points]; square [id]: = 0; i: = 0; repeat square [id]: = square [id] + (xt [i] +xt [i+1]) * (yt [i] - yt [i+1]); i: = i+1; until not (i<=points-1); square [id]: = 0.5*Abs (square [id]); end; procedure perimetr; vari: integer; begindlina [id]: =0; for i: = 1 to points-1 do dlina [id]: =dlina [id] + sqrt ( (xt [i] - xt [i+1]) * (xt [i] - xt [i+1]) + (yt [i] - yt [i+1]) * (yt [i] - yt [i+1])); dlina [id]: =dlina [id] +sqrt ( (xt [1] - xt [points]) * (xt [1] - xt [points]) + (yt [1] - yt [points]) * (yt [1] - yt [points])); end;

procedure Delay (ms: longint); var TheTime: LongInt; begin TheTime: = GetTickCount + ms; while GetTickCount < TheTime do Application. ProcessMessages; end;

procedure TFormMain. Build; var TmpPoly: TPolygon32; begin Outline. Free; Outline: = nil; TmpPoly: = Polygon [id]. Outline; Outline: = TmpPoly. Grow (Fixed (0), 0); Outline. FillMode: = pfWinding; TmpPoly. Free;

end; procedure TFormMain. DelAllNClick (Sender: TObject); vari: integer; begin for i: = 1 to id do begin Grid. Rows [i]. Clear (); Polygon [id]. Clear; Conty [i]. Free; end; id: =0; DelPolButton. Enabled: =False; end;

procedure TFormMain. DelLastNClick (Sender: TObject); begin if (id<>0) then DelContour (id); end; procedure TFormMain. DelPolButtonClick (Sender: TObject);

begin DelContour (rowg); end;

procedure TFormMain. Draw (sloi: integer; proz: integer); begin Conty [sloi]. Bitmap. BeginUpdate; Conty [sloi]. Bitmap. Clear ($00); Conty [sloi]. Bitmap. Draw (0, 0, Conty [sloi]. Bitmap); Polygon [sloi]. DrawFill (Conty [sloi]. Bitmap, SetAlpha (clBlue32, proz)); Polygon [sloi]. DrawEdge (Conty [sloi]. Bitmap, SetAlpha (clBlack32, 255)); Conty [sloi]. Bitmap. EndUpdate; Conty [sloi]. Bitmap. Changed; ImgView321. Refresh; end; procedure TFormMain. SaveContNClick (Sender: TObject); var: integer; bm: TBitmap32; fFileHandle: TextFile; begin bm: = TBitmap32. Create (); bm. SetSize (ImgView321. Bitmap. Width, ImgView321. Bitmap. Height); bm. FillRect (0,0,bm. Width,bm. Height,$0f000000); for i: = 1 to id do conty [i]. bitmap. DrawTo (bm); if SavePictureDialog1. Execute then bm. SaveToFile (SavePictureDialog1. FileName); memo1. lines. Add (razredit. text); memo1. lines. Add ('0.0'); memo1. lines. Add ('0.0'); memo1. lines. Add ('-razredit. text); memo1. lines. Add (UpLeftX. text); memo1. lines. Add (UpLeftY. text); memo1. Lines. SaveToFile ('c: \test. jgw'); memo1. Clear; end; procedure TFormMain. NewPolButtonClick (Sender: TObject); varswap: integer; beginscrollfill: =true; if ( (points>=3) or (id=0)) and (radiovidcon. ItemIndex=0) then Begin inc (id); conty [id]: =TBitmapLayer. Create (ImgView321. Layers); conty [id]. Bitmap. SetSizeFrom (ImgView321. Bitmap); conty [id]. Bitmap. DrawMode: = dmBlend; conty [id]. Location: = FloatRect (0, 0, conty [id]. Bitmap. Width, conty [id]. Bitmap. Height); conty [id]. Scaled: =True; {conty [id]. Bitmap. MoveTo (0,0); conty [id]. Bitmap. pencolor: =Color32 (clBlack);

conty [id]. bitmap. LineToS (200, 200); }Polygon [id]: = TPolygon32. Create; Polygon [id]. NewLine; points: =0; Grid. Cells [0, id]: = (IntToStr (id)); Grid. Cells [1, id]: ='set ' + IntToStr (3-points) + ' dots'; Grid. Cells [2, id]: ='set ' + IntToStr (3-points) + ' dots'; prozra [id]: =ProzrCont. Position; end; end;

procedure TFormMain. FormCreate (Sender: TObject); beginStopperSlayer: =true;

GetDir (0,CurDir); id: =0; points: =0; mm: =true; DelPolButton. enabled: =false;

rowg: =0; colg: =0; scrollfill: =true; Grid. Cols [0]. Add ('Контур'); Grid. Cols [1]. Add ('Периметр'); Grid. Cols [2]. Add ('Площадь'); end; procedure TFormMain. GridKeyDown (Sender: TObject; var Key: Word;

Shift: TShiftState);

var i: integer; begin if (Key = VK_DELETE) then DelContour (rowg);

if (Key = VK_INSERT) and (Grid. Cells [colg,rowg] <>'') then begin draw (Rowg,1); Delay (50); draw (Rowg, 200); Delay (50); draw (Rowg,Prozra [rowg]); Delay (50); end; end;

procedure TFormMain. GridMouseDown (Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); beginmm: =true; end; procedure TFormMain. GridMouseUp (Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

beginmm: =false; end; procedure TFormMain. GridSelectCell (Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); begin scrollfill: =false; colg: =ACol; rowg: =ARow;

DelPolButton. Enabled: =True;

if Grid. Cells [Colg,Rowg] <>'' then begin while mm=True do begin draw (Rowg,1); Delay (50); draw (Rowg, 200); Delay (50); draw (Rowg,Prozra [rowg]); Delay (50); end; end; end;

procedure TFormMain. Left; var i,j: integer; beginrepeat for j: = 0 to mgview321. Bitmap. Height do begin for i: = 0 to imgview321. Bitmap. Width-1 do begin if (dot [id, i,j] =0) and (dot [id, i+1,j] =1) then begin if ColorSrav (ImgView321. Bitmap. PixelS [i,j]) =True then begin dot [id, i,j]: =1; if i=0 then dot [id, i,j]: =2; end else dot [id, i,j]: =2; end; end; end;

until StopLeft=False; end; procedure TFormMain. Right; var i,j: integer;

beginrepeat for j: = 1 to imgview321. Bitmap. Height do begin for i: = imgview321. Bitmap. Width downto 1 do begin if (dot [id, i,j] =0) and (dot [id, i-1,j] =1) then begin if lorSrav (ImgView321. Bitmap. PixelS [i,j]) =True then begin dot [id, i,j]: =1; if i=imgview321. Bitmap. Width then dot [id, i,j]: =2; end else dot [id, i,j]: =2; end; end; end; until StopRight=False; end; procedure TFormMain. Up; var i,j: integer; beginrepeat for i: = 0 to imgview321. Bitmap. Width do begin for j: = 0 to imgview321. Bitmap. Height do begin if (dot [id, i,j] =0) and (dot [id, i,j+1] =1) then begin if ColorSrav (ImgView321. Bitmap. PixelS [i,j]) =True then begin dot [id, i,j]: =1; if j=0 then dot [id, i,j]: =2; end else dot [id, i,j]: =2; end; end; end; until StopUp=False; end; procedure TFormMain. Down; var i,j: integer; beginrepeat for i: = 1 to imgview321. Bitmap. Width do begin for j: = imgview321. Bitmap. Height downto 1 do begin if (dot [id, i,j] =0) and (dot [id, i,j-1] =1) then begin if ColorSrav (ImgView321. Bitmap. PixelS [i,j]) =True then begin dot [id, i,j]: =1; if j=imgview321. Bitmap. Height then dot [id, i,j]: =2; end else dot [id, i,j]: =2; end; end; end; until StopDown=False; end; function TFormMain. ColorSrav (colFun: TColor32): boolean; beginif (abs (TColor32Entry (ColFun). R-TColor32Entry (Col). R) <=StrtoInt (EditR. Text)) and (abs (TColor32Entry (ColFun). G-TColor32Entry (Col). G) <=StrtoInt (EditG. Text)) and (abs (TColor32Entry (ColFun). B-TColor32Entry (Col). B) <=StrtoInt (EditB. Text)) then Result: = True else Result: = False; end; function TFormMain. StopDown: boolean; vari,j,k: integer; begin for i: = 1 to imgview321. Bitmap. Width do begin for j: = imgview321. Bitmap. Height downto 1 do begin if (dot [id, i,j] =0) and (dot [id, i,j-1] =1) then k: =1; end; end; if k=1 then Result: =True else Result: =False; end; function TFormMain. StopUp: boolean; vari,j,k: integer; begin for i: = 1 to imgview321. Bitmap. Width do begin for j: = 1 to imgview321. Bitmap. Height do begin if (dot [id, i,j] =0) and (dot [id, i,j+1] =1) then k: =1; end; end; if k=1 then Result: =True else Result: =False; end; function TFormMain. StopRight: boolean; vari,j,k: integer; begin for j: = 1 to imgview321. Bitmap. Height do begin for i: = imgview321. Bitmap. Width downto 1 do begin if (dot [id, i,j] =0) and (dot [id, i-1,j] =1) then k: =1; end; end; if k=1 then Result: =True else Result: =False; end; function TFormMain. StopLeft: boolean; vari,j,k: integer; begin for j: = 1 to imgview321. Bitmap. Height do begin for i: = 1 to imgview321. Bitmap. Width-1 do begin if (dot [id, i,j] =0) and (dot [id, i+1,j] =1) then k: =1; end; end; if k=1 then Result: =True else Result: =False; end; procedure TFormMain. OtrisovkaAuto; var i,j: integer; beginfor i: = 0 to conty [id]. Bitmap. Width do begin for j: = 0 to conty [id]. Bitmap. Height do begin if dot [id, i,j] =2 then conty [id]. Bitmap [i,j]: = Color32 (0,255,0); end; conty [id]. Changed; end; end; procedure TFormMain. ImgView321MouseDown (Sender: TObject; Button: MouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); var i,j,t: integer; l: real; beginif RadioVidCon. ItemIndex=1 thenbegin if Button = mbLeft then begin if (p. X>=1) and (p. X<imgview321. Bitmap. Width) and (p. Y>=1) and p. Y<imgview321. Bitmap. Height) then begin x_g: =p. X; y_g: =p. Y; col: = ImgView321. Bitmap. PixelS [x_g,y_g]; setlength (dot, id+1, imgview321. Bitmap. Width+1, imgview321. Bitmap. Height+1);

conty [id]: =TBitmapLayer. Create (ImgView321. Layers); conty [id]. Bitmap. SetSizeFrom (ImgView321. Bitmap); conty [id]. Bitmap. DrawMode: = dmBlend; conty [id]. Location: = FloatRect (0, 0, conty [id]. Bitmap. Width, onty [id]. Bitmap. Height); conty [id]. Scaled: =True; dot [id,x_g,y_g]: =1 repeat Up; Right; Down; Left; until (StopUp=False) and (StopLeft=False) and (StopRight=False) and StopDown=False); t: =0; for i: = 0 to imgview321. Bitmap. Width do begin for j: = 0 to imgview321. Bitmap. Height do begin if dot [id, i,j] =1 then inc (t); end; end; if t>3 then begin Grid. Cells [0, id]: = (IntToStr (id)); Grid. Cells [2, id]: = (IntToStr (t*strtoint (RazrEdit. Text))); l: =2*sqrt (Pi*t); Grid. Cells [1, id]: = (IntToStr (round (l))); end else begin showmessage ('В области менее трех точек. '); conty [id]. Free; dot [id]: =nil; id: =id-1; end; OtrisovkaAuto; end else showmessage ('Попали в (за) край снимка! '); end; if Button = mbRight then // условие на левый клик Begin conty [id]. Free; dot [id]: =nil; Grid. Rows [id]. Clear (); if id>=1 then id: =id-1 else if id=0 then id: =0; end; end; if RadioVidCon. ItemIndex=0 then Begin if (id>0) then Begin if (p. X<ImgView321. Bitmap. Width) and (p. Y < ImgView321. Bitmap. Height) and (p. X>0) and (p. Y>0) and ( (xt [points] <>p. X) and (yt [points] <>p. Y)) then Begin if Button = mbLeft then Begin Polygon [id]. Add (FixedPoint (p. X, p. Y)); inc (points); TochekPanel. Caption: ='Вершин: '+ IntToStr (points); xt [points]: =p. X; yt [points]: =p. Y; if points >=3 then begin perimetr; area; Grid. Cells [1, id]: =FloatToStr (dlina [id] *StrToFloat (RazrEdit. Text));

rid. Cells [2, id]: =FloatToStr (square [id] *StrToFloat (RazrEdit. Text) *StrToFloat (RazrEdit. Text)); end else DelContour (id); End; Build; Draw (id,ProzrCont. Position); end; end; end; procedure TFormMain. ImgView321MouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); var col: TColor32; begin p. x: = X; p. y: = Y; p: =ImgView321. ControlToBitmap (p); col: = ImgView321. Bitmap. PixelS [p. X,p. Y]; if (p. X<=ImgView321. Bitmap. Width) and (p. Y <= ImgView321. Bitmap. Height)

and (p. X>=0) and (p. Y>=0) then begin XYPanel. Caption: =' [x,y] ='+' ['+IntToStr (p. X) +','+IntToStr (p. Y) +'] ';

WxWyPanel. Caption: = ' [Wx,Wy] ='+' ['+IntToStr (StrToInt (RazrEdit. Text) *p. X+StrToInt (UpLeftX. text)) +

','+IntToStr (StrToInt (RazrEdit. Text) *p. Y+StrToInt (UpLeftY. text)) +'] ';

RGBPanel. Caption: =' [R,G,B] ='+ ' ['+ IntToStr (TColor32Entry (Col). R) +','+

IntToStr (TColor32Entry (Col). G) +','+IntToStr (TColor32Entry (Col). B) + '] ';

if id >=1 then end else begin XYPanel. Caption: =' [x,y] = [?,?] '; WXWYPanel. Caption: =' [Wx,Wy] = [?,?] '; RGBPanel. Caption: =' [R,G,B] = [?,?,?] '; end; end; procedure TFormMain. OpenContNClick (Sender: TObject); beginwith OpenPictureDialog1 do if Execute then begin conty [100]: =TBitmapLayer. Create (ImgView321. Layers); conty [100]. Bitmap. LoadFromFile (FileName); if (conty [100]. Bitmap. Width=imgview321. Bitmap. Width) and (conty [100]. Bitmap. Height=imgview321. Bitmap. Height) then begin conty [100]. Bitmap. DrawMode: = dmBlend; conty [100]. Location: = FloatRect (0, 0, conty [100]. Bitmap. Width, onty [100]. Bitmap. Height); conty [100]. Scaled: =True; end else begin conty [100]. free; showmessage ('Размеры изображений контуров и снимка не совпадают. '); end; end; end; procedure TFormMain. OpenNClick (Sender: TObject); beginOpenPictureDialog1. InitialDir: =CurDir; with OpenPictureDialog1 do if Execute then begin ImgView321. Bitmap. LoadFromFile (FileName); end; NewPolButton. Enabled: =True; DelPolButton. Enabled: =True; end; procedure TFormMain. Button1Click (Sender: TObject); vargog: TColor32; beginColorDialog1. Execute; gog: =ColorDialog1. Color; Shape1. Brush. Color: = gog; end; procedure TFormMain. CloseNClick (Sender: TObject); vari: integer; begin for i: = 1 to id do begin Grid. Rows [i]. Clear (); Conty [i]. Free; // нет слоя Polygon [i]. Clear; // нет полигона end; ImgView321. Bitmap. Clear (clSilver); id: =0; points: =0; NewPolButton. Enabled: =False; DelPolButton. Enabled: =False; end; procedure TFormMain. ScaleBarChange (Sender: TObject); varNewScale: real; begin NewScale: = ScaleBar. Position/100; ScaleBar. Repaint; ImgView321. Scale: = NewScale; ScaleCombo. Text: = IntToStr (Round (NewScale*100)) +'%'; end; procedure TFormMain. ScaleComboChange (Sender: TObject); var S: string; I: Integer; begin S: = ScaleCombo. Text; S: = StringReplace (S, '%', '', [rfReplaceAll]); S: = StringReplace (S, ' ', '', [rfReplaceAll]); if S = '' then Exit; I: = StrToIntDef (S, - 1); if (I < 1) or (I > 1000) then I: = Round (ImgView321. Scale * 100) else ImgView321. Scale: = I / 100; ScaleCombo. Text: = IntToStr (I) + '%'; ScaleCombo. SelStart: = Length (ScaleCombo. Text) - 1; ScaleBar. Position: = I; end; procedure TFormMain. ProzrContChange (Sender: TObject); begin if (scrollfill=true) and (id<>0) then begin Draw (id,ProzrCont. Position); prozra [id]: =ProzrCont. Position; end; if scrollfill=false and (Grid. Cells [Colg,Rowg] <>'') then begin Draw (rowg,ProzrCont. Position); prozra [rowg]: =ProzrCont. Position; end; end; procedure TFormMain. DelContour (nomer: integer); var i: integer; begin if (Grid. Cells [0,nomer] <>'') and (nomer<>id) then begin for i: =nomer to id-1 do begin Grid. Rows [i]: =Grid. Rows [i+1]; Polygon [i]: =Polygon [i+1]; prozra [i]: =prozra [i+1]; end; conty [id]. Free; Grid. Rows [id]. Clear (); for i: =nomer to id-1 do begin draw (i,ProzrCont. Position); Grid. Cells [0, i]: =IntToStr (i); end; id: =id-1; end else begin if nomer=id then Polygon [id]. Clear; draw (id,ProzrCont. Position); points: =0; Grid. Cells [1, id]: ='set ' + IntToStr (3-points) + ' dots'; Grid. Cells [2, id]: ='set ' + IntToStr (3-points) + ' dots'; end; end; end.

Размещено на Allbest.ru