M1RAI

conv_rom_to_ar_numbers_v2

Nov 27th, 2019
115
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. program pratique;
  2. uses wincrt;
  3. var
  4. fs,fc:text;
  5.  
  6. function majusc(ch:string):string;
  7. begin
  8.     if ch = ''
  9.     then majusc:=''
  10.     else
  11.     begin
  12.         if ch[1] in ['a'..'z'] then
  13.         begin
  14.             majusc:= upcase(ch[1]) + majusc(ch);
  15.             Delete(ch,1,1);
  16.         end
  17.         else
  18.         begin
  19.             majusc:= ch[1] + majusc(ch);
  20.             Delete(ch,1,1);
  21.         end;
  22.     end;
  23. end;
  24.          
  25.              
  26.  
  27.  
  28.  
  29. function verif(ch:string):Boolean;
  30. var i:integer;
  31. begin
  32.     i:=1;
  33.     while(i<=length(ch)) and (ch[i] in ['I','V','X','L','C','D','M']) do
  34.     Inc(i);
  35.     verif:= i > length(ch);
  36. end;
  37.  
  38. function rom_ar(c:char):integer;
  39. var x:integer;
  40. begin
  41.     case c of
  42.         'I': x:=1;
  43.         'V': x:=5;
  44.         'X': x:=10;
  45.         'L': x:=50;
  46.         'C': x:=100;
  47.         'D': x:=500;
  48.         'M': x:=1000;
  49.         end;
  50. rom_ar:=x;
  51.  
  52. end;
  53.  
  54.  
  55. function somme(ch:string):integer;
  56. var S,i:integer;
  57. begin
  58.   S:=0;
  59.   for i:=1 to Length(ch) do
  60.   begin  
  61.     S:= S + rom_ar(ch[i]);
  62.     if rom_ar(ch[i]) >= rom_ar(ch[i+1])
  63.     then S:= S + rom_ar(ch[i+1])
  64.     else S:= S - rom_ar(ch[i+1]);
  65.    end;    
  66. somme:=S;  
  67. end;
  68.  
  69. function ascii(ch:string):integer;
  70. var cha,a:string;
  71. n,e,i:integer;
  72. begin
  73.     cha:='';
  74.     a:='';
  75.     for i:=1 to Length(ch) do
  76.     begin
  77.         str(ord(ch[i]),a);
  78.         cha:= cha + a;
  79.     end;
  80.     Val(cha,n,e);
  81.     ascii:=n;
  82.  
  83. end;
  84.  
  85. procedure menu(var fs:text; i:byte);
  86. var
  87. x:string;
  88. begin
  89.     repeat
  90.         writeln('voulez vous coninuez?');
  91.         writeln('1-Oui  2-Non');
  92.         repeat
  93.             readln(i);
  94.             writeln('veuillez saisir 1 ou 2');
  95.         until (i=1) or(i=2);
  96.         if (i=1) then
  97.         reset(fs);
  98.         readln(x);
  99.         writeln(fs,x);
  100.         close(fs);
  101.     until i=2;
  102.  
  103. end;
  104.  
  105.  
  106. procedure saisie(var fs:text);
  107. var x:string;
  108. begin
  109.   rewrite(fs);
  110.   read(x);
  111.   write(fs,x);
  112.   menu(fs,i);
  113.   close(fs)
  114. end;
  115.  
  116. procedure Crypt(var fs,fc:text);
  117. var mot,x,R,d,b:string;
  118. begin
  119.   reset(fs);
  120.   rewrite(fc);
  121.   while not(eof(fs)) do
  122.     begin
  123.         R:='';
  124.         readln(fs,x);
  125.         x:=x+' ';
  126.         d:='';
  127.         b:='';
  128.         while(x<>'') do
  129.         begin
  130.             majusc(x);
  131.             mot:=copy(x,1,pos(' ',x)-1);
  132.             if verif(mot)
  133.             then
  134.             begin
  135.                 str(somme(mot),d);
  136.                 R:=R + d + ' ';
  137.             end
  138.             else
  139.             begin
  140.                 str(ascii(mot),b);
  141.                 R:=R + b + ' ';
  142.             end;
  143.             Delete(x,pos(' ',x),1);
  144.         end;
  145.         writeln(fc,R);  
  146.     end;
  147.     close(fs);
  148.     close(fc);
  149. end;
  150.  
  151.  
  152. begin
  153. assign(fs,'C:\Pascal\devpratique\Source.txt');
  154. assign(fc,'C:\Pascal\devpratique\Crypt.txt');
  155. saisie(fs);
  156. crypt(fs,fc);
  157. end.
RAW Paste Data