ditherunit.pas

查看html文件的控件

  Index			: integer;
begin
  Index := 0;
  GetPaletteColors(FTree, RGBQuadArray, Index);
end;

// Handles passed to ProcessImage should refer to DIB sections, not DDBs.
// In certain cases, specifically when it's called upon to process 1, 4, or
// 8-bit per pixel images on systems with palettized display adapters,
// ProcessImage can produce incorrect results if it's passed a handle to a
// DDB.
function TColorQuantizer.ProcessImage(const DIB: TDIBReader): boolean;
var
  i			,
  j			: integer;
  ScanLine		: pointer;
  Pixel			: PRGBTriple;
begin
  Result := True;

  for j := 0 to DIB.Bitmap.Height-1 do
  begin
    Scanline := DIB.Scanline[j];
    Pixel := ScanLine;
    for i := 0 to DIB.Bitmap.Width-1 do
    begin
      with Pixel^ do
        AddColor(FTree, rgbtRed, rgbtGreen, rgbtBlue,
                 FColorBits, 0, FLeafCount, FReducibleNodes);

      while FLeafCount > FMaxColors do
        ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
      inc(Pixel);
    end;
  end;
end;

procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
  ColorBits: integer; Level: integer; var LeafCount: integer;
  var ReducibleNodes: TReducibleNodes);
const
  Mask:  array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
var
  Index			: integer;
  Shift			: integer;
begin
  // If the node doesn't exist, create it.
  if (Node = nil) then
    Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);

  if (Node.IsLeaf) then
  begin
    inc(Node.PixelCount);
    inc(Node.RedSum, r);
    inc(Node.GreenSum, g);
    inc(Node.BlueSum, b);
  end else
  begin
    // Recurse a level deeper if the node is not a leaf.
    Shift := 7 - Level;

    Index := (((r and mask[Level]) SHR Shift) SHL 2)  or
             (((g and mask[Level]) SHR Shift) SHL 1)  or
              ((b and mask[Level]) SHR Shift);
    AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
  end;
end;

procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
var
  i			: integer;
begin
  for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
    if (Node.Child[i] <> nil) then
      DeleteTree(Node.Child[i]);

  Node.Free;
  Node := nil;
end;

procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
  var RGBQuadArray: TRGBQuadArray; var Index: integer);
var
  i			: integer;
begin
  if (Node.IsLeaf) then
  begin
    with RGBQuadArray[Index] do
    begin
      if (Node.PixelCount <> 0) then
      begin
        rgbRed   := BYTE(Node.RedSum   DIV Node.PixelCount);
        rgbGreen := BYTE(Node.GreenSum DIV Node.PixelCount);
        rgbBlue  := BYTE(Node.BlueSum  DIV Node.PixelCount);
      end else
      begin
        rgbRed := 0;
        rgbGreen := 0;
        rgbBlue := 0;
      end;
      rgbReserved := 0;
    end;
    inc(Index);
  end else
  begin
    for i := Low(Node.Child) to High(Node.Child) do
      if (Node.Child[i] <> nil) then
        GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
  end;
end;

procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
  var ReducibleNodes: TReducibleNodes);
var
  RedSum		,
  GreenSum		,
  BlueSum 		: integer;
  Children		: integer;
  i			: integer;
  Node			: TOctreeNode;
begin
  // Find the deepest level containing at least one reducible node
  i := Colorbits - 1;
  while (i > 0) and (ReducibleNodes[i] = nil) do
    dec(i);

  // Reduce the node most recently added to the list at level i.
  Node := ReducibleNodes[i];
  ReducibleNodes[i] := Node.Next;

  RedSum   := 0;
  GreenSum := 0;
  BlueSum  := 0;
  Children := 0;

  for i := Low(ReducibleNodes) to High(ReducibleNodes) do
    if (Node.Child[i] <> nil) then
    begin
      inc(RedSum, Node.Child[i].RedSum);
      inc(GreenSum, Node.Child[i].GreenSum);
      inc(BlueSum, Node.Child[i].BlueSum);
      inc(Node.PixelCount, Node.Child[i].PixelCount);
      Node.Child[i].Free;
      Node.Child[i] := nil;
      inc(Children);
    end;

  Node.IsLeaf := TRUE;
  Node.RedSum := RedSum;
  Node.GreenSum := GreenSum;
  Node.BlueSum := BlueSum;
  dec(LeafCount, Children-1);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Octree Color Quantization Wrapper
//
////////////////////////////////////////////////////////////////////////////////
//	Adapted from Earl F. Glynn's PaletteLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////

// Wrapper for internal use - uses TDIBReader for bitmap access
function doCreateOptimizedPaletteForSingleBitmap(const DIB: TDIBReader;
  Colors, ColorBits: integer; Windows: boolean): hPalette;
var
  SystemPalette		: HPalette;
  ColorQuantizer	: TColorQuantizer;
  i			: integer;
  LogicalPalette	: TMaxLogPalette;
  RGBQuadArray		: TRGBQuadArray;
  Offset		: integer;
begin
  LogicalPalette.palVersion := $0300;
  LogicalPalette.palNumEntries := Colors;

  if (Windows) then
  begin
    // Get the windows 20 color system palette
    SystemPalette := GetStockObject(DEFAULT_PALETTE);
    GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
    GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);
    Colors := 236;
    Offset := 10;
    LogicalPalette.palNumEntries := 256;
  end else
    Offset := 0;

  // Normally for 24-bit images, use ColorBits of 5 or 6.  For 8-bit images
  // use ColorBits = 8.
  ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
  try
    ColorQuantizer.ProcessImage(DIB);
    ColorQuantizer.GetColorTable(RGBQuadArray);
  finally
    ColorQuantizer.Free;
  end;

  for i := 0 to Colors-1 do
    with LogicalPalette.palPalEntry[i+Offset] do
    begin
      peRed   := RGBQuadArray[i].rgbRed;
      peGreen := RGBQuadArray[i].rgbGreen;
      peBlue  := RGBQuadArray[i].rgbBlue;
      peFlags := RGBQuadArray[i].rgbReserved;
    end;
  Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;

function CreateOptimizedPaletteForSingleBitmap(const Bitmap: TBitmap;
  Colors, ColorBits: integer; Windows: boolean): hPalette;
var
  DIB			: TDIBReader;
begin
  DIB := TDIBReader.Create(Bitmap, pf24bit);
  try
    Result := doCreateOptimizedPaletteForSingleBitmap(DIB, Colors, ColorBits, Windows);
  finally
    DIB.Free;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Color reduction
//
////////////////////////////////////////////////////////////////////////////////
{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
  DitherMode: TDitherMode): TBitmap;
var
  Palette		: hPalette;
  ColorLookup		: TColorLookup;
  Ditherer		: TDitherEngine;
  Row			: Integer;
  DIBResult		: TDIBWriter;
  DIBSource		: TDIBReader;
  SrcScanLine		,
  Src			: PRGBTriple;
  DstScanLine		,
  Dst			: PChar;
  BGR			: TRGBTriple;
{$ifdef DEBUG_DITHERPERFORMANCE}
  TimeStart		,
  TimeStop		: DWORD;
{$endif}


begin
{$ifdef DEBUG_DITHERPERFORMANCE}
  timeBeginPeriod(5);
  TimeStart := timeGetTime;
{$endif}

  Result := TBitmap.Create;
  try

    if (ColorReduction = rmNone) then
    begin
      Result.Assign(Bitmap);
      SetPixelFormat(Result, pf24bit);
      exit;
    end;

    // Set bitmap width and height
    Result.Width := Bitmap.Width;
    Result.Height := Bitmap.Height;

    // Set the bitmap pixel format
    SafeSetPixelFormat(Result, pf8bit);
    Result.Palette := 0;

    ColorLookup := nil;
    Ditherer := nil;
    DIBResult := nil;
    DIBSource := nil;
    Palette := 0;
    try // Protect above resources

      // Dithering and color mapper only supports 24 bit bitmaps,
      // so we have convert the source bitmap to the appropiate format.
      DIBSource := TDIBReader.Create(Bitmap, pf24bit);

      try
        // Create a palette based on current options
        case (ColorReduction) of
          rmQuantizeWindows:
            Palette := CreateOptimizedPaletteForSingleBitmap(Bitmap, 256, 8, True);
          rmNetscape:
            Palette := WebPalette;
          rmMyPalette:
            Palette := CopyPalette(ThePalette);
          rmWindows20:
            Palette := GetStockObject(DEFAULT_PALETTE);
        else
          exit;
        end;

        Result.Palette := Palette;

        case (ColorReduction) of
          // For some strange reason my fast and dirty color lookup
          // is more precise that Windows GetNearestPaletteIndex...
          rmNetscape:
            ColorLookup := TNetscapeColorLookup.Create(Palette);
        else
          ColorLookup := TFastColorLookup.Create(Palette);
        end;

        // Nothing to do if palette doesn't contain any colors
        if (ColorLookup.Colors = 0) then
          exit;

        // Create a ditherer based on current options
        case (DitherMode) of
          dmNearest:
            Ditherer := TDitherEngine.Create(Bitmap.Width, ColorLookup);
          dmFloydSteinberg:
            Ditherer := TFloydSteinbergEngine.Create(Bitmap.Width, ColorLookup);
        else
          exit;
        end;

        // The processed bitmap is returned in pf8bit format
        DIBResult := TDIBWriter.Create(Result, pf8bit);

        // Process the image
        Row := 0;
        while (Row < Bitmap.Height) do
        begin
          SrcScanline := DIBSource.ScanLine[Row];
          DstScanline := DIBResult.ScanLine[Row];
          Src := pointer(longInt(SrcScanLine) + Ditherer.Column*sizeof(TRGBTriple));
          Dst := pointer(longInt(DstScanLine) + Ditherer.Column);

          while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
          begin
            BGR := Src^;
            // Dither and map a single pixel
            Dst^ := Ditherer.Dither(BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue,
              BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue);

            inc(Src, Ditherer.Direction);
            inc(Dst, Ditherer.Direction);
          end;

          Inc(Row);
          Ditherer.NextLine;
        end;
      except
        Result.ReleasePalette;
        if (Palette <> 0) then
          DeleteObject(Palette);
        raise;
      end;
    finally
      if (ColorLookup <> nil) then
        ColorLookup.Free;
      if (Ditherer <> nil) then
        Ditherer.Free;
      if (DIBResult <> nil) then
        DIBResult.Free;
      if (DIBSource <> nil) then
        DIBSource.Free;
    end;
  except
    Result.Free;
    raise;
  end;

{$ifdef DEBUG_DITHERPERFORMANCE}
  TimeStop := timeGetTime;
  ShowMessage(format('Dithered %d pixels in %d mS, Rate %d pixels/mS (%d pixels/S)',
    [Bitmap.Height*Bitmap.Width, TimeStop-TimeStart,
    MulDiv(Bitmap.Height, Bitmap.Width, TimeStop-TimeStart+1),
    MulDiv(Bitmap.Height, Bitmap.Width * 1000, TimeStop-TimeStart+1)]));
  timeEndPeriod(5);
{$endif}
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

function GetBitmap(Source: TPersistent): TBitmap;
var
  PixelFormat		: TPixelFormat;
  FBitmap: TBitmap;
  ColorReduction: TColorReduction;
  DitherMode: TDitherMode;

begin
  Result := Nil;
  if (Source is TBitmap) then    {should always be}
  begin
    if (TBitmap(Source).Empty) then
      exit;
    PixelFormat := GetPixelFormat(TBitmap(Source));
    if (PixelFormat > pfDevice) then
    begin
      if ColorBits >= 8 then
        ColorReduction := rmMyPalette
      else ColorReduction := rmWindows20;
      DitherMode := dmFloydSteinberg;
      // Convert image to 8 bits/pixel or less
      FBitmap := ReduceColors(TBitmap(Source), ColorReduction, DitherMode);
    end else
    begin
      // Create new bitmap and copy
      FBitmap := TBitmap.Create;
      FBitmap.Assign(TBitmap(Source));
    end;
    Result := FBitmap;
  end;
end;            

end.