Listing 18

//das Beispiel zeigt die Kompression nach dem LZSS Algorhithmus, der eine Erweiterung des
//LZ77 ist
//im Unterschied zum LZ77 wird hier geprüft, ob die Länge des Kompr.'zeigers nicht größer der
//Länge der Zeichen ist, auf die der Kompr.'zeiger zeigt
//es wird ein ID-Bit eingeführt, welches bei der Dekompression angibt ob ein Zeiger oder ein
//einzelnes Zeichen folgt

unit LZSS;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TCompress = record //Struktur des Kompressionszeigers
     Pos: Word;
     Len: Byte;
     Car: Char;
  end;
  
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Edit1: TEdit;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

const
  Bits: array[0..7] of Byte = (1, 2, 4, 8, 16, 32, 64, 128);

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure SetBits(var b: string; bitco: Word; isset: Boolean);
var byt, bit: Byte;

begin
if Length(b)<(bitco div 8)+1 then b:=b+chr(0);

byt:=ord(b[(bitco div 8)+1]);
bit:=bitco-(bitco div 8)*8; 

if isset then
begin
   if (byt and Bits[bit])=0 then byt:=byt+Bits[bit];
end
else
begin
   if (byt and Bits[bit])<>0 then byt:=byt-Bits[bit];
end;

b[(bitco div 8)+1]:=chr(byt);
end;

function GetBits(b: string; bitco: Word): Boolean;
var byt, bit: Byte;

begin
byt:=ord(b[(bitco div 8)+1]);
bit:=bitco-(bitco div 8)*8;

result:=((byt and Bits[bit])<>0);
end;

procedure LZSSCompress(ofn, sfn: string);
var fo, fs: file;
    fsize: Integer;
    cv, vv, po, posps, bitco, bl: Word;
    s, p, b: string;
    buf: array[1..High(Word)] of Char;
    Temp: TCompress;

begin   

AssignFile(fo, ofn);
{$I-}
Reset(fo, 1);
{$I+}

AssignFile(fs, sfn);
{$I-}
Rewrite(fs, 1);
{$I+}

if IOResult = 0 then
begin
//Achtung: das Beispiel kann nur Dateigrößen <= High(Word) bearbeiten !!!
fsize:=FileSize(fo);
BlockRead(fo, buf, fsize);

s:=buf;

cv:=1; vv:=0; po:=0; b:=''; bitco:=0;
while cv<=fsize do
begin
   p:=Copy(s, vv+1, cv-vv);
   posps:=Pos(p, s);
   if (cv<fsize) and (Length(p)<256) and (posps>0) and (posps<=(vv+1)-Length(p)) then
      po:=posps
   else
   begin
      Temp.Pos:=po;
      Temp.Len:=Length(p)-1;
      Temp.Car:=s[cv];
      if Temp.Len>3 then
      begin
         SetBits(b, bitco, True);
         BlockWrite(fs, Temp, sizeof(TCompress));
      end
      else
      begin
         SetBits(b, bitco, False);
         BlockWrite(fs, p[1], sizeof(Char));
         cv:=vv+1;
      end;
      inc(bitco);
      
      vv:=cv; po:=0; 
   end;

   inc(cv);
end;

BlockWrite(fs, b[1], Length(b)); 
BlockWrite(fs, bitco, sizeof(Word)); 
end;

CloseFile(fo);
CloseFile(fs); 
end;

procedure LZSSDeCompress(ofn, sfn: string);
var fo, fs: file;
    fsize: Integer;
    cv, vv, bitco, bl: Word;
    s, p, b: string;
    buf: array[1..High(Word)] of Char;
    Temp: TCompress;

begin

AssignFile(fo, ofn);
{$I-}
Reset(fo, 1);
{$I+}

AssignFile(fs, sfn);
{$I-}
Rewrite(fs, 1);
{$I+}

if IOResult = 0 then
begin
fsize:=FileSize(fo);

Seek(fo, fsize-sizeof(Word));
BlockRead(fo, bitco, sizeof(Word)); bl:=bitco div 8; if bitco<>(bitco div 8)*8 then inc(bl);
Seek(fo, fsize-sizeof(Word)-bl);
BlockRead(fo, buf, bl);

b:=buf; 

Seek(fo, 0);

s:='';

for cv:=0 to bitco-1 do
begin
   if GetBits(b, cv) then
   begin
      BlockRead(fo, Temp, sizeof(TCompress));
      p:='';
      p:=Copy(s, Temp.Pos, Temp.Len);
      p:=p+Temp.Car;
   end
   else
   begin
      p:=chr(0);
      BlockRead(fo, p[1], sizeof(Char));
   end;

   s:=s+p;
end;

BlockWrite(fs, s[1], Length(s));
end;

CloseFile(fo);
CloseFile(fs); 
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
caption:='Kompression ...';
LZSSCompress(Edit1.Text, ChangeFileExt(Edit1.Text, '.cmp'));
caption:='OK';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
caption:='Dekompression ...';
LZSSDeCompress(ChangeFileExt(Edit1.Text, '.cmp'), ChangeFileExt(Edit1.Text, 'Kopie'+ExtractFileExt(Edit1.Text)));
caption:='OK';
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
if OpenDialog1.execute then
   Edit1.Text:=OpenDialog1.FileName;
end;

end.