Programme pascal de conversion entre bases

conversion de base 2 a base 8 et 16
program test;
uses wincrt;
const
ch1='01';
type
ch=string[46];
chv=string[4];
ch2=string[1];
bits=3..4;
var
n,ph:string;
b:byte;
bit:bits;
k:integer;
v:chv;
procedure saisie_base(var B : byte);
begin
repeat
write('donner une base dans [8,16] : ');
readln(B);
until B in [8,16];
end;

function recherche(n:string):boolean;
var
i:integer;
begin
i:=0;
repeat
i:=i+1;
until (pos(upcase(n[i]),ch1)=0) or (i > length(n));
if i > length(n) then recherche:=true
else recherche:=false;
end;
procedure saisie_ch(var n : string);
begin
repeat
write('donner un nombre dans la base :');
readln(n);
until Recherche(n);
end;

function puissance (b,r:integer):integer;

begin
if r=0
then puissance:=1
else
puissance:=puissance(b,r-1)*b;
end;

function convert (v:chv):ch2;
var
s,e,x,i:integer;
u:string;
begin
s:=0;
for i:=1 to length (v) do
begin
val(v[i],x,e);
s:=s+x*puissance(2,length(v)-i);
end;
if s in[0..9] then str(s,u)
else u:=chr(ord('a')+s-10);
convert:=u;
end;

{function converssion (n:string;b:byte):string;
begin
if b=8 then bit:=3
else bit:=4;
while length(n) mod bit <>0 do
n:=concat('0',n);
k:=length(n);
ph:='';
repeat
v:=copy(n,k-bit+1,bit);
ph:=concat(convert(v),ph);
k:=k-bit;
until k=0;
converssion:=ph;
end;}

function converssion (n:string;b:byte):string;
begin
if b=8 then bit:=3
else bit:=4;
while length(n) mod bit <>0 do
n:=concat('0',n);
k:=0;
ph:='';
repeat
v:=copy(n,k+1,bit);
ph:=concat(ph,convert(v));
k:=k+bit;
until k=length(n);
converssion:=ph;
end;

begin
Saisie_ch(n);
saisie_base(b);
write(converssion(n,b));
end.

***********************************************************

conversion de base 8 et 16 a base 2

program test;
uses wincrt;
type
ch=string[46];
ch0=string[4];
var
n,v:string;
b:byte;
ph:string;

u:string;
r:integer;
procedure saisie_base(var B : byte);
begin
repeat
write('donner une base dans [2..36] : ');
readln(B);
until B in [2..36];
end;
procedure base(var ch1:ch;B:byte);
var
k:integer;
x:string[1];
begin
if b <= 10 then
begin
ch1:='';
for k:=0 to b-1 do begin str(k,x);ch1:=concat(ch1,x); end;
end
else
begin
ch1:='0123456789';
for k:= 10 to b-1 do ch1:=concat(ch1,chr(ord('A')+k-10));
end;
end;
function recherche(n:string;ch1:ch):boolean;
var
i:integer;
begin
i:=0;
repeat
i:=i+1;
until (pos(upcase(n[i]),ch1)=0) or (i > length(n));
if i > length(n) then recherche:=true
else recherche:=false;
end;
procedure saisie_ch(var n : string);
var
ch1:ch;
begin
Base(ch1,B);
repeat
write('donner un nombre dans la base :');
readln(n);
until Recherche(n,ch1);
end;

function convert(c:char;b:byte):ch0;
var j,x,e,r:integer;
v:string[1];
begin
if c in ['0'..'9'] then val(c,x,e)
else x:=ord(upcase(c))-ord('A')+10;

if b=8 then begin
u:='000';
j:=3;
end
else
begin
u:='0000';
j:=4;
end;
repeat
r:=x mod 2;
str(r,v);
u[j]:=v[1];
j:=j-1;
x:=x div 2;
until x=0;
convert:=u;
end;

function conversion (n:string):string;

var i:integer;
begin
ph:='';
for i:=1 to length(n) do
ph:=concat(ph,convert(n[i],b));
conversion:=ph;
end;

begin
saisie_base(b);
Saisie_ch(n);
write(conversion(n));
end.

****************************************************************

conversion de base 10 a l'autres bases

program base10_base;
uses wincrt;
var
n:integer;
b:byte;

procedure saisie_base(var b : byte);
begin
repeat
write('donner une base dans [2..36] : '); readln(b);
until b in [2..36];
end;

procedure saisie_n(var n : integer;x:integer);
begin
repeat
write('donner un entier dans > ',x,' : '); readln(n);
until n > x;
end;

Procedure affichage(x:byte);
begin

if x in [0..9] then write(x)
else write(chr(ord('A')+ x - 10));
end;

procedure remplir (n:integer;b:byte);
begin
if n<>0 then
begin
remplir(n div b,b);
affichage(n mod b);
end;
end;

begin
saisie_n(n,0);
saisie_base(b);
remplir(n,b);
end.

*******************************************************

conversio autres bases a la base 10

program base_base10;
uses wincrt;
type
ch=string[46];
var n:string;
b:byte;
p,s:integer;
procedure saisie_base(var b : byte);
begin
repeat
write('donner une base dans [2..36] : '); readln(b);
until b in [2..36];
end;

procedure base (var ch1:ch;b:byte);
var k:integer;
x:string[1];
begin
if b<=10 then
begin
ch1:='';
for k:=0 to b-1 do
begin str(k,x); ch1:=concat(ch1,x);end;
end
else
begin
ch1:='0123456789';
for k:=10 to b-1 do
ch1:=concat(ch1,chr(ord('A')+k-10));
end;
writeln(ch1);
end;

function recherche (n:string;ch1:ch):boolean;
var
i:integer;
begin
i:=0;
repeat
i:=i+1;
until (pos(upcase(n[i]),ch1)=0) or(i>length(n));
if i>length(n) then recherche:=true
else recherche:=false;
end;

procedure saisie_ch(var n:string);
var ch1:ch;
begin
base (ch1,b);
repeat
write('donner un nombre dans la base: ');
readln(n);
until recherche (n,ch1);
end;

function puis (b,r:integer):integer;
var i:integer;
begin
p:=1;
for i:= 1 to r do
p:=p*b;
puis:=p;
end;

function conver(b:byte; n:string):integer;
var
i,e:integer;
y:integer;
x:string[1];
begin
s:=0;
for i:=1 to length(n) do
begin
if n[i] in ['0'..'9'] then val(n[i],y,e)
else y:= (ord(upcase(n[i]))-ord('A') + 10);

s:=s+y*puis(b,length(n)-i);
end;
conver:=s;
end;
begin
saisie_base(b);
saisie_ch(n);
writeln(conver(b,n));
end.