uses crt,dos,objects;

type ps=^string;

var regs:Registers;l:ptrrec;

procedure clrscr;
 begin regs.ax:=3;
       intr($10,regs);end;

procedure readln(p:ps);
   begin l:=ptrrec(p);
   with regs do begin ah:=$3f;
         bx:=0;cx:=80;
         ds:=l.seg;dx:=l.ofs+1;
         msdos(regs);
         p^[0]:=chr(ax-2) end; end;

procedure  write(p:ps);
   begin l:=ptrrec(p);
   with regs do begin ah:=$40;
     bx:=1;cx:=length(p^);
      ds:=l.seg;dx:=l.ofs+1;
         msdos(regs);end;end;

procedure writeln(p:ps);
    var e:ps;
    begin new(e);e^:=#10#13;
    write(p);write(e) end;

function readkey:char;
         begin with regs do begin
         ah:=8;msdos(regs);
         readkey:=chr(al) end end;
procedure putc(c:char);
         begin with regs do begin
         ah:=2;dl:=ord©;
         msdos(regs);end end;

var p,s,e,st,s2:ps;
i:integer;
b:char;
k:integer;
Begin
      clrscr;new(e);e^:=#10#13;
      new(p);new(s);p^:='Введите слово, по нажатию ввода конец. ';
      new(st);new(s2);
      b:='0';
      s2^:='';
      write(p);
      repeat st^:=st^+b;
      b:=readkey;
      if b=#13 then break;
      putc('*');
      until false;
      clrscr;
      for i:=2 to length(st^)+1 do s2^:=s2^+('*');
      p^:='Введите буквы для выхода нажмите ввод ';
      write(p);
      write(s2);
      repeat b:=readkey;
      if b=#13 then break;
      if pos(b,st^)>0 then begin
      clrscr;
      s2^[pos(b,st^)]:=b;
      write (p);
      write (s2);
      end;
      until false;
      end.

Program InsSort;
Const n = 60;
      m = 6;
Var A : array[1..n] of Integer;
    inputArray : array[1..m,1..m] of integer;
k : Integer; l, r, i, j : Integer; b : Integer; p,v:integer;
max1,max2:integer;
Begin
{Блок чтения массива A}
 
writeln('исходная матрица');
randomize;
for p:=1 to m do //random
begin
  for v:=1 to m do
  begin
  inputArray[p,v]:=random(50); 
  write(inputArray[p,v]:3)
  end;
writeln;
end;
 
k:=1;
for p:=1 to m do //a = iA
begin
  for v:=1 to m do
  begin
  A[k]:=inputArray[p,v];
  inc (k);
  end;
end;
 
max1 := 1;
for k:=2 to n do
  if a[k] > a[max1] then
  max1 := k;
 
if max1=1 then 
  max2 := 2
  else 
  max2 := 1;
 
for k:=2 to N do
  if k <> max1 then // чтобы пропустить max1
    if a[k] > a[max2] then
      max2 := k;
writeln(max1,' ', a[max1]);
writeln(max2,' ', a[max2]);
 
{непосредсвенно алгоритм сортировки}
For k :=1 to n-1 do
begin
  b := A[k+1];
  If b > A[k] then
   begin
   l := 1; r := k; {Бинарный поиск}
   Repeat
   j := (l + r) div 2;
   If b > A[j] then
   r := j else
   l := j + 1;
   until (l = j);{ Сдвиг “хвоста” массива на 1 позицию вправо}
   For i := k downto j do A[i+1] := A[i];
A[j] := b ; { Пересылка элемента на свое место}
end
 
end; {Блок вывода массива A}
 
writeln('конечная матрица');
k:=1;
for p:=1 to m do //a = iA
begin
  for v:=1 to m do
  begin
  inputArray[p,v]:=A[k];
  write(inputArray[p,v]:3);
  inc (k);
  end;
  writeln;
end;
End.

Var
  ddd : text;
  
Function  file_exist(name:string) : boolean;
  Begin
    file_exist:=false;
    Assign(ddd, name);
    {$I-}
    Reset (ddd);
    {$I+}
    if IOResult=0 then begin
      file_exist:=true;
    end;
  End;

BEGIN
    if file_exist ('d10.txt') then begin
      if file_exist ('d10.bak') then Erase(ddd);
      Assign(ddd, 'd10.txt');
      Rename(ddd, 'd10.bak');
    end;
END.

Procedure Readlist (var p:dlist);
var
f: file of integer;
q: dlist;
pr,info: integer;
begin
Assign(f,'spisok.dat');
Reset(f);
while not (eof(f)) do
begin
read(f,info);
CreateNewNode(p,info);
end;
close(f);
end;

Procedure Savelist (p:dlist);
var
f: file of integer;
q: dlist;
begin
Assign(f,'spisok.dat');
rewrite(f);
write (f,p^.info);
q:=p^.next;
while q<>p do
begin
 write(f,p^.info);
 q:=q^.next;
 end;
close(f);
end;