Witam! pisze kompresje metoda dynamiczna ! napisalem juz wiekszosc kodu ale pojawil sie bad
nie moge dodac do drzewa wiecej niz jeden znak. problem znajduje sie jak mysle w procedurze memberart oraz member tylko nie wiem na czym polegaten bład ! jezeli ktos moglby przesledzic i wskazac mi gdzie popełniam blad to byłym bardzo mu wdzieczny!
oto kod programu :
{$APPTYPE CONSOLE}
uses
SysUtils;
type huffman =^elem;
elem=record
ilosc:integer;
znak:char;
okresl:boolean;
ldrzewo:huffman;
pdrzewo:huffman;
end;
var drzewo:huffman;
dr:huffman;
jest:boolean;
tabznak:array[1..255] of integer;
tablog:array[1..255] of boolean;
wydruk:string;
d1,d2,d3:huffman;
ART:huffman;
nznak:huffman;
pomdrzewo:huffman;
procedure nowedrzewo();
begin
new(pomdrzewo);
new(d1); //???
new(d2);
new(d3);
new(art);
new(nznak);
new(drzewo);
with drzewo^ do
begin
znak:='$';
ilosc:=1;
okresl:=true;
ldrzewo:=nil;
pdrzewo:=nil;
end;
end;
procedure pisz(drzewo:huffman);
begin
if drzewo<>nil then
with drzewo^ do
begin
write(':',znak);
writeln(':',ilosc);
pisz(ldrzewo);
pisz(pdrzewo);
end;
end;
function member(c:char;var drzewo:huffman; var jest:boolean):boolean;
begin
jest:=false;
if (drzewo<>nil) then
with drzewo^ do
begin
if ((znak=c) and (okresl=false)) then
begin
jest:=true;
ilosc:=ilosc+1;
end
else
member(c,ldrzewo,jest);
if not jest then
member(c,pdrzewo,jest);
end;
member:=jest;
end;
procedure memberART(c:char; var drzewo:huffman); //??
begin
if (drzewo<>nil) then
begin
write('member art');
readln;
if ((drzewo.okresl=true) and (drzewo.znak='$')) then
begin
art.znak:=drzewo.znak;
art.ilosc:=drzewo.ilosc;
art.okresl:=drzewo.okresl;
art.ldrzewo:=nil;
art.pdrzewo:=nil;
nznak.znak:=c;
nznak.ilosc:=1;
nznak.okresl:=false;
nznak.ldrzewo:=nil;
nznak.pdrzewo:=nil;
drzewo.znak:='*';
drzewo.ilosc:=0;
drzewo.okresl:=true;
drzewo.ldrzewo:=nznak;
drzewo.pdrzewo:=art;
end
else
begin
memberart(c,drzewo.ldrzewo);
memberart(c,drzewo.pdrzewo);
end;
end;
end;
function hierarhia(var jeden:integer; var dwa:integer):boolean;
var
i:integer;
oczek:boolean;
begin
oczek:=true;
jeden:=1;
for i:=2 to 255 do
begin
if (tablog[i]=true) then
begin
if (tabznak[jeden]<tabznak[i]) then
begin
oczek:=false;
dwa:=i;
break;
end
else jeden:=i;
end;
end;
hierarhia:=oczek;
end;
procedure initab();
var i:integer;
begin
for i:=1 to 255 do
begin
tabznak[i]:=0;
tablog[i]:=false;
end;
end;
procedure dodaj(c:char);
begin
if ((member(c,drzewo,jest))=false) then
begin
writeln('ok');
readln;
memberART(c,drzewo);
end;
end;
function oblicz(drzewo:huffman; z:integer):integer; //var ??
var
pom:integer;
begin
pom:=0;
if (drzewo<>nil) then
begin
if ((drzewo.ldrzewo=nil) and (drzewo.pdrzewo=nil)) then
begin
pom:=drzewo.ilosc;
end
else
begin
drzewo.ilosc:=oblicz(drzewo.ldrzewo,2*z)+oblicz(drzewo.pdrzewo,(2*z)+1);
pom:=drzewo.ilosc;
end;
tabznak[z]:=pom;
tablog[z]:=true;
end
else
pom:=0;
oblicz:=pom;
end;
function znajdz(lokalizacja:string):huffman;
var
i:integer;
begin
pomdrzewo:=drzewo;
i:=0;
while(lokalizacja[i]<>'\0') do
begin
if(lokalizacja[i]='l') then pomdrzewo:=pomdrzewo.ldrzewo
else
pomdrzewo:=pomdrzewo.pdrzewo;
i:=i+1;
end;
znajdz:=pomdrzewo;
end;
function wykonaj(liczba:integer):string;
var
droga:string;
begin
while(liczba>1) do
begin
if (liczba div 2 =1) then droga:='r'+droga
else
droga:='l'+droga;
liczba:=liczba mod 2;
end;
wykonaj:=droga;
end;
procedure modyfikacja(jeden :integer; dwa:integer); //new
// d1,d2,d3:huffman;
begin
{
d1,d2,d3:huffman;
new(d1); //???
new(d2);
new(d3);
}
d1:=znajdz(wykonaj(jeden));
d2:=znajdz(wykonaj(dwa));
d3.ilosc:=d1.ilosc;
d3.znak:=d1.znak;
d3.okresl:=d1.okresl;
d3.ldrzewo:=d1.ldrzewo;
d3.pdrzewo:=d1.pdrzewo;
d1.ilosc:=d2.ilosc;
d1.znak:=d2.znak;
d1.okresl:=d2.okresl;
d1.ldrzewo:=d2.pdrzewo;
d1.pdrzewo:=d2.pdrzewo;
d2.ilosc:=d3.ilosc;
d2.znak:=d3.znak;
d2.okresl:=d3.okresl;
d2.ldrzewo:=d3.ldrzewo;
d2.pdrzewo:=d3.pdrzewo;
end;
function znakNAbin(c:char):string;
var s,bin:string;
resz,numer:integer;
liczba,i:integer;
wynik:array[1..8] of integer;
begin
liczba:=0;
for i:=1 to 8 do
wynik[i]:=0;
liczba:=numer;
i:=8;
while liczba>0 do
begin
resz:=liczba mod 2;
if resz>0 then
wynik[i]:=1
else
wynik[i]:=0;
liczba:=liczba div 2; // wynik dzileenia liczby przez 2 bez reszty
i:=i-1; //zmijsza pozycje w tablicy o 1
end;
for i:=1 to 8 do
bin:=bin+inttostr(wynik[i]);
znaknabin:=bin;
end;
procedure aktualizuj();
var x,y:integer;
begin
initab();
oblicz(drzewo,1);
if (hierarhia(x,y)=false) then
begin
modyfikacja(x,y);
aktualizuj();
end;
end;
procedure wrzucart(drzewo:huffman; kod:string);
begin
if drzewo<>nil then
if ((drzewo.okresl=true) and (drzewo.znak='$')) then
write(':',kod)
else
begin
wrzucart(drzewo.ldrzewo,kod+'0');
wrzucart(drzewo.pdrzewo,kod+'1');
end;
end;
procedure wrzuc(drzewo:huffman; kod:string; c:char);
begin
if drzewo<>nil then
if((drzewo.znak=c) and (drzewo.okresl=false)) then
write(':',kod)
else
begin
wrzuc(drzewo.ldrzewo,kod+'0',c);
wrzuc(drzewo.pdrzewo,kod+'0',c);
end;
end;
function jestznak(c:char; drzewo:huffman):boolean;
begin
jest:=false;
if drzewo<>nil then
if((drzewo.znak=c) and (drzewo.okresl=false)) then jest:=true;
if (jest=false) then jest:=jestznak(c,drzewo.ldrzewo);
if (jest=false) then jest:=jestznak(c,drzewo.pdrzewo);
jestznak:=jest;
end;
//
procedure piszplik(c:char);
begin
if (jestznak(c,drzewo)=false)
then
begin
wrzucart(drzewo,'');
end;
wrzuc(drzewo,'',c);
end;
procedure piszd(drzewo:huffman);
begin
if drzewo<>nil then
with drzewo^ do
begin
write(':',znak);
write(':',ilosc);
piszd(ldrzewo);
piszd(pdrzewo);
end;
end;
Begin
initab();
nowedrzewo();
piszd(drzewo);
readln;
dodaj('c');
aktualizuj();
dodaj('c');
aktualizuj();
dodaj('a'); // i tu gdy dodam inny znak to sie sypie :[
aktualizuj();
piszd(drzewo);
readln;
writeln('ok1');
dodaj('a');
aktualizuj();
readln;
pisz(drzewo);
dodaj('c');
aktualizuj();
readln;
pisz(drzewo);
readln;
readln;
{ TODO -oUser -cConsole Main : Insert code here }
end.