compression/codage.pas

program codage;

uses crt,dos,math;

type
	anagramme=^cellule1;
	cellule1=record
			octet:byte;
			prec:anagramme;
			suiv:anagramme;
			end;
	decalage=array of anagramme;
	catalogue=array[0..255] of byte;
	fichier=array of byte;
	bit=0..1;
	liste=^cellule2;
	cellule2=record
			octet:byte;
			freq:longword;
			suiv:liste;
			gauche:liste;
			droite:liste;
			end;
	tableau=array[0..255] of liste;
	sauvegarde=array of liste;
	final=array[0..255] of array of bit;

var f:fichier;a:anagramme;d:decalage;taille,p:longword;l:liste;fin:final;longueur:byte;s:sauvegarde;chemin:string;

procedure importer(var p:anagramme; var taille:longword; var chemin:string);
var f:file;p1:anagramme;
begin
write('Chemin du fichier : ');
readln(chemin);
if chemin[length(chemin)]=' ' then delete(chemin,length(chemin),1);
assign(f,chemin);
reset(f,1);
new(p);
p1:=p;
writeln('Importation...');
while not eof(f) do
	begin
	new(p1^.suiv);
	p1^.suiv^.prec:=p1;
	p1:=p1^.suiv;
	blockread(f,p1^.octet,1);
	end;
taille:=filesize(f);
close(f);
p:=p^.suiv;
p1^.suiv:=p;
p^.prec:=p1;
end;

function EstSuperieur(p1,p2:anagramme;longueur:longword):boolean;
var pa,pb:anagramme;i:longword;
begin
i:=1;
pa:=p1;
pb:=p2;
while ((i<=longueur) and (pa^.octet=pb^.octet)) do
	begin
	pa:=pa^.suiv;
	pb:=pb^.suiv;
	i:=i+1;
	end;
if pa^.octet>pb^.octet then EstSuperieur:=true else EstSuperieur:=false;
end;

function inserer(p:anagramme;t:decalage;debut,fin,taille:longword):longword;
var milieu:longword;
begin
if fin-debut=0 then inserer:=debut
else
	begin
	milieu:=(debut+fin) div 2;
	if EstSuperieur(t[milieu],p,taille) then
		inserer:=inserer(p,t,debut,milieu,taille)
	else
		inserer:=inserer(p,t,milieu+1,fin,taille);
	end;
end;

procedure reindex(var t:decalage;p:anagramme;i,taille:longword; var position:longword);
var j,k:longword;
begin
j:=inserer(p,t,0,i,taille);
setlength(t,i+1);
if j<=position then position:=position+1;
for k:=i downto j do t[k+1]:=t[k];
t[j]:=p;
end;

procedure tabler(var t:decalage; var p:anagramme;taille:longword; var position:longword);
var i:longword;x:byte;
begin
x:=1;
setlength(t,1);
t[0]:=p;
position:=0;
for i:=1 to taille-1 do
	begin
	p:=p^.suiv;
	reindex(t,p,i,taille,position);
	if ((i+1)*100) div taille >= x then
		begin
		writeln(x,'% des décalages indexés');
		x:=x+1;
		end;
	end;
end;

procedure prefixe(n:longword; var p:anagramme; var i:integer);
var p1:anagramme;
begin
i:=0;
new(p);
p1:=p;
repeat
	begin
	i:=i+1;
	new(p1^.suiv);
	p1^.suiv^.prec:=p1;
	p1:=p1^.suiv;
	p1^.octet:=((n-(trunc(power(2,7*i))*(n div trunc(power(2,7*i))))) div trunc(power(2,7*(i-1))))*2+1;
	end;
until n div trunc(power(2,7*i))=0;
p:=p^.suiv;
p1^.suiv:=p;
p^.prec:=p1;
p^.octet:=p^.octet-1;
p:=p^.prec;
end;

procedure dernier(var d:decalage);
var i:longword;
begin
for i:=0 to length(d)-1 do d[i]:=d[i]^.prec;
end;

procedure transformer(n:longword;d:decalage;taille:longword;var f:fichier);
var i:longword;j:integer;p:anagramme;
begin
setlength(f,0);
prefixe(n,p,j);
writeln('Position du motif original fixée à ',n,', codée sur ',j,' octet(s)');
(*Écriture du préfixe...*)
setlength(f,j+taille);
for i:=0 to j-1 do
	begin
	f[i]:=p^.octet;
	p:=p^.prec;
	end;
writeln('Écriture de la séquence codée...');
dernier(d);
for i:=0 to taille-1 do
	begin
	f[i+j]:=d[i]^.octet;
	dispose(d[i]);
	end;
setlength(d,0);
end;

procedure coder(var p:fichier;taille:longword);
var ref,car:catalogue;i:longword;j,k,l:byte;f:fichier;
begin
setlength(f,taille);
for i:=0 to 255 do ref[i]:=i;
car:=ref;
for i:=0 to taille-1 do
	begin
	j:=p[i];
	f[i]:=ref[j];
	l:=car[ref[j]];
	for k:=ref[j] downto 1 do
		begin
		car[k]:=car[k-1];
		ref[car[k]]:=k;
		end;
	car[0]:=l;
	ref[l]:=0;
	end;
p:=f;
setlength(f,0);
end;











procedure trier(var l:liste);
var l1,l2:liste;
begin
l1:=l;
if l<>nil then
	begin
	while l1^.suiv<>nil do
		begin
		if l1^.suiv^.freq<l^.freq then
			begin
			l2:=l1^.suiv;
			l1^.suiv:=l2^.suiv;
			l2^.suiv:=l;
			l:=l2;
			l1:=l;
			end;
		l1:=l1^.suiv;
		end;
	trier(l^.suiv);
	end;
end;

function inserer2(var l:liste; var l1:liste):liste;
begin
if l=nil then
	begin
	l1^.suiv:=nil;
	inserer2:=l1;
	end
else
	begin
	if l1^.freq<=l^.freq then
		begin
		l1^.suiv:=l;
		inserer2:=l1;
		end
	else
		begin
		l^.suiv:=inserer2(l^.suiv,l1);
		inserer2:=l;
		end;
	end;
end;

procedure branche(var l:liste;b:bit;var fin:final);
var aux:array of bit;
begin
if ((l^.gauche=nil) and (l^.droite=nil)) then
	begin
	aux:=fin[l^.octet];
	setlength(aux,length(aux)+1);
	aux[length(aux)-1]:=b;
	fin[l^.octet]:=aux;
	setlength(aux,0);
	end
else
	begin
	branche(l^.gauche,b,fin);
	branche(l^.droite,b,fin);
	end;
end;

procedure arbre(var l:liste;var fin:final);
var l1:liste;
begin
if l^.suiv<>nil then
	begin
	new(l1);
	l1^.gauche:=l;
	l1^.droite:=l^.suiv;
	l1^.freq:=l^.freq+l^.suiv^.freq;
	branche(l1^.gauche,0,fin);
	branche(l1^.droite,1,fin);
	l:=inserer2(l^.suiv^.suiv,l1);
	arbre(l,fin);
	end;
end;

procedure nombrelong(n:longword; var nombre:fichier);
var i:longword;
begin
i:=1;
setlength(nombre,0);
repeat
	begin
	setlength(nombre,i);
	nombre[i-1]:=((n-(trunc(power(2,7*i))*(n div trunc(power(2,7*i))))) div trunc(power(2,7*(i-1))))*2+1;
	i:=i+1;
	end;
until n div trunc(power(2,7*(i-1)))=0;
nombre[0]:=nombre[0]-1;
end;

function nouv_chemin(chemin:string):string;
var i:byte;s:string;
begin
s:=chemin;
i:=length(chemin);
while s[i]<>'.' do i:=i-1;
delete(s,i,length(chemin)-i+1);
nouv_chemin:=s+'.cmp'
end;


procedure ecrire(fin:final;p:fichier;taille:longword;s:sauvegarde;longueur:byte;chemin:string);
var f:file;i,m:longword;j,k:byte;nombre:fichier;
begin
assign(f,nouv_chemin(chemin));
rewrite(f,1);
writeln('Écriture du dictionnaire...');
blockwrite(f,longueur,1);
for i:=high(s) downto 0 do
	begin
	blockwrite(f,s[i]^.octet,1);
	nombrelong(s[i]^.freq,nombre);
	for j:=length(nombre)-1 downto 0 do blockwrite(f,nombre[j],1);
	end;
writeln('Recherche du point de départ des données...');
k:=0;
m:=0;
for i:=0 to high(s) do m:=length(fin[s[i]^.octet])*s[i]^.freq+m;
m:=(m-1) mod 8;
blockwrite(f,m,1);
writeln('Écriture des données...');
j:=0;
for i:=0 to taille-1 do
	begin
	for j:=high(fin[p[i]]) downto 0 do
		begin
		k:=(fin[p[i]][j])*trunc(power(2,m))+k;
		if m=0 then
			begin
			blockwrite(f,k,1);
			k:=0;
			m:=7;
			end
		else m:=m-1;
		end;
	end;
end;

procedure compter(p:fichier;taille:longword; var l:liste; var longueur:byte);
var i:longword;j:byte;l1:liste;t:tableau;
begin
writeln('Bilan des octets...');
j:=255;
longueur:=0;
for i:=0 to 255 do t[i]:=nil;
for i:=0 to taille-1 do
	begin
	if t[p[i]]=nil then
		begin
		longueur:=longueur+1;
		new(t[p[i]]);
		t[p[i]]^.freq:=0;
		t[p[i]]^.octet:=p[i];
		t[p[i]]^.gauche:=nil;
		t[p[i]]^.droite:=nil;
		t[p[i]]^.suiv:=nil;
		if p[i]<j then j:=p[i];
		end;
	t[p[i]]^.freq:=t[p[i]]^.freq+1;
	end;
l:=t[j];
l1:=l;
for i:=j+1 to 255 do
	begin
	if assigned(t[i]) then
		begin
		l1^.suiv:=t[i];
		l1:=t[i];
		end;
	end;
end;

procedure verification(fin:final);
var i:byte;j:longword;
begin
writeln('Vérification');
for i:=0 to 255 do
	begin
	if length(fin[i])>0 then
		begin
		write(i,' ');
		for j:=high(fin[i]) downto 0 do write(fin[i][j]);
		writeln;
		end;
	end;
end;

procedure verification2(l:liste);
begin
if l<>nil then
	begin
	writeln(l^.octet,': ',l^.freq);
	verification2(l^.suiv);
	end;
end;

function sauver(l:liste):sauvegarde;
var s:sauvegarde;
begin
setlength(s,0);
while l<>nil do
	begin
	setlength(s,length(s)+1);
	s[length(s)-1]:=l;
	l:=l^.suiv;
	end;
sauver:=s;
end;

begin
writeln('Algorithme de Burrows-Weeler :');
importer(a,taille,chemin);
writeln('Création des décalages...');
tabler(d,a,taille,p);
transformer(p,d,taille,f);
writeln('Algorithme de Move-To-Front...');
taille:=length(f);
coder(f,taille);
writeln('Algorithme de Huffman :');
compter(f,taille,l,longueur);
writeln('Tri préliminaire...');
trier(l);
s:=sauver(l);
writeln('Création de l''arbre-dictionnaire...');
arbre(l,fin);
ecrire(fin,f,taille,s,longueur,chemin);
end.