1 unit Unit1;
2 
3 {
4 -So lets put things together and play with masks
5 -Just read the code, it should be clear
6 -As you can see this demo will uses more cpu because it create mask every time it paints but still it is very fast
7 }
8 {$mode objfpc}{$H+}
9 
10 interface
11 
12 uses
13   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
14   ComCtrls, StdCtrls, OpenGLContext, BGRABitmap, BGRABitmapTypes, BGRAOpenGL;
15 
16 type
17 
18   { TForm1 }
19 
20   TForm1 = class(TForm)
21     GroupBox1: TGroupBox;
22     Label1: TLabel;
23     Label2: TLabel;
24     Panel1: TPanel;
25     Panel2: TPanel;
26     RadioGroup1: TRadioGroup;
27     Timer1: TTimer;
28     TrackBar1: TTrackBar;
29     procedure FormCreate(Sender: TObject);
30     procedure FormShow(Sender: TObject);
31     procedure Timer1Timer(Sender: TObject);
32   private
33     OpenGLControl: TOpenGLControl;
34   public
35     Tex, Mask: IBGLTexture;
36     rectMask: TRect;
37     MainFont: IBGLFont;
38     r: single;
39     GoBack: boolean;
40     procedure OpenGLControlPaint(Sender: TObject);
41     procedure UpdateMask;
42   end;
43 
44 var
45   Form1: TForm1;
46 
47 implementation
48 
49 uses Types,Math;
50 
51 {$R *.lfm}
52 
53 { TForm1 }
54 
55 procedure TForm1.FormCreate(Sender: TObject);
56 begin
57   OpenGLControl := TOpenGLControl.Create(Self);
58   with OpenGLControl do
59   begin
60     Align := alClient;
61     Parent := Panel2;
62     OnPaint := @OpenGLControlPaint;
63     AutoResizeViewport := True;
64   end;
65   RadioGroup1.ItemIndex := 0;
66 end;
67 
68 procedure TForm1.FormShow(Sender: TObject);
69 begin
70   //You can not make textures before form show
71   Tex := BGLTexture('Background.jpg');
72   MainFont := BGLFont('Arial',20);
73   Timer1.Enabled := True;
74 end;
75 
76 procedure TForm1.Timer1Timer(Sender: TObject);
77 begin
78   if not GoBack then
79   begin
80     if r = 200 then
81       GoBack := True;
82     r += 1;
83   end
84   else
85   begin
86     if r = 50 then
87       GoBack := False;
88     r -= 1;
89   end;
90   OpenGLControl.Invalidate;
91 end;
92 
93 procedure TForm1.OpenGLControlPaint(Sender: TObject);
94 begin
95   //Dont forget this
96   BGLViewPort(OpenGLControl.Width, OpenGLControl.Height, BGRABlack);
97 
98   case RadioGroup1.ItemIndex of
99     0:
100     begin
101       //Draw just texture
102       //StretchPutImage will resample image to prefered size
103       BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex);
104     end;
105     1:
106     begin
107       UpdateMask;
108       //See how mask looks
109       if Assigned(Mask) then
110       begin
111         Mask.BlendMode := obmNormal;
112         BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask);
113       end;
114     end;
115     2:
116     begin
117       UpdateMask;
118       //Now see them together
119       if Assigned(Mask) then
120       begin
121         //draw only the part of the image that overlaps with the mask
122         BGLCanvas.ClipRect := rectMask;
123         BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex);
124         BGLCanvas.NoClip;
125 
126         //apply the mask
127         Mask.BlendMode := obmMultiply;
128         BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask);
129       end;
130 
131       //draw the whole picture without mask
132       BGLCanvas.StretchPutImage(0, 0, OpenGLControl.Width, OpenGLControl.Height, Tex, 255-TrackBar1.Position);
133 
134       if Assigned(Mask) then
135       begin
136         //draw the mask
137         Mask.BlendMode := obmAdd;
138         BGLCanvas.PutImage(rectMask.Left, rectMask.Top, Mask, (255-TrackBar1.Position) div 4);
139       end;
140     end;
141   end;
142 
143   MainFont.TextOut(0,0, inttostr(OpenGLControl.FrameDiffTimeInMSecs) + ' ms');
144 
145   //And dont forget this
146   OpenGLControl.SwapBuffers;
147 end;
148 
149 procedure TForm1.UpdateMask;
150 var rectEllipse: TRect;
151     mousePos: TPoint;
152     bmp: TBGLBitmap;
153 begin
154   mousePos := Panel2.ScreenToControl(Mouse.CursorPos);
155 
156   //determine area of the ellipse
157   rectEllipse := Rect(mousePos.x - ceil(r), mousePos.y - ceil(r),
158                  mousePos.x + ceil(r) + 1, mousePos.y + ceil(r) + 1);
159   rectMask := EmptyRect;
160   if IntersectRect(rectMask, rect(0,0, BGLCanvas.Width, BGLCanvas.Height), rectEllipse) then
161   begin
162     //render the ellipse
163     bmp := TBGLBitmap.Create(rectMask.Right-rectMask.Left, rectMask.Bottom-rectMask.Top, BGRABlack);
164     bmp.FillEllipseAntialias(mousePos.x-rectMask.Left, mousePos.y-rectMask.Top, r, r, BGRAWhite);
165     Mask := bmp.MakeTextureAndFree;
166   end else
167     Mask := nil;
168 end;
169 
170 end.
171