M1RAI

conv_rom_to_ar_numbers

Nov 27th, 2019
111
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.  
  86. procedure Crypt(var fs,fc:text);
  87. var mot,x,R,d,b:string;
  88. begin
  89.   reset(fs);
  90.   rewrite(fc);
  91.   while not(eof(fs)) do
  92.     begin
  93.         R:='';
  94.         readln(fs,x);
  95.         x:=x+' ';
  96.         d:='';
  97.         b:='';
  98.         while(x<>'') do
  99.         begin
  100.             majusc(x);
  101.             mot:=copy(x,1,pos(' ',x)-1);
  102.             if verif(mot)
  103.             then
  104.             begin
  105.                 str(somme(mot),d);
  106.                 R:=R + d + ' ';
  107.             end
  108.             else
  109.             begin
  110.                 str(ascii(mot),b);
  111.                 R:=R + b + ' ';
  112.             end;
  113.             Delete(x,pos(' ',x),1);
  114.         end;
  115.         writeln(fc,R);
  116.     end;
  117.     close(fs);
  118.     close(fc);
  119. end;
  120.  
  121.  
  122. begin
  123. assign(fs,'C:\Pascal\devpratique\Source.txt');
  124. assign(fc,'C:\Pascal\devpratique\Crypt.txt');
  125. crypt(fs,fc);
  126. end.
RAW Paste Data