1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAPalette;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 BGRAClasses, SysUtils, Avl_Tree, BGRABitmapTypes, FPimage;
10
11 const
12 MaxLastAddedColors = 10;
13
14 type
15 TBGRAPaletteFormat = integer;
16
17 const
18 palUnknown : TBGRAPaletteFormat = 0;
19 palPaintDotNet : TBGRAPaletteFormat = 1;
20 palGimp : TBGRAPaletteFormat = 2;
21 palAdobeSwatchExchange : TBGRAPaletteFormat = 3;
22 palKOffice : TBGRAPaletteFormat = 4;
23 palJascPSP : TBGRAPaletteFormat = 5;
24 palCustom : TBGRAPaletteFormat = 100;
25
26 type
27 TBGRAIndexedPaletteEntry = packed record
28 Color: TBGRAPixel;
29 Index: UInt32;
30 end;
31 PBGRAIndexedPaletteEntry = ^TBGRAIndexedPaletteEntry;
32 TBGRAWeightedPaletteEntry = packed record
33 Color: TBGRAPixel;
34 Weight: UInt32;
35 end;
36 PBGRAWeightedPaletteEntry = ^TBGRAWeightedPaletteEntry;
37 ArrayOfWeightedColor = array of TBGRAWeightedPaletteEntry;
38
39 TBGRAPixelComparer = function (p1,p2 : PBGRAPixel): boolean;
40
41 { TBGRACustomPalette }
42
43 TBGRACustomPalette = class
44 private
GetDominantColornull45 function GetDominantColor: TBGRAPixel;
46 protected
GetCountnull47 function GetCount: integer; virtual; abstract;
GetColorByIndexnull48 function GetColorByIndex(AIndex: integer): TBGRAPixel; virtual; abstract;
49 public
ContainsColornull50 function ContainsColor(AValue: TBGRAPixel): boolean; virtual; abstract;
IndexOfColornull51 function IndexOfColor(AValue: TBGRAPixel): integer; virtual; abstract;
GetAsArrayOfColornull52 function GetAsArrayOfColor: ArrayOfTBGRAPixel; virtual; abstract;
GetAsArrayOfWeightedColornull53 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; virtual; abstract;
54 procedure AssignTo(AImage: TFPCustomImage); overload;
55 procedure AssignTo(APalette: TFPPalette); overload;
56 property DominantColor: TBGRAPixel read GetDominantColor;
57 property Count: integer read GetCount;
58 property Color[AIndex: integer]: TBGRAPixel read GetColorByIndex;
59 end;
60
61 type
62 { TBGRAAvgLvlPalette }
63
64 TBGRAAvgLvlPalette = class(TBGRACustomPalette)
65 protected
66 FTree: TAVLTree;
67 FArray: array of PBGRAPixel;
68 FLastAddedColors: packed array[0..MaxLastAddedColors-1] of PBGRAPixel;
69 FLastAddedColorCount: integer;
GetCountnull70 function GetCount: integer; override;
GetColorByIndexnull71 function GetColorByIndex(AIndex: integer): TBGRAPixel; override;
72 procedure FreeEntry(AEntry: PBGRAPixel); virtual; abstract;
73 procedure NeedArray; virtual;
74 procedure ClearArray; virtual;
75 procedure AddLastColor(AColor: PBGRAPixel);
GetLastColornull76 function GetLastColor(AValue: TBGRAPixel): PBGRAPixel;
77 procedure ClearLastColors;
78 public
79 constructor Create; overload;
ContainsColornull80 function ContainsColor(AValue: TBGRAPixel): boolean; override;
IndexOfColornull81 function IndexOfColor(AValue: TBGRAPixel): integer; override;
82 procedure Clear; virtual;
83 destructor Destroy; override;
GetAsArrayOfColornull84 function GetAsArrayOfColor: ArrayOfTBGRAPixel; override;
GetAsArrayOfWeightedColornull85 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; override;
86 end;
87
88 { TBGRAPalette }
89
90 TBGRAPalette = class(TBGRAAvgLvlPalette)
91 protected
CreateEntrynull92 function CreateEntry(AColor: TBGRAPixel): PBGRAPixel; virtual;
93 procedure FreeEntry(AEntry: PBGRAPixel); override;
94 procedure IncludePixel(PPixel: PBGRAPixel); virtual;
95 procedure ExceptionUnknownPaletteFormat;
96 procedure ExceptionInvalidPaletteFormat;
97 public
98 constructor Create(ABitmap: TBGRACustomBitmap); overload; virtual;
99 constructor Create(APalette: TBGRACustomPalette); overload; virtual;
100 constructor Create(AColors: ArrayOfTBGRAPixel); overload; virtual;
101 constructor Create(AColors: ArrayOfWeightedColor); overload; virtual;
AddColornull102 function AddColor(AValue: TBGRAPixel): boolean; virtual;
103 procedure AddColors(ABitmap: TBGRACustomBitmap); overload; virtual;
104 procedure AddColors(APalette: TBGRACustomPalette); overload; virtual;
RemoveColornull105 function RemoveColor(AValue: TBGRAPixel): boolean; virtual;
106 procedure LoadFromFile(AFilenameUTF8: string); virtual;
107 procedure LoadFromStream(AStream: TStream; AFormat: TBGRAPaletteFormat); virtual;
108 procedure LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat);
109 procedure SaveToFile(AFilenameUTF8: string); virtual;
110 procedure SaveToStream(AStream: TStream; AFormat: TBGRAPaletteFormat); virtual;
DetectPaletteFormatnull111 function DetectPaletteFormat(AStream: TStream): TBGRAPaletteFormat; overload; virtual;
DetectPaletteFormatnull112 function DetectPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat; overload;
SuggestPaletteFormatnull113 function SuggestPaletteFormat(AFilenameUTF8: string): TBGRAPaletteFormat; virtual;
114 end;
115
116 { TBGRAIndexedPalette }
117
118 TBGRAIndexedPalette = class(TBGRAPalette)
119 private
120 FCurrentIndex: UInt32;
121 protected
122 procedure NeedArray; override;
CreateEntrynull123 function CreateEntry(AColor: TBGRAPixel): PBGRAPixel; override;
124 procedure FreeEntry(AEntry: PBGRAPixel); override;
125 public
RemoveColornull126 function RemoveColor({%H-}AValue: TBGRAPixel): boolean; override;
IndexOfColornull127 function IndexOfColor(AValue: TBGRAPixel): integer; override;
128 procedure Clear; override;
129 end;
130
131 { TBGRAWeightedPalette }
132
133 TBGRAWeightedPalette = class(TBGRAPalette)
134 private
135 protected
CreateEntrynull136 function CreateEntry(AColor: TBGRAPixel): PBGRAPixel; override;
137 procedure FreeEntry(AEntry: PBGRAPixel); override;
GetWeightByIndexnull138 function GetWeightByIndex(AIndex: Integer): UInt32; virtual;
139 procedure IncludePixel(PPixel: PBGRAPixel); override;
140 public
141 constructor Create(AColors: ArrayOfWeightedColor); override;
GetAsArrayOfWeightedColornull142 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; override;
IncColornull143 function IncColor(AValue: TBGRAPixel; out NewWeight: UInt32): boolean;
DecColornull144 function DecColor(AValue: TBGRAPixel; out NewWeight: UInt32): boolean;
145 property Weight[AIndex: Integer]: UInt32 read GetWeightByIndex;
146 end;
147
148 { TBGRAReferencePalette }
149
150 TBGRAReferencePalette = class(TBGRAAvgLvlPalette)
151 protected
152 procedure FreeEntry({%H-}AEntry: PBGRAPixel); override;
153 public
AddColornull154 function AddColor(AValue: PBGRAPixel): boolean;
RemoveColornull155 function RemoveColor(AValue: PBGRAPixel): boolean;
156 end;
157
158 { TBGRACustomApproxPalette }
159
160 TBGRACustomApproxPalette = class(TBGRACustomPalette)
161 private
FindNearestColorIgnoreAlphanull162 function FindNearestColorIgnoreAlpha(AValue: TBGRAPixel): TBGRAPixel; inline;
FindNearestColorIndexIgnoreAlphanull163 function FindNearestColorIndexIgnoreAlpha(AValue: TBGRAPixel): integer; inline;
164 protected
GetWeightByIndexnull165 function GetWeightByIndex({%H-}AIndex: Integer): UInt32; virtual;
166 public
FindNearestColornull167 function FindNearestColor(AValue: TBGRAPixel; AIgnoreAlpha: boolean): TBGRAPixel; overload;
FindNearestColornull168 function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; overload; virtual; abstract;
FindNearestColorIndexnull169 function FindNearestColorIndex(AValue: TBGRAPixel; AIgnoreAlpha: boolean): integer; overload;
FindNearestColorIndexnull170 function FindNearestColorIndex(AValue: TBGRAPixel): integer; overload; virtual; abstract;
171 property Weight[AIndex: Integer]: UInt32 read GetWeightByIndex;
172 end;
173
174 { TBGRA16BitPalette }
175
176 TBGRA16BitPalette = class(TBGRACustomApproxPalette)
177 protected
GetCountnull178 function GetCount: integer; override;
GetColorByIndexnull179 function GetColorByIndex(AIndex: integer): TBGRAPixel; override;
180 public
ContainsColornull181 function ContainsColor(AValue: TBGRAPixel): boolean; override;
IndexOfColornull182 function IndexOfColor(AValue: TBGRAPixel): integer; override;
GetAsArrayOfColornull183 function GetAsArrayOfColor: ArrayOfTBGRAPixel; override;
GetAsArrayOfWeightedColornull184 function GetAsArrayOfWeightedColor: ArrayOfWeightedColor; override;
FindNearestColornull185 function FindNearestColor(AValue: TBGRAPixel): TBGRAPixel; override;
FindNearestColorIndexnull186 function FindNearestColorIndex(AValue: TBGRAPixel): integer; override;
187 end;
188
189 { TBGRACustomColorQuantizer }
190
191 TBGRACustomColorQuantizer = class
192 protected
GetDominantColornull193 function GetDominantColor: TBGRAPixel; virtual;
GetPalettenull194 function GetPalette: TBGRACustomApproxPalette; virtual; abstract;
GetSourceColornull195 function GetSourceColor(AIndex: integer): TBGRAPixel; virtual; abstract;
GetSourceColorCountnull196 function GetSourceColorCount: Integer; virtual; abstract;
GetReductionColorCountnull197 function GetReductionColorCount: integer; virtual; abstract;
198 procedure SetReductionColorCount(AValue: Integer); virtual; abstract;
199 public
200 constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean); overload; virtual; abstract;
201 constructor Create(AColors: array of TBGRAPixel; ASeparateAlphaChannel: boolean); overload;
202 constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption); overload; virtual; abstract;
203 constructor Create(APalette: TBGRACustomPalette; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); overload; virtual; abstract;
204 constructor Create(AColors: array of TBGRAPixel; ASeparateAlphaChannel: boolean; AReductionColorCount: integer); overload;
205 constructor Create(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption; AReductionColorCount: integer); overload; virtual; abstract;
206 procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect); overload; virtual; abstract;
207 procedure ApplyDitheringInplace(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap); overload;
GetDitheredBitmapnull208 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; ABounds: TRect): TBGRACustomBitmap; overload; virtual; abstract;
GetDitheredBitmapnull209 function GetDitheredBitmap(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): TBGRACustomBitmap; overload;
210 procedure SaveBitmapToFile(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; AFilenameUTF8: string); overload;
211 procedure SaveBitmapToFile(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; AFilenameUTF8: string; AFormat: TBGRAImageFormat); overload;
212 procedure SaveBitmapToStream(AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; AStream: TStream; AFormat: TBGRAImageFormat); virtual; abstract;
GetDitheredBitmapIndexedDatanull213 function GetDitheredBitmapIndexedData(ABitDepth: integer; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload;
GetDitheredBitmapIndexedDatanull214 function GetDitheredBitmapIndexedData(ABitDepth: integer; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap): Pointer; overload;
GetDitheredBitmapIndexedDatanull215 function GetDitheredBitmapIndexedData(ABitDepth: integer; AByteOrder: TRawImageByteOrder; AAlgorithm: TDitheringAlgorithm;
216 ABitmap: TBGRACustomBitmap; out AScanlineSize: PtrInt): Pointer; overload; virtual; abstract;
217 property SourceColorCount: Integer read GetSourceColorCount;
218 property SourceColor[AIndex: integer]: TBGRAPixel read GetSourceColor;
219 property ReductionColorCount: Integer read GetReductionColorCount write SetReductionColorCount;
220 property ReducedPalette: TBGRACustomApproxPalette read GetPalette;
221 property DominantColor: TBGRAPixel read GetDominantColor;
222 end;
223
224 TBGRAColorQuantizerAny = class of TBGRACustomColorQuantizer;
225
226 var
227 BGRAColorQuantizerFactory: TBGRAColorQuantizerAny;
228
BGRARequiredBitDepthnull229 function BGRARequiredBitDepth(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption): integer; overload;
BGRARequiredBitDepthnull230 function BGRARequiredBitDepth(APalette: TBGRACustomPalette): integer; overload;
231
232 type
Palettenull233 TPaletteReaderProc = function(APalette: TBGRAPalette; AStream: TStream): boolean;
234 TPaletteWriterProc = procedure(APalette: TBGRAPalette; AStream: TStream);
Buf256null235 TCheckPaletteFormatProc = function(ABuf256: string): boolean;
236
237 procedure BGRARegisterPaletteFormat(AFormatIndex: TBGRAPaletteFormat; AExtension: string; ADescription: string;
238 AReadProc: TPaletteReaderProc; AWriteProc: TPaletteWriterProc; ACheckFormatProc: TCheckPaletteFormatProc);
BGRARegisteredPaletteFormatFilternull239 function BGRARegisteredPaletteFormatFilter(AAllSupportedDescription: string) : string;
240
241 procedure ArrayOfWeightedColor_QuickSort(AColors: ArrayOfWeightedColor; AMinIndex,
242 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
243
244 procedure ArrayOfWeightedColor_InsertionSort(AColors: ArrayOfWeightedColor; AMinIndex,
245 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
246
247 procedure ArrayOfTBGRAPixel_QuickSort(AColors: ArrayOfTBGRAPixel; AMinIndex,
248 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
249
250 procedure ArrayOfTBGRAPixel_InsertionSort(AColors: ArrayOfTBGRAPixel; AMinIndex,
251 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
252
253 implementation
254
255 uses BGRAUTF8, bufstream;
256
IsDWordGreaternull257 function IsDWordGreater(p1, p2: PBGRAPixel): boolean;
258 begin
259 result := LongWord(p1^) > LongWord(p2^);
260 end;
261
262 const
263 InsertionSortLimit = 10;
264
265 procedure ArrayOfWeightedColor_InsertionSort(AColors: ArrayOfWeightedColor; AMinIndex,
266 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
267 var i,j,insertPos: Int32or64;
268 compared: TBGRAWeightedPaletteEntry;
269 begin
270 if AComparer = nil then AComparer := @IsDWordGreater;
271 for i := AMinIndex+1 to AMaxIndex do
272 begin
273 insertPos := i;
274 compared := AColors[i];
275 while (insertPos > AMinIndex) and AComparer(@AColors[insertPos-1].Color,@compared.Color) do
276 dec(insertPos);
277 if insertPos <> i then
278 begin
279 for j := i downto insertPos+1 do
280 AColors[j] := AColors[j-1];
281 AColors[insertPos] := compared;
282 end;
283 end;
284 end;
285
286 procedure ArrayOfWeightedColor_QuickSort(AColors: ArrayOfWeightedColor; AMinIndex,
287 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
288 var Pivot: TBGRAPixel;
289 CurMin,CurMax,i : Int32or64;
290
291 procedure Swap(a,b: Int32or64);
292 var Temp: TBGRAWeightedPaletteEntry;
293 begin
294 if a = b then exit;
295 Temp := AColors[a];
296 AColors[a] := AColors[b];
297 AColors[b] := Temp;
298 end;
299 begin
300 if AComparer = nil then AComparer := @IsDWordGreater;
301 if AMaxIndex-AMinIndex+1 <= InsertionSortLimit then
302 begin
303 ArrayOfWeightedColor_InsertionSort(AColors,AMinIndex,AMaxIndex,AComparer);
304 exit;
305 end;
306 Pivot := AColors[(AMinIndex+AMaxIndex) shr 1].Color;
307 CurMin := AMinIndex;
308 CurMax := AMaxIndex;
309 i := CurMin;
310 while i < CurMax do
311 begin
312 if AComparer(@AColors[i].Color, @Pivot) then
313 begin
314 Swap(i, CurMax);
315 dec(CurMax);
316 end else
317 begin
318 if AComparer(@Pivot, @AColors[i].Color) then
319 begin
320 Swap(i, CurMin);
321 inc(CurMin);
322 end;
323 inc(i);
324 end;
325 end;
326 if AComparer(@Pivot, @AColors[i].Color) then
327 begin
328 Swap(i, CurMin);
329 inc(CurMin);
330 end;
331 if CurMin > AMinIndex then ArrayOfWeightedColor_QuickSort(AColors,AMinIndex,CurMin,AComparer);
332 if CurMax < AMaxIndex then ArrayOfWeightedColor_QuickSort(AColors,CurMax,AMaxIndex,AComparer);
333 end;
334
335 procedure ArrayOfTBGRAPixel_InsertionSort(AColors: ArrayOfTBGRAPixel; AMinIndex,
336 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
337 var i,j,insertPos: Int32or64;
338 compared: TBGRAPixel;
339 begin
340 if AComparer = nil then AComparer := @IsDWordGreater;
341 for i := AMinIndex+1 to AMaxIndex do
342 begin
343 insertPos := i;
344 compared := AColors[i];
345 while (insertPos > AMinIndex) and AComparer(@AColors[insertPos-1],@compared) do
346 dec(insertPos);
347 if insertPos <> i then
348 begin
349 for j := i downto insertPos+1 do
350 AColors[j] := AColors[j-1];
351 AColors[insertPos] := compared;
352 end;
353 end;
354 end;
355
356 procedure ArrayOfTBGRAPixel_QuickSort(AColors: ArrayOfTBGRAPixel; AMinIndex,
357 AMaxIndex: Int32or64; AComparer: TBGRAPixelComparer = nil);
358 var Pivot: TBGRAPixel;
359 CurMin,CurMax,i : Int32or64;
360
361 procedure Swap(a,b: Int32or64);
362 var Temp: TBGRAPixel;
363 begin
364 if a = b then exit;
365 Temp := AColors[a];
366 AColors[a] := AColors[b];
367 AColors[b] := Temp;
368 end;
369 begin
370 if AComparer = nil then AComparer := @IsDWordGreater;
371 if AMaxIndex-AMinIndex+1 <= InsertionSortLimit then
372 begin
373 ArrayOfTBGRAPixel_InsertionSort(AColors,AMinIndex,AMaxIndex,AComparer);
374 exit;
375 end;
376 Pivot := AColors[(AMinIndex+AMaxIndex) shr 1];
377 CurMin := AMinIndex;
378 CurMax := AMaxIndex;
379 i := CurMin;
380 while i < CurMax do
381 begin
382 if AComparer(@AColors[i], @Pivot) then
383 begin
384 Swap(i, CurMax);
385 dec(CurMax);
386 end else
387 begin
388 if AComparer(@Pivot, @AColors[i]) then
389 begin
390 Swap(i, CurMin);
391 inc(CurMin);
392 end;
393 inc(i);
394 end;
395 end;
396 if AComparer(@Pivot, @AColors[i]) then
397 begin
398 Swap(i, CurMin);
399 inc(CurMin);
400 end;
401 if CurMin > AMinIndex then ArrayOfTBGRAPixel_QuickSort(AColors,AMinIndex,CurMin,AComparer);
402 if CurMax < AMaxIndex then ArrayOfTBGRAPixel_QuickSort(AColors,CurMax,AMaxIndex,AComparer);
403 end;
404
405 {$i paletteformats.inc}
406
BGRARequiredBitDepthnull407 function BGRARequiredBitDepth(ABitmap: TBGRACustomBitmap; AAlpha: TAlphaChannelPaletteOption): integer;
408 var
409 palette: TBGRAPalette;
410 p: PBGRAPixel;
411 i: Int32or64;
412 transparentEntry: boolean;
413 begin
414 palette := TBGRAPalette.Create;
415 p := ABitmap.Data;
416 transparentEntry := false;
417 if AAlpha = acIgnore then
418 begin
419 for i := ABitmap.NbPixels-1 downto 0 do
420 begin
421 palette.AddColor(BGRA(p^.red,p^.green,p^.blue));
422 inc(p);
423 if palette.Count > 256 then break;
424 end;
425 end else
426 if AAlpha = acTransparentEntry then
427 begin
428 for i := ABitmap.NbPixels-1 downto 0 do
429 begin
430 if p^.alpha < 128 then
431 transparentEntry:= true
432 else
433 palette.AddColor(BGRA(p^.red,p^.green,p^.blue));
434 inc(p);
435 if palette.Count > 256 then break;
436 end;
437 end else
438 begin
439 for i := ABitmap.NbPixels-1 downto 0 do
440 begin
441 palette.AddColor(p^);
442 inc(p);
443 if palette.Count > 256 then break;
444 end;
445 end;
446
447 if palette.Count+byte(transparentEntry) > 256 then
448 begin
449 if (AAlpha = acFullChannelInPalette) and ABitmap.HasTransparentPixels then
450 result := 32
451 else
452 if (AAlpha = acTransparentEntry) and ABitmap.HasTransparentPixels then
453 result := 25
454 else
455 result := 24;
456 end else
457 begin
458 result := 8;
459 while (result > 0) and (1 shl (result shr 1) >= palette.Count) do result := result shr 1;
460 end;
461 palette.Free;
462 end;
463
BGRARequiredBitDepthnull464 function BGRARequiredBitDepth(APalette: TBGRACustomPalette): integer;
465 var i: integer;
466 hasTransp: boolean;
467 begin
468 if APalette.Count > 256 then
469 begin
470 hasTransp := false;
471 for i := 0 to APalette.Count-1 do
472 if APalette.Color[i].alpha <> 255 then
473 begin
474 hasTransp:= true;
475 break;
476 end;
477 if hasTransp then
478 result := 32
479 else
480 result := 24;
481 end else
482 begin
483 result := 8;
484 while (result > 0) and (1 shl (result shr 1) >= APalette.Count) do result := result shr 1;
485 end;
486 end;
487
488 { TBGRA16BitPalette }
489
TBGRA16BitPalette.GetCountnull490 function TBGRA16BitPalette.GetCount: integer;
491 begin
492 result := 65537;
493 end;
494
GetColorByIndexnull495 function TBGRA16BitPalette.GetColorByIndex(AIndex: integer): TBGRAPixel;
496 begin
497 if (AIndex >= 65536) or (AIndex < 0) then
498 result := BGRAPixelTransparent
499 else
500 result := Color16BitToBGRA(AIndex);
501 end;
502
ContainsColornull503 function TBGRA16BitPalette.ContainsColor(AValue: TBGRAPixel): boolean;
504 begin
505 if AValue.alpha = 0 then
506 result := true
507 else
508 result := (AValue.alpha = 255) and (FindNearestColor(AValue)=AValue);
509 end;
510
IndexOfColornull511 function TBGRA16BitPalette.IndexOfColor(AValue: TBGRAPixel): integer;
512 var idx: integer;
513 begin
514 if AValue.Alpha = 0 then
515 result := 65536
516 else
517 begin
518 idx := BGRAToColor16Bit(AValue);
519 if Color16BitToBGRA(idx)=AValue then
520 result := idx
521 else
522 result := -1;
523 end;
524 end;
525
TBGRA16BitPalette.GetAsArrayOfColornull526 function TBGRA16BitPalette.GetAsArrayOfColor: ArrayOfTBGRAPixel;
527 begin
528 result := nil;
529 raise exception.Create('Palette too big');
530 end;
531
GetAsArrayOfWeightedColornull532 function TBGRA16BitPalette.GetAsArrayOfWeightedColor: ArrayOfWeightedColor;
533 begin
534 result := nil;
535 raise exception.Create('Palette too big');
536 end;
537
FindNearestColornull538 function TBGRA16BitPalette.FindNearestColor(AValue: TBGRAPixel): TBGRAPixel;
539 begin
540 if AValue.alpha = 0 then result := BGRAPixelTransparent
541 else
542 result := GetColorByIndex(BGRAToColor16Bit(AValue));
543 end;
544
TBGRA16BitPalette.FindNearestColorIndexnull545 function TBGRA16BitPalette.FindNearestColorIndex(AValue: TBGRAPixel): integer;
546 begin
547 result := BGRAToColor16Bit(AValue);
548 end;
549
550 { TBGRAIndexedPalette }
551
552 procedure TBGRAIndexedPalette.NeedArray;
553 var Node: TAVLTreeNode;
554 n: UInt32;
555 begin
556 n := Count;
557 if UInt32(length(FArray)) <> n then
558 begin
559 setLength(FArray,n);
560 for Node in FTree do
561 with PBGRAIndexedPaletteEntry(Node.Data)^ do
562 begin
563 if Index < n then //index is unsigned so always >= 0
564 FArray[Index] := @Color;
565 end;
566 end;
567 end;
568
TBGRAIndexedPalette.CreateEntrynull569 function TBGRAIndexedPalette.CreateEntry(AColor: TBGRAPixel): PBGRAPixel;
570 begin
571 result := PBGRAPixel(GetMem(sizeOf(TBGRAIndexedPaletteEntry)));
572 result^ := AColor;
573 PBGRAIndexedPaletteEntry(result)^.Index := FCurrentIndex;
574 Inc(FCurrentIndex);
575 end;
576
577 procedure TBGRAIndexedPalette.FreeEntry(AEntry: PBGRAPixel);
578 begin
579 FreeMem(AEntry);
580 end;
581
RemoveColornull582 function TBGRAIndexedPalette.RemoveColor(AValue: TBGRAPixel): boolean;
583 begin
584 Result:= false;
585 raise exception.Create('It is not possible to remove a color from an indexed palette');
586 end;
587
IndexOfColornull588 function TBGRAIndexedPalette.IndexOfColor(AValue: TBGRAPixel): integer;
589 Var Node: TAVLTreeNode;
590 begin
591 Node := FTree.Find(@AValue);
592 if Assigned(Node) then
593 result := PBGRAIndexedPaletteEntry(Node.Data)^.Index
594 else
595 result := -1;
596 end;
597
598 procedure TBGRAIndexedPalette.Clear;
599 begin
600 inherited Clear;
601 FCurrentIndex := 0;
602 end;
603
604 { TBGRACustomColorQuantizer }
605
GetDominantColornull606 function TBGRACustomColorQuantizer.GetDominantColor: TBGRAPixel;
607 begin
608 result := ReducedPalette.DominantColor;
609 end;
610
611 constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel;
612 ASeparateAlphaChannel: boolean);
613 var palette: TBGRAPalette;
614 i: Integer;
615 begin
616 palette := TBGRAPalette.Create;
617 for i := 0 to high(AColors) do
618 palette.AddColor(AColors[i]);
619 Create(palette, ASeparateAlphaChannel);
620 palette.Free;
621 end;
622
623 constructor TBGRACustomColorQuantizer.Create(AColors: array of TBGRAPixel;
624 ASeparateAlphaChannel: boolean; AReductionColorCount: integer);
625 var palette: TBGRAPalette;
626 i: Integer;
627 begin
628 palette := TBGRAPalette.Create;
629 for i := 0 to high(AColors) do
630 palette.AddColor(AColors[i]);
631 Create(palette, ASeparateAlphaChannel, AReductionColorCount);
632 palette.Free;
633 end;
634
635 procedure TBGRACustomColorQuantizer.ApplyDitheringInplace(
636 AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap);
637 begin
638 ApplyDitheringInplace(AAlgorithm, ABitmap, rect(0,0,ABitmap.Width,ABitmap.Height));
639 end;
640
GetDitheredBitmapnull641 function TBGRACustomColorQuantizer.GetDitheredBitmap(
642 AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap
643 ): TBGRACustomBitmap;
644 begin
645 result := GetDitheredBitmap(AAlgorithm, ABitmap, rect(0,0,ABitmap.Width,ABitmap.Height));
646 end;
647
648 procedure TBGRACustomColorQuantizer.SaveBitmapToFile(
649 AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
650 AFilenameUTF8: string);
651 begin
652 SaveBitmapToFile(AAlgorithm, ABitmap, AFilenameUTF8, SuggestImageFormat(AFilenameUTF8));
653 end;
654
655 procedure TBGRACustomColorQuantizer.SaveBitmapToFile(
656 AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
657 AFilenameUTF8: string; AFormat: TBGRAImageFormat);
658 var
659 stream: TFileStreamUTF8;
660 begin
661 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmCreate);
662 try
663 SaveBitmapToStream(AAlgorithm, ABitmap, stream, AFormat);
664 finally
665 stream.Free;
666 end;
667 end;
668
TBGRACustomColorQuantizer.GetDitheredBitmapIndexedDatanull669 function TBGRACustomColorQuantizer.GetDitheredBitmapIndexedData(
670 ABitDepth: integer; AAlgorithm: TDitheringAlgorithm; ABitmap: TBGRACustomBitmap;
671 out AScanlineSize: PtrInt): Pointer;
672 begin
673 result := GetDitheredBitmapIndexedData(ABitDepth,
674 {$IFDEF ENDIAN_LITTLE}riboLSBFirst{$ELSE}riboMSBFirst{$endif},
675 AAlgorithm, ABitmap, AScanlineSize);
676 end;
677
TBGRACustomColorQuantizer.GetDitheredBitmapIndexedDatanull678 function TBGRACustomColorQuantizer.GetDitheredBitmapIndexedData(
679 ABitDepth: integer; AAlgorithm: TDitheringAlgorithm;
680 ABitmap: TBGRACustomBitmap): Pointer;
681 var dummy: PtrInt;
682 begin
683 result := GetDitheredBitmapIndexedData(ABitDepth, AAlgorithm, ABitmap, dummy);
684 end;
685
686 { TBGRACustomPalette }
687
GetDominantColornull688 function TBGRACustomPalette.GetDominantColor: TBGRAPixel;
689 var
690 w: ArrayOfWeightedColor;
691 i: Integer;
692 maxWeight, totalWeight: UInt32;
693 begin
694 result := BGRAWhite;
695 maxWeight := 0;
696 w := GetAsArrayOfWeightedColor;
697 totalWeight:= 0;
698 for i := 0 to high(w) do
699 inc(totalWeight, w[i].Weight);
700 for i := 0 to high(w) do
701 if (w[i].Weight > maxWeight) and (BGRAToGSBA(w[i].Color).saturation > 16000) then
702 begin
703 maxWeight:= w[i].Weight;
704 result := w[i].Color;
705 end;
706 if maxWeight > totalWeight div 20 then exit;
707 for i := 0 to high(w) do
708 if (w[i].Weight > maxWeight) and (BGRAToGSBA(w[i].Color).lightness < 56000) and (BGRAToGSBA(w[i].Color).lightness > 16000) then
709 begin
710 maxWeight:= w[i].Weight;
711 result := w[i].Color;
712 end;
713 if maxWeight > 0 then exit;
714 for i := 0 to high(w) do
715 if (w[i].Weight > maxWeight) then
716 begin
717 maxWeight:= w[i].Weight;
718 result := w[i].Color;
719 end;
720 end;
721
722 procedure TBGRACustomPalette.AssignTo(AImage: TFPCustomImage);
723 begin
724 AImage.UsePalette := true;
725 AssignTo(AImage.Palette);
726 end;
727
728 procedure TBGRACustomPalette.AssignTo(APalette: TFPPalette);
729 var i: integer;
730 begin
731 APalette.Clear;
732 APalette.Capacity := Count;
733 for i := 0 to Count-1 do
734 APalette.Color[i] := BGRAToFPColor(Color[i]);
735 end;
736
737 { TBGRACustomApproxPalette }
738
TBGRACustomApproxPalette.FindNearestColorIgnoreAlphanull739 function TBGRACustomApproxPalette.FindNearestColorIgnoreAlpha(AValue: TBGRAPixel): TBGRAPixel;
740 var saveAlpha: byte;
741 begin
742 if AValue.alpha = 0 then
743 result := BGRAPixelTransparent
744 else
745 begin
746 saveAlpha := AValue.alpha;
747 AValue.alpha := 255;
748 result := FindNearestColor(AValue);
749 result.alpha := saveAlpha;
750 end;
751 end;
752
TBGRACustomApproxPalette.FindNearestColorIndexIgnoreAlphanull753 function TBGRACustomApproxPalette.FindNearestColorIndexIgnoreAlpha(
754 AValue: TBGRAPixel): integer;
755 begin
756 if AValue.alpha = 0 then
757 result := -1
758 else
759 begin
760 AValue.alpha := 255;
761 result := FindNearestColorIndex(AValue);
762 end;
763 end;
764
GetWeightByIndexnull765 function TBGRACustomApproxPalette.GetWeightByIndex(AIndex: Integer): UInt32;
766 begin
767 result := 1;
768 end;
769
FindNearestColornull770 function TBGRACustomApproxPalette.FindNearestColor(AValue: TBGRAPixel; AIgnoreAlpha: boolean): TBGRAPixel;
771 begin
772 if AIgnoreAlpha then
773 result := FindNearestColorIgnoreAlpha(AValue)
774 else
775 result := FindNearestColor(AValue);
776 end;
777
TBGRACustomApproxPalette.FindNearestColorIndexnull778 function TBGRACustomApproxPalette.FindNearestColorIndex(AValue: TBGRAPixel;
779 AIgnoreAlpha: boolean): integer;
780 begin
781 if AIgnoreAlpha then
782 result := FindNearestColorIndexIgnoreAlpha(AValue)
783 else
784 result := FindNearestColorIndex(AValue);
785 end;
786
787 { TBGRAWeightedPalette }
788
GetWeightByIndexnull789 function TBGRAWeightedPalette.GetWeightByIndex(AIndex: Integer): UInt32;
790 begin
791 NeedArray;
792 if (AIndex >= 0) and (AIndex < length(FArray)) then
793 result := PBGRAWeightedPaletteEntry(FArray[AIndex])^.Weight
794 else
795 raise ERangeError.Create('Index out of bounds');
796 end;
797
798 procedure TBGRAWeightedPalette.IncludePixel(PPixel: PBGRAPixel);
799 var dummy: UInt32;
800 begin
801 IncColor(PPixel^,dummy);
802 end;
803
804 constructor TBGRAWeightedPalette.Create(AColors: ArrayOfWeightedColor);
805 var
806 i: Integer;
807 begin
808 inherited Create;
809 for i := 0 to high(AColors) do
810 with AColors[i] do IncColor(Color,Weight);
811 end;
812
TBGRAWeightedPalette.GetAsArrayOfWeightedColornull813 function TBGRAWeightedPalette.GetAsArrayOfWeightedColor: ArrayOfWeightedColor;
814 var
815 i: Int32or64;
816 begin
817 NeedArray;
818 setlength(result, length(FArray));
819 for i := 0 to high(result) do
820 result[i] := PBGRAWeightedPaletteEntry(FArray[i])^;
821 end;
822
TBGRAWeightedPalette.CreateEntrynull823 function TBGRAWeightedPalette.CreateEntry(AColor: TBGRAPixel): PBGRAPixel;
824 begin
825 result := PBGRAPixel(GetMem(sizeOf(TBGRAWeightedPaletteEntry)));
826 result^ := AColor;
827 PBGRAWeightedPaletteEntry(result)^.Weight := 1;
828 end;
829
830 procedure TBGRAWeightedPalette.FreeEntry(AEntry: PBGRAPixel);
831 begin
832 FreeMem(AEntry);
833 end;
834
IncColornull835 function TBGRAWeightedPalette.IncColor(AValue: TBGRAPixel; out NewWeight: UInt32
836 ): boolean;
837 Var Node: TAVLTreeNode;
838 Entry: PBGRAPixel;
839 begin
840 Entry := GetLastColor(AValue);
841 if Entry <> nil then
842 begin
843 NewWeight := PBGRAWeightedPaletteEntry(Entry)^.Weight+1;
844 PBGRAWeightedPaletteEntry(Entry)^.Weight := NewWeight;
845 result := false;
846 exit;
847 end;
848 Node := FTree.Find(@AValue);
849 if Assigned(Node) then
850 begin
851 Entry := PBGRAPixel(Node.Data);
852 NewWeight := PBGRAWeightedPaletteEntry(Entry)^.Weight+1;
853 PBGRAWeightedPaletteEntry(Entry)^.Weight := NewWeight;
854 AddLastColor(Entry);
855 result := false;
856 end
857 else
858 begin
859 Entry := CreateEntry(AValue);
860 FTree.Add(Entry);
861 ClearArray;
862 NewWeight := PBGRAWeightedPaletteEntry(Entry)^.Weight;
863 AddLastColor(Entry);
864 result := true;
865 end;
866 end;
867
DecColornull868 function TBGRAWeightedPalette.DecColor(AValue: TBGRAPixel; out NewWeight: UInt32
869 ): boolean;
870 var
871 Node : TAVLTreeNode;
872 Entry: PBGRAPixel;
873 begin
874 Node := FTree.Find(@AValue);
875 if Assigned(Node) then
876 begin
877 Entry := PBGRAPixel(Node.Data);
878 NewWeight := PBGRAWeightedPaletteEntry(Entry)^.Weight;
879 if NewWeight >= 2 then
880 begin
881 dec(NewWeight);
882 PBGRAWeightedPaletteEntry(Entry)^.Weight := NewWeight;
883 end
884 else
885 begin
886 NewWeight := 0;
887 FreeEntry(Entry);
888 FTree.Delete(Node);
889 ClearArray;
890 ClearLastColors;
891 end;
892 result := true;
893 end else
894 begin
895 result := false;
896 NewWeight := 0;
897 end;
898 end;
899
900 { TBGRAReferencePalette }
901
902 procedure TBGRAReferencePalette.FreeEntry(AEntry: PBGRAPixel);
903 begin
904 //nothing
905 end;
906
TBGRAReferencePalette.AddColornull907 function TBGRAReferencePalette.AddColor(AValue: PBGRAPixel): boolean;
908 begin
909 if Assigned(GetLastColor(AValue^)) then
910 begin
911 result := false;
912 exit;
913 end;
914 AddLastColor(AValue);
915 if Assigned(FTree.Find(AValue)) then
916 begin
917 result := false;
918 end
919 else
920 begin
921 result := true;
922 FTree.Add(AValue);
923 ClearArray;
924 end;
925 end;
926
RemoveColornull927 function TBGRAReferencePalette.RemoveColor(AValue: PBGRAPixel): boolean;
928 var
929 Node : TAVLTreeNode;
930 begin
931 Node := FTree.Find(AValue);
932 if Assigned(Node) then
933 begin
934 FTree.Delete(Node);
935 result := true;
936 ClearArray;
937 ClearLastColors;
938 end else
939 result := false;
940 end;
941
PaletteOnCompareItemsnull942 function PaletteOnCompareItems(Data1, Data2: Pointer): integer;
943 var gray1, gray2: UInt32or64;
944 c1, c2: TBGRAPixel;
945 begin
946 c1 := PBGRAPixel(Data1)^;
947 c2 := PBGRAPixel(Data2)^;
948 if c1.alpha < c2.alpha then
949 result := -1
950 else if c1.alpha > c2.alpha then
951 result := 1
952 else
953 begin
954 gray1 := (GammaExpansionTab[c1.red] shl 8)+(GammaExpansionTab[c1.green] shl 9)+(GammaExpansionTab[c1.blue] shl 7);
955 gray2 := (GammaExpansionTab[c2.red] shl 8)+(GammaExpansionTab[c2.green] shl 9)+(GammaExpansionTab[c2.blue] shl 7);
956 if gray1<gray2 then
957 result := -1
958 else if gray1>gray2 then
959 result := 1
960 else
961 begin
962 if c1.green > c2.green then
963 result := 1
964 else if c1.green < c2.green then
965 result := -1
966 else if c1.red > c2.red then
967 result := 1
968 else if c1.red < c2.red then
969 result := -1
970 else if c1.blue > c2.blue then
971 result := 1
972 else if c1.blue < c2.blue then
973 result := -1
974 else
975 result := 0;
976 end;
977 end;
978 end;
979
980 { TBGRAAvgLvlPalette }
981
982 constructor TBGRAAvgLvlPalette.Create;
983 begin
984 FTree := TAVLTree.Create;
985 FTree.OnCompare := @PaletteOnCompareItems;
986 end;
987
988 destructor TBGRAAvgLvlPalette.Destroy;
989 begin
990 Clear;
991 FreeAndNil(FTree);
992 inherited Destroy;
993 end;
994
TBGRAAvgLvlPalette.GetAsArrayOfColornull995 function TBGRAAvgLvlPalette.GetAsArrayOfColor: ArrayOfTBGRAPixel;
996 var i: Int32or64;
997 begin
998 NeedArray;
999 setlength(result, Length(FArray));
1000 for i := 0 to high(result) do
1001 result[i] := FArray[i]^;
1002 end;
1003
GetAsArrayOfWeightedColornull1004 function TBGRAAvgLvlPalette.GetAsArrayOfWeightedColor: ArrayOfWeightedColor;
1005 var i: Int32or64;
1006 begin
1007 NeedArray;
1008 setlength(result, Length(FArray));
1009 for i := 0 to high(result) do
1010 with result[i] do
1011 begin
1012 Color := FArray[i]^;
1013 Weight:= 1;
1014 end;
1015 end;
1016
1017 procedure TBGRAAvgLvlPalette.Clear;
1018 var Node: TAVLTreeNode;
1019 begin
1020 For Node in FTree do
1021 FreeEntry(PBGRAPixel(Node.Data));
1022 FTree.Clear;
1023 ClearArray;
1024 FLastAddedColorCount := 0;
1025 end;
1026
GetCountnull1027 function TBGRAAvgLvlPalette.GetCount: integer;
1028 begin
1029 result := FTree.Count;
1030 end;
1031
ContainsColornull1032 function TBGRAAvgLvlPalette.ContainsColor(AValue: TBGRAPixel): boolean;
1033 Var Node: TAVLTreeNode;
1034 begin
1035 if Assigned(GetLastColor(AValue)) then
1036 begin
1037 result := true;
1038 exit;
1039 end;
1040 Node := FTree.Find(@AValue);
1041 result := Assigned(Node);
1042 if result then AddLastColor(PBGRAPixel(Node.Data));
1043 end;
1044
IndexOfColornull1045 function TBGRAAvgLvlPalette.IndexOfColor(AValue: TBGRAPixel): integer;
1046 Var Node: TAVLTreeNode;
1047 begin
1048 Node := FTree.Find(@AValue);
1049 if Assigned(Node) then
1050 begin
1051 result := 0;
1052 Node := Node.Left;
1053 while Assigned(Node) do
1054 begin
1055 inc(result);
1056 Node := Node.Left;
1057 end;
1058 end else
1059 result := -1;
1060 end;
1061
GetColorByIndexnull1062 function TBGRAAvgLvlPalette.GetColorByIndex(AIndex: integer): TBGRAPixel;
1063 begin
1064 NeedArray;
1065 if (AIndex >= 0) and (AIndex < length(FArray)) then
1066 result := FArray[AIndex]^
1067 else
1068 raise ERangeError.Create('Index out of bounds');
1069 end;
1070
1071 procedure TBGRAAvgLvlPalette.NeedArray;
1072 var Node: TAVLTreeNode;
1073 i,n: integer;
1074 begin
1075 n := Count;
1076 if length(FArray) <> n then
1077 begin
1078 setLength(FArray,n);
1079 i := 0;
1080 for Node in FTree do
1081 begin
1082 if i >= n then break;
1083 FArray[i] := PBGRAPixel(Node.Data);
1084 inc(i);
1085 end;
1086 end;
1087 end;
1088
1089 procedure TBGRAAvgLvlPalette.ClearArray;
1090 begin
1091 FArray := nil;
1092 end;
1093
1094 procedure TBGRAAvgLvlPalette.AddLastColor(AColor: PBGRAPixel);
1095 begin
1096 if FLastAddedColorCount < MaxLastAddedColors then
1097 begin
1098 FLastAddedColors[FLastAddedColorCount] := AColor;
1099 inc(FLastAddedColorCount);
1100 end else
1101 begin
1102 move(FLastAddedColors[1],FLastAddedColors[0],(FLastAddedColorCount-1)*sizeof(PBGRAPixel));
1103 FLastAddedColors[FLastAddedColorCount-1] := AColor;
1104 end;
1105 end;
1106
GetLastColornull1107 function TBGRAAvgLvlPalette.GetLastColor(AValue: TBGRAPixel): PBGRAPixel;
1108 var
1109 i: Int32or64;
1110 begin
1111 for i := FLastAddedColorCount-1 downto 0 do
1112 if PLongWord(FLastAddedColors[i])^ = LongWord(AValue) then
1113 begin
1114 result := FLastAddedColors[i];
1115 exit;
1116 end;
1117 result := nil;
1118 end;
1119
1120 procedure TBGRAAvgLvlPalette.ClearLastColors;
1121 begin
1122 FLastAddedColorCount := 0;
1123 end;
1124
1125 { TBGRAPalette }
1126
TBGRAPalette.CreateEntrynull1127 function TBGRAPalette.CreateEntry(AColor: TBGRAPixel): PBGRAPixel;
1128 begin
1129 result := PBGRAPixel(GetMem(sizeOf(TBGRAPixel)));
1130 result^ := AColor;
1131 end;
1132
1133 procedure TBGRAPalette.FreeEntry(AEntry: PBGRAPixel);
1134 begin
1135 FreeMem(AEntry);
1136 end;
1137
1138 procedure TBGRAPalette.IncludePixel(PPixel: PBGRAPixel);
1139 begin
1140 AddColor(PPixel^);
1141 end;
1142
1143 procedure TBGRAPalette.ExceptionUnknownPaletteFormat;
1144 begin
1145 raise Exception.Create('Unknown palette format');
1146 end;
1147
1148 procedure TBGRAPalette.ExceptionInvalidPaletteFormat;
1149 begin
1150 raise Exception.Create('Invalid palette format');
1151 end;
1152
1153 constructor TBGRAPalette.Create(ABitmap: TBGRACustomBitmap);
1154 var p: PBGRAPixel;
1155 n: integer;
1156 begin
1157 inherited Create;
1158 n:= ABitmap.NbPixels;
1159 p := ABitmap.Data;
1160 while n > 0 do
1161 begin
1162 IncludePixel(p);
1163 inc(p);
1164 dec(n);
1165 end;
1166 end;
1167
1168 constructor TBGRAPalette.Create(APalette: TBGRACustomPalette);
1169 begin
1170 inherited Create;
1171 AddColors(APalette);
1172 end;
1173
1174 constructor TBGRAPalette.Create(AColors: ArrayOfTBGRAPixel);
1175 var
1176 i: Integer;
1177 begin
1178 inherited Create;
1179 for i := 0 to high(AColors) do
1180 AddColor(AColors[i]);
1181 end;
1182
1183 constructor TBGRAPalette.Create(AColors: ArrayOfWeightedColor);
1184 var
1185 i: Integer;
1186 begin
1187 inherited Create;
1188 for i := 0 to high(AColors) do
1189 AddColor(AColors[i].Color);
1190 end;
1191
AddColornull1192 function TBGRAPalette.AddColor(AValue: TBGRAPixel): boolean;
1193 Var Node: TAVLTreeNode;
1194 Entry: PBGRAPixel;
1195 begin
1196 if Assigned(GetLastColor(AValue)) then
1197 begin
1198 result := false;
1199 exit;
1200 end;
1201 Node := FTree.Find(@AValue);
1202 if Assigned(Node) then
1203 begin
1204 AddLastColor(PBGRAPixel(Node.Data));
1205 result := false;
1206 end
1207 else
1208 begin
1209 result := true;
1210 Entry := CreateEntry(AValue);
1211 FTree.Add(Entry);
1212 ClearArray;
1213 AddLastColor(Entry);
1214 end;
1215 end;
1216
1217 procedure TBGRAPalette.AddColors(ABitmap: TBGRACustomBitmap);
1218 var p: PBGRAPixel;
1219 n: integer;
1220 begin
1221 n := ABitmap.NbPixels;
1222 p := ABitmap.Data;
1223 while n > 0 do
1224 begin
1225 AddColor(p^);
1226 inc(p);
1227 dec(n);
1228 end;
1229 end;
1230
1231 procedure TBGRAPalette.AddColors(APalette: TBGRACustomPalette);
1232 var i: Int32or64;
1233 begin
1234 for i := 0 to APalette.Count- 1 do
1235 AddColor(APalette.Color[i]);
1236 end;
1237
RemoveColornull1238 function TBGRAPalette.RemoveColor(AValue: TBGRAPixel): boolean;
1239 var
1240 Node : TAVLTreeNode;
1241 begin
1242 Node := FTree.Find(@AValue);
1243 if Assigned(Node) then
1244 begin
1245 FreeEntry(Node.Data);
1246 FTree.Delete(Node);
1247 result := true;
1248 ClearArray;
1249 ClearLastColors;
1250 end else
1251 result := false;
1252 end;
1253
1254 procedure TBGRAPalette.LoadFromFile(AFilenameUTF8: string);
1255 var
1256 stream: TFileStreamUTF8;
1257 format: TBGRAPaletteFormat;
1258 begin
1259 format := DetectPaletteFormat(AFilenameUTF8);
1260 if format = palUnknown then
1261 begin
1262 ExceptionUnknownPaletteFormat;
1263 exit;
1264 end;
1265 stream:= TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead);
1266 try
1267 LoadFromStream(stream, format);
1268 finally
1269 stream.Free;
1270 end;
1271 end;
1272
1273 procedure TBGRAPalette.LoadFromStream(AStream: TStream;
1274 AFormat: TBGRAPaletteFormat);
1275 var buf: TReadBufStream;
1276 handled: boolean;
1277 i: Integer;
1278 begin
1279 RegisterDefaultPaletteFormats;
1280 Clear;
1281 buf := TReadBufStream.Create(AStream);
1282 try
1283 handled := false;
1284 for i := 0 to High(PaletteFormats) do
1285 if PaletteFormats[i].formatIndex = AFormat then
1286 begin
1287 if not PaletteFormats[i].reader(self, AStream) then
1288 ExceptionInvalidPaletteFormat;
1289 handled := true;
1290 break;
1291 end;
1292 if not handled then ExceptionUnknownPaletteFormat;
1293 finally
1294 buf.Free;
1295 end;
1296 end;
1297
1298 procedure TBGRAPalette.LoadFromResource(AFilename: string; AFormat: TBGRAPaletteFormat);
1299 var
1300 stream: TStream;
1301 begin
1302 stream := BGRAResource.GetResourceStream(AFilename);
1303 try
1304 LoadFromStream(stream, AFormat);
1305 finally
1306 stream.Free;
1307 end;
1308 end;
1309
1310 procedure TBGRAPalette.SaveToFile(AFilenameUTF8: string);
1311 var
1312 stream: TFileStreamUTF8;
1313 begin
1314 stream:= TFileStreamUTF8.Create(AFilenameUTF8,fmCreate);
1315 try
1316 SaveToStream(stream, SuggestPaletteFormat(AFilenameUTF8));
1317 finally
1318 stream.Free;
1319 end;
1320 end;
1321
1322 procedure TBGRAPalette.SaveToStream(AStream: TStream;
1323 AFormat: TBGRAPaletteFormat);
1324 var buf: TWriteBufStream;
1325 handled: boolean;
1326 i: Integer;
1327 begin
1328 RegisterDefaultPaletteFormats;
1329 buf := TWriteBufStream.Create(AStream);
1330 try
1331 handled := false;
1332 for i := 0 to High(PaletteFormats) do
1333 if PaletteFormats[i].formatIndex = AFormat then
1334 begin
1335 PaletteFormats[i].writer(self, AStream);
1336 handled := true;
1337 break;
1338 end;
1339 if not handled then ExceptionUnknownPaletteFormat;
1340 finally
1341 buf.Free;
1342 end;
1343 end;
1344
DetectPaletteFormatnull1345 function TBGRAPalette.DetectPaletteFormat(AStream: TStream): TBGRAPaletteFormat;
1346 var buf: string;
1347 oldPos: int64;
1348 i: Integer;
1349 begin
1350 result := palUnknown;
1351 setlength(buf,256);
1352 fillchar(buf[1],length(buf),#0);
1353 oldPos := AStream.Position;
1354 AStream.Read(buf[1],length(buf));
1355 AStream.Position := oldPos;
1356 if length(buf)>0 then
1357 begin
1358 RegisterDefaultPaletteFormats;
1359 for i := 0 to high(PaletteFormats) do
1360 if PaletteFormats[i].checkFormat(buf) then
1361 begin
1362 result := PaletteFormats[i].formatIndex;
1363 exit;
1364 end;
1365 end;
1366 end;
1367
DetectPaletteFormatnull1368 function TBGRAPalette.DetectPaletteFormat(AFilenameUTF8: string
1369 ): TBGRAPaletteFormat;
1370 var stream: TFileStreamUTF8;
1371 begin
1372 result := SuggestPaletteFormat(AFilenameUTF8);
1373 if not FileExists(AFilenameUTF8) then exit;
1374 try
1375 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
1376 except
1377 exit;
1378 end;
1379 try
1380 result := DetectPaletteFormat(stream);
1381 if result = palUnknown then
1382 result := SuggestPaletteFormat(AFilenameUTF8);
1383 finally
1384 stream.Free;
1385 end;
1386 end;
1387
TBGRAPalette.SuggestPaletteFormatnull1388 function TBGRAPalette.SuggestPaletteFormat(AFilenameUTF8: string
1389 ): TBGRAPaletteFormat;
1390 var ext: string;
1391 i: Integer;
1392 begin
1393 RegisterDefaultPaletteFormats;
1394 ext := ExtractFileExt(AFilenameUTF8);
1395 if ext <> '' then
1396 begin
1397 for i := 0 to high(PaletteFormats) do
1398 if CompareText(PaletteFormats[i].ext,ext) = 0 then
1399 begin
1400 result := PaletteFormats[i].formatIndex;
1401 exit;
1402 end;
1403 end;
1404 result := palUnknown;
1405 end;
1406
1407 end.
1408
1409