old/PAS/CHISLA.PAS

Uses CRT,DOS;
Const
  s : array [1..5] of string[27] = ('         Простое          ',
                                    '     Взаимно простые      ',
                                    '       Совершенное        ',
                                    '      Дружественные       ',
                                    '          Выход           ');

  text1 : array [1..5] of string[50] = (' Узнать простое ли число ',
                                        ' Узнать взаимно простые ли 2 числа ',
                                        ' Узнать совершенное ли число ',
                                        ' Узнать дружественные ли 2 числа ',
                                        ' Выход из программмы ');

Var
  IfExit  : boolean;
  CurMenu : integer;
{-------------------------------------------}
Procedure SetCursorSize(size:word);
var
  reg : registers;
begin
  with reg do begin
    AH := $01;
    CH := hi(size);
    CL := lo(size);
    Intr($10,reg);
  end;
end;
{------------------------------------------}
Function ReadVal(st:string) : longint;
Var
  rc        : real;
  code      : integer;
  tm        : string[35];
  ch        : char;
  x,r       : byte;
Begin
  TextColor(LightGray);
  GotoXY(24,20);
  Write('                                   ');
  GotoXY(24,20);
  Write(st);
  SetCursorSize(12*43);
  x := 24;
  repeat
    tm := '';
    GotoXY(24,22);
    Write('                                   ');
    GotoXY(24,22);
    Code := 0;
    x := 24;
    r := 1;
    ch := readkey;
    if ch = #13 then code := 1;
    While ch <> #13 do begin
      if ch in [#48..#57] then
       if x < 59 then
        begin
          tm := concat(tm,ch);
          GotoXY(x,22);
          Write(ch);
          inc(x);
          inc(r)
        end;
       if ch = #8 then
         if r > 0 then
           begin
             delete(tm,length(tm),1);
             dec(x);
             dec(r);
             GotoXY(x,22);
             Write(' ');
             GotoXY(x,22);
           end;
       ch := readkey;
    end;
    if length(tm) > 10 then code := 1
    else
     begin
       Val(tm,rc,code);
       if rc <= 0 then code := 1;
     end;
  until code = 0;
  ReadVal := trunc(rc);
  SetCursorSize(16*16);
  GotoXY(23,22);
  Write('                                    ');
  GotoXY(23,20);
  Write('                                    ')
End{ReadVal};
{---------------------------------------}
Procedure Simple;
Var
  v1 : longint;
  i  : integer;
Begin
  v1 := ReadVal('Введите целое число ');
  i  := 2;
  while (v1 mod i <> 0) and (i < v1) do inc(i);
  GotoXY(24,20);
  Write('                                    ');
  GotoXY(24,20);
  if i = v1 then
    begin
      TextColor(LightGray);
      WriteLn('Число ',v1,' простое');
    end
  else
    begin
      TextColor(LightGray);
      WriteLn('Число ',v1,' имеет делитель ',i);
    end;
  ReadKey;
  GotoXY(23,20);
  Write('                                    ');
End;{Simple}
{---------------------------------}
Procedure SimpleTwice;

Var
  v2 : longint;
  v1 : longint;
  i  : integer;

Begin
  v1 := ReadVal('Введите первое число ');
  v2 := ReadVal('Введите второе число ');
  i  := 2;
  while not ((v1 mod i = 0) and (v2 mod i = 0)) and (i <= v1) do inc(i);
  GotoXY(24,20);
  Write('                                    ');
  GotoXY(24,20);
  if (i = v1+1) and (v2 mod v1 <> 0) then
    begin
      TextColor(LightGray);
      WriteLn('Числа взаимно простые');
    end
  else
    begin
      TextColor(LightGray);
      WriteLn('Числа имеют общий делитель ',i);
    end;
  ReadKey;
  GotoXY(23,20);
  Write('                                    ');
End;{SimpleTwice}
{-------------------------------}
Procedure Perfect;
Var
 v1 : longint;
 i  : integer;
 summa : longint;
Begin
  v1 := ReadVal('Введите целое число ');
  i  := 1;
  summa := 0;
  for i := 1 to v1-1 do
    if v1 mod i = 0 then Inc(summa,i);
  GotoXY(24,20);
  Write('                                    ');
  GotoXY(24,20);
  if summa = v1 then
    begin
      TextColor(LightGray);
      WriteLn('Число ',v1, ' совершенное');
    end
  else
    begin
      TextColor(LightGray);
      WriteLn('Число ',v1, ' не совершенное ');
    end;
  ReadKey;
  GotoXY(23,20);
  Write('                                    ');
End;{Perfect}
{-------------------------------}
Procedure Friend;

Var
  v2 : longint;
  v1 : longint;
  i  : integer;
  summa1,summa2 : longint;
Begin
  v1 := ReadVal('Введите первое число ');
  v2 := ReadVal('Введите второе число ');
  i  := 2;
  summa1 := 0;
  summa2 := 0;
  for i := 1 to v1-1 do
    if v1 mod i = 0 then Inc(summa1,i);

  for i := 1 to v2-1 do
    if v2 mod i = 0 then Inc(summa2,i);
  GotoXY(24,20);
  Write('                                    ');
  GotoXY(24,20);
  if (summa1 = v2) and (summa2 = v1) then
    begin
      TextColor(LightGray);
      WriteLn('Числа дружественные');
    end
  else
    begin
      TextColor(LightGray);
      WriteLn('Числа не дружественные');
    end;
  ReadKey;
  GotoXY(23,20);
  Write('                                    ');
End;{Friend}
{-------------------------------}
Procedure ChangeMenu(MoveUP : integer);
Begin
  CurMenu := Curmenu + MoveUp;
  GotoXY(28,5+(CurMenu*2));
  TextColor(Blue);
  TextBackGround(Green);
  Write(s[CurMenu]);
  GotoXY(28,5+((CurMenu-MoveUp)*2));
  TextColor(Blue);
  TextBackGround(black);
  Write(s[CurMenu-Moveup]);
  TextColor(lightgray);
  GotoXY(23,20);
  Write('                                    ');
  GotoXY(23,20);
  Write(text1[curmenu]);
End;{ChangeMenu}
{--------------------------------}
Procedure Init;
Var
  i : byte;
Begin
  ClrScr;
  IFExit := false;
  SetCursorSize(16*16);
  TextColor(Green);
  GotoXY(2,2);Write('╔');GotoXY(2,24);Write('╚');GotoXY(79,2);Write('╗');
  GotoXY(79,24);Write('╝');GotoXY(1,1);
  for i := 3 to 78 do
    begin
      GotoXY(i,2);
      Write('═');
      GotoXY(i,24);
      Write('═')
    end;
  For i := 3 to 23 do
    begin
      GotoXY(2,i);
      Write('║');
      GotoXY(79,i);
      Write('║')
    end;
  TextColor(Blue);
  for i:= 1 to 5 do
    begin
      GotoXY(28,5+(i*2));
      Write(s[i]);
    end;
  CurMenu := 2;
  ChangeMenu(-1);
  TextColor(Magenta);
  For i := 23 to 59 do
    begin
      GotoXY(i,19);
      Write('═');
      GotoXY(i,21);
      Write('═');
      GotoXY(i,23);
      Write('═');
    end;
  GotoXY(22,19); Write('╔'); GotoXY(22,20); Write('║'); GotoXY(22,23);
  Write('╚'); GotoXY(60,19); Write('╗'); GotoXY(60,20); Write('║');
  GotoXY(60,22); Write('║'); GotoXY(22,22); Write('║'); GotoXY(60,23);
  Write('╝'); GotoXY(22,21); Write('╠'); GotoXY(60,21); Write('╣');
End;{Init}
{--------------------------------}
Procedure Main;
Var
  ch : char;
Begin
  repeat
    if KeyPressed then
      begin
        ch := readkey;
        if ch = #0 then ch := readkey;
        case ch of
          #27 : IfExit := true;
          #72 : if CurMenu <> 1 then ChangeMenu(-1);
          #80 : if CurMenu <> 5 then ChangeMenu(1);
          #13 : Case CurMenu of
                  1 :Simple;
                  2 :SimpleTwice;
                  3 :Perfect;
                  4 :Friend;
                  5 :IfExit := true;
                end;
        end;
      end;
  until IFExit;
End;{Main}
{--------------------------------}
Begin
  init;
  Main;
End.