1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAColorQuantization;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 BGRAClasses, SysUtils, BGRAPalette, BGRABitmapTypes;
10
11 type
12 TBGRAColorBox = class;
13 TBGRAColorTree = class;
14 TBGRAApproxPalette = class;
15 TBiggestLeafMethod = (blMix, blApparentInterval, blWeight);
16
17 { TDimensionMinMax }
18
19 TDimensionMinMax = object
20 Minimum: UInt32;
21 Maximum: UInt32;
Sizenull22 function Size: UInt32;
Containsnull23 function Contains(AValue: UInt32): boolean;
PointLikenull24 function PointLike: boolean;
25 procedure SetAsPoint(AValue: UInt32);
GetCenternull26 function GetCenter: UInt32;
27 procedure GrowToInclude(AValue: UInt32);
28 end;
29
30 TColorDimension = (cdFast,cdRed,cdGreen,cdBlue,cdAlpha,cdRGB,cdRG,cdGB,cdRB,cdRInvG,cdGInvB,cdRInvB,cdRInvGB,cdGInvRB,cdBInvRG,
31 cdSaturation);
32 TColorDimensions = set of TColorDimension;
33
34 { TBGRAColorQuantizer }
35
36 TBGRAColorQuantizer = class(TBGRACustomColorQuantizer)
37 private
38 FColors: ArrayOfWeightedColor;
39 FPalette: TBGRAApproxPalette;
40 FReductionColorCount: Integer;
41 FReductionKeepContrast: boolean;
42 FSeparateAlphaChannel: boolean;
43 procedure Init(ABox: TBGRAColorBox);
44 procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; ARedBounds, AGreenBounds, ABlueBounds, AAlphaBounds: TDimensionMinMax; AUniform: boolean); overload;
45 procedure NormalizeArrayOfColors(AColors: ArrayOfTBGRAPixel; AColorBounds, AAlphaBounds: TDimensionMinMax); overload;
46 protected
GetPalettenull47 function GetPalette: TBGRACustomApproxPalette; override;
GetSourceColornull48 function GetSourceColor(AIndex: integer): TBGRAPixel; override;
GetSourceColorCountnull49 function GetSourceColorCount: Integer; override;
GetReductionColorCountnull50 function GetReductionColorCount: integer; override;
51 procedure SetReductionColorCount(AValue: Integer); override;
52 public
53 constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean); override;
54 constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); override;
55 constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); override;
56 constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption; AReductionColorCount: integer); override;
57 destructor Destroy; override;
58 procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); override;
GetDitheredBitmapnull59 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; override;
GetDitheredBitmapIndexedDatanull60 function GetDitheredBitmapIndexedData(ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm;
61 ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload; override;
62 procedure SaveBitmapToStream(AAlgorithm: TDitheringAlgorithm;
63 ABitmap: TBGRACustomBitmap; AStream: TStream; AFormat: TBGRAImageFormat); override;
64 end;
65
66 { TBGRAApproxPalette }
67
68 TBGRAApproxPalette = class(TBGRACustomApproxPalette)
69 private
70 FTree: TBGRAColorTree;
71 FColors: ArrayOfWeightedColor;
72 protected
GetCountnull73 function GetCount: integer; override;
GetColorByIndexnull74 function GetColorByIndex(AIndex: integer): TBGRAPixel; override;
GetWeightByIndexnull75 function GetWeightByIndex(AIndex: Integer): UInt32; override;
76 procedure Init(const AColors: ArrayOfTBGRAPixel);
77 public
78 constructor Create(const AColors: ArrayOfTBGRAPixel); overload;
79 constructor Create(const AColors: ArrayOfWeightedColor); overload;
80 constructor Create(AOwnedSplitTree: TBGRAColorTree); overload;
81 destructor Destroy; override;
ContainsColornull82 function ContainsColor(AValue: TBGRAPixel): boolean; override;
IndexOfColornull83 function IndexOfColor(AValue: TBGRAPixel): integer; override;
FindNearestColornull84 function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; override;
FindNearestColorIndexnull85 function FindNearestColorIndex(AValue: TBGRAPixel): integer; override;
GetAsArrayOfColornull86 function GetAsArrayOfColor: ArrayOfTBGRAPixel; override;
GetAsArrayOfWeightedColornull87 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; override;
88 end;
89
90 { TBGRAApproxPaletteViaLargerPalette }
91
92 TBGRAApproxPaletteViaLargerPalette = class(TBGRAApproxPalette)
93 private
94 FLarger: TBGRACustomApproxPalette;
95 FLargerColors: array of record
96 approxColor: TBGRAPixel;
97 approxColorIndex: integer;
98 end;
99 FLargerOwned: boolean;
100 FTransparentColorIndex: integer;
101 protected
FindNearestLargerColorIndexnull102 function FindNearestLargerColorIndex(AValue: TBGRAPixel): integer; virtual;
SlowFindNearestColorIndexnull103 function SlowFindNearestColorIndex(AValue: TBGRAPixel): integer;
104 public
105 constructor Create(const AColors: ArrayOfTBGRAPixel; ALarger: TBGRACustomApproxPalette; ALargerOwned: boolean);
106 destructor Destroy; override;
FindNearestColornull107 function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; override;
FindNearestColorIndexnull108 function FindNearestColorIndex(AValue: TBGRAPixel): integer; override;
GetAsArrayOfWeightedColornull109 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; override;
110 end;
111
112 TIsChannelStrictlyGreaterFunc = TBGRAPixelComparer;
113 TIsChannelGreaterThanOrEqualToValueFunc = function (p : PBGRAPixel; v: UInt32): boolean;
114
115 TColorBoxBounds = array[TColorDimension] of TDimensionMinMax;
116
117 { TBGRAColorBox }
118
119 TBGRAColorBox = class
120 private
121 FBounds: TColorBoxBounds;
122 FTotalWeight: UInt32;
123 FColors: ArrayOfWeightedColor;
124 FDimensions: TColorDimensions;
125 FPureTransparentColorCount: integer;
GetApparentIntervalnull126 function GetApparentInterval(ADimension: TColorDimension): UInt32;
GetAverageColornull127 function GetAverageColor: TBGRAPixel;
GetAverageColorOrMainColornull128 function GetAverageColorOrMainColor: TBGRAPixel;
GetBoundsnull129 function GetBounds(ADimension: TColorDimension): TDimensionMinMax;
GetColorCountnull130 function GetColorCount(ACountPureTransparent: boolean): integer;
GetHasPureTransparentColornull131 function GetHasPureTransparentColor: boolean;
GetInferiorColornull132 function GetInferiorColor: TBGRAPixel;
GetLargestApparentDimensionnull133 function GetLargestApparentDimension: TColorDimension;
GetLargestApparentIntervalnull134 function GetLargestApparentInterval: UInt32;
GetPointLikenull135 function GetPointLike: boolean;
GetSuperiorColornull136 function GetSuperiorColor: TBGRAPixel;
137 procedure Init(AColors: ArrayOfWeightedColor; AOwner: boolean);
138 procedure SortBy(ADimension: TColorDimension);
GetMedianIndexnull139 function GetMedianIndex(ADimension : TColorDimension; AMinValue, AMaxValue: UInt32): integer;
140 public
141 constructor Create(ADimensions: TColorDimensions; AColors: ArrayOfWeightedColor; AOwner: boolean); overload;
142 constructor Create(ADimensions: TColorDimensions; const AColors: ArrayOfTBGRAPixel; AAlpha: TAlphaChannelPaletteOption = acFullChannelInPalette); overload;
143 constructor Create(ADimensions: TColorDimensions; ABounds: TColorBoxBounds); overload;
144 constructor Create(ADimensions: TColorDimensions; APalette: TBGRACustomPalette); overload;
145 constructor Create(ADimensions: TColorDimensions; ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); overload;
146 constructor Create(ADimensions: TColorDimensions; AColors: PBGRAPixel; ANbPixels: integer; AAlpha: TAlphaChannelPaletteOption); overload;
BoundsContainnull147 function BoundsContain(AColor: TBGRAPixel): boolean;
MedianCutnull148 function MedianCut(ADimension: TColorDimension; out SuperiorMiddle: UInt32): TBGRAColorBox;
Duplicatenull149 function Duplicate : TBGRAColorBox;
150 property Bounds[ADimension: TColorDimension]: TDimensionMinMax read GetBounds;
151 property ApparentInterval[AChannel: TColorDimension]: UInt32 read GetApparentInterval;
152 property LargestApparentDimension: TColorDimension read GetLargestApparentDimension;
153 property LargestApparentInterval: UInt32 read GetLargestApparentInterval;
154 property PointLike: boolean read GetPointLike;
155 property AverageColor: TBGRAPixel read GetAverageColor;
156 property SuperiorColor: TBGRAPixel read GetSuperiorColor;
157 property InferiorColor: TBGRAPixel read GetInferiorColor;
158 property AverageColorOrMainColor: TBGRAPixel read GetAverageColorOrMainColor;
GetAsArrayOfColorsnull159 function GetAsArrayOfColors(AIncludePureTransparent: boolean): ArrayOfTBGRAPixel;
160 property TotalWeight: UInt32 read FTotalWeight;
161 property ColorCount[ACountPureTransparent: boolean]: integer read GetColorCount;
162 property HasPureTransparentColor: boolean read GetHasPureTransparentColor;
163 property PureTransparentColorCount: integer read FPureTransparentColorCount;
164 end;
165
166 TBGRALeafColorMode = (lcAverage, lcCenter, lcExtremum, lcMix);
167
168 { TBGRAColorTree }
169
170 TBGRAColorTree = class
171 private
172 FLeaf: TBGRAColorBox;
173 FIsLeaf: boolean;
174 FLargestApparentInterval: integer;
175 FWeight: UInt32;
176
177 FLeafColor: TBGRAPixel;
178 FLeafColorIndex: integer;
179 FLeafColorComputed: boolean;
180 FMinBorder, FMaxBorder: array[TColorDimension] of boolean;
181 FCenterColor: TBGRAPixel;
182 FAverageColor: TBGRAPixel;
183
184 FPureTransparentColorCount: integer;
185 FPureTransparentColorIndex: integer;
186 FDimension: TColorDimension;
187 FPixelValueComparer: TIsChannelGreaterThanOrEqualToValueFunc;
188 FSuperiorMiddle: UInt32;
189 FInferiorBranch, FSuperiorBranch: TBGRAColorTree;
GetApproximatedColorCountnull190 function GetApproximatedColorCount: integer;
GetHasPureTransparentColornull191 function GetHasPureTransparentColor: boolean;
GetLeafCountnull192 function GetLeafCount: integer;
193 procedure Init(ALeaf: TBGRAColorBox; AOwned: boolean);
194 procedure InternalComputeLeavesColor(ALeafColor: TBGRALeafColorMode; var AStartIndex: integer);
195 procedure CheckColorComputed;
196 public
197 constructor Create(ABox: TBGRAColorBox; AOwned: boolean); overload;
198 constructor Create(ADimensions: TColorDimensions; APalette: TBGRACustomPalette); overload;
199 constructor Create(ADimensions: TColorDimensions; ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); overload;
200 destructor Destroy; override;
201 procedure FreeLeaves;
FindBiggestLeafnull202 function FindBiggestLeaf(AMethod: TBiggestLeafMethod): TBGRAColorTree;
203 property LargestApparentInterval: integer read FLargestApparentInterval;
204 property Weight: UInt32 read FWeight;
205 property IsLeaf: boolean read FIsLeaf;
TrySplitLeafnull206 function TrySplitLeaf: boolean;
207 procedure ComputeLeavesColor(ALeafColor: TBGRALeafColorMode);
ApproximateColornull208 function ApproximateColor(AColor: TBGRAPixel): TBGRAPixel;
ApproximateColorIndexnull209 function ApproximateColorIndex(AColor: TBGRAPixel): integer;
GetAsArrayOfApproximatedColorsnull210 function GetAsArrayOfApproximatedColors: ArrayOfTBGRAPixel;
GetAsArrayOfWeightedColorsnull211 function GetAsArrayOfWeightedColors: ArrayOfWeightedColor;
212 procedure SplitIntoPalette(ACount: integer; AMethod: TBiggestLeafMethod;
213 ALeafColor: TBGRALeafColorMode);
SplitIntoPaletteWithSubPalettenull214 function SplitIntoPaletteWithSubPalette(ACount: integer; AMethod: TBiggestLeafMethod;
215 ALeafColor: TBGRALeafColorMode; ASubPaletteCount: integer): ArrayOfTBGRAPixel;
216 property LeafCount: integer read GetLeafCount;
217 property ApproximatedColorCount: integer read GetApproximatedColorCount;
218 property HasPureTransparentColor: boolean read GetHasPureTransparentColor;
219 property PureTransparentColorCount: integer read FPureTransparentColorCount;
220 end;
221
GetPixelStrictComparernull222 function GetPixelStrictComparer(ADimension: TColorDimension): TIsChannelStrictlyGreaterFunc;
GetPixelValueComparernull223 function GetPixelValueComparer(ADimension: TColorDimension): TIsChannelGreaterThanOrEqualToValueFunc;
BGRAColorCountnull224 function BGRAColorCount(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption): integer;
225
226 const AllColorDimensions = [cdRed,cdGreen,cdBlue,cdAlpha,cdRGB,cdRG,cdGB,cdRB,cdRInvG,cdGInvB,cdRInvB,cdRInvGB,cdGInvRB,cdBInvRG,
227 cdSaturation];
228
229 implementation
230
231 uses BGRADithering, FPimage, FPWriteBMP, BGRAWritePNG, math;
232
233 const MedianMinPercentage = 0.2;
234
235 const RedShift = 1;
236 GreenShift = 2;
237 AlphaShift = 1;
238 SaturationShift = 2;
239
GetDimensionValuenull240 function GetDimensionValue(APixel: TBGRAPixel; ADimension: TColorDimension): UInt32;
241 var v: UInt32;
242 begin
243 case ADimension of
244 cdFast: result := LongWord(APixel);
245 cdRed: result := GammaExpansionTab[APixel.red] shl RedShift;
246 cdGreen: result := GammaExpansionTab[APixel.green] shl GreenShift;
247 cdBlue: result := GammaExpansionTab[APixel.blue];
248 cdAlpha: result := (APixel.alpha + (APixel.alpha shl 8)) shl AlphaShift;
249 cdRGB: result := GammaExpansionTab[APixel.blue] + (GammaExpansionTab[APixel.red] shl RedShift) + (GammaExpansionTab[APixel.green] shl GreenShift);
250 cdRG: result := (GammaExpansionTab[APixel.red] shl RedShift) + (GammaExpansionTab[APixel.green] shl GreenShift);
251 cdGB: result := GammaExpansionTab[APixel.blue] + (GammaExpansionTab[APixel.green] shl GreenShift);
252 cdRB: result := (GammaExpansionTab[APixel.red] shl RedShift) + GammaExpansionTab[APixel.blue];
253 cdRInvG: result := (GammaExpansionTab[APixel.red] shl RedShift) + ((not GammaExpansionTab[APixel.green]) shl GreenShift);
254 cdGInvB: result := (GammaExpansionTab[APixel.green] shl GreenShift) + (not GammaExpansionTab[APixel.blue]);
255 cdRInvB: result := (GammaExpansionTab[APixel.red] shl RedShift) + (not GammaExpansionTab[APixel.blue]);
256 cdRInvGB: result := (GammaExpansionTab[APixel.red] shl RedShift) + ((not GammaExpansionTab[APixel.green]) shl GreenShift) + (not GammaExpansionTab[APixel.blue]);
257 cdGInvRB: result := (GammaExpansionTab[APixel.green] shl GreenShift) + ((not GammaExpansionTab[APixel.red]) shl RedShift) + (not GammaExpansionTab[APixel.blue]);
258 cdBInvRG: result := (GammaExpansionTab[APixel.blue]) + ((not GammaExpansionTab[APixel.red]) shl RedShift) + ((not GammaExpansionTab[APixel.green]) shl GreenShift);
259 cdSaturation: with GammaExpansion(APixel) do
260 begin
261 v := red;
262 if green>v then v := green;
263 if blue>v then v := blue;
264 result := v;
265 v := red;
266 if green<v then v := green;
267 if blue<v then v := blue;
268 dec(result, v);
269 result := result shl SaturationShift;
270 end
271 else raise exception.Create('Unknown dimension');
272 end;
273 end;
274
IsRGBGreaternull275 function IsRGBGreater(p1, p2: PBGRAPixel): boolean;
276 begin
277 result := ((GammaExpansionTab[p1^.red] shl RedShift)+(GammaExpansionTab[p1^.green] shl GreenShift)+GammaExpansionTab[p1^.blue]) >
278 ((GammaExpansionTab[p2^.red] shl RedShift)+(GammaExpansionTab[p2^.green] shl GreenShift)+GammaExpansionTab[p2^.blue]);
279 end;
280
IsRGBGreaterThanValuenull281 function IsRGBGreaterThanValue(p: PBGRAPixel;
282 v: UInt32): boolean;
283 begin
284 with p^ do
285 result := ((GammaExpansionTab[red] shl RedShift)+(GammaExpansionTab[green] shl GreenShift)+GammaExpansionTab[blue]) >= v;
286 end;
287
IsRGGreaternull288 function IsRGGreater(p1, p2: PBGRAPixel): boolean;
289 begin
290 result := ((GammaExpansionTab[p1^.red] shl RedShift)+(GammaExpansionTab[p1^.green] shl GreenShift)) >
291 ((GammaExpansionTab[p2^.red] shl RedShift)+(GammaExpansionTab[p2^.green] shl GreenShift));
292 end;
293
IsRGGreaterThanValuenull294 function IsRGGreaterThanValue(p: PBGRAPixel;
295 v: UInt32): boolean;
296 begin
297 with p^ do
298 result := ((GammaExpansionTab[red] shl RedShift)+(GammaExpansionTab[green] shl GreenShift)) >= v;
299 end;
300
IsGBGreaternull301 function IsGBGreater(p1, p2: PBGRAPixel): boolean;
302 begin
303 result := ((GammaExpansionTab[p1^.green] shl GreenShift)+GammaExpansionTab[p1^.blue]) >
304 ((GammaExpansionTab[p2^.green] shl GreenShift)+GammaExpansionTab[p2^.blue]);
305 end;
306
IsGBGreaterThanValuenull307 function IsGBGreaterThanValue(p: PBGRAPixel;
308 v: UInt32): boolean;
309 begin
310 with p^ do
311 result := ((GammaExpansionTab[green] shl GreenShift)+GammaExpansionTab[blue]) >= v;
312 end;
313
IsRBGreaternull314 function IsRBGreater(p1, p2: PBGRAPixel): boolean;
315 begin
316 result := ((GammaExpansionTab[p1^.red] shl RedShift)+GammaExpansionTab[p1^.blue]) >
317 ((GammaExpansionTab[p2^.red] shl RedShift)+GammaExpansionTab[p2^.blue]);
318 end;
319
IsRBGreaterThanValuenull320 function IsRBGreaterThanValue(p: PBGRAPixel;
321 v: UInt32): boolean;
322 begin
323 with p^ do
324 result := ((GammaExpansionTab[red] shl RedShift)+GammaExpansionTab[blue]) >= v;
325 end;
326
IsRInvGGreaternull327 function IsRInvGGreater(p1, p2: PBGRAPixel
328 ): boolean;
329 begin
330 result := (GammaExpansionTab[p1^.red]+ ((not GammaExpansionTab[p1^.green]) shl GreenShift)) >
331 (GammaExpansionTab[p2^.red]+((not GammaExpansionTab[p2^.green]) shl GreenShift));
332 end;
333
IsRInvGGreaterThanValuenull334 function IsRInvGGreaterThanValue(p: PBGRAPixel;
335 v: UInt32): boolean;
336 begin
337 with p^ do
338 result := (GammaExpansionTab[red]+((not GammaExpansionTab[green]) shl GreenShift)) >= v;
339 end;
340
IsGInvBGreaternull341 function IsGInvBGreater(p1, p2: PBGRAPixel
342 ): boolean;
343 begin
344 result := (GammaExpansionTab[p1^.green] shl GreenShift + not GammaExpansionTab[p1^.blue]) >
345 (GammaExpansionTab[p2^.green] shl GreenShift + not GammaExpansionTab[p2^.blue]);
346 end;
347
IsGInvBGreaterThanValuenull348 function IsGInvBGreaterThanValue(p: PBGRAPixel;
349 v: UInt32): boolean;
350 begin
351 with p^ do
352 result := (GammaExpansionTab[green] shl GreenShift + not GammaExpansionTab[blue]) >= v;
353 end;
354
IsRInvBGreaternull355 function IsRInvBGreater(p1, p2: PBGRAPixel
356 ): boolean;
357 begin
358 result := (GammaExpansionTab[p1^.red] shl RedShift + not GammaExpansionTab[p1^.blue]) >
359 (GammaExpansionTab[p2^.red] shl RedShift + not GammaExpansionTab[p2^.blue]);
360 end;
361
IsRInvBGreaterThanValuenull362 function IsRInvBGreaterThanValue(p: PBGRAPixel;
363 v: UInt32): boolean;
364 begin
365 with p^ do
366 result := (GammaExpansionTab[red] shl RedShift + not GammaExpansionTab[blue]) >= v;
367 end;
368
IsRInvGBGreaternull369 function IsRInvGBGreater(p1, p2: PBGRAPixel
370 ): boolean;
371 begin
372 result := (GammaExpansionTab[p1^.red] shl RedShift + ((not GammaExpansionTab[p1^.green]) shl GreenShift) + not GammaExpansionTab[p1^.blue]) >
373 (GammaExpansionTab[p2^.red] shl RedShift + ((not GammaExpansionTab[p2^.green]) shl GreenShift) + not GammaExpansionTab[p2^.blue]);
374 end;
375
IsRInvGBGreaterThanValuenull376 function IsRInvGBGreaterThanValue(p: PBGRAPixel;
377 v: UInt32): boolean;
378 begin
379 with p^ do
380 result := (GammaExpansionTab[red] shl RedShift + ((not GammaExpansionTab[green]) shl GreenShift) + not GammaExpansionTab[blue]) >= v;
381 end;
382
IsGInvRBGreaternull383 function IsGInvRBGreater(p1, p2: PBGRAPixel
384 ): boolean;
385 begin
386 result := (GammaExpansionTab[p1^.green] shl GreenShift + ((not GammaExpansionTab[p1^.red]) shl RedShift) + not GammaExpansionTab[p1^.blue]) >
387 (GammaExpansionTab[p2^.green] shl GreenShift + ((not GammaExpansionTab[p2^.red]) shl RedShift) + not GammaExpansionTab[p2^.blue]);
388 end;
389
IsGInvRBGreaterThanValuenull390 function IsGInvRBGreaterThanValue(p: PBGRAPixel;
391 v: UInt32): boolean;
392 begin
393 with p^ do
394 result := (GammaExpansionTab[green] shl GreenShift + ((not GammaExpansionTab[red]) shl RedShift) + not GammaExpansionTab[blue]) >= v;
395 end;
396
IsBInvRGGreaternull397 function IsBInvRGGreater(p1, p2: PBGRAPixel
398 ): boolean;
399 begin
400 result := (GammaExpansionTab[p1^.blue] + ((not GammaExpansionTab[p1^.red]) shl RedShift) + ((not GammaExpansionTab[p1^.green]) shl GreenShift)) >
401 (GammaExpansionTab[p2^.blue] + ((not GammaExpansionTab[p2^.red]) shl RedShift) + ((not GammaExpansionTab[p2^.green]) shl GreenShift));
402 end;
403
IsBInvRGGreaterThanValuenull404 function IsBInvRGGreaterThanValue(p: PBGRAPixel;
405 v: UInt32): boolean;
406 begin
407 with p^ do
408 result := (GammaExpansionTab[blue] + ((not GammaExpansionTab[red]) shl RedShift) + ((not GammaExpansionTab[green]) shl GreenShift)) >= v;
409 end;
410
IsSaturationGreaternull411 function IsSaturationGreater(p1, p2: PBGRAPixel): boolean;
412 begin
413 result := GetDimensionValue(p1^,cdSaturation) > GetDimensionValue(p2^,cdSaturation);
414 end;
415
IsSaturationGreaterThanValuenull416 function IsSaturationGreaterThanValue(p: PBGRAPixel;
417 v: UInt32): boolean;
418 begin
419 result := GetDimensionValue(p^,cdSaturation) >= v;
420 end;
421
IsRedGreaternull422 function IsRedGreater(p1, p2: PBGRAPixel): boolean;
423 begin
424 result := p1^.red > p2^.red;
425 end;
426
IsRedGreaterThanValuenull427 function IsRedGreaterThanValue(p: PBGRAPixel;
428 v: UInt32): boolean;
429 begin
430 result := GammaExpansionTab[p^.red] shl RedShift >= v;
431 end;
432
IsGreenGreaternull433 function IsGreenGreater(p1, p2: PBGRAPixel
434 ): boolean;
435 begin
436 result := p1^.green > p2^.green;
437 end;
438
IsGreenGreaterThanValuenull439 function IsGreenGreaterThanValue(p: PBGRAPixel;
440 v: UInt32): boolean;
441 begin
442 result := GammaExpansionTab[p^.green] shl GreenShift >= v;
443 end;
444
IsBlueGreaternull445 function IsBlueGreater(p1, p2: PBGRAPixel
446 ): boolean;
447 begin
448 result := p1^.blue > p2^.blue;
449 end;
450
IsBlueGreaterThanValuenull451 function IsBlueGreaterThanValue(p: PBGRAPixel;
452 v: UInt32): boolean;
453 begin
454 result := GammaExpansionTab[p^.blue] >= v;
455 end;
456
IsAlphaGreaternull457 function IsAlphaGreater(p1, p2: PBGRAPixel
458 ): boolean;
459 begin
460 result := p1^.alpha > p2^.alpha;
461 end;
462
IsAlphaGreaterThanValuenull463 function IsAlphaGreaterThanValue(p: PBGRAPixel;
464 v: UInt32): boolean;
465 begin
466 result := (p^.alpha + p^.alpha shl 8) shl AlphaShift >= v;
467 end;
468
IsDWordGreaternull469 function IsDWordGreater(p1, p2: PBGRAPixel
470 ): boolean;
471 begin
472 result := LongWord(p1^) > LongWord(p2^);
473 end;
474
IsDWordGreaterThanValuenull475 function IsDWordGreaterThanValue(p: PBGRAPixel;
476 v: UInt32): boolean;
477 begin
478 result := LongWord(p^) >= v;
479 end;
480
GetPixelStrictComparernull481 function GetPixelStrictComparer(ADimension: TColorDimension
482 ): TIsChannelStrictlyGreaterFunc;
483 begin
484 case ADimension of
485 cdFast: result := @IsDWordGreater;
486 cdRed: result := @IsRedGreater;
487 cdGreen: result := @IsGreenGreater;
488 cdBlue: result := @IsBlueGreater;
489 cdAlpha: result := @IsAlphaGreater;
490 cdRGB: result := @IsRGBGreater;
491 cdRG: result := @IsRGGreater;
492 cdGB: result := @IsGBGreater;
493 cdRB: result := @IsRBGreater;
494 cdRInvG: result := @IsRInvGGreater;
495 cdGInvB: result := @IsGInvBGreater;
496 cdRInvB: result := @IsRInvBGreater;
497 cdRInvGB: result := @IsRInvGBGreater;
498 cdGInvRB: result := @IsGInvRBGreater;
499 cdBInvRG: result := @IsBInvRGGreater;
500 cdSaturation: result := @IsSaturationGreater;
501 else raise Exception.Create('Unknown dimension');
502 end;
503 end;
504
GetPixelValueComparernull505 function GetPixelValueComparer(ADimension: TColorDimension
506 ): TIsChannelGreaterThanOrEqualToValueFunc;
507 begin
508 case ADimension of
509 cdFast: result := @IsDWordGreaterThanValue;
510 cdRed: result := @IsRedGreaterThanValue;
511 cdGreen: result := @IsGreenGreaterThanValue;
512 cdBlue: result := @IsBlueGreaterThanValue;
513 cdAlpha: result := @IsAlphaGreaterThanValue;
514 cdRGB: result := @IsRGBGreaterThanValue;
515 cdRG: result := @IsRGGreaterThanValue;
516 cdGB: result := @IsGBGreaterThanValue;
517 cdRB: result := @IsRBGreaterThanValue;
518 cdRInvG: result := @IsRInvGGreaterThanValue;
519 cdGInvB: result := @IsGInvBGreaterThanValue;
520 cdRInvB: result := @IsRInvBGreaterThanValue;
521 cdRInvGB: result := @IsRInvGBGreaterThanValue;
522 cdGInvRB: result := @IsGInvRBGreaterThanValue;
523 cdBInvRG: result := @IsBInvRGGreaterThanValue;
524 cdSaturation: result := @IsSaturationGreaterThanValue;
525 else raise Exception.Create('Unknown dimension');
526 end;
527 end;
528
BGRAColorCountnull529 function BGRAColorCount(ABitmap: TBGRACustomBitmap;
530 AAlpha: TAlphaChannelPaletteOption): integer;
531 var
532 box: TBGRAColorBox;
533 begin
534 box := TBGRAColorBox.Create(AllColorDimensions,ABitmap,AAlpha);
535 result := box.ColorCount[True];
536 box.Free;
537 end;
538
539 const
540 ApproxPaletteDimensions = [cdAlpha,cdRInvG,cdGInvB,cdRInvB,cdRInvGB,cdGInvRB,cdBInvRG,cdRGB];
541
542 { TBGRAApproxPaletteViaLargerPalette }
543
FindNearestLargerColorIndexnull544 function TBGRAApproxPaletteViaLargerPalette.FindNearestLargerColorIndex(
545 AValue: TBGRAPixel): integer;
546 begin
547 result := FLarger.FindNearestColorIndex(AValue);
548 end;
549
TBGRAApproxPaletteViaLargerPalette.SlowFindNearestColorIndexnull550 function TBGRAApproxPaletteViaLargerPalette.SlowFindNearestColorIndex(
551 AValue: TBGRAPixel): integer;
552 var diff,curDiff: Int32or64;
553 i: Int32or64;
554 begin
555 if AValue.alpha = 0 then
556 begin
557 result := FTransparentColorIndex;
558 exit;
559 end;
560 diff := BGRAWordDiff(AValue, FColors[0].Color);
561 result := 0;
562 for i := 0 to high(FColors) do
563 begin
564 curDiff := BGRAWordDiff(AValue, FColors[i].Color);
565 if curDiff < diff then
566 begin
567 result := i;
568 diff := curDiff;
569 end;
570 end;
571 end;
572
573 constructor TBGRAApproxPaletteViaLargerPalette.Create(
574 const AColors: ArrayOfTBGRAPixel; ALarger: TBGRACustomApproxPalette; ALargerOwned: boolean);
575 var i: integer;
576 largeWeighted: ArrayOfWeightedColor;
577 begin
578 inherited Create(AColors);
579 FTransparentColorIndex:= -1;
580 for i := 0 to high(FColors) do
581 begin
582 FColors[i].Weight := 0;
583 if FColors[i].Color.alpha = 0 then FTransparentColorIndex:= i;
584 end;
585 FLarger := ALarger;
586 FLargerOwned := ALargerOwned;
587 largeWeighted := FLarger.GetAsArrayOfWeightedColor;
588 setlength(FLargerColors, length(largeWeighted));
589 for i := 0 to high(FLargerColors) do
590 with FLargerColors[i] do
591 begin
592 approxColorIndex := SlowFindNearestColorIndex(largeWeighted[i].Color);
593 if approxColorIndex = -1 then
594 approxColor := BGRAPixelTransparent
595 else
596 begin
597 approxColor := FColors[approxColorIndex].Color;
598 inc(FColors[approxColorIndex].Weight, largeWeighted[i].Weight);
599 end;
600 end;
601 end;
602
603 destructor TBGRAApproxPaletteViaLargerPalette.Destroy;
604 begin
605 if FLargerOwned then FreeAndNil(FLarger);
606 inherited Destroy;
607 end;
608
FindNearestColornull609 function TBGRAApproxPaletteViaLargerPalette.FindNearestColor(AValue: TBGRAPixel
610 ): TBGRAPixel;
611 var index: integer;
612 begin
613 index := FindNearestLargerColorIndex(AValue);
614 if index = -1 then
615 result := BGRAPixelTransparent
616 else
617 Result:= FLargerColors[index].approxColor;
618 end;
619
FindNearestColorIndexnull620 function TBGRAApproxPaletteViaLargerPalette.FindNearestColorIndex(
621 AValue: TBGRAPixel): integer;
622 var index: integer;
623 begin
624 index := FindNearestLargerColorIndex(AValue);
625 if index = -1 then
626 result := -1
627 else
628 Result:= FLargerColors[index].approxColorIndex;
629 end;
630
TBGRAApproxPaletteViaLargerPalette.GetAsArrayOfWeightedColornull631 function TBGRAApproxPaletteViaLargerPalette.GetAsArrayOfWeightedColor: ArrayOfWeightedColor;
632 var
633 i: Integer;
634 begin
635 setlength(result, length(FColors));
636 for i := 0 to high(FColors) do
637 result[i] := FColors[i];
638 end;
639
640 { TBGRAApproxPalette }
641
TBGRAApproxPalette.GetCountnull642 function TBGRAApproxPalette.GetCount: integer;
643 begin
644 result := length(FColors);
645 end;
646
GetColorByIndexnull647 function TBGRAApproxPalette.GetColorByIndex(AIndex: integer): TBGRAPixel;
648 begin
649 if (AIndex < 0) or (AIndex >= length(FColors)) then
650 raise ERangeError.Create('Index out of bounds');
651 result := FColors[AIndex].Color;
652 end;
653
TBGRAApproxPalette.GetWeightByIndexnull654 function TBGRAApproxPalette.GetWeightByIndex(AIndex: Integer): UInt32;
655 begin
656 if (AIndex < 0) or (AIndex >= length(FColors)) then
657 raise ERangeError.Create('Index out of bounds');
658 result := FColors[AIndex].Weight;
659 end;
660
661 procedure TBGRAApproxPalette.Init(const AColors: ArrayOfTBGRAPixel);
662 var
663 weightedColors: ArrayOfWeightedColor;
664 i: Int32or64;
665 begin
666 setlength(weightedColors, length(AColors));
667 for i := 0 to high(weightedColors) do
668 with weightedColors[i] do
669 begin
670 Color := AColors[i];
671 Weight := 1;
672 end;
673 FTree := TBGRAColorTree.Create(TBGRAColorBox.Create(ApproxPaletteDimensions,weightedColors,True),True);
674 FTree.SplitIntoPalette(length(AColors),blApparentInterval,lcAverage);
675
676 FColors := FTree.GetAsArrayOfWeightedColors;
677 end;
678
679 constructor TBGRAApproxPalette.Create(const AColors: ArrayOfTBGRAPixel);
680 begin
681 Init(AColors);
682 end;
683
684 constructor TBGRAApproxPalette.Create(const AColors: ArrayOfWeightedColor);
685 begin
686 FTree := TBGRAColorTree.Create(TBGRAColorBox.Create(ApproxPaletteDimensions,AColors,True),True);
687 FTree.SplitIntoPalette(length(AColors),blApparentInterval,lcAverage);
688
689 FColors := FTree.GetAsArrayOfWeightedColors;
690 end;
691
692 constructor TBGRAApproxPalette.Create(AOwnedSplitTree: TBGRAColorTree);
693 begin
694 FTree := AOwnedSplitTree;
695 FColors := FTree.GetAsArrayOfWeightedColors;
696 end;
697
698 destructor TBGRAApproxPalette.Destroy;
699 begin
700 FreeAndNil(FTree);
701 inherited Destroy;
702 end;
703
ContainsColornull704 function TBGRAApproxPalette.ContainsColor(AValue: TBGRAPixel): boolean;
705 begin
706 result := (IndexOfColor(AValue)<>-1);
707 end;
708
IndexOfColornull709 function TBGRAApproxPalette.IndexOfColor(AValue: TBGRAPixel): integer;
710 begin
711 result := FTree.ApproximateColorIndex(AValue);
712 if (result <> -1) and not (LongWord(FColors[result].Color) = LongWord(AValue)) then result := -1;
713 end;
714
FindNearestColornull715 function TBGRAApproxPalette.FindNearestColor(AValue: TBGRAPixel): TBGRAPixel;
716 begin
717 result := FTree.ApproximateColor(AValue);
718 end;
719
FindNearestColorIndexnull720 function TBGRAApproxPalette.FindNearestColorIndex(AValue: TBGRAPixel): integer;
721 begin
722 result := FTree.ApproximateColorIndex(AValue);
723 end;
724
TBGRAApproxPalette.GetAsArrayOfColornull725 function TBGRAApproxPalette.GetAsArrayOfColor: ArrayOfTBGRAPixel;
726 var
727 i: Int32or64;
728 begin
729 setlength(result, length(FColors));
730 for i := 0 to high(result) do
731 result[i] := FColors[i].Color;
732 end;
733
TBGRAApproxPalette.GetAsArrayOfWeightedColornull734 function TBGRAApproxPalette.GetAsArrayOfWeightedColor: ArrayOfWeightedColor;
735 var
736 i: Int32or64;
737 begin
738 if Assigned(FTree) then
739 result := FTree.GetAsArrayOfWeightedColors
740 else
741 begin
742 setlength(result, length(FColors));
743 for i := 0 to high(result) do
744 result[i] := FColors[i];
745 end;
746 end;
747
748 { TBGRAColorQuantizer }
749
750 procedure TBGRAColorQuantizer.Init(ABox: TBGRAColorBox);
751 begin
752 FColors := ABox.FColors;
753 if ABox.HasPureTransparentColor then
754 begin
755 setlength(FColors,length(FColors)+1);
756 with FColors[high(FColors)] do
757 begin
758 Color := BGRAPixelTransparent;
759 Weight:= ABox.PureTransparentColorCount;
760 end;
761 end;
762 ABox.FColors := nil;
763 ABox.Free;
764 FReductionColorCount := 256;
765 FReductionKeepContrast := true;
766 end;
767
768 procedure TBGRAColorQuantizer.SetReductionColorCount(AValue: Integer);
769 begin
770 if AValue < 1 then AValue := 1;
771 if FReductionColorCount=AValue then Exit;
772 FReductionColorCount:=AValue;
773 FreeAndNil(FPalette);
774 end;
775
776 procedure TBGRAColorQuantizer.NormalizeArrayOfColors(
777 AColors: ArrayOfTBGRAPixel; ARedBounds, AGreenBounds, ABlueBounds,
778 AAlphaBounds: TDimensionMinMax; AUniform: boolean);
779 var
780 curRedBounds, curGreenBounds, curBlueBounds, curAlphaBounds: TDimensionMinMax;
781 RedSub,RedMul,RedDiv,RedAdd: UInt32or64;
782 GreenSub,GreenMul,GreenDiv,GreenAdd: UInt32or64;
783 BlueSub,BlueMul,BlueDiv,BlueAdd: UInt32or64;
784 AlphaSub,AlphaMul,AlphaDiv,AlphaAdd: UInt32or64;
785 i: Int32or64;
786 colorBounds: TDimensionMinMax;
787 begin
788 if length(AColors)=0 then exit;
789 if AUniform then
790 begin
791 colorBounds := ABlueBounds;
792 colorBounds.GrowToInclude(AGreenBounds.Minimum shr GreenShift);
793 colorBounds.GrowToInclude(AGreenBounds.Maximum shr GreenShift);
794 colorBounds.GrowToInclude(ARedBounds.Minimum shr RedShift);
795 colorBounds.GrowToInclude(ARedBounds.Maximum shr RedShift);
796 NormalizeArrayOfColors(AColors, colorBounds, AAlphaBounds);
797 exit;
798 end;
799 curRedBounds.SetAsPoint(GetDimensionValue(AColors[0],cdRed));
800 curGreenBounds.SetAsPoint(GetDimensionValue(AColors[0],cdGreen));
801 curBlueBounds.SetAsPoint(GetDimensionValue(AColors[0],cdBlue));
802 curAlphaBounds.SetAsPoint(GetDimensionValue(AColors[0],cdAlpha));
803 for i := 1 to high(AColors) do
804 with AColors[i] do
805 begin
806 curRedBounds.GrowToInclude(GetDimensionValue(AColors[i],cdRed));
807 curGreenBounds.GrowToInclude(GetDimensionValue(AColors[i],cdGreen));
808 curBlueBounds.GrowToInclude(GetDimensionValue(AColors[i],cdBlue));
809 curAlphaBounds.GrowToInclude(GetDimensionValue(AColors[i],cdAlpha));
810 end;
811 RedSub := curRedBounds.Minimum shr RedShift;
812 RedMul := ARedBounds.Size shr RedShift;
813 RedDiv := curRedBounds.Size shr RedShift;
814 RedAdd := ARedBounds.Minimum shr RedShift;
815 if RedDiv = 0 then RedDiv := 1;
816 GreenSub := curGreenBounds.Minimum shr GreenShift;
817 GreenMul := AGreenBounds.Size shr GreenShift;
818 GreenDiv := curGreenBounds.Size shr GreenShift;
819 GreenAdd := AGreenBounds.Minimum shr GreenShift;
820 if GreenDiv = 0 then GreenDiv := 1;
821 BlueSub := curBlueBounds.Minimum;
822 BlueMul := ABlueBounds.Size;
823 BlueDiv := curBlueBounds.Size;
824 BlueAdd := ABlueBounds.Minimum;
825 if BlueDiv = 0 then BlueDiv := 1;
826 AlphaSub := curAlphaBounds.Minimum shr (AlphaShift+8);
827 AlphaMul := AAlphaBounds.Size shr (AlphaShift+8);
828 AlphaDiv := curAlphaBounds.Size shr (AlphaShift+8);
829 AlphaAdd := AAlphaBounds.Minimum shr (AlphaShift+8);
830 if AlphaDiv = 0 then AlphaDiv := 1;
831 for i := 0 to high(AColors) do
832 with AColors[i] do
833 begin
834 red := GammaCompressionTab[((GammaExpansionTab[red]-RedSub)*RedMul+(RedDiv shr 1)) div RedDiv + RedAdd];
835 green := GammaCompressionTab[((GammaExpansionTab[green]-GreenSub)*GreenMul+(GreenDiv shr 1)) div GreenDiv + GreenAdd];
836 blue := GammaCompressionTab[((GammaExpansionTab[blue]-BlueSub)*BlueMul+(BlueDiv shr 1)) div BlueDiv + BlueAdd];
837 alpha := ((alpha-AlphaSub)*AlphaMul+(AlphaDiv shr 1)) div AlphaDiv + AlphaAdd;
838 end;
839 end;
840
841 procedure TBGRAColorQuantizer.NormalizeArrayOfColors(
842 AColors: ArrayOfTBGRAPixel; AColorBounds, AAlphaBounds: TDimensionMinMax);
843 var
844 curColorBounds, curAlphaBounds: TDimensionMinMax;
845 ColorSub,ColorMul,ColorDiv,ColorAdd: UInt32or64;
846 AlphaSub,AlphaMul,AlphaDiv,AlphaAdd: UInt32or64;
847 i: Int32or64;
848 begin
849 if length(AColors)=0 then exit;
850 curColorBounds.SetAsPoint(GammaExpansionTab[AColors[0].red]);
851 curColorBounds.GrowToInclude(GammaExpansionTab[AColors[0].green]);
852 curColorBounds.GrowToInclude(GammaExpansionTab[AColors[0].blue]);
853 curAlphaBounds.SetAsPoint(AColors[0].alpha);
854 for i := 1 to high(AColors) do
855 with AColors[i] do
856 begin
857 curColorBounds.GrowToInclude(GammaExpansionTab[red]);
858 curColorBounds.GrowToInclude(GammaExpansionTab[green]);
859 curColorBounds.GrowToInclude(GammaExpansionTab[blue]);
860 curAlphaBounds.GrowToInclude(alpha);
861 end;
862 ColorSub := curColorBounds.Minimum;
863 ColorMul := AColorBounds.Size;
864 ColorDiv := curColorBounds.Size;
865 ColorAdd := AColorBounds.Minimum;
866 if ColorDiv = 0 then ColorDiv := 1;
867 AlphaSub := curAlphaBounds.Minimum;
868 AlphaMul := AAlphaBounds.Size shr 8;
869 AlphaDiv := curAlphaBounds.Size;
870 AlphaAdd := AAlphaBounds.Minimum shr 8;
871 if AlphaDiv = 0 then AlphaDiv := 1;
872 for i := 0 to high(AColors) do
873 with AColors[i] do
874 begin
875 red := GammaCompressionTab[((GammaExpansionTab[red]-ColorSub)*ColorMul+(ColorDiv shr 1)) div ColorDiv + ColorAdd];
876 green := GammaCompressionTab[((GammaExpansionTab[green]-ColorSub)*ColorMul+(ColorDiv shr 1)) div ColorDiv + ColorAdd];
877 blue := GammaCompressionTab[((GammaExpansionTab[blue]-ColorSub)*ColorMul+(ColorDiv shr 1)) div ColorDiv + ColorAdd];
878 alpha := ((alpha-AlphaSub)*AlphaMul+(AlphaDiv shr 1)) div AlphaDiv + AlphaAdd;
879 end;
880 end;
881
GetSourceColorCountnull882 function TBGRAColorQuantizer.GetSourceColorCount: Integer;
883 begin
884 result := length(FColors);
885 end;
886
TBGRAColorQuantizer.GetReductionColorCountnull887 function TBGRAColorQuantizer.GetReductionColorCount: integer;
888 begin
889 result := FReductionColorCount;
890 end;
891
TBGRAColorQuantizer.GetPalettenull892 function TBGRAColorQuantizer.GetPalette: TBGRACustomApproxPalette;
893 var
894 tree: TBGRAColorTree;
895
896 procedure MakeTreeErrorDiffusionFriendly;
897 var moreColors: ArrayOfWeightedColor;
898 box: TBGRAColorBox;
899 begin
900 moreColors := tree.GetAsArrayOfWeightedColors;
901 tree.free;
902 box := TBGRAColorBox.Create([cdRed,cdGreen,cdBlue,cdAlpha],moreColors,True);
903 tree := TBGRAColorTree.Create(box,True);
904 tree.SplitIntoPalette(box.ColorCount[true], blApparentInterval, lcAverage);
905 end;
906
907 var
908 originalBox: TBGRAColorBox;
909 colors: ArrayOfTBGRAPixel;
910 bounds: array[TColorDimension] of TDimensionMinMax;
911 nbLarge,nbOriginal: integer;
912
913 begin
914 if not Assigned(FPalette) then
915 if FReductionColorCount >= length(FColors) then
916 begin
917 originalBox := TBGRAColorBox.Create([cdRed,cdGreen,cdBlue,cdAlpha],FColors, False);
918 tree := TBGRAColorTree.Create(originalBox,True);
919 tree.SplitIntoPalette(originalBox.ColorCount[true], blApparentInterval, lcAverage);
920 FPalette := TBGRAApproxPalette.Create(tree);
921 end else
922 begin
923 originalBox := TBGRAColorBox.Create(AllColorDimensions, FColors, False);
924 bounds[cdRed] := originalBox.Bounds[cdRed];
925 bounds[cdGreen] := originalBox.Bounds[cdGreen];
926 bounds[cdBlue] := originalBox.Bounds[cdBlue];
927 bounds[cdAlpha] := originalBox.Bounds[cdAlpha];
928 if originalBox.HasPureTransparentColor then bounds[cdAlpha].Minimum := 0;
929 if FReductionColorCount = 1 then
930 begin
931 setlength(colors,1);
932 colors[0] := originalBox.AverageColor;
933 originalBox.Free;
934 FPalette := TBGRAApproxPalette.Create(colors);
935 end else
936 begin
937 tree := TBGRAColorTree.Create(originalBox,True);
938 if FReductionColorCount <= 64 then
939 begin
940 nbLarge := 128;
941 nbOriginal := originalBox.ColorCount[True];
942 if nbOriginal < 128 then nbLarge:= nbOriginal;
943 colors := tree.SplitIntoPaletteWithSubPalette(nbLarge, blMix,lcMix, FReductionColorCount);
944 MakeTreeErrorDiffusionFriendly;
945 if FReductionColorCount <= 4 then
946 NormalizeArrayOfColors(colors, bounds[cdRed],bounds[cdGreen],bounds[cdBlue],bounds[cdAlpha],true);
947 FPalette := TBGRAApproxPaletteViaLargerPalette.Create(colors, TBGRAApproxPalette.Create(tree), True);
948 end else
949 begin
950 tree.SplitIntoPalette(FReductionColorCount, blMix,lcMix);
951 MakeTreeErrorDiffusionFriendly;
952 FPalette := TBGRAApproxPalette.Create(tree);
953 end;
954 end;
955 end;
956 result := FPalette;
957 end;
958
GetSourceColornull959 function TBGRAColorQuantizer.GetSourceColor(AIndex: integer): TBGRAPixel;
960 begin
961 if (AIndex < 0) or (AIndex >= length(FColors)) then
962 raise ERangeError.Create('Index out of bounds');
963 result := FColors[AIndex].Color;
964 end;
965
966 constructor TBGRAColorQuantizer.Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean);
967 begin
968 FSeparateAlphaChannel:= ASeparateAlphaChannel;
969 Init(TBGRAColorBox.Create(AllColorDimensions, APalette));
970 end;
971
972 constructor TBGRAColorQuantizer.Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption);
973 begin
974 FSeparateAlphaChannel:= (AAlpha = acIgnore);
975 Init(TBGRAColorBox.Create(AllColorDimensions, ABitmap, AAlpha));
976 end;
977
978 constructor TBGRAColorQuantizer.Create(APalette: TBGRACustomPalette;
979 ASeparateAlphaChannel: boolean; AReductionColorCount: integer);
980 begin
981 FSeparateAlphaChannel:= ASeparateAlphaChannel;
982 Init(TBGRAColorBox.Create(AllColorDimensions, APalette));
983 ReductionColorCount := AReductionColorCount;
984 end;
985
986 constructor TBGRAColorQuantizer.Create(ABitmap: TBGRACustomBitmap;
987 AAlpha: TAlphaChannelPaletteOption; AReductionColorCount: integer);
988 begin
989 FSeparateAlphaChannel:= (AAlpha = acIgnore);
990 Init(TBGRAColorBox.Create(AllColorDimensions, ABitmap, AAlpha));
991 ReductionColorCount := AReductionColorCount;
992 end;
993
994 destructor TBGRAColorQuantizer.Destroy;
995 begin
996 FreeAndNil(FPalette);
997 inherited Destroy;
998 end;
999
1000 procedure TBGRAColorQuantizer.ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
1001 ABounds: TRect);
1002 var task: TDitheringTask;
1003 begin
1004 task := CreateDitheringTask(AAlgorithm, ABitmap, ReducedPalette, FSeparateAlphaChannel, ABounds);
1005 task.Destination := ABitmap;
1006 task.Execute;
1007 task.Free;
1008 end;
1009
GetDitheredBitmapnull1010 function TBGRAColorQuantizer.GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm;
1011 ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap;
1012 var task: TDitheringTask;
1013 begin
1014 task := CreateDitheringTask(AAlgorithm, ABitmap, ReducedPalette, FSeparateAlphaChannel, ABounds);
1015 result := task.Execute;
1016 task.Free;
1017 end;
1018
GetDitheredBitmapIndexedDatanull1019 function TBGRAColorQuantizer.GetDitheredBitmapIndexedData(
1020 ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
1021 out AScanlineSize: PtrInt): Pointer;
1022 var
1023 indexer: TDitheringToIndexedImage;
1024 begin
1025 indexer := TDitheringToIndexedImage.Create(ReducedPalette, FSeparateAlphaChannel, ABitDepth, AByteOrder);
1026 indexer.DefaultTransparentColorIndex := ReducedPalette.IndexOfColor(BGRAPixelTransparent);
1027 AScanlineSize:= indexer.ComputeMinimumScanlineSize(ABitmap.Width);
1028 result := indexer.DitherImage(AAlgorithm, ABitmap, AScanlineSize);
1029 indexer.Free;
1030 end;
1031
1032 procedure TBGRAColorQuantizer.SaveBitmapToStream(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
1033 AStream: TStream; AFormat: TBGRAImageFormat);
1034 var
1035 dithered: TBGRACustomBitmap;
1036 hasTransp: boolean;
1037 writer: TFPCustomImageWriter;
1038 depth: integer;
1039 begin
1040 dithered := GetDitheredBitmap(AAlgorithm, ABitmap);
1041 try
1042 ReducedPalette.AssignTo(dithered);
1043 hasTransp := dithered.HasTransparentPixels;
1044 writer := CreateBGRAImageWriter(AFormat, hasTransp);
1045 try
1046 if writer is TBGRAWriterPNG then TBGRAWriterPNG(writer).Indexed := true else
1047 if writer is TFPWriterBMP then
1048 begin
1049 if not hasTransp then
1050 begin
1051 depth := BGRARequiredBitDepth(ReducedPalette);
1052 if depth < 8 then
1053 begin
1054 if depth > 4 then
1055 depth := 8
1056 else if depth > 1 then
1057 depth := 4;
1058 end;
1059 TFPWriterBMP(writer).BitsPerPixel := depth;
1060 end;
1061 end;
1062 dithered.SaveToStream(AStream, writer);
1063 finally
1064 writer.Free;
1065 end;
1066 finally
1067 dithered.Free;
1068 end;
1069 end;
1070
1071 { TBGRAColorTree }
1072
TrySplitLeafnull1073 function TBGRAColorTree.TrySplitLeaf: boolean;
1074 var
1075 dim: TColorDimension;
1076 box2: TBGRAColorBox;
1077 mid: UInt32;
1078 begin
1079 result := false;
1080 if IsLeaf and Assigned(FLeaf) and not FLeaf.PointLike then
1081 begin
1082 dim := FLeaf.LargestApparentDimension;
1083 box2 := FLeaf.MedianCut(dim,mid);
1084 if box2 <> nil then
1085 begin
1086 FInferiorBranch := TBGRAColorTree.Create(FLeaf,True);
1087 FSuperiorBranch := TBGRAColorTree.Create(box2,True);
1088
1089 FInferiorBranch.FMinBorder := FMinBorder;
1090 FInferiorBranch.FMaxBorder := FMaxBorder;
1091 FSuperiorBranch.FMinBorder := FMinBorder;
1092 FSuperiorBranch.FMaxBorder := FMaxBorder;
1093 FInferiorBranch.FMaxBorder[dim] := false;
1094 FSuperiorBranch.FMinBorder[dim] := false;
1095
1096 FLeaf := nil;
1097 FIsLeaf:= false;
1098 FDimension := dim;
1099 FPixelValueComparer := GetPixelValueComparer(FDimension);
1100 FSuperiorMiddle := mid;
1101 result := true;
1102 end;
1103 end;
1104 end;
1105
1106 procedure TBGRAColorTree.ComputeLeavesColor(ALeafColor: TBGRALeafColorMode);
1107 var index: integer;
1108 begin
1109 index := 0;
1110 if HasPureTransparentColor then
1111 begin
1112 FPureTransparentColorIndex:= index;
1113 inc(index);
1114 end;
1115 InternalComputeLeavesColor(ALeafColor,{%H-}index);
1116 end;
1117
1118 procedure TBGRAColorTree.InternalComputeLeavesColor(
1119 ALeafColor: TBGRALeafColorMode; var AStartIndex: integer);
1120 var nbMin,nbMax: Int32or64;
1121 c: TColorDimension;
1122 extremumColor: TBGRAPixel;
1123 extremumColorRelevant: Boolean;
1124 begin
1125 if IsLeaf then
1126 begin
1127 FLeafColorIndex := AStartIndex;
1128 inc(AStartIndex);
1129 if Assigned(FLeaf) then
1130 begin
1131 if not FLeafColorComputed then
1132 begin
1133 FLeafColorComputed := true;
1134 FCenterColor.alpha:= min(FLeaf.FBounds[cdAlpha].GetCenter shr AlphaShift, 255);
1135 FCenterColor.red:= GammaCompressionTab[min(FLeaf.FBounds[cdRed].GetCenter shr RedShift, 65535)];
1136 FCenterColor.green:= GammaCompressionTab[min(FLeaf.FBounds[cdGreen].GetCenter shr GreenShift, 65535)];
1137 FCenterColor.blue:= GammaCompressionTab[min(FLeaf.FBounds[cdBlue].GetCenter, 65535)];
1138 FAverageColor := FLeaf.AverageColorOrMainColor;
1139 extremumColor := FAverageColor;
1140
1141 if ALeafColor in [lcMix,lcExtremum] then
1142 begin
1143 nbMax := 0;
1144 nbMin := 0;
1145 for c := succ(low(TColorDimension)) to high(TColorDimension) do
1146 begin
1147 if FMinBorder[c] then inc(nbMin);
1148 if FMaxBorder[c] then inc(nbMax);
1149 end;
1150
1151 if nbMin > nbMax then
1152 extremumColor := FLeaf.InferiorColor
1153 else if nbMax > nbMin then
1154 extremumColor := FLeaf.SuperiorColor;
1155 end;
1156
1157 case ALeafColor of
1158 lcAverage,lcMix: FLeafColor := FAverageColor;
1159 lcExtremum: FLeafColor := extremumColor;
1160 else FLeafColor := FCenterColor;
1161 end;
1162
1163 if ALeafColor = lcMix then
1164 begin
1165 extremumColorRelevant := false;
1166 for c := succ(low(TColorDimension)) to high(TColorDimension) do
1167 if UInt32(abs(GetDimensionValue(extremumColor,c) - GetDimensionValue(FLeafColor,c))) >
1168 FLeaf.FBounds[c].Size div 7 then
1169 begin
1170 extremumColorRelevant := true;
1171 break;
1172 end;
1173 if extremumColorRelevant then FLeafColor := extremumColor;
1174 end;
1175 end;
1176 end else
1177 begin
1178 FLeafColor := BGRAPixelTransparent;
1179 FCenterColor := BGRAPixelTransparent;
1180 end;
1181 end else
1182 begin
1183 if Assigned(FInferiorBranch) then FInferiorBranch.InternalComputeLeavesColor(ALeafColor, AStartIndex);
1184 if Assigned(FSuperiorBranch) then FSuperiorBranch.InternalComputeLeavesColor(ALeafColor, AStartIndex);
1185 end;
1186 end;
1187
1188 procedure TBGRAColorTree.CheckColorComputed;
1189 begin
1190 if not FLeafColorComputed then
1191 raise exception.Create('Color not computed. Call ComputeLeavesColor first.');
1192 end;
1193
ApproximateColornull1194 function TBGRAColorTree.ApproximateColor(AColor: TBGRAPixel): TBGRAPixel;
1195 var branch: TBGRAColorTree;
1196 begin
1197 if AColor.alpha = 0 then
1198 begin
1199 result := BGRAPixelTransparent;
1200 exit;
1201 end;
1202 if IsLeaf then
1203 begin
1204 CheckColorComputed;
1205 result := FLeafColor;
1206 end else
1207 begin
1208 if FPixelValueComparer(@AColor,FSuperiorMiddle) then
1209 branch := FSuperiorBranch else branch := FInferiorBranch;
1210 if Assigned(branch) then
1211 result := branch.ApproximateColor(AColor)
1212 else
1213 result := BGRAPixelTransparent;
1214 end;
1215 end;
1216
ApproximateColorIndexnull1217 function TBGRAColorTree.ApproximateColorIndex(AColor: TBGRAPixel): integer;
1218 var branch: TBGRAColorTree;
1219 begin
1220 if AColor.alpha = 0 then
1221 begin
1222 result := FPureTransparentColorIndex;
1223 exit;
1224 end;
1225 if IsLeaf then
1226 begin
1227 CheckColorComputed;
1228 result := FLeafColorIndex;
1229 end else
1230 begin
1231 if FPixelValueComparer(@AColor,FSuperiorMiddle) then
1232 branch := FSuperiorBranch else branch := FInferiorBranch;
1233 if Assigned(branch) then
1234 result := branch.ApproximateColorIndex(AColor)
1235 else
1236 result := FPureTransparentColorIndex;
1237 end;
1238 end;
1239
GetAsArrayOfApproximatedColorsnull1240 function TBGRAColorTree.GetAsArrayOfApproximatedColors: ArrayOfTBGRAPixel;
1241 var a,b: ArrayOfTBGRAPixel;
1242 idx,i: integer;
1243 begin
1244 if IsLeaf then
1245 begin
1246 CheckColorComputed;
1247 setlength(result,1+byte(HasPureTransparentColor));
1248 idx := 0;
1249 if HasPureTransparentColor then
1250 begin
1251 result[idx] := BGRAPixelTransparent;
1252 inc(idx);
1253 end;
1254 result[idx] := FLeafColor;
1255 end else
1256 begin
1257 a := FInferiorBranch.GetAsArrayOfApproximatedColors;
1258 b := FSuperiorBranch.GetAsArrayOfApproximatedColors;
1259 setlength(result, length(a)+length(b)+byte(HasPureTransparentColor));
1260 idx := 0;
1261 if HasPureTransparentColor then
1262 begin
1263 result[idx] := BGRAPixelTransparent;
1264 inc(idx);
1265 end;
1266 for i := 0 to high(a) do
1267 begin
1268 result[idx] := a[i];
1269 inc(idx);
1270 end;
1271 for i := 0 to high(b) do
1272 begin
1273 result[idx] := b[i];
1274 inc(idx);
1275 end;
1276 end;
1277 end;
1278
GetAsArrayOfWeightedColorsnull1279 function TBGRAColorTree.GetAsArrayOfWeightedColors: ArrayOfWeightedColor;
1280 var a,b: ArrayOfWeightedColor;
1281 idx,i: integer;
1282 begin
1283 if IsLeaf then
1284 begin
1285 CheckColorComputed;
1286 setlength(result,1+byte(HasPureTransparentColor));
1287 idx := 0;
1288 if HasPureTransparentColor then
1289 begin
1290 result[idx].Color := BGRAPixelTransparent;
1291 result[idx].Weight := PureTransparentColorCount;
1292 inc(idx);
1293 end;
1294 result[idx].Color := FLeafColor;
1295 result[idx].Weight := Weight;
1296 end else
1297 begin
1298 a := FInferiorBranch.GetAsArrayOfWeightedColors;
1299 b := FSuperiorBranch.GetAsArrayOfWeightedColors;
1300 setlength(result, length(a)+length(b)+byte(HasPureTransparentColor));
1301 idx := 0;
1302 if HasPureTransparentColor then
1303 begin
1304 result[idx].Color := BGRAPixelTransparent;
1305 result[idx].Weight := PureTransparentColorCount;
1306 inc(idx);
1307 end;
1308 for i := 0 to high(a) do
1309 begin
1310 result[idx] := a[i];
1311 inc(idx);
1312 end;
1313 for i := 0 to high(b) do
1314 begin
1315 result[idx] := b[i];
1316 inc(idx);
1317 end;
1318 end;
1319 end;
1320
1321 procedure TBGRAColorTree.SplitIntoPalette(ACount: integer;
1322 AMethod: TBiggestLeafMethod; ALeafColor: TBGRALeafColorMode);
1323 var nbColors: integer;
1324 leaf: TBGRAColorTree;
1325 begin
1326 nbColors := ApproximatedColorCount;
1327 while nbColors < ACount do
1328 begin
1329 leaf := FindBiggestLeaf(AMethod);
1330 if not leaf.TrySplitLeaf then break;
1331 inc(nbColors);
1332 end;
1333 ComputeLeavesColor(ALeafColor);
1334 FreeLeaves;
1335 end;
1336
SplitIntoPaletteWithSubPalettenull1337 function TBGRAColorTree.SplitIntoPaletteWithSubPalette(ACount: integer;
1338 AMethod: TBiggestLeafMethod; ALeafColor: TBGRALeafColorMode;
1339 ASubPaletteCount: integer): ArrayOfTBGRAPixel;
1340 var nbColors: integer;
1341 leaf: TBGRAColorTree;
1342 begin
1343 result := nil;
1344 nbColors := ApproximatedColorCount;
1345 if ASubPaletteCount > ACount then ASubPaletteCount:= ACount;
1346 if nbColors = ASubPaletteCount then
1347 begin
1348 ComputeLeavesColor(ALeafColor);
1349 result := GetAsArrayOfApproximatedColors;
1350 end;
1351 while nbColors < ACount do
1352 begin
1353 leaf := FindBiggestLeaf(AMethod);
1354 if not leaf.TrySplitLeaf then break;
1355 inc(nbColors);
1356 if nbColors = ASubPaletteCount then
1357 begin
1358 ComputeLeavesColor(ALeafColor);
1359 result := GetAsArrayOfApproximatedColors;
1360 end;
1361 end;
1362 ComputeLeavesColor(ALeafColor);
1363 FreeLeaves;
1364 end;
1365
GetLeafCountnull1366 function TBGRAColorTree.GetLeafCount: integer;
1367 begin
1368 if IsLeaf then
1369 result := 1
1370 else
1371 begin
1372 result := 0;
1373 if Assigned(FInferiorBranch) then inc(result, FInferiorBranch.LeafCount);
1374 if Assigned(FSuperiorBranch) then inc(result, FSuperiorBranch.LeafCount);
1375 end;
1376 end;
1377
GetApproximatedColorCountnull1378 function TBGRAColorTree.GetApproximatedColorCount: integer;
1379 begin
1380 if IsLeaf then
1381 result := 1
1382 else
1383 begin
1384 result := 0;
1385 if Assigned(FInferiorBranch) then inc(result, FInferiorBranch.ApproximatedColorCount);
1386 if Assigned(FSuperiorBranch) then inc(result, FSuperiorBranch.ApproximatedColorCount);
1387 end;
1388 if HasPureTransparentColor then inc(result);
1389 end;
1390
GetHasPureTransparentColornull1391 function TBGRAColorTree.GetHasPureTransparentColor: boolean;
1392 begin
1393 result := FPureTransparentColorCount > 0;
1394 end;
1395
1396 procedure TBGRAColorTree.Init(ALeaf: TBGRAColorBox; AOwned: boolean);
1397 var
1398 c: TColorDimension;
1399 begin
1400 if not AOwned then
1401 FLeaf := ALeaf.Duplicate
1402 else
1403 FLeaf := ALeaf;
1404 FLargestApparentInterval:= FLeaf.LargestApparentInterval;
1405 FWeight := FLeaf.TotalWeight;
1406 FIsLeaf:= true;
1407 for c := low(TColorDimension) to high(TColorDimension) do
1408 begin
1409 FMinBorder[c] := true;
1410 FMaxBorder[c] := true;
1411 end;
1412 FPureTransparentColorCount:= FLeaf.PureTransparentColorCount;
1413 FPureTransparentColorIndex:= -1;
1414 end;
1415
1416 constructor TBGRAColorTree.Create(ABox: TBGRAColorBox; AOwned: boolean);
1417 begin
1418 Init(ABox,AOwned);
1419 end;
1420
1421 constructor TBGRAColorTree.Create(ADimensions: TColorDimensions; APalette: TBGRACustomPalette);
1422 begin
1423 Init(TBGRAColorBox.Create(ADimensions, APalette),True);
1424 end;
1425
1426 constructor TBGRAColorTree.Create(ADimensions: TColorDimensions; ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption);
1427 begin
1428 Init(TBGRAColorBox.Create(ADimensions, ABitmap, AAlpha),True);
1429 end;
1430
1431 destructor TBGRAColorTree.Destroy;
1432 begin
1433 FreeAndNil(FInferiorBranch);
1434 FreeAndNil(FSuperiorBranch);
1435 FreeAndNil(FLeaf);
1436 inherited Destroy;
1437 end;
1438
1439 procedure TBGRAColorTree.FreeLeaves;
1440 begin
1441 if IsLeaf then
1442 FreeAndNil(FLeaf)
1443 else
1444 begin
1445 if Assigned(FInferiorBranch) then FInferiorBranch.FreeLeaves;
1446 if Assigned(FSuperiorBranch) then FSuperiorBranch.FreeLeaves;
1447 end;
1448 end;
1449
FindBiggestLeafnull1450 function TBGRAColorTree.FindBiggestLeaf(AMethod: TBiggestLeafMethod
1451 ): TBGRAColorTree;
1452 var infLeaf,supLeaf: TBGRAColorTree;
1453 begin
1454 if IsLeaf then
1455 result := self
1456 else
1457 begin
1458 infLeaf := FInferiorBranch.FindBiggestLeaf(AMethod);
1459 supLeaf := FSuperiorBranch.FindBiggestLeaf(AMethod);
1460 case AMethod of
1461 blApparentInterval:
1462 if infLeaf.LargestApparentInterval >= supLeaf.LargestApparentInterval then
1463 result := infLeaf
1464 else
1465 result := supLeaf;
1466 blWeight:
1467 if (infLeaf.LargestApparentInterval > 0) and (infLeaf.Weight >= supLeaf.Weight) then
1468 result := infLeaf
1469 else
1470 result := supLeaf;
1471 else{blMix:}
1472 if (sqrt(infLeaf.Weight/FWeight)*(infLeaf.LargestApparentInterval/LargestApparentInterval) >=
1473 sqrt(supLeaf.Weight/FWeight)*(supLeaf.LargestApparentInterval/LargestApparentInterval) ) then
1474 result := infLeaf
1475 else
1476 result := supLeaf;
1477 end;
1478 end;
1479 end;
1480
1481 { TDimensionMinMax }
1482
TDimensionMinMax.Sizenull1483 function TDimensionMinMax.Size: UInt32;
1484 begin
1485 if Maximum>Minimum then
1486 result := Maximum-Minimum
1487 else
1488 result := 0;
1489 end;
1490
TDimensionMinMax.Containsnull1491 function TDimensionMinMax.Contains(AValue: UInt32): boolean;
1492 begin
1493 result := (AValue >= Minimum) and (AValue <= Maximum);
1494 end;
1495
TDimensionMinMax.PointLikenull1496 function TDimensionMinMax.PointLike: boolean;
1497 begin
1498 result := (Minimum = Maximum);
1499 end;
1500
1501 procedure TDimensionMinMax.SetAsPoint(AValue: UInt32);
1502 begin
1503 Minimum := AValue;
1504 Maximum := AValue;
1505 end;
1506
GetCenternull1507 function TDimensionMinMax.GetCenter: UInt32;
1508 begin
1509 result := (Minimum+Maximum) shr 1;
1510 end;
1511
1512 procedure TDimensionMinMax.GrowToInclude(AValue: UInt32);
1513 begin
1514 if AValue < Minimum then Minimum := AValue
1515 else if AValue > Maximum then Maximum := AValue;
1516 end;
1517
1518 { TBGRAColorBox }
1519
GetApparentIntervalnull1520 function TBGRAColorBox.GetApparentInterval(ADimension: TColorDimension): UInt32;
1521 var factor: single;
1522 begin
1523 if not (ADimension in FDimensions) then result := 0
1524 else
1525 begin
1526 factor := 1;
1527 case ADimension of
1528 cdRGB: factor := 0.7;
1529 end;
1530 result := round(FBounds[ADimension].Size*factor);
1531 end;
1532 end;
1533
TBGRAColorBox.GetAverageColornull1534 function TBGRAColorBox.GetAverageColor: TBGRAPixel;
1535 var
1536 n: integer;
1537 r, g, b, a: double;
1538 cura: double;
1539 w: UInt32;
1540 begin
1541 a := 0;
1542 r := 0;
1543 g := 0;
1544 b := 0;
1545 w := 0;
1546 for n := 0 to high(FColors) do
1547 with FColors[n].Color do
1548 begin
1549 cura := (alpha / 255)*FColors[n].Weight;
1550 IncF(a, cura);
1551 IncF(r, GammaExpansionTab[red] * cura);
1552 IncF(g, GammaExpansionTab[green] * cura);
1553 IncF(b, GammaExpansionTab[blue] * cura);
1554 Inc(w, FColors[n].Weight);
1555 end;
1556 if w = 0 then
1557 Result := BGRAPixelTransparent
1558 else
1559 begin
1560 result.alpha := round(a*255/w);
1561 if result.alpha = 0 then result := BGRAPixelTransparent
1562 else
1563 begin
1564 result.red := GammaCompressionTab[round(r / a)];
1565 result.green := GammaCompressionTab[round(g / a)];
1566 result.blue := GammaCompressionTab[round(b / a)];
1567 end;
1568 end;
1569 end;
1570
GetAverageColorOrMainColornull1571 function TBGRAColorBox.GetAverageColorOrMainColor: TBGRAPixel;
1572 var i: integer;
1573 maxWeight: UInt32;
1574 begin
1575 result := BGRAPixelTransparent;
1576 maxWeight:= 0;
1577 for i := 0 to high(FColors) do
1578 with FColors[i] do
1579 begin
1580 if Weight > maxWeight then
1581 begin
1582 maxWeight:= Weight;
1583 result := Color;
1584 end;
1585 end;
1586 if maxWeight <= 3*FTotalWeight shr 2 then
1587 result := GetAverageColor;
1588 end;
1589
TBGRAColorBox.GetBoundsnull1590 function TBGRAColorBox.GetBounds(ADimension: TColorDimension): TDimensionMinMax;
1591 begin
1592 result := FBounds[ADimension];
1593 end;
1594
GetColorCountnull1595 function TBGRAColorBox.GetColorCount(ACountPureTransparent: boolean): integer;
1596 begin
1597 result := length(FColors);
1598 if ACountPureTransparent and HasPureTransparentColor then inc(result);
1599 end;
1600
TBGRAColorBox.GetHasPureTransparentColornull1601 function TBGRAColorBox.GetHasPureTransparentColor: boolean;
1602 begin
1603 result := FPureTransparentColorCount > 0;
1604 end;
1605
TBGRAColorBox.GetInferiorColornull1606 function TBGRAColorBox.GetInferiorColor: TBGRAPixel;
1607 var
1608 n: integer;
1609 r, g, b, a: double;
1610 w: UInt32;
1611 cura: double;
1612 wantedWeight: UInt32;
1613 begin
1614 a := 0;
1615 r := 0;
1616 g := 0;
1617 b := 0;
1618 w := 0;
1619 wantedWeight:= FTotalWeight div 10;
1620 for n := 0 to high(FColors) do
1621 with FColors[n].Color do
1622 begin
1623 cura := (alpha / 255)*FColors[n].Weight;
1624 IncF(a, cura);
1625 IncF(r, red * cura);
1626 IncF(g, green * cura);
1627 IncF(b, blue * cura);
1628 Inc(w, FColors[n].Weight);
1629 if w >= wantedWeight then break;
1630 end;
1631 if w = 0 then
1632 Result := BGRAPixelTransparent
1633 else
1634 begin
1635 result.alpha := round(a*255/w);
1636 if result.alpha = 0 then result := BGRAPixelTransparent
1637 else
1638 begin
1639 result.red := round(r / a);
1640 result.green := round(g / a);
1641 result.blue := round(b / a);
1642 end;
1643 end;
1644 end;
1645
GetLargestApparentDimensionnull1646 function TBGRAColorBox.GetLargestApparentDimension: TColorDimension;
1647 var c: TColorDimension;
1648 curApparentInterval, maxApparentInterval: UInt32;
1649 begin
1650 c := succ(low(TColorDimension));
1651 result := c;
1652 maxApparentInterval:= ApparentInterval[c];
1653 while c < high(TColorDimension) do
1654 begin
1655 inc(c);
1656 curApparentInterval:= ApparentInterval[c];
1657 if curApparentInterval > maxApparentInterval then
1658 begin
1659 maxApparentInterval:= curApparentInterval;
1660 result := c;
1661 end;
1662 end;
1663 end;
1664
TBGRAColorBox.GetLargestApparentIntervalnull1665 function TBGRAColorBox.GetLargestApparentInterval: UInt32;
1666 var
1667 curApparentInterval: UInt32;
1668 c: TColorDimension;
1669 begin
1670 result:= ApparentInterval[succ(low(TColorDimension))];
1671 for c := succ(succ(low(TColorDimension))) to high(TColorDimension) do
1672 begin
1673 curApparentInterval:= ApparentInterval[c];
1674 if curApparentInterval > result then
1675 result := curApparentInterval;
1676 end;
1677 end;
1678
GetPointLikenull1679 function TBGRAColorBox.GetPointLike: boolean;
1680 var c: TColorDimension;
1681 begin
1682 for c := succ(low(TColorDimension)) to high(TColorDimension) do
1683 if not FBounds[c].PointLike then
1684 begin
1685 result := false;
1686 exit;
1687 end;
1688 result := true;
1689 end;
1690
GetSuperiorColornull1691 function TBGRAColorBox.GetSuperiorColor: TBGRAPixel;
1692 var
1693 n: integer;
1694 r, g, b, a: double;
1695 w: UInt32;
1696 cura: double;
1697 wantedWeight: UInt32;
1698 begin
1699 a := 0;
1700 r := 0;
1701 g := 0;
1702 b := 0;
1703 w := 0;
1704 wantedWeight:= FTotalWeight div 10;
1705 for n := high(FColors) downto 0 do
1706 with FColors[n].Color do
1707 begin
1708 cura := (alpha / 255)*FColors[n].Weight;
1709 IncF(a, cura);
1710 IncF(r, red * cura);
1711 IncF(g, green * cura);
1712 IncF(b, blue * cura);
1713 Inc(w, FColors[n].Weight);
1714 if w >= wantedWeight then break;
1715 end;
1716 if w = 0 then
1717 Result := BGRAPixelTransparent
1718 else
1719 begin
1720 result.alpha := round(a*255/w);
1721 if result.alpha = 0 then result := BGRAPixelTransparent
1722 else
1723 begin
1724 result.red := round(r / a);
1725 result.green := round(g / a);
1726 result.blue := round(b / a);
1727 end;
1728 end;
1729 end;
1730
1731 procedure TBGRAColorBox.Init(AColors: ArrayOfWeightedColor; AOwner: boolean);
1732 var
1733 i,idx: Int32or64;
1734 FirstColor: boolean;
1735 c: TColorDimension;
1736 begin
1737 FPureTransparentColorCount:= 0;
1738 FTotalWeight:= 0;
1739 for c := low(TColorDimension) to high(TColorDimension) do
1740 FBounds[c].SetAsPoint(0);
1741 FirstColor := True;
1742 if AOwner then
1743 FColors := AColors
1744 else
1745 SetLength(FColors, length(AColors));
1746 idx := 0;
1747 for i := 0 to high(AColors) do
1748 with AColors[i] do
1749 begin
1750 if Color.alpha > 0 then
1751 begin
1752 if FirstColor then
1753 begin
1754 for c := low(TColorDimension) to high(TColorDimension) do
1755 FBounds[c].SetAsPoint(GetDimensionValue(Color,c));
1756 FirstColor := false;
1757 end else
1758 begin
1759 for c := low(TColorDimension) to high(TColorDimension) do
1760 FBounds[c].GrowToInclude(GetDimensionValue(Color,c));
1761 end;
1762 inc(FTotalWeight, Weight);
1763 if not AOwner or (idx <> i) then
1764 FColors[idx] := AColors[i];
1765 inc(idx);
1766 end else
1767 inc(FPureTransparentColorCount, Weight);
1768 end;
1769 setlength(FColors,idx);
1770 end;
1771
1772 procedure TBGRAColorBox.SortBy(ADimension: TColorDimension);
1773 var comparer: TIsChannelStrictlyGreaterFunc;
1774 begin
1775 comparer := GetPixelStrictComparer(ADimension);
1776 if comparer = nil then exit;
1777 ArrayOfWeightedColor_QuickSort(FColors,0,high(FColors),comparer)
1778 end;
1779
TBGRAColorBox.GetMedianIndexnull1780 function TBGRAColorBox.GetMedianIndex(ADimension: TColorDimension;
1781 AMinValue, AMaxValue: UInt32
1782 ): integer;
1783 var i: integer;
1784 sum,goal: UInt32;
1785 valueComparer: TIsChannelGreaterThanOrEqualToValueFunc;
1786 strictComparer: TIsChannelStrictlyGreaterFunc;
1787 ofs: integer;
1788 begin
1789 if length(FColors) = 1 then
1790 begin
1791 result := 0;
1792 exit;
1793 end else
1794 if length(FColors) = 0 then
1795 begin
1796 result := -1;
1797 exit;
1798 end;
1799 valueComparer:= GetPixelValueComparer(ADimension);
1800 sum := 0;
1801 goal := (FTotalWeight+1) shr 1;
1802 result := high(FColors) shr 1;
1803 for i := 0 to high(FColors) do
1804 begin
1805 inc(sum, FColors[i].Weight);
1806 if (sum>=goal) and (valueComparer(@FColors[i].Color, AMinValue)) then
1807 begin
1808 result := i;
1809 while (result > 0) and (valueComparer(@FColors[result].Color, AMaxValue+1)) do dec(result);
1810 break;
1811 end;
1812 end;
1813 if result = 0 then inc(result);
1814 //check that there it is not splitting consecutive colors with the same value
1815 strictComparer := GetPixelStrictComparer(ADimension);
1816 ofs := 0;
1817 while true do
1818 begin
1819 if (result-ofs < 1) and (result+ofs > high(FColors)) then break;
1820 if (result-ofs >= 1) and strictComparer(@FColors[result-ofs].Color,@FColors[result-ofs-1].Color) then
1821 begin
1822 result := result-ofs;
1823 exit;
1824 end;
1825 if (result+ofs <= high(FColors)) and strictComparer(@FColors[result+ofs].Color,@FColors[result+ofs-1].Color) then
1826 begin
1827 result := result+ofs;
1828 exit;
1829 end;
1830 inc(ofs);
1831 end;
1832 end;
1833
1834 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions; AColors: ArrayOfWeightedColor; AOwner: boolean);
1835 begin
1836 FDimensions:= ADimensions;
1837 Init(AColors,AOwner);
1838 end;
1839
1840 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions;
1841 const AColors: ArrayOfTBGRAPixel; AAlpha: TAlphaChannelPaletteOption = acFullChannelInPalette);
1842 var weightedColors: ArrayOfWeightedColor;
1843 i: Integer;
1844 begin
1845 if AAlpha = acFullChannelInPalette then
1846 begin
1847 FDimensions:= ADimensions;
1848 setlength(weightedColors, length(AColors));
1849 for i := 0 to high(weightedColors) do
1850 with weightedColors[i] do
1851 begin
1852 color := AColors[i];
1853 Weight:= 1;
1854 end;
1855 Init(weightedColors,True);
1856 end else
1857 Create(ADimensions, @AColors[0], length(AColors), AAlpha);
1858 end;
1859
1860 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions; ABounds: TColorBoxBounds);
1861 begin
1862 FDimensions:= ADimensions;
1863 FBounds := ABounds;
1864 FTotalWeight:= 0;
1865 FPureTransparentColorCount:= 0;
1866 end;
1867
1868 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions; APalette: TBGRACustomPalette);
1869 begin
1870 FDimensions:= ADimensions;
1871 Init(APalette.GetAsArrayOfWeightedColor,False);
1872 end;
1873
1874 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions;
1875 ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption);
1876 begin
1877 Create(ADimensions, ABitmap.Data, ABitmap.NbPixels, AAlpha);
1878 end;
1879
1880 constructor TBGRAColorBox.Create(ADimensions: TColorDimensions; AColors: PBGRAPixel; ANbPixels: integer; AAlpha: TAlphaChannelPaletteOption);
1881 var i,j,prev,idx: integer;
1882 p: PBGRAPixel;
1883 skip: boolean;
1884 alphaMask: LongWord;
1885 transpIndex: integer;
1886 begin
1887 if AAlpha <> acFullChannelInPalette then
1888 alphaMask := LEtoN($FF000000)
1889 else
1890 alphaMask := 0;
1891 FDimensions:= ADimensions;
1892 transpIndex := -1;
1893 SetLength(FColors,ANbPixels);
1894 if length(FColors)>0 then
1895 begin
1896 p := AColors;
1897 idx := 0;
1898 for i := 0 to ANbPixels-1 do
1899 begin
1900 if (p^.alpha = 0) or ((AAlpha = acTransparentEntry) and (p^.alpha < 128)) then
1901 begin
1902 skip := true;
1903 if not (AAlpha = acIgnore) then
1904 begin
1905 if (transpIndex=-1) then
1906 begin
1907 transpIndex := idx;
1908 with FColors[idx] do
1909 begin
1910 Color := BGRAPixelTransparent;
1911 Weight:= 1;
1912 end;
1913 inc(idx);
1914 end else
1915 inc(FColors[transpIndex].Weight);
1916 end;
1917 if (p^.alpha = 0) then
1918 begin
1919 inc(p);
1920 continue;
1921 end;
1922 end;
1923 skip := false;
1924 for j := idx-1 downto idx-10 do
1925 if j < 0 then
1926 break
1927 else
1928 with FColors[j] do
1929 if LongWord(Color)=LongWord(p^) or alphaMask then
1930 begin
1931 skip := true;
1932 inc(Weight);
1933 break;
1934 end;
1935 if skip then
1936 begin
1937 inc(p);
1938 continue;
1939 end;
1940 with FColors[idx] do
1941 begin
1942 Color := p^;
1943 if AAlpha <> acFullChannelInPalette then Color.alpha := 255;
1944 Weight := 1;
1945 inc(p);
1946 inc(idx);
1947 end;
1948 end;
1949 setLength(FColors, idx);
1950
1951 ArrayOfWeightedColor_QuickSort(FColors,0,high(FColors),@IsDWordGreater);
1952 prev := 0;
1953 for i := 1 to high(FColors) do
1954 begin
1955 if LongWord(FColors[i].Color)=LongWord(FColors[prev].Color) then
1956 inc(FColors[prev].Weight, FColors[i].Weight)
1957 else
1958 begin
1959 inc(prev);
1960 if i <> prev then
1961 FColors[prev] := FColors[i];
1962 end;
1963 end;
1964 setlength(FColors, prev+1);
1965 end;
1966 Init(FColors,True);
1967 end;
1968
TBGRAColorBox.BoundsContainnull1969 function TBGRAColorBox.BoundsContain(AColor: TBGRAPixel): boolean;
1970 var c: TColorDimension;
1971 begin
1972 for c := succ(low(TColorDimension)) to high(TColorDimension) do
1973 if not FBounds[c].Contains(GetDimensionValue(AColor,c)) then
1974 begin
1975 result := false;
1976 exit;
1977 end;
1978 result := true;
1979 end;
1980
TBGRAColorBox.MedianCutnull1981 function TBGRAColorBox.MedianCut(ADimension: TColorDimension; out SuperiorMiddle: UInt32
1982 ): TBGRAColorBox;
1983 var idxSplit: Int32or64;
1984 secondArray: ArrayOfWeightedColor;
1985 i: Int32or64;
1986 begin
1987 result := nil;
1988 SuperiorMiddle := 0;
1989 if FBounds[ADimension].PointLike then exit;
1990 if length(FColors) <= 1 then exit;
1991 SortBy(ADimension);
1992 idxSplit := GetMedianIndex(ADimension,
1993 round(FBounds[ADimension].Minimum*(1-MedianMinPercentage)+FBounds[ADimension].Maximum*MedianMinPercentage),
1994 round(FBounds[ADimension].Minimum*MedianMinPercentage+FBounds[ADimension].Maximum*(1-MedianMinPercentage)));
1995 if idxSplit = -1 then exit;
1996 setlength(secondArray, length(FColors)-idxSplit);
1997 for i := idxSplit to high(FColors) do
1998 secondArray[i-idxSplit] := FColors[i];
1999 result := TBGRAColorBox.Create(FDimensions, secondArray,True);
2000 setlength(FColors, idxSplit);
2001 Init(FColors,True);
2002 SuperiorMiddle := (FBounds[ADimension].Maximum + result.FBounds[ADimension].Minimum + 1) shr 1;
2003 end;
2004
Duplicatenull2005 function TBGRAColorBox.Duplicate: TBGRAColorBox;
2006 var
2007 i: Int32or64;
2008 begin
2009 result := TBGRAColorBox.Create(FDimensions, FBounds);
2010 result.FTotalWeight := FTotalWeight;
2011 setlength(result.FColors, length(FColors));
2012 for i := 0 to high(FColors) do
2013 result.FColors[i] := FColors[i];
2014 end;
2015
GetAsArrayOfColorsnull2016 function TBGRAColorBox.GetAsArrayOfColors(AIncludePureTransparent: boolean): ArrayOfTBGRAPixel;
2017 var i,idx: integer;
2018 begin
2019 if AIncludePureTransparent and HasPureTransparentColor then
2020 begin
2021 setlength(result, length(FColors)+1);
2022 result[0] := BGRAPixelTransparent;
2023 idx := 1;
2024 end else
2025 begin
2026 setlength(result, length(FColors));
2027 idx := 0;
2028 end;
2029 for i:= 0 to high(FColors) do
2030 begin
2031 result[idx] := FColors[i].Color;
2032 inc(idx);
2033 end;
2034 end;
2035
2036 end.
2037
2038