Const
 xz : array [1..12] of byte = (31,28,31,30,31,30,31,31,30,31,30,31);
Var
 S, st : string;
 i, dd, mm : byte;
 code, gg : integer;
Begin
 st:=''; i:=1;
 Write('Введите текущую дату (в формате дд.мм.гггг) : '); ReadLn(S);
 While S[i]<>'.' do
  Begin
   st:=st+s[i];
   inc(i);
  End;
 inc(i);
 val(st, dd, code);
 st:='';
 While S[i]<>'.' do
  Begin
   st:=st+s[i];
   inc(i);
  End;
 inc(i);
 val(st, mm, code);
 st:=s[i]+s[i+1]+s[i+2]+s[i+3];
 val(st, gg, code);
 {сегодня}
 If (dd=1) and (mm=1) then WriteLn('С Новым Годом!') else
  If dd=xz[mm] then WriteLn('Сегодня последний день месяца!') else
   If dd=1 then WriteLn('Сегодня первый день месяца!');
 {завтра}
 if dd=xz[mm] then
   Begin
    dd:=1;
    if mm=12 then
      Begin
       mm:=1;
       inc(gg);
       Write('С наступающим Новым Годом!.. ');
      end
     else inc(mm);
   End
  else inc(dd);
{=}
 WriteLn('Завтра ',dd,'.',mm,'.',gg);
 WriteLn;
End.

program laba3;
uses crt;
const n=10;
var
  A: array [1..n] of integer;
  i, j, ed, des: integer;
  flag, flag2: boolean;
begin
  clrscr;
  randomize;
  writeln('Исходный массив:');
  write('[');
  for i:=1 to 10 do
  begin
    a[i]:=random(70)-40;
    write(' ',a[i]);
  end;
  writeln(' ]');

  i:=0;
  flag:=true;
  while flag do
  begin
    inc(i);
    ed:=abs(a[i])-abs(a[i] div 10)*10;
    des:=abs(a[i] div 10);
    if des=0 then
    begin
      for j:=i to n-1 do
        a[j]:=a[j+1];
      a[n]:=0;
      flag2:=false;
      for j:=i to n do
        if a[i]=0 then flag2:=true;
      if not flag2 then i:=i-1;
    end
    else if ed=des then
    begin
      for j:=i to n-1 do
        a[j]:=a[j+1];
      a[n]:=0;
      flag2:=false;
      for j:=i to n do
        if a[i]=0 then flag2:=true;
      if not flag2 then i:=i-1;
    end;

    if i>=n then flag:=false;
  end;

  writeln('Обработанный массив:');
  write('[');
  for i:=1 to 10 do
    write(' ',a[i]);
  writeln(' ]');
end.

program laba4;
uses crt;
const n=10;
var
  A: array [1..n] of integer;
  i, j, ed, des, k, l, negative: integer;
begin
  clrscr;
  randomize;
  l:=1;
  write('Введите число k ');
  readln(k);
  writeln('Исходный массив:');
  write('[');
  for i:=1 to 10 do
  begin
    a[i]:=random(70)-40;
    write(' ',a[i]);
  end;
  writeln(' ]');

  for i:=1 to n do
  begin
    ed:=abs(a[i])-abs(a[i] div 10)*10;
    des:=abs(a[i] div 10);
    if a[i]>=0 then negative:=1
    else negative:=-1;
    if (l=ed) or (l=des) then
      if des=0 then
        a[i]:=negative*k*10+a[i]
      else a[i]:=negative*k*100+a[i];
  end;

  writeln('Обработанный массив:');
  write('[');
  for i:=1 to 10 do
    write(' ',a[i]);
  writeln(' ]');
end.

program laba6;
uses crt;
type
  R2DArray = array [1..10,1..10] of real;
var
  i, j, n, m, r : integer;
  A, B, C: R2DArray;

procedure MultiplyMatrixes(n : Integer;
     m : Integer;
     k : Integer;
     const A : R2DArray;
     const B : R2DArray;
     var C : R2DArray);
var
    I : Integer;
    J : Integer;
    L : Integer;
begin
    i:=1;
    while i<=n do
    begin
        j:=1;
        while j<=k do
        begin
            c[i,j] := 0;
            l:=1;
            while l<=m do
            begin
                c[i,j] := c[i,j]+a[i,l]*b[l,j];
                Inc(l);
            end;
            Inc(j);
        end;
        Inc(i);
    end;
end;

begin
  clrscr;
  n:=2;
  m:=3;
  r:=4;
  randomize;
  for i:=1 to 2 do
    for j:=1 to 3 do
      A[i,j]:=random(500)/10;
  for i:=1 to 3 do
    for j:=1 to 4 do
      B[i,j]:=random(500)/10;

  MultiplyMatrixes(n,m,r,A,B,C);

  writeln('A= ');
  for i:=1 to 2 do
  begin
    for j:= 1 to 3 do
      write(A[i,j]:4:2,'  ');
    writeln;
  end;
  writeln;
  writeln('B= ');
  for i:=1 to 3 do
  begin
    for j:= 1 to 4 do
      write(B[i,j]:4:2,'  ');
    writeln;
  end;
  writeln;
  writeln('Результат умножения матриц  C= ');
  for i:=1 to 2 do
  begin
    for j:= 1 to 4 do
      write(C[i,j]:4:2,'  ');
    writeln;
  end;

end.

program laba7;
uses crt;
type
  TAbiturient = record
    Family: string;
    Mark: byte;
  end;
var
  Abiturients: array [1..50] of TAbiturient;
  i, n: integer;
  flag: boolean;
  YN: char;
begin
  clrscr;
  flag:= true;
  i:=0;
  while flag do
  begin
    inc(i);
    write('Введите фамилию ',i,'-го  абитуриента : ');
    readln(Abiturients[i].family);
    write('оценка за первый экзамен: ');
    readln(Abiturients[i].mark);
    write('Продолжить ввод? (Y/N) ');
    YN:=readkey;
    if not((YN='y') or (YN='Y')) then
      flag:=false
    else writeln;

  end;
  n:=i;
  writeln;
  writeln;
  writeln('Абитуриенты, допущенные ко второму экзамену:');
  for i:=1 to n do
  begin
    if Abiturients[i].mark>2 then
      writeln(Abiturients[i].family);
  end;

  readln;

end.

program lab8;
uses crt;
type
  TSotrudniki = record
    FIO : string;
    Phone : LongInt;
  end;
var
  Sotrudniki: array [1..50] of TSotrudniki;
  f: Text;
  Family: string;
  sumb, continuesearch: char;
  i, n: integer;
begin
  clrscr;
  assign(f,'L8BASE.TXT');
  reset(f);
  i:=0;
  while not EOF(f) do
  begin
    inc(i);
    readln(f,Sotrudniki[i].FIO);
    readln(f,Sotrudniki[i].phone);
  end;
 continuesearch:='д';
 while (continuesearch='д') or (continuesearch='Д') do
 begin
  write('Фамилия для поиска : ');
  readln(Family);
  n:=i;
  for i:=1 to n do
    if family=Sotrudniki[i].FIO then
    begin
      writeln('Телефон сотрудника "',Sotrudniki[i].FIO,'"');
      writeln(Sotrudniki[i].phone);
    end;
  write('Продолжить поиск? (Д/Н)?');
  continuesearch:=readkey;
  writeln;
 end;
 readln;
end.

Фамилия[пробел]ИО[enter]
[телефон]
....

Иванов АВ
1224561
Петров ПЮ
2336589
Сидоров ВЕ
5425326
Кузнецов СИ
4812265
Лебедев ПА
5542396
Голубев ВС
3396578
Виноградов ПО
4556923
Смирнов СБ
2354897

program var17;
uses crt;
var
  f: text;
  textstr: string;
  i, pos, j, numpredl, numslova,
    kolvopredl, k, wordrep: integer;
  sumb: char;
  sortedtext: array [1..20, 1..20] of string[40];
  kolvoslov: array [1..20] of integer;
  flagvstrechi: boolean;
begin
  clrscr;
  {Файл, в котором находится текст}
  assign(f,'text.txt');
  reset(f);
  textstr:='';
  {Чтение текста в память (строку)}
  while not EOF(f) do
  begin
    read(f,sumb);
    textstr:=textstr+sumb;
  end;
  {Позиция начала слова}
  pos:=1;
  {Количество предложений}
  numpredl:=1;
  {Количество слов}
  numslova:=1;
  {Разбор строки в массив упорядоченного текста sortedtext}
  for i:=1 to length(textstr) do
  begin
    if (textstr[i]=' ') or (textstr[i]=',') or (textstr[i]='.') then
    begin
     for j:= pos to i-1 do
       sortedtext[numpredl,numslova]:=sortedtext[numpredl,numslova]+textstr[j];
     pos:=i+1;
     inc(numslova);
    end;
    if (textstr[i]='.') then
    begin
      kolvoslov[numpredl]:=numslova-1;
      inc(numpredl);
      numslova:=1;
    end;
  end;
  numpredl:=numpredl-1;
  {Флаг встречаемости слова}
  flagvstrechi:=false;
  for i:=1 to kolvoslov[1] do
  begin
    {Количество встреч слова в предложениях текста
    (должно быть равно количеству предложений)}
    wordrep:=1;
    for j:=2 to numpredl do
      for k:=1 to kolvoslov[j] do
         if sortedtext[1,i]=sortedtext[j,k] then
           inc(wordrep);
    if wordrep=numpredl then
    begin
      writeln('В каждом предложении данного текста встречается слово "',sortedtext[1,i],'"');
      flagvstrechi:=true;
    end;
  end;
  {Если в тексте не встретилось слов, повторяющихся в каждом предложении}
  if not flagvstrechi then
    writeln('В данном тексте нет слов, встречающихся в каждом предложении.');
  readln;
end.

program laba7;
uses crt;
type
  TAbiturient = record
    Family: string;
    Mark: byte;
  end;
var
  Abiturients: array [1..50] of TAbiturient;
  i, n: integer;
  YN: char;
  KolvoAb: integer;
begin
  clrscr;
  write('Количество абитуриентов: ');
  readln(KolvoAb);
  for i:=1 to KolvoAb do
  begin
    write('Введите фамилию ',i,'-го абитуриента : ');
    readln(Abiturients[i].family);
    write('Введите оценку, которую ',i,'-й абитуриент получил на предыдущем экзамене: ');
    readln(Abiturients[i].mark);
  end;
  n:=i;
  writeln;
  writeln;
  writeln('Абитуриенты, допущенные к экзамену:');
  for i:=1 to n do
  begin
    if Abiturients[i].mark>2 then
      writeln(Abiturients[i].family);
  end;

  readln;

end.