DelphiList20

Listing 20

unit Huffmann;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    Memo2: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(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;
  BitcoBuffer: DWord;
  StringBuffer: string;
  HBaumBuffer: THuffmannList;

implementation

{$R *.DFM}

procedure SetBits(var b: string; bitco: DWord; 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: DWord): 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 TForm1.FormCreate(Sender: TObject);
begin
HBaumBuffer:=THuffmannList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
HBaumBuffer.Free;
end;

function HuffmannCompress(source: string; HBaum: THuffmannList; var bitco: DWord): string;
var cv, vv, vc, id: DWord;
    s: string;

    SList: TStringList;
    HList: THuffmannList;
    Temp: THuffmann;

begin
SList:=TStringList.Create;
SList.sorted:=False;

HList:=THuffmannList.Create;

//1. Häufigkeiten ermitteln und in HList speichern
Temp.HCount:=0; Temp.HType:=False; //Blatt
for cv:=0 to 255 do HList.Add(Temp);

for cv:=1 to Length(source) do
begin
   Temp:=HList[ord(source[cv])];
   vv:=Temp.HCount; inc(vv); Temp.HCount:=vv;
   Temp.HToken:=source[cv];
   HList[ord(source[cv])]:=Temp;
end;

cv:=0;
while cv<HList.Count do
   if HList[cv].HCount=0 then HList.Delete(cv) else inc(cv);

HList.Sort;

//2. HBaum aufbauen
HBaum.Clear;

while HList.Count>=2 do
begin
   //HCount addieren und letzten beiden in Baum aufnehmen
   Temp.HRight:=HBaum.Add(HList[HList.Count-1]);
   Temp.HLeft:=HBaum.Add(HList[HList.Count-2]);
   Temp.HCount:=HList[HList.Count-2].HCount+HList[HList.Count-1].HCount;
   Temp.HType:=True; //Knoten
   HList.Delete(HList.Count-1); //zwei letzten El. löschen
   HList.Delete(HList.Count-1);
   HList.Add(Temp); //Knoten aufnehmen
   HList.Sort; //Knoten einsortieren
end;

HBaum.Add(HList[HList.Count-1]); //letztes El.(Wurzel) in HBaum

HList.Free;

//3. Code ermitteln und Daten komprimieren
for cv:=0 to 255 do
begin
   SList.Add('');
   for vc:=0 to HBaum.Count-1 do
      if (HBaum[vc].HToken=chr(cv)) and not HBaum[vc].HType then
      begin
         vv:=vc+1; id:=vc;
         while vv<HBaum.Count do
         begin
            if HBaum[vv].HType and ((HBaum[vv].HLeft=id) or (HBaum[vv].HRight=id)) then
            begin
               s:=SList[cv];
               if HBaum[vv].HRight=id then s:='1'+s else s:='0'+s;
               SList[cv]:=s;
               id:=vv;
            end;
            inc(vv);
         end;
         Break;
      end;
end;

result:=''; bitco:=0;
for cv:=1 to Length(source) do
begin
   s:=SList[ord(source[cv])];
   for vv:=1 to Length(s) do begin SetBits(result, bitco, (s[vv]='1')); inc(bitco); end;
end;

SList.Free;
end;

function HuffmannDeCompress(dest: string; HBaum: THuffmannList; bitco: DWord): string;
var cv, vv, id: DWord;

begin

id:=HBaum.Count-1; vv:=0; cv:=0; result:='';
for cv:=0 to bitco-1 do
begin
   if GetBits(dest, cv) then
      id:=HBaum[id].HRight //gehe nach rechts
   else
      id:=HBaum[id].HLeft; //nach links

   if not HBaum[id].HType then begin result:=result+HBaum[id].HToken; id:=HBaum.Count-1; end; //Blatt
end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   caption:='Kompression ...';
   StringBuffer:=HuffmannCompress(Memo1.Text, HBaumBuffer, BitcoBuffer);
   caption:='OK';
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   caption:='DeKompression ...';
   Memo2.Text:=HuffmannDeCompress(StringBuffer, HBaumBuffer, BitcoBuffer);
   if Memo1.Text=Memo2.Text then caption:='OK: gleich' else caption:='OK: ungleich';
end;

end.

//Unit HuffmannList: bildet die Klasse THuffmannList
//diese Liste nimmt beim Kompressionsvorgang den Huffmannbaum auf

unit HuffmannList;

interface

uses
  Windows, Messages, SysUtils, Classes;

type
  THuffmann = record
     HCount: DWord;
     HToken: Char;
     HLeft,
     HRight: DWord;
     HType: Boolean; //Knoten=True; Blatt=False;
  end;

  THuffmannArray = array[0..0] of THuffmann;

  THuffmannList = class(TObject)
  private
    FCount: LongInt;
    FHuffmann: ^THuffmannArray;

    function GetValue(Index: LongInt): THuffmann;
    procedure SetValue(Index: LongInt; Value: THuffmann);

    procedure QuickSort(L, R: Integer);

  public
    constructor Create;
    destructor Destroy; override;

    function Add(const Value: THuffmann): LongInt; //normal Add
    procedure Insert(Index: LongInt; const Value: THuffmann);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure Sort;
    procedure LoadFromFile(fn: string);
    procedure SaveToFile(fn: string);

    property Count: LongInt read FCount;
    property Value[Index: LongInt]: THuffmann read GetValue write SetValue; default;
  end;

function Huffmann(HCount: Word; HToken: Char; HLeft, HRight: Word; HType: Boolean): THuffmann;

implementation

constructor THuffmannList.Create;
begin
   inherited Create;

   FCount := 0;
   ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));
end;

destructor THuffmannList.Destroy;
begin
   ReAllocMem(FHuffmann, 0);

   inherited Destroy;
end;

function THuffmannList.GetValue(Index: LongInt): THuffmann;
begin
   if (not Assigned(Self)) or (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   Result := FHuffmann^[Index];
end;

procedure THuffmannList.SetValue(Index: LongInt; Value: THuffmann);
begin
   if (not Assigned(Self)) or (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   FHuffmann^[Index] := Value;
end;

function THuffmannList.Add(const Value: THuffmann): LongInt;
begin
   FHuffmann^[FCount]:=Value;
   Result:=FCount;

   inc(FCount);
   ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));
end;

procedure THuffmannList.Insert(Index: LongInt; const Value: THuffmann);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   inc(FCount);
   ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));

   System.Move(FHuffmann^[Index], FHuffmann^[Index+1], (FCount-Index)*sizeof(THuffmann));

   FHuffmann^[Index]:=Value;
end;

procedure THuffmannList.Delete(Index: LongInt);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   System.Move(FHuffmann^[Index+1], FHuffmann^[Index], (FCount-Index-1)*sizeof(THuffmann));

   dec(FCount);
   ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));
end;

procedure THuffmannList.Clear;
begin

   FCount := 0;
   ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));
end;

procedure THuffmannList.Sort;
begin
   if (FHuffmann <> nil) and (FCount > 0) then QuickSort(0, FCount - 1);
end;

procedure THuffmannList.LoadFromFile(fn: string);
var fs: file;
    buffer: Integer;
    cv: Integer;

begin
AssignFile(fs, fn);
{$I-}
Reset(fs, 1);
{$I+}

if IOResult = 0 then
begin

BlockRead(fs, FCount, sizeof(LongInt));
ReAllocMem(FHuffmann, (FCount + 1) * SizeOf(THuffmann));

for cv:=0 to FCount-1 do
  BlockRead(fs, FHuffmann^[cv], sizeof(THuffmann));

end;

CloseFile(fs);
end;

procedure THuffmannList.SaveToFile(fn: string);
var fs: file;
    cv: Integer;

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

if IOResult = 0 then
begin

BlockWrite(fs, FCount, sizeof(LongInt));

for cv:=0 to FCount-1 do
  BlockWrite(fs, FHuffmann^[cv], sizeof(THuffmann));

end;

CloseFile(fs);
end;

//Routinen

procedure THuffmannList.QuickSort(L, R: Integer);
var I, J: Integer;
    P: Word;

    Temp: THuffmann;

begin

  repeat
    I := L;
    J := R;
    P := FHuffmann^[(L + R) shr 1].HCount;

    repeat
      while FHuffmann^[I].HCount>P do Inc(I);
      while FHuffmann^[J].HCount<P do Dec(J);

      if I <= J then
      begin
        Temp:=FHuffmann^[I]; FHuffmann^[I]:=FHuffmann^[J]; FHuffmann^[J]:=Temp; //Items tauschen

        Inc(I);
        Dec(J);
      end;

    until I > J;

    if L < J then QuickSort(L, J);

    L := I;

  until I >= R;

end;

//Funktion Huffmann gibt einen THuffmann-Datensatz zurück (außerhalb der Klasse THuffmannList)

function Huffmann(HCount: Word; HToken: Char; HLeft, HRight: Word; HType: Boolean): THuffmann;
begin
   result.HCount:=HCount;
   result.HToken:=HToken;
   result.HLeft:=HLeft;
   result.HRight:=HRight;
   result.HType:=HType;
end;

end.

Zurück zur Hauptseite