Определить номера точек, которые могут являться вершинами квадрата.

 {$I-} {отключаем обычную реакцию на ошибки}
  repeat
    Writeln('Введите наименование файла');
    readln(NameFile);
    assign(f,nameFIle);
    reset(f);
    If IOResult<>0 then
    begin
      Writeln('Запрашиваемый вами файл ' ,Namefile, ' не найден, повторите ввод');
      readkey;
      reset(f)
    end;
    clrscr;
  until IOResult=0; 
 {$I+} {не забываем включать проверку ввода/вывода}

Procedure punkt2;
Var
 a:array[1..15,1..15] of integer;
 l:array[1..15] of Byte;
 i,j,n,max,x:integer;
 b,f1:boolean;
 f:text;
 
BEGIN
 restorecrtmode;
 clrscr;
textbackground(0);
textcolor(15);
clrscr;
f1:=false;
repeat
textbackground(0);
textcolor(15);
Menyu(k,3);{выводим меню}
clrscr;
case k of{выбираем стрелками действие}
1:begin
   SubMenyu(w,2,3,1);
   case w of
   1:begin
      clrscr;
      textbackground(0);
      textcolor(15);
      Resetfile(f,'matrica.txt',b);
      if not b then
       begin
        writeln('Создайте файл или введите данные с клавиатуры');
        readln;
        Menyu(k,3);
       end
      else
       begin
        n:=0;
        while not eof(f) do
         begin
          read(f,a[2*n+1],a[2*n+2]);
          n:=n+1;
         end;
        close(f);
        f1:=true;
        writeln('n=',n);
        write('Press Enter');
        readln;
       end;
     end;
2:begin
      textbackground(0);
      textcolor(15);
      clrscr;
      repeat
 Write('Введите размерность матрицы');
 Readln(n);
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('A[',i,',',j,']= ');
    readln(a[i,j]);
   end;
 clrscr;
f1:=true;
     end;
   end;
  end;
2:begin
  SubMenyu(w,2,3,2);
  case w of
  1:begin
    textbackground(0);
    textcolor(15);
    clrscr;
    if not f1 then
     begin
      write('Матрица еще не создана, вернитесь к пункту 1');
      readln;
      SubMenyu(w,2,3,1);
      exit;
     end;
 writeln('Исходная матрица:');
 for i:=1 to n do
  begin
   for j:=1 to n do
   write(a[i,j]:5);
   writeln;
   write('Y:');
   for j:=1 to n do
   write(a[i,j]:5);
   writeln;
  end;
 writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
 
2:begin
    assign(f,'result.txt') ;
    rewrite(f);
    textbackground(0);
    textcolor(15);
    clrscr;
    writeln(f,'Исходные данные:');
    write(f,'X:');
for i:=1 to n do
begin
   for j:=1 to n do
writeln(f,'');
write(f,'Y:');
end;
for i:=1 to n do
begin
   for j:=1 to n do
write(f,a[i,j]:5);
writeln(f,'');
end;
writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
begin
      p:=1;
writeln(f,'исходная матрица’);
end;
if p=0 then write(f,’ошибка');
writeln('Результат записан в файл RESULT.TXT') ;
    readln;
    close(f); 
   end;
 end;
end;
3:begin
  Init;
  MenuToScr;
  end;
end;
until k=3;
end;

program Full;
{$R-}
uses Crt, Graph;
const
     NORM=WHITE; { цвет невыделеного пункта }
     SEL=YELLOW;  { цвет выделенного пункта }
     BackSelectedColor=Cyan;
     BackNotSelectedColor=Black;
 
     N=5;      {количество пунктов в меню}
     HeightSize = 40; {высота, занимаемая каждой строчкой в меню}
     WidthSize = 200; {длина каждой строчки}
     {массив названий пунктов вспомогательных меню}
     glav:array[1..3] of string=('1-Ввод',
                                 '2-Вывод',
                                 '3-Выход');
     vvod:array[1..2] of string=('1-Из файла',
                                 '2-С клавиатуры');
     vyvod:array[1..2] of string=('1-На экран',
                                  '2-В файл');
var
     menu:array[1..N] of string[12];{ названия пунктов меню }
     punkt:integer;  { номер выделенного пункта }
     ch:char;        { введенный символ }
     x,y:integer;    { координаты первой строки меню }
     k,w:byte;{переменные для выбора пунктов в вспомогательных меню}
 
Procedure Init;
var grDriver,grMode:Integer;
begin
grDriver := Detect;
InitGraph(grDriver, grMode,'..\BGI');
end;
procedure ResetFile(var f:text;name:string;var b:boolean);
begin
b:=true;
assign(f,name);
{$I-} reset(f);  {$I+}
if IOResult <> 0 then
  begin
   b:=false;
   writeLn('Файл ',name,' не найден!');
   writeLn(' Нажмите ENTER');
   readln;
   exit;
  end
end;
procedure ShowSelectedPunkt;
begin
     SetFillStyle(1, BackSelectedColor );
     Bar(x,y+(punkt-1)*HeightSize-(HeightSize div 4),
         x + WidthSize, y+(punkt-1)*HeightSize+3*(HeightSize div 4));
     SetColor(SEL);
     MoveTo(x,y+(punkt-1)*HeightSize);
     OutText(menu[punkt]);{ выделим строку меню }
     SetColor(NORM);
end;
 
procedure ShowNotSelected(i : integer);
begin
     SetFillStyle(1, BackNotSelectedColor);
     Bar(x,y+(i-1)*HeightSize-(HeightSize div 4),
         x + WidthSize, y+(i-1)*HeightSize+3*(HeightSize div 4));
     SetColor(NORM);
     MoveTo(x,y+(i-1)*HeightSize);
     OutText(menu[i]);{ выделим строку меню }
end;
 
Procedure MenuToScr;{ вывод меню на экран }
var i:integer;
begin
     ClearDevice;
     SetTextStyle(TriplexFont, HorizDir, 2);
     SetTextJustify(LeftText, TopText);
     SetColor(NORM);
     for i:=1 to N do begin
          ShowNotSelected(i);
     end;
     ShowSelectedPunkt;
end;
 
procedure Menyu(var k: byte;kol:byte);
var kod: char;
    i:byte;
begin
clrscr;
k:=1;
gotoxy(5,1);
repeat
  for i:=1 to kol do
   begin
     if i=k then
      begin
         textbackground(3);
         textcolor(12);
      end
     else
      begin
         textbackground(0);
         textcolor(15)
      end;
     gotoxy(12*(i-1)+1,1);
     write(glav[i]);
   end;
  repeat
  kod:=readkey;
  until kod in [#13, #75, #77];
  case kod of
  #75: begin  {стрелка влево}
       k:=k-1;
       if k=0 then k:=kol;{если левый край, в конец}
       end;
  #77: begin  {стрелка вправо}
       k:=k+1;
       if k>kol then k:=1;{если правый край, в нвчало}
       end;
   end;
 until kod=#13;
end;
 
procedure SubMenyu(var k:byte;kol1,kol2,w:byte);
{создание и вывод на экран выпадающего меню}
var kod: char;
    i:byte;
begin
window(1,1,80,25);
textbackground(0);
clrscr;
for i:=1 to kol2 do{воостановим главное меню}
 begin
  gotoxy(12*(i-1)+1,1);
  write(glav[i]);
 end;
k:=1;
gotoxy(4,2);
k:=1; {выведен первый пункт меню}
repeat
for i:=1 to kol1 do
 begin
  if i=k then {выделенный пункт}
   begin
    textbackground(3);
    textcolor(9);
   end
  else  {остальные}
   begin
    textbackground(0);
    textcolor(15)
   end;
gotoxy(1,i+1);{ставим курсор}
case w of
1:write(vvod[i]);{выводим пункты}
2:write(vyvod[i]);
end;
end;
repeat
kod:=readkey;
until Kod in [#13, #72, #80];
case kod of
#72: begin{стрелка вверх}
     k:=k-1;
     if k=0 then k:=kol1;{если выше верха, вниз}
     end;
#80: begin {стрелка вниз}
     k:=k+1;
     if k>kol1 then k:=1;{если ниже низа, вверх}
     end;
end;
until kod=#13;{нажат Enter, выходим из меню в выбранную процедуру}
end;
 
Procedure punkt1;
const nmax=20;
{логическая функция определения квадрата}
function Square(x1,y1,x2,y2,x3,y3,x4,y4:integer):boolean;
var s1,s2,s3,s4,s5,s6:Longint;
begin
{если квадраты 4х отрезков равны
+ квадраты двух остальных отрезков равны между собой и равны 2*длина любого из первых
это квадрат }
s1:=sqr(x1-x2)+sqr(y1-y2);
s2:=sqr(x1-x3)+sqr(y1-y3);
s3:=sqr(x1-x4)+sqr(y1-y4);
s4:=sqr(x2-x3)+sqr(y2-y3);
s5:=sqr(x2-x4)+sqr(y2-y4);
s6:=sqr(x3-x4)+sqr(y3-y4);
Square:=((s1=s3)and(s1=s4)and(s1=s6)and(s2=s5)and(s2=2*s1))
     or ((s1=s2)and(s1=s5)and(s1=s6)and(s3=s4)and(s3=2*s1))
     or ((s2=s3)and(s2=s4)and(s2=s5)and(s1=s6)and(s1=2*s2));
end;
var a:array[1..2*nmax] of longint;
    n,i,j,m,q,p:byte;
    b,f1:boolean;
    f:text;
begin
restorecrtmode;
clrscr;
textbackground(0);
textcolor(15);
clrscr;
f1:=false;
repeat
textbackground(0);
textcolor(15);
Menyu(k,3);{выводим меню}
clrscr;
case k of{выбираем стрелками действие}
1:begin
   SubMenyu(w,2,3,1);
   case w of
   1:begin
      clrscr;
      textbackground(0);
      textcolor(15);
      Resetfile(f,'massiv.txt',b);
      if not b then
       begin
        writeln('Создайте файл или введите данные с клавиатуры');
        readln;
        Menyu(k,3);
       end
      else
       begin
        n:=0;
        while not eof(f) do
         begin
          read(f,a[2*n+1],a[2*n+2]);
          n:=n+1;
         end;
        close(f);
        f1:=true;
        writeln('n=',n);
        write('Press Enter');
        readln;
       end;
     end;
   2:begin
      textbackground(0);
      textcolor(15);
      clrscr;
      repeat
      write('Введите количество точек от 4 до ',nmax,' n=');
      readln(n);
      until n in [4..nmax];
      writeln('Введите координаты точек, целые числа:');
      for i:=1 to n do
       begin
        writeln('Точка ',i);
        readln(a[2*i-1],a[2*i]);
       end;
      f1:=true;
     end;
   end;
  end;
2:begin
  SubMenyu(w,2,3,2);
  case w of
  1:begin
    textbackground(0);
    textcolor(15);
    clrscr;
    if not f1 then
     begin
      write('Массив еще не создан, вернитесь к пункту 1');
      readln;
      SubMenyu(w,2,3,1);
      exit;
     end;
    writeln('Исходные координаты:');
    write('X:');
    for i:=1 to n do
    write(a[2*i-1]:4);
    writeln;
    write('Y:');
    for i:=1 to n do
    write(a[2*i]:4);
    writeln;
    p:=0;
    for i:=1 to n-3 do
    for j:=i+1 to n-2 do
    for m:=j+1 to n-1 do
    for q:=m+1 to n do
    if Square(a[2*i-1],a[2*i],a[2*j-1],a[2*j],a[2*m-1],a[2*m],a[2*q-1],a[2*q]) then
     begin
      p:=1;
      writeln('Точки номер ',i,' ',j,' ',m,' ',q);
     end;
    if p=0 then write('Нет ни одного квадрата');
    readln;
   end;
  2:begin
    assign(f,'result.txt') ;
    rewrite(f);
    textbackground(0);
    textcolor(15);
    clrscr;
    writeln(f,'Исходные координаты:');
    write(f,'X:');
    for i:=1 to n do
    write(f,a[2*i-1]:4);
    writeln(f,'');
    write(f,'Y:');
    for i:=1 to n do
    write(f,a[2*i]:4);
    writeln(f,'');
    p:=0;
    for i:=1 to n-3 do
    for j:=i+1 to n-2 do
    for m:=j+1 to n-1 do
    for q:=m+1 to n do
    if Square(a[2*i-1],a[2*i],a[2*j-1],a[2*j],a[2*m-1],a[2*m],a[2*q-1],a[2*q]) then
     begin
      p:=1;
      writeln(f,'Tochki # ',i,' ',j,' ',m,' ',q);
     end;
    if p=0 then write(f,'Нет ни одного квадрата');
    writeln('Результат записан в файл RESULT.TXT') ;
    readln;
    close(f); 
   end;
 end;
end;
3:begin
  Init;
  MenuToScr;
  end;
end;
until k=3;
end;
 
Procedure punkt2;
Var
 a:array[1..15,1..15] of integer;
 l:array[1..15] of Byte;
 i,j,n,max,x:integer;
 b,f1:boolean;
 f:text;
 
BEGIN
 restorecrtmode;
 clrscr;
textbackground(0);
textcolor(15);
clrscr;
f1:=false;
repeat
textbackground(0);
textcolor(15);
Menyu(k,3);{выводим меню}
clrscr;
case k of{выбираем стрелками действие}
1:begin
   SubMenyu(w,2,3,1);
   case w of
   1:begin
      clrscr;
      textbackground(0);
      textcolor(15);
      Resetfile(f,'matrica.txt',b);
      if not b then
       begin
        writeln('Создайте файл или введите данные с клавиатуры');
        readln;
        Menyu(k,3);
       end
      else
       begin
        n:=0;
        while not eof(f) do
         begin
          read(f,a[2*n+1],a[2*n+2]);
          n:=n+1;
         end;
        close(f);
        f1:=true;
        writeln('n=',n);
        write('Press Enter');
        readln;
       end;
     end;
2:begin
      textbackground(0);
      textcolor(15);
      clrscr;
      repeat
 Write('Введите размерность матрицы');
 Readln(n);
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('A[',i,',',j,']= ');
    readln(a[i,j]);
   end;
 clrscr;
f1:=true;
     end;
   end;
  end;
2:begin
  SubMenyu(w,2,3,2);
  case w of
  1:begin
    textbackground(0);
    textcolor(15);
    clrscr;
    if not f1 then
     begin
      write('Матрица еще не создана, вернитесь к пункту 1');
      readln;
      SubMenyu(w,2,3,1);
      exit;
     end;
 writeln('Исходная матрица:');
 for i:=1 to n do
  begin
   for j:=1 to n do
   write(a[i,j]:5);
   writeln;
   write('Y:');
   for j:=1 to n do
   write(a[i,j]:5);
   writeln;
  end;
 writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
 
2:begin
    assign(f,'result.txt') ;
    rewrite(f);
    textbackground(0);
    textcolor(15);
    clrscr;
    writeln(f,'Исходные данные:');
    write(f,'X:');
for i:=1 to n do
begin
   for j:=1 to n do
writeln(f,'');
write(f,'Y:');
end;
for i:=1 to n do
begin
   for j:=1 to n do
write(f,a[i,j]:5);
writeln(f,'');
end;
writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   l[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       l[i]:=j;
      end;
    end;
  end;
begin
      p:=1;
writeln(f,'исходная матрица?);
end;
if p=0 then write(f,?ошибка?);
writeln('Результат записан в файл RESULT.TXT') ;
    readln;
    close(f); 
   end;
 end;
end;
3:begin
  Init;
  MenuToScr;
  end;
end;
until k=3;
end;
 
 
Procedure punkt3;
 procedure Sum;
 type natur=1..2147483647;{в обычном Паскале это предел натуральных чисел}
 var n,p,q,i,a, b, r:natur;
 function NOD_Evklid (a, b : natur) : natur;
 var r : natur;
 begin
  if ((a=0)or(b=0)) then
   begin
    NOD_Evklid := abs(a+b);
    exit;
   end;
  r := a-b*(a div b);
  while r <> 0 do
   begin
    a := b;
    b := r;
    r := a-b*(a div b);
   end;
  NOD_Evklid := b;
 end;
 begin
 restorecrtmode;
 clrscr;
 repeat
 write('Введите количество слагаемых n=');
 readln(n);
 until(n>0)and(n<=16);{при n>16 выходим за верхний предел интервала чисел.}
 p:=1;
 q:=1;
 for i:=2 to n do
  begin
   p:=p*i+q;{ числитель}
   q:=i*q;{ знаменатель}
  end;
 r:=NOD_Evklid(p,q);{ находим НОД}
 p:=p div r;{сокращаем числитель}
 q:=q div r;{знаменатель}
 write('Сумма=',p,'/',q);{выводим в виде дроби}
 readln;
 Init;
 end;
begin
sum;
end;
Procedure punkt4;
const rz=['_',':',';',',',' ','.','?','!'];
var s,s1,s2:string; 
    c:char;
   i,k,n,max,p:byte; 
begin
restorecrtmode;
clrscr;
writeln('Введите текст на русском языке'); 
readln(s); 
n:=length(s); 
write('Введите букву для поиска c='); 
readln(c); 
i:=1; 
max:=0;s2:=''; 
while i<=n do 
if not(s[i] in rz)and ((i=1)or(s[i-1] in rz)) then{ если буква, а перед ней разделитель, или она первая}
 begin 
  k:=i;s1:='';p:=0; 
  while not(s[k] in rz)and(k<=n)do {пока не разделитель и не конец строки}
   begin
    s1:=s1+s[k];{ составляем слово}
    if s[k]=c then p:=p+1;{считаем заданную букву}
    k:=k+1;{идем вперед} 
   end; 
  if p>max then {если больше чем до этого} 
   begin
    max:=p; 
    s2:=s1;{ запомним слово}
   end ; 
 i:=i+length(s1);{ перепрыгиваем}
end 
else i:=i+1; 
if max=0 then write(' Слов с буквой ',c,' нет')
else write('Наибольшее число букв ',c,' в слове ',s2); 
readln;
Init;
end;
 
 
 
 
{ основная программа }
begin
 
menu[1]:=' Massiv ';
menu[2]:=' Matrica ';
menu[3]:=' Summa ';
menu[4]:=' Ctroka ';
menu[5]:=' Quit ';
punkt:=1;
x:=200;
y:=100;
Init;
MenuToScr;
repeat
 ch:=ReadKey;
 if ch=char(0) then
  begin
   ch:=ReadKey;
   case ch of
   chr(80):{ стрелка вниз }
           if punkt<N then
            begin
             ShowNotSelected(punkt);
             punkt:=punkt+1;
             ShowSelectedPunkt;
            end;
   chr(72):{ стрелка вверх }
           if punkt>1 then
            begin
             ShowNotSelected(punkt);
             punkt:=punkt-1;
             ShowSelectedPunkt;
            end;
   end;
  end
 else if ch=chr(13) then
  begin { нажата клавиша <Enter> }
    case punkt of
    1:punkt1;
    2:punkt2;
    3:punkt3;
    4:punkt4;
    N:ch:=chr(27);{ выход }
    end;
    MenuToScr;
  end;
until ch=chr(27);{ 27 - код <Esc> }
end.

Procedure punkt2;
Var
 a:array[1..15,1..15] of integer;// это матрица

n:=0;
        while not eof(f) do
         begin
          read(f,a[2*n+1],a[2*n+2]);//а читаем элементы массива, нужно же матрицу читать
          n:=n+1;
         end;

read(f,n);
for i:=1 to n do
for j:=1 to n do
read(f,a[i,j]);
close(f);

var s:string;
      n,i,j:integer;
      a:array[1..100,1..100] of integer;
begin
файл открыл процедурой
n:=0;
while not eof(f) do
 begin
  readln(f,s);
  n:=n+1;
 end;
close(f);
reset(f);
for i:=1 to n do
for j:=1 to n do
read(f,a[i,j]);
close(f);
.........
end;

program Full;
{$R-}
uses Crt, Graph;
const
     NORM=WHITE; { цвет невыделеного пункта }
     SEL=YELLOW;  { цвет выделенного пункта }
     BackSelectedColor=Cyan;
     BackNotSelectedColor=Black;
 
     N=5;      {количество пунктов в меню}
     HeightSize = 40; {высота, занимаемая каждой строчкой в меню}
     WidthSize = 200; {длина каждой строчки}
     {массив названий пунктов вспомогательных меню}
     glav:array[1..3] of string=('1-Ввод',
                                 '2-Вывод',
                                 '3-Выход');
     vvod:array[1..2] of string=('1-Из файла',
                                 '2-С клавиатуры');
     vyvod:array[1..2] of string=('1-На экран',
                                  '2-В файл');
var
     menu:array[1..N] of string[12];{ названия пунктов меню }
     punkt:integer;  { номер выделенного пункта }
     ch:char;        { введенный символ }
     x,y:integer;    { координаты первой строки меню }
     k,w:byte;{переменные для выбора пунктов в вспомогательных меню}
 
Procedure Init;
var grDriver,grMode:Integer;
begin
grDriver := Detect;
InitGraph(grDriver, grMode,'..\BGI');
end;
procedure ResetFile(var f:text;name:string;var b:boolean);
begin
b:=true;
assign(f,name);
{$I-} reset(f);  {$I+}
if IOResult <> 0 then
  begin
   b:=false;
   writeLn('Файл ',name,' не найден!');
   writeLn(' Нажмите ENTER');
   readln;
   exit;
  end
end;
procedure ShowSelectedPunkt;
begin
     SetFillStyle(1, BackSelectedColor );
     Bar(x,y+(punkt-1)*HeightSize-(HeightSize div 4),
         x + WidthSize, y+(punkt-1)*HeightSize+3*(HeightSize div 4));
     SetColor(SEL);
     MoveTo(x,y+(punkt-1)*HeightSize);
     OutText(menu[punkt]);{ выделим строку меню }
     SetColor(NORM);
end;
 
procedure ShowNotSelected(i : integer);
begin
     SetFillStyle(1, BackNotSelectedColor);
     Bar(x,y+(i-1)*HeightSize-(HeightSize div 4),
         x + WidthSize, y+(i-1)*HeightSize+3*(HeightSize div 4));
     SetColor(NORM);
     MoveTo(x,y+(i-1)*HeightSize);
     OutText(menu[i]);{ выделим строку меню }
end;
 
Procedure MenuToScr;{ вывод меню на экран }
var i:integer;
begin
     ClearDevice;
     SetTextStyle(TriplexFont, HorizDir, 2);
     SetTextJustify(LeftText, TopText);
     SetColor(NORM);
     for i:=1 to N do begin
          ShowNotSelected(i);
     end;
     ShowSelectedPunkt;
end;
 
procedure Menyu(var k: byte;kol:byte);
var kod: char;
    i:byte;
begin
clrscr;
k:=1;
gotoxy(5,1);
repeat
  for i:=1 to kol do
   begin
     if i=k then
      begin
         textbackground(3);
         textcolor(12);
      end
     else
      begin
         textbackground(0);
         textcolor(15)
      end;
     gotoxy(12*(i-1)+1,1);
     write(glav[i]);
   end;
  repeat
  kod:=readkey;
  until kod in [#13, #75, #77];
  case kod of
  #75: begin  {стрелка влево}
       k:=k-1;
       if k=0 then k:=kol;{если левый край, в конец}
       end;
  #77: begin  {стрелка вправо}
       k:=k+1;
       if k>kol then k:=1;{если правый край, в нвчало}
       end;
   end;
 until kod=#13;
end;
 
procedure SubMenyu(var k:byte;kol1,kol2,w:byte);
{создание и вывод на экран выпадающего меню}
var kod: char;
    i:byte;
begin
window(1,1,80,25);
textbackground(0);
clrscr;
for i:=1 to kol2 do{воостановим главное меню}
 begin
  gotoxy(12*(i-1)+1,1);
  write(glav[i]);
 end;
k:=1;
gotoxy(4,2);
k:=1; {выведен первый пункт меню}
repeat
for i:=1 to kol1 do
 begin
  if i=k then {выделенный пункт}
   begin
    textbackground(3);
    textcolor(9);
   end
  else  {остальные}
   begin
    textbackground(0);
    textcolor(15)
   end;
gotoxy(1,i+1);{ставим курсор}
case w of
1:write(vvod[i]);{выводим пункты}
2:write(vyvod[i]);
end;
end;
repeat
kod:=readkey;
until Kod in [#13, #72, #80];
case kod of
#72: begin{стрелка вверх}
     k:=k-1;
     if k=0 then k:=kol1;{если выше верха, вниз}
     end;
#80: begin {стрелка вниз}
     k:=k+1;
     if k>kol1 then k:=1;{если ниже низа, вверх}
     end;
end;
until kod=#13;{нажат Enter, выходим из меню в выбранную процедуру}
end;
 
Procedure punkt1;
const nmax=20;
{логическая функция определения квадрата}
function Square(x1,y1,x2,y2,x3,y3,x4,y4:integer):boolean;
var s1,s2,s3,s4,s5,s6:Longint;
begin
{если квадраты 4х отрезков равны
+ квадраты двух остальных отрезков равны между собой и равны 2*длина любого из первых
это квадрат }
s1:=sqr(x1-x2)+sqr(y1-y2);
s2:=sqr(x1-x3)+sqr(y1-y3);
s3:=sqr(x1-x4)+sqr(y1-y4);
s4:=sqr(x2-x3)+sqr(y2-y3);
s5:=sqr(x2-x4)+sqr(y2-y4);
s6:=sqr(x3-x4)+sqr(y3-y4);
Square:=((s1=s3)and(s1=s4)and(s1=s6)and(s2=s5)and(s2=2*s1))
     or ((s1=s2)and(s1=s5)and(s1=s6)and(s3=s4)and(s3=2*s1))
     or ((s2=s3)and(s2=s4)and(s2=s5)and(s1=s6)and(s1=2*s2));
end;
var a:array[1..2*nmax] of longint;
    n,i,j,m,q,p:byte;
    b,f1:boolean;
    f:text;
begin
restorecrtmode;
clrscr;
textbackground(0);
textcolor(15);
clrscr;
f1:=false;
repeat
textbackground(0);
textcolor(15);
Menyu(k,3);{выводим меню}
clrscr;
case k of{выбираем стрелками действие}
1:begin
   SubMenyu(w,2,3,1);
   case w of
   1:begin
      clrscr;
      textbackground(0);
      textcolor(15);
      Resetfile(f,'massiv.txt',b);
      if not b then
       begin
        writeln('Создайте файл или введите данные с клавиатуры');
        readln;
        Menyu(k,3);
       end
      else
       begin
        n:=0;
        while not eof(f) do
         begin
          read(f,a[2*n+1],a[2*n+2]);
          n:=n+1;
         end;
        close(f);
        f1:=true;
        writeln('n=',n);
        write('Press Enter');
        readln;
       end;
     end;
   2:begin
      textbackground(0);
      textcolor(15);
      clrscr;
      repeat
      write('Введите количество точек от 4 до ',nmax,' n=');
      readln(n);
      until n in [4..nmax];
      writeln('Введите координаты точек, целые числа:');
      for i:=1 to n do
       begin
        writeln('Точка ',i);
        readln(a[2*i-1],a[2*i]);
       end;
      f1:=true;
     end;
   end;
  end;
2:begin
  SubMenyu(w,2,3,2);
  case w of
  1:begin
    textbackground(0);
    textcolor(15);
    clrscr;
    if not f1 then
     begin
      write('Массив еще не создан, вернитесь к пункту 1');
      readln;
      SubMenyu(w,2,3,1);
      exit;
     end;
    writeln('Исходные координаты:');
    write('X:');
    for i:=1 to n do
    write(a[2*i-1]:4);
    writeln;
    write('Y:');
    for i:=1 to n do
    write(a[2*i]:4);
    writeln;
    p:=0;
    for i:=1 to n-3 do
    for j:=i+1 to n-2 do
    for m:=j+1 to n-1 do
    for q:=m+1 to n do
    if Square(a[2*i-1],a[2*i],a[2*j-1],a[2*j],a[2*m-1],a[2*m],a[2*q-1],a[2*q]) then
     begin
      p:=1;
      writeln('Точки номер ',i,' ',j,' ',m,' ',q);
     end;
    if p=0 then write('Нет ни одного квадрата');
    readln;
   end;
  2:begin
    assign(f,'result.txt') ;
    rewrite(f);
    textbackground(0);
    textcolor(15);
    clrscr;
    writeln(f,'Исходные координаты:');
    write(f,'X:');
    for i:=1 to n do
    write(f,a[2*i-1]:4);
    writeln(f,'');
    write(f,'Y:');
    for i:=1 to n do
    write(f,a[2*i]:4);
    writeln(f,'');
    p:=0;
    for i:=1 to n-3 do
    for j:=i+1 to n-2 do
    for m:=j+1 to n-1 do
    for q:=m+1 to n do
    if Square(a[2*i-1],a[2*i],a[2*j-1],a[2*j],a[2*m-1],a[2*m],a[2*q-1],a[2*q]) then
     begin
      p:=1;
      writeln(f,'Tochki # ',i,' ',j,' ',m,' ',q);
     end;
    if p=0 then write(f,'Нет ни одного квадрата');
    writeln('Результат записан в файл RESULT.TXT') ;
    readln;
    close(f); 
   end;
 end;
end;
3:begin
  Init;
  MenuToScr;
  end;
end;
until k=3;
end;
 
Procedure punkt2;
Var
 a:array[1..15,1..15] of integer;
 k:array[1..15] of Byte;
 i,j,n,max,x:integer;
BEGIN
 restorecrtmode;
 clrscr;
 Write('Введите размерность матрицы');
 Readln(n);
 for i:=1 to n do
  for j:=1 to n do
   begin
    write('A[',i,',',j,']= ');
    readln(a[i,j]);
   end;
 clrscr;
 writeln('Исходная матрица:');
 for i:=1 to n do
  begin
   for j:=1 to n do
   write(a[i,j]:5);
   writeln;
  end;
 writeln;
 for i:=1 to n do
  begin
   max:=a[i,1];
   k[i]:=1;
   for j:=1 to n do
    begin
     if a[i,j]>max then
      begin
       max:=a[i,j];
       k[i]:=j;
      end;
    end;
  end;
 
 for i:=1 to n do
  begin
   x:=a[i,i];
   a[i,i]:=a[i,k[i]];
   a[i,k[i]]:=x;
  end;
writeln('Измененная матрица:');
 for i:=1 to n do
  begin
   for j:=1 to n do
    write(a[i,j]:5);
   writeln;
  end;
 readln;
 Init;
end;
 
Procedure punkt3;
 procedure Sum;
 type natur=1..2147483647;{в обычном Паскале это предел натуральных чисел}
 var n,p,q,i,a, b, r:natur;
 function NOD_Evklid (a, b : natur) : natur;
 var r : natur;
 begin
  if ((a=0)or(b=0)) then
   begin
    NOD_Evklid := abs(a+b);
    exit;
   end;
  r := a-b*(a div b);
  while r <> 0 do
   begin
    a := b;
    b := r;
    r := a-b*(a div b);
   end;
  NOD_Evklid := b;
 end;
 begin
 restorecrtmode;
 clrscr;
 repeat
 write('Введите количество слагаемых n=');
 readln(n);
 until(n>0)and(n<=16);{при n>16 выходим за верхний предел интервала чисел.}
 p:=1;
 q:=1;
 for i:=2 to n do
  begin
   p:=p*i+q;{ числитель}
   q:=i*q;{ знаменатель}
  end;
 r:=NOD_Evklid(p,q);{ находим НОД}
 p:=p div r;{сокращаем числитель}
 q:=q div r;{знаменатель}
 write('Сумма=',p,'/',q);{выводим в виде дроби}
 readln;
 Init;
 end;
begin
sum;
end;
Procedure punkt4;
{uses crt;}
const rz=['_',':',';',',',' ','.','?','!'];
      rb=['А'..'п','р'..'ё'];
function Count(s:string;c:char):byte;{подсчет буквы в слове}
var i,k:byte;
begin
k:=0;
for i:=1 to length(s) do
if s[i]=c then k:=k+1;
Count:=k;
end;
var s,s1:string;
    a:array[1..100] of string;
    c:char;
    i,k,n,max:byte;
    begin
clrscr;
writeln('Введите текст на русском языке, окончание Enter');
s:='';
n:=0;
repeat
c:=readkey;
if  (c in rb)or(c in rz) then
 begin
  n:=n+1;
  write(c);
  s:=s+c;
 end;
if c=#8 then {если не та буква, жмем BackSpase}
 begin
  gotoXY(whereX-1,whereY);{курсор на 1 назад}
  dec(s[0]);{уменьшаем длину строки, вводим что нужно}
 end;
if c=#13 then writeln;
until c=#13;
write('Введите букву для поиска c=');
readln(c);
i:=1;
max:=0;
n:=0;
while i<=length(s) do
if not(s[i] in rz)and ((i=1)or(s[i-1] in rz)) then{если буква, а перед ней разделитель, или она первая}
 begin
  k:=i;s1:='';
  while not(s[k] in rz)and(k<=length(s))do {пока не разделитель и не конец строки}
   begin
    n:=n+1;
    s1:=s1+s[k];{составляем слово}
    k:=k+1;{идем вперед}
   end;
  if Count(s1,c)>max then max:=Count(s1,c);{если больше чем до этого}
  a[n]:=s1;{запишем слово в массив}
  i:=i+length(s1);{перепрыгиваем}
 end
else i:=i+1;
if max=0 then write('Слов с буквой ',c,' нет')
else
 begin
  writeln('Наибольшее число букв ',c,' в словах=',max);
  writeln('Это слова:');
  for i:=1 to n do
  if Count(a[i],c)=max then
  writeln(a[i]);
 end;
readln
end;
 
 
 
 
{ основная программа }
begin
 
menu[1]:=' Massiv ';
menu[2]:=' Matrica ';
menu[3]:=' Summa ';
menu[4]:=' Ctroka ';
menu[5]:=' Quit ';
punkt:=1;
x:=200;
y:=100;
Init;
MenuToScr;
repeat
 ch:=ReadKey;
 if ch=char(0) then
  begin
   ch:=ReadKey;
   case ch of
   chr(80):{ стрелка вниз }
           if punkt<N then
            begin
             ShowNotSelected(punkt);
             punkt:=punkt+1;
             ShowSelectedPunkt;
            end;
   chr(72):{ стрелка вверх }
           if punkt>1 then
            begin
             ShowNotSelected(punkt);
             punkt:=punkt-1;
             ShowSelectedPunkt;
            end;
   end;
  end
 else if ch=chr(13) then
  begin { нажата клавиша <Enter> }
    case punkt of
    1:punkt1;
    2:punkt2;
    3:punkt3;
    4:punkt4;
    N:ch:=chr(27);{ выход }
    end;
    MenuToScr;
  end;
until ch=chr(27);{ 27 - код <Esc> }
end.