tiflzw.pas

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

// 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 - 1;
  HSIZE = 5003;
  XEOF = -1;

type
  TLZWCompRecord = record
    inpos: integer;
    oStream: TStream;
    CountDown: integer;
    indata: pbyte;
    init_bits: integer;
    n_bits: integer;
    maxcode: integer;
    ClearCode: integer;
    EOFCode: integer;
    free_ent: integer;
    clear_flg: integer;
    a_count: integer;
    htab: array[0..HSIZE - 1] of integer;
    codetab: array[0..HSIZE - 1] of word;
    cur_accum: dword;
    cur_bits: integer;
    accum: array[0..255] of char;
    g_init_bits: integer;
    _fcode: integer;
    _i: integer;
    _c: integer;
    _ent: integer;
    _disp: integer;
    _hsize_reg: integer;
    _hshift: integer;
  end;
  PLZWCompRecord = ^TLZWCompRecord;

function NextPixel(var lzwr: TLZWCompRecord): integer;
begin
  with lzwr do
  begin
    if (CountDown = 0) then
    begin
      result := XEOF;
      exit;
    end;
    dec(CountDown);
    result := pbyte(integer(indata) + inpos)^;
    inc(inpos);
  end;
end;

procedure cl_hash(var lzwr: TLZWCompRecord; hsize: integer);
var
  htab_p: pinteger;
  i, m1: integer;
begin
  htab_p := @(lzwr.htab[0]);
  inc(htab_p, hsize);
  m1 := -1;
  i := hsize - 16;
  repeat
    pinteger(integer(htab_p) - 4 * 16)^ := m1;
    pinteger(integer(htab_p) - 4 * 15)^ := m1;
    pinteger(integer(htab_p) - 4 * 14)^ := m1;
    pinteger(integer(htab_p) - 4 * 13)^ := m1;
    pinteger(integer(htab_p) - 4 * 12)^ := m1;
    pinteger(integer(htab_p) - 4 * 11)^ := m1;
    pinteger(integer(htab_p) - 4 * 10)^ := m1;
    pinteger(integer(htab_p) - 4 * 9)^ := m1;
    pinteger(integer(htab_p) - 4 * 8)^ := m1;
    pinteger(integer(htab_p) - 4 * 7)^ := m1;
    pinteger(integer(htab_p) - 4 * 6)^ := m1;
    pinteger(integer(htab_p) - 4 * 5)^ := m1;
    pinteger(integer(htab_p) - 4 * 4)^ := m1;
    pinteger(integer(htab_p) - 4 * 3)^ := m1;
    pinteger(integer(htab_p) - 4 * 2)^ := m1;
    pinteger(integer(htab_p) - 4 * 1)^ := m1;
    dec(htab_p, 16);
    dec(i, 16);
  until not (i >= 0);
  inc(i, 16);
  while i > 0 do
  begin
    dec(htab_p);
    htab_p^ := m1;
    dec(i);
  end;
end;

procedure flush_char(var lzwr: TLZWCompRecord);
begin
  with lzwr do
  begin
    if (a_count > 0) then
    begin
      oStream.Write(accum[0], a_count);
      a_count := 0;
    end;
  end;
end;

procedure char_out(var lzwr: TLZWCompRecord; c: integer);
begin
  with lzwr do
  begin
    accum[a_count] := char(c);
    inc(a_count);
    if (a_count >= 254) then
      flush_char(lzwr);
  end;
end;

procedure output(var lzwr: TLZWCompRecord; code: integer);
const
  masks: array[0..16] of integer = ($0000, $8000, $C000, $E000, $F000,
    $F800, $FC00, $FE00, $FF00, $FF80,
    $FFC0, $FFE0, $FFF0, $FFF8, $FFFC,
    $FFFE, $FFFF);
begin
  with lzwr do
  begin
    cur_accum := cur_accum and (((1 shl cur_bits) - 1) shl (32 - cur_bits));
    if (cur_bits > 0) then
      cur_accum := cur_accum or dword(code shl (32 - n_bits - cur_bits))
    else
      cur_accum := code shl dword(32 - n_bits);
    inc(cur_bits, n_bits);
    while (cur_bits >= 8) do
    begin
      char_out(lzwr, dword(cur_accum and $FF000000) shr 24);
      cur_accum := cur_accum shl 8;
      dec(cur_bits, 8);
    end;
    if (free_ent > maxcode - 1) 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, dword(cur_accum and $FF000000) shr 24);
        cur_accum := cur_accum shl 8;
        dec(cur_bits, 8);
      end;
      flush_char(lzwr);
    end;
  end;
end;

procedure cl_block(var lzwr: TLZWCompRecord);
begin
  with lzwr do
  begin
    cl_hash(lzwr, integer(hsize));
    free_ent := ClearCode + 2;
    clear_flg := 1;
    output(lzwr, integer(ClearCode));
  end;
end;

// op=0 initialize/encode
// op=1 encode
// op=2 finalize

procedure lzwcompress(var lzwr: TLZWCompRecord; op: integer);
label
  probe, nomatch;
begin
  with lzwr do
  begin
    if op = 0 then
    begin
      // initialize
      g_init_bits := init_bits;
      clear_flg := 0;
      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 := NextPixel(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);
    end;
    if (op = 0) or (op = 1) then
    begin
      // encoding
      while (true) do
      begin
        _c := NextPixel(lzwr);
        if _c = XEOF then
          break;
        _fcode := integer(((integer(_c) shl maxbits) + _ent));
        _i := ((integer(_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;
        _disp := _hsize_reg - _i;
        if (_i = 0) then
          _disp := 1;
        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));
        _ent := _c;
        if (free_ent < maxmaxcode - 1) then
        begin
          codetab[_i] := free_ent;
          inc(free_ent);
          htab[_i] := _fcode;
        end
        else
          cl_block(lzwr);
      end;
    end
    else if op = 2 then
    begin
      // finalize
      output(lzwr, integer(_ent));
      output(lzwr, integer(EOFCode));
    end;
  end;
end;

// indata: decompressed data
// inputlen: indata length (in bytes)
// outstream: compressed data
// Id: is a reference variable (where I store the pointer to TLZWCompRecord object)
// IMPORTANT:
//		- In the first call "Id" is ZERO.
//    - In the nexts call "Id" will be the some returned in the first call
//		- In the last call "indata" will be NIL (you will free your allocated objects)

procedure TIFFLZWCompress(indata: pbyte; inputlen: integer; outstream: TStream; var id: integer);
var
  lzwr: PLZWCompRecord;
begin
  if id = 0 then
  begin
    // initialize/encode
    new(lzwr);
    lzwr^.indata := pbyte(indata);
    lzwr^.oStream := outstream;
    lzwr^.cur_accum := 0;
    lzwr^.cur_bits := 0;
    lzwr^.CountDown := inputlen;
    lzwr^.free_ent := 0;
    lzwr^.inpos := 0;
    lzwr^.init_bits := 8 + 1;
    lzwcompress(lzwr^, 0);
    id := integer(lzwr)
  end
  else if id <> 0 then
  begin
    lzwr := PLZWCompRecord(id);
    if indata = nil then
    begin
      // finalize
      lzwcompress(lzwr^, 2);
      dispose(lzwr)
    end
    else
    begin
      // continue encoding
      lzwr^.CountDown := inputlen;
      lzwr^.indata := pbyte(indata);
      lzwr^.inpos := 0;
      lzwcompress(lzwr^, 1);
    end;
  end;
end;

end.