nyuuzyou/soloby huggingface dataset:
Вопрос: Дана действительная матрица размером n х m, все элементы которой различны. В каждой строке выбирается элемент с наименьшим значением, затем среди этих чисел выбирается наибольшее. Указать индексы элемента с найденным значением.
Категория: школьный раздел
Ответы:
uses crt;
const n=5; m=4;
var a:array[1..n,1..m]of integer;
i,j,k,b:integer;
f:boolean;
 
function max(k:integer):integer;
var j,s,m:integer;
begin
 m:=1;
 for j:=1 to m do if a[k,j]>a[k,m] then m:=i;
 max:=m;
end;
 
begin
 clrscr;
 randomize;
 writeln('Исходная матрица');
 for i:=1 to n do
 begin
  for j:=1 to m do
  begin
   a[i,j]:=-20+random(60);
   write(a[i,j]:4);
  end;
  writeln;
 end;
 
 for i:=1 to n do writeln('Максимальный элемент в ',i,'-й строке A[',i,' ',max(i),' = ',a[i,max(i)]);
 readln;
end.

var   n:Integer; mn:Double; mj:Integer;
                 mx:Double;
                 mxi,          
                 mxj:Integer; 
                 i,j:Integer;
                 T:array of array of Double; 
 n:=Length(T);
   mx:=T[0,0];
   mxi:=0;
   mxj:=0;
   for i:=0 to N-1 do 
   begin //Должен быть
       mn:=T[i,0];
       mj:=0;
       begin
         for j:=0 to n-1 do
               if mn>T[i,j] then  
               begin
                 mn:=T[i,j];
                 mj:=j;
               end;
         if mx<mn then 
         begin
           mx:=mn;
           mxi:=i;
           mxj:=mj;
         end;
       end; 
   end;

de: #pascal
const n=8;{количество строк}
       m=10;{количество столбцов}
Var a: array [1..n,1..m] of real;{данная матрица}
    i,j,k,l,v:integer;
    minj,maxi:real;
BEGIN
{заполнение матрицы произвольными положительными действительными числами от 0 до 99}
randomize;
For i:=1 to n do
 For j:=1 to m do
   a[i,j]:=random(100);
maxi:=-1;{так как все числа положительные (мы сами так заполнили)}
For i:=1 to n do begin
 minj:=a[i,1];{предположим что первый элемент каждой i-ой строки минимальный}
 For j:=2 to m do
  {сравниваем все остальные элементы строки с уже найденным минимальным}
  If a[i,j]<minj then begin{если он меньше уже найденного то}
                     minj:=a[i,j];{он минимальный}
                     v:=j;{сохраняем его номер столбца}
                    end;
{проверяем только что полученный элемент на максимум}
 If minj>maxi then begin{если верно то сохраняем его и его индексы}
                   k:=i;
                   l:=v;
                   maxi:=minj;
                 end;
end;
{Выводим искомый элемент и его индексы хоть в едите хоть в лабеле}
 
END.
Вопрос: Дана действительная квадратная матрица порядка N (N — нечетное), все элементы которой различны. Найти наибольший элемент среди стоящих на главной и побочной диагоналях и поменять его местами с элементом, стоящим на пересечении этих диагоналей.
Категория: школьный раздел
Ответы:
program n685;
uses crt;
var jmx,imx,i,j,m,n,x:integer;
    a: array[1..19,1..19] of integer;
begin
clrscr;
randomize;
repeat
write('Введите нечетное n до 19 n=');
readln(n);
until (n in [1..19])and odd(n);
writeln('Исходная матрица:');
for i:=1 to n do
 begin
  for j:=1 to n do
   begin
    a[i,j]:=random(50);
    write(a[i,j]:4);
   end;
  writeln;
 end;
imx:=1;
jmx:=1;
for i:=1 to n do
for j:=1 to n do
if((i=j)or(j=n-i+1))and(a[i,j]>a[imx,jmx]) then
 begin
  imx:=i;
  jmx:=j;
 end;
writeln('Максимальный элемент a[',imx,',',jmx,']=',a[imx,jmx]);
x:=a[imx,jmx];
a[imx,jmx]:=a[n div 2+1,n div 2+1];
a[n div 2+1,n div 2+1]:=x;
writeln('Обмен элементов:');
for i:=1 to n do
 begin
  for j:=1 to n do
  write(a[i,j]:4);
  writeln;
 end;
readln
end.
Вопрос: Для заданной квадратной матрицы сформировать одномерный массив из ее диагональных элементов. Найти след матрицы, просуммировав элементы одномерного массива. Преобразовать исходную матрицу по правилу: четные строки разделить на полученное значение, нечетные оставить без изменения.
Категория: школьный раздел
Ответы:
uses crt;
const nmax=15;
var a:array[1..nmax,1..nmax] of real;
    b:array[1..nmax] of real;
    n,i,j:integer;
    s:real;
begin
clrscr;
randomize;
repeat
write('Размер матрицы до ',nmax,' n=');
readln(n);
until n in [1..nmax];
writeln('Исходная матрица:');
s:=0;
for i:=1 to n do
 begin
  for j:=1 to n do
   begin
    a[i,j]:=10*random;
    write(a[i,j]:5:2);
    if j=i  then
     begin
      b[i]:=a[i,j];
      s:=s+b[i];
     end;
   end;
  writeln;
 end;
writeln;
writeln('Массив элементов главной диагонали:');
for i:=1 to n do
write(b[i]:5:2);
writeln;
writeln('След=',s:0:2);
writeln('Преобразованная матрица:');
for i:=1 to n do
 begin
  for j:=1 to n do
   begin
    if i mod 2=0 then a[i,j]:=a[i,j]/s;
    write(a[i,j]:5:2);
   end;
  writeln;
 end;
readln
end.
Вопрос: Дана прямоугольная матрица. Найти строку с наибольшей и строку с наименьшей суммой элементов. Вывести на печать найденные строки и суммы их элементов.
Категория: школьный раздел
Ответы:
Program matrix;
USES Crt;
Var a: array[1..20, 1..20] of integer;
    n,S,i,j,k,mins, maxs, mini, maxi, t : integer;
Begin
ClrScr;
Write('Vvedite kolichestvo strok n= ');
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('Matrica a');
for i:=1 to n do
 begin
  for j:=1 to n do
  Write(a[i,j],'  ','  ');
  Writeln;
 end;
mins:=0;
for j:=1 to n do
mins:= mins+a[1,j];{summa v str 1, poka=min}
maxs:= mins;
mini:= 1;
maxi:= 1;
for i:=1 to n do
 begin
  t:=0;
  for j:=1 to n do
   t:= t+ a[i,j];
  if (t>maxs) then
  begin
   maxs:= t;
   maxi:= i;
  end;
 if (t<mins) then
  begin
   mins:= t;
   mini:= i;
  end;
 end;
writeln ('Max summ = ', maxs, ' ctroka ', maxi);
for j:=1 to n do
write(a[maxi,j],' ');
writeln;
writeln;
writeln ('Min summ = ', mins, ' ctroka ', mini);
for j:=1 to n do
write(a[mini,j],' ');
Readln;
end.
Вопрос: 6. Содержание ценовой политики заключается в том
 чтобы определить фазу жизненного цикла продукции
 чтобы обеспечить выживаемость в условиях конкуренции
 (*ответ к тесту*) чтобы овладеть определенной долей рынка и обеспечить намеченный объем продаж
7. Под ценной бумагой понимается
 активные акции и облигации
 (*ответ к тесту*) продаваемый и покупаемый финансовый документ, дающий право владельцу на получение в будущем 
денежной прибыли
 сертификат акции
8. Брокерской деятельностью признается
 (*ответ к тесту*) совершение гражданско-правовых сделок с ценными бумагами в качестве поверенного или комиссионера, 
действующего на основании
 договора — поручения или комиссии, а также доверенности на совершение таких сделок
 совершение сделок от своего имени и за свой счет путем объявления цен покупки или продажи
9. Объектами инвестиционной деятельности являются
 инвесторы, закзчики, исполнители работ
 (*ответ к тесту*) вновь создаваемые и модернизируемые фонды и оборотные средства во всех отраслях и сферах 
народного хозяйства РФ
 денежные средства, банковские вклады
10. Основные меры регулирования инвестиционной деятельности направлены на
 (*ответ к тесту*) снижение доли бюджетных ассигнований и увеличение доли собственных средств предприятий, частных 
инвестиций и заемных средств
 снижение доли собственных средств предприятий и увеличение частных инвестиций
11. Состав бизнес-плана инвестиционного проекта и степень его детализации зависят от
 сферы , к которой он относится
 ни от каких вышеперечисленных
 размера будущего проекта
 характера создаваемого предприятия
 (*ответ к тесту*) от всех вышеперечисленных
Категория: экономические
Ответы:
Правильные вопросы выделены по тесту
тест уже прошел свою проверку
надеюсь на плюс 1 голос к ответу
Вопрос: В данной действительной квадратной матрице порядка n найти наибольший по модулю элемент. Получить квадратную матрицу порядка n — 1 путем отбрасывания из исходной матрицы строки и столбца, на пересечении которых расположен элемент с найденным значением.
Категория: школьный раздел
Ответы:
program prog;
var i, j, n, m_i, m_j: byte;
    A: array[1..100,1..100] of Real;
    maxmod: Real;
begin
randomize;
writeln('Vvedite N:');
readln(n);
{заполнение случайными числами, можно вводить вручную}
for i:=1 to n do
    for j:=1 to n do
        A[i,j]:=-100+random(200);
 
{поиск максимального по модулю элемента}
maxmod:=abs(A[1,1]);
m_i:=1;
m_j:=1;
for i:=1 to n do
 for j:=1 to n do
  if abs(A[i,j])>maxmod then
  begin
  maxmod:=abs(A[i,j]);
  m_i:=i; m_j:=j;
  end;
 
{Печать матрицы и ответа}
writeln('Исходная матрица:');
for i:=1 to n do
begin
 for j:=1 to n do write(A[i,j]:6:1);
 writeln;
end;
writeln('Максимальный по модулю элемент A[',m_i,';',m_j,'] = ', A[m_i, m_j]:6:1);
{вывод на печать уменьшенной матрицы}
for i:=1 to n do
 if (i<>m_i) then
 begin
 for j:=1 to n do
   if (j<>m_j) then write(A[i,j]:6:1);
 writeln;
 end;
readln;
end
Вопрос: Расположить столбцы матрицы D[M, N] в порядке возрастания элементов k-й строки (1 < k < М).
Категория: школьный раздел
Ответы:
uses crt;
const nmax=20;
var a:array[1..nmax,1..nmax] of real;
    m,n,i,j,k,p:byte;
    d:real;
begin
clrscr;
repeat
write('Количество строк до ',nmax,' m=');
readln(m);
until m in [1..nmax];
repeat
write('Количество столбцов до ',nmax,' n=');
readln(n);
until n in [1..nmax];
writeln('Исходная матрица:');
for i:=1 to m do
 begin
   for j:=1 to n do
    begin
     a[i,j]:=10*random;
     write(a[i,j]:5:2);
    end;
   writeln;
 end;
writeln;
repeat
write('Введите номер строки от 1 до ',m,' k=');
readln(k);
until k in [1..m];
for i:=1 to n-1 do
for j:=i+1 to n do
if a[k,i]>a[k,j] then
for p:=1 to m do
 begin
  d:=a[p,i];
  a[p,i]:=a[p,j];
  a[p,j]:=d;
 end;
writeln;
writeln('Столбцы упорядочены по возрастанию элементов в строке ',k);
for i:=1 to m do
 begin
  for j:=1 to n do
  write(a[i,j]:5:2);
  writeln;
 end;
readln
end.
Вопрос: Среди столбцов заданной целочисленной матрицы, содержащих только такие элементы, которые по модулю не больше 10, найти столбец с минимальным произведением элементов
Категория: школьный раздел
Ответы:
Program Matr;
Uses crt;
Var A:array[1..20,1..20] of integer; g:array[1..20] of integer;
i,j,min,k,m,n,nom:integer;
Begin
 
ClrScr; Randomize; min:=9999;
Write('n='); Readln(n);
Write('m='); Readln(m);
For i:=1 to n do
 For j:=1 to m do
 Begin
   A[i,j]:=random(21)-10;
   Write(A[i,j]:5); k:=k+1;
    If k mod m=0 then Writeln;
   g[j]:=1;
 End;
j:=1;
Repeat
  For i:=1 to n do
  Begin
    g[j]:=g[j]*A[i,j];
  End;
 j:=j+1;
Until j=m;
For j:=1 to n do
 Begin
  If g[j]<min then
  Begin
    min:=g[j];
    nom:=j;
   End;
End;
Write('min stolb:',nom); Readln;
End.
Вопрос: Для заданной квадратной матрицы найти такие k, что k-я строка матрицы совпадает с k-м столбцом.
Категория: школьный раздел
Ответы:
uses crt;
const n=5;
var a: array[1..n,1..n] of integer; 
      i,j: byte; u: boolean;
begin
 u:=false;
 randomize;
 clrscr;
 writeln('исходный массив: ');
 for i:=1 to n do
  begin
   for j:=1 to n do
    begin
     a[i,j]:=random(19)-9;
     write(a[i,j]:3);
    end; 
   writeln;
  end; 
 writeln;
 for i:=1 to n do
  for j:=1 to n do
   if (i=j) and (j=a[i,j]) then u:=true;
 if u=true then
  begin
   writeln('строка совпадает со столбцом и со значением элемента в следующих случаях: ');
   for i:=1 to n do
    for j:=1 to n do
     if (i=j) and (j=a[i,j]) then write(a[i,j]:3);
  end
 else writeln('элементов, удовлетворяющих условию в матрице нет');
end.
Вопрос: Найти максимальный среди всех элементов тех строк заданной матрицы, которые упорядочены (либо по возрастанию, либо по убыванию).
Категория: школьный раздел
Ответы:
uses crt;
const nmax=20;
var a:array[1..nmax,1..nmax] of integer;
    m,n,i,j,mx:integer;
    f,b:boolean;
procedure Max;
var i,j:integer;
begin
b:=false;
i:=1;
mx:=-maxint-1;
for i:=1 to m do
 begin
   j:=2;
   f:=true;
   while(j<n)and f do
   if(a[i,j]<=a[i,j-1])and(a[i,j]<=a[i,j+1]){если не нужна строгая упорядоченность, знак = везде убрать}
   or (a[i,j]>=a[i,j-1])and(a[i,j]>=a[i,j+1]) then f:=false
   else j:=j+1;
   if f then
    begin
     b:=true;
     for j:=1 to n do
     if a[i,j]>mx then mx:=a[i,j];
    end;
 end;
end;
 
begin
clrscr;
repeat
write('Количество строк до ',nmax,' m=');
readln(m);
until m in [1..nmax];
repeat
write('Количество столбцов от 3 до ',nmax,' n=');
readln(n);
until n in [3..nmax];
clrscr;
writeln('Введите элементы матрицы, целые числа, в том числе упорядоченные строки:');
for i:=1 to m do
for j:=1 to n do
 begin
  gotoXY(j*4,3+i);
  readln(a[i,j]);
 end;
writeln;
Max;
if not b then write('В матрице нет строго упорядоченных строк')
else write('Максимальный элемент в упорядоченных строках=',mx);
readln
end.
Вопрос: Составить программу, которая заполняет квадратную матрицу порядка п натуральными числами 1, 2, 3, ..., n2, записывая их в нее «по спирали». 
Например, для п = 5 получаем следующую матрицу: 
1    2    3    4    5 
16    17    18    19    6 
15    24    25    20    7 
14    23    22    21    8 
14    12    11    10    9
Категория: школьный раздел
Ответы:
const
  nmax=20;
var
  a: array[1..nmax,1..nmax] of byte;
  n,i,j,c,k: byte;
begin
  repeat
    write('Введите размер матрицы n: ');
    readln(n);
  until n<=20;
 
  i:=1; j:=1; c:=0; k:=1;
  repeat
    //вправо
    while (k<=n*n)and(j<=n-c) do
    begin
      a[i,j]:=k;
      inc(j);
      inc(k);
    end;
    //вниз
    inc(i); dec(j);
    while (k<=n*n)and(i<=n-c) do
    begin
      a[i,j]:=k;
      inc(i);
      inc(k);
    end;
    //влево
    dec(j); dec(i);
    while (k<=n*n)and(j>=1+c) do
    begin
      a[i,j]:=k;
      dec(j);
      inc(k);
    end;
    //вверх
    inc(c); inc(j); dec(i);
    while (k<=n*n)and(i>=1+c) do
    begin
      a[i,j]:=k;
      dec(i);
      inc(k);
    end;
    inc(j); inc(i);
  until k>n*n;
 
  writeln('Матрица по спирали:');
  for i:=1 to n do
  begin
    for j:=1 to n do
      write(a[i,j]:4);
    writeln;
  end;
end.
Вопрос: Среди тех строк целочисленной матрицы, которые содержат только нечетные элементы, найти строку с максимальной суммой модулей элементов. (программа Паскаль)
Категория: школьный раздел
Ответы:
const
  n = 5;
 
type
  matr = array[1..n, 1..n] of integer;
 
procedure zapolnenie(var mas: matr);
var
  i, j: integer;
begin
  for i := 1 to n do
    for j := 1 to n do
      mas[i, j] := random(20) - 20;
end;
 
procedure vivod(const mas: matr);
var
  i, j: integer;
begin
  for i := 1 to n do
  begin
    for j := 1 to n do
      Write(mas[i, j]:5);
    Writeln;
  end;
end;
 
function maxstr(const mas: matr; var str: integer): integer;
var
  i, j, max, sum: integer;
begin
  for i := 1 to n do
  begin
    sum := 0;
    for j := 1 to n do
      sum := sum + abs(mas[i, j]);
    if max < sum then
    begin
      max := sum;
      str := i;
    end;
  end;
  maxstr := max;
end;
 
var
  mas: matr;
  str: integer;
 
begin
  zapolnenie(mas);
  vivod(mas);
  Writeln;
  Writeln('Сумма: ', maxstr(mas, str), ' Строка: ', str);
end.
Вопрос: Подсчитать количество строк заданной целочисленной матрицы N х N, являющихся перестановкой чисел 1, 2, ..., N (т. е. содержащих каждое из чисел 1, 2, ..., N ровно один раз).
Категория: школьный раздел
Ответы:
Var a:array[1..100,1..100] of integer;
i,j,flag,n,k:byte;
begin
randomize;
k:=0;
Writeln('vvedite n'); readln(n);
for i:=1 to n do
begin
for j:=1 to n do
begin
a[i,j]:=random(100)+1;
write(a[i,j],' ');
end;
Writeln;
end;
for i:=1 to n do
begin
flag:=0;
for j:=1 to n do
begin
if a[i,j]=a[i,j+1]
then flag:=1;
end;
if flag=1
then k:=k+1;
end;
Writeln(k);
readln;
end.
Вопрос: Дана строка, заканчивающаяся точкой. Подсчитать, сколько слов в строке.
Категория: школьный раздел
Ответы:
program stroki;
var s:string;
    k,i:integer;
begin write('Vvedite stroku:');
      readln(s);
      s:=' '+s;
      for i:=1 to length(s) do
        if s[i]=' ' then k:=k+1;
      writeln(k);
end.
Вопрос: Дана строка, содержащая английский текст. Найти количество слов, начинающихся с буквы «b».
Категория: школьный раздел
Ответы:
uses crt;
const pr: set of char=[' ','(',',','.',';',':','-'];
var s: string;
    i,k: byte;
begin
write('s='); readln(s);
if (s[1]='B') or (s[1]='b') then inc(k);
for i:=2 to length(s) do
    if ((s[i]='B') or (s[i]='b')) and (s[i-1] in pr) then inc(k);
writeln('Слов на B(b): ',k);
readln;
end.
Вопрос: Дана строка. Преобразовать ее, заменив звездочками все двоеточия (:), встречающиеся среди первых n/2 символов, и заменив точками все восклицательные знаки, встречающиеся среди символов, стоящих после n/2 символов. Здесь n - длина строки.
Категория: школьный раздел
Ответы:
var
  str: string;
  i,n: byte;
begin
  write('Введите строку: ');
  readln(str);
  n:=length(str);
  for i:=1 to n do
  begin
    if (i<n div 2)and(str[i]=':') then str[i]:='*';
    if (i>n div 2)and(str[i]='!') then str[i]:='.';
  end;
  writeln(str);
  readln;
end.
Вопрос: В строке удалить символ двоеточие (:) и подсчитать количество удаленных символов.
Категория: школьный раздел
Ответы:
var
  s:string;
  k:byte;
begin
  readln(s);
  k:=0;
  while pos(':',s)<>0 do
    begin
      delete(s,pos(':',s),1);
      k:=k+1;
    end;
  writeln(s);
  writeln('k=',k);
end.
Вопрос: Дана строка символов, среди которых есть одна открывающаяся и одна закрывающаяся скобки. Вывести на экран все символы, расположенные внутри этих скобок.
Категория: школьный раздел
Ответы:
var s:string;
    i:byte;
begin
 readln(s);
 for i:=1 to length(s) do
  if s[i]='(' then break;
 inc(i);
 while s[i]<>')' do
 begin
  write(s[i]);
  inc(i);
 end;
 writeln;
end.
Вопрос: Дана строка, содержащая текст. Найти длину самого короткого и самого длинного слов
Категория: школьный раздел
Ответы:
Var
  s:string;
  max,min,i,k:integer;
begin
write('Введите строку: ');
readln(s);
s:=s+' ';
for i:=1 to length(s) do
  begin
  if s[i]=' ' then
     begin
     if k>max then max:=k;
     if (k<min) or (min=0) then min:=k;
     k:=-1;
     end;
  k:=k+1;
  end;
writeln('Самое короткое: ',min,'; самое длиное: ',max);
end.
Вопрос: Дана строка, содержащая текст, заканчивающийся точкой. Вывести на экран все слова, содержащие три буквы. Если таких слов нет, то вывести сообщение об этом.
Категория: школьный раздел
Ответы:
program str;
uses crt;
var
   s: string;
   n,nsl,ksl,kol,i:byte;
begin
  writeln('Введите строку: ');
  readln(s);
  s:=' '+s;
  n:=length(s);
 
  for i:=1 to n do
  begin
      if (s[i]=' ') and (s[i+1]<>' ') and (s[i+1]<>'.') then
         nsl:=i+1;
 
      if (s[i]<>' ') and (s[i]<>'.') and ((s[i+1]='.') or (s[i+1]=' ')) then
      begin
         ksl:=i;
         if ((ksl-nsl)+1=3) then kol:=kol+1;
      end; 
  end;
  
  writeln('Слов из 3-х букв ',kol);
 
end.
Вопрос: Дана строка. Преобразовать ее, удалив каждый символ * и повторив дважды подряд каждый символ, отличный от *.
Категория: школьный раздел
Ответы:
uses crt;
var s: string;
    i: byte;
begin
write('s=');
readln(s);
for i:=length(s) downto 1 do
    if s[i]='*' then delete(s,i,1)
       else insert(s[i],s,i);
write('s=',s);
end.
Вопрос: Дана строка текста. Подсчитать количество букв «к» в последнем слове.
Категория: школьный раздел
Ответы:
var s : string;
   k, kol, i : integer;
begin
  Write('Введите строку : ');
  ReadLn(s);
    for i:=1 to length(s) do
if s[i]=' ' then k:=i;
for i:=k+1 to length(s) do
if s[i]='k' then inc(kol);
  WriteLn('В последнем слове буква "k" встречается ',kol,' раз.');
  ReadLn;
end.
Вопрос: Определить, сколько раз в тексте встречается заданное слово
Категория: школьный раздел
Ответы:
program IdWord;
Uses Crt;
var c, w : string;
    k : Integer;
begin
 ClrScr;
 Write('Vvedite stpoky: ->  ', c); ReadLn(c);
 Write('Vvedite slovo: ->  ', w); ReadLn(w);
 w := w + ' ';
 k := 0;
 While pos(w, c) > 0 do
  begin
   delete(c, 1, pos(w, c));
   k := k + 1;
  end;
 WriteLn('Kolichectvo slov v ctroke:  ', k);
 Readln
end.
Вопрос: Дана строка-предложение на английском языке. Преобразовать строку так, чтобы каждое слово начиналось с заглавной буквы
Категория: школьный раздел
Ответы:
program zzz;
uses crt;
const rb=['а'..'п','р'..'я','ё'];
function Up(c:char):char;
begin
if c in ['а'..'п'] then Up:=chr(ord(c)-32)
else if c in ['р'..'я'] then Up:=chr(ord(c)-80)
else if c='ё' then Up:='Ё';
end;
var s:string;
    i:byte;
begin
clrscr;
writeln('Bilo');
Readln (s);
for i:=1 to length(s) do
if (s[i] in rb)and((i=1)or(s[i-1]=' ')) then s[i]:=Up(s[i]);
writeln('Stalo ');
write(s);
readln
end.
Вопрос: Дана строка. Подсчитать, сколько различных символов встречается в ней. Вывести их на экран.
Категория: школьный раздел
Ответы:
var str,org:string;
    i:integer;
begin
  writeln('Введите строку : ');
  readln(str);
  org:='';
  for i:=1 to length(str) do
    if (pos(str[i],org)=0) then org:=org+str[i];
  
  writeln('Оригинальных символов : ', length(org));
  for i:=1 to length(org) do write(org[i],' ');
end.
Вопрос: Компания «Универ» заключила договор и получила в аренду землю с 01.07.2018г. Срок аренды земли составляет 50 лет. Договором аренды предусматривается бесплатная аренда в первые два года. По условиям договора арендатор производит ежегодные арендные платежи в сумме 600 000 руб. в год. Арендатор обязан произвести 48 платежей, первый платеж производится не позднее 01.06.2018г.
Категория: экономические
Ответы:
Вопрос: Дана строка. Подсчитать самую длинную последовательность подряд идущих букв «а».
Категория: школьный раздел
Ответы:
uses crt;
var i,sum,max:integer;
     s:string;
begin
 clrscr;
 writeln('Vvedite stroku ');
 readln(s);
 for i:=1 to length(s) do
sum:=0;
max:=0;
  if s[i]='a' then sum:=sum+1
   else 
    begin 
     if sum>max then max:=sum;
     sum:=0;
    end;
 writeln(max);
readln;
 
end.
Вопрос: Имеется строка, содержащая буквы латинского алфавита и цифры. Вывести на экран длину наибольшей последовательности цифр, идущих подряд.
Категория: школьный раздел
Ответы:
uses crt;
var s:string;
    i,l,max:integer;
    M:set of char;
    flag:boolean;
begin
  clrscr;
  writeln('Введите строку ...');
  readln(s);
  M:=['0'..'9'];
  flag:=false;
  i:=0;l:=0;max:=0;
  repeat
    inc(i);
    if s[i] in M then
    begin
      if flag=false then
      begin
        flag:=true;
        l:=1;
      end
      else inc(l);
    end
    else begin
   if flag then
   begin
     if max<l then max:=l;
     flag:=false;
   end
   end;
  until i=length(s);
  if l>max then max:=l;
  writeln(max);
  readln;
end.
Вопрос: Дана строка. Указать те слова, которые содержат хотя бы одну букву «к».
Категория: школьный раздел
Ответы:
Var s,s1:string;
Begin
    write('Строка: ');readln(s);
    s:=s+' ';
    While Pos(' ',s)>0 do
    Begin
      s1:=Copy(s,1,Pos(' ',s)-1);
      if Pos('k',s1)>0 then write(s1,' ');
      Delete(s,1,Pos(' ',s));
    End;
End.
Вопрос: Дана строка. Найти в ней те слова, которые начинаются и оканчиваются одной и той же буквой.
Категория: школьный раздел
Ответы:
const sn=[' ','.',',','!','?'];
 
var s,slovo:string;
    i:integer;
 
begin
  readln(s);
  slovo:='';
  if not (s[length(s)] in sn) then
    s:=s+' ';
  for i:=1 to length(s) do begin
    if not (s[i] in sn) then
      slovo:=slovo+s[i]
    else begin
      if slovo[1]=slovo[length(slovo)] then
        writeln(slovo);
      slovo:='';
    end;
  end;
  readln
end.
Вопрос: Строка содержит одно слово. Проверить, будет ли оно читаться одинаково справа налево и слева направо (т. е. является ли оно палиндромом).
Категория: школьный раздел
Ответы:
uses crt;
var
 s: string;
 i: integer;
 flag: boolean;
begin
 clrscr;
 write('Введите слово: ');
 readln(s);
 flag := true;
 for i := 1 to length(s) div 2 do
  if s[i] <> s[length(s) - i + 1] then
  begin
   flag := false;
   break;
  end;
 if flag then write('Палиндром') else write('Ни разу не палиндром');
 readln;
end.
Вопрос: В записке слова зашифрованы — каждое из них записано наоборот. Расшифровать сообщение.
Категория: школьный раздел
Ответы:
uses crt;
var s,sn,temp: string;
    i: byte;
begin
write('s='); readln(s);   //запрашиваем и считываем строку
temp:='';           //временная строка для перевернутого слова пуста
sn:='';             //строка для расшифрованной строки пока пуста
s:=s+' ';           //добавляем в конец строки пробел, чтобы не потерять последнее слово
for i:=1 to length(s) do       //в цикле с параметром перебираем элементы строки от первого до последнего
    if s[i] in ['A'..'Z','a'..'z','А'..'Я','а'..'я']         //если символ - это буква (то есть часть слова),
     then temp:=s[i]+temp      //записываем его в начало расшифровываемого слова (ведь известно, что слова записаны наоборот)
      else                       //иначе
          begin
          sn:=sn+temp+s[i];    //присоединяем перевернутое (читай, расшифрованное слово) в новую строку и добавляем знак препинания или пробел (что там нам попалось в строке)
          temp:='';            //очищаем временную строку для переворота следующего слова
          end;
writeln('s=',sn);              //выводим расшифровенную строку
readln;
end.
Вопрос: Дан текст. Написать программу, определяющую процентное отношение строчных и прописных букв к общему числу символов в нем.
Категория: школьный раздел
Ответы:
uses crt;
var
   s:string;
   i:longint;
   lit:byte;
begin
   clrscr;
   readln(s);
   for i:=1 to length(s) do
      if s[i] in ['a'..'z','а'..'я','ё','A'..'Z','А'..'Я','Ё'] then
         inc(lit);
   writeln('Отношение букв к длине текста: ',lit/length(s)*100,'%');
end.
Вопрос: Проверить, одинаковое ли число открывающихся и закрывающихся скобок в данной строке и правильно ли они расставлены, т. е. для каждой открывающей скобки есть соответствующая закрывающая скобка.
Категория: школьный раздел
Ответы:
uses crt;
var s: string;
    i,psi,k: integer;
begin
write ('Введите строку ');
readln (s);
for i:=1 to length (s) do
    if s[i]='(' then inc(k) else
       if s[i]=')' then dec(k);
if k=0 then writeln ('Скобки расставлены правильно') else
   if k=1 then writeln ('Лишняя открывающая скобка') else
      if k>1 then writeln ('Лишние открывающие скобки')else
         if k=-1 then writeln ('Лишняя закрывающая скобка') else
            writeln ('Лишние закрывающие скобки');
end.
Вопрос: Из заданной символьной строки выбрать те символы, которые встречаются в ней только один раз, в том порядке, в котором они встречаются в тексте.
Категория: школьный раздел
Ответы:
program m2;
uses Crt;
var s:String;
i,j,n,k:Integer;
f:Boolean;
begin
ClrScr;
Writeln('Введите строку:');
Readln(s);
n:=Length(s);
for i:=1 to n do
begin
f:=True;
for j:=1 to n do 
if (i<>j) and (s[i]=s[j]) then f:=False;
if f and (k=0) then Writeln('Символы,которые встречаются в строке один раз:');
if f then 
begin
Write(s[i],' '); 
inc(k);
end;
end;
if k=0 then Writeln('В строке нет символов которые встречаются всего один раз.');
Readln;
end.
Вопрос: Дан текст, состоящий из предложений, разделяемых точками. Напишите программу, производящую следующее форматирование: после каждой точки в конце предложения должен стоять хотя бы один пробел; первое слово в предложении должно начинаться с прописной буквы. 
Замечание. Текст может быть как на русском, так и на английском языке.
Категория: школьный раздел
Ответы:
uses crt;
function Up(c:char):char;{функция преобразования строчных букв в прописные}
begin
if c in ['a'..'z']then c:=UpCase(c){для латинских стандартная функция}
else if c in ['а'..'п'] then c:=chr(ord(c)-32){русские а-п}
else if c in ['р'..'я'] then c:=chr(ord(c)-80){русские р-я}
else if c='ё' then c:='Ё';
Up:=c;
end;
var s:string;
    i,j:byte;
begin
clrscr;
writeln('Введите текст из нескольких предложений, разделенных точками:');
readln(s);
s[1]:=Up(s[1]);{первая буква}
for i:=length(s)downto 1 do{идем с конца строки}
if s[i]='.' then{нашли точку}
 begin
  if s[i+1]<>' 'then{если после нее не пробел}
   begin
    s[i+1]:=Up(s[i+1]);{делаем букву прописной}
    insert(' ',s,i+1);{вставляем перед ней пробел}
   end
  else{если уже есть пробел}
   for j:=i+1 to length(s)do{идем по строке вперед, ищем где пробелы кончились
(их может быть несколько)}
   if s[j]<>' 'then{нашли первый не пробел}
    begin
     s[j]:=Up(s[j]);{делаем прописной}
     break;{выходим из цикла}
    end;
 end;
write(s);
readln
end.
Вопрос: Дана строка, состоящая из слов, разделенных пробелами. Напишите программу, удаляющую лишние пробелы. Пробел считается лишним, если он: 
стоит в начале строки; 
стоит в конце строки; 
следует за пробелом.
Категория: школьный раздел
Ответы:
var
  s: string;
begin
  write('Vvedite text: ');
  readln(s);
  while s[1]=' ' do
    delete(s,1,1);//в начале строки
  while s[length(s)]=' ' do
    delete(s,length(s),1);//в конце строки
  while pos('  ',s)>0 do
    delete(s,pos('  ',s),1);//в середине, в апострофах по 2 пробела
  writeln(s);
end.
Вопрос: Дана строка, состоящая из русских слов, разделенных пробелами (одним или несколькими). Вывести строку, содержащую эти же слова (разделенные одним пробелом), но расположенные в обратном порядке.
Категория: школьный раздел
Ответы:
program Project1;
 
const
  //Разделители слов.
  D = ['.', ',', ':', ';', '!', '?', '-', ' ', #9, #10, #13];
var
  S, SRes : String;
  i, Len, Pos1 : Integer;
begin
  repeat
    Writeln('Задайте строку:');
    Readln(S);
 
    Len := Length(S);
    SRes := '';
    Pos1 := 0;
    //Перебор символов строки в направлении справа-налево.
    for i := Len downto 1 do begin
      //Пропускаем разделители.
      if S[i] in D then Continue;
      //Отслеживаем конец слова.
      if (i = Len) or (S[i + 1] in D) then Pos1 := i;
      //Отслеживаем начало слова.
      if (i = 1) or (S[i - 1] in D) then begin
        //Добавление пробела.
        if SRes <> '' then SRes := Sres + ' ';
        //Добавляем слово к строке.
        SRes := SRes + Copy(S, i, Pos1 - i + 1);
      end;
    end;
 
    Writeln('Ответ:');
    Writeln(SRes);
 
    Writeln('Повторить - Enter. Выход - любой символ + Enter.');
    Readln(S);
  until S <> '';
end.
Вопрос: Составить программу преобразования натуральных чисел, записанных в римской нумерации, в десятичную систему счисления.
Категория: школьный раздел
Ответы:
program rim_arab;
uses crt;
var a:string;
    i,j:integer;
    b:array[1..50] of integer;
    s:longint;
begin
clrscr;
writeln('Rimskoe chislo');
readln(a);
for i:=1 to length(a) do
    begin
      if (a[i]<>'I') and (a[i]<>'V') and (a[i]<>'X')
      and (a[i]<>'L')and (a[i]<>'C') and (a[i]<>'D') and (a[i]<>'M')
      then halt;
      if a[i]='I'then b[i]:=1;
      if a[i]='V'then b[i]:=5;
      if a[i]='X'then b[i]:=10;
      if a[i]='L'then b[i]:=50;
      if a[i]='C'then b[i]:=100;
      if a[i]='D'then b[i]:=500;
      if a[i]='M'then b[i]:=1000;
    end;
s:=0;
for i:=1 to length(a) do
   begin
     s:=s+b[i];
     if(i>1)and(b[i-1]<b[i]) then s:=s-2*b[i-1];
   end;
write(s);
readln;
end.
Вопрос: а) Дана строка-предложение. Зашифровать ее, поместив вначале все символы, расположенные на четных местах, а затем, в обратном порядке, все символы, расположенные на нечетных местах. 
(Например, строка "Программа" превратится в "ргамамроП".) 
б) Запрограммировать решение обратной задачи (расшифровки).
Категория: школьный раздел
Ответы:
uses crt;
var s,sn: string;
    i,j,k: byte;
begin
write('s='); readln(s); sn:='';
i:=length(s); k:=0;
if length(s) mod 2=0 then j:=length(s) div 2
   else j:=length(s) div 2+1;
for i:=length(s) downto j do
    begin
    sn:=sn+s[i];
    if k<length(s) div 2 then
       begin
       inc(k);
       sn:=sn+s[k];
       end;
    end;
writeln(sn);
readln;
end.
Вопрос: Два шара массами 100 г и 200 г движутся навстречу друг к другу со скоростями 4м/с и 5м/с соответственно. С какой скоростью будут двигаться шары, если после соударения они движутся как единое целое?
Категория: школьный раздел
Ответы:
Вопрос: Из данного списка спортсменов получить данные о тех из них, кто занимается плаванием. Указать возраст, сколько лет они занимаются спортом.
Категория: школьный раздел
Ответы:
Program sportmans;
uses crt;
Type Sport=Record Family, discipline:string[20];
                  vozrast,letVsporte:integer;
     end;
var A:array [1..3] of sport;
 
    i,n,s:integer;
 
Begin Write ('Vvedite koli4estvo sportsmenov');
      Read (n);
      For i:=1 to n do
      Begin Writeln ('Vvedite dannie sportsmena');
            With A[i] do
                          begin
                                writeln ('Vvedite vozrast sportsmena');
                                readln (vozrast);
                                writeln ('Vvedite disciplinu');
                                readln (discipline);
                                writeln ('Vvedite koli4estvo let v sporte');
                                Readln (letVsporte);
                                Writeln ('Vvedite Family');
                                Readln (Family);
                                end;
                                end;
 
S:=0;
For i:=1 to n do
With a[i] do
If discipline = 'plavanie'
   then S:=S+1;
   Writeln (S);
 
End.
Вопрос: Из ассортимента конфет, выпускаемых кондитерской фабрикой, выбрать те, стоимость которых от 100 до 200 руб. за 1 кг. Указать срок их годности и номера магазинов, в которых они имеются в продаже.
Категория: школьный раздел
Ответы:
type konf=record
  name: string[45];
   cena:integer;
   god:integer;
   mag:integer;
end;
var kon: array [1..100] of konf;
   I,k,max: integer;
   a:array[1..100]of integer;
begin
   for I:=1 to 3 do
   begin
      writeln ('введите название');
      readln (kon[I].name);
      writeln ('введите цену');
      readln (kon[I].cena);
      writeln ('введите срок годности');
      readln (kon[I].god);
      writeln ('введите номер магазина');
      readln (kon[I].mag);
      end;
for i:=1 to 3 do
if (kon[I].cena>=100) and (kon[I].cena<=200) then begin
writeln(kon[I].name);
writeln(kon[I].god);
writeln(kon[I].mag);end;
readln;
end.
Вопрос: Получить список учеников музыкальной школы, которые учатся играть на скрипке. Указать также, сколько лет они занимаются музыкой и принимали ли участие в каких-либо конкурсах
Категория: школьный раздел
Ответы:
Program spisok;
Const n=2;
Type uch=Record
          fam:string[20];{фамилия}
          inctr:string[20];{инструмент}
          stag:integer;{стаж}
          konk:integer;{участие в конкурсах 0-НЕТ,1-ДА}
     end;
Var muz:array[1..n] of uch;{массив записей}
    i:integer;
BEGIN
     Writeln('Введите записи');
     For i:=1 to n do
          begin
               Writeln(i);
               With muz[i] do begin
                    Writeln('Фамилия ');
                    readln(fam);
                    Writeln('Инструмент ');
                    readln(inctr);
                    writeln('Cтаж');
                    readln(stag);
                    writeln('Участие в конкурсах (0-НЕТ,1-ДА) ');
                    readln(konk);
               end;
          end;
    Writeln('');
    For i:=1 to n do begin
      if muz[i].inctr='скрипка' then begin
        With muz[i] do begin
                    Writeln('Фамилия ',fam);
                    Writeln('Инструмент ',inctr);
                    writeln('Cтаж',stag);
                    writeln('Участие в конкурсах (0-НЕТ,1-ДА) ',konk);    
        end;
      end;
    end;
END.
Вопрос: Получить фамилии детей данного детского сада, которые родились в указанном месяце; вывести также их возраст и группу.
Категория: школьный раздел
Ответы:
uses crt;
const N=3; //количество детей
type
    FIO = record
    family  : string[20];   // фамилия
    name    : string[15];   // имя
end;
type
    DATE = record
    number  : byte;  // число
    month   : byte;  // месяц
    year    : integer;  // год
end;
type
    Voz = record
    Voz  : string[5];   // возраст
end;
type
    GR=record
    group : byte;  // группа
end;
type
    child=record
    childFIO   : FIO;
    childDATE  : DATE;
    childGR    : GR;
    childVoz    : Voz;
end;
 
var A :array[1..N] of child;
    i,k,j : byte;
begin
//**************ВВОД ДАННЫХ*********************************
for i:=1 to N do
begin
    write('Фамилия: '); readln(A[i].childFIO.family);
    write('Имя: '); readln(A[i].childFIO.name);
    write('Дата рождения: '); readln(A[i].childDATE.number, A[i].childDATE.month, A[i].childDATE.year);
    write('Возраст:');readln(A [i].childVoz.Voz);
    write('Группа: '); readln(A[i].childGR.group);
end;
clrscr;
//*************ВЫВОД ДАННЫХ*********************************
writeln('***************************************');
for i:=1 to N do
begin
    writeln('Фамилия: ', A[i].childFIO.family);
    writeln('Имя: ', A[i].childFIO.name);
    writeln('Дата рождения: ', A[i].childDATE.number,' ', A[i].childDATE.month,' ', A[i].childDATE.year);
    writeln ('Возраст:',A [i].childVoz.Voz);
    writeln('Группа: ', A[i].childGR.group);
writeln('***************************************');
end;
//дети которые родились в определенном месяце
write('месяц для поиска: '); readln(k);
j:=0;
for i:=1 to N do
    if k = A[i].childDATE.month then
    begin
    j:= j + 1;
    if j = 1 then writeln('дети которые родились в ',k,' месяце');
    writeln(j,') ', A[i].childFIO.family,',   ',2014-A[i].childDATE.year,' лет,   ',A[i].childGR.group,' группа' );
    end;
if j = 0 then writeln('детей которые родились в ',k,' месяце нет');
end.

program hgft;
type
   Sad=record
        Familija : String[30];
         Imja: String[20];
         God:integer;
         mesjac:integer;
         gruppa:  String;
   end;
   var
     a:array[1..100] of sad ;
    N,i,m,j:integer;
     begin
     writeln('Vvedite kolichestvodeetej');
     readln(n);
     For I:=1 to n do
     begin
      writeln('Dannye ',i, 'rebenka');
      writeln ('vvedite Familiju ');
      readln(a[i].Familija);
      writeln ('vvedite Imja');
      readln(a[i].Imja );
      writeln ('vvedite God rohjdeniaj');
      readln(a[i].god);
      writeln ('vvedite mesjac rojhdenija');
      readln(a[i].mesjac);
      writeln ('vvedite gruppu ');
      readln(a[i].gruppa );
     end;
 
     Writeln('VVedite nomer mesjaca');
     readln(m);
     For j:=1 to n do
     begin
      if a[i].mesjac=m then
      begin
      writeln(a[i].Familija,'  ',a[i].Imja,'  Gruppa:' ,a[i].gruppa,'   vozrast:',2010-a[i].god);
      end;
      readln;
     end;
 end.
Вопрос: Получить список тех учителей школы, которые преподают математику и информатику, указать стаж их работы и недельную нагрузку.
Категория: школьный раздел
Ответы:
Uses crt; 
 Type 
 book=Record 
 fam: String; 
 pred: String; 
 st: Byte; 
 nagr: Byte; 
 end; 
 Var 
 x: Array [1..20] of book; 
 i,n: Integer; 
 BEGIN 
 Clrscr; 
 Writeln('Введите кол-во учителей: '); Readln(n); 
 For i:=1 to n do 
 begin 
    Write('Фамилия учителя: '); Readln(x[i].fam); 
    Write('Предмет: '); Readln(x[i].pred); 
    Write('Стаж: '); Readln(x[i].st); 
    Write('Нагрузка: '); Readln(x[i].nagr); 
 end; 
 Writeln('Список тех учителей школы, которые преподают математику и информатику:'); 
 For i:=1 to n do 
 If (x[i].pred='Математика') or (x[i].pred='Информатика') Then 
 begin 
    Writeln(x[i].fam); 
    Writeln(x[i].st); 
    Writeln(x[i].nagr); 
    Writeln('--------'); 
 end; 
 Readln 
 END.
Вопрос: Получить анкетные данные учеников, участвовавших в олимпиаде по информатике и заработавших не менее 30 баллов.
Категория: школьный раздел
Ответы:
Program file11;
uses crt;
Type Student = record
      fio: string [5];
      school, group: integer;
      olimp: string[10]; ball:real;
end;
var
     f: file of student;
     name: string;
     uch: array[1..4] of student;
     i:integer;
     n:char;
     s1:student; ball:real; olimp: string[10];
begin
clrscr;
Writeln ('Задайте имя файла');
Readln (name);
Assign (f, name);
Rewrite (f);
Writeln ('Введите фамилию и инициалы студента');
Readln (s1.fio);
While s1.fio <> ' ' do
      Begin
           Writeln ('Введите номер школы и группы');
           Readln (s1.school, s1.group);
           writeln ('участвовал(вала) студент(ка) в олимпиаде по информатикe? ');
           readln (s1.olimp);
           writeln ('Сколько баллов набрал?');
           readln (s1.ball);
           write (f,s1);
           Writeln ('Введите фамилию и инициалы следующего студента ');
           Readln (name);
           s1.fio:=name;
      End;
      Writeln ('Файл создан');
         Close(f);reset(f);
      writeln (' Pokazat spisok ');
       while not Eof(f) do
       begin
             read (f,s1);   while(s1.ball)>=30 do begin
              olimp:='информатика';
 
                 begin
                      writeln ('ФИО: ',s1.fio);
                      writeln ('Школа: ',s1.school);
                      writeln ('Участвовал в олимпиаде: ',s1.olimp);
                      writeln ('Баллы: ',s1.ball);
                      writeln('---------------------');
                 end; end;
Close(f);
End;end.
Вопрос: Даны результаты переписи населения. Получить фамилии, имена и подсчитать общее число жителей, родившихся после 1990 года
Категория: школьный раздел
Ответы:
program ghost;
uses
     crt;
type
     man = Record
     fam: String;
     name: String;
     data: Integer;
     end;
var
    perepis: array[1..3] of man;
    i: Integer;
    count: Integer;
begin
    clrscr;
    perepis[1].fam := 'ivanov';
    perepis[1].name := 'ivan';
    perepis[1].data := 1990;
    perepis[2].fam := 'petrov';
    perepis[2].name := 'petr';
    perepis[2].data := 1991;
    perepis[3].fam := 'sidorov';
    perepis[3].name := 'sidr';
    perepis[3].data := 1992;
    count := 0;
    for i := 1 to 3 do
        if (perepis[i].data = 1990) then
           Inc(count);
    for i := 1 to 3 do
    begin
         write('famaly: ', perepis[i].fam);
         writeln;
         write('name: ', perepis[i].name);
         writeln;
         write('data: ', perepis[i].data);
         writeln;
         writeln('_____');
    end;
    writeln('count: ', count);
    readkey;
end.
Вопрос: В сведениях об экспортируемых товарах указывается наименование товара, страна, импортирующая товар, и объем поставляемой партии в штуках. Составить список стран, в которые экспортируется данный товар, и общий объем его экспорта
Категория: школьный раздел
Ответы:
type
tovar=record
name: string[20];
country:string[20];
v:integer;
end;
 
var
j, volume, vv, code,n ,i:integer;
s, t, t1 :string[20];
d :array[1..5] of tovar;
f :text;    l:tovar;
begin
assign(f, 'input.txt');
rewrite(f);
 
//создание
write('Введите количество товаров: ');
 readln(n);
 writeln('Введите данные о товарах');
 for i:=1 to n do
 begin
 writeln(i,' товар');
 with l do
  begin
   write('Наименование: '); readln(name);
   write('Страна: '); readln(country);
   write('Обьем: '); readln(v);
   write(f,s);
  end;
  end;
 
 
 
reset(f);
volume := 0;
writeln('Введите наименование товара: '); readln(s);
writeln('Данный товар экспортируется с следующие страны: ');
j := 1;
while not eof(f) do begin
readln(f, t); d[j].name := t;
readln(f, t1); d[j].country := t1;
readln(f, vv); d[j].v := vv;
if d[j].name = s then begin write(d[j].country, ' '); volume := volume + d[j].v end;
j := j + 1;
end;
writeln;
writeln('Общий объем экспорта товара = ', volume);
close(f);
end.
Вопрос: Сведения о сотрудниках включают: фамилию, имя, отчество, дату рождения, полученное образование, домашний адрес, профессию. Получить ФИО (фамилию, имя, отчество) всех сотрудников с высшим образованием. Выдать сведения о сотрудниках, имеющих данную профессию и родившихся не раньше указанной даты.
Категория: школьный раздел
Ответы:
uses
  crt;
 
type
  str40 = string[40];
  str30 = string[30];
  str15 = string[15];
  sluzh = record
    im: str40;
    fam: str40;
    ot: str40;
    rojdenia: str15;
    obr:str40;
    adres: str30;
    sp: str15;
  end;
 
Var
  a: array [1..100] of sluzh;
  sp: str15;
  k : integer;
  i,n : integer;
Begin
  Clrscr;
  {specialnost:=sp;}
  k:=0;
  write ('Введите количество сотрудников: ');
  readln(n);
  for i:=1 to n do
    begin
      writeln('Сотрудник №: ', i, ':');
      write ('Введите имя: ');
      readln(a[i].im);
      write ('Введите фамилию: ');
      readln(a[i].fam);
      write ('Введите отчество: ');
      readln(a[i].ot);
      write ('Введите адрес: ');
      readln(a[i].adres);
      write ('Введите дату рождения: ');
      readln(a[i].rojdenia);
      write ('Введите профессию: ');
      readln(a[i].sp);
      write ('Введите образование: ');
      readln(a[i].obr);
      writeln;
  end;
  for i:=1 to n do
    if a[i].obr='высшее' then
    begin
      writeln (a[i].im,' ',a[i].obr);
    end;
  writeln;
  write ('Введите профессию для поиска: ');
  readln(sp);
  for i:=1 to n do
    if sp= a[i].sp then
    begin
      writeln (a[i].fam,' ',a[i].sp);
    inc(k);
  end;
  Writeln ('Количество найденных сотрудников: ',k);
  readln;
end.
Вопрос: При поступлении в университет лица, получившие оценку «неудовлетворительно» на первом экзамене, ко второму экзамену не допускаются. Считая фамилии абитуриентов и их оценки после первого экзамена исходными данными, составить список абитуриентов, допущенных ко второму экзамену
Категория: школьный раздел
Ответы:
type zap=array [1..100] of record
name:string[20];
mark:0..5;
end;
var p:zap;
i,N:integer;
c:char;
begin
readln(N); {Количество}
for i:=1 to N do
begin
p[i].name:=' ';
repeat
read(c);
p[i].name:=p[i].name+c;
until c=' ';
read(p[i].mark);
end;
for i:=1 to N do
begin
if pi[i].mark>2 then writeln(p[i].name,' ',p[i].mark)
else continue;
end;
readln;
end.
Вопрос: Имеются сведения о датах рождения сотрудников учреждения. 
а) Определить самого молодого сотрудника. 
б) Определить самого старшего сотрудника. 
в) Получить список всех сотрудников, родившихся весной.
Категория: школьный раздел
Ответы:
а) Определить самого молодого сотрудника. 
const mi = 20;
type chel = record
              family: string; //фамилия
              age: integer    //возраст
            end;
var i, kol, min: integer;
    ch: array [1..mi] of chel;
Begin
  //ввод количества сотрудников c проверкой диапазона
  repeat
    write('Количество сотрудников (1..', mi, ')? ');
    readln(kol)
  until kol in [1..mi];
  //ввод информации о сотрудниках
  for i := 1 to kol do
    begin
      writeln('Сотрудник ',i);
      write('Фамилия: ');
      readln(ch[i].family);
      write('Возраст: ');
      readln(ch[i].age)
    end;
  //определяем младшего
  min := 1; //будем пока младшим считать самого первого
  //цикл по остальным сотрудникам, если находится моложе, считаем его младшим
  for i := 2 to kol do if ch[i].age < ch[min].age then min := i;
  write('Младший среди сотрудников: ', ch[min].family);
  readln
End.
Вопрос: Вычислить средний балл учеников класса, если известны оценки каждого ученика по математике, русскому языку и физике. Получить список учеников, имеющих средний балл выше среднего в классе.
Категория: школьный раздел
Ответы:
program lab100301;
uses crt;
type
  tablica=record
  name:string[10];
  sred:real;
  rus,math,fiz:byte;
  end;
var
  a:tablica;
  mas:array[1..30] of tablica;
  s:real; n:integer;
  i:integer;
begin
  clrscr;
  writeln('введите количество учеников ');
  readln(n);
  for i:=1 to n do
    with mas[i] do
    begin
      write('фамилия ',i,'-го ученика : '); readln(name);
      write('русский язык: '); readln(rus);
      write('математика : '); readln(math);
      write('физика : '); readln(fiz);
      sred:=(rus+math+fiz)/3;
      s := s + sred;
      writeln('Средний бал ученика: ' , name,'  ',  sred:3:1);
    end;
 
  s := s / n;
  writeln('Обший средний бал: ',s);
  writeln('');
  writeln('ученики чей средний бал выше среднего ');
  writeln('');
  writeln(' ________________________ ');
  writeln('| фамилия  |средний балл |');
  writeln(' ------------------------ ');
  for i:=1 to n do
    with mas[i] do
      if mas[i].sred>s then
        begin
          write('|',name:9,'|');
          writeln(sred:14:2,'|');
        end;
  writeln(' --------------------------');
  readkey;
end.