DelphiList19

Listing 19

//das Listing verdeutlicht eine Möglichkeit Daten nach dem RLE
//(run length encoding = Lauflängencodierung) Verfahren zu komprimieren

unit RLE;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Button3: TButton;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

function RunLengthCompress(s: string): string;
var cv, vv, po, co: Word;

begin //Längenbyte: 0-127 -> x gleiche Zeichen; 128-255 -> x ungleiche Zeichen folgen

if Length(s)<3 then begin result:=s; Exit; end;

cv:=1; vv:=1; result:='';
while cv<=Length(s) do
begin

   if s[cv]=Copy(s, cv+1, 1) then
   begin
      if cv-vv>0 then
      begin
         co:=cv-vv;
         while co>127 do begin result:=result+chr(127+128)+Copy(s, vv, 127); co:=co-127; vv:=vv+127; end;
         result:=result+chr(co+128)+Copy(s, vv, co);
         vv:=cv;
      end;

      //cv und cv+1 gleich -> mind. 2 gleiche Zeichen gefunden
      for po:=cv+1 to Length(s) do
         if s[po]<>Copy(s, po+1, 1) then
         begin
            co:=po-vv+1;
            while co>127 do begin result:=result+chr(127)+s[cv]; co:=co-127; vv:=vv+127; end;
            result:=result+chr(co)+s[cv];
            cv:=po;
            vv:=po+1;
            Break;
         end;
   end;

   if (cv=Length(s)) and (vv<=Length(s)) then
   begin
      co:=cv-vv+1;
      while co>127 do begin result:=result+chr(127+128)+Copy(s, vv, 127); co:=co-127; vv:=vv+127; end;
      result:=result+chr(co+128)+Copy(s, vv, co);
   end;

   inc(cv);
end;

end;

function RunLengthDeCompress(s: string): string;
var cv, vv, co: Word;

begin

result:='';

if Length(s)<2 then begin result:=s; Exit; end;

cv:=1;
while cv<=Length(s) do
begin
   co:=ord(s[cv]);

   if co<128 then
   begin
      if co=0 then begin inc(cv); Continue; end;

      for vv:=1 to co do
         result:=result+s[cv+1];

      cv:=cv+2;
   end
   else
   begin
      co:=co-128;

      for vv:=cv+1 to cv+co do
         result:=result+s[vv];

      cv:=cv+(co+1);
   end;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);
var fo, fs: file;
    fsize: Integer;
    ofn, sfn, s: string;
    c: array[1..High(Word)] of Char;

begin
caption:='Kompression ...';

ofn:=Edit1.Text;
sfn:=ChangeFileExt(Edit1.Text, '.cmp');

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, c, fsize);

s:=c;
s:=RunLengthCompress(Copy(s, 1, fsize));
BlockWrite(fs, s[1], Length(s));
end;

CloseFile(fo);
CloseFile(fs);

caption:='OK';
end;

procedure TForm1.Button2Click(Sender: TObject);
var fo, fs: file;
    fsize: Integer;
    ofn, sfn, s: string;
    c: array[1..High(Word)] of Char;

begin
caption:='Dekompression ...';

ofn:=ChangeFileExt(Edit1.Text, '.cmp');
sfn:=ChangeFileExt(Edit1.Text, 'Kopie'+ExtractFileExt(Edit1.Text));

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

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

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

s:=c;
s:=RunLengthDeCompress(Copy(s, 1, fsize));
BlockWrite(fs, s[1], Length(s));
end;

CloseFile(fo);
CloseFile(fs);

caption:='OK';
end;

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

end.

Zurück zur Hauptseite