Ответ Darina18 на закрытую тему (Задачи по Паскаль)

[JUDAS]

Здравствуйте Дарина !
Вашу тему закрыл один из модераторов. Не смотря на это, у каждого человека должен быть шанс на помощь ))). Ваши задачки очень интересны и своеобразны.
Вот полный код программы, которая решает все ваши 9 задач подряд.
Единственная проблема - ввод украинского текста через консоль. Я использовал функцию OemToChar из windows.

program Darina11;
uses
  windows;
const
  MOUNT : array[1..12] of byte = (31,28,31,30,31,30,31,31,30,31,30,31);
  WEEK  : array[0..6] of string = ('PN','VT','SR','CH','PT','SB','VS');
  ukrlower = 'абвгдеєжзиіїйклмнопрстуфхцчшщєюяь';
  ukrupper = 'АБВГДЕЄЖЗИІЇЙКЛМНОПРСТУФХЦЧШЩЄЮЯЬ';
  yname : array[0..11] of string = ('krica','korova','tiger','zaec','drakon','zmeya',
   'loshady','ovca','obezyana','kurica','pzina','svinya');
  ycolor : array[0..4] of string = ('green','red','yellow','white','black');
  ntype  : array[0..6] of string = ('error','ShortInt', 'Byte', 'Integer', 'Word', 'LongInt', 'Real');

function CheckYear(Y:integer):string;
var v : byte;
begin
  v:=0;
  if Y mod 10 = 1 then v:=1 else
  if Y mod 10 in [2..4] then v:=2;
  if Y div 10 = 1 then v:=0;

  case v of
   0: CheckYear:='let';
   1: CheckYear:='god';
   2: CheckYear:='goda';
  end;
end;

function CheckYearByJappan(Y:integer):string;
var i1, i2 : integer;
begin
  // 4-й год - такой же как и 1984
  i1:= (Y-4) mod 60;
  i2:= (i1 div 12);
  i1:= (i1 mod 12);
  result := ycolor[i2]+' '+yname[i1];
end;

 // 9. Записать целое число N (N <13) римской нумерацией.
function GetRomanStr(N:integer):string;
var
  S : string;
  i : integer;
begin
  S:='';
  case N of
   1..3 : for i:=1 to N do S:=S+'I';
   4    : S:='IV';
   5..8 : begin
           S:='V';
           for i:=6 to N do S:=S+'I';
          end;
   9    : S:='IX';
   10..13:begin
           S:='X';
           for i:=11 to N do S:=S+'I';
          end;
  end;
  GetRomanStr:=S;
end;

var x,y : double;
    i,j : integer;
    d,m,year, c: integer;
    s,r : string;
    IsType : byte = 0; // 0 - ошибка
begin
  writeln('Task 1');
// 1. Точка на плоскости задана целыми координатами.
// Изменить соответствующую координату точки на единицу в зависимости от нажатия клавиши, 
  writeln('enter base position (X Y Side) ');
  writeln('side : L (left), R (right), U (up), D (down)');  read(x,y,s);
  s:=Trim(AnsiUppercase(s));
  r:='1';
  if length(s)>0 then
  case s[1] of
   'L': x:=x-1;
   'R': x:=x+1;
   'U': y:=y+1;
   'D': y:=y-1;
   else
     r:='';
  end else
  r:='';

  if r='' then
   writeln('error side') else
   writeln('Point (X=',x:8:2,', Y=',y:8:2,')');

  writeln('Task 2');
// 2. Для натурального числа K <100 вывести фразу "K лет".

  writeln('enter year ');read(i);
  if i in [1..100] then
  begin
   r:=CheckYear(i);
   writeln(i,' ',r);
  end else
  writeln('error input');

  writeln('Task 3');
 // 3. Определить день недели по указанной датой.
  writeln('enter data DD MM YYYY ');read(d,m,year);
 // допустим 1.01.1990 был понедельник
 // считатем сколько дней между 1.01.1990 с учётом высокосных годов
 j := 0;
 for i:=1990 to year-1 do
 inc(j, 365+byte((i mod 4) = 0));
 // приплюсовуем текущую дату в текущем году
 for i:=1 to m-1 do
 if i<>2 then j:=j+MOUNT[i] else
 j:=j+MOUNT[i] + byte((year mod 4) = 0);
 j:=j+d-1;
 writeln(WEEK[j mod 7]);

 writeln('Task 4');
// 4. Запрограммировать проверку тестового задания на умножение натуральных чисел в пределах сотни. 
 Randomize;
 c:=0;
 for i:= 1 to 10 do
 begin
   d:= round(random(99)+1);
   m:= round(random(99)+1);
   writeln(d,'*',m,' = ?');
   j:= random(2)+1;
   writeln('variants 1-',round(d*m+j), ', 2-', round(d*m-j), ', 3-', round(d*m));
   read(j);
   if j=3 then inc(c);
 end;
 writeln('Questions = 10, Errors = ',10-c);
 writeln('Scope = ',5-round(c/5)); 
end.

Надеюсь вы не розачаровались в форуме и не покинули его

[JUDAS]

begin
 // ПРОДОЛЖЕНИЕ КОДА
 writeln('Task 5');

 writeln('enter weight (kg.) '); read(i);
 writeln('enter growth (sm.) '); read(j);

// 5. Голландский медик Рейнхолд Лаесле вычислил индекс массы тела человека
 x:=0.01*j;
 x:=i/(x*x);
 if X<20 then writeln('distrophic') else
 if (X>=20) and (X<25)  then writeln('normal') else
 if (X>=25) and (X<30)  then writeln('izbitochnij') else
 if (X>=30) and (X<40)  then writeln('zhirhaya svinya') else
 writeln('kaban s record Giness');        
 writeln('Task 6');

 //6. За малой украинской буквой записать соответствующую большую.
 writeln('Read ukrainan text '); read(s);
 setlength(R, length(S));
 OemToChar(@S[1],@r[1]);
 for i:=1 to length(r) do
 begin
   if r[i]=#0 then r[i]:=' ';
   j:=Pos(r[i],ukrlower);
   if j<1 then r[i]:=' ';
   r[i]:=UkrUpper[j];
 end;
 CharToOem(@r[1],@S[1]);
 writeln(S);
                         
 writeln('Task 7 avtor proschelkal');   
 writeln('Task 8');
// 8. В старояпонском календаре был принят 60-летний цикл, состоящий из пяти 12-летних подциклов
 writeln('enter year '); read(year);
 if year>=0 then
 writeln(CheckYearByJappan(year)) else
 writeln('left year, or left ERA ');      

 writeln('Task 9');
 // 9. Записать целое число N (N <13) римской нумерацией.
  writeln('enter number '); read(i);
 if i in [1..13] then
  writeln(GetRomanStr(i))
 else
 writeln('out of number');

 //10. Определить тип введенного числа: ShortInt, Byte, Integer, Word, LongInt, Real.
 // пусть IsType : byte = 0; // тип данных где 0 - ошибка
 // 1-ShortInt, 2-Byte, 3-Integer, 4-Word, 5-LongInt, 6-Real  10-вещ. 11-целый
 writeln('================');
 writeln('Task 10');
 writeln('enter value '); read(s);
 s:=Trim(S);
 // проверяем на допустимые символы
 IsType := 0;
 for i:=1 to LenGth(S) do
 if not (S[i] in ['0'..'9','.']) then
 break;
 IsType := 11;
 // проверяем на вещественность/целость
 for i:=1 to LenGth(S) do
 if (S[i]='.') then
 begin
  IsType := 10;
  break;
 end;
 // пробуем превратить в число
 case IsType of
  10: if TryStrToFloat(S, x) then
       IsType:=6 else
       IsType:=0;
  11: if TryStrToInt(S, i) then
      begin
        if (i>-$80) and (i<$80) then IsType:=1 else
        if (i>=0) and (i<=$FF) then  IsType:=2 else
        if (i>=0) and (i<=$ffff) then IsType:=4 else
        if (i>=-$7ffffff) and (i<=$7ffffff) then IsType:=3 else
        if (i>=0) and (i<=$fffffff) then IsType:=5 else
        IsType:=0;
      end else
      IsType:=0;
 end;
 writeln('type of = ',ntype[IsType]);
end.