Писал лабу (СиАОД) по реализации алгоритма кодирования файлов кодом Шеннона на Pascal'e.
Может кому будет интересно.
program Shennon_code;
uses crt;
type
TTable = record
data : byte;
P : real;
Q : real;
L : byte;
CODE : string[30];
end;
pVertex = ^Vertex;
Vertex = record
data: byte;
left, right: pVertex;
end;
var
count : integer;
Table : array [1..255] of TTable;
DATA : byte;
T_count : byte;
F1, F2 : file of byte;
L1, L2 : longint;
L_sr : real;
H : real;
root : pVertex;
{/*---------------------------------------------------------------------*/}
function Coding(InputFileName, OutputFileName: string): real;
{/*............................................*/}
procedure SortTable;
var
tmp_p: TTable;
i,j: byte;
begin
for i:=1 to T_count do begin
for j:=T_count downto i+1 do begin
if Table[j].p > Table[j-1].p then begin
tmp_P:=Table[j];
Table[j]:=Table[j-1];
Table[j-1]:=tmp_P;
end;
end;
end;
end;
{/*............................................*/}
function GetCodeWord(Q: real; l: byte): string;
var
tmp: string[30];
i: byte;
begin
tmp:='';
for i:=1 to l do begin
Q:=Q*2;
case trunc(Q) of
0: tmp:=tmp+'0';
1: tmp:=tmp+'1';
end;
if Q >= 1 then Q:=Q-1;
end;
GetCodeWord:=tmp;
end;
{/*............................................*/}
procedure ReadFile(FileName: string);
var
d,i : byte;
c : longint;
flg : 0..1;
tmp : real;
begin
Assign(F1,FileName);
Reset(F1);
c:=1;
T_count:=1;
while not EOF(F1) do begin
read(F1,d); inc(c);
flg:=0;
for i:=1 to T_count do
if Table[i].data = d then begin
flg:=1;
Table[i].p:=Table[i].p+1;
break;
end;
if flg = 0 then begin
Table[T_count].data:=d;
Table[T_count].p:=1;
Table[T_count].q:=0;
inc(T_count);
end;
end; dec(T_count); dec(c);
Close(F1);
SortTable;
for i:=1 to T_count do begin
Table[i].P := Table[i].P / c;
if i = 1 then Table[i].Q := 0
else Table[i].Q := Table[i-1].Q + Table[i-1].P;
tmp := abs(ln(Table[i].P) / ln(2));
if tmp - trunc(tmp) > 0.0 then
Table[i].L:=trunc(tmp)+1
else
Table[i].L:=trunc(tmp);
Table[i].Code := GetCodeWord(Table[i].Q, Table[i].L);
L_sr := L_sr+Table[i].P*Table[i].L;
H := H+Table[i].P*round(ln(Table[i].P)/ln(2));
end;
end;
{/*............................................*/}
procedure InsertBits(Q: real; l: byte);
var
i: byte;
tmp: byte;
begin
tmp:=0;
for i:=1 to l do begin
Q:=Q*2;
if count < 7 then begin
count:=count+1;
data := data shl 1;
inc(data,trunc(Q));
end
else begin
write(F2,data); inc(L2);
data := 0;
inc(data,trunc(Q));
count:=0;
end;
if Q > 1 then Q:=Q-1;
end;
end;
{/*............................................*/}
var
d, i: byte;
L_sr: real;
begin
count:=-1;
ReadFile(InputFileName);
SortTable;
Assign(F1, InputFileName); Assign(F2, OutputFileName);
Reset(F1); Rewrite(F2);
L1:=0; L2:=0;
while not EOF(F1) do begin
read(F1,d); inc(L1);
for i:=1 to T_count do
if Table[i].data = d then begin
InsertBits(Table[i].q,Table[i].l);
break;
end;
end;
if count >= 0 then
for i:=1 to 7 - count do begin
data := data shl 1;
inc(data,0);
end;
write(F2,data);
Close(F1); Close(F2);
end;
{/*---------------------------------------------------------------------*/}
procedure CreateTree;
{/*................................................*/}
procedure AddStringINTOVertex(s: string; data: byte);
var
p: ^pVertex;
count: byte;
i: byte;
begin
p:=@root;
if p^ = nil then begin
new(p^);
p^^.data:=0;
p^^.left:=nil;
p^^.right:=nil;
end;
for i:=1 to length(s) do begin
if s[i] = '0' then begin
p:=@(p^^.left);
if p^ = nil then begin
new(p^);
p^^.data:=0;
if (i = length(s)) and (p^^.data = 0) then
p^^.data := data;
p^^.left:=nil;
p^^.right:=nil;
end;
end
else if s[i] = '1' then begin
p:=@(p^^.right);
if p^ = nil then begin
new(p^);
p^^.data:=0;
if (i = length(s)) and (p^^.data = 0) then
p^^.data := data;
p^^.left:=nil;
p^^.right:=nil;
end;
end;
end;
end;
{/*................................................*/}
var
i: byte;
begin
root:=nil;
for i:=1 to T_count do begin
AddStringINTOVertex(Table[i].CODE, Table[i].data);
end;
end;
{/*---------------------------------------------------------------------*/}
procedure DeCoding(InputFileName, OutputFileName: string);
var
p: ^pVertex;
{/*..................................................*/}
function DecToBin(K: integer): string;
var
tmp, c, s: string;
sum, len, i: integer;
begin
s:='';
str((K mod 2),tmp);
while K >= 2 do begin
K := K div 2;
sum := K mod 2;
str(sum, c);
tmp:=tmp+c;
end;
len:=length(tmp);
s:='';
for i:=0 to len-1 do s:=s+copy(tmp,len-i,1);
if length(s) < 8 then
for i:=length(s) to 7 do
s:='0'+s;
DecToBin:=s;
end;
{/*..................................................*/}
function FindInVertex(s: string): byte;
var
w, i: byte;
begin
p:=@root;
w:=0;
for i:=1 to length(s) do begin
if s[i] = '1' then p:=@(p^^.right)
else if s[i] = '0' then p:=@(p^^.left);
if p^^.data <> 0 then begin
w:=i;
break;
end;
end;
FindInVertex:=w;
end;
{/*..................................................*/}
var
str, tmp: string;
position, len: byte;
k: longint;
begin
Assign(F1,InputFileName); Assign(F2,OutputFileName);
Reset(F1); Rewrite(F2);
str:=''; K:=0;
while K <> L1 do begin
tmp:='';
if not Eof(F1) then begin
read(F1,data);
tmp:=DecToBin(data);
end;
str:=str+tmp;
len:=length(str);
if len > 200 then begin
while len > 150 do begin
position:=FindInVertex(str);
if position <> 0 then begin
write(F2, p^^.data);
delete(str,1,position);
len:=length(str);
inc(K);
end;
end;
end else begin
position:=FindInVertex(str);
if position <> 0 then begin
write(F2, p^^.data);
delete(str,1,position);
inc(K);
end;
end;
end;
Close(F1); Close(F2);
end;
var
i: byte;
BEGIN
clrscr;
GotoXY(60,24); writeln('Coding ..... ');
Coding('1.txt','2.txt');
GotoXY(1,1);
writeln('K = ',L2 / L1:1:5);
writeln('L_sr = ',L_sr:1:5);
writeln('H = ',(-1)*H:1:5);
GotoXY(60,24); writeln('Make tree ..... ');
CreateTree;
GotoXY(60,24); writeln('Decoding ..... ');
DeCoding('2.txt','3.txt');
GotoXY(60,24); writeln('The end ');
readln
END.
