pngimage1.pas

查看html文件的控件

  GetMem(row_buffer, row_buffer_width);
  GetMem(filter_buffers[FILTERNONE], row_buffer_width);
  if efSub in Bitmap.Filter then
    GetMem(filter_buffers[FILTERSUB], row_buffer_width);
  if efUp in Bitmap.Filter then
    GetMem(filter_buffers[FILTERUP], row_buffer_width);
  if efAverage in Bitmap.Filter then
    GetMem(filter_buffers[FILTERAVERAGE], row_buffer_width);
  if efPaeth in Bitmap.Filter then
    GetMem(filter_buffers[FILTERPAETH], row_buffer_width);
  {Fill the filternone with zeros}
  ZeroMemory(@filter_buffers[FILTERNONE][0], row_buffer_width);

  Bitmap.Interlacing := FALSE;
  
  {Testing encoding method}
  if Bitmap.Interlacing then
  {No interlacing}
  begin
  end
  else
  {Interlacing}
  begin
    {Pass each row}
    for j := 0 to Bitmap.Height - 1 do
    begin

      {Write depending on the pixel format}
      case Bitmap.PixelFormat of
      pf1bit, pf4bit, pf8bit:
        filter := EncodeFilterRow(Bitmap.ScanLine[j], filter_buffers,
          row_buffer_width, offset);
      else
      begin
        {Copy pointer to the line bytes}
        Line := Bitmap.ScanLine[j];

        {Test the pixel format}
        case Bitmap.PixelFormat of
          {3 bytes, just swap}
          pf24bit:
          FOR i := 0 to Bitmap.Width - 1 do
          begin
            Row_Buffer^[i * 3] := AdjustValue(pRGBLine(Line)^[i].rgbtRed);
            Row_Buffer^[1 + (i * 3)] := AdjustValue(pRGBLine(Line)^[i].rgbtGreen);
            Row_Buffer^[2 + (i * 3)] := AdjustValue(pRGBLine(Line)^[i].rgbtBlue);
          end;
          {4 bytes, swap and ignore last byte unused}
          pf32bit:
          FOR i := 0 to Bitmap.Width - 1 do
          begin
            Row_Buffer^[i * 4] := AdjustValue(pRGBALine(Line)^[i].rgbRed);
            Row_Buffer^[1 + (i * 4)] := AdjustValue(pRGBALine(Line)^[i].rgbGreen);
            Row_Buffer^[2 + (i * 4)] := AdjustValue(pRGBALine(Line)^[i].rgbBlue);
          end;
        end;

        {Filter the row}
        filter := EncodeFilterRow(@Row_Buffer[0], filter_buffers,
          row_buffer_width, offset);
      end;
      end;

      (*Write to stream*)
      Encode.Write(Filter, 1);
      Encode.Write(filter_buffers[Filter]^[0], row_buffer_width);
    end;
  end;

  {Free the compression stream}
  Encode.Free;
  {Free memory from the filters}
  FreeMem(row_buffer, row_buffer_width);
  FreeMem(filter_buffers[FILTERNONE], row_buffer_width);
  if efSub in Bitmap.Filter then
    FreeMem(filter_buffers[FILTERSUB], row_buffer_width);
  if efUp in Bitmap.Filter then
    FreeMem(filter_buffers[FILTERUP], row_buffer_width);
  if efAverage in Bitmap.Filter then
    FreeMem(filter_buffers[FILTERAVERAGE], row_buffer_width);
  if efPaeth in Bitmap.Filter then
    FreeMem(filter_buffers[FILTERPAETH], row_buffer_width);

  {$IFDEF _SHAREWARE} Shareware {$ENDIF};
end;

{:Adjust image pixel format}
procedure TChunkIDAT.SetupPixelFormat;
var
  PlteIndex, i     : Integer;
  GrayscalePal     : TMaxLogPalette;
  GAMACHUNK        : TChunkGAMA;
begin
  (*{In case we need an alpha channel bitmap}
  if (IHDR.ColorType = GrayscaleALpha) or
    (IHDR.ColorType = RGBAlpha) then
  begin
    {Free the old mask}
    FreeAndNil(Bitmap.fMask);

    {Create a new bitmap}
    Bitmap.fMask := TBitmap.Create;

    {Set its properties}
    with Bitmap.fMask do
    begin
      Width := IHDR.Width;
      Height := IHDR.Height;
      PixelFormat := pf8bit;
    end;
  end; *)
  {Retrieve the chunk GAMA}
  GamaChunk := Gama;

  {Set the pixel formats}
  CASE IHDR.ColorType of
    GrayScale, Palette, GrayScaleAlpha:
    CASE IHDR.BitDepth of
      1: Bitmap.PixelFormat := pf1bit;     {1 bit, 2 colors: 2^1}
      2: Bitmap.PixelFormat := pf4bit;
      4: Bitmap.PixelFormat := pf4bit;
      8: Bitmap.PixelFormat := pf8bit;     {1 byte in each pixel, 256 colors}
     16: Bitmap.PixelFormat := pf8bit;     {2 bytes per sample}
    END;
    RGB, RGBALPHA:
    CASE IHDR.BitDepth of
      8: Bitmap.PixelFormat := pf24bit;    {R, G, B values for each pixel}
     16: Bitmap.PixelFormat := pf24bit;    {Increased range of values for RGB}
    END;
  END;

  {Create the palettes for the file formats}
  CASE IHDR.ColorType of
  Grayscale, GrayscaleAlpha:
 {Create grayscale palette}
  with GrayscalePal do
  begin
    palVersion := $300;

    {Set the number of colors in palette}
    {Since the max is 256 colors 16bit per sample pixels will be}
    {averanged to 8}
    if IHDR.BitDepth = 16 then
      palNumEntries := 256
    else
      palNumEntries := (1 shl IHDR.BitDepth);

    {Set the palette colors}
    FOR i := 0 to palNumEntries - 1 DO
      WITH palPalEntry[i] do
      begin
        {Average the colors}
        {When i is 0, the color is black}
        {When i is palNumEntries, the color is white}
        peRed := MulDiv(i, 255, palNumEntries - 1);
        {Correct using gamma}
        if Assigned(GamaChunk) then
          peRed := GamaChunk.GammaTable[peRed];
        peGreen := peRed;
        peBlue := peGreen;
        peFlags := PC_NOCOLLAPSE;
      end;

    IF (IHDR.BitDepth = 2) and (palNumEntries < 16) then
    begin
      {Note: This is really a crazy totally nonsence fix for supporting 2bit}
      palNumEntries := 16;
      copymemory(@palpalentry[4], @palpalentry[0], 21);
      copymemory(@palpalentry[8], @palpalentry[0], 21);
      copymemory(@palpalentry[12], @palpalentry[0], 21);
    end;

    {Apply the bitmap palette}
    Bitmap.Palette := CreatePalette(PLogPalette(@GrayscalePal)^);
  end;
  Palette:
  BEGIN
    {Test if there is PLTE chunk, if so apply the palette}
    PlteIndex := Owner.IndexOfClass(TChunkPLTE); { Paul }
    if PlteIndex <> -1 then
      Bitmap.Palette := TChunkPLTE(Owner[PlteIndex]).Palette
    ELSE
      CallError(PNG_ERROR_NO_PALETTE);
  END;
  END;
end;

{:Filters the row using definied types}
procedure TChunkIDAT.FilterRow(Filter: Byte; CurrentRow, LastRow: pByteArray;
  offset, row_buffer_width: Integer);
var
  Col: Integer;  {Current Column}
  Left, Above, AboveLeft: Integer;
  vv, pp: Integer;
begin

  // Filter the row based upon the filter type.
  case filter of
    {No filtering, do nothing}
    FILTERNONE: begin end;
    {Sub filter}
    FILTERSUB:
    {The value is the difference from the value to the left}
    for col := offset to row_buffer_width - 1 do
      CurrentRow[col] := (CurrentRow[col] + CurrentRow[col-offset]) AND $FF;
    FILTERUP:
    {The value is the difference from the value in the previous row.}
    for col := 0 to row_buffer_width - 1 do
      CurrentRow[col] := (CurrentRow[col] + LastRow[col]) AND $FF ;
    FILTERAVERAGE:
    for col := 0 to row_buffer_width - 1 do
    begin
      above := LastRow[col];

      if (col < offset) then
        left := 0
      else
        left := CurrentRow[col-offset] ;

      CurrentRow[col] := (CurrentRow[col] + (left + above) div 2) AND $FF ;
    end;
    FILTERPAETH:
    for col := 0 to row_buffer_width - 1 do
    begin
      above := LastRow[col] ;

      if (col < offset) then
      begin
        left := 0 ;
        aboveleft := 0 ;
      end
      else
      begin
        left := CurrentRow[col-offset] ;
        aboveleft := LastRow[col-offset] ;
      end;

      vv := CurrentRow[col] ;
      pp := PaethPredictor(left, above, aboveleft) ;
      CurrentRow[col] := (pp + vv) AND $FF ;
    end;
    else
      {In case the filter is not reconized}
      CallError(PNG_ERROR_INVALID_FILTER_TYPE);
  end; {Case}

end;

{:When the chunk is going to be saved to a stream}
procedure TChunkIDAT.SaveToStream(Stream: TStream);
begin
  {Set to encode the image to the data}
  EncodeImage;
  {Then write}
  inherited;
end;

{Assign data from one gama chunk}
procedure TChunkGAMA.Assign(Source: TChunk);
begin
  inherited; // fix 1
  GammaTable := TChunkGAMA(Source).GammaTable;
  InverseTable := TChunkGAMA(Source).InverseTable;
end;

{When the object is being created}
constructor TChunkGAMA.Create(AOwner: TChunkList);
begin
  inherited;
  {Set the size of the stream and initial value}
  fStream.SetSize(4);
  Value := 1;
end;

{:Creates a gamma table for using}
procedure TChunkGAMA.DoAction;
var
  I    : Integer;
begin
  {Create gamma table and inverse gamma table (for saving)}
  FOR I := 0 TO 255 DO
  begin
    GammaTable[I] := Round(Power((I / 255), 1 / (Value / 100000 * 2.2)) * 255);
    InverseTable[Round(Power((I / 255), 1 / (Value / 100000 * 2.2)) * 255)] := I;
  end;
end;


{Returns the Gama value}
function TChunkGAMA.GetValue: Cardinal;
begin
  Result := SwapLong(pCardinal(fStream.Memory)^);
end;

{Sets the Gama value}
procedure TChunkGAMA.SetValue(Value: Cardinal);
begin
  pCardinal(fStream.Memory)^ := SwapLong(Value);
end;

{:When the chunk is being saved}
procedure TChunkIHDR.SaveToStream(Stream: TStream);
begin
  {Set the IHDR chunk properties}
    Compression := 0; {The only compression method avaliable}
    Filter := 0;      {The only filter scheme avaliable}

    if Owner.Owner.Interlacing then  {Interlace method}
      Interlaced := 1           {ADAM 7}
    else
      Interlaced := 0;          {NONE}

    Width := Owner.Owner.Width;
    Height := Owner.Owner.Height;

    {Color type}
    case Owner.Owner.PixelFormat of
      pf1bit, pf4bit, pf8bit:
      begin
        {Palette}
        ColorType := PALETTE;
        {Bit depth}
        case Owner.Owner.PixelFormat of
          pf1bit: BitDepth := 1;
          pf4bit: BitDepth := 4;
          pf8bit: BitDepth := 8;
        end;

      end;
      else
      begin
        {R, G, B}
        Owner.Owner.PixelFormat := pf24bit;
        ColorType := RGB;
        BitDepth := 8;
      end;
    end;

  inherited;
end;

{Get values for the other properties}
function TChunkIHDR.GetValue(Index: Integer): Byte;
begin
  case Index of
    0: {Bit depth}   Result := pIHDRChunk(fStream.Memory)^.BitDepth;
    1: {Color type}  Result := pIHDRChunk(fStream.Memory)^.ColorType;
    2: {Compression} Result := pIHDRChunk(fStream.Memory)^.Compression;
    3: {Filter}      Result := pIHDRChunk(fStream.Memory)^.Filter;
    4: {Interlaced}  Result := pIHDRChunk(fStream.Memory)^.Interlaced;
    else {Avoid warning}
      Result := 0;
  end;

end;

{Set value for the other properties}
procedure TChunkIHDR.SetValue(Index: Integer; Value: Byte);
begin
  case Index of
    0: {Bit depth}   pIHDRChunk(fStream.Memory)^.BitDepth := Value;
    1: {Color type}  pIHDRChunk(fStream.Memory)^.ColorType := Value;
    2: {Compression} pIHDRChunk(fStream.Memory)^.Compression := Value;
    3: {Filter}      pIHDRChunk(fStream.Memory)^.Filter := Value;
    4: {Interlaced}  pIHDRChunk(fStream.Memory)^.Interlaced := Value;
  end;
end;

{Returns the image height}
function TChunkIHDR.GetHeight: Cardinal;
begin
  Result := SwapLong(pIHDRChunk(fStream.Memory)^.Height);
end;

{Returns the image width}
function TChunkIHDR.GetWidth: Cardinal;
begin
  Result := SwapLong(pIHDRChunk(fStream.Memory)^.Width);
end;

{Sets the image height}
procedure TChunkIHDR.SetHeight(Value: Cardinal);
begin
  pIHDRChunk(fStream.Memory)^.Height := SwapLong(Value);

  {Changes the image size}
  if Owner.Owner.Height <> Int(Value) then
    Owner.Owner.Height := Value;
end;

{Sets the image width}
procedure TChunkIHDR.SetWidth(Value: Cardinal);
begin
  pIHDRChunk(fStream.Memory)^.Width := SwapLong(Value);

  {Changes the image size}
  if Owner.Owner.Width <> Int(Value) then
    Owner.Owner.Width := Value;
end;

{:When the object is being created}
constructor TChunkIHDR.Create(AOwner: TChunkList);
begin
  inherited;
  {Resize the IHDR chunk}
  fStream.SetSize(13);
end;

{:Returns the index of the chunk class}
function TChunkClasses.IndexOfClass(Item: TChunkClass): Integer; { Paul }
var
  i: Integer;
begin
  {If none found, return -1}
  Result := -1;

  {Test each class}
  if Count > 0 then
    FOR i := 0 to Count - 1 DO
      if Self.Item[I].ChunkClass = Item then
      begin
        Result := i;
        break;
      end;
end;

{:Returns the index of the given chunk type}
function TChunkClasses.IndexOfType(Item: TChunkType): Integer; { Paul }
var
  i: Integer;
begin
  {If none found, return -1}
  Result := -1;

  {Test each class}
  if Count > 0 then
    FOR i := 0 to Count - 1 DO
      if Self.Item[I].ChunkType = Item then
      begin
        Result := i;
        break;
      end;
end;

{:When the object is being destroyed}
destructor TChunkClasses.Destroy;
var
  i: Integer;
begin
  {Free each registered chunk class}
  if Count > 0 then
  FOR i := 0 TO Count - 1 DO
    Dispose(pChunkClassInfo(fList[i]));

  {Free the list}
  if Assigned(fList) then fList.free;

  inherited;
end;