giflzw.pas

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

unit giflzw;

{$R-}
{$Q-}

// Example of GIF LZW, NONLZW compression and LZW decompression plug-in for ImageEn

{$I ie.inc}

interface

uses Windows, Graphics, classes, sysutils, hyieutils, hyiedefs;

// Compression
procedure GIFLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar; BitsPerPixel: integer);
procedure GIFNONLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar; BitsPerPixel: integer);

// Decompression
procedure GIFLZWDecompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar);

implementation

{$R-}

/////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////////////////////
// Standard LZW Decompression

{$IFOPT R+}{$DEFINE RangeCheck}{$ENDIF}{$R-}

type

  TDecodeData = record
    ReadPos: integer;
    DataLen: integer;
    BitsLeft: Integer;
    CurrByte: Longint;
    PosY: Integer;
    InterlacePass: Integer;
    Step: integer;
    LZWCodeSize: Byte;
    CurrCodeSize: Integer;
    ClearCode: Integer;
    EndingCode: Integer;
    HighCode: Word;
  end;

  TCodeTable = record
    Suffix, Prefix: array[1..4096] of Word;
    CodeSize: Byte;
    TableFull: Boolean;
    Firstprt, Nextprt: Word;
  end;

function GetNL(LineNo, Height: Integer; var InterlacePass: Integer; var Step: integer): Integer;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GetNL'); {$endif}
  result := LineNo;
  Inc(result, step);
  if (result >= height) then
    repeat
      if (Interlacepass > 0) then
        step := step shr 1;
      Inc(Interlacepass);
      result := step shr 1;
    until (result < height);
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

function InitCompressionStream(InitLZWCodeSize: Byte; var DecData: TDecodeData): boolean;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('InitCompressionStream'); {$endif}
  result := true;
  with DecData do
  begin
    LZWCodeSize := InitLZWCodeSize;
    if not (LZWCodeSize in [2..9]) then
    begin
      result := false;
      exit;
    end;
    CurrCodeSize := succ(LZWCodeSize);
    ClearCode := 1 shl LZWCodeSize;
    EndingCode := succ(ClearCode);
    HighCode := pred(ClearCode);
    BitsLeft := 0;
    PosY := 0;
    InterlacePass := 0;
    Step := 8;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

function NextCode(var ba: TIEByteArray; var DecData: TDecodeData): word;
const
  CodeMsk: array[0..12] of Word = (
    0, $0001, $0003, $0007, $000F,
    $001F, $003F, $007F, $00FF,
    $01FF, $03FF, $07FF, $0FFF);
var
  LongResult: Longint;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('NextCode'); {$endif}
  with DecData do
  begin
    if BitsLeft = 0 then
    begin
      CurrByte := ba.Data^[ReadPos];
      inc(ReadPos);
      BitsLeft := 8;
    end;
    LongResult := CurrByte shr (8 - BitsLeft);
    while CurrCodeSize > BitsLeft do
    begin
      CurrByte := ba.Data^[ReadPos];
      inc(ReadPos);
      LongResult := LongResult or (CurrByte shl BitsLeft);
      BitsLeft := BitsLeft + 8;
    end;
    BitsLeft := BitsLeft - CurrCodeSize;
    Result := LongResult and CodeMsk[CurrCodeSize];
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

procedure GIFLZWDecompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: pchar);
var
  SP: integer;
  DecodeDat: array[0..4095] of byte;
  DecData: TDecodeData;
  Prefix: array[0..4095] of integer;
  Suffix: array[0..4095] of integer;
  CurrBuf: word;
  px: pbyte;
  LZWCodeSize: byte;
  CompData: TIEByteArray;
  procedure DecodeCode(var Code: word);
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('GIFLZWDecompress.DecodeCode'); {$endif}
    while Code > DecData.HighCode do
    begin
      DecodeDat[SP] := Suffix[Code];
      inc(SP);
      Code := Prefix[Code];
    end;
    DecodeDat[SP] := Code;
    Inc(SP);
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
  procedure GetDat;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('GIFLZWDecompress.GetDat'); {$endif}
    with DecData do
      while SP > 0 do
      begin
        dec(SP);
        if posy < height then
          px^ := decodedat[sp];
        inc(px);
        inc(CurrBuf);
        if CurrBuf > Width then
        begin
          if not InterLaced then
            Inc(PosY)
          else
            PosY := GetNL(PosY, Height, InterlacePass, Step);
          CurrBuf := 1;
          px := pbyte(integer(fData) + PosY * Width + CurrBuf - 1);
        end;
      end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
  procedure CheckprtValue(var prt, Topprt: Word; var MaxVal: Boolean);
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('GIFLZWDecompress.CheckprtValue'); {$endif}
    if prt >= Topprt then
    begin
      if DecData.CurrCodeSize < 12 then
      begin
        Topprt := Topprt shl 1;
        inc(DecData.CurrCodeSize)
      end
      else
        MaxVal := True;
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;

var
  TempOldCode, OldCode: word;
  Code, C: word;
  MaxVal: boolean;
  prt: Word;
  Topprt: Word;
  b, v: byte;
  spos: int64;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('GIFLZWDecompress'); {$endif}
  spos := Stream.Position;
  //
  Stream.Read(LZWCodeSize, 1);
  px := pbyte(fdata);
  if not InitCompressionStream(LZWCodeSize, DecData) then
  begin
    Stream.Position := spos; // reset position indicates an error
    exit;
  end;
  DecData.DataLen := 0;
  CompData := TIEByteArray.Create;
  repeat
    if (Stream.Read(b, 1) = 0) then
      break;
    if b = 0 then
      break;
    v := CompData.AppendFromStream(Stream, b);
    DecData.DataLen := DecData.DataLen + v;
  until false;
  DecData.ReadPos := 0;
  OldCode := 0;
  SP := 0;
  CurrBuf := 1;
  MaxVal := False;
  if DecData.ReadPos >= DecData.DataLen then
  begin
    FreeAndNil(CompData);
    exit;
  end;
  C := NextCode(CompData, DecData);
  while C <> DecData.EndingCode do
  begin
    if C = DecData.ClearCode then
    begin
      DecData.CurrCodeSize := DecData.LZWCodeSize + 1;
      prt := DecData.EndingCode + 1;
      Topprt := 1 shl DecData.CurrCodeSize;
      while C = DecData.ClearCode do
      begin
        if DecData.ReadPos >= DecData.DataLen then
        begin
          FreeAndNil(CompData);
          exit;
        end;
        C := NextCode(CompData, DecData);
      end;
      if C = DecData.EndingCode then
      begin
        FreeAndNil(CompData);
        if DecData.ReadPos < DecData.DataLen then
          Stream.Position := spos; // reset position indicates an error
        exit;
      end;
      if C >= prt then
        C := 0;
      OldCode := C;
      DecodeDat[SP] := C;
      inc(SP);
    end
    else
    begin
      Code := C;
      if Code < prt then
      begin
        DecodeCode(Code);
        if prt <= Topprt then
        begin
          Suffix[prt] := Code;
          Prefix[prt] := OldCode;
          inc(prt);
          CheckprtValue(prt, Topprt, MaxVal);
          OldCode := C;
        end;
      end
      else
      begin
        if Code <> prt then
        begin
          FreeAndNil(CompData);
          Stream.Position := spos; // reset position indicates an error
          exit;
        end;
        TempOldCode := OldCode;
        while OldCode > DecData.HighCode do
        begin
          DecodeDat[SP] := Suffix[OldCode];
          OldCode := Prefix[OldCode];
        end;
        DecodeDat[SP] := OldCode;
        if prt <= Topprt then
        begin
          Suffix[prt] := OldCode;
          Prefix[prt] := TempOldCode;
          inc(prt);
          CheckprtValue(prt, Topprt, MaxVal);
        end;
        DecodeCode(Code);
        OldCode := C;
      end;
    end;
    GetDat;
    if DecData.ReadPos >= DecData.DataLen then
    begin
      FreeAndNil(CompData);
      exit;
    end;
    C := NextCode(CompData, DecData);
    if (MaxVal = True) and (C <> DecData.ClearCode) then
    begin
      FreeAndNil(CompData);
      Stream.Position := spos; // reset position indicates an error
      exit;
    end;
    MaxVal := False;
  end;
  FreeAndNil(CompData);
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

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

(*-----------------------------------------------------------------------
 *
 * miGIF Compression - mouse and ivo's GIF-compatible compression
 *
 *          -run length encoding compression routines-
 *
 * Copyright (C) 1998 Hutchison Avenue Software Corporation
 *               http://www.hasc.com
 *               [e-mail]
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies and that both that
 * copyright notice and this permission notice appear in supporting
 * documentation.  This software is provided "AS IS." The Hutchison Avenue
 * Software Corporation disclaims all warranties, either express or implied,
 * including but not limited to implied warranties of merchantability and
 * fitness for a particular purpose, with respect to this code and accompanying
 * documentation.
 *
 * The miGIF compression routines do not, strictly speaking, generate files
 * conforming to the GIF spec, since the image data is not LZW-compressed
 * (this is the point: in order to avoid transgression of the Unisys patent
 * on the LZW algorithm.)  However, miGIF generates data streams that any
 * reasonably sane LZW decompresser will decompress to what we want.
 *
 * miGIF compression uses run length encoding. It compresses horizontal runs
 * of pixels of the same color. This type of compression gives good results
 * on images with many runs, for example images with lines, text and solid
 * shapes on a solid-colored background. It gives little or no compression
 * on images with few runs, for example digital or scanned photos.
 *
 *                               der Mouse
 *                      [e-mail]
 *            7D C8 61 52 5D E7 2D 39  4E F1 31 3E E8 B3 27 4B
 *
 *                             [e-mail]
 *
 * The Graphics Interchange Format(c) is the Copyright property of
 * CompuServe Incorporated.  GIF(sm) is a Service Mark property of
 * CompuServe Incorporated.
 *
 *
*)

type
  varblk = record
    rl_pixel: integer;
    rl_basecode: integer;
    rl_count: integer;
    rl_table_pixel: integer;
    rl_table_max: integer;
    just_cleared: integer;
    out_bits: integer;
    out_bits_init: integer;
    out_count: integer;
    out_bump: integer;
    out_bump_init: integer;
    out_clear: integer;
    out_clear_init: integer;
    max_ocodes: integer;
    code_clear: integer;
    code_eof: integer;
    obuf: dword;
    obits: integer;
    ofile: TStream;
    oblock: array[0..255] of byte;
    oblen: integer;
    //
    Data, Datap: pbyte;
    // interlaced
    fInterlaced: boolean;
    Pass, wlen, y, x: integer;
    iwidth, iheight: integer;
  end;

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

function isqrt(x: dword): dword;
var
  r: dword;
  v: dword;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('isqrt'); {$endif}
  if (x < 2) then
  begin
    result := x;
    exit;
  end;
  v := x;
  r := 1;
  while v <> 0 do