IPB
ЛогинПароль:

> Внимание! Действует предмодерация

Подраздел FAQ (ЧАВО, ЧАстые ВОпросы) предназначен для размещения готовых рабочих программ, реализаций алгоритмов. Это нечто вроде справочника, он наполнялся в течение 2000х годов. Ваши вопросы, особенно просьбы решить задачу, не пройдут предмодерацию. Те, кто наполнял раздел, уже не заходят на форум, а с теми, кто на форуме сейчас, лучше начинать общение в других разделах. В частности, решение задач — здесь.

> Общие вопросы по математике.
сообщение
Сообщение #1


Ищущий истину
******

Группа: Пользователи
Сообщений: 4 825
Пол: Мужской
Реальное имя: Олег

Репутация: -  45  +


Описание и реализация алгоритмов:


--------------------
Помогая друг другу, мы справимся с любыми трудностями!
"Не опускать крылья!" (С)
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Гость






Работа с римскими числами

Как проверить, является ли введенная с клавитуры строка римским числом, и перевести ее в арабское число?

Const
legals = 'IVXLCDM';
values:
Array[1 .. 7] Of Word =
(1, 5, 10, 50, 100, 500, 1000);
Var
s: String;
i: Byte;
value, v, c: Integer;
Begin
WriteLn('Примеры чисел:');
writeln('XXVIII=28 XXXIX=39 CCCXCVII=397 MDCCCXVIII=1818');
Write('Введите римское число: ');
ReadLn(s);
For i := 1 To Length(s) Do
If Pos(UpCase(s[i]), legals) = 0 Then
Begin
WriteLn('Ошибка - неверный символ "',s[i],'"'); Halt
End
Else s[i] := Upcase(s[i]);
v := values[Pos(s[1], legals)];
value := 0;
c := 1;
For i := 2 To Length(s) Do
If Pos(s[Pred(i)],legals) <> Pos(s[i],legals) Then
Begin
c := c * (Byte(pos(s[Pred(i)],legals) > Pos(s[i],legals))*2 - 1);
If c < (-1) Then
Begin
value := -v * c -10001; Break
End
Else Inc(value, v * c);
v := values[Pos(s[i], legals)];
c := 1;
End
Else
If c > 2 Then
Begin
value := -v * c - 10000; Break;
End
Else Inc©;

Inc(value, v * c);
Case value Of
-10000: WriteLn('Ошибка: больше 3 одинаковых элементов');
-10001: WriteLn('Ошибка: присутствует более одного меньшего элемента');
-9999..-1: WriteLn('Ошибка: отрицательный результат');
0: WriteLn('Ошибка: сгенерирован 0');
else WriteLn('Арабское число: ',value);
End;
End.


Программа переводит арабские числа в римские и наоборот:

const
n = 13; { Всего рассматривается 13 комбинаций }
pair: array[1 .. n] of record { Каждая подобная Пара однозначно определяет соответствие }
r: string[2]; { заданого в виде строки римского числа (поле R) }
a: integer; { арабскому числу, хранящемуся в поле A }
end =
(
(r: 'I' ; a: 1),
(r:'IV' ; a: 4),
(r: 'V' ; a: 5),
(r:'IX' ; a: 9),
(r: 'X' ; a: 10),
(r:'XL' ; a: 40),
(r: 'L' ; a: 50),
(r:'XC' ; a: 90),
(r: 'C' ; a: 100),
(r:'CD' ; a: 400),
(r: 'D' ; a: 500),
(r:'CM' ; a: 900),
(r: 'M' ; a: 1000)
);

{ Функция перевода целого числа (value) в строку, представляющую его в римской системе }
function ToRoman(value: integer): string;
var
theResult: string;
i: integer;
begin
theResult := '';
i := n;

while value > 0 do begin

while pair[i].a > value do dec(i);
theResult := theResult + pair[i].r;
dec(value, pair[i].a);

end;

ToRoman := theResult;
end;

{
Попытка перевода строки в арабское число.
Если в строке содержатся неподходящие символы, или полученное арабское число,
переведенное в римскую систему, выдает результат, отличающийся от входной строки S,
считается, что произошла ошибка конвертации, и функция возвращает -1
}
function ToArabic(s: string): integer;
var
theResult: integer;
i, pos: integer;
begin
ToArabic := -1;
theResult := 0;

i := n;
pos := 1;

while pos <= length(s) do begin

while copy(s, pos, length(pair[i].r)) <> pair[i].r do begin

dec(i);
{ I будет равняться 0 только если во входной строке встречается некорректный символ }
if i = 0 then exit;

end;
theResult := theResult + pair[i].a;
inc(pos, length(pair[i].r));

end;
{
Проверяем результат переводом его назад в римскую систему
}
if ToRoman(theResult) = s then ToArabic := theResult
end;

var
value, Err: integer;
s: string;

begin

{
Программа будет работать, пока пользователь не введет пустую строку
}
repeat
write('--> '); readLn(s);

if s <> '' then begin

{ Пытаемся перевести строку в число }
val(s, value, Err);

{ Если это удалось (Err = 0), то было введено арабское число, иначе - _возможно_ введено римское число }
if Err = 0 then
writeln(ToRoman(value))
else writeln(ToArabic(s));

end;

until s = '';

end.


Ну, и если кому-то понадобится рекурсивная функция перевода арабских чисел в римские - вот она:
const
n = 13;
pair: array[1 .. n] of record
r: string[2];
a: integer;
end =
(
(r: 'I' ; a: 1),
(r:'IV' ; a: 4),
(r: 'V' ; a: 5),
(r:'IX' ; a: 9),
(r: 'X' ; a: 10),
(r:'XL' ; a: 40),
(r: 'L' ; a: 50),
(r:'XC' ; a: 90),
(r: 'C' ; a: 100),
(r:'CD' ; a: 400),
(r: 'D' ; a: 500),
(r:'CM' ; a: 900),
(r: 'M' ; a: 1000)
);


function get_roman(value: integer): string;
var i: integer;
begin

if value <= 0 then get_roman := ''
else begin

i := n;
while pair[i].a > value do dec(i);
get_roman := pair[i].r + get_roman(value - pair[i].a);

end

end;
 К началу страницы 
+ Ответить 

Сообщений в этой теме


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 29.03.2024 18:17
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name