1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 {
3 /**************************************************************************\
4 bgrabitmaptypes.pas
5 -------------------
6 This unit defines basic types and it must be
7 included in the 'uses' clause.
8
9 --> Include BGRABitmap and BGRABitmapTypes in the 'uses' clause.
10 If you are using LCL types, add also BGRAGraphics unit.
11 }
12
13 unit BGRABitmapTypes;
14
15 {$mode objfpc}{$H+}
16 {$i bgrabitmap.inc}
17
18 interface
19
20 uses
21 BGRAClasses, BGRAGraphics, BGRAUnicode,
22 FPImage{$IFDEF BGRABITMAP_USE_FPCANVAS}, FPImgCanv{$ENDIF}
23 {$IFDEF BGRABITMAP_USE_LCL}, LCLType, GraphType, LResources{$ENDIF},
24 BGRAMultiFileType;
25
26
27 const
28 BGRABitmapVersion = 11030100;
29
BGRABitmapVersionStrnull30 function BGRABitmapVersionStr: string;
31
32 type
33 TMultiFileContainer = BGRAMultiFileType.TMultiFileContainer;
34 Int32or64 = BGRAClasses.Int32or64;
35 UInt32or64 = BGRAClasses.UInt32or64;
36 HDC = {$IFDEF BGRABITMAP_USE_LCL}LCLType.HDC{$ELSE}PtrUInt{$ENDIF};
37
38 {=== Miscellaneous types ===}
39
40 type
41 {* Options when doing a floodfill (also called bucket fill) }
42 TFloodfillMode = (
43 {** Pixels that are filled are replaced }
44 fmSet,
45 {** Pixels that are filled are drawn upon with the fill color }
46 fmDrawWithTransparency,
47 {** Pixels that are filled are drawn without gamma correction upon with the fill color }
48 fmLinearBlend,
49 {** Pixels that are XORed with the fill color}
50 fmXor,
51 {** Pixels that are filled are drawn upon to the extent that the color underneath is similar to
52 the start color. The more different the different is, the less it is drawn upon }
53 fmProgressive);
54
55 {* Specifies how much smoothing is applied to the computation of the median }
56 TMedianOption = (moNone, moLowSmooth, moMediumSmooth, moHighSmooth);
57 {* Specifies the shape of a predefined blur }
58 TRadialBlurType = (
59 {** Gaussian-like, pixel importance decreases progressively }
60 rbNormal,
61 {** Disk blur, pixel importance does not decrease progressively }
62 rbDisk,
63 {** Pixel are considered when they are at a certain distance }
64 rbCorona,
65 {** Gaussian-like, but 10 times smaller than ''rbNormal'' }
66 rbPrecise,
67 {** Gaussian-like but simplified to be computed faster }
68 rbFast,
69 {** Box blur, pixel importance does not decrease progressively
70 and the pixels are included when they are in a square.
71 This is much faster than ''rbFast'' however you may get
72 square shapes in the resulting image }
73 rbBox);
74
75 TEmbossOption = (eoTransparent, eoPreserveHue);
76 TEmbossOptions = set of TEmbossOption;
77
78 {* List of image formats }
79 TBGRAImageFormat = (
80 {** Unknown format }
81 ifUnknown,
82 {** JPEG format, opaque, lossy compression }
83 ifJpeg,
84 {** PNG format, transparency, lossless compression }
85 ifPng,
86 {** GIF format, single transparent color, lossless in theory but only low number of colors allowed }
87 ifGif,
88 {** BMP format, transparency, no compression. Note that transparency is
89 not supported by all BMP readers so it is recommended to avoid
90 storing images with transparency in this format }
91 ifBmp,
92 {** iGO BMP (16-bit, rudimentary lossless compression) }
93 ifBmpMioMap,
94 {** ICO format, contains different sizes of the same image }
95 ifIco,
96 {** CUR format, has hotspot, contains different sizes of the same image }
97 ifCur,
98 {** PCX format, opaque, rudimentary lossless compression }
99 ifPcx,
100 {** Paint.NET format, layers, lossless compression }
101 ifPaintDotNet,
102 {** LazPaint format, layers, lossless compression }
103 ifLazPaint,
104 {** OpenRaster format, layers, lossless compression }
105 ifOpenRaster,
106 {** Phoxo format, layers }
107 ifPhoxo,
108 {** Photoshop format, layers, rudimentary lossless compression }
109 ifPsd,
110 {** Targa format (TGA), transparency, rudimentary lossless compression }
111 ifTarga,
112 {** TIFF format, limited support }
113 ifTiff,
114 {** X-Window capture, limited support }
115 ifXwd,
116 {** X-Pixmap, text encoded image, limited support }
117 ifXPixMap,
118 {** text or binary encoded image, no compression, extension PBM, PGM, PPM }
119 ifPortableAnyMap,
120 {** Scalable Vector Graphic, vectorial, read-only as raster }
121 ifSvg,
122 {** Lossless or lossy compression using V8 algorithm (need libwebp library) }
123 ifWebP);
124
125 {* Options when loading an image }
126 TBGRALoadingOption = (
127 {** Do not clear RGB channels when alpha is zero (not recommended) }
128 loKeepTransparentRGB,
129 {** Consider BMP to be opaque if no alpha value is provided (for compatibility) }
130 loBmpAutoOpaque,
131 {** Load JPEG quickly however with a lower quality }
132 loJpegQuick);
133 TBGRALoadingOptions = set of TBGRALoadingOption;
134
135 TTextLayout = BGRAGraphics.TTextLayout;
136 TFontBidiMode = BGRAUnicode.TFontBidiMode;
137 TBidiTextAlignment = (btaNatural, btaOpposite, btaLeftJustify, btaRightJustify, btaCenter);
138
139 const
140 fbmAuto = BGRAUnicode.fbmAuto;
141 fbmLeftToRight = BGRAUnicode.fbmLeftToRight;
142 fbmRightToLeft = BGRAUnicode.fbmRightToLeft;
143
AlignmentToBidiTextAlignmentnull144 function AlignmentToBidiTextAlignment(AAlign: TAlignment; ARightToLeft: boolean): TBidiTextAlignment; overload;
AlignmentToBidiTextAlignmentnull145 function AlignmentToBidiTextAlignment(AAlign: TAlignment): TBidiTextAlignment; overload;
BidiTextAlignmentToAlignmentnull146 function BidiTextAlignmentToAlignment(ABidiAlign: TBidiTextAlignment; ARightToLeft: boolean): TAlignment;
147
148 const
149 RadialBlurTypeToStr: array[TRadialBlurType] of string =
150 ('Normal','Disk','Corona','Precise','Fast','Box');
151
152
153 tlTop = BGRAGraphics.tlTop;
154 tlCenter = BGRAGraphics.tlCenter;
155 tlBottom = BGRAGraphics.tlBottom;
156
157 // checks the bounds of an image in the given clipping rectangle
CheckPutImageBoundsnull158 function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb, maxyb, ignoreleft: integer; const cliprect: TRect): boolean;
159
160 {==== Imported from GraphType ====}
161 //if this unit is defined, otherwise
162 //define here the types used by the library.
163 {$IFDEF BGRABITMAP_USE_LCL}
164 type
165 { Order of the lines in an image }
166 TRawImageLineOrder = GraphType.TRawImageLineOrder;
167 { Order of the bits in a byte containing pixel values }
168 TRawImageBitOrder = GraphType.TRawImageBitOrder;
169 { Order of the bytes in a group of byte containing pixel values }
170 TRawImageByteOrder = GraphType.TRawImageByteOrder;
171 { Definition of a single line 3D bevel }
172 TGraphicsBevelCut = GraphType.TGraphicsBevelCut;
173
174 const
175 riloTopToBottom = GraphType.riloTopToBottom; // The first line (line 0) is the top line
176 riloBottomToTop = GraphType.riloBottomToTop; // The first line (line 0) is the bottom line
177
178 riboBitsInOrder = GraphType.riboBitsInOrder; // Bit 0 is pixel 0
179 riboReversedBits = GraphType.riboReversedBits; // Bit 0 is pixel 7 (Bit 1 is pixel 6, ...)
180
181 riboLSBFirst = GraphType.riboLSBFirst; // least significant byte first (little endian)
182 riboMSBFirst = GraphType.riboMSBFirst; // most significant byte first (big endian)
183
184 fsSurface = GraphType.fsSurface; //type is defined as Graphics.TFillStyle
185 fsBorder = GraphType.fsBorder;
186
187 bvNone = GraphType.bvNone;
188 bvLowered = GraphType.bvLowered;
189 bvRaised = GraphType.bvRaised;
190 bvSpace = GraphType.bvSpace;
191 {$ELSE}
192 type
193 {* Order of the lines in an image }
194 TRawImageLineOrder = (
195 {** The first line in memory (line 0) is the top line }
196 riloTopToBottom,
197 {** The first line in memory (line 0) is the bottom line }
198 riloBottomToTop);
199
200 {* Order of the bits in a byte containing pixel values }
201 TRawImageBitOrder = (
202 {** The lowest bit is on the left. So with a monochrome picture, bit 0 would be pixel 0 }
203 riboBitsInOrder,
204 {** The lowest bit is on the right. So with a momochrome picture, bit 0 would be pixel 7 (bit 1 would be pixel 6, ...) }
205 riboReversedBits);
206
207 {* Order of the bytes in a group of byte containing pixel values }
208 TRawImageByteOrder = (
209 {** Least significant byte first (little endian) }
210 riboLSBFirst,
211 {** most significant byte first (big endian) }
212 riboMSBFirst);
213
214 {* Definition of a single line 3D bevel }
215 TGraphicsBevelCut =
216 (
217 {** No bevel }
218 bvNone,
219 {** Shape is lowered, light is on the bottom-right corner }
220 bvLowered,
221 {** Shape is raised, light is on the top-left corner }
222 bvRaised,
223 {** Shape is at the same level, there is no particular lighting }
224 bvSpace);
225 {$ENDIF}
226
227 {$DEFINE INCLUDE_INTERFACE}
228 {$I bgrapixel.inc}
229
230 {$DEFINE INCLUDE_INTERFACE}
231 {$I geometrytypes.inc}
232
233 {$DEFINE INCLUDE_INTERFACE}
234 {$i csscolorconst.inc}
235
236 {$DEFINE INCLUDE_INTERFACE}
237 {$I bgrascanner.inc}
238
239 {$DEFINE INCLUDE_INTERFACE}
240 {$I unibitmap.inc}
241
242 {$DEFINE INCLUDE_INTERFACE}
243 {$I unibitmapgeneric.inc}
244
245 {==== Integer math ====}
246
247 {* Computes the value modulo cycle, and if the ''value'' is negative, the result
248 is still positive }
PositiveModnull249 function PositiveMod(value, cycle: Int32or64): Int32or64; inline; overload;
250
251 { Sin65536 and Cos65536 are fast routines to compute sine and cosine as integer values.
252 They use a table to store already computed values. The return value is an integer
253 ranging from 0 to 65536, so the mean value is 32768 and the half amplitude is
254 32768 instead of 1. The input has a period of 65536, so you can supply any integer
255 without applying a modulo. }
256
257 { Compute all values now }
258 procedure PrecalcSin65536;
259
260 {* Returns an integer approximation of the sine. Value ranges from 0 to 65535,
261 where 65536 corresponds to the next cycle }
Sin65536null262 function Sin65536(value: word): Int32or64; inline;
263 {* Returns an integer approximation of the cosine. Value ranges from 0 to 65535,
264 where 65536 corresponds to the next cycle }
Cos65536null265 function Cos65536(value: word): Int32or64; inline;
266
267 {* Returns the square root of the given byte, considering that
268 255 is equal to unity }
ByteSqrtnull269 function ByteSqrt(value: byte): byte; inline;
270
271 {==== Types provided for fonts ====}
272 type
273 {* Quality to be used to render text }
274 TBGRAFontQuality = (
275 {** Use the system capabilities. It is rather fast however it may be
276 not be smoothed. }
277 fqSystem,
278 {** Use the system capabilities to render with ClearType. This quality is
279 of course better than fqSystem however it may not be perfect.}
280 fqSystemClearType,
281 {** Garanties a high quality antialiasing. }
282 fqFineAntialiasing,
283 {** Fine antialiasing with ClearType assuming an LCD display in red/green/blue order }
284 fqFineClearTypeRGB,
285 {** Fine antialiasing with ClearType assuming an LCD display in blue/green/red order }
286 fqFineClearTypeBGR);
287
TBGRAFontQualitynull288 TGetFineClearTypeAutoFunc = function(): TBGRAFontQuality;
289 var
290 fqFineClearType : TGetFineClearTypeAutoFunc;
291
292 type
293 {* Measurements of a font }
294 TFontPixelMetric = record
295 {** The values have been computed }
296 Defined: boolean;
297 {** Position of the baseline, where most letters lie }
298 Baseline,
299 {** Position of the top of the small letters (x being one of them) }
300 xLine,
301 {** Position of the top of the UPPERCASE letters }
302 CapLine,
303 {** Position of the bottom of letters like g and p }
304 DescentLine,
305 {** Total line height including line spacing defined by the font }
306 Lineheight: integer;
307 end;
308
309 {* Measurements of a font in floating point values }
310 TFontPixelMetricF = record
311 {** The values have been computed }
312 Defined: boolean;
313 {** Position of the baseline, where most letters lie }
314 Baseline,
315 {** Position of the top of the small letters (x being one of them) }
316 xLine,
317 {** Position of the top of the UPPERCASE letters }
318 CapLine,
319 {** Position of the bottom of letters like g and p }
320 DescentLine,
321 {** Total line height including line spacing defined by the font }
322 Lineheight: single;
323 end;
324
325 {* Vertical anchoring of the font. When text is drawn, a start coordinate
326 is necessary. Text can be positioned in different ways. This enum
327 defines what position it is regarding the font }
328 TFontVerticalAnchor = (
329 {** The top of the font. Everything will be drawn below the start coordinate. }
330 fvaTop,
331 {** The center of the font }
332 fvaCenter,
333 {** The top of capital letters }
334 fvaCapLine,
335 {** The center of capital letters }
336 fvaCapCenter,
337 {** The top of small letters }
338 fvaXLine,
339 {** The center of small letters }
340 fvaXCenter,
341 {** The baseline, the bottom of most letters }
342 fvaBaseline,
343 {** The bottom of letters that go below the baseline }
344 fvaDescentLine,
345 {** The bottom of the font. Everything will be drawn above the start coordinate }
346 fvaBottom);
347
348 {* Definition of a function that handles work-break }
349 TWordBreakHandler = procedure(var ABeforeUTF8, AAfterUTF8: string) of object;
350
351 {* Alignment for a typewriter, that does not have any more information
352 than a square shape containing glyphs }
353 TBGRATypeWriterAlignment = (twaTopLeft, twaTop, twaTopRight, twaLeft, twaMiddle, twaRight, twaBottomLeft, twaBottom, twaBottomRight);
354 {* How a typewriter must render its content on a Canvas2d }
355 TBGRATypeWriterOutlineMode = (twoPath, twoFill, twoStroke, twoFillOverStroke, twoStrokeOverFill, twoFillThenStroke, twoStrokeThenFill);
356
357 { TBGRACustomFontRenderer }
358 {* Abstract class for all font renderers }
359 TBGRACustomFontRenderer = class
360 protected
361 {** Specifies the height of the font without taking into account additional line spacing.
362 A negative value means that it is the full height instead }
363 FFontEmHeightF: single;
GetFontEmHeightnull364 function GetFontEmHeight: integer;
365 procedure SetFontEmHeight(AValue: integer);
366 public
367 {** Specifies the font to use. Unless the font renderer accept otherwise,
368 the name is in human readable form, like 'Arial', 'Times New Roman', ... }
369 FontName: string;
370
371 {** Specifies the set of styles to be applied to the font.
372 These can be fsBold, fsItalic, fsStrikeOut, fsUnderline.
373 So the value [fsBold,fsItalic] means that the font must be bold and italic }
374 FontStyle: TFontStyles;
375
376 {** Specifies the quality of rendering. Default value is fqSystem }
377 FontQuality : TBGRAFontQuality;
378
379 {** Specifies the rotation of the text, for functions that support text rotation.
380 It is expressed in tenth of degrees, positive values going counter-clockwise }
381 FontOrientation: integer;
382
383 {** Returns measurement for the current font in pixels }
GetFontPixelMetricnull384 function GetFontPixelMetric: TFontPixelMetric; virtual; abstract;
GetFontPixelMetricFnull385 function GetFontPixelMetricF: TFontPixelMetricF; virtual;
FontExistsnull386 function FontExists(AName: string): boolean; virtual; abstract;
387
388 {** Returns the total size of the string provided using the current font.
389 Orientation is not taken into account, so that the width is along the text }
TextSizenull390 function TextSize(sUTF8: string): TSize; overload; virtual; abstract;
TextSizeFnull391 function TextSizeF(sUTF8: string): TPointF; overload; virtual;
TextSizenull392 function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; overload; virtual; abstract;
TextSizeFnull393 function TextSizeF(sUTF8: string; AMaxWidthF: single; ARightToLeft: boolean): TPointF; overload; virtual;
TextSizeAnglenull394 function TextSizeAngle(sUTF8: string; {%H-}orientationTenthDegCCW: integer): TSize; virtual;
TextSizeAngleFnull395 function TextSizeAngleF(sUTF8: string; {%H-}orientationTenthDegCCW: integer): TPointF; virtual;
396
397 {** Returns the number of Unicode characters that fit into the specified size }
TextFitInfonull398 function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; virtual; abstract;
TextFitInfoFnull399 function TextFitInfoF(sUTF8: string; AMaxWidthF: single): integer; virtual;
400
401 {** Draws the UTF8 encoded string, with color ''c''.
402 If align is taLeftJustify, (''x'',''y'') is the top-left corner.
403 If align is taCenter, (''x'',''y'') is at the top and middle of the text.
404 If align is taRightJustify, (''x'',''y'') is the top-right corner.
405 The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
406 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
407 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
408
409 {** Same as above functions, except that the text is filled using texture.
410 The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
411 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
412 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
413
414 {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
415 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
416 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
417 {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
418 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
419 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
420
421 {** Draw the UTF8 encoded string at the coordinate (''x'',''y''), clipped inside the rectangle ''ARect''.
422 Additional style information is provided by the style parameter.
423 The color ''c'' is used to fill the text. No rotation is applied. }
424 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; virtual; abstract;
425
426 {** Same as above except a ''texture'' is used to fill the text }
427 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; virtual; abstract;
428
429 {** Copy the path for the UTF8 encoded string into ''ADest''.
430 If ''align'' is ''taLeftJustify'', (''x'',''y'') is the top-left corner.
431 If ''align'' is ''taCenter'', (''x'',''y'') is at the top and middle of the text.
432 If ''align'' is ''taRightJustify'', (''x'',''y'') is the top-right corner. }
433 procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment); virtual; //optional
434 procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment; {%H-}ARightToLeft: boolean); virtual; //optional
HandlesTextPathnull435 function HandlesTextPath: boolean; virtual;
436
437 property FontEmHeight: integer read GetFontEmHeight write SetFontEmHeight;
438 property FontEmHeightF: single read FFontEmHeightF write FFontEmHeightF;
439 end;
440
441 {* Output mode for the improved renderer for readability. This is used by the font renderer based on LCL in ''BGRAText'' }
442 TBGRATextOutImproveReadabilityMode = (irMask, irNormal, irClearTypeRGB, irClearTypeBGR);
443
444 {** Removes line ending and tab characters from a string (for a function
445 like ''TextOut'' that does not handle this). this works with UTF8 strings
446 as well }
CleanTextOutStringnull447 function CleanTextOutString(const s: string): string;
448 {** Remove the line ending at the specified position or return False.
449 This works with UTF8 strings however the index is the byte index }
RemoveLineEndingnull450 function RemoveLineEnding(var s: string; indexByte: integer): boolean;
451 {** Remove the line ending at the specified position or return False.
452 The index is the character index, that may be different from the
453 byte index }
RemoveLineEndingUTF8null454 function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
455 {** Default word break handler }
456 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
457
458 {==== Images and resampling ====}
459
460 type
461 {* How the resample is to be computed }
462 TResampleMode = (
463 {** Low quality resample by repeating pixels, stretching them }
464 rmSimpleStretch,
465 {** Use resample filters. This gives high
466 quality resampling however this the proportion changes slightly because
467 the first and last pixel are considered to occupy only half a unit as
468 they are considered as the border of the picture
469 (pixel-centered coordinates) }
470 rmFineResample);
471
472 {* List of resample filter to be used with ''rmFineResample'' }
473 TResampleFilter = (
474 {** Equivalent of simple stretch with high quality and pixel-centered coordinates }
475 rfBox,
476 {** Linear interpolation giving slow transition between pixels }
477 rfLinear,
478 {** Mix of ''rfLinear'' and ''rfCosine'' giving medium speed stransition between pixels }
479 rfHalfCosine,
480 {** Cosine-like interpolation giving fast transition between pixels }
481 rfCosine,
482 {** Simple bi-cubic filter (blurry) }
483 rfBicubic,
484 {** Mitchell filter, good for downsizing interpolation }
485 rfMitchell,
486 {** Spline filter, good for upsizing interpolation, however slightly blurry }
487 rfSpline,
488 {** Lanczos with radius 2, blur is corrected }
489 rfLanczos2,
490 {** Lanczos with radius 3, high contrast }
491 rfLanczos3,
492 {** Lanczos with radius 4, high contrast }
493 rfLanczos4,
494 {** Best quality using rfMitchell or rfSpline }
495 rfBestQuality);
496
497 const
498 {** List of strings to represent resample filters }
499 ResampleFilterStr : array[TResampleFilter] of string =
500 ('Box','Linear','HalfCosine','Cosine','Bicubic','Mitchell','Spline',
501 'Lanczos2','Lanczos3','Lanczos4','BestQuality');
502
503 {** Gives the sample filter represented by a string }
StrToResampleFilternull504 function StrToResampleFilter(str: string): TResampleFilter;
505
506 type
507 {* Image information from superficial analysis }
508 TQuickImageInfo = record
509 {** Width in pixels }
510 Width,
511 {** Height in pixels }
512 Height,
513 {** Bitdepth for colors (1, 2, 4, 8 for images with palette/grayscale, 16, 24 or 48 if each channel is present) }
514 ColorDepth,
515 {** Bitdepth for alpha (0 if no alpha channel, 1 if bit mask, 8 or 16 if alpha channel) }
516 AlphaDepth: integer;
517 end;
518
519 {* Bitmap reader with additional features }
520 TBGRAImageReader = class(TFPCustomImageReader)
521 {** Return bitmap information (size, bit depth) }
GetQuickInfonull522 function GetQuickInfo(AStream: TStream): TQuickImageInfo; virtual; abstract;
523 {** Return a draft of the bitmap, the ratio may change compared to the original width and height (useful to make thumbnails) }
GetBitmapDraftnull524 function GetBitmapDraft(AStream: TStream; AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; virtual; abstract;
525 end;
526
527 { TBGRACustomWriterPNG }
528
529 TBGRACustomWriterPNG = class(TFPCustomImageWriter)
530 protected
GetUseAlphanull531 function GetUseAlpha: boolean; virtual; abstract;
532 procedure SetUseAlpha(AValue: boolean); virtual; abstract;
533 public
534 property UseAlpha : boolean read GetUseAlpha write SetUseAlpha;
535 end;
536
537 var
538 {** List of stream readers for images }
539 DefaultBGRAImageReader: array[TBGRAImageFormat] of TFPCustomImageReaderClass;
540 {** List of stream writers for images }
541 DefaultBGRAImageWriter: array[TBGRAImageFormat] of TFPCustomImageWriterClass;
542
543 {** Detect the file format of a given file }
DetectFileFormatnull544 function DetectFileFormat(AFilenameUTF8: string): TBGRAImageFormat;
545 {** Detect the file format of a given stream. ''ASuggestedExtensionUTF8'' can
546 be provided to guess the format }
DetectFileFormatnull547 function DetectFileFormat(AStream: TStream; ASuggestedExtensionUTF8: string = ''): TBGRAImageFormat;
548 {** Returns the file format that is most likely to be stored in the
549 given filename (according to its extension) }
SuggestImageFormatnull550 function SuggestImageFormat(AFilenameOrExtensionUTF8: string): TBGRAImageFormat;
551 {** Returns a likely image extension for the format }
SuggestImageExtensionnull552 function SuggestImageExtension(AFormat: TBGRAImageFormat): string;
553 {** Create an image reader for the given format }
CreateBGRAImageReadernull554 function CreateBGRAImageReader(AFormat: TBGRAImageFormat): TFPCustomImageReader;
555 {** Create an image writer for the given format. ''AHasTransparentPixels''
556 specifies if alpha channel must be supported }
CreateBGRAImageWriternull557 function CreateBGRAImageWriter(AFormat: TBGRAImageFormat; AHasTransparentPixels: boolean): TFPCustomImageWriter;
558
559 {$DEFINE INCLUDE_INTERFACE}
560 {$I bgracustombitmap.inc}
561
562 operator =(const AGuid1, AGuid2: TGuid): boolean;
563
564 type
565 { TBGRAResourceManager }
566
567 TBGRAResourceManager = class
568 protected
GetWinResourceTypenull569 function GetWinResourceType(AExtension: string): pchar;
570 public
GetResourceStreamnull571 function GetResourceStream(AFilename: string): TStream; virtual;
IsWinResourcenull572 function IsWinResource(AFilename: string): boolean; virtual;
573 end;
574
575 var
576 BGRAResource : TBGRAResourceManager;
577
578 implementation
579
580 uses Math, SysUtils, BGRAUTF8,
581 FPReadXwd, FPReadXPM,
582 FPWriteJPEG, FPWriteBMP, FPWritePCX,
583 FPWriteTGA, FPWriteXPM, FPReadPNM, FPWritePNM;
584
BGRABitmapVersionStrnull585 function BGRABitmapVersionStr: string;
586 var numbers: TStringList;
587 i,remaining: LongWord;
588 begin
589 numbers := TStringList.Create;
590 remaining := BGRABitmapVersion;
591 for i := 1 to 4 do
592 begin
593 numbers.Insert(0, IntToStr(remaining mod 100));
594 remaining := remaining div 100;
595 end;
596 while (numbers.Count > 1) and (numbers[numbers.Count-1]='0') do
597 numbers.Delete(numbers.Count-1);
598 numbers.Delimiter:= '.';
599 result := numbers.DelimitedText;
600 numbers.Free;
601 end;
602
603 {$DEFINE INCLUDE_IMPLEMENTATION}
604 {$I geometrytypes.inc}
605
606 {$DEFINE INCLUDE_IMPLEMENTATION}
607 {$I unibitmap.inc}
608
609 {$DEFINE INCLUDE_IMPLEMENTATION}
610 {$I unibitmapgeneric.inc}
611
612 {$DEFINE INCLUDE_IMPLEMENTATION}
613 {$I csscolorconst.inc}
614
615 {$DEFINE INCLUDE_IMPLEMENTATION}
616 {$I bgracustombitmap.inc}
617
618 {$DEFINE INCLUDE_IMPLEMENTATION}
619 {$I bgrascanner.inc}
620
621 {$DEFINE INCLUDE_IMPLEMENTATION}
622 {$I bgrapixel.inc}
623
AlignmentToBidiTextAlignmentnull624 function AlignmentToBidiTextAlignment(AAlign: TAlignment; ARightToLeft: boolean): TBidiTextAlignment;
625 begin
626 case AAlign of
627 taCenter: result := btaCenter;
628 taRightJustify: if ARightToLeft then result := btaNatural else result := btaOpposite;
629 else {taLeftJustify}
630 if ARightToLeft then result := btaOpposite else result := btaNatural;
631 end;
632 end;
633
AlignmentToBidiTextAlignmentnull634 function AlignmentToBidiTextAlignment(AAlign: TAlignment): TBidiTextAlignment;
635 begin
636 case AAlign of
637 taCenter: result := btaCenter;
638 taRightJustify: result := btaRightJustify;
639 else {taLeftJustify}
640 result := btaLeftJustify;
641 end;
642 end;
643
BidiTextAlignmentToAlignmentnull644 function BidiTextAlignmentToAlignment(ABidiAlign: TBidiTextAlignment;
645 ARightToLeft: boolean): TAlignment;
646 begin
647 case ABidiAlign of
648 btaCenter: result := taCenter;
649 btaLeftJustify: result := taLeftJustify;
650 btaRightJustify: result := taRightJustify;
651 btaOpposite: if ARightToLeft then result := taLeftJustify else result := taRightJustify;
652 else {btaNatural}
653 if ARightToLeft then result := taRightJustify else result := taLeftJustify;
654 end;
655 end;
656
CleanTextOutStringnull657 function CleanTextOutString(const s: string): string;
658 var idxIn, idxOut: integer;
659 begin
660 setlength(result, length(s));
661 idxIn := 1;
662 idxOut := 1;
663 while IdxIn <= length(s) do
664 begin
665 if not (s[idxIn] in[#13,#10,#9]) then //those characters are always 1 byte long so it is the same with UTF8
666 begin
667 result[idxOut] := s[idxIn];
668 inc(idxOut);
669 end;
670 inc(idxIn);
671 end;
672 setlength(result, idxOut-1);
673 end;
674
RemoveLineEndingnull675 function RemoveLineEnding(var s: string; indexByte: integer): boolean;
676 begin //we can ignore UTF8 character length because #13 and #10 are always 1 byte long
cannull677 //so this function can be applied to UTF8 strings as well
678 result := false;
679 if length(s) >= indexByte then
680 begin
681 if s[indexByte] in[#13,#10] then
682 begin
683 result := true;
684 if length(s) >= indexByte+1 then
685 begin
686 if (s[indexByte+1] <> s[indexByte]) and (s[indexByte+1] in[#13,#10]) then
687 delete(s,indexByte,2)
688 else
689 delete(s,indexByte,1);
690 end
691 else
692 delete(s,indexByte,1);
693 end else
694 if (s[indexByte] = #$C2) and (length(s) >= indexByte+1) and (s[indexByte+1] = #$85) then
695 begin
696 result := true;
697 delete(s,indexByte,2);
698 end else
699 if (s[indexByte] = #$E2) and (length(s) >= indexByte+2) and (s[indexByte+1] = #$80) and
700 (s[indexByte+2] in[#$A8,#$A9]) then
701 begin
702 result := true;
703 delete(s,indexByte,3);
704 end
705 end;
706 end;
707
RemoveLineEndingUTF8null708 function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
709 var indexByte: integer;
710 pIndex: PChar;
711 begin
712 pIndex := UTF8CharStart(@sUTF8[1],length(sUTF8),indexUTF8);
713 if pIndex = nil then
714 begin
715 result := false;
716 exit;
717 end;
718 indexByte := pIndex - @sUTF8[1];
719 result := RemoveLineEnding(sUTF8, indexByte);
720 end;
721
722 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
723 const spacingChars = [' '];
724 wordBreakChars = [' ',#9,'-','?','!'];
725 var p, charLen: integer;
726 u: LongWord;
727 begin
728 if (AAfter <> '') and (ABefore <> '') and not (AAfter[1] in spacingChars) and not (ABefore[length(ABefore)] in wordBreakChars) then
729 begin
730 p := length(ABefore);
731 while (p > 1) and not (ABefore[p-1] in wordBreakChars) do dec(p);
732 while (p < length(ABefore)+1) and (ABefore[p] in [#$80..#$BF]) do inc(p); //do not split UTF8 char
733 //keep non-spacing mark together
734 while p <= length(ABefore) do
735 begin
736 charLen := UTF8CharacterLength(@ABefore[p]);
737 if p+charLen > length(ABefore)+1 then charLen := length(ABefore)+1-p;
738 u := UTF8CodepointToUnicode(@ABefore[p],charLen);
739 if (GetUnicodeBidiClassEx(u) in[ubcNonSpacingMark, ubcCombiningLeftToRight]) then
740 inc(p,charLen)
741 else
742 break;
743 end;
744
745 if p = 1 then
746 begin
747 //keep ideographic punctuation together
748 charLen := UTF8CharacterLength(@AAfter[p]);
749 if charLen > length(AAfter) then charLen := length(AAfter);
750 u := UTF8CodepointToUnicode(@AAfter[p],charLen);
751 case u of
752 UNICODE_IDEOGRAPHIC_COMMA,
753 UNICODE_IDEOGRAPHIC_FULL_STOP,
754 UNICODE_FULLWIDTH_COMMA,
755 UNICODE_HORIZONTAL_ELLIPSIS:
756 begin
757 p := length(ABefore)+1;
758 while p > 1 do
759 begin
760 charLen := 1;
761 dec(p);
762 while (p > 0) and (ABefore[p] in [#$80..#$BF]) do
763 begin
764 dec(p); //do not split UTF8 char
765 inc(charLen);
766 end;
767 if charLen <= 4 then
768 u := UTF8CodepointToUnicode(@ABefore[p],charLen)
769 else
770 u := ord('A');
771 case GetUnicodeBidiClass(u) of
772 ubcNonSpacingMark: ; // include NSM
773 ubcOtherNeutrals, ubcWhiteSpace, ubcCommonSeparator, ubcEuropeanNumberSeparator:
774 begin
775 p := 1;
776 break;
777 end
778 else
779 break;
780 end;
781 end;
782 end;
783 end;
784 end;
785
786 if p > 1 then //can put the word after
787 begin
788 AAfter := copy(ABefore,p,length(ABefore)-p+1)+AAfter;
789 ABefore := copy(ABefore,1,p-1);
790 end else
791 begin //cannot put the word after, so before
792
793 end;
794 end;
795 while (ABefore <> '') and (ABefore[length(ABefore)] in spacingChars) do delete(ABefore,length(ABefore),1);
796 while (AAfter <> '') and (AAfter[1] in spacingChars) do delete(AAfter,1,1);
797 end;
798
799
StrToResampleFilternull800 function StrToResampleFilter(str: string): TResampleFilter;
801 var f: TResampleFilter;
802 begin
803 result := rfLinear;
804 str := LowerCase(str);
805 for f := low(TResampleFilter) to high(TResampleFilter) do
806 if CompareText(str,ResampleFilterStr[f])=0 then
807 begin
808 result := f;
809 exit;
810 end;
811 end;
812
GetFineClearTypeAutonull813 function GetFineClearTypeAuto: TBGRAFontQuality;
814 begin
815 result := fqFineClearTypeRGB;
816 end;
817
818 { TBGRACustomFontRenderer }
819
GetFontEmHeightnull820 function TBGRACustomFontRenderer.GetFontEmHeight: integer;
821 begin
822 result := round(FFontEmHeightF);
823 end;
824
825 procedure TBGRACustomFontRenderer.SetFontEmHeight(AValue: integer);
826 begin
827 FFontEmHeightF:= AValue;
828 end;
829
GetFontPixelMetricFnull830 function TBGRACustomFontRenderer.GetFontPixelMetricF: TFontPixelMetricF;
831 begin
832 with GetFontPixelMetric do
833 begin
834 result.Defined := Defined;
835 result.Baseline := Baseline;
836 result.xLine := xLine;
837 result.CapLine := CapLine;
838 result.DescentLine := DescentLine;
839 result.Lineheight := LineHeight;
840 end;
841 end;
842
TextSizeFnull843 function TBGRACustomFontRenderer.TextSizeF(sUTF8: string): TPointF;
844 begin
845 with TextSize(sUTF8) do
846 result := PointF(cx,cy);
847 end;
848
TextSizeFnull849 function TBGRACustomFontRenderer.TextSizeF(sUTF8: string; AMaxWidthF: single;
850 ARightToLeft: boolean): TPointF;
851 begin
852 with TextSize(sUTF8, round(AMaxWidthF), ARightToLeft) do
853 result := PointF(cx,cy);
854 end;
855
TBGRACustomFontRenderer.TextFitInfoFnull856 function TBGRACustomFontRenderer.TextFitInfoF(sUTF8: string; AMaxWidthF: single): integer;
857 begin
858 result := TextFitInfo(sUTF8, round(AMaxWidthF));
859 end;
860
TextSizeAnglenull861 function TBGRACustomFontRenderer.TextSizeAngle(sUTF8: string;
862 orientationTenthDegCCW: integer): TSize;
863 begin
864 result := TextSize(sUTF8); //ignore orientation by default
865 end;
866
TBGRACustomFontRenderer.TextSizeAngleFnull867 function TBGRACustomFontRenderer.TextSizeAngleF(sUTF8: string;
868 orientationTenthDegCCW: integer): TPointF;
869 begin
870 result := TextSizeF(sUTF8); //ignore orientation by default
871 end;
872
873 procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
874 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
875 ARightToLeft: boolean);
876 begin
877 //if RightToLeft is not handled
878 TextOut(ADest,x,y,sUTF8,c,align);
879 end;
880
881 procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
882 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
883 ARightToLeft: boolean);
884 begin
885 //if RightToLeft is not handled
886 TextOut(ADest,x,y,sUTF8,texture,align);
887 end;
888
889 procedure TBGRACustomFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
890 y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel;
891 align: TAlignment; ARightToLeft: boolean);
892 begin
893 //if RightToLeft is not handled
894 TextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,c,align);
895 end;
896
897 procedure TBGRACustomFontRenderer.TextOutAngle(ADest: TBGRACustomBitmap; x,
898 y: single; orientationTenthDegCCW: integer; sUTF8: string;
899 texture: IBGRAScanner; align: TAlignment; ARightToLeft: boolean);
900 begin
901 //if RightToLeft is not handled
902 TextOutAngle(ADest,x,y,orientationTenthDegCCW,sUTF8,texture,align);
903 end;
904
905 procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment);
906 begin {optional implementation} end;
907
908 procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x,
909 y: single; s: string; align: TAlignment; ARightToLeft: boolean);
910 begin
911 //if RightToLeft is not handled
912 CopyTextPathTo(ADest, x,y, s, align);
913 end;
914
TBGRACustomFontRenderer.HandlesTextPathnull915 function TBGRACustomFontRenderer.HandlesTextPath: boolean;
916 begin
917 result := false;
918 end;
919
920
CheckPutImageBoundsnull921 function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb,
922 maxyb, ignoreleft: integer; const cliprect: TRect): boolean;
923 var x2,y2: integer;
924 begin
925 if (x >= cliprect.Right) or (y >= cliprect.Bottom) or (x <= cliprect.Left-tx) or
926 (y <= cliprect.Top-ty) or (ty <= 0) or (tx <= 0) then
927 begin
928 result := false;
929 exit;
930 end;
931
932 x2 := x + tx - 1;
933 y2 := y + ty - 1;
934
935 if y < cliprect.Top then
936 minyb := cliprect.Top
937 else
938 minyb := y;
939 if y2 >= cliprect.Bottom then
940 maxyb := cliprect.Bottom - 1
941 else
942 maxyb := y2;
943
944 if x < cliprect.Left then
945 begin
946 ignoreleft := cliprect.Left-x;
947 minxb := cliprect.Left;
948 end
949 else
950 begin
951 ignoreleft := 0;
952 minxb := x;
953 end;
954 if x2 >= cliprect.Right then
955 maxxb := cliprect.Right - 1
956 else
957 maxxb := x2;
958
959 result := true;
960 end;
961
962 {************************** Cyclic functions *******************}
963
964 // Get the cyclic value in the range [0..cycle-1]
PositiveModnull965 function PositiveMod(value, cycle: Int32or64): Int32or64; inline;
966 begin
967 result := value mod cycle;
968 if result < 0 then //modulo can be negative
969 Inc(result, cycle);
970 end;
971
972 { Table of precalc values. Note : the value is stored for
973 the first half of the cycle, and values are stored 'minus 1'
974 in order to stay in the range 0..65535 }
975 var
976 sinTab65536: packed array of word;
977 byteSqrtTab: packed array of word;
978
Sin65536null979 function Sin65536(value: word): Int32or64;
980 var b: integer;
981 begin
982 //allocate array
983 if sinTab65536 = nil then
984 setlength(sinTab65536,32768);
985
isnull986 if value >= 32768 then //function is upside down after half-period
987 begin
988 b := value xor 32768;
989 if sinTab65536[b] = 0 then //precalc
990 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
991 result := not sinTab65536[b];
992 end else
993 begin
994 b := value;
995 if sinTab65536[b] = 0 then //precalc
996 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
997 {$hints off}
998 result := sinTab65536[b]+1;
999 {$hints on}
1000 end;
1001 end;
1002
Cos65536null1003 function Cos65536(value: word): Int32or64;
1004 begin
1005 {$PUSH}{$R-}
1006 result := Sin65536(value+16384); //cosine is translated
1007 {$POP}
1008 end;
1009
1010 procedure PrecalcSin65536;
1011 var
1012 i: Integer;
1013 begin
1014 for i := 0 to 32767 do Sin65536(i);
1015 end;
1016
1017 procedure PrecalcByteSqrt;
1018 var i: integer;
1019 begin
1020 if byteSqrtTab = nil then
1021 begin
1022 setlength(byteSqrtTab,256);
1023 for i := 0 to 255 do
1024 byteSqrtTab[i] := round(sqrt(i/255)*255);
1025 end;
1026 end;
1027
ByteSqrtnull1028 function ByteSqrt(value: byte): byte; inline;
1029 begin
1030 if byteSqrtTab = nil then PrecalcByteSqrt;
1031 result := ByteSqrtTab[value];
1032 end;
1033
DetectFileFormatnull1034 function DetectFileFormat(AFilenameUTF8: string): TBGRAImageFormat;
1035 var stream: TFileStreamUTF8;
1036 begin
1037 try
1038 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
1039 except
1040 result := ifUnknown;
1041 exit;
1042 end;
1043 try
1044 result := DetectFileFormat(stream, ExtractFileExt(AFilenameUTF8));
1045 finally
1046 stream.Free;
1047 end;
1048 end;
1049
DetectFileFormatnull1050 function DetectFileFormat(AStream: TStream; ASuggestedExtensionUTF8: string
1051 ): TBGRAImageFormat;
1052 var
1053 scores: array[TBGRAImageFormat] of integer;
1054 imageFormat,bestImageFormat: TBGRAImageFormat;
1055 bestScore: integer;
1056
1057 procedure DetectFromStream;
1058 var
1059 {%H-}magic: packed array[0..7] of byte;
1060 {%H-}dwords: packed array[0..9] of LongWord;
1061 magicAsText, moreMagic: string;
1062
1063 streamStartPos, maxFileSize: Int64;
1064 expectedFileSize: LongWord;
1065
1066 procedure DetectTarga;
1067 var
1068 paletteCount: integer;
1069 {%H-}targaPixelFormat: packed record pixelDepth: byte; imgDescriptor: byte; end;
1070 begin
1071 if (magic[1] in[$00,$01]) and (magic[2] in[0,1,2,3,9,10,11]) and (maxFileSize >= 18) then
1072 begin
1073 paletteCount:= magic[5] + magic[6] shl 8;
1074 if ((paletteCount = 0) and (magic[7] = 0)) or
1075 (magic[7] in [16,24,32]) then //check palette bit count
1076 begin
1077 AStream.Position:= streamStartPos+16;
1078 if AStream.Read({%H-}targaPixelFormat,2) = 2 then
1079 begin
1080 if (targaPixelFormat.pixelDepth in [8,16,24,32]) and
1081 (targaPixelFormat.imgDescriptor and 15 < targaPixelFormat.pixelDepth) then
1082 inc(scores[ifTarga],2);
1083 end;
1084 end;
1085 end;
1086 end;
1087
1088 procedure DetectLazPaint;
1089 var
1090 w,h: LongWord;
1091 i: integer;
1092 begin
1093 if (copy(magicAsText,1,8) = 'LazPaint') then //with header
1094 begin
1095 AStream.Position:= streamStartPos+8;
1096 if AStream.Read(dwords,10*4) = 10*4 then
1097 begin
1098 for i := 0 to 6 do dwords[i] := LEtoN(dwords[i]);
1099 if (dwords[0] = 0) and (dwords[1] <= maxFileSize) and (dwords[5] <= maxFileSize) and
1100 (dwords[9] <= maxFileSize) and
1101 (dwords[6] = 0) then inc(scores[ifLazPaint],2);
1102 end;
1103 end else //without header
1104 if ((magic[0] <> 0) or (magic[1] <> 0)) and (magic[2] = 0) and (magic[3] = 0) and
1105 ((magic[4] <> 0) or (magic[5] <> 0)) and (magic[6] = 0) and (magic[7] = 0) then
1106 begin
1107 w := magic[0] + (magic[1] shl 8);
1108 h := magic[4] + (magic[5] shl 8);
1109 AStream.Position:= streamStartPos+8;
1110 if AStream.Read(dwords,4) = 4 then
1111 begin
1112 dwords[0] := LEtoN(dwords[0]);
1113 if (dwords[0] > 0) and (dwords[0] < 65536) then
1114 begin
1115 if 12+dwords[0] < expectedFileSize then
1116 begin
1117 AStream.Position:= streamStartPos+12+dwords[0];
1118 if AStream.Read(dwords,6*4) = 6*4 then
1119 begin
1120 for i := 0 to 5 do dwords[i] := LEtoN(dwords[i]);
1121 if (dwords[0] <= w) and (dwords[1] <= h) and
1122 (dwords[2] <= w) and (dwords[3] <= h) and
1123 (dwords[2] >= dwords[0]) and (dwords[3] >= dwords[1]) and
1124 ((dwords[4] = 0) or (dwords[4] = 1)) and
1125 (dwords[5] > 0) then inc(scores[ifLazPaint],1);
1126 end;
1127 end;
1128 end;
1129 end;
1130 end;
1131 end;
1132
1133 begin
1134 fillchar({%H-}magic, sizeof(magic), 0);
1135 fillchar({%H-}dwords, sizeof(dwords), 0);
1136
1137 streamStartPos:= AStream.Position;
1138 maxFileSize:= AStream.Size - streamStartPos;
1139 if maxFileSize < 8 then exit;
1140 if AStream.Read(magic,sizeof(magic)) <> sizeof(magic) then
1141 begin
1142 fillchar(scores,sizeof(scores),0);
1143 exit;
1144 end;
1145 setlength(magicAsText,sizeof(magic));
1146 move(magic[0],magicAsText[1],sizeof(magic));
1147
1148 if (magic[0] = $ff) and (magic[1] = $d8) then
1149 begin
1150 inc(scores[ifJpeg]);
1151 if (magic[2] = $ff) and (magic[3] >= $c0) then inc(scores[ifJpeg]);
1152 end;
1153
1154 if (magic[0] = $89) and (magic[1] = $50) and (magic[2] = $4e) and
1155 (magic[3] = $47) and (magic[4] = $0d) and (magic[5] = $0a) and
1156 (magic[6] = $1a) and (magic[7] = $0a) then inc(scores[ifPng],2);
1157
1158 if (copy(magicAsText,1,6)='GIF87a') or (copy(magicAsText,1,6)='GIF89a') then inc(scores[ifGif],2);
1159
1160 if (magic[0] = $0a) and (magic[1] in [0,2,3,4,5]) and (magic[2] in[0,1]) and (magic[3] in[1,2,4,8]) then
1161 inc(scores[ifPcx],2);
1162
1163 if (copy(magicAsText,1,2)='BM') then
1164 begin
1165 inc(scores[ifBmp]);
1166 expectedFileSize:= magic[2] + (magic[3] shl 8) + (magic[4] shl 16) + (magic[5] shl 24);
1167 if expectedFileSize = maxFileSize then inc(scores[ifBmp]);
1168 end else
1169 if (copy(magicAsText,1,2)='RL') then
1170 begin
1171 inc(scores[ifBmpMioMap]);
1172 if (magic[2] in[0,1]) and (magic[3] = 0) then inc(scores[ifBmpMioMap]);
1173 end;
1174
1175 if (magic[0] = $00) and (magic[1] = $00) and (magic[3] = $00) and
1176 (magic[4] + (magic[5] shl 8) > 0) then
1177 begin
1178 if magic[2] = $01 then
1179 inc(scores[ifIco])
1180 else if magic[2] = $02 then
1181 inc(scores[ifCur]);
1182 end;
1183
1184 if (copy(magicAsText,1,4) = 'PDN3') then
1185 begin
1186 expectedFileSize:= 6 + (magic[4] + (magic[5] shl 8) + (magic[6] shl 16)) + 2;
1187 if expectedFileSize <= maxFileSize then
1188 begin
1189 inc(scores[ifPaintDotNet]);
1190 if magic[7] = $3c then inc(scores[ifPaintDotNet]);
1191 end;
1192 end;
1193
1194 if (copy(magicAsText,1,4) = 'oXo ') then
1195 begin
1196 inc(scores[ifPhoxo],1);
1197 if (magic[4] = 1) and (magic[5] = 0) and (magic[6] = 0) and (magic[7] = 0) then
1198 inc(scores[ifPhoxo],1);
1199 end;
1200
1201 DetectLazPaint;
1202
1203 if (magic[0] = $50) and (magic[1] = $4b) and (magic[2] = $03) and (magic[3] = $04) then
1204 begin
1205 if DefaultBGRAImageReader[ifOpenRaster] = nil then inc(scores[ifOpenRaster]) else
1206 with CreateBGRAImageReader(ifOpenRaster) do
1207 try
1208 AStream.Position := streamStartPos;
1209 if CheckContents(AStream) then inc(scores[ifOpenRaster],2);
1210 finally
1211 Free;
1212 end;
1213 end;
1214
1215 if (copy(magicAsText,1,4) = '8BPS') and (magic[4] = $00) and (magic[5] = $01) then inc(scores[ifPsd],2);
1216
1217 DetectTarga;
1218
1219 if (copy(magicAsText,1,2)='II') and (magic[2] = 42) and (magic[3]=0) then inc(scores[ifTiff]) else
1220 if (copy(magicAsText,1,2)='MM') and (magic[2] = 0) and (magic[3]=42) then inc(scores[ifTiff]);
1221
1222 if (copy(magicAsText,1,8) = '/* XPM *') or (copy(magicAsText,1,6) = '! XPM2') then inc(scores[ifXPixMap]);
1223
1224 if (copy(magicAsText,1,6) = '<?xml ') or (copy(magicAsText,1,5) = '<svg ') then inc(scores[ifSvg]);
1225
1226 if (length(magicAsText)>3) and (magicAsText[1]='P') and
1227 (magicAsText[2] in['1'..'6']) and (magicAsText[3] = #10) then inc(scores[ifPortableAnyMap]);
1228
1229 if (copy(magicAsText,1,4) = 'RIFF') then
1230 begin
1231 AStream.Position:= streamStartPos+8;
1232 setlength(moreMagic, 4);
1233 if (AStream.Read(moreMagic[1],4) = 4)
1234 and (moreMagic = 'WEBP') then
1235 inc(scores[ifWebP], 2);
1236 end;
1237
1238 AStream.Position := streamStartPos;
1239 end;
1240
1241 var
1242 extFormat: TBGRAImageFormat;
1243
1244 begin
1245 result := ifUnknown;
1246 for imageFormat:= low(TBGRAImageFormat) to high(TBGRAImageFormat) do
1247 scores[imageFormat] := 0;
1248
1249 ASuggestedExtensionUTF8:= UTF8LowerCase(ASuggestedExtensionUTF8);
1250 if (ASuggestedExtensionUTF8 <> '') and (ASuggestedExtensionUTF8[1] <> '.') then //first UTF8 char is in first pos
1251 ASuggestedExtensionUTF8 := '.'+ASuggestedExtensionUTF8;
1252
1253 extFormat:= SuggestImageFormat(ASuggestedExtensionUTF8);
1254 if extFormat <> ifUnknown then inc(scores[extFormat]);
1255
1256 If AStream <> nil then DetectFromStream;
1257
1258 bestScore := 0;
1259 bestImageFormat:= ifUnknown;
1260 for imageFormat:=low(TBGRAImageFormat) to high(TBGRAImageFormat) do
1261 if scores[imageFormat] > bestScore then
1262 begin
1263 bestScore:= scores[imageFormat];
1264 bestImageFormat:= imageFormat;
1265 end;
1266 result := bestImageFormat;
1267 end;
1268
SuggestImageFormatnull1269 function SuggestImageFormat(AFilenameOrExtensionUTF8: string): TBGRAImageFormat;
1270 var ext: string;
1271 posDot: integer;
1272 begin
1273 result := ifUnknown;
1274
1275 ext := ExtractFileName(AFilenameOrExtensionUTF8);
1276 posDot := LastDelimiter('.', ext);
1277 if posDot <> 0 then ext := copy(ext,posDot,length(ext)-posDot+1)
1278 else ext := '.'+ext;
1279 ext := UTF8LowerCase(ext);
1280
1281 if (ext = '.jpg') or (ext = '.jpeg') then result := ifJpeg else
1282 if (ext = '.png') then result := ifPng else
1283 if (ext = '.gif') then result := ifGif else
1284 if (ext = '.pcx') then result := ifPcx else
1285 if (ext = '.bmp') then result := ifBmp else
1286 if (ext = '.ico') then result := ifIco else
1287 if (ext = '.cur') then result := ifCur else
1288 if (ext = '.pdn') then result := ifPaintDotNet else
1289 if (ext = '.lzp') then result := ifLazPaint else
1290 if (ext = '.ora') then result := ifOpenRaster else
1291 if (ext = '.psd') then result := ifPsd else
1292 if (ext = '.tga') then result := ifTarga else
1293 if (ext = '.tif') or (ext = '.tiff') then result := ifTiff else
1294 if (ext = '.xwd') then result := ifXwd else
1295 if (ext = '.xpm') then result := ifXPixMap else
1296 if (ext = '.oxo') then result := ifPhoxo else
1297 if (ext = '.svg') then result := ifSvg else
1298 if (ext = '.pbm') or (ext = '.pgm') or (ext = '.ppm') then result := ifPortableAnyMap else
1299 if (ext = '.webp') then result := ifWebP;
1300 end;
1301
SuggestImageExtensionnull1302 function SuggestImageExtension(AFormat: TBGRAImageFormat): string;
1303 begin
1304 case AFormat of
1305 ifJpeg: result := 'jpg';
1306 ifPng: result := 'png';
1307 ifGif: result := 'gif';
1308 ifBmp: result := 'bmp';
1309 ifBmpMioMap: result := 'bmp';
1310 ifIco: result := 'ico';
1311 ifCur: result := 'ico';
1312 ifPcx: result := 'pcx';
1313 ifPaintDotNet: result := 'pdn';
1314 ifLazPaint: result := 'lzp';
1315 ifOpenRaster: result := 'ora';
1316 ifPhoxo: result := 'oXo';
1317 ifPsd: result := 'psd';
1318 ifTarga: result := 'tga';
1319 ifTiff: result := 'tif';
1320 ifXwd: result := 'xwd';
1321 ifXPixMap: result := 'xpm';
1322 ifSvg: result := 'svg';
1323 ifPortableAnyMap: result := 'ppm';
1324 ifWebP: result := 'webp';
1325 else result := '?';
1326 end;
1327 end;
1328
CreateBGRAImageReadernull1329 function CreateBGRAImageReader(AFormat: TBGRAImageFormat): TFPCustomImageReader;
1330 begin
1331 if DefaultBGRAImageReader[AFormat] = nil then
1332 begin
1333 case AFormat of
1334 ifUnknown: raise exception.Create('The image format is unknown.');
1335 ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to read this image.');
1336 ifPaintDotNet: raise exception.Create('You need to call BGRAPaintNet.RegisterPaintNetFormat to read this image.');
1337 ifSvg: raise exception.Create('You need to call BGRA.RegisterSvgFormat to read this image.');
1338 else
1339 raise exception.Create('The image reader is not registered for this image format.');
1340 end;
1341 end;
1342 result := DefaultBGRAImageReader[AFormat].Create;
1343 end;
1344
CreateBGRAImageWriternull1345 function CreateBGRAImageWriter(AFormat: TBGRAImageFormat; AHasTransparentPixels: boolean): TFPCustomImageWriter;
1346 begin
1347 if DefaultBGRAImageWriter[AFormat] = nil then
1348 begin
1349 case AFormat of
1350 ifUnknown: raise exception.Create('The image format is unknown');
1351 ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to write with this image format.');
1352 ifPhoxo: raise exception.Create('You need to call BGRAPhoxo.RegisterPhoxoFormat to write with this image format.');
1353 else
1354 raise exception.Create('The image writer is not registered for this image format.');
1355 end;
1356 end;
1357
1358 if AFormat = ifPng then
1359 begin
1360 result := DefaultBGRAImageWriter[AFormat].Create;
1361 if result is TBGRACustomWriterPNG then
1362 TBGRACustomWriterPNG(result).UseAlpha := AHasTransparentPixels;
1363 end else
1364 if AFormat = ifBmp then
1365 begin
1366 result := TFPWriterBMP.Create;
1367 if AHasTransparentPixels then
1368 TFPWriterBMP(result).BitsPerPixel := 32 else
1369 TFPWriterBMP(result).BitsPerPixel := 24;
1370 end else
1371 if AFormat = ifXPixMap then
1372 begin
1373 result := TFPWriterXPM.Create;
1374 TFPWriterXPM(result).ColorCharSize := 2;
1375 end else
1376 result := DefaultBGRAImageWriter[AFormat].Create;
1377 end;
1378
1379 operator =(const AGuid1, AGuid2: TGuid): boolean;
1380 begin
1381 result := CompareMem(@AGuid1, @AGuid2, sizeof(TGuid));
1382 end;
1383
1384 type
1385 TResourceType = record
1386 ext: string;
1387 code: pchar;
1388 end;
1389
1390 {$IFNDEF BGRABITMAP_USE_LCL}{$IFDEF MSWINDOWS}
1391 const
1392 RT_BITMAP = MAKEINTRESOURCE(2);
1393 RT_RCDATA = MAKEINTRESOURCE(10);
1394 RT_GROUP_CURSOR = MAKEINTRESOURCE(12);
1395 RT_GROUP_ICON = MAKEINTRESOURCE(14);
1396 RT_HTML = MAKEINTRESOURCE(23);
1397 {$ENDIF}{$ENDIF}
1398
1399 const
1400 ResourceTypes: array[1..7] of TResourceType =
1401 ((ext: 'CUR'; code: RT_GROUP_CURSOR),
1402 (ext: 'BMP'; code: RT_BITMAP),
1403 (ext: 'ICO'; code: RT_GROUP_ICON),
1404 (ext: 'DAT'; code: RT_RCDATA),
1405 (ext: 'DATA'; code: RT_RCDATA),
1406 (ext: 'HTM'; code: RT_HTML),
1407 (ext: 'HTML'; code: RT_HTML));
1408
1409 { TBGRAResourceManager }
1410
GetWinResourceTypenull1411 function TBGRAResourceManager.GetWinResourceType(AExtension: string): pchar;
1412 var
1413 i: Integer;
1414 begin
1415 if (AExtension <> '') and (AExtension[1]='.') then delete(AExtension,1,1);
1416 for i := low(ResourceTypes) to high(ResourceTypes) do
1417 if AExtension = ResourceTypes[i].ext then
1418 exit(ResourceTypes[i].code);
1419
1420 exit(RT_RCDATA);
1421 end;
1422
GetResourceStreamnull1423 function TBGRAResourceManager.GetResourceStream(AFilename: string): TStream;
1424 var
1425 name,ext: RawByteString;
1426 rt: PChar;
1427 begin
1428 ext := UpperCase(ExtractFileExt(AFilename));
1429 name := ChangeFileExt(AFilename,'');
1430 rt := GetWinResourceType(ext);
1431
1432 if (rt = RT_GROUP_CURSOR) or (rt = RT_GROUP_ICON) then
1433 raise exception.Create('Not implemented');
1434
1435 result := TResourceStream.Create(HINSTANCE, name, rt);
1436 end;
1437
IsWinResourcenull1438 function TBGRAResourceManager.IsWinResource(AFilename: string): boolean;
1439 var
1440 name,ext: RawByteString;
1441 rt: PChar;
1442 begin
1443 ext := UpperCase(ExtractFileExt(AFilename));
1444 name := ChangeFileExt(AFilename,'');
1445 rt := GetWinResourceType(ext);
1446 result := FindResource(HINSTANCE, pchar(name), rt)<>0;
1447 end;
1448
1449 {$IFDEF BGRABITMAP_USE_LCL}
1450 type
1451
1452 { TLCLResourceManager }
1453
1454 TLCLResourceManager = class(TBGRAResourceManager)
1455 protected
FindLazarusResourcenull1456 function FindLazarusResource(AFilename: string): TLResource;
1457 public
GetResourceStreamnull1458 function GetResourceStream(AFilename: string): TStream; override;
IsWinResourcenull1459 function IsWinResource(AFilename: string): boolean; override;
1460 end;
1461
FindLazarusResourcenull1462 function TLCLResourceManager.FindLazarusResource(AFilename: string): TLResource;
1463 var
1464 name,ext: RawByteString;
1465 begin
1466 ext := UpperCase(ExtractFileExt(AFilename));
1467 if (ext<>'') and (ext[1]='.') then Delete(ext,1,1);
1468 name := ChangeFileExt(AFilename,'');
1469 if ext<>'' then
1470 result := LazarusResources.Find(name,ext)
1471 else
1472 result := LazarusResources.Find(name);
1473 end;
1474
GetResourceStreamnull1475 function TLCLResourceManager.GetResourceStream(AFilename: string): TStream;
1476 var
1477 res: TLResource;
1478 begin
1479 res := FindLazarusResource(AFilename);
1480 if Assigned(res) then
1481 result := TLazarusResourceStream.CreateFromHandle(res)
1482 else
1483 result := inherited GetResourceStream(AFilename);
1484 end;
1485
IsWinResourcenull1486 function TLCLResourceManager.IsWinResource(AFilename: string): boolean;
1487 begin
1488 if FindLazarusResource(AFilename)<>nil then
1489 result := false
1490 else
1491 Result:=inherited IsWinResource(AFilename);
1492 end;
1493
1494 {$ENDIF}
1495
1496 initialization
1497
1498 {$DEFINE INCLUDE_INIT}
1499 {$I bgrapixel.inc}
1500
1501 {$DEFINE INCLUDE_INIT}
1502 {$I csscolorconst.inc}
1503
1504 fqFineClearType := @GetFineClearTypeAuto;
1505
1506 DefaultBGRAImageWriter[ifJpeg] := TFPWriterJPEG;
1507 DefaultBGRAImageWriter[ifBmp] := TFPWriterBMP;
1508 DefaultBGRAImageWriter[ifPcx] := TFPWriterPCX;
1509 DefaultBGRAImageWriter[ifTarga] := TFPWriterTarga;
1510 DefaultBGRAImageWriter[ifXPixMap] := TFPWriterXPM;
1511 DefaultBGRAImageWriter[ifPortableAnyMap] := TFPWriterPNM;
1512 //writing XWD not implemented
1513
1514 DefaultBGRAImageReader[ifXwd] := TFPReaderXWD;
1515 DefaultBGRAImageReader[ifPortableAnyMap] := TFPReaderPNM;
1516 //the other readers are registered by their unit
1517
1518 {$IFDEF BGRABITMAP_USE_LCL}
1519 BGRAResource := TLCLResourceManager.Create;
1520 {$ELSE}
1521 BGRAResource := TBGRAResourceManager.Create;
1522 {$ENDIF}
1523
1524 finalization
1525
1526 {$DEFINE INCLUDE_FINAL}
1527 {$I csscolorconst.inc}
1528
1529 {$DEFINE INCLUDE_FINAL}
1530 {$I bgrapixel.inc}
1531
1532 BGRAResource.Free;
1533 end.
1534