Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Центр помощи > [Pascal] Из римской системы счисления в десятичную


Автор: Jam 11.12.2006, 11:27
Задача такая , С клавиатуры вводится число в римской системе счисления , и программа должна перевести его в 10 с.с. , кстати там должны быть еще проверка , ну типо , если я напишу "IIIXCL" это ж неправильно , так как разряды какие то там не соответсвуют.
Заранее спасибо!  smile 

Автор: Jam 11.12.2006, 13:00
Ну так что сделает кто нибуть? smile

Автор: Romikgy 11.12.2006, 17:54
Ну раз все молчат ... то попробую я 
(да и комод видать не зря кинул ссылку )
smile
Код

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;
function rpos(const sub, str: string ): Integer;
 var l1,l2,l3:Integer;
 flag: Boolean;
begin
   Result:=0;
   l3:=Length(sub);
  for l2:=Length(str) downto Length(sub) do
  begin
    flag:=True;
    l1:=l3;
    while (l1>=1) and (flag) do

   begin
     if str[l2-(l3-l1)]<>sub[l1] then flag:=False;
     l1:=l1-1;
   end;
   Result:=l2-l3+1;
   if flag and (l1=0) then Exit;
  end;
  Result:=0;
end;

procedure rom2dec(const sx:string);
const all_ch:string ='IVXLCDM';
ed: array [1..9] of string =('I','II','III','IV','V','VI','VII','VIII','IX');
de: array [1..9] of string = ('X','XX','XXX','XL','L','LX','LXX','LXXX','XC');
sot: array [1..9] of string = ('C','CC','CCC','CD','D','DC','DCC','DCCC','CM');
  //digi: array [1..7] of Integer =(1,5,10,50,100,500,1000);
 var
 ss: string;
 god,t,i: Integer;
begin
  god:=0;
  t:=0;
  ss:=sx;

  begin
    //edin
    for i:=9 downto 1 do
    if rpos(ed[i],ss)>0 then
    begin
      if (i=5) and (rpos(ed[4],ss)>0) then t:=-1;
      god:=god+(i+t);
      ss:=Copy(ss,1,rpos(ed[(i+t)],ss)-1);
      Break;
    end;
    //dec
    t:=0;
    for i:=9 downto 1 do
    if rpos(de[i],ss)>0 then
    begin
      if (i=5) and (rpos(de[4],ss)>0) then t:=-1;
      god:=god+(i+t)*10;
      ss:=Copy(ss,1,rpos(de[(i+t)],ss)-1);
      Break;
    end;
    //sot
    t:=0;
    for i:=9 downto 1 do
    if rpos(sot[i],ss)>0 then
    begin
      if (i=5) and (rpos(sot[4],ss)>0) then t:=-1;
      god:=god+(i+t)*100;
      ss:=Copy(ss,1,rpos(sot[(i+t)],ss)-1);
      Break;
    end;
    //tus
    while ss<>'' do
    if rpos('M',ss)>0 then
    begin
      god:=god+1000;
      if Length(ss)=1 then ss:='' else
         ss:=Copy(ss,1,rpos('M',ss)-1);
    end
    else
    begin

      Break;
    end;  
  end;
  if (ss='') then
  Writeln(god)
  else
  Writeln('Error');
end;

var sx: string;


begin
  
  { TODO -oUser -cConsole Main : Insert code here }
  Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);

  while sx<>'' do
  begin
   rom2dec(sx);
   Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);
  end;
end.

Автор: Jam 15.12.2006, 15:37
Romikgy, 

ошибка
1) не может найти файл sysunit.tpu
2) {$ACC...} , стираешь $ и проходит этот коммент
3) Result не описана
4) //dce <--- что такое "//" там бегина просит , я не понимаю , помоги разоьрать это smile

Автор: Alexeis 15.12.2006, 16:16
Цитата(Jam @  15.12.2006,  15:37 Найти цитируемый пост)
1) не может найти файл sysunit.tpu

Нужно убрать 
Цитата

uses
  SysUtils;


Цитата(Jam @  15.12.2006,  15:37 Найти цитируемый пост)
2) {$ACC...} , стираешь $ и проходит этот коммент

Нужно убрать целиком
Цитата

{$APPTYPE CONSOLE}


Цитата(Jam @  15.12.2006,  15:37 Найти цитируемый пост)
3) Result не описана


ее везде нужно заменить на rpos


Цитата(Jam @  15.12.2006,  15:37 Найти цитируемый пост)
4) //dce <--- что такое "//" там бегина просит , я не понимаю , помоги разоьрать это smile 

Эту строчку тоже нужно убрать целиком.

Это все нововведения делфи smile

Автор: Sunvas 15.12.2006, 19:12
Решение из DRKB:
Код

function RomanToDec(const Value: string): integer; 
var 
  i, lastValue, curValue: integer; 
begin 
  Result := 0; 
  lastValue := 0; 
  for i := Length(Value) downto 1 do 
  begin 
    case UpCase(Value[i]) of 
      'C': 
        curValue := 100; 
      'D': 
        curValue := 500; 
      'I': 
        curValue := 1; 
      'L': 
        curValue := 50; 
      'M': 
        curValue := 1000; 
      'V': 
        curValue := 5; 
      'X': 
        curValue := 10; 
    else 
      raise Exception.CreateFmt('Invalid character: %s', [Value[i]]); <--Проверка ошибки
    end; 
    if curValue < lastValue then 
      Dec(Result, curValue) 
    else 
      Inc(Result, curValue); 
    lastValue := curValue; 
  end; 
end; 


Код правда на Делфи, но один хрен...

Автор: Jam 16.12.2006, 09:53
Ну все мужики! Всем спасибо громное! smile К сожалению не могу повысить репутацию, но если можно повысьте сами от меня!!! smile Спасибо еще раз!

Автор: Jam 25.12.2006, 11:27
Проблемка smile программа работает неверно , если внести
"IC" покажет 1 , а на самом деле должно быть ERror . исправьте пожалуйста скорее!!! smile 

Автор: Romikgy 25.12.2006, 12:36
Код

function rpos(const sub, str: string ): Integer;
 var l1,l2,l3:Integer;
 flag: Boolean;
begin
   Result:=0;
   l3:=Length(sub);
  for l2:=Length(str) downto Length(sub) do
  begin
    flag:=True;
    l1:=l3;
    while (l1>=1) and (flag) do

   begin
     if str[l2-(l3-l1)]<>sub[l1] then flag:=False;
     l1:=l1-1;
   end;
   Result:=l2-l3+1;
   if flag and (l1=0) then Exit;
  end;
  Result:=0;
end;

procedure rom2dec(const sx:string);
const all_ch:string ='IVXLCDM';
ed: array [1..9] of string =('I','II','III','IV','V','VI','VII','VIII','IX');
de: array [1..9] of string = ('X','XX','XXX','XL','L','LX','LXX','LXXX','XC');
sot: array [1..9] of string = ('C','CC','CCC','CD','D','DC','DCC','DCCC','CM');
  //digi: array [1..7] of Integer =(1,5,10,50,100,500,1000);
 var
 ss: string;
 god,t,i: Integer;
begin
  god:=0;
  t:=0;
  ss:=sx;

  begin
    //edin
    for i:=9 downto 1 do
    if rpos(ed[i],ss)>0 then
    begin
      if (rpos(ed[i],ss)+Length(ed[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (rpos(ed[4],ss)>0) then t:=-1;
      god:=god+(i+t);
      ss:=Copy(ss,1,rpos(ed[(i+t)],ss)-1);
      Break;
    end;
    //dec
    t:=0;
    for i:=9 downto 1 do
    if rpos(de[i],ss)>0 then
    begin
      if (rpos(de[i],ss)+Length(de[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (rpos(de[4],ss)>0) then t:=-1;
      god:=god+(i+t)*10;
      ss:=Copy(ss,1,rpos(de[(i+t)],ss)-1);
      Break;
    end;
    //sot
    t:=0;
    for i:=9 downto 1 do
    if rpos(sot[i],ss)>0 then
    begin
      if (rpos(sot[i],ss)+Length(sot[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (rpos(sot[4],ss)>0) then t:=-1;
      god:=god+(i+t)*100;
      ss:=Copy(ss,1,rpos(sot[(i+t)],ss)-1);
      Break;
    end;
    //tus
    while ss<>'' do
    if rpos('M',ss)>0 then
    begin
      god:=god+1000;
      if Length(ss)=1 then ss:='' else
         ss:=Copy(ss,1,rpos('M',ss)-1);
    end
    else
    begin

      Break;
    end;  
  end;
  if (ss='') then
  Writeln(god)
  else
  Writeln('Error');
end;

var sx: string;


begin

  { TODO -oUser -cConsole Main : Insert code here }
  Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);

  while sx<>'' do
  begin
    sx:=UpperCase(sx);
   rom2dec(sx);
   Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);
  end;
end.

Автор: Jam 25.12.2006, 15:30
XLLLLLLLLLLL - 40 , а ведь должна быть ошибка smile ничего не понимаю smile

Автор: Romikgy 25.12.2006, 15:36
Jam, вот ты нудный..... smile я же писал ф_цию пересчета а не ф_цию поиска всех ошибок!

Автор: Romikgy 25.12.2006, 16:07
Код

function rpos(const sub, str: string ): Integer;
 var l1,l2,l3:Integer;
 flag: Boolean;
begin
   //Result:=0;
   l3:=Length(sub);
  for l2:=Length(str) downto Length(sub) do
  begin
    flag:=True;
    l1:=l3;
    while (l1>=1) and (flag) do

   begin
     if str[l2-(l3-l1)]<>sub[l1] then flag:=False;
     l1:=l1-1;
   end;
   Result:=l2-l3+1;
   if flag and (l1=0) then Exit;
  end;
  Result:=0;
end;

procedure rom2dec(const sx:string);
const all_ch:string ='IVXLCDM';
ed: array [1..9] of string =('I','II','III','IV','V','VI','VII','VIII','IX');
de: array [1..9] of string = ('X','XX','XXX','XL','L','LX','LXX','LXXX','XC');
sot: array [1..9] of string = ('C','CC','CCC','CD','D','DC','DCC','DCCC','CM');
  //digi: array [1..7] of Integer =(1,5,10,50,100,500,1000);
 var
 ss: string;
 god,t,i,tek: Integer;
begin
  god:=0;
  t:=0;
  ss:=sx;

  begin
    //edin
    for i:=9 downto 1 do
    begin
      tek:=rpos(ed[i],ss);
    if tek>0 then
    begin
      if (tek+Length(ed[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (tek>0) then t:=-1;
      god:=god+(i+t);
      ss:=Copy(ss,1,tek-1);
      Break;
    end;
    end;
    if (rpos(ed[1],ss)>0) or (rpos(ed[5],ss)>0) then
    begin
       Writeln('Error');
        Exit;
    end;
    //dec
    t:=0;
    for i:=9 downto 1 do
    begin
      tek:=rpos(de[i],ss);
    if tek>0 then
    begin
      if (tek+Length(de[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (tek>0) then t:=-1;
      god:=god+(i+t)*10;
      ss:=Copy(ss,1,tek-1);
      Break;
    end;
    end;
    if (rpos(de[1],ss)>0) or (rpos(de[5],ss)>0) then
    begin
       Writeln('Error');
        Exit;
    end;
    //sot
    t:=0;
    for i:=9 downto 1 do
    begin
      tek:=rpos(sot[i],ss);
    if tek>0 then
    begin
      if (tek+Length(sot[i])-1<>Length(ss)) then
      begin
        Writeln('Error');
        Exit;
      end;
      if (i=5) and (tek>0) then t:=-1;
      god:=god+(i+t)*100;
      ss:=Copy(ss,1,tek-1);
      Break;
    end;
    end;
    if (rpos(sot[1],ss)>0) or (rpos(sot[5],ss)>0) then
    begin
       Writeln('Error');
        Exit;
    end;
    //tus
    while ss<>'' do
    if rpos('M',ss)>0 then
    begin
      if (rpos('M',ss)<>Length(ss)) then
      begin
        Break;
      end;
      god:=god+1000;
      if Length(ss)=1 then ss:='' else
         ss:=Copy(ss,1,rpos('M',ss)-1);
    end
    else
    begin

      Break;
    end;  
  end;
  if (ss='') then
  Writeln(god)
  else
  Writeln('Error');
end;

var sx: string;


begin

  { TODO -oUser -cConsole Main : Insert code here }
  Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);

  while sx<>'' do
  begin
    sx:=UpperCase(sx);
   rom2dec(sx);
   Writeln('Please enter digital in roman (enter for exit)');
  Readln(sx);
  end;
end.

воть так , вроде все поправил....

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)