unit Unit2;

interface
uses
   Windows, Graphics;
type
  PRGBColor = ^TRGBColor;
  TRGBColor = record
    B, G, R: Byte;
  end;
  PByte = ^Byte;
  LColor = Record
    Color ,Times : Integer;
  end;

procedure Convert(SBitmap : TBitMap ; var DBitMap : TBitMap) ;

implementation

var
    ColorCount : array[0..4096] of LColor; //為記錄顏色使用頻率的數(shù)組
    ColorTable : array[0..4096] of Byte; // 為記錄顏色索引值的數(shù)組

//統(tǒng)計顏色使用頻率
procedure CountColor(BitMap : TBitMap;Var ClrCount : array of LColor);   
var
    Ptr : PRGBColor;
    i,j : Integer;
    CIndex : Integer;
begin
  for i := 0 to 4096 do         // 初始化ColorCount數(shù)組
  begin
    ClrCount[i].Color := i;
    ClrCount[i].Times := 0;
  end;

  with BitMap do
    for i := 0 to ( Height - 1 ) do
    begin
      Ptr := ScanLine[i];
      for j := 0 to (Width - 1) do
      begin //取 R、G、B三種顏色的前4位組成12位，共4096種顏色
        CIndex := (Ptr.R and $0F0) shl 4;    
        CIndex := CIndex + (Ptr.G and $0F0);
        CIndex := CIndex + ((Ptr.B and $0F0) shr 4);
        Inc(ClrCount[CIndex].Times,1);    //計算顏色的使用次數(shù)
        Inc(Ptr);
      end;
    end;
end;//procedure CountColor

// 清除使用次數(shù)為 0 的顏色數(shù)據(jù),返回值為當(dāng)前圖像中顏色的種類
function Delzero(Var ClrCount : array of LColor): Integer;
var i,CIndex : Integer;
begin
  CIndex := 0;
  for i := 0 to 4096 do
  begin
    if (ClrCount[i].Times <> 0) then
    begin
      ClrCount[CIndex] := ClrCount[i];
      ClrCount[i].Times := 0;
      Inc(CIndex);
    end;
  end;
  Result := CIndex;
end;//function Delzero

// 快速排序， 將各種顏色 按使用的頻率排序(Hight -- Low )
procedure Sort(var A: array of LColor; Top : Integer);

  procedure QuickSort(var A: array of LColor; iLo, iHi: Integer);
  var
    Lo, Hi, Mid: Integer;
    Temp : LColor;
  begin
    Lo := iLo;
    Hi := iHi;
    Mid := A[(Lo + Hi) div 2].Times;
    repeat
      while A[Lo].Times > Mid do Inc(Lo);
      while A[Hi].Times < Mid do Dec(Hi);
      if Lo <= Hi then
      begin
        Temp := A[Lo];
        A[Lo] := A[Hi];
        A[Hi] := Temp;
        Inc(Lo);
        Dec(Hi);
      end;
    until Lo > Hi;
    if Hi > iLo then QuickSort(A, iLo, Hi);
    if Lo < iHi then QuickSort(A, Lo, iHi);
  end;

begin
  QuickSort(A, Low(A), Top);
end;

// 構(gòu)建調(diào)色表
function BuildColorTable(var ClrCount : array of LColor; 
			var Pal :PLogPalette):HPalette;
var i  : Integer;
begin
  Pal.palVersion:=$300;
  Pal.palNumEntries:=256;
  for i := 0 to 255 do
  begin
    Pal.palPalEntry[i].peRed := ((ClrCount[i].Color and $0F00) shr 4) + 7;
    Pal.palPalEntry[i].peGreen := (ClrCount[i].Color and $0F0) + 7;
    Pal.palPalEntry[i].peBlue := ((ClrCount[i].Color and $00F) shl 4) + 7;
    pal.palPalEntry[i].peFlags := 0;
  end;
  Result := CreatePalette(Pal^);
end;


//根據(jù)統(tǒng)計的信息調(diào)整圖像中的顏色， 將不常用的顏色用常用的顏色代替
procedure AdjustColor(ClrNumber : Integer; ClrCount : array of LColor);
var i ,C,Error,m: Integer;
    CIndex : Byte;
begin
//  for i := 0 to 4096 do ColorTable[i] := 0;
  for i := 0 to 255 do
    ColorTable[ClrCount[i].Color] := i;

  for i := 256 to ClrNumber do
  begin
    Error := 10000;
    CIndex := 0;
    C := ClrCount[i].Color;
    for m := 0 to 255 do
      if abs(ClrCount[m].Color - C) < Error then
        begin
          Error := abs(ClrCount[m].Color - C);
          CIndex := m;
        end;
    ColorTable[ClrCount[i].Color] := CIndex;
  end;
end;//procedure AdjustColor

procedure Convert(SBitmap : TBitMap; var DBitMap: TBitMap) ;
var
    Pal: PLogPalette;
    i , j , t, ColorNumber: integer;
    SPtr : PRGBColor;
    DPtr : PByte;
begin
  if (SBitMap.Empty) then
    Exit;

  CountColor(SBitMap,ColorCount);      //統(tǒng)計顏色的使用頻率
  ColorNumber := DelZero(ColorCount);  //去處不使用的顏色
  Sort(ColorCount,ColorNumber);       // 將顏色按使用頻率排序
  AdjustColor(ColorNumber,ColorCount);

  With DBitMap do
  begin
    PixelFormat := pf8bit;
    SBitMap.PixelFormat := pf24bit;
    Width := SBitMap.Width;
    Height := SBitMap.Height;

    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    BuildColorTable(ColorCount,Pal);
    Palette := BuildColorTable(ColorCount,Pal); // Set DBitMap.Palette
    FreeMem(pal);

    for i := 0 to ( Height - 1 ) do
    begin
      SPtr := SBitMap.ScanLine[i];
      DPtr := ScanLine[i];
      for j := 0 to (Width - 1) do
      begin
        t := (SPtr.R and $0F0) shl 4;
        t := t + (SPtr.G and $0F0);
        t := t + ((SPtr.B and $0F0) shr 4);
        DPtr^ := ColorTable[t];
        Inc(SPtr);
        Inc(DPtr);
      end;      
    end;
    
  end;
end; //procedure Convert

end.