1 unit blur_main;
2 
3 {$mode objfpc}{$H+}
4 
5 interface
6 
7 uses
8   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
9   ExtCtrls, StdCtrls, BGRABitmap, BGRABitmapTypes, EpikTimer, LMessages,
10   BGRAGrayscaleMask;
11 
12 type
13 
14   { TForm1 }
15 
16   TForm1 = class(TForm)
17     Label_RadiusValueY: TLabel;
18     Label_RadiusX: TLabel;
19     Label2: TLabel;
20     Label_RadiusY: TLabel;
21     Label_RadiusValueX: TLabel;
22     Panel1: TPanel;
23     Radio_Box: TRadioButton;
24     Radio_Motion: TRadioButton;
25     Radio_Fast: TRadioButton;
26     Radio_Corona: TRadioButton;
27     Radio_Disk: TRadioButton;
28     Radio_OrientedMotion: TRadioButton;
29     Radio_Radial: TRadioButton;
30     TrackBar_BlurRadiusX: TTrackBar;
31     TrackBar_BlurRadiusY: TTrackBar;
32     procedure FormCreate(Sender: TObject);
33     procedure FormDestroy(Sender: TObject);
34     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
35       {%H-}Shift: TShiftState; X, Y: Integer);
36     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
37     procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
38       {%H-}Shift: TShiftState; {%H-}X, {%H-}Y: Integer);
39     procedure FormPaint(Sender: TObject);
40     procedure Radio_Change(Sender: TObject);
41     procedure TrackBar_BlurRadiusChange(Sender: TObject);
42     procedure WMEraseBkgnd(var {%H-}Message: TLMEraseBkgnd); message LM_ERASEBKGND;
43   private
44     { private declarations }
45     procedure UpdateLabelRadius;
46   public
47     { public declarations }
48     image: TBGRABitmap;
49     shadowBase: TGrayscaleMask;
50     timer : TEpikTimer;
51     movingShadow: boolean;
52     movingOrigin,shadowOfs: TPoint;
53   end;
54 
55 var
56   Form1: TForm1;
57 
58 implementation
59 
60 {$R *.lfm}
61 
ComputeAnglenull62 function ComputeAngle(dx, dy: single): single;
63 begin
64      if dy = 0 then
65      begin
66        if dx < 0 then result := 180 else result := 0;
67      end else
68      if dx = 0 then
69      begin
70        if dy < 0 then result := -90 else result := 90;
71      end else
72      begin
73        result := ArcTan(dy/dx)*180/Pi;
74        if dx < 0 then result += 180;
75      end;
76 end;
77 
78 { TForm1 }
79 
80 procedure TForm1.FormPaint(Sender: TObject);
81 var bmp: TBGRABitmap;
82     ombre: TGrayscaleMask;
83     x,y,tx,ty: integer;
84     blurType: TRadialBlurType;
85     radiusX,radiusY,len: single;
86 begin
87   tx := clientWidth;
88   ty := Panel1.Top;
89   bmp := TBGRABitmap.Create(tx,ty,BGRAWhite);
90   x := (tx-image.Width) div 2;
91   y := (ty-image.Height) div 2;
92 
93   radiusX := TrackBar_BlurRadiusX.Position/10;
94   radiusY := TrackBar_BlurRadiusY.Position/10;
95 
96   timer.Clear;
97   timer.Start;
98   if Radio_Motion.Checked or Radio_OrientedMotion.Checked then
99   begin
100     len := sqrt(sqr(radiusX)+sqr(radiusY));
101     ombre := shadowBase.FilterBlurMotion(len*2,ComputeAngle(radiusX,radiusY),Radio_OrientedMotion.Checked) as TGrayscaleMask;
102   end else
103   begin
104     if Radio_Box.Checked then
105     begin
106       blurType := rbBox;
107       ombre := shadowBase.FilterBlurRadial(radiusX,radiusY,blurType) as TGrayscaleMask;
108     end else
109     begin
110       if Radio_Fast.Checked then blurType := rbFast else
111       if Radio_Corona.Checked then blurType := rbCorona else
112       if Radio_Disk.Checked then blurType := rbDisk else
113       if Radio_Radial.Checked then blurType := rbNormal;
114       ombre := shadowBase.FilterBlurRadial(radiusX,radiusY,blurType) as TGrayscaleMask;
115     end;
116   end;
117   timer.Stop;
118   ombre.Rectangle(0,0,ombre.width,ombre.height,TByteMask.New(128));
119   bmp.FillMask(x+shadowOfs.x,y+shadowOfs.y,ombre,BGRA(64,128,64), dmDrawWithTransparency);
120   ombre.free;
121 
122   bmp.PutImage(x,y,image,dmDrawWithTransparency);
123   bmp.TextOut(0,0,inttostr(round(timer.Elapsed*1000))+' ms',BGRABlack);
124   bmp.Draw(Canvas,0,0);
125   bmp.Free;
126 end;
127 
128 procedure TForm1.Radio_Change(Sender: TObject);
129 begin
130   Invalidate;
131 end;
132 
133 procedure TForm1.TrackBar_BlurRadiusChange(Sender: TObject);
134 begin
135   UpdateLabelRadius;
136   Repaint;
137 end;
138 
139 procedure TForm1.WMEraseBkgnd(var Message: TLMEraseBkgnd);
140 begin
141   //
142 end;
143 
144 procedure TForm1.UpdateLabelRadius;
145 begin
146   Label_RadiusValueX.Caption := '= '+FloatToStrF(TrackBar_BlurRadiusX.Position/10,ffFixed,7,1);
147   Label_RadiusValueY.Caption := '= '+FloatToStrF(TrackBar_BlurRadiusY.Position/10,ffFixed,7,1);
148   Label_RadiusValueX.Update;
149   Label_RadiusValueY.Update;
150 end;
151 
152 procedure TForm1.FormCreate(Sender: TObject);
153 begin
154   image := TBGRABitmap.Create(160,200);
155   image.FontName := 'Times New Roman';
156   image.FontHeight := 300;
157   image.FontAntialias:= true;
158   image.TextOut(image.Width div 2,-100,'a',BGRA(128,192,128,255),taCenter);
159   shadowBase := TGrayscaleMask.Create(image, cAlpha);
160   UpdateLabelRadius;
161   timer := TEpikTimer.Create(Self);
162   shadowOfs := Point(10,10);
163 end;
164 
165 procedure TForm1.FormDestroy(Sender: TObject);
166 begin
167   image.free;
168   shadowBase.free;
169 end;
170 
171 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
172   Shift: TShiftState; X, Y: Integer);
173 begin
174   if Button = mbLeft then
175   begin
176     movingOrigin := Point(X,Y);
177     movingShadow := true;
178   end;
179 end;
180 
181 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
182   Y: Integer);
183 begin
184   if movingShadow then
185   begin
186     inc(shadowOfs.x, X-movingOrigin.X);
187     inc(shadowOfs.y, Y-movingOrigin.Y);
188     movingOrigin := Point(X,Y);
189     Invalidate;
190   end;
191 end;
192 
193 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
194   Shift: TShiftState; X, Y: Integer);
195 begin
196   if Button = mbLeft then
197     movingShadow:= false;
198 end;
199 
200 end.
201 
202