pngfiltw.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

(*
Copyright (c) 1998-2007 by HiComponents. All rights reserved.

This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.

HiComponents grants you the right to include the compiled component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE,
BUT YOU MAY NOT DISTRIBUTE THIS SOURCE CODE OR ITS COMPILED .DCU IN ANY FORM.

ImageEn, IEvolution and ImageEn ActiveX may not be included in any commercial,
shareware or freeware libraries or components.

email: [e-mail]

http://www.hicomponents.com
*)

unit pngfiltw;

{$R-}
{$Q-}

{$I ie.inc}

{$IFDEF IEINCLUDEPNG}

interface

uses Windows, Graphics, classes, sysutils, ImageEnProc, ImageEnIO, hyiedefs, hyieutils, iezlib;

procedure WritePNGStream(Stream: TStream; bitmap: TIEBitmap; var IOParams: TIOParamsVals; var xProgress: TProgressRec; AlphaChannel: TIEMask);

implementation

uses pngfilt, neurquant;

{$R-}

var
  __turboFloat: LongBool = False;

type
  TIOData = record
    Stream: TStream;
    Aborting: pboolean;
  end;
  PIOData = ^TIOData;

function memcmp(buf1, buf2: pbyte; count: integer): integer; cdecl;
begin
  if count = 0 then
    result := 0
  else
  begin
    while true do
    begin
      dec(count);
      if (count=0) or (buf1^<>buf2^) then
        break;
      inc(buf1);
      inc(buf2);
    end;
    result := buf1^ - buf2^;
  end;
end;

function strncpy(dest, src: pchar; maxlen: integer): pchar; cdecl;
begin
  result := strmove(dest, src, maxlen);
end;

function strcpy(dest, src: pchar): pchar; cdecl;
begin
  result := sysutils.StrCopy(dest, src);
end;


function fabs(v: double): double; cdecl;
begin
  result := abs(v);
end;

function IntPower(Base: Extended; Exponent: Integer): Extended;
asm
        mov     ecx, eax
        cdq
        fld1                      { Result := 1 }
        xor     eax, edx
        sub     eax, edx          { eax := Abs(Exponent) }
        jz      @@3
        fld     Base
        jmp     @@2
@@1:    fmul    ST, ST            { X := Base * Base }
@@2:    shr     eax,1
        jnc     @@1
        fmul    ST(1),ST          { Result := Result * X }
        jnz     @@1
        fstp    st                { pop X from FPU stack }
        cmp     ecx, 0
        jge     @@3
        fld1
        fdivrp                    { Result := 1 / Result }
@@3:
        fwait
end;

function pow(Base, Exponent: double): double; cdecl;
begin
  if Exponent = 0.0 then
    Result := 1.0 { n**0 = 1 }
  else if (Base = 0.0) and (Exponent > 0.0) then
    Result := 0.0 { 0**n = 0, n > 0 }
  else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
    Result := IntPower(Base, Trunc(Exponent))
  else
    Result := Exp(Exponent * Ln(Base))
end;

function strtod(s: pchar; var vp: pchar): double; cdecl;
begin
  vp := @s[strlen(s) - 1]; // !!
  result := IEStrToFloatDef(s, 0);
end;

function malloc(size: Integer): Pointer; cdecl;
begin
  result := allocmem(size);
end;

procedure free(P: Pointer); cdecl;
begin
  FreeMem(P);
end;

function memset(P: Pointer; B: Byte; count: Integer): pointer; cdecl;
begin
  FillChar(P^, count, B);
  result := P;
end;

function memcpy(dest, source: Pointer; count: Integer): pointer; cdecl;
begin
  Move(source^, dest^, count);
  result := dest;
end;

function _ftol: integer; cdecl;
var
  f: double;
begin
  asm
   	lea    eax, f             //  BC++ passes floats on the FPU stack
    	fstp  qword ptr [eax]     //  Delphi passes floats on the CPU stack
  end;
  if f > 2147483647.0 then
    f := 2147483647.0;
  if f < -2147483648.0 then
    f := 2147483648.0;
  result := integer(Trunc(f));
end;

function memmove(dest, source: Pointer; count: Integer): pointer; cdecl;
begin
  Move(source^, dest^, count);
  result := dest;
end;

function strlen(str: pchar): integer; cdecl;
begin
  result := Sysutils.strlen(str);
end;

function realloc(block: pointer; size: integer): pointer; cdecl;
begin
  reallocmem(block, size);
  result := block;
end;

function fscanf(f: pointer; format: pchar): integer; cdecl;
begin
  result := 0;
end;


{$L pngset.obj}
{$L pngtrans.obj}
{$L pngmem.obj}
{$L pngerror.obj}

{$L pngwrite.obj}
{$L pngwio.obj}
{$L pngwtran.obj}
{$L pngwutil.obj}

{$L pngget.obj}
{$L png.obj}

procedure png_set_error_fn(png_ptr: png_structp; error_ptr: png_voidp;
  error_fn, warning_fn: png_error_ptr);
  cdecl; external;
function png_set_interlace_handling(png_ptr: png_structp): int;
  cdecl; external;
procedure png_chunk_warning(png_ptr: png_structp;
  const mess: png_charp);
  cdecl; external;
function png_create_write_struct(user_png_ver: png_charp;
  error_ptr: user_error_ptr; error_fn: png_error_ptr;
  warn_fn: png_error_ptr): png_structp;
  cdecl; external;
function png_create_info_struct(png_ptr: png_structp): png_infop;
  cdecl; external;
procedure png_destroy_write_struct(png_ptr_ptr: png_structpp;
  info_ptr_ptr: png_infopp);
  cdecl; external;
procedure png_set_IHDR(png_ptr: png_structp; info_ptr: png_infop;
  width, height: png_uint_32; bit_depth, color_type,
  interlace_type, compression_type, filter_type: int);
  cdecl; external;
procedure png_set_PLTE(png_ptr: png_structp; info_ptr: png_infop;
  palette: png_colorp; num_palette: int);
  cdecl; external;
procedure png_set_bKGD(png_ptr: png_structp; info_ptr: png_infop;
  background: png_color_16p);
  cdecl; external;
procedure png_set_tRNS(png_ptr: png_structp; info_ptr: png_infop;
  trans: png_bytep; num_trans: integer; trans_values: png_color_16p);
  cdecl; external;
procedure png_write_info(png_ptr: png_structp; info_ptr: png_infop);
  cdecl; external;
procedure png_set_bgr(png_ptr: png_structp);
  cdecl; external;
procedure png_set_write_fn(png_ptr: png_structp;
  io_ptr: png_voidp; write_data_fn: png_rw_ptr;
  output_flush_fn: png_flush_ptr);
  cdecl; external;
function png_get_io_ptr(png_ptr: png_structp): png_voidp;
  cdecl; external;
procedure png_write_rows(png_ptr: png_structp; row: png_bytepp;
  num_rows: png_uint_32);
  cdecl; external;
procedure png_write_end(png_ptr: png_structp; info_ptr: png_infop);
  cdecl; external;
procedure png_set_pHYs(png_ptr: png_structp; info_ptr: png_infop;
  res_x, res_y: png_uint_32; unit_type: int);
  cdecl; external;
procedure png_set_filter(png_ptr: png_structp; method, filters: int);
  cdecl; external;
procedure png_set_compression_level(png_ptr: png_structp; level: int);
  cdecl; external;
procedure png_set_sBIT(png_ptr: png_structp; info_ptr: png_infop;
  sig_bits: png_color_8p);
  cdecl; external;
procedure png_set_text(png_ptr: png_structp; info_ptr: png_infop;
  text_ptr: png_textp; num_text: int);
  cdecl; external;

(*
function png_get_bKGD(png_ptr: png_structp; info_ptr: png_infop;
             var background: png_color_16p): png_uint_32;
              cdecl; external;
*)

procedure PNG_MEMSET_CHECK; external;
procedure PNG_CREATE_STRUCT; external;
procedure PNG_DESTROY_STRUCT; external;
procedure png_warning; external;
procedure png_malloc; external;
procedure png_free; external;
procedure png_memcpy_check; external;
procedure PNG_DO_STRIP_FILLER; external;
procedure PNG_DO_PACKSWAP; external;
procedure PNG_DO_SWAP; external;
procedure PNG_DO_BGR; external;
procedure PNG_DO_INVERT; external;
procedure PNG_WRITE_DATA; external;
procedure png_create_struct_2; external;
procedure PNG_SET_MEM_FN; external;
procedure png_destroy_struct_2; external;
procedure PNG_SET_INVERT_ALPHA; external;
procedure PNG_SET_INVERT_MONO; external;
procedure PNG_SET_SHIFT; external;
procedure PNG_SET_PACKING; external;
procedure PNG_SET_SWAP_ALPHA; external;
procedure PNG_SET_FILLER; external;
procedure PNG_SET_SWAP; external;
procedure PNG_SET_PACKSWAP; external;
procedure PNG_WRITE_FLUSH; external;


procedure ErrorFunc(png_ptr: Pointer; msg: Pointer); cdecl;
begin
  raise EInvalidGraphic.create('Error on creating PNG');
end;

procedure WarnFunc(png_ptr: Pointer; msg: Pointer);  cdecl;
begin
end;

procedure WriteFunc(png_ptr: png_structp; data: Pointer; length: png_size_t); cdecl;
var
  iodata: PIOData;
begin
  iodata := png_get_io_ptr(png_ptr);
  if dword(iodata.Stream.Write(pchar(data)^, length)) < length then
    iodata.Aborting^ := true;
end;

procedure FlushFunc(png_ptr: png_structp); cdecl;
begin
end;

///////////////////////////////////////////////////////////////////////////////////////

procedure WritePNGStream(Stream: TStream; bitmap: TIEBitmap; var IOParams: TIOParamsVals; var xProgress: TProgressRec; AlphaChannel: TIEMask);
var
  png_ptr: png_structp;
  info_ptr: png_infop;
  Error_ptr: pointer;
  bit_depth, color_type, interlace_type: integer;
  WBitmap: TIEBitmap;
  BackCol, ForeCol: TRGB;
  FreeW: boolean; // se true liberare WBitmap
  qt: TIEQuantizer;
  palette: array[0..255] of TRGB;
  ppalette: PRGBROW;
  background: png_color_16;
  number_passes, pass, y, x, height, width: integer;
  px, ppx: pointer;
  pp: PRGB;
  brow: pbyte;
  pw: pword;
  nullpr: TProgressRec;
  bitmapwidth1: integer;
  iodata: TIOData;
  px2, px4: PRGBA;
  px_byte, px3: pbyte;
  bb: byte;
  bps: integer;
  hasalpha: boolean;
  px_word: pword;
  p8: png_color_8;
  i,altindex:integer;
  d,dt:double;
  tcl:TRGB;
  png_text_mem:png_textp;
  png_text_idx:png_textp;
  num_text:integer;
begin
  with nullpr do
  begin
    Aborting := xProgress.Aborting;
    fOnProgress := nil;
    Sender := nil;
  end;
  Error_ptr := nil;
  png_ptr := png_create_write_struct('1.2.14', Error_ptr, @ErrorFunc, @WarnFunc);
  if png_ptr = nil then
    raise EInvalidGraphic.create('Error on creating PNG');
  info_ptr := png_create_info_struct(png_ptr);
  if info_ptr = nil then
  begin
    png_destroy_write_struct(@png_ptr, nil);
    raise EInvalidGraphic.create('Error on creating PNG');
  end;
  iodata.Stream := Stream;
  iodata.Aborting := xProgress.Aborting;
  png_set_write_fn(png_ptr, @iodata, @WriteFunc, @FlushFunc);

  // Adjusts unsupported BitsPerSample and SamplesPerPixel
  if (IOParams.SamplesPerPixel=1) and (IOParams.BitsPerSample<>1) and (IOParams.BitsPerSample<>8) and (IOParams.BitsPerSample<>16) then
    IOParams.SamplesPerPixel:=8;

  // The bitmap to write will be contained in WBitmap
  FreeW := false;