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