giflzw.pas

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

      else
        c := -1;
      if (rl_count > 0) and (c <> rl_pixel) then
        rl_flush(vb);
      if c = -1 then
        break;
      if (rl_pixel = c) then
        inc(rl_count)
      else
      begin
        rl_pixel := c;
        rl_count := 1;
      end;
      inc(bufpos);
    until false;
    goutput(vb, code_eof);
    if (obits > 0) then
      block_out(vb, obuf);
    if (oblen > 0) then
      write_block(vb);
  end;
  //
  c := 0;
  Stream.Write(c, 1);
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

// Original C code:
// ppmtogif.c - read a portable pixmap and produce a GIF file
//
// Based on GIFENCOD by David Rowley <[e-mail]>.A
// Lempel-Zim compression based on "compress".
//
// Modified by Marcel Wijkstra <[e-mail]>
//
//
// Copyright (C) 1989 by Jef Poskanzer.
//

const
  BITS = 12;
  maxbits = 12;
  maxmaxcode = 1 shl BITS;
  HSIZE = 5003;
  XEOF = -1;

type
  TLZWCompRecord = record
    Width, Height: integer;
    curx, cury: integer;
    px: pbyte;
    CountDown: integer;
    Pass: integer;
    Interlace: boolean;
    data: pbyte;
    init_bits: integer;
    n_bits: integer;
    maxcode: integer;
    ClearCode: integer;
    EOFCode: integer;
    free_ent: integer;
    offset: integer;
    in_count: integer;
    out_count: integer;
    clear_flg: integer;
    a_count: integer;
    htab: array[0..HSIZE - 1] of integer;
    codetab: array[0..HSIZE - 1] of word;
    cur_accum: integer;
    cur_bits: integer;
    accum: array[0..255] of char;
    os: TStream;
    g_init_bits: integer;
  end;
  PLZWCompRecord = ^TLZWCompRecord;

procedure BumpPixel(var lzwr: TLZWCompRecord);
begin
  {$ifdef IEPROFILE} try IEProfileBegin(''); {$endif}
  with lzwr do
  begin
    inc(curx);
    inc(px);
    if curx = Width then
    begin
      curx := 0;
      if not Interlace then
      begin
        inc(cury);
      end
      else
      begin
        case Pass of
          0:
            begin
              inc(cury, 8);
              if (cury >= Height) then
              begin
                inc(Pass);
                cury := 4;
              end;
            end;
          1:
            begin
              inc(cury, 8);
              if (cury >= Height) then
              begin
                inc(Pass);
                cury := 2;
              end;
            end;
          2:
            begin
              inc(cury, 4);
              if (cury >= Height) then
              begin
                inc(Pass);
                cury := 1;
              end;
            end;
          3:
            begin
              inc(cury, 2);
            end;
        end;
      end;
      px := pbyte(integer(data) + cury * Width);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

function GIFNextPixel(var lzwr: TLZWCompRecord): integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GIFNextPixel'); {$endif}
  with lzwr do
    if (CountDown = 0) then
      result := XEOF
    else
    begin
      dec(CountDown);
      result := px^;
      BumpPixel(lzwr);
    end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure cl_hash(var lzwr: TLZWCompRecord; hsize: integer);
var
  htab_p: pinteger;
  i: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('cl_hash'); {$endif}
  htab_p := @(lzwr.htab[0]);
  inc(htab_p, hsize);
  i := hsize - 16;
  repeat
    pinteger(integer(htab_p) - 64)^ := -1;
    pinteger(integer(htab_p) - 60)^ := -1;
    pinteger(integer(htab_p) - 56)^ := -1;
    pinteger(integer(htab_p) - 52)^ := -1;
    pinteger(integer(htab_p) - 48)^ := -1;
    pinteger(integer(htab_p) - 44)^ := -1;
    pinteger(integer(htab_p) - 40)^ := -1;
    pinteger(integer(htab_p) - 36)^ := -1;
    pinteger(integer(htab_p) - 32)^ := -1;
    pinteger(integer(htab_p) - 28)^ := -1;
    pinteger(integer(htab_p) - 24)^ := -1;
    pinteger(integer(htab_p) - 20)^ := -1;
    pinteger(integer(htab_p) - 16)^ := -1;
    pinteger(integer(htab_p) - 12)^ := -1;
    pinteger(integer(htab_p) - 8)^ := -1;
    pinteger(integer(htab_p) - 4)^ := -1;
    dec(htab_p, 16);
    dec(i, 16);
  until not (i >= 0);
  inc(i, 16);
  while i > 0 do
  begin
    dec(htab_p);
    htab_p^ := -1;
    dec(i);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure flush_char(var lzwr: TLZWCompRecord);
var
  bb: byte;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('flush_char'); {$endif}
  with lzwr do
  begin
    if (a_count > 0) then
    begin
      bb := a_count;
      os.Write(bb, 1);
      os.Write(accum[0], a_count);
      a_count := 0;
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure char_out(var lzwr: TLZWCompRecord; c: integer);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('char_out'); {$endif}
  with lzwr do
  begin
    accum[a_count] := char(c);
    inc(a_count);
    if (a_count >= 254) then
      flush_char(lzwr);
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure output(var lzwr: TLZWCompRecord; code: integer);
const
  masks: array[0..16] of integer = ($0000, $0001, $0003, $0007, $000F,
    $001F, $003F, $007F, $00FF,
    $01FF, $03FF, $07FF, $0FFF,
    $1FFF, $3FFF, $7FFF, $FFFF);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('output'); {$endif}
  with lzwr do
  begin
    if (cur_bits > 0) then
      cur_accum := (cur_accum and masks[cur_bits]) or (code shl cur_bits)
    else
      cur_accum := code;
    inc(cur_bits, n_bits);
    while (cur_bits >= 8) do
    begin
      char_out(lzwr, integer(cur_accum and $FF));
      cur_accum := cur_accum shr 8;
      dec(cur_bits, 8);
    end;
    if (free_ent > maxcode) or (clear_flg <> 0) then
    begin
      if (clear_flg <> 0) then
      begin
        n_bits := g_init_bits;
        maxcode := 1 shl n_bits - 1;
        clear_flg := 0;
      end
      else
      begin
        inc(n_bits);
        if (n_bits = maxbits) then
          maxcode := maxmaxcode
        else
          maxcode := 1 shl n_bits - 1;
      end;
    end;
    if (code = EOFCode) then
    begin
      while (cur_bits > 0) do
      begin
        char_out(lzwr, integer(cur_accum and $FF));
        cur_accum := cur_accum shr 8;
        dec(cur_bits, 8);
      end;
      flush_char(lzwr);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure cl_block(var lzwr: TLZWCompRecord);
begin
  {$ifdef IEPROFILE} try IEProfileBegin('cl_block'); {$endif}
  with lzwr do
  begin
    cl_hash(lzwr, integer(hsize));
    free_ent := ClearCode + 2;
    clear_flg := 1;
    output(lzwr, integer(ClearCode));
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure lzwcompress(var lzwr: TLZWCompRecord);
label
  probe, nomatch;
var
  fcode: integer;
  i: integer;
  c: integer;
  ent: integer;
  disp: integer;
  hsize_reg: integer;
  hshift: integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('lzwcompress'); {$endif}
  with lzwr do
  begin
    g_init_bits := init_bits;
    offset := 0;
    out_count := 0;
    clear_flg := 0;
    in_count := 1;
    n_bits := init_bits;
    maxcode := 1 shl n_bits - 1;
    ClearCode := (1 shl (lzwr.init_bits - 1));
    EOFCode := ClearCode + 1;
    free_ent := ClearCode + 2;
    a_count := 0;
    ent := GIFNextPixel(lzwr);
    hshift := 0;
    fcode := hsize;
    while fcode < 65536 do
    begin
      inc(hshift);
      fcode := fcode * 2;
    end;
    hshift := 8 - hshift;
    hsize_reg := hsize;
    cl_hash(lzwr, hsize_reg);
    output(lzwr, ClearCode);
    while (true) do
    begin
      c := GIFNextPixel(lzwr);
      if c = XEOF then
        break;
      inc(in_count);
      fcode := (c shl maxbits) + ent;
      i := (c shl hshift) xor ent;
      if (lzwr.htab[i] = fcode) then
      begin
        ent := codetab[i];
        continue;
      end
      else if (integer(htab[i]) < 0) then
        goto nomatch;
      if (i = 0) then
        disp := 1
      else
        disp := hsize_reg - i;
      probe:
      dec(i, disp);
      if (i < 0) then
        inc(i, hsize_reg);
      if (htab[i] = fcode) then
      begin
        ent := codetab[i];
        continue;
      end;
      if (integer(htab[i]) > 0) then
        goto probe;
      nomatch:
      output(lzwr, integer(ent));
      inc(out_count);
      ent := c;
      if (free_ent < maxmaxcode) then
      begin
        codetab[i] := free_ent;
        inc(free_ent);
        htab[i] := fcode;
      end
      else
        cl_block(lzwr);
    end;
    output(lzwr, integer(ent));
    inc(out_count);
    output(lzwr, integer(EOFCode));
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure GIFLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar; BitsPerPixel: integer);
var
  lzwr: PLZWCompRecord;
  InitCodeSize: integer;
  bb: byte;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GIFLZWCompress'); {$endif}
  new(lzwr);
  lzwr^.Interlace := Interlaced;
  lzwr^.Width := Width;
  lzwr^.Height := Height;
  lzwr^.data := pbyte(FData);
  lzwr^.cur_accum := 0;
  lzwr^.cur_bits := 0;
  lzwr^.CountDown := Width * Height;
  lzwr^.Pass := 0;
  lzwr^.free_ent := 0;
  if (BitsPerPixel <= 1) then
    InitCodeSize := 2
  else
    InitCodeSize := BitsPerPixel;
  lzwr^.curx := 0;
  lzwr^.cury := 0;
  lzwr^.px := pbyte(fdata);
  //
  bb := InitCodeSize;
  Stream.Write(bb, 1);
  lzwr^.init_bits := InitCodeSize + 1;
  lzwr^.os := Stream;
  lzwcompress(lzwr^);
  bb := 0;
  Stream.Write(bb, 1);
  dispose(lzwr);
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

{$IFDEF RangeCheck}{$R+}{$UNDEF RangeCheck}{$ENDIF}

end.