VPF::[Pascal] Из римской системы счисления в десятичную

Jam

Дата 11.12.2006, 11:27 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

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

Это сообщение отредактировал(а) Jam - 11.12.2006, 11:29

Jam

Дата 11.12.2006, 13:00 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

Ну так что сделает кто нибуть? smile

Romikgy

Дата 11.12.2006, 17:54 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 9
Всего: 146

Ну раз все молчат ... то попробую я
(да и комод видать не зря кинул ссылку )
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 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

Romikgy,

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

Alexeis

Дата 15.12.2006, 16:16 (ссылка)

(нет голосов)

Загрузка ...

Амеба

Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 23
Всего: 459

Цитата(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

Это сообщение отредактировал(а) alexeis1 - 15.12.2006, 16:16

--------------------

Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать

Sunvas

Дата 15.12.2006, 19:12 (ссылка)

(нет голосов)

Загрузка ...

Соль и сахар

Профиль
Группа: Участник
Сообщений: 3388
Регистрация: 12.3.2006
Где: Тосно

Репутация: 7
Всего: 89

Решение из 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 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

Ну все мужики! Всем спасибо громное! smile

К сожалению не могу повысить репутацию, но если можно повысьте сами от меня!!! smile

Спасибо еще раз!

Jam

Дата 25.12.2006, 11:27 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

Проблемка

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

Romikgy

Дата 25.12.2006, 12:36 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 9
Всего: 146

Код


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 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 20.10.2006

Репутация: нет
Всего: нет

XLLLLLLLLLLL - 40 , а ведь должна быть ошибка smile

ничего не понимаю smile

Romikgy

Дата 25.12.2006, 15:36 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 9
Всего: 146

Jam, вот ты нудный..... smile

я же писал ф_цию пересчета а не ф_цию поиска всех ошибок!

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

Romikgy

Дата 25.12.2006, 16:07 (ссылка)

(нет голосов)

Загрузка ...

Любитель-программер

Профиль
Группа: Участник Клуба
Сообщений: 7326
Регистрация: 11.5.2005
Где: Porto Franco Odes sa

Репутация: 9
Всего: 146

Код


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.

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

Это сообщение отредактировал(а) Romikgy - 25.12.2006, 16:07

--------------------

Владение русской орфографией это как владение кунг-фу — истинные мастера не применяют его без надобности.

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Центр помощи \| Следующая тема »