This commit is contained in:
raspbeguy 2016-03-07 17:51:00 +01:00
commit 9eb3aa151d
3 changed files with 677 additions and 0 deletions

0
README.md Normal file
View File

426
codage.pas Normal file
View File

@ -0,0 +1,426 @@
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.

251
decodage.pas Normal file
View File

@ -0,0 +1,251 @@
program decodage;
uses crt,dos,math;
type
liste=^cellule;
cellule=record
octet:byte;
freq:longword;
suiv:liste;
gauche:liste;
droite:liste;
end;
fichier=array of byte;
catalogue=array[0..255] of byte;
var p:fichier;l:liste;premier:byte;taille,index:longword;chemin:string;
function prefixe(ind:fichier):longword;
var s,i:longword;
begin
s:=0;
for i:=length(ind)-1 downto 0 do s:=(ind[i] div 2)*trunc(power(2,7*(length(ind)-1-i)))+s;
prefixe:=s;
end;
procedure importer(var p:fichier; var l:liste; var premier:byte;var chemin:string);
var f:file;i:longword;j,longueur:byte;ind:fichier;l1,l2:liste;
begin
write('Chemin du fichier : ');
readln(chemin);
assign(f,chemin);
reset(f,1);
writeln('Importation...');
blockread(f,longueur,1);
(*Pour éviter les problèmes avec longueur=0, on fera une boucle de 0 à longueur-1*)
longueur:=longueur-1;
new(l);
l^.suiv:=nil;
setlength(ind,0);
for j:=0 to longueur do
begin
l^.gauche:=nil;
l^.droite:=nil;
blockread(f,l^.octet,1);
repeat
begin
setlength(ind,length(ind)+1);
blockread(f,ind[length(ind)-1],1);
end;
until ind[length(ind)-1] mod 2 = 0;
l^.freq:=prefixe(ind);
setlength(ind,0);
new(l1);
l1^.suiv:=l;
l:=l1;
end;
l2:=l;
l:=l^.suiv;
dispose(l2);
blockread(f,premier,1);
i:=0;
setlength(p,filesize(f)-filepos(f));
while not eof(f) do
begin
blockread(f,p[i],1);
i:=i+1;
end;
close(f);
end;
function inserer(var l:liste; var l1:liste):liste;
begin
if l=nil then
begin
l1^.suiv:=nil;
inserer:=l1;
end
else
begin
if l1^.freq<=l^.freq then
begin
l1^.suiv:=l;
inserer:=l1;
end
else
begin
l^.suiv:=inserer(l^.suiv,l1);
inserer:=l;
end;
end;
end;
procedure arbre(var l:liste);
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;
l:=inserer(l^.suiv^.suiv,l1);
arbre(l);
end;
end;
function bit(b,position:byte):byte;
begin
bit:=(b div trunc(power(2,position)))-(2*(b div trunc(power(2,position+1))));
end;
procedure interpreter(l:liste;var p:fichier;premier:byte);
var m:byte;l1:liste;f:fichier;i:longword;
begin
m:=premier;
l1:=l;
setlength(f,0);
for i:=0 to length(p)-1 do
begin
repeat
begin
if bit(p[i],m)=0 then l1:=l1^.gauche else l1:=l1^.droite;
if ((l1^.gauche=nil) and (l1^.droite=nil)) then
begin
setlength(f,length(f)+1);
f[length(f)-1]:=l1^.octet;
l1:=l;
end;
m:=m-1;
end;
until m=255;
m:=7;
end;
p:=f;
setlength(f,0);
end;
procedure coder(p:fichier;taille:longword);
var ref,car:catalogue;i:longword;j,k,l:byte;f:fichier;
begin
for i:=0 to 255 do ref[i]:=i;
car:=ref;
setlength(f,taille);
for i:=0 to taille-1 do
begin
j:=p[i];
f[i]:=car[j];
l:=car[j];
for k:=j downto 1 do
begin
car[k]:=car[k-1];
end;
car[0]:=l;
end;
p:=f;
setlength(f,0);
end;
function prefixe(ind:fichier;taille:longword):longword;
var s,i:longword;
begin
s:=0;
for i:=taille-1 downto 0 do s:=(ind[i] div 2)*trunc(power(2,7*(taille-1-i)))+s;
prefixe:=s;
end;
procedure preliminaire(var f:fichier;var index:longword);
var ind,p:fichier;i,j:longword;
begin
i:=0;
setlength(ind,0);
repeat
begin
setlength(ind,i+1);
ind[i]:=f[i];
i:=i+1;
end;
until ind[i-1] mod 2 = 0;
index:=prefixe(ind,i);
setlength(ind,0);
setlength(p,length(f)-i);
for j:=i to length(f)-1 do p[j-i]:=f[i];
f:=p;
setlength(p,0);
end;
function decode(index,taille:longword;t:fichier):fichier;
var i,j,sum:longword;C,P:array of longword;S:fichier;
begin
setlength(C,256);
setlength(P,taille);
setlength(S,taille);
for i:=0 to 255 do C[i]:=0;
for i:=0 to taille-1 do
begin
P[i]:=C[t[i]];
C[t[i]]:=C[t[i]]+1;
end;
sum:=0;
for i:=0 to 255 do
begin
sum:=sum+C[i];
C[i]:=sum-C[i];
end;
i:=index;
for j:=taille-1 downto 0 do
begin
S[j]:=t[i];
i:=P[i]+C[t[i]];
end;
decode:=S;
end;
function nouv_chemin(chemin,nom: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+'/'+nom
end;
procedure ecrire(d:fichier;taille:longword;chemin:string);
var f1:file;nom:string;i:longword;
begin
write('Nom du fichier : ');
readln(nom);
assign(f1,nouv_chemin(chemin,nom));
rewrite(f1,1);
writeln('Écriture de la séquence...');
for i:=0 to taille-1 do
begin
blockwrite(f1,d[i],1);
end;
close(f1);
end;
begin
importer(p,l,premier,chemin);
arbre(l);
interpreter(l,p,premier);
taille:=length(p);
coder(p,taille);
preliminaire(p,index);
taille:=length(p);
p:=decode(index,taille,p);
writeln('ok');
ecrire(p,taille,chemin);
end.