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