source: trunk/Packages/bgrabitmap/bgragrayscalemask.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 11.3 KB
Line 
1unit BGRAGrayscaleMask;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRABitmapTypes;
9
10type
11 { TGrayscaleMask }
12
13 TGrayscaleMask = class
14 private
15 FData: PByte;
16 FWidth, FHeight, FNbPixels: Integer;
17 function GetScanLine(Y: Integer): PByte;
18 procedure Init(AWidth,AHeight: Integer);
19 public
20 constructor Create(AWidth,AHeight: Integer); overload;
21 constructor Create(AWidth,AHeight: Integer; AValue: byte); overload;
22 constructor Create(ABitmap: TBGRACustomBitmap; AChannel: TChannel); overload;
23 constructor CreateDownSample(ABitmap: TBGRACustomBitmap; AWidth,AHeight: integer);
24 procedure CopyFrom(ABitmap: TBGRACustomBitmap; AChannel: TChannel);
25 procedure Draw(ABitmap: TBGRACustomBitmap; X,Y: Integer);
26 procedure DrawAsAlpha(ABitmap: TBGRACustomBitmap; X,Y: Integer; const c: TBGRAPixel); overload;
27 procedure DrawAsAlpha(ABitmap: TBGRACustomBitmap; X,Y: Integer; texture: IBGRAScanner); overload;
28 destructor Destroy; override;
29 function GetPixel(X,Y: integer): byte;
30 procedure SetPixel(X,Y: integer; AValue: byte);
31 property ScanLine[Y: Integer]: PByte read GetScanLine;
32 property Data: PByte read FData;
33 property Width: Integer read FWidth;
34 property Height: Integer read FHeight;
35 property NbPixels: Integer read FNbPixels;
36 end;
37
38procedure DownSamplePutImageGrayscale(sourceData: PByte; sourcePixelSize: NativeInt; sourceRowDelta: NativeInt; sourceWidth, sourceHeight: NativeInt; dest: TGrayscaleMask; ADestRect: TRect); overload;
39procedure DownSamplePutImageGrayscale(source: TBGRACustomBitmap; dest: TGrayscaleMask; ADestRect: TRect); overload;
40
41procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,
42 y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel;
43 texture: IBGRAScanner; RGBOrder: boolean);
44
45implementation
46
47uses BGRABlend;
48
49procedure BGRAFillClearTypeGrayscaleMask(dest: TBGRACustomBitmap; x,
50 y: integer; xThird: integer; mask: TGrayscaleMask; color: TBGRAPixel;
51 texture: IBGRAScanner; RGBOrder: boolean);
52var delta: NativeInt;
53begin
54 delta := mask.Width;
55 BGRABlend.BGRAFillClearTypeMaskPtr(dest,x,y,xThird,mask.ScanLine[0],1,delta,mask.Width,mask.Height,color,texture,RGBOrder);
56end;
57
58{ TGrayscaleMask }
59
60function TGrayscaleMask.GetScanLine(Y: Integer): PByte;
61begin
62 if (y < 0) or (y >= FHeight) then
63 raise ERangeError.Create('Scanline: out of bounds');
64 result := FData + NativeInt(Y)*NativeInt(FWidth);
65end;
66
67procedure TGrayscaleMask.Init(AWidth, AHeight: Integer);
68begin
69 if FData <> nil then
70 begin
71 FreeMem(FData);
72 FData := nil;
73 end;
74 FWidth := AWidth; if FWidth < 0 then FWidth:= 0;
75 FHeight := AHeight; if FHeight < 0 then FHeight:= 0;
76 FNbPixels:= FWidth*FHeight;
77 if FNbPixels > 0 then getmem(FData, FNbPixels);
78end;
79
80procedure TGrayscaleMask.CopyFrom(ABitmap: TBGRACustomBitmap; AChannel: TChannel
81 );
82var psrc: PByte;
83 pdest: PByte;
84 x,y: integer;
85 ofs: NativeInt;
86begin
87 Init(ABitmap.Width,ABitmap.Height);
88 if FNbPixels > 0 then
89 begin
90 pdest := FData;
91 Case AChannel of
92 cAlpha: ofs := TBGRAPixel_AlphaByteOffset;
93 cRed: ofs := TBGRAPixel_RedByteOffset;
94 cGreen: ofs := TBGRAPixel_GreenByteOffset;
95 else
96 ofs := TBGRAPixel_BlueByteOffset;
97 end;
98 for y := 0 to FHeight-1 do
99 begin
100 psrc := PByte(ABitmap.ScanLine[y])+ofs;
101 for x := FWidth-1 downto 0 do
102 begin
103 pdest^ := psrc^;
104 inc(pdest);
105 inc(psrc,sizeof(TBGRAPixel));
106 end;
107 end;
108 end;
109end;
110
111constructor TGrayscaleMask.Create(AWidth, AHeight: Integer);
112begin
113 Init(AWidth,AHeight);
114 if FNbPixels > 0 then FillChar(FData^, FNbPixels, 0);
115end;
116
117constructor TGrayscaleMask.Create(AWidth, AHeight: Integer; AValue: byte);
118begin
119 Init(AWidth,AHeight);
120 if FNbPixels > 0 then FillChar(FData^, FNbPixels, AValue);
121end;
122
123constructor TGrayscaleMask.Create(ABitmap: TBGRACustomBitmap; AChannel: TChannel);
124begin
125 CopyFrom(ABitmap, AChannel);
126end;
127
128constructor TGrayscaleMask.CreateDownSample(ABitmap: TBGRACustomBitmap; AWidth,
129 AHeight: integer);
130begin
131 if (AWidth = ABitmap.Width) and (AHeight = ABitmap.Height) then
132 CopyFrom(ABitmap,cGreen)
133 else
134 begin
135 if (ABitmap.Width < AWidth) or (ABitmap.Height < AHeight) then
136 raise exception.Create('Original size smaller');
137 Init(AWidth,AHeight);
138 if FNbPixels > 0 then
139 DownSamplePutImageGrayscale(ABitmap, self, rect(0,0,FWidth,FHeight));
140 end;
141end;
142
143procedure TGrayscaleMask.Draw(ABitmap: TBGRACustomBitmap; X, Y: Integer);
144var
145 yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount,
146 i, delta_source, delta_dest: integer;
147 pdest: PBGRAPixel;
148 psource: PByte;
149 value: byte;
150begin
151 if not CheckPutImageBounds(x,y,FWidth,Fheight,minxb,minyb,maxxb,maxyb,ignoreleft,ABitmap.ClipRect) then exit;
152 copycount := maxxb - minxb + 1;
153
154 psource := ScanLine[minyb - y] + ignoreleft;
155 delta_source := FWidth;
156
157 pdest := ABitmap.Scanline[minyb] + minxb;
158 if ABitmap.LineOrder = riloBottomToTop then
159 delta_dest := -ABitmap.Width
160 else
161 delta_dest := ABitmap.Width;
162
163 Dec(delta_source, copycount);
164 Dec(delta_dest, copycount);
165 for yb := minyb to maxyb do
166 begin
167 for i := copycount -1 downto 0 do
168 begin
169 value := psource^;
170 pdest^ := BGRA(value,value,value,255);
171 inc(psource);
172 inc(pdest);
173 end;
174 Inc(psource, delta_source);
175 Inc(pdest, delta_dest);
176 end;
177 ABitmap.InvalidateBitmap;
178end;
179
180procedure TGrayscaleMask.DrawAsAlpha(ABitmap: TBGRACustomBitmap; X, Y: Integer;
181 const c: TBGRAPixel);
182var
183 yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount,
184 i, delta_source, delta_dest: integer;
185 pdest: PBGRAPixel;
186 psource: PByte;
187begin
188 if not CheckPutImageBounds(x,y,FWidth,Fheight,minxb,minyb,maxxb,maxyb,ignoreleft,ABitmap.ClipRect) then exit;
189 copycount := maxxb - minxb + 1;
190
191 psource := ScanLine[minyb - y] + ignoreleft;
192 delta_source := FWidth;
193
194 pdest := ABitmap.Scanline[minyb] + minxb;
195 if ABitmap.LineOrder = riloBottomToTop then
196 delta_dest := -ABitmap.Width
197 else
198 delta_dest := ABitmap.Width;
199
200 Dec(delta_source, copycount);
201 Dec(delta_dest, copycount);
202 for yb := minyb to maxyb do
203 begin
204 for i := copycount -1 downto 0 do
205 begin
206 DrawPixelInlineWithAlphaCheck(pdest,c,psource^);
207 inc(psource);
208 inc(pdest);
209 end;
210 Inc(psource, delta_source);
211 Inc(pdest, delta_dest);
212 end;
213 ABitmap.InvalidateBitmap;
214end;
215
216procedure TGrayscaleMask.DrawAsAlpha(ABitmap: TBGRACustomBitmap; X, Y: Integer;
217 texture: IBGRAScanner);
218var
219 yb, minxb, minyb, maxxb, maxyb, ignoreleft, copycount,
220 i, delta_source, delta_dest: integer;
221 pdest,ptex: PBGRAPixel;
222 psource: PByte;
223 memScan: PBGRAPixel;
224begin
225 if not CheckPutImageBounds(x,y,FWidth,Fheight,minxb,minyb,maxxb,maxyb,ignoreleft,ABitmap.ClipRect) then exit;
226 copycount := maxxb - minxb + 1;
227 if copycount <= 0 then exit;
228
229 psource := ScanLine[minyb - y] + ignoreleft;
230 delta_source := FWidth;
231
232 pdest := ABitmap.Scanline[minyb] + minxb;
233 if ABitmap.LineOrder = riloBottomToTop then
234 delta_dest := -ABitmap.Width
235 else
236 delta_dest := ABitmap.Width;
237
238 getmem(memscan, copycount*sizeof(TBGRAPixel));
239
240 Dec(delta_source, copycount);
241 Dec(delta_dest, copycount);
242 for yb := minyb to maxyb do
243 begin
244 texture.ScanMoveTo(ignoreleft,yb-y);
245 texture.ScanPutPixels(memscan,copycount,dmSet);
246 ptex := memScan;
247 for i := copycount -1 downto 0 do
248 begin
249 DrawPixelInlineWithAlphaCheck(pdest,ptex^,psource^);
250 inc(psource);
251 inc(pdest);
252 inc(ptex);
253 end;
254 Inc(psource, delta_source);
255 Inc(pdest, delta_dest);
256 end;
257 ABitmap.InvalidateBitmap;
258 freemem(memscan);
259end;
260
261destructor TGrayscaleMask.Destroy;
262begin
263 if FData <> nil then
264 begin
265 freemem(FData);
266 FData := nil;
267 end;
268 inherited Destroy;
269end;
270
271function TGrayscaleMask.GetPixel(X, Y: integer): byte;
272begin
273 if (x < 0) or (x >= FWidth) then
274 raise ERangeError.Create('GetPixel: out of bounds');
275 result := (ScanLine[Y]+X)^;
276end;
277
278procedure TGrayscaleMask.SetPixel(X, Y: integer; AValue: byte);
279begin
280 if (x < 0) or (x >= FWidth) then
281 raise ERangeError.Create('SetPixel: out of bounds');
282 (ScanLine[Y]+X)^ := AValue;
283end;
284
285procedure DownSamplePutImageGrayscale(sourceData: PByte;
286 sourcePixelSize: NativeInt; sourceRowDelta: NativeInt; sourceWidth,
287 sourceHeight: NativeInt; dest: TGrayscaleMask; ADestRect: TRect);
288var
289 x_dest,y_dest: integer;
290 pdest: PByte;
291 nbPix,sum: NativeUInt;
292 prev_x_src,x_src,x_src_nb,xb: NativeInt;
293 x_src_inc,x_src_acc,x_src_div,x_src_rest: NativeInt;
294 prev_y_src,y_src,y_src_nb,yb: NativeInt;
295 y_src_inc,y_src_acc,y_src_div,y_src_rest: NativeInt;
296 psrc,psrc2,psrc3: PByte;
297begin
298 y_src_div := ADestRect.Bottom-ADestRect.Top;
299 y_src_inc := sourceHeight div y_src_div;
300 y_src_rest := sourceHeight mod y_src_div;
301 x_src_div := ADestRect.Right-ADestRect.Left;
302 x_src_inc := sourceWidth div x_src_div;
303 x_src_rest := sourceWidth mod x_src_div;
304
305 if (x_src_rest = 0) and (y_src_rest = 0) then
306 begin
307 x_src_nb := x_src_inc;
308 y_src_nb := y_src_inc;
309 nbPix := x_src_nb*y_src_nb;
310 y_src := 0;
311 for y_dest := ADestRect.Top to ADestRect.Bottom-1 do
312 begin
313 pdest := dest.ScanLine[y_dest]+ADestRect.Left;
314 psrc := sourceData + y_src*sourceRowDelta;
315 inc(y_src,y_src_inc);
316
317 for x_dest := ADestRect.Right-ADestRect.Left-1 downto 0 do
318 begin
319 sum := 0;
320 psrc2 := psrc;
321 for xb := x_src_nb-1 downto 0 do
322 begin
323 psrc3 := psrc2;
324 for yb := y_src_nb-1 downto 0 do
325 begin
326 inc(sum, psrc3^);
327 inc(psrc3, sourceRowDelta);
328 end;
329 inc(psrc2, sourcePixelSize);
330 end;
331 pdest^ := sum div nbPix;
332
333 psrc := psrc2;
334 inc(pdest);
335 end;
336 end;
337 end else
338 begin
339 y_src := 0;
340 y_src_acc := 0;
341 for y_dest := ADestRect.Top to ADestRect.Bottom-1 do
342 begin
343 pdest := dest.ScanLine[y_dest]+ADestRect.Left;
344 psrc := sourceData + y_src*sourceRowDelta;
345
346 prev_y_src := y_src;
347 inc(y_src,y_src_inc);
348 inc(y_src_acc,y_src_rest);
349 if y_src_acc >= y_src_div then
350 begin
351 dec(y_src_acc,y_src_div);
352 inc(y_src);
353 end;
354 y_src_nb := y_src-prev_y_src;
355
356 x_src := 0;
357 x_src_acc := 0;
358 for x_dest := ADestRect.Right-ADestRect.Left-1 downto 0 do
359 begin
360 prev_x_src := x_src;
361 inc(x_src,x_src_inc);
362 inc(x_src_acc,x_src_rest);
363 if x_src_acc >= x_src_div then
364 begin
365 dec(x_src_acc,x_src_div);
366 inc(x_src);
367 end;
368 x_src_nb := x_src-prev_x_src;
369
370 sum := 0;
371 nbPix := 0;
372 psrc2 := psrc;
373 for xb := x_src_nb-1 downto 0 do
374 begin
375 psrc3 := psrc2;
376 for yb := y_src_nb-1 downto 0 do
377 begin
378 inc(nbPix);
379 inc(sum, psrc3^);
380 inc(psrc3, sourceRowDelta);
381 end;
382 inc(psrc2, sourcePixelSize);
383 end;
384 pdest^ := sum div nbPix;
385
386 psrc := psrc2;
387 inc(pdest);
388 end;
389 end;
390 end;
391end;
392
393procedure DownSamplePutImageGrayscale(source: TBGRACustomBitmap;
394 dest: TGrayscaleMask; ADestRect: TRect);
395var delta: NativeInt;
396begin
397 delta := source.Width*sizeof(TBGRAPixel);
398 if source.LineOrder = riloBottomToTop then
399 delta := -delta;
400 DownSamplePutImageGrayscale(PByte(source.ScanLine[0])+1,sizeof(TBGRAPixel),delta,source.Width,source.Height,dest,ADestRect);
401end;
402
403end.
404
Note: See TracBrowser for help on using the repository browser.