home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / graphics32 / Examples / Clx / PixelF_Ex / MainUnit.pas next >
Pascal/Delphi Source File  |  2004-07-21  |  5KB  |  169 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 PixelF_Ex
  17.  *
  18.  * The Initial Developer of the Original Code is
  19.  * Michael Hansen
  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.   Classes, QGraphics, QControls, QForms, QDialogs, QStdCtrls, QExtCtrls,
  32.   GR32, GR32_Lowlevel, GR32_Image, GR32_RangeBars;
  33.  
  34. type
  35.   TMainForm = class(TForm)
  36.     Image32: TImage32;
  37.     PnlSettings: TPanel;
  38.     Label3: TLabel;
  39.     Panel4: TPanel;
  40.     gbTwist: TGaugeBar;
  41.     rbGetPixelFS: TRadioButton;
  42.     rbPixelS: TRadioButton;
  43.     procedure Image32PaintStage(Sender: TObject; Buffer: TBitmap32;
  44.       StageNum: Cardinal);
  45.     procedure FormCreate(Sender: TObject);
  46.     procedure gbTwistChange(Sender: TObject);
  47.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  48.   private
  49.     { Private declarations }
  50.   public
  51.     { Public declarations }
  52.     Src: TBitmap32;
  53.     procedure TwirlDistortion(Dst, Src: TBitmap32; const Value: Integer);
  54.   end;
  55.  
  56. var
  57.   MainForm: TMainForm;
  58.  
  59. implementation
  60.  
  61. {$R *.xfm}
  62.  
  63. uses Math;
  64.  
  65. procedure TMainForm.TwirlDistortion(Dst, Src: TBitmap32; const Value: Integer);
  66. {twirl algoritm inspired by Patrick Quinn┤s remap demo}
  67. var
  68.   X, Y, DstR, DstB: Integer;
  69.   r, rx, ry, t, tt, v: Single;
  70. begin
  71.   rx := Src.Width / 2;
  72.   ry := Src.Height / 2;
  73.   v := -Value / 5 / Src.Height;
  74.   DstR := Dst.Width - 1;
  75.   DstB := Dst.Height - 1;
  76.  
  77.   if rbGetPixelFS.Checked then
  78.    for Y := 0 to DstB do
  79.     for X := 0 to DstR do begin
  80.       r := Hypot(X - rx, Y - ry);
  81.       t := ArcTan2(Y - ry, X - rx);
  82.       tt := t + r * v;
  83.       Dst.Pixel[X, Y] := Src.PixelFS[ rx + r * Cos(tt),
  84.                                       ry + r * Sin(tt) ];
  85.     end
  86.   else if rbPixelS.Checked then
  87.    for Y := 0 to DstB do
  88.     for X := 0 to DstR do begin
  89.       r := Hypot(X - rx, Y - ry);
  90.       t := ArcTan2(Y - ry, X - rx);
  91.       tt := t + r * v;
  92.       Dst.Pixel[X, Y] := Src.PixelS[ Round(rx + r * Cos(tt)),
  93.                                      Round(ry + r * Sin(tt)) ];
  94.     end;
  95. end;
  96.  
  97. procedure TMainForm.Image32PaintStage(Sender: TObject; Buffer: TBitmap32;
  98.   StageNum: Cardinal);
  99. const
  100.   Colors: array [0..1] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
  101. var
  102.   W, I, J, Parity: Integer;
  103.   Line1, Line2: TArrayOfColor32; // a buffer for a couple of scanlines
  104. begin
  105.   with Image32.Buffer do
  106.     if StageNum = 0 then
  107.     begin
  108.       W := Width;
  109.       SetLength(Line1, W);
  110.       SetLength(Line2, W);
  111.       for I := 0 to W - 1 do
  112.       begin
  113.         Parity := I shr 3 and $1;
  114.         Line1[I] := Colors[Parity];
  115.         Line2[I] := Colors[1 - Parity];
  116.       end;
  117.       for J := 0 to Height - 1 do
  118.       begin
  119.         Parity := J shr 3 and $1;
  120.         if Boolean(Parity) then MoveLongword(Line1[0], ScanLine[J]^, W)
  121.         else MoveLongword(Line2[0], ScanLine[J]^, W);
  122.       end;
  123.     end
  124.     else
  125.       FrameRectS(BoundsRect , $FF000000);
  126. end;
  127.  
  128. procedure TMainForm.FormCreate(Sender: TObject);
  129. var
  130.   i: integer;
  131. begin
  132.   with Image32 do
  133.   begin
  134.     if PaintStages[0].Stage = PST_CLEAR_BACKGND then PaintStages[0].Stage := PST_CUSTOM;
  135.     PaintStages.Add.Stage := PST_CUSTOM;
  136.   end;
  137.  
  138.   Src := TBitmap32.Create;
  139.   with Src do begin //Making distorted borders look better
  140.    Assign(Image32.Bitmap);
  141.    for i:= 0 to Width - 1 do begin
  142.     Pixel[i, 0] := Pixel[i, 0] and $00FFFFFF;
  143.     Pixel[i, Height - 1] := Pixel[i, 0] and $00FFFFFF;
  144.    end;
  145.    for i:= 0 to Height - 1 do begin
  146.     Pixel[0, i] := Pixel[i, 0] and $00FFFFFF or $7F000000;
  147.     Pixel[Width - 1, i] := Pixel[i, 0] and $00FFFFFF;
  148.    end;
  149.    OuterColor := $00000000;
  150.   end;
  151. end;
  152.  
  153. procedure TMainForm.gbTwistChange(Sender: TObject);
  154. begin
  155.  with Image32 do
  156.   begin
  157.    TwirlDistortion(Bitmap, Src, gbTwist.Position);
  158.    gbTwist.Repaint;
  159.    Repaint;
  160.   end;
  161. end;
  162.  
  163. procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
  164. begin
  165.  Src.Free;
  166. end;
  167.  
  168. end.
  169.