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