home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / graphics32 / Examples / Vcl / Transform_Ex / MainUnit.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2004-07-05  |  15.5 KB  |  595 lines
  1. unit MainUnit;
  2.  
  3. (* ***** BEGIN LICENSE BLOCK *****
  4.  * Version: MPL 1.1
  5.  *
  6.  * The contents of this file are subject to the Mozilla Public License Version
  7.  * 1.1 (the "License"); you may not use this file except in compliance with
  8.  * the License. You may obtain a copy of the License at
  9.  * http://www.mozilla.org/MPL/
  10.  *
  11.  * Software distributed under the License is distributed on an "AS IS" basis,
  12.  * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  13.  * for the specific language governing rights and limitations under the
  14.  * License.
  15.  *
  16.  * The Original Code is Graphics32
  17.  *
  18.  * The Initial Developer of the Original Code is
  19.  * Alex A. Denisov
  20.  *
  21.  * Portions created by the Initial Developer are Copyright (C) 2000-2004
  22.  * the Initial Developer. All Rights Reserved.
  23.  *
  24.  * Contributor(s):
  25.  *
  26.  * ***** END LICENSE BLOCK ***** *)
  27.  
  28. interface
  29.  
  30. uses
  31.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  32.   GR32, GR32_Image, GR32_Transforms, GR32_Layers, ExtCtrls, StdCtrls, Buttons,
  33.   ComCtrls, Grids, GR32_RangeBars;
  34.  
  35. type
  36.   TOpType = (opNone, opTranslate, opScale, opRotate, opSkew);
  37.   TOpRec = record
  38.     OpType: TOpType;
  39.     Dx, Dy: Extended;        // shifts for opTranslate mode
  40.     Sx, Sy: Extended;        // scale factors for opScale mode
  41.     Cx, Cy, Alpha: Extended; // rotation center and angle (deg) for opRotate mode
  42.     Fx, Fy: Extended;        // skew factors for opSkew mode
  43.   end;
  44.   TOpRecs = array[0..7] of TOpRec;
  45.  
  46. const
  47.   OpTypes: array [0..4] of TOpType = (opNone, opTranslate, opScale, opRotate,
  48.     opSkew);
  49.  
  50. type
  51.   TTransformMode = (tmAffine, tmProjective, tmBilinear);
  52.  
  53.   TForm1 = class(TForm)
  54.     Src: TImage32;
  55.     Dst: TImage32;
  56.     PageControl1: TPageControl;
  57.     TabSheet1: TTabSheet;
  58.     Panel2: TPanel;
  59.     Shape1: TShape;
  60.     Shape2: TShape;
  61.     StringGrid: TStringGrid;
  62.     ListBox: TListBox;
  63.     Button1: TButton;
  64.     Label9: TLabel;
  65.     CodeString: TEdit;
  66.     Panel1: TPanel;
  67.     Label1: TLabel;
  68.     ComboBox: TComboBox;
  69.     Notebook: TNotebook;
  70.     Label2: TLabel;
  71.     Label3: TLabel;
  72.     Label4: TLabel;
  73.     Label5: TLabel;
  74.     eDx: TEdit;
  75.     eDy: TEdit;
  76.     Label6: TLabel;
  77.     Label7: TLabel;
  78.     Label8: TLabel;
  79.     eSy: TEdit;
  80.     eSx: TEdit;
  81.     Label11: TLabel;
  82.     Label13: TLabel;
  83.     Label16: TLabel;
  84.     Label15: TLabel;
  85.     eCx: TEdit;
  86.     eAlpha: TEdit;
  87.     eCy: TEdit;
  88.     Label12: TLabel;
  89.     Label14: TLabel;
  90.     Label17: TLabel;
  91.     eFx: TEdit;
  92.     eFy: TEdit;
  93.     Label10: TLabel;
  94.     RadioGroup1: TRadioGroup;
  95.     Panel3: TPanel;
  96.     TabSheet2: TTabSheet;
  97.     Label18: TLabel;
  98.     OpacityBar: TGaugeBar;
  99.     sbDx: TGaugeBar;
  100.     sbDy: TGaugeBar;
  101.     sbSx: TGaugeBar;
  102.     sbSy: TGaugeBar;
  103.     sbAlpha: TGaugeBar;
  104.     sbFx: TGaugeBar;
  105.     sbFy: TGaugeBar;
  106.     procedure FormCreate(Sender: TObject);
  107.     procedure FormDestroy(Sender: TObject);
  108.     procedure ListBoxClick(Sender: TObject);
  109.     procedure ComboBoxChange(Sender: TObject);
  110.     procedure TranslationChanged(Sender: TObject);
  111.     procedure ScaleChanged(Sender: TObject);
  112.     procedure TranslationScrolled(Sender: TObject);
  113.     procedure Button1Click(Sender: TObject);
  114.     procedure ScaleScrolled(Sender: TObject);
  115.     procedure RotationChanged(Sender: TObject);
  116.     procedure RotationScrolled(Sender: TObject);
  117.     procedure SkewChanged(Sender: TObject);
  118.     procedure SkewScrolled(Sender: TObject);
  119.     procedure RadioGroup1Click(Sender: TObject);
  120.     procedure OpacityChange(Sender: TObject);
  121.     procedure PageControl1Change(Sender: TObject);
  122.  
  123.     procedure RubberLayerMouseDown(Sender: TObject; Button: TMouseButton;
  124.       Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  125.     procedure RubberLayerMouseMove(Sender: TObject; Shift: TShiftState; X,
  126.       Y: Integer; Layer: TCustomLayer);
  127.     procedure RubberLayerMouseUp(Sender: TObject; Button: TMouseButton;
  128.       Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  129.  
  130.     procedure AppEventsIdle(Sender: TObject; var Done: Boolean);
  131.   protected
  132.     LoadingValues: Boolean;
  133.     DraggedVertex: Integer;
  134.     LastMousePos: TPoint;
  135.     StippleStart: Single;
  136.     procedure PaintHandles(Sender: TObject; BackBuffer: TBitmap32);
  137.   public
  138.     Operation: TOpRecs;
  139.     Current: ^TOpRec;
  140.     AT: TAffineTransformation;
  141.     PT: TProjectiveTransformation;
  142.     TT: TTransformation;
  143.     Vertices: array[0..3] of TPoint;
  144.     Mode: TTransformMode;
  145.     procedure ClearTransformations;
  146.     procedure DoTransform;
  147.     procedure GenTransform;
  148.     procedure PrepareSource;
  149.     procedure ShowSettings(OperationNum: Integer);
  150.     procedure InitVertices; // for projective mapping
  151.   end;
  152.  
  153. var
  154.   Form1: TForm1;
  155.  
  156. implementation
  157.  
  158. function GetVal(Src: string; var Dst: Extended): Boolean;
  159. var
  160.   Code: Integer;
  161. begin
  162.   Val(Src, Dst, Code);
  163.   Result := Code = 0;
  164. end;
  165.  
  166. {$R *.DFM}
  167.  
  168. procedure TForm1.FormCreate(Sender: TObject);
  169. begin
  170.   with TCustomLayer.Create(Dst.Layers) do
  171.   begin
  172.     OnPaint := PaintHandles;
  173.   end;
  174.  
  175.   DraggedVertex := -1;
  176.   Dst.SetupBitmap; // set the destination bitmap size to match the image size
  177.   PrepareSource;
  178.   ClearTransformations;
  179.   ShowSettings(0);
  180.   AT := TAffineTransformation.Create;
  181.   PT := TProjectiveTransformation.Create;
  182.   TT := AT;
  183.   DoTransform;
  184.  
  185.   Application.OnIdle := AppEventsIdle;
  186. end;
  187.  
  188. procedure TForm1.ClearTransformations;
  189. var
  190.   I: Integer;
  191. begin
  192.   FillChar(Operation[0], SizeOf(TOpRecs), 0);
  193.   for I := 0 to 7 do
  194.   begin
  195.     Operation[I].Sx := 1;
  196.     Operation[I].Sy := 1;
  197.     Operation[I].Cx := Src.Bitmap.Width / 2;
  198.     Operation[I].Cy := Src.Bitmap.Height / 2;
  199.   end;
  200. end;
  201.  
  202. procedure TForm1.PrepareSource;
  203. begin
  204.   // make the border pixels transparent while keeping their RGB components
  205.   SetBorderTransparent(Src.Bitmap,
  206.     Rect(0, 0, Src.Bitmap.Width - 1, Src.Bitmap.Height - 1));
  207. end;
  208.  
  209. procedure TForm1.DoTransform;
  210. var
  211.   i, j: Integer;
  212.   P: PColor32;
  213. begin
  214.   Application.ProcessMessages;
  215.   GenTransform;
  216.   Dst.BeginUpdate;
  217.  
  218.   // Fill Dst with checkerboard pattern
  219.   P := Dst.Bitmap.PixelPtr[0, 0];
  220.   for j := 0 to Dst.Bitmap.Height - 1 do
  221.     for i := 0 to Dst.Bitmap.Width - 1 do
  222.     begin
  223.       if Odd(i shr 4) = Odd(j shr 4) then P^ := clGray32
  224.       else P^ := clWhite32;
  225.       Inc(P);
  226.     end;
  227.  
  228.   Transform(Dst.Bitmap, Src.Bitmap, TT);
  229.   Dst.EndUpdate;
  230.   Dst.Repaint;
  231.  
  232.   if Mode = tmAffine then
  233.   begin
  234.     // fill the string grid
  235.     for j := 0 to 2 do
  236.       for i := 0 to 2 do
  237.         StringGrid.Cells[i, j] := Format('%.3g', [AT.Matrix[i, j]]);
  238.     StringGrid.Col := 3; // hide grid cursor
  239.   end;
  240. end;
  241.  
  242. procedure TForm1.GenTransform;
  243. var
  244.   I: Integer;
  245.   Rec: TOpRec;
  246.   S: string;
  247. begin
  248.   TT.SrcRect := FloatRect(0, 0, Src.Bitmap.Width - 1, Src.Bitmap.Height - 1);
  249.   if Mode = tmProjective then
  250.   begin
  251.     PT.X0 := Vertices[0].X;
  252.     PT.Y0 := Vertices[0].Y;
  253.     PT.X1 := Vertices[1].X;
  254.     PT.Y1 := Vertices[1].Y;
  255.     PT.X2 := Vertices[2].X;
  256.     PT.Y2 := Vertices[2].Y;
  257.     PT.X3 := Vertices[3].X;
  258.     PT.Y3 := Vertices[3].Y;
  259.   end
  260.   else {if Mode = tmAffine then }
  261.   begin
  262.     // affine mode
  263.     AT.Clear;
  264.     for I := 0 to 7 do
  265.     begin
  266.       Rec := Operation[I];
  267.       case Rec.OpType of
  268.         opTranslate:  AT.Translate(Rec.Dx, Rec.Dy);
  269.         opScale:      AT.Scale(Rec.Sx, Rec.Sy);
  270.         opRotate:     AT.Rotate(Rec.Cx, Rec.Cy, Rec.Alpha);
  271.         opSkew:       AT.Skew(Rec.Fx, Rec.Fy);
  272.       end;
  273.       case Rec.OpType of
  274.         opTranslate:  s := s + Format('Translate(%.3g, %.3g); ', [Rec.Dx, Rec.Dy]);
  275.         opScale:      s := s + Format('Scale(%.3g, %.3g); ', [Rec.Sx, Rec.Sy]);
  276.         opRotate:     s := s + Format('Rotate(%.3g, %.3g, %3g); ', [Rec.Cx, Rec.Cy, Rec.Alpha]);
  277.         opSkew:       s := s + Format('Skew(%.3g, %.3g); ', [Rec.Fx, Rec.Fy]);
  278.       end;
  279.     end;
  280.     if Length(s) = 0 then s := 'Clear;';
  281.     CodeString.Text := s;
  282.   end;
  283. end;
  284.  
  285. procedure TForm1.FormDestroy(Sender: TObject);
  286. begin
  287.   AT.Free;
  288.   PT.Free;
  289. end;
  290.  
  291. procedure TForm1.Button1Click(Sender: TObject);
  292. begin
  293.   ClearTransformations;
  294.   ShowSettings(Listbox.ItemIndex);
  295.   DoTransform;
  296. end;
  297.  
  298. procedure TForm1.ListBoxClick(Sender: TObject);
  299. begin
  300.   ShowSettings(ListBox.ItemIndex);
  301. end;
  302.  
  303. procedure TForm1.ShowSettings(OperationNum: Integer);
  304. begin
  305.   LoadingValues := True;
  306.   ListBox.ItemIndex := OperationNum;
  307.   Current := @Operation[OperationNum];
  308.   Combobox.ItemIndex := Ord(Current.OpType);
  309.   NoteBook.PageIndex := Ord(Current.OpType);
  310.   eDx.Text := Format('%.4g', [Current.Dx]);
  311.   eDy.Text := Format('%.4g', [Current.Dy]);
  312.   sbDx.Position := Round(Current.Dx * 10);
  313.   sbDy.Position := Round(Current.Dy * 10);
  314.   eSx.Text := Format('%.4g', [Current.Sx]);
  315.   eSy.Text := Format('%.4g', [Current.Sy]);
  316.   sbSx.Position := Round(Current.Sx * 100);
  317.   sbSy.Position := Round(Current.Sy * 100);
  318.   eCx.Text := Format('%.4g', [Current.Cx]);
  319.   eCy.Text := Format('%.4g', [Current.Cy]);
  320.   eAlpha.Text := Format('%.4g', [Current.Alpha]);
  321.   sbAlpha.Position := Round(Current.Alpha * 2);
  322.   eFx.Text := Format('%.4g', [Current.Fx]);
  323.   eFy.Text := Format('%.4g', [Current.Fy]);
  324.   sbFx.Position := Round(Current.Fx * 100);
  325.   sbFy.Position := Round(Current.Fy * 100);
  326.   LoadingValues := False;
  327. end;
  328.  
  329. procedure TForm1.ComboBoxChange(Sender: TObject);
  330. begin
  331.   Current.OpType := OpTypes[ComboBox.ItemIndex];
  332.   ShowSettings(ListBox.ItemIndex);
  333.   DoTransform;
  334. end;
  335.  
  336. procedure TForm1.TranslationChanged(Sender: TObject);
  337. var
  338.   Tx, Ty: Extended;
  339. begin
  340.   if LoadingValues then Exit;
  341.   if GetVal(eDx.Text, Tx) and GetVal(eDy.Text, Ty) then
  342.   begin
  343.     Current.Dx := Tx;
  344.     Current.Dy := Ty;
  345.     DoTransform;
  346.     LoadingValues := True;
  347.     sbDx.Position := Round(Current.Dx * 10);
  348.     sbDy.Position := Round(Current.Dy * 10);
  349.     LoadingValues := False;
  350.   end;
  351. end;
  352.  
  353. procedure TForm1.TranslationScrolled(Sender: TObject);
  354. begin
  355.   if LoadingValues then Exit;
  356.   Current.Dx := sbDx.Position / 10;
  357.   Current.Dy := sbDy.Position / 10;
  358.   DoTransform;
  359.   LoadingValues := True;
  360.   eDx.Text := FloatToStr(Current.Dx);
  361.   eDy.Text := FloatToStr(Current.Dy);
  362.   LoadingValues := False;
  363. end;
  364.  
  365. procedure TForm1.ScaleChanged(Sender: TObject);
  366. var
  367.   Sx, Sy: Extended;
  368. begin
  369.   if LoadingValues then Exit;
  370.   if GetVal(eSx.Text, Sx) and GetVal(eSy.Text, Sy) then
  371.   begin
  372.     Current.Sx := Sx;
  373.     Current.Sy := Sy;
  374.     DoTransform;
  375.     LoadingValues := True;
  376.     sbSx.Position := Round(Current.Sx * 100);
  377.     sbSy.Position := Round(Current.Sy * 100);
  378.     LoadingValues := False;
  379.   end;
  380. end;
  381.  
  382. procedure TForm1.ScaleScrolled(Sender: TObject);
  383. begin
  384.   if LoadingValues then Exit;
  385.   Current.Sx := sbSx.Position / 100;
  386.   Current.Sy := sbSy.Position / 100;
  387.   DoTransform;
  388.   LoadingValues := True;
  389.   eSx.Text := FloatToStr(Current.Sx);
  390.   eSy.Text := FloatToStr(Current.Sy);
  391.   LoadingValues := False;
  392. end;
  393.  
  394. procedure TForm1.RotationChanged(Sender: TObject);
  395. var
  396.   Cx, Cy, Alpha: Extended;
  397. begin
  398.   if LoadingValues then Exit;
  399.   if GetVal(eCx.Text, Cx) and GetVal(eCy.Text, Cy) and
  400.     GetVal(eAlpha.Text, Alpha) then
  401.   begin
  402.     Current.Cx := Cx;
  403.     Current.Cy := Cy;
  404.     Current.Alpha := Alpha;
  405.     DoTransform;
  406.     LoadingValues := True;
  407.     sbAlpha.Position := Round(Alpha * 2);
  408.     LoadingValues := False;
  409.   end;
  410. end;
  411.  
  412. procedure TForm1.RotationScrolled(Sender: TObject);
  413. begin
  414.   if LoadingValues then Exit;
  415.   Current.Alpha := sbAlpha.Position / 2;
  416.   DoTransform;
  417.   LoadingValues := True;
  418.   eAlpha.Text := FloatToStr(Current.Alpha / 2);
  419.   LoadingValues := False;
  420. end;
  421.  
  422. procedure TForm1.SkewChanged(Sender: TObject);
  423. var
  424.   Fx, Fy: Extended;
  425. begin
  426.   if LoadingValues then Exit;
  427.   if GetVal(eFx.Text, Fx) and GetVal(eFy.Text, Fy) then
  428.   begin
  429.     Current.Fx := Fx;
  430.     Current.Fy := Fy;
  431.     DoTransform;
  432.     LoadingValues := True;
  433.     sbFx.Position := Round(Current.Fx * 10);
  434.     sbFy.Position := Round(Current.Fy * 10);
  435.     LoadingValues := False;
  436.   end;
  437. end;
  438.  
  439. procedure TForm1.SkewScrolled(Sender: TObject);
  440. begin
  441.   if LoadingValues then Exit;
  442.   Current.Fx := sbFx.Position / 10;
  443.   Current.Fy := sbFy.Position / 10;
  444.   DoTransform;
  445.   LoadingValues := True;
  446.   eFx.Text := FloatToStr(Current.Fx);
  447.   eFy.Text := FloatToStr(Current.Fy);
  448.   LoadingValues := False;
  449. end;
  450.  
  451. procedure TForm1.RadioGroup1Click(Sender: TObject);
  452. const
  453.   STRETCH_FILTER: array [0..1] of TStretchFilter = (sfNearest, sfLinear);
  454. begin
  455.   Src.Bitmap.StretchFilter := STRETCH_FILTER[RadioGroup1.ItemIndex];
  456.   DoTransform;
  457. end;
  458.  
  459. procedure TForm1.OpacityChange(Sender: TObject);
  460. begin
  461.   OpacityBar.Update;
  462.   Src.Bitmap.MasterAlpha := OpacityBar.Position;
  463.   DoTransform;
  464. end;
  465.  
  466. procedure TForm1.InitVertices;
  467. begin
  468.   Vertices[0].X := 0;
  469.   Vertices[0].Y := 0;
  470.   Vertices[1].X := Src.Bitmap.Width - 1;
  471.   Vertices[1].Y := 0;
  472.   Vertices[2].X := Src.Bitmap.Width - 1;
  473.   Vertices[2].Y := Src.Bitmap.Height - 1;
  474.   Vertices[3].X := 0;
  475.   Vertices[3].Y := Src.Bitmap.Height - 1;
  476. end;
  477.  
  478. procedure TForm1.PageControl1Change(Sender: TObject);
  479. begin
  480.   if PageControl1.ActivePage = TabSheet1 then
  481.   begin
  482.     Mode := tmAffine;
  483.     TT := AT;
  484.     RadioGroup1.Parent := TabSheet1;
  485.   end
  486.   else {if PageControl1.ActivePage = TabSheet2 then }
  487.   begin
  488.     // set current transformation as projective
  489.     Mode := tmProjective;
  490.     TT := PT;
  491.     InitVertices;
  492.     RadioGroup1.Parent := TabSheet2;
  493.   end;
  494.   DoTransform;
  495. end;
  496.  
  497. procedure TForm1.RubberLayerMouseDown(Sender: TObject;
  498.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  499. var
  500.   I: Integer;
  501. begin
  502.   if Mode = tmAffine then Exit;
  503.  
  504.   DraggedVertex := -1;
  505.  
  506.   // find the vertex to drag
  507.   for I := 0 to 3 do
  508.     if (Abs(Vertices[I].X - X) < 3) and (Abs(Vertices[I].Y - Y) < 3) then
  509.     begin
  510.       DraggedVertex := I;
  511.       Break;
  512.     end;
  513.  
  514.   // or drag all of them, (DragVertex = 4)
  515.   if DraggedVertex = -1 then DraggedVertex := 4;
  516.  
  517.   // store current mouse position
  518.   LastMousePos := Point(X, Y);
  519. end;
  520.  
  521. procedure TForm1.RubberLayerMouseMove(Sender: TObject; Shift: TShiftState;
  522.   X, Y: Integer; Layer: TCustomLayer);
  523. var
  524.   Dx, Dy, I: Integer;
  525. begin
  526.   if Mode = tmAffine then Exit;
  527.   
  528.   if DraggedVertex = -1 then Exit; // mouse is not pressed
  529.  
  530.   Dx := X - LastMousePos.X;
  531.   Dy := Y - LastMousePos.Y;
  532.   LastMousePos := Point(X, Y);
  533.  
  534.   // update coords
  535.   if DraggedVertex = 4 then
  536.   begin
  537.     for I := 0 to 3 do
  538.     begin
  539.       Inc(Vertices[I].X, Dx);
  540.       Inc(Vertices[I].Y, Dy);
  541.     end;
  542.   end
  543.   else
  544.   begin
  545.     Inc(Vertices[DraggedVertex].X, Dx);
  546.     Inc(Vertices[DraggedVertex].Y, Dy);
  547.   end;
  548.  
  549.   DoTransform;
  550. end;
  551.  
  552. procedure TForm1.RubberLayerMouseUp(Sender: TObject; Button: TMouseButton;
  553.   Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer);
  554. begin
  555.   DraggedVertex := -1;
  556. end;
  557.  
  558. procedure TForm1.AppEventsIdle(Sender: TObject; var Done: Boolean);
  559. begin
  560.   StippleStart := StippleStart - 0.05;
  561.   Dst.Invalidate;
  562. end;
  563.  
  564. procedure TForm1.PaintHandles(Sender: TObject; BackBuffer: TBitmap32);
  565. var
  566.   I, X0, Y0, X1, Y1: Integer;
  567.  
  568.   procedure PaintVertex(X, Y: Integer);
  569.   begin
  570.     BackBuffer.FillRectS(X - 2, Y - 2, X + 2, Y + 2, clWhite32);
  571.     BackBuffer.FrameRectS(X - 3, Y - 3, X + 3, Y + 3, clBlack32);
  572.   end;
  573.  
  574. begin
  575.   if PageControl1.ActivePage = TabSheet1 then Exit;
  576.  
  577.   BackBuffer.SetStipple([clBlack32, clBlack32, clWhite32, clWhite32]);
  578.   BackBuffer.StippleStep := 0.5;
  579.   BackBuffer.StippleCounter := StippleStart;
  580.  
  581.   X0 := Vertices[3].X;
  582.   Y0 := Vertices[3].Y;
  583.   for I := 0 to 3 do
  584.   begin
  585.     X1 := Vertices[I].X;
  586.     Y1 := Vertices[I].Y;
  587.     BackBuffer.LineFSP(X0, Y0, X1, Y1);
  588.     X0 := X1;
  589.     Y0 := Y1;
  590.   end;
  591.   for I := 0 to 3 do PaintVertex(Vertices[I].X, Vertices[I].Y);
  592. end;
  593.  
  594. end.
  595.