← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/packages/fcl-image/src/fpquantizer.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/packages/fcl-image/src/fpquantizer.pas
 
1
{*****************************************************************************}
 
2
{
 
3
    This file is part of the Free Pascal's "Free Components Library".
 
4
    Copyright (c) 2005 by Giulio Bernardi
 
5
 
 
6
    This file contains classes used to quantize images.
 
7
 
 
8
    See the file COPYING.FPC, included in this distribution,
 
9
    for details about the copyright.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
14
}
 
15
{*****************************************************************************}
 
16
 
 
17
{$mode objfpc}{$h+}
 
18
unit FPQuantizer;
 
19
 
 
20
interface
 
21
 
 
22
uses sysutils, classes, fpimage, fpcolhash;
 
23
 
 
24
type
 
25
  FPQuantizerException = class (exception);
 
26
 
 
27
type
 
28
  TFPQuantizerProgressEvent = procedure (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte;
 
29
                                         const Msg: AnsiString; var Continue : Boolean) of object;
 
30
 
 
31
type
 
32
  TFPColorQuantizer = class
 
33
    private
 
34
      FOnProgress : TFPQuantizerProgressEvent;
 
35
    protected
 
36
      FColNum : longword;
 
37
      FSupportsAlpha : boolean;
 
38
      FImages : array of TFPCustomImage;
 
39
      FCount : integer;
 
40
      function InternalQuantize : TFPPalette; virtual; abstract;
 
41
      procedure SetColNum(AColNum : longword); virtual;
 
42
      procedure Progress (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean); virtual;
 
43
      function GetImage(Index : integer) : TFPCustomImage;
 
44
      procedure SetImage(Index : integer; const Img : TFPCustomImage);
 
45
      procedure SetCount(Value : integer);
 
46
    public
 
47
      property OnProgress : TFPQuantizerProgressEvent read FOnProgress write FOnProgress;
 
48
      property Images[Index : integer] : TFPCustomImage read GetImage write SetImage;
 
49
      property Count : integer read FCount write SetCount;
 
50
      property ColorNumber : longword read FColNum write SetColNum;
 
51
      property SupportsAlpha : boolean read FSupportsAlpha;
 
52
      procedure Clear;
 
53
      procedure Add(const Img : TFPCustomImage);
 
54
      function Quantize : TFPPalette;
 
55
      constructor Create; virtual;
 
56
      destructor Destroy; override;
 
57
  end;
 
58
 
 
59
 
 
60
type
 
61
  POctreeQNode = ^TOctreeQNode;
 
62
  TOctreeQChilds = array[0..7] of POctreeQNode;
 
63
  TOctreeQNode = record
 
64
    isleaf : boolean;
 
65
    count : longword;
 
66
    R, G, B : longword;
 
67
    Next : POctreeQNode; //used in the reduction list.
 
68
    Childs : TOctreeQChilds;
 
69
  end;
 
70
 
 
71
 
 
72
type
 
73
  TFPOctreeQuantizer = class(TFPColorQuantizer)
 
74
    private
 
75
      Root : POctreeQNode;
 
76
      ReductionList : TOctreeQChilds;
 
77
      LeafTot, MaxLeaf : longword;
 
78
      percent : byte;              { these values are used to call OnProgress event }
 
79
      percentinterval : longword;
 
80
      percentacc : longword;
 
81
      FContinue : boolean;
 
82
      procedure DisposeNode(var Node : POctreeQNode);
 
83
      procedure AddColor(var Node : POctreeQNode; const R, G, B, Level : byte);
 
84
      procedure AddToPalette(var Node : POctreeQNode; Palette : TFPPalette; var Current : integer);
 
85
      procedure Reduce;
 
86
      function BuildPalette : TFPPalette;
 
87
    protected
 
88
      function InternalQuantize : TFPPalette; override;
 
89
    public
 
90
  end;
 
91
 
 
92
type
 
93
  TMCBox = record
 
94
    total, startindex, endindex : longword;
 
95
  end;
 
96
 
 
97
const mcSlow = 0;
 
98
      mcNormal = 1;
 
99
      mcFast = 2;
 
100
 
 
101
type
 
102
  TFPMedianCutQuantizer = class(TFPColorQuantizer)
 
103
    private
 
104
      HashTable, palcache : TFPColorHashTable;
 
105
      arr : TFPColorWeightArray;
 
106
      boxes : array of TMCBox;
 
107
      Used : integer;
 
108
      percent : byte;              { these values are used to call OnProgress event }
 
109
      percentinterval : longword;
 
110
      percentacc : longword;
 
111
      FContinue : boolean;
 
112
      FMode : byte;
 
113
      function ColorCompare(const c1, c2 : TFPPackedColor; const Dim : byte) : shortint;
 
114
      function FindLargestDimension(const Box : TMCBox) : byte;
 
115
      procedure QuickSort(const l, r : integer; const Dim : byte);
 
116
      procedure QuickSortBoxes(const l, r : integer);
 
117
      function MeanBox(const box : TMCBox) : TFPColor;
 
118
      function BuildPalette : TFPPalette;
 
119
      procedure SetMode(const Amode : byte);
 
120
      function MaskColor(const col : TFPColor) : TFPColor;
 
121
    protected
 
122
      function InternalQuantize : TFPPalette; override;
 
123
    public
 
124
      constructor Create; override;
 
125
      property Mode : byte read FMode write SetMode;
 
126
  end;
 
127
 
 
128
implementation
 
129
 
 
130
function RGB2FPColor(const R, G, B : longword) : TFPColor;
 
131
begin
 
132
  Result.Red:=(R shl 8) + R;
 
133
  Result.Green:=(G shl 8) + G;
 
134
  Result.Blue:=(B shl 8) + B;
 
135
  Result.Alpha := AlphaOpaque;
 
136
end;
 
137
 
 
138
{ TFPColorQuantizer }
 
139
 
 
140
function TFPColorQuantizer.Quantize : TFPPalette;
 
141
begin
 
142
  Result:=InternalQuantize;
 
143
end;
 
144
 
 
145
constructor TFPColorQuantizer.Create;
 
146
begin
 
147
  FSupportsAlpha:=false;
 
148
  FColNum:=256; //default setting.
 
149
  FCount:=0;
 
150
  setlength(FImages,0);
 
151
end;
 
152
 
 
153
destructor TFPColorQuantizer.Destroy;
 
154
begin
 
155
  Setlength(FImages,0);
 
156
  inherited Destroy;
 
157
end;
 
158
 
 
159
procedure TFPColorQuantizer.SetColNum(AColNum : longword);
 
160
begin
 
161
  if AColNum<2 then
 
162
    raise FPQuantizerException.Create('Invalid color depth: '+IntToStr(AColNum));
 
163
  FColNum:=AColNum;
 
164
end;
 
165
 
 
166
procedure TFPColorQuantizer.Progress(Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean);
 
167
begin
 
168
  if Assigned(FOnProgress) then
 
169
    FOnProgress(Sender,Stage,PercentDone,Msg,Continue);
 
170
end;
 
171
 
 
172
function TFPColorQuantizer.GetImage(Index : integer) : TFPCustomImage;
 
173
begin
 
174
  if Index>=FCount then
 
175
    raise FPQuantizerException.Create('Invalid image index: '+IntToStr(Index));
 
176
  Result:=FImages[index];
 
177
end;
 
178
 
 
179
procedure TFPColorQuantizer.SetImage(Index : integer; const Img : TFPCustomImage);
 
180
begin
 
181
  if Index>=FCount then
 
182
    raise FPQuantizerException.Create('Invalid image index: '+IntToStr(Index));
 
183
  FImages[Index]:=Img;
 
184
end;
 
185
 
 
186
procedure TFPColorQuantizer.SetCount(Value : integer);
 
187
var old, i : integer;
 
188
begin
 
189
  old:=FCount;
 
190
  setlength(FImages,Value);
 
191
  for i:=old to Value-1 do
 
192
    FImages[i]:=nil;
 
193
  FCount:=Value;
 
194
end;
 
195
 
 
196
procedure TFPColorQuantizer.Clear;
 
197
begin
 
198
  setlength(FImages,0);
 
199
  FCount:=0;
 
200
end;
 
201
 
 
202
procedure TFPColorQuantizer.Add(const Img : TFPCustomImage);
 
203
var i : integer;
 
204
begin
 
205
{ Find first unused slot }
 
206
  for i:=0 to FCount-1 do
 
207
    if FImages[i]=nil then
 
208
    begin
 
209
      Fimages[i]:=Img;
 
210
      exit;
 
211
    end;
 
212
 { If we reached this point there are no unused slot: let's enlarge the array }
 
213
  SetCount(Fcount+1);
 
214
  FImages[FCount-1]:=Img;
 
215
end;
 
216
 
 
217
{ TFPOctreeQuantizer }
 
218
 
 
219
const Mask : array[0..7] of byte = ($80, $40, $20, $10, $08, $04, $02, $01);
 
220
 
 
221
procedure TFPOctreeQuantizer.AddColor(var Node : POctreeQNode; const R, G, B, Level : byte);
 
222
var index, shift : byte;
 
223
begin
 
224
  if Node=nil then
 
225
  begin
 
226
    Node:=getmem(sizeof(TOctreeQNode));
 
227
    if Node=nil then
 
228
      raise FPQuantizerException.Create('Out of memory');
 
229
    FillByte(Node^,sizeof(TOctreeQNode),0);
 
230
    if level=7 then
 
231
    begin
 
232
      Node^.isleaf:=true;
 
233
      inc(LeafTot); { we just created a new leaf }
 
234
    end
 
235
    else
 
236
    begin { we don't put leaves in reduction list since this is unuseful }
 
237
      Node^.isleaf:=false;
 
238
      Node^.Next:=ReductionList[level]; { added on top of the reduction list for its level }
 
239
      ReductionList[level]:=Node;
 
240
    end;
 
241
  end;
 
242
  if Node^.isleaf then
 
243
  begin
 
244
    inc(Node^.R,R);
 
245
    inc(Node^.G,G);
 
246
    inc(Node^.B,B);
 
247
    inc(Node^.count);
 
248
  end
 
249
  else
 
250
  begin
 
251
    shift:=7-level;
 
252
    index:=((R and mask[level]) shr shift) shl 2;
 
253
    index:=index+((G and mask[level]) shr shift) shl 1;
 
254
    index:=index+((B and mask[level]) shr shift);
 
255
    AddColor(Node^.Childs[index],R,G,B,Level+1);
 
256
  end;
 
257
end;
 
258
 
 
259
procedure TFPOctreeQuantizer.DisposeNode(var Node : POctreeQNode);
 
260
var i : integer;
 
261
begin
 
262
  if Node=nil then exit;
 
263
  if not (Node^.isleaf) then
 
264
    for i:=0 to 7 do
 
265
      if Node^.childs[i]<>nil then
 
266
        DisposeNode(Node^.childs[i]);
 
267
  FreeMem(Node);
 
268
  Node:=nil;
 
269
end;
 
270
 
 
271
procedure TFPOctreeQuantizer.Reduce;
 
272
var i : integer;
 
273
    Node : POctreeQNode;
 
274
begin
 
275
  i:=6; { level 7 nodes don't have childs, start from 6 and go backward }
 
276
  while ((i>0) and (ReductionList[i]=nil)) do
 
277
    dec(i);
 
278
 
 
279
  { remove this node from the list}
 
280
  Node:=ReductionList[i];
 
281
  ReductionList[i]:=Node^.Next;
 
282
 
 
283
  for i:=0 to 7 do
 
284
    if Node^.childs[i]<>nil then
 
285
    begin
 
286
      inc(Node^.count,Node^.childs[i]^.count);
 
287
      inc(Node^.r,Node^.childs[i]^.r);
 
288
      inc(Node^.g,Node^.childs[i]^.g);
 
289
      inc(Node^.b,Node^.childs[i]^.b);
 
290
      DisposeNode(Node^.childs[i]);
 
291
      dec(LeafTot);
 
292
    end;
 
293
  Node^.isleaf:=true;
 
294
  inc(LeafTot); { this node is now a leaf! }
 
295
end;
 
296
 
 
297
procedure TFPOctreeQuantizer.AddToPalette(var Node : POctreeQNode; Palette : TFPPalette; var Current : integer);
 
298
var i : byte;
 
299
begin
 
300
  if not FContinue then exit;
 
301
 
 
302
  if Node^.isleaf then
 
303
  begin
 
304
    if (current >= LeafTot) then
 
305
      raise FPQuantizerException.Create('Octree Quantizer internal error: palette index too high.');
 
306
    Node^.r:= Node^.r div Node^.count;
 
307
    Node^.g:= Node^.g div Node^.count;
 
308
    Node^.b:= Node^.b div Node^.count;
 
309
    Palette.Color[Current]:=RGB2FPColor(Node^.r,Node^.g,Node^.b);
 
310
    inc(current);
 
311
 
 
312
    { ************************************************ }
 
313
    inc(percentacc);
 
314
    if percentacc>=percentinterval then
 
315
    begin
 
316
      dec(percentacc,percentinterval);
 
317
      inc(percent);
 
318
      Progress(self,psRunning,percent,'',FContinue);
 
319
    end;
 
320
    { ************************************************ }
 
321
 
 
322
  end
 
323
  else
 
324
  for i:=0 to 7 do
 
325
    if Node^.childs[i]<>nil then
 
326
      AddToPalette(Node^.childs[i],Palette,Current);
 
327
end;
 
328
 
 
329
function TFPOctreeQuantizer.BuildPalette : TFPPalette;
 
330
var pal : TFPPalette;
 
331
    i : integer;
 
332
begin
 
333
  if Root=nil then exit;
 
334
  pal:=TFPPalette.Create(LeafTot);
 
335
  i:=0;
 
336
  try
 
337
    AddToPalette(Root,pal,i);
 
338
  except
 
339
    pal.Free;
 
340
    pal:=nil;
 
341
    raise;
 
342
  end;
 
343
  if not FContinue then
 
344
  begin
 
345
    pal.Free;
 
346
    pal:=nil;
 
347
  end;
 
348
  Result:=pal;
 
349
end;
 
350
 
 
351
function TFPOctreeQuantizer.InternalQuantize : TFPPalette;
 
352
var i, j, k : integer;
 
353
    color : TFPColor;
 
354
begin
 
355
  Root:=nil;
 
356
  for i:=0 to high(ReductionList) do
 
357
    ReductionList[i]:=nil;
 
358
  LeafTot:=0;
 
359
  MaxLeaf:=FColNum;
 
360
 
 
361
  { ************************************************************** }
 
362
  { set up some values useful when calling OnProgress event        }
 
363
  { number of operations is:                                       }
 
364
  {    width*heigth for population                                 }
 
365
  {    initial palette count - final palette count for reduction   }
 
366
  {    final palette count for building the palette                }
 
367
  { total: width*heigth+initial palette count.                     }
 
368
  { if source image doesn't have a palette assume palette count as }
 
369
  { width*height (worst scenario) if it is < 2^24, or 2^24 else    }
 
370
  percentinterval:=0;
 
371
  percentacc:=0;
 
372
  for i:=0 to FCount-1 do
 
373
    if FImages[i]<>nil then
 
374
    begin
 
375
      percentinterval:=percentinterval+FImages[i].Width*FImages[i].Height;
 
376
      if FImages[i].UsePalette then
 
377
        percentacc:=percentacc+FImages[i].Palette.Count
 
378
      else
 
379
        percentacc:=percentacc+FImages[i].Width*FImages[i].Height;
 
380
    end;
 
381
  if percentacc>$1000000 then percentacc:=$1000000;
 
382
 
 
383
  percentinterval:=(percentacc+percentinterval) div 100;  { how many operations for 1% }
 
384
  if percentinterval=0 then percentinterval:=$FFFFFFFF;  { it's quick, call progress only when starting and ending }
 
385
  percent:=0;
 
386
  percentacc:=0;
 
387
  FContinue:=true;
 
388
  Progress (self,psStarting,0,'',FContinue);
 
389
  Result:=nil;
 
390
  if not FContinue then exit;
 
391
  { ************************************************************** }
 
392
 
 
393
  { populate the octree with colors }
 
394
  try
 
395
    for k:=0 to FCount-1 do
 
396
      if FImages[k]<>nil then
 
397
        for j:=0 to FImages[k].Height-1 do
 
398
          for i:=0 to FImages[k].Width-1 do
 
399
          begin
 
400
            Color:=FImages[k][i,j];
 
401
            AddColor(Root,(Color.Red and $FF00) shr 8,(Color.Green and $FF00) shr 8,(Color.Blue and $FF00) shr 8,0);
 
402
            { ************************************************* }
 
403
            inc(percentacc);
 
404
            if percentacc>=percentinterval then
 
405
            begin
 
406
              dec(percentacc,percentinterval);
 
407
              inc(percent);
 
408
              Progress(self,psRunning,percent,'',FContinue);
 
409
              if not FContinue then exit;
 
410
            end;
 
411
            { ************************************************* }
 
412
          end;
 
413
    { reduce number of colors until it is <= MaxLeaf }
 
414
    while LeafTot > MaxLeaf do
 
415
    begin
 
416
      Reduce;
 
417
      { ************************************************* }
 
418
      inc(percentacc);
 
419
      if percentacc>=percentinterval then
 
420
      begin
 
421
        dec(percentacc,percentinterval);
 
422
        inc(percent);
 
423
        Progress(self,psRunning,percent,'',FContinue);
 
424
        if not FContinue then exit;
 
425
      end;
 
426
      { ************************************************* }
 
427
    end;
 
428
 
 
429
    { build the palette }
 
430
    Result:=BuildPalette;
 
431
    if FContinue then Progress (self,psEnding,100,'',FContinue);
 
432
  finally
 
433
    DisposeNode(Root);
 
434
  end;
 
435
end;
 
436
 
 
437
{ TFPMedianCutQuantizer }
 
438
 
 
439
const DIM_ALPHA = 0;
 
440
      DIM_RED   = 1;
 
441
      DIM_GREEN = 2;
 
442
      DIM_BLUE  = 3;
 
443
 
 
444
constructor TFPMedianCutQuantizer.Create;
 
445
begin
 
446
  inherited Create;
 
447
  FSupportsAlpha:=true;
 
448
  FMode:=mcNormal;
 
449
end;
 
450
 
 
451
procedure TFPMedianCutQuantizer.SetMode(const Amode : byte);
 
452
begin
 
453
  if not (Amode in [mcSlow,mcNormal,mcFast]) then
 
454
    raise FPQuantizerException.Create('Invalid quantizer mode: '+IntToStr(Amode));
 
455
  FMode:=Amode;
 
456
end;
 
457
 
 
458
function TFPMedianCutQuantizer.FindLargestDimension(const Box : TMCBox) : byte;
 
459
var i : longword;
 
460
    col : TFPPackedColor;
 
461
    maxa, mina, maxr, minr, maxg, ming, maxb, minb : byte;
 
462
begin
 
463
  maxa:=0;   maxr:=0;   maxg:=0;   maxb:=0;
 
464
  mina:=$FF; minr:=$FF; ming:=$FF; minb:=$FF;
 
465
  for i:=box.startindex to box.endindex do
 
466
  begin
 
467
    col:=arr[i]^.Col;
 
468
    if col.A<mina then mina:=col.A;
 
469
    if col.A>maxa then maxa:=col.A;
 
470
    if col.R<minr then minr:=col.R;
 
471
    if col.R>maxr then maxr:=col.R;
 
472
    if col.G<ming then ming:=col.G;
 
473
    if col.G>maxg then maxg:=col.G;
 
474
    if col.B<minb then minb:=col.B;
 
475
    if col.B>maxb then maxb:=col.B;
 
476
  end;
 
477
  maxa:=maxa-mina;
 
478
  maxr:=maxr-minr;
 
479
  maxg:=maxg-ming;
 
480
  maxb:=maxb-minb;
 
481
  if ((maxa>maxr) and (maxa>maxg) and (maxa>maxb)) then Result:=DIM_ALPHA
 
482
  else if ((maxr>maxa) and (maxr>maxg) and (maxr>maxb)) then Result:=DIM_RED
 
483
  else if ((maxg>maxa) and (maxg>maxr) and (maxg>maxb)) then Result:=DIM_GREEN
 
484
  else Result:=DIM_BLUE;
 
485
end;
 
486
 
 
487
function TFPMedianCutQuantizer.ColorCompare(const c1, c2 : TFPPackedColor; const Dim : byte) : shortint;
 
488
var tmp : integer;
 
489
begin
 
490
  case Dim of
 
491
    DIM_ALPHA : tmp:=(c1.A-c2.A);
 
492
    DIM_RED   : tmp:=(c1.R-c2.R);
 
493
    DIM_GREEN : tmp:=(c1.G-c2.G);
 
494
    DIM_BLUE  : tmp:=(c1.B-c2.B)
 
495
  else raise FPQuantizerException.Create('Invalid dimension: '+IntToStr(Dim));
 
496
  end;
 
497
  if tmp>0 then Result:=1
 
498
  else if tmp<0 then Result:=-1
 
499
  else Result:=0;
 
500
end;
 
501
 
 
502
procedure TFPMedianCutQuantizer.QuickSort(const l, r : integer; const Dim : byte);
 
503
var i, j : integer;
 
504
    pivot, temp : PFPColorWeight;
 
505
begin
 
506
  if l<r then
 
507
  begin
 
508
    pivot:=arr[l];
 
509
    i:=l+1;
 
510
    j:=r;
 
511
    repeat
 
512
      while ((i<=r) and (ColorCompare(arr[i]^.Col,pivot^.Col,dim)<=0)) do
 
513
        inc(i);
 
514
      while (ColorCompare(arr[j]^.Col,pivot^.Col,dim)=1) do
 
515
        dec(j);
 
516
      if i<j then
 
517
      begin
 
518
        temp:=arr[i];
 
519
        arr[i]:=arr[j];
 
520
        arr[j]:=temp;
 
521
      end;
 
522
    until i > j;
 
523
    { don't swap if they are equal }
 
524
    if ColorCompare(arr[j]^.Col,pivot^.Col,dim)<>0 then
 
525
    begin
 
526
      arr[l]:=arr[j];
 
527
      arr[j]:=pivot;
 
528
    end;
 
529
    Quicksort(l,j-1,dim);
 
530
    Quicksort(i,r,dim);
 
531
  end;
 
532
end;
 
533
 
 
534
procedure TFPMedianCutQuantizer.QuickSortBoxes(const l, r : integer);
 
535
var i, j : integer;
 
536
    pivot, temp : TMCBox;
 
537
begin
 
538
  if l<r then
 
539
  begin
 
540
    pivot:=boxes[l];
 
541
    i:=l+1;
 
542
    j:=r;
 
543
    repeat
 
544
      while ((i<=r) and (boxes[i].total>=pivot.total)) do
 
545
        inc(i);
 
546
      while (boxes[j].total<pivot.total) do
 
547
        dec(j);
 
548
      if i<j then
 
549
      begin
 
550
        temp:=boxes[i];
 
551
        boxes[i]:=boxes[j];
 
552
        boxes[j]:=temp;
 
553
      end;
 
554
    until i > j;
 
555
    { don't swap if they are equal }
 
556
    if boxes[j].total<>pivot.total then
 
557
    begin
 
558
      boxes[l]:=boxes[j];
 
559
      boxes[j]:=pivot;
 
560
    end;
 
561
    QuicksortBoxes(l,j-1);
 
562
    QuicksortBoxes(i,r);
 
563
  end;
 
564
end;
 
565
 
 
566
function TFPMedianCutQuantizer.MeanBox(const box : TMCBox) : TFPColor;
 
567
var tota,totr,totg,totb, pixcount : longword;
 
568
    i : integer;
 
569
    col : TFPPackedColor;
 
570
    fpcol : TFPColor;
 
571
begin
 
572
  tota:=0; totr:=0; totg:=0; totb:=0; pixcount:=0;
 
573
  for i:=box.startindex to box.endindex do
 
574
  begin
 
575
    tota:=tota+(arr[i]^.Col.A*arr[i]^.Num);
 
576
    totr:=totr+(arr[i]^.Col.R*arr[i]^.Num);
 
577
    totg:=totg+(arr[i]^.Col.G*arr[i]^.Num);
 
578
    totb:=totb+(arr[i]^.Col.B*arr[i]^.Num);
 
579
    inc(pixcount,arr[i]^.Num);
 
580
  end;
 
581
  tota:=round(tota / pixcount);
 
582
  totr:=round(totr / pixcount);
 
583
  totg:=round(totg / pixcount);
 
584
  totb:=round(totb / pixcount);
 
585
  if tota>$FF then tota:=$FF;
 
586
  if totr>$FF then totr:=$FF;
 
587
  if totg>$FF then totg:=$FF;
 
588
  if totb>$FF then totb:=$FF;
 
589
  col.a:=tota;
 
590
  col.r:=totr;
 
591
  col.g:=totg;
 
592
  col.b:=totb;
 
593
  fpcol:=Packed2FPColor(col);
 
594
  if palcache.Get(fpcol)<>nil then { already found, try the middle color }
 
595
  begin
 
596
    fpcol:=Packed2FPColor(arr[(box.startindex+box.endindex) div 2]^.Col);
 
597
    if palcache.Get(fpcol)<>nil then { already found, try the first unused color }
 
598
      for i:=box.startindex to box.endindex do
 
599
      begin
 
600
        col.a:=arr[i]^.Col.A;
 
601
        col.r:=arr[i]^.Col.R;
 
602
        col.g:=arr[i]^.Col.G;
 
603
        col.b:=arr[i]^.Col.B;
 
604
        fpcol:=Packed2FPColor(col);
 
605
        if palcache.Get(fpcol)=nil then break;
 
606
      end;
 
607
  end;
 
608
  palcache.Insert(fpcol,nil);
 
609
  Result:=fpcol;
 
610
end;
 
611
 
 
612
function TFPMedianCutQuantizer.BuildPalette : TFPPalette;
 
613
var pal : TFPPalette;
 
614
    i : integer;
 
615
begin
 
616
  pal:=TFPPalette.Create(Used);
 
617
  try
 
618
    palcache:=TFPColorHashTable.Create;
 
619
    try
 
620
      for i:=0 to Used-1 do
 
621
      begin
 
622
        pal.Color[i]:=MeanBox(boxes[i]);
 
623
        { ************************************************* }
 
624
        inc(percentacc);
 
625
        if percentacc>=percentinterval then
 
626
        begin
 
627
          percentacc:=percentacc mod percentinterval;
 
628
          inc(percent);
 
629
          Progress(self,psRunning,percent,'',FContinue);
 
630
          if not FContinue then exit;
 
631
        end;
 
632
        { ************************************************* }
 
633
      end
 
634
    finally
 
635
      palcache.Free;
 
636
    end;
 
637
  except
 
638
    pal.Free;
 
639
    raise;
 
640
  end;
 
641
  Result:=pal;
 
642
end;
 
643
 
 
644
{ slow   mode: no filtering 
 
645
  normal mode: 8 bit r, 6 bit g, 6 bit b 
 
646
  fast   mode: 5 bit r, 5 bit g, 5 bit b }
 
647
 
 
648
const mask_r_normal = $FFFF;
 
649
      mask_g_normal = $FCFC;
 
650
      mask_b_normal = $FCFC;
 
651
      mask_r_fast   = $F8F8;
 
652
      mask_g_fast   = $F8F8;
 
653
      mask_b_fast   = $F8F8;
 
654
 
 
655
function TFPMedianCutQuantizer.MaskColor(const col : TFPColor) : TFPColor;
 
656
begin
 
657
  case FMode of
 
658
    mcNormal:
 
659
          begin
 
660
            Result.Red:=Col.Red and mask_r_normal;
 
661
            Result.Green:=Col.Green and mask_g_normal;
 
662
            Result.Blue:=Col.Blue and mask_b_normal;
 
663
          end;
 
664
    mcFast:
 
665
          begin
 
666
            Result.Red:=Col.Red and mask_r_fast;
 
667
            Result.Green:=Col.Green and mask_g_fast;
 
668
            Result.Blue:=Col.Blue and mask_b_fast;
 
669
          end
 
670
    else Result:=Col;
 
671
  end;
 
672
end;
 
673
 
 
674
function TFPMedianCutQuantizer.InternalQuantize : TFPPalette;
 
675
var box : ^TMCBox;
 
676
    i, j, k : integer;
 
677
    dim : byte;
 
678
    boxpercent : longword;
 
679
begin
 
680
  HashTable:=TFPColorHashTable.Create;
 
681
  try
 
682
  { *****************************************************************************
 
683
    Operations:
 
684
    width*height of each image (populate the hash table)
 
685
    number of desired colors for the box creation process (this should weight as the previous step)
 
686
    number of desired colors for building the palette.
 
687
  }
 
688
    percentinterval:=0;
 
689
    for k:=0 to FCount-1 do
 
690
      if FImages[k]<>nil then
 
691
        percentinterval:=percentinterval+FImages[k].Height*FImages[k].Width;
 
692
    boxpercent:=percentinterval div FColNum;
 
693
    percentinterval:=percentinterval*2+FColNum;
 
694
 
 
695
  percentinterval:=percentinterval div 100;  { how many operations for 1% }
 
696
  if percentinterval=0 then percentinterval:=$FFFFFFFF;  { it's quick, call progress only when starting and ending }
 
697
  percent:=0;
 
698
  percentacc:=0;
 
699
  FContinue:=true;
 
700
  Progress (self,psStarting,0,'',FContinue);
 
701
  if not FContinue then exit;
 
702
  { ***************************************************************************** }
 
703
 
 
704
  { For every color in the images, count how many pixels use it}
 
705
    for k:=0 to FCount-1 do
 
706
      if FImages[k]<>nil then
 
707
        for j:=0 to FImages[k].Height-1 do
 
708
          for i:=0 to FImages[k].Width-1 do
 
709
          begin
 
710
            HashTable.Add(MaskColor(FImages[k][i,j]),1);
 
711
            { ************************************************* }
 
712
            inc(percentacc);
 
713
            if percentacc>=percentinterval then
 
714
            begin
 
715
              percentacc:=percentacc mod percentinterval;
 
716
              inc(percent);
 
717
              Progress(self,psRunning,percent,'',FContinue);
 
718
              if not FContinue then exit;
 
719
            end;
 
720
            { ************************************************* }
 
721
          end;
 
722
  { Then let's have the list in array form }
 
723
    setlength(arr,0);
 
724
    arr:=HashTable.GetArray;
 
725
    try
 
726
      HashTable.Clear; { free some resources }
 
727
 
 
728
      setlength(boxes,FColNum);
 
729
      boxes[0].startindex:=0;
 
730
      boxes[0].endindex:=length(arr)-1;
 
731
      boxes[0].total:=boxes[0].endindex+1;
 
732
      Used:=1;
 
733
 
 
734
      while (used<FColNum) do
 
735
      begin
 
736
        box:=nil;
 
737
        { find a box with at least 2 colors }
 
738
        for i:=0 to Used-1 do
 
739
          if (boxes[i].total)>=2 then
 
740
          begin
 
741
            box:=@boxes[i];
 
742
            break;
 
743
          end;
 
744
        if box=nil then break;
 
745
 
 
746
        dim:=FindLargestDimension(box^);
 
747
        { sort the colors of the box along the largest dimension }
 
748
        QuickSort(box^.startindex,box^.endindex,dim);
 
749
 
 
750
        { Split the box: half of the colors in the first one, the rest in the second one }
 
751
        j:=(box^.startindex+box^.endindex) div 2;
 
752
        { This is the second box }
 
753
        boxes[Used].startindex:=j+1;
 
754
        boxes[Used].endindex:=box^.endindex;
 
755
        boxes[Used].total:=box^.endindex-j;
 
756
        { And here we update the first box }
 
757
        box^.endindex:=j;
 
758
        box^.total:=box^.endindex-box^.startindex+1;
 
759
        { Sort the boxes so that the first one is the one with higher number of colors }
 
760
        QuickSortBoxes(0,Used);
 
761
        inc(Used);
 
762
 
 
763
        { ************************************************* }
 
764
        inc(percentacc,boxpercent);
 
765
        if percentacc>=percentinterval then
 
766
        begin
 
767
          inc(percent,percentacc div percentinterval);
 
768
          percentacc:=percentacc mod percentinterval;
 
769
          Progress(self,psRunning,percent,'',FContinue);
 
770
          if not FContinue then exit;
 
771
        end;
 
772
        { ************************************************* }
 
773
      end;
 
774
      Result:=BuildPalette;
 
775
      if FContinue then Progress (self,psEnding,100,'',FContinue);
 
776
    finally
 
777
      setlength(boxes,0);
 
778
      for i:=0 to length(arr)-1 do
 
779
        FreeMem(arr[i]);
 
780
      setlength(arr,0);
 
781
    end;
 
782
  finally
 
783
    HashTable.Free;
 
784
  end;
 
785
end;
 
786
 
 
787
end.
 
 
b'\\ No newline at end of file'