giflzw.pas

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

  begin
    v := v shr 2;
    r := r shl 1;
  end;
  repeat
    v := trunc(((x / r) + r) / 2);
    if ((v = r) or (v = r + 1)) then
    begin
      result := r;
      exit;
    end;
    r := v;
  until false;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure did_clear(var vb: varblk);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('did_clear'); {$endif}
  with vb do
  begin
    out_bits := out_bits_init;
    out_bump := out_bump_init;
    out_clear := out_clear_init;
    out_count := 0;
    rl_table_max := 0;
    just_cleared := 1;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure write_block(var vb: varblk);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('write_block'); {$endif}
  with vb do
  begin
    ofile.Write(oblen, 1);
    ofile.Write(oblock[0], oblen);
    oblen := 0;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure block_out(var vb: varblk; c: byte);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('block_out'); {$endif}
  with vb do
  begin
    oblock[oblen] := c;
    inc(oblen);
    if (oblen >= 255) then
      write_block(vb);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure goutput(var vb: varblk; val: integer);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('goutput'); {$endif}
{$WARNINGS OFF}
  with vb do
  begin
    obuf := obuf or (val shl obits);
    inc(obits, out_bits);
    while (obits >= 8) do
    begin
      block_out(vb, obuf and $FF);
      obuf := obuf shr 8;
      dec(obits, 8);
    end;
  end;
{$WARNINGS ON}
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure output_plain(var vb: varblk; c: integer);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('output_plain'); {$endif}
  with vb do
  begin
    just_cleared := 0;
    goutput(vb, c);
    inc(out_count);
    if (out_count >= out_bump) then
    begin
      inc(out_bits);
      inc(out_bump, 1 shl (out_bits - 1));
    end;
    if (out_count >= out_clear) then
    begin
      goutput(vb, code_clear);
      did_clear(vb);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure reset_out_clear(var vb: varblk);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('reset_out_clear'); {$endif}
  with vb do
  begin
    out_clear := out_clear_init;
    if (out_count >= out_clear) then
    begin
      goutput(vb, code_clear);
      did_clear(vb);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure rl_flush_fromclear(var vb: varblk; count: integer);
var
  n: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('rl_flush_fromclear'); {$endif}
  with vb do
  begin
    out_clear := max_ocodes;
    rl_table_pixel := rl_pixel;
    n := 1;
    while (count > 0) do
    begin
      if (n = 1) then
      begin
        rl_table_max := 1;
        output_plain(vb, rl_pixel);
        dec(count);
      end
      else if (count >= n) then
      begin
        rl_table_max := n;
        output_plain(vb, rl_basecode + n - 2);
        dec(count, n);
      end
      else if (count = 1) then
      begin
        inc(rl_table_max);
        output_plain(vb, rl_pixel);
        count := 0;
      end
      else
      begin
        inc(rl_table_max);
        output_plain(vb, rl_basecode + count - 2);
        count := 0;
      end;
      if (out_count = 0) then
        n := 1
      else
        inc(n);
    end;
    reset_out_clear(vb);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

function computetc(count: dword; nrepcodes: dword): dword;
var
  perrep: dword;
  n: dword;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('computetc'); {$endif}
  result := 0;
  perrep := trunc((nrepcodes * (nrepcodes + 1)) / 2);
  while (count >= perrep) do
  begin
    inc(result, nrepcodes);
    dec(count, perrep);
  end;
  if (count > 0) then
  begin
    n := isqrt(count);
    while ((n * (n + 1)) >= 2 * count) do
      dec(n);
    while ((n * (n + 1)) < 2 * count) do
      inc(n);
    inc(result, n);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure rl_flush_clearorrep(var vb: varblk; count: integer);
var
  withclr: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('rl_flush_clearorrep'); {$endif}
  with vb do
  begin
    withclr := 1 + computetc(count, max_ocodes);
    if (withclr < count) then
    begin
      goutput(vb, code_clear);
      did_clear(vb);
      rl_flush_fromclear(vb, count);
    end
    else
    begin
      while count > 0 do
      begin
        output_plain(vb, rl_pixel);
        dec(count);
      end;
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure rl_flush_withtable(var vb: varblk; count: integer);
var
  repmax: integer;
  repleft: integer;
  leftover: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('rl_flush_withtable'); {$endif}
{$WARNINGS OFF}
  with vb do
  begin
    repmax := trunc(count / rl_table_max);
    leftover := count mod rl_table_max;
    if leftover <> 0 then
      repleft := 1
    else
      repleft := 0;
    if (out_count + repmax + repleft > max_ocodes) then
    begin
      repmax := max_ocodes - out_count;
      leftover := count - (repmax * rl_table_max);
      repleft := 1 + computetc(leftover, max_ocodes);
    end;
    if (1 + computetc(count, max_ocodes) < repmax + repleft) then
    begin
      goutput(vb, code_clear);
      did_clear(vb);
      rl_flush_fromclear(vb, count);
      exit;
    end;
    out_clear := max_ocodes;
    while repmax > 0 do
    begin
      output_plain(vb, rl_basecode + rl_table_max - 2);
      dec(repmax);
    end;
    if (leftover <> 0) then
    begin
      if (just_cleared <> 0) then
      begin
        rl_flush_fromclear(vb, leftover);
      end
      else if (leftover = 1) then
      begin
        output_plain(vb, rl_pixel);
      end
      else
      begin
        output_plain(vb, rl_basecode + leftover - 2);
      end;
    end;
    reset_out_clear(vb);
  end;
{$WARNINGS ON}
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure rl_flush(var vb: varblk);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('rl_flush'); {$endif}
  with vb do
  begin
    if (rl_count = 1) then
    begin
      output_plain(vb, rl_pixel);
      rl_count := 0;
      exit;
    end;
    if (just_cleared <> 0) then
    begin
      rl_flush_fromclear(vb, rl_count);
    end
    else if ((rl_table_max < 2) or (rl_table_pixel <> rl_pixel)) then
    begin
      rl_flush_clearorrep(vb, rl_count);
    end
    else
    begin
      rl_flush_withtable(vb, rl_count);
    end;
    rl_count := 0;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

function GetNextPixel(var vb: varblk): integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GetNextPixel'); {$endif}
  with vb do
  begin
    dec(x);
    if (x <= 0) then
    begin
      x := iwidth;
      case (Pass) of
        0:
          begin
            inc(y, 8);
            if (y >= iheight) then
            begin
              inc(pass);
              y := 4;
            end;
          end;
        1:
          begin
            inc(y, 8);
            if (y >= iheight) then
            begin
              inc(pass);
              y := 2;
            end;
          end;
        2:
          begin
            inc(y, 4);
            if (y >= iheight) then
            begin
              inc(pass);
              Y := 1;
            end;
          end;
        3:
          inc(y, 2);
      end;
      Datap := pbyte(integer(Data) + (y * iWidth));
    end;
    result := Datap^;
    inc(Datap);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure GIFNONLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar; BitsPerPixel: integer);
var
  b: byte;
  c, bufdim: integer;
  vb: varblk;
  bufpos: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GIFNONLZWCompress'); {$endif}
  bufdim := Height * Width; // only for 8 bitXpixel
  if BitsPerPixel = 1 then
    BitsPerPixel := 2;
  b := BitsPerPixel;
  Stream.Write(b, 1);
  inc(BitsPerPixel);
  //
  bufpos := 0;
  with vb do
  begin
    ofile := Stream;
    obuf := 0;
    obits := 0;
    oblen := 0;
    code_clear := 1 shl (BitsPerPixel - 1);
    code_eof := code_clear + 1;
    rl_basecode := code_eof + 1;
    out_bump_init := (1 shl (BitsPerPixel - 1)) - 1;
    if (BitsPerPixel <= 3) then
      out_clear_init := 9
    else
      out_clear_init := out_bump_init - 1;
    out_bits_init := BitsPerPixel;
    max_ocodes := $1000 - ((1 shl (out_bits_init - 1)) + 3);
    did_clear(vb);
    goutput(vb, code_clear);
    rl_count := 0;
    y := 0;
    Pass := 0;
    iwidth := width;
    iheight := height;
    if Interlaced then
      x := iwidth
    else
      x := bufdim;
    Data := pbyte(fData);
    Datap := Data;
    fInterlaced := Interlaced;
    repeat
      if bufpos < bufdim then
        c := GetNextPixel(vb)