1175 lines
26 KiB
Plaintext
1175 lines
26 KiB
Plaintext
(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
|
|
(*
|
|
File version 1003
|
|
*)
|
|
|
|
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: PAnsiChar; BitsPerPixel: integer);
|
|
procedure GIFNONLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: PAnsiChar; BitsPerPixel: integer);
|
|
|
|
// Decompression
|
|
procedure GIFLZWDecompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: PAnsiChar);
|
|
|
|
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;
|
|
|
|
function GetNL(LineNo, Height: Integer; var InterlacePass: Integer; var Step: integer): Integer;
|
|
begin
|
|
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);
|
|
end;
|
|
|
|
function InitCompressionStream(InitLZWCodeSize: Byte; var DecData: TDecodeData): boolean;
|
|
begin
|
|
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;
|
|
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
|
|
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);
|
|
inc(BitsLeft, 8);
|
|
end;
|
|
dec(BitsLeft, CurrCodeSize);
|
|
Result := LongResult and CodeMsk[CurrCodeSize];
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure GIFLZWDecompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: PAnsiChar);
|
|
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
|
|
while Code > DecData.HighCode do
|
|
begin
|
|
DecodeDat[SP] := Suffix[Code];
|
|
inc(SP);
|
|
Code := Prefix[Code];
|
|
end;
|
|
DecodeDat[SP] := Code;
|
|
Inc(SP);
|
|
end;
|
|
procedure GetDat;
|
|
begin
|
|
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(FData);
|
|
inc(px, PosY * Width + CurrBuf - 1);
|
|
end;
|
|
end;
|
|
end;
|
|
procedure CheckprtValue(var prt, Topprt: Word);
|
|
begin
|
|
if (prt >= Topprt) and (DecData.CurrCodeSize < 12) then
|
|
begin
|
|
Topprt := Topprt shl 1;
|
|
inc(DecData.CurrCodeSize)
|
|
end;
|
|
end;
|
|
|
|
var
|
|
TempOldCode, OldCode: word;
|
|
Code, C: word;
|
|
prt: Word;
|
|
Topprt: Word;
|
|
b, v: byte;
|
|
spos: int64;
|
|
begin
|
|
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(Stream.Size - Stream.Position);
|
|
|
|
try
|
|
|
|
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;
|
|
if DecData.ReadPos >= DecData.DataLen then
|
|
exit;
|
|
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
|
|
exit;
|
|
C := NextCode(CompData, DecData);
|
|
end;
|
|
if C = DecData.EndingCode then
|
|
begin
|
|
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 <= 4095 then
|
|
begin
|
|
Suffix[prt] := Code;
|
|
Prefix[prt] := OldCode;
|
|
inc(prt);
|
|
CheckprtValue(prt, Topprt);
|
|
OldCode := C;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if Code <> prt then
|
|
begin
|
|
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);
|
|
end;
|
|
DecodeCode(Code);
|
|
OldCode := C;
|
|
end;
|
|
end;
|
|
GetDat;
|
|
if DecData.ReadPos >= DecData.DataLen then
|
|
exit;
|
|
C := NextCode(CompData, DecData);
|
|
end;
|
|
|
|
finally
|
|
CompData.Free();
|
|
end;
|
|
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
|
|
* info@hasc.com
|
|
*
|
|
* 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
|
|
* mouse@rodents.montreal.qc.ca
|
|
* 7D C8 61 52 5D E7 2D 39 4E F1 31 3E E8 B3 27 4B
|
|
*
|
|
* ivo@hasc.com
|
|
*
|
|
* 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
|
|
if (x < 2) then
|
|
begin
|
|
result := x;
|
|
exit;
|
|
end;
|
|
v := x;
|
|
r := 1;
|
|
while v <> 0 do
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure did_clear(var vb: varblk);
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure write_block(var vb: varblk);
|
|
begin
|
|
with vb do
|
|
begin
|
|
ofile.Write(oblen, 1);
|
|
ofile.Write(oblock[0], oblen);
|
|
oblen := 0;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure block_out(var vb: varblk; c: byte);
|
|
begin
|
|
with vb do
|
|
begin
|
|
oblock[oblen] := c;
|
|
inc(oblen);
|
|
if (oblen >= 255) then
|
|
write_block(vb);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure goutput(var vb: varblk; val: integer);
|
|
begin
|
|
{$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}
|
|
end;
|
|
|
|
|
|
procedure output_plain(var vb: varblk; c: integer);
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure reset_out_clear(var vb: varblk);
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure rl_flush_fromclear(var vb: varblk; count: integer);
|
|
var
|
|
n: integer;
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
function computetc(count: dword; nrepcodes: dword): dword;
|
|
var
|
|
perrep: dword;
|
|
n: dword;
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure rl_flush_clearorrep(var vb: varblk; count: integer);
|
|
var
|
|
withclr: integer;
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
procedure rl_flush_withtable(var vb: varblk; count: integer);
|
|
var
|
|
repmax: integer;
|
|
repleft: integer;
|
|
leftover: integer;
|
|
begin
|
|
{$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}
|
|
end;
|
|
|
|
|
|
procedure rl_flush(var vb: varblk);
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
|
|
function GetNextPixel(var vb: varblk): integer;
|
|
begin
|
|
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 := Data;
|
|
inc(Datap, y * iWidth);
|
|
|
|
end;
|
|
result := Datap^;
|
|
inc(Datap);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure GIFNONLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: PAnsiChar; BitsPerPixel: integer);
|
|
var
|
|
b: byte;
|
|
c, bufdim: integer;
|
|
vb: varblk;
|
|
bufpos: integer;
|
|
begin
|
|
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)
|
|
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);
|
|
end;
|
|
|
|
|
|
/////////////////////////////////////////////////////////////////////////////////////////////
|
|
/////////////////////////////////////////////////////////////////////////////////////////////
|
|
/////////////////////////////////////////////////////////////////////////////////////////////
|
|
|
|
// Original C code:
|
|
// ppmtogif.c - read a portable pixmap and produce a GIF file
|
|
//
|
|
// Based on GIFENCOD by David Rowley <mgardi@watdscu.waterloo.edu>.A
|
|
// Lempel-Zim compression based on "compress".
|
|
//
|
|
// Modified by Marcel Wijkstra <wijkstra@fwi.uva.nl>
|
|
//
|
|
//
|
|
// 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 AnsiChar;
|
|
os: TStream;
|
|
g_init_bits: integer;
|
|
end;
|
|
PLZWCompRecord = ^TLZWCompRecord;
|
|
|
|
procedure BumpPixel(var lzwr: TLZWCompRecord);
|
|
begin
|
|
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 := data;
|
|
inc(px, cury * Width);
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GIFNextPixel(var lzwr: TLZWCompRecord): integer;
|
|
begin
|
|
with lzwr do
|
|
if (CountDown = 0) then
|
|
result := XEOF
|
|
else
|
|
begin
|
|
dec(CountDown);
|
|
result := px^;
|
|
BumpPixel(lzwr);
|
|
end;
|
|
end;
|
|
|
|
procedure cl_hash(var lzwr: TLZWCompRecord; hsize: integer);
|
|
var
|
|
htab_p: pinteger;
|
|
i: integer;
|
|
begin
|
|
htab_p := @(lzwr.htab[0]);
|
|
inc(htab_p, hsize);
|
|
i := hsize - 16;
|
|
repeat
|
|
pinteger(uint64(htab_p) - 64)^ := -1;
|
|
pinteger(uint64(htab_p) - 60)^ := -1;
|
|
pinteger(uint64(htab_p) - 56)^ := -1;
|
|
pinteger(uint64(htab_p) - 52)^ := -1;
|
|
pinteger(uint64(htab_p) - 48)^ := -1;
|
|
pinteger(uint64(htab_p) - 44)^ := -1;
|
|
pinteger(uint64(htab_p) - 40)^ := -1;
|
|
pinteger(uint64(htab_p) - 36)^ := -1;
|
|
pinteger(uint64(htab_p) - 32)^ := -1;
|
|
pinteger(uint64(htab_p) - 28)^ := -1;
|
|
pinteger(uint64(htab_p) - 24)^ := -1;
|
|
pinteger(uint64(htab_p) - 20)^ := -1;
|
|
pinteger(uint64(htab_p) - 16)^ := -1;
|
|
pinteger(uint64(htab_p) - 12)^ := -1;
|
|
pinteger(uint64(htab_p) - 8)^ := -1;
|
|
pinteger(uint64(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;
|
|
end;
|
|
|
|
procedure flush_char(var lzwr: TLZWCompRecord);
|
|
var
|
|
bb: byte;
|
|
begin
|
|
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;
|
|
end;
|
|
|
|
procedure char_out(var lzwr: TLZWCompRecord; c: integer);
|
|
begin
|
|
with lzwr do
|
|
begin
|
|
accum[a_count] := AnsiChar(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, $0001, $0003, $0007, $000F,
|
|
$001F, $003F, $007F, $00FF,
|
|
$01FF, $03FF, $07FF, $0FFF,
|
|
$1FFF, $3FFF, $7FFF, $FFFF);
|
|
begin
|
|
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;
|
|
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;
|
|
|
|
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
|
|
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;
|
|
end;
|
|
|
|
procedure GIFLZWCompress(Stream: TStream; Height, Width: integer; Interlaced: boolean; FData: PAnsiChar; BitsPerPixel: integer);
|
|
var
|
|
lzwr: PLZWCompRecord;
|
|
InitCodeSize: integer;
|
|
bb: byte;
|
|
begin
|
|
new(lzwr);
|
|
try
|
|
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);
|
|
|
|
finally
|
|
dispose(lzwr);
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF RangeCheck}{$R+}{$UNDEF RangeCheck}{$ENDIF}
|
|
|
|
end.
|
|
|